diff options
112 files changed, 2021 insertions, 1235 deletions
diff --git a/.circleci/config.yml b/.circleci/config.yml deleted file mode 100644 index adab42c622..0000000000 --- a/.circleci/config.yml +++ /dev/null @@ -1,202 +0,0 @@ -# This file used to contain configuration to also build documentation and CoqIDE, -# run the test-suite and the validate targets, -# including with 32-bits architecture or bleeding-edge compiler. - -defaults: - params: ¶ms - # Following parameters are used in Coq CircleCI Job (using yaml - # reference syntax) - working_directory: ~/coq - docker: - - image: $CI_REGISTRY_IMAGE:$CACHEKEY - - environment: &envvars - CACHEKEY: "bionic_coq-V2018-07-11-V2" - CI_REGISTRY_IMAGE: registry.gitlab.com/coq/coq - -version: 2 - -before_script: &before_script - name: Setup OPAM Switch - command: | - echo export TERM=xterm >> ~/.profile - source ~/.profile - echo . ~/.profile >> $BASH_ENV - printenv | sort - opam switch "$COMPILER" - opam config list - opam list - -.build-template: &build-template - <<: *params - steps: - - checkout - - run: *before_script - - run: &build-clean - name: Clean - command: | - make clean # ensure that `make clean` works on a fresh clone - - run: &build-configure - name: Configure - command: | - ./configure -local -native-compiler ${NATIVE_COMP} -coqide no - - run: &build-build - name: Build - command: | - make -j ${NJOBS} byte - make -j ${NJOBS} - make test-suite/misc/universes/all_stdlib.v - - persist_to_workspace: - root: &workspace ~/ - paths: - - coq/ - - environment: - <<: *envvars - NATIVE_COMP: "yes" - -.ci-template: &ci-template - <<: *params - steps: - - run: *before_script - - attach_workspace: &attach_workspace - at: *workspace - - - run: - name: Test - command: | - dev/ci/ci-wrapper.sh ${CIRCLE_JOB} - - persist_to_workspace: - root: *workspace - paths: - - coq/ - environment: *envvars - -# Defines individual jobs, see the workflows section below for job orchestration -jobs: - - # Build and prepare test environment - build: *build-template - - bignums: - <<: *ci-template - - color: - <<: *ci-template - - compcert: - <<: *ci-template - - coq-dpdgraph: - <<: *ci-template - - coquelicot: - <<: *ci-template - - cross-crypto: - <<: *ci-template - - elpi: - <<: *ci-template - - equations: - <<: *ci-template - - geocoq: - <<: *ci-template - - fcsl-pcm: - <<: *ci-template - - fiat-crypto: - <<: *ci-template - - fiat-parsers: - <<: *ci-template - - flocq: - <<: *ci-template - - math-classes: - <<: *ci-template - - corn: - <<: *ci-template - - formal-topology: - <<: *ci-template - - hott: - <<: *ci-template - - iris-lambda-rust: - <<: *ci-template - - ltac2: - <<: *ci-template - - math-comp: - <<: *ci-template - - mtac2: - <<: *ci-template - - pidetop: - <<: *ci-template - - sf: - <<: *ci-template - - unimath: - <<: *ci-template - - vst: - <<: *ci-template - -workflows: - version: 2 - - # Run on each push - main: - jobs: - - build - - - bignums: &req-main - requires: - - build - - color: - requires: - - build - - bignums - # - compcert: *req-main - # - coq-dpdgraph: *req-main - # - coquelicot: *req-main - # - cross-crypto: *req-main - # - elpi: *req-main - # - equations: *req-main - # - geocoq: *req-main - # - fcsl-pcm: *req-main - # - fiat-crypto: *req-main - # - fiat-parsers: *req-main - # - flocq: *req-main - - math-classes: - requires: - - build - - bignums - # - mtac2: *req-main - - corn: - requires: - - build - - math-classes - - formal-topology: - requires: - - build - - corn - # - hott: *req-main - # - iris-lambda-rust: *req-main - # - ltac2: *req-main - # - math-comp: *req-main - # - pidetop: *req-main - # - sf: *req-main - # - unimath: *req-main - # - vst: *req-main diff --git a/.github/CODEOWNERS b/.github/CODEOWNERS index 384e46723a..20d49e675f 100644 --- a/.github/CODEOWNERS +++ b/.github/CODEOWNERS @@ -9,7 +9,6 @@ ########## CI infrastructure ########## /dev/ci/ @coq/ci-maintainers -/.circleci/ @coq/ci-maintainers /.travis.yml @coq/ci-maintainers /.gitlab-ci.yml @coq/ci-maintainers @@ -5,6 +5,11 @@ Kernel - Mutually defined records are now supported. +Notations + +- New support for autonomous grammars of terms, called "custom + entries" (see chapter "Syntax extensions" of the reference manual). + Tactics - Added toplevel goal selector ! which expects a single focused goal. @@ -132,10 +137,18 @@ Display diffs between proof steps - coqtop and coqide can now highlight the differences between proof steps in color. This can be enabled from the command line or the - "Set Diffs on|off|removed" command. Please see the documentation for + `Set Diffs "on"|"off"|"removed"` command. Please see the documentation for details. Showing diffs in Proof General requires small changes to PG (under discussion). +Notations + +- Added `++` infix for `VectorDef.append`. + Note that this might cause incompatibilities if you have, e.g., list_scope + and vector_scope both open with vector_scope on top, and expect `++` to + refer to `app`. + Solution: wrap `_ ++ _` in `(_ ++ _)%list` (or whichever scope you want). + Changes from 8.8.0 to 8.8.1 =========================== @@ -3,7 +3,6 @@ [](https://gitlab.com/coq/coq/commits/master) [](https://travis-ci.org/coq/coq/builds) [](https://ci.appveyor.com/project/coq/coq/branch/master) -[](https://circleci.com/gh/coq/workflows/coq/tree/master) [](https://gitter.im/coq/coq) [](https://doi.org/10.5281/zenodo.1003420) diff --git a/coqpp/coqpp_main.ml b/coqpp/coqpp_main.ml index e76a1e9ed8..fd425ef4ff 100644 --- a/coqpp/coqpp_main.ml +++ b/coqpp/coqpp_main.ml @@ -326,10 +326,14 @@ let print_ast fmt ext = end +let declare_plugin fmt name = + fprintf fmt "let %s = \"%s\"@\n" plugin_name name; + fprintf fmt "let _ = Mltop.add_known_module %s@\n" plugin_name + let pr_ast fmt = function | Code s -> fprintf fmt "%s@\n" s.code | Comment s -> fprintf fmt "%s@\n" s -| DeclarePlugin name -> fprintf fmt "let %s = \"%s\"@\n" plugin_name name +| DeclarePlugin name -> declare_plugin fmt name | GramExt gram -> fprintf fmt "%a@\n" GramExt.print_ast gram | VernacExt -> fprintf fmt "VERNACEXT@\n" | TacticExt tac -> fprintf fmt "%a@\n" TacticExt.print_ast tac diff --git a/dev/ci/README.md b/dev/ci/README.md index 45176581cd..43d680af61 100644 --- a/dev/ci/README.md +++ b/dev/ci/README.md @@ -75,9 +75,6 @@ We are currently running tests on the following platforms: camlp5, and with warnings as errors; it runs the test-suite and tests the compilation of several external developments. -- Circle CI runs tests that are redundant with GitLab CI and may be removed - eventually. - - Travis CI is used to test the compilation of Coq and run the test-suite on macOS. It also runs a linter that checks whitespace discipline. A [pre-commit hook](../tools/pre-commit) is automatically installed by @@ -165,8 +162,7 @@ automatically built and uploaded to your GitLab registry, and is loaded by subsequent jobs. **IMPORTANT**: When updating Coq's CI docker image, you must modify -the `CACHEKEY` variable in [`.gitlab-ci.yml`](../../.gitlab-ci.yml), -[`.circleci/config.yml`](../../.circleci/config.yml), +the `CACHEKEY` variable in [`.gitlab-ci.yml`](../../.gitlab-ci.yml) and [`Dockerfile`](docker/bionic_coq/Dockerfile) The Docker building job reuses the uploaded image if it is available, diff --git a/dev/ci/ci-common.sh b/dev/ci/ci-common.sh index a68cd0933e..9259a6e0c8 100644 --- a/dev/ci/ci-common.sh +++ b/dev/ci/ci-common.sh @@ -20,10 +20,6 @@ else then export CI_PULL_REQUEST="$TRAVIS_PULL_REQUEST" export CI_BRANCH="$TRAVIS_BRANCH" - elif [ -n "${CIRCLECI}" ]; - then - export CI_PULL_REQUEST="$CIRCLE_PR_NUMBER" - export CI_BRANCH="$CIRCLE_BRANCH" else # assume local CI_BRANCH="$(git rev-parse --abbrev-ref HEAD)" export CI_BRANCH diff --git a/doc/sphinx/README.rst b/doc/sphinx/README.rst index 32de15ee31..1643baf0e8 100644 --- a/doc/sphinx/README.rst +++ b/doc/sphinx/README.rst @@ -239,6 +239,9 @@ In addition to the objects above, the ``coqrst`` Sphinx plugin defines the follo http://docutils.sourceforge.net/docs/ref/rst/directives.html#generic-admonition for more details. + Optionally, any text immediately following the ``.. example::`` header is + used as the example's title. + Example:: .. example:: Adding a hint to a database diff --git a/doc/sphinx/addendum/canonical-structures.rst b/doc/sphinx/addendum/canonical-structures.rst index 6843e9eaa1..3af3115a59 100644 --- a/doc/sphinx/addendum/canonical-structures.rst +++ b/doc/sphinx/addendum/canonical-structures.rst @@ -6,14 +6,14 @@ Canonical Structures :Authors: Assia Mahboubi and Enrico Tassi -This chapter explains the basics of Canonical Structure and how they can be used +This chapter explains the basics of canonical structures and how they can be used to overload notations and build a hierarchy of algebraic structures. The examples are taken from :cite:`CSwcu`. We invite the interested reader to refer to this paper for all the details that are omitted here for brevity. The interested reader shall also find in :cite:`CSlessadhoc` a detailed description -of another, complementary, use of Canonical Structures: advanced proof search. +of another, complementary, use of canonical structures: advanced proof search. This latter papers also presents many techniques one can employ to tune the -inference of Canonical Structures. +inference of canonical structures. Notation overloading @@ -38,21 +38,21 @@ of the terms that are compared. End theory. End EQ. -We use Coq modules as name spaces. This allows us to follow the same +We use Coq modules as namespaces. This allows us to follow the same pattern and naming convention for the rest of the chapter. The base -name space contains the definitions of the algebraic structure. To +namespace contains the definitions of the algebraic structure. To keep the example small, the algebraic structure ``EQ.type`` we are defining is very simplistic, and characterizes terms on which a binary relation is defined, without requiring such relation to validate any property. The inner theory module contains the overloaded notation ``==`` -and will eventually contain lemmas holding on all the instances of the +and will eventually contain lemmas holding all the instances of the algebraic structure (in this case there are no lemmas). Note that in practice the user may want to declare ``EQ.obj`` as a coercion, but we will not do that here. The following line tests that, when we assume a type ``e`` that is in -theEQ class, then we can relates two of its objects with ``==``. +theEQ class, we can relate two of its objects with ``==``. .. coqtop:: all @@ -312,7 +312,7 @@ The following script registers an ``LEQ`` class for ``nat`` and for the type constructor ``*``. It also tests that they work as expected. Unfortunately, these declarations are very verbose. In the following -subsection we show how to make these declaration more compact. +subsection we show how to make them more compact. .. coqtop:: all @@ -385,7 +385,7 @@ with message "T is not an EQ.type"”. The other utilities are used to ask |Coq| to solve a specific unification problem, that will in turn require the inference of some canonical structures. -They are explained in mode details in :cite:`CSwcu`. +They are explained in more details in :cite:`CSwcu`. We now have all we need to create a compact “packager” to declare instances of the ``LEQ`` class. diff --git a/doc/sphinx/addendum/extraction.rst b/doc/sphinx/addendum/extraction.rst index cb93d48a41..8c1eacf085 100644 --- a/doc/sphinx/addendum/extraction.rst +++ b/doc/sphinx/addendum/extraction.rst @@ -116,13 +116,13 @@ be optimized in order to be efficient (for instance, when using induction principles we do not want to compute all the recursive calls but only the needed ones). So the extraction mechanism provides an automatic optimization routine that will be called each time the user -want to generate |OCaml| programs. The optimizations can be split in two +wants to generate an |OCaml| program. The optimizations can be split in two groups: the type-preserving ones (essentially constant inlining and reductions) and the non type-preserving ones (some function abstractions of dummy types are removed when it is deemed safe in order to have more elegant types). Therefore some constants may not appear in the resulting monolithic |OCaml| program. In the case of modular extraction, -even if some inlining is done, the inlined constant are nevertheless +even if some inlining is done, the inlined constants are nevertheless printed, to ensure session-independent programs. Concerning Haskell, type-preserving optimizations are less useful @@ -185,7 +185,7 @@ The type-preserving optimizations are controlled by the following |Coq| options: **Inlining and printing of a constant declaration:** -A user can explicitly ask for a constant to be extracted by two means: +The user can explicitly ask for a constant to be extracted by two means: * by mentioning it on the extraction command line @@ -224,19 +224,18 @@ principles of extraction (logical parts and types). When an actual extraction takes place, an error is normally raised if the :cmd:`Extraction Implicit` declarations cannot be honored, that is -if any of the implicited variables still occurs in the final code. +if any of the implicit arguments still occurs in the final code. This behavior can be relaxed via the following option: .. opt:: Extraction SafeImplicits Default is on. When this option is off, a warning is emitted - instead of an error if some implicited variables still occur in the + instead of an error if some implicit arguments still occur in the final code of an extraction. This way, the extracted code may be obtained nonetheless and reviewed manually to locate the source of the issue - (in the code, some comments mark the location of these remaining - implicited variables). + (in the code, some comments mark the location of these remaining implicit arguments). Note that this extracted code might not compile or run properly, - depending of the use of these remaining implicited variables. + depending of the use of these remaining implicit arguments. Realizing axioms ~~~~~~~~~~~~~~~~ @@ -296,7 +295,7 @@ The number of type variables is checked by the system. For example: Realizing an axiom via :cmd:`Extract Constant` is only useful in the case of an informative axiom (of sort ``Type`` or ``Set``). A logical axiom -have no computational content and hence will not appears in extracted +has no computational content and hence will not appear in extracted terms. But a warning is nonetheless issued if extraction encounters a logical axiom. This warning reminds user that inconsistent logical axioms may lead to incorrect or non-terminating extracted terms. @@ -312,7 +311,7 @@ Realizing inductive types The system also provides a mechanism to specify ML terms for inductive types and constructors. For instance, the user may want to use the ML -native boolean type instead of |Coq| one. The syntax is the following: +native boolean type instead of the |Coq| one. The syntax is the following: .. cmd:: Extract Inductive @qualid => @string [ {+ @string } ] @@ -332,10 +331,10 @@ native boolean type instead of |Coq| one. The syntax is the following: branches in functional form, and then the inductive element to destruct. For instance, the match branch ``| S n => foo`` gives the functional form ``(fun n -> foo)``. Note that a constructor with no - argument is considered to have one unit argument, in order to block + arguments is considered to have one unit argument, in order to block early evaluation of the branch: ``| O => bar`` leads to the functional form ``(fun () -> bar)``. For instance, when extracting ``nat`` - into |OCaml| ``int``, the code to provide has type: + into |OCaml| ``int``, the code to be provided has type: ``(unit->'a)->(int->'a)->int->'a``. .. caution:: As for :cmd:`Extract Constant`, this command should be used with care: @@ -371,7 +370,7 @@ Typical examples are the following: When extracting to |OCaml|, if an inductive constructor or type has arity 2 and the corresponding string is enclosed by parentheses, and the string meets |OCaml|'s lexical criteria for an infix symbol, then the rest of the string is - used as infix constructor or type. + used as an infix constructor or type. .. coqtop:: in @@ -389,7 +388,7 @@ Avoiding conflicts with existing filenames ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ When using :cmd:`Extraction Library`, the names of the extracted files -directly depends from the names of the |Coq| files. It may happen that +directly depend on the names of the |Coq| files. It may happen that these filenames are in conflict with already existing files, either in the standard library of the target language or in other code that is meant to be linked with the extracted code. @@ -475,17 +474,18 @@ type-checker without any ``Obj.magic`` (see examples below). Some examples ------------- -We present here two examples of extractions, taken from the -|Coq| Standard Library. We choose |OCaml| as target language, -but all can be done in the other dialects with slight modifications. +We present here two examples of extraction, taken from the +|Coq| Standard Library. We choose |OCaml| as the target language, +but everything, with slight modifications, can also be done in the +other languages supported by extraction. We then indicate where to find other examples and tests of extraction. A detailed example: Euclidean division ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ The file ``Euclid`` contains the proof of Euclidean division. -The natural numbers used there are unary integers of type ``nat``, -defined by two constructors ``O`` and ``S``. +The natural numbers used here are unary, represented by the type``nat``, +which is defined by two constructors ``O`` and ``S``. This module contains a theorem ``eucl_dev``, whose type is:: forall b:nat, b > 0 -> forall a:nat, diveucl a b @@ -579,7 +579,7 @@ extraction test: * ``stalmarck`` : https://github.com/coq-contribs/stalmarck Note that ``continuations`` and ``multiplier`` are a bit particular. They are -examples of developments where ``Obj.magic`` are needed. This is -probably due to an heavy use of impredicativity. After compilation, those +examples of developments where ``Obj.magic`` is needed. This is +probably due to a heavy use of impredicativity. After compilation, those two examples run nonetheless, thanks to the correction of the extraction :cite:`Let02`. diff --git a/doc/sphinx/addendum/implicit-coercions.rst b/doc/sphinx/addendum/implicit-coercions.rst index 09faa06765..f134022eb6 100644 --- a/doc/sphinx/addendum/implicit-coercions.rst +++ b/doc/sphinx/addendum/implicit-coercions.rst @@ -31,7 +31,7 @@ A class with `n` parameters is any defined name with a type :g:`forall (x₁:A₁)..(xₙ:Aₙ),s` where ``s`` is a sort. Thus a class with parameters is considered as a single class and not as a family of classes. An object of a class ``C`` is any term of type :g:`C t₁ .. tₙ`. -In addition to these user-classes, we have two abstract classes: +In addition to these user-defined classes, we have two built-in classes: * ``Sortclass``, the class of sorts; its objects are the terms whose type is a @@ -50,11 +50,11 @@ Formally, the syntax of a classes is defined as: Coercions --------- -A name ``f`` can be declared as a coercion between a source user-class +A name ``f`` can be declared as a coercion between a source user-defined class ``C`` with `n` parameters and a target class ``D`` if one of these conditions holds: - * ``D`` is a user-class, then the type of ``f`` must have the form + * ``D`` is a user-defined class, then the type of ``f`` must have the form :g:`forall (x₁:A₁)..(xₙ:Aₙ)(y:C x₁..xₙ), D u₁..uₘ` where `m` is the number of parameters of ``D``. * ``D`` is ``Funclass``, then the type of ``f`` must have the form @@ -65,8 +65,8 @@ conditions holds: We then write :g:`f : C >-> D`. The restriction on the type of coercions is called *the uniform inheritance condition*. -.. note:: The abstract class ``Sortclass`` can be used as a source class, but - the abstract class ``Funclass`` cannot. +.. note:: The built-in class ``Sortclass`` can be used as a source class, but + the built-in class ``Funclass`` cannot. To coerce an object :g:`t:C t₁..tₙ` of ``C`` towards ``D``, we have to apply the coercion ``f`` to it; the obtained term :g:`f t₁..tₙ t` is @@ -95,7 +95,7 @@ We can now declare ``f`` as coercion from ``C'`` to ``D``, since we can The identity coercions have a special status: to coerce an object :g:`t:C' t₁..tₖ` -of ``C'`` towards ``C``, we does not have to insert explicitly ``Id_C'_C`` +of ``C'`` towards ``C``, we do not have to insert explicitly ``Id_C'_C`` since :g:`Id_C'_C t₁..tₖ t` is convertible with ``t``. However we "rewrite" the type of ``t`` to become an object of ``C``; in this case, it becomes :g:`C uₙ'..uₖ'` where each ``uᵢ'`` is the result of the @@ -121,7 +121,7 @@ by the coercions ``f₁..fₖ``. The application of a coercion path to a term consists of the successive application of its coercions. -Declaration of Coercions +Declaring Coercions ------------------------- .. cmd:: Coercion @qualid : @class >-> @class @@ -140,8 +140,8 @@ Declaration of Coercions .. warn:: Ambiguous path. - When the coercion :token:`qualid` is added to the inheritance graph, non - valid coercion paths are ignored; they are signaled by a warning + When the coercion :token:`qualid` is added to the inheritance graph, + invalid coercion paths are ignored; they are signaled by a warning displaying these paths of the form :g:`[f₁;..;fₙ] : C >-> D`. .. cmdv:: Local Coercion @qualid : @class >-> @class @@ -215,7 +215,7 @@ declaration, this constructor is declared as a coercion. .. cmdv:: Local Identity Coercion @ident : @ident >-> @ident - Idem but locally to the current section. + Same as ``Identity Coercion`` but locally to the current section. .. cmdv:: SubClass @ident := @type :name: SubClass @@ -319,7 +319,7 @@ Coercions and Modules Since |Coq| version 8.3, the coercions present in a module are activated only when the module is explicitly imported. Formerly, the coercions - were activated as soon as the module was required, whatever it was + were activated as soon as the module was required, whether it was imported or not. This option makes it possible to recover the behavior of the versions of @@ -387,8 +387,8 @@ We give now an example using identity coercions. In the case of functional arguments, we use the monotonic rule of -sub-typing. Approximatively, to coerce :g:`t:forall x:A,B` towards -:g:`forall x:A',B'`, one have to coerce ``A'`` towards ``A`` and ``B`` +sub-typing. To coerce :g:`t : forall x : A, B` towards +:g:`forall x : A', B'`, we have to coerce ``A'`` towards ``A`` and ``B`` towards ``B'``. An example is given below: .. coqtop:: all @@ -424,8 +424,8 @@ replaced by ``x:A'`` where ``A'`` is the result of the application to ``Sortclass`` if it exists. This case occurs in the abstraction :g:`fun x:A => t`, universal quantification :g:`forall x:A,B`, global variables and parameters of (co-)inductive definitions and -functions. In :g:`forall x:A,B`, such a coercion path may be applied -to ``B`` also if necessary. +functions. In :g:`forall x:A,B`, such a coercion path may also be applied +to ``B`` if necessary. .. coqtop:: all diff --git a/doc/sphinx/addendum/miscellaneous-extensions.rst b/doc/sphinx/addendum/miscellaneous-extensions.rst index b6c35d8fa7..0f2d35d044 100644 --- a/doc/sphinx/addendum/miscellaneous-extensions.rst +++ b/doc/sphinx/addendum/miscellaneous-extensions.rst @@ -32,6 +32,7 @@ When the proof ends two constants are defined: ends with ``Qed``, and transparent if the proof ends with ``Defined``. .. example:: + .. coqtop:: all Require Coq.derive.Derive. diff --git a/doc/sphinx/addendum/program.rst b/doc/sphinx/addendum/program.rst index b685e68e43..28fe68d78d 100644 --- a/doc/sphinx/addendum/program.rst +++ b/doc/sphinx/addendum/program.rst @@ -38,12 +38,12 @@ obligations which need to be resolved to create the final term. Elaborating programs --------------------- -The main difference from |Coq| is that an object in a type T : Set can -be considered as an object of type { x : T | P} for any wellformed P : -Prop. If we go from T to the subset of T verifying property P, we must -prove that the object under consideration verifies it. Russell will -generate an obligation for every such coercion. In the other -direction, Russell will automatically insert a projection. +The main difference from |Coq| is that an object in a type :g:`T : Set` can +be considered as an object of type :g:`{x : T | P}` for any well-formed +:g:`P : Prop`. If we go from :g:`T` to the subset of :g:`T` verifying property +:g:`P`, we must prove that the object under consideration verifies it. Russell +will generate an obligation for every such coercion. In the other direction, +Russell will automatically insert a projection. Another distinction is the treatment of pattern-matching. Apart from the following differences, it is equivalent to the standard match @@ -67,7 +67,7 @@ operation (see :ref:`extendedpatternmatching`). (match x as y return (x = y -> _) with | 0 => fun H : x = 0 -> t | S n => fun H : x = S n -> u - end) (eq_refl n). + end) (eq_refl x). This permits to get the proper equalities in the context of proof obligations inside clauses, without which reasoning is very limited. @@ -75,7 +75,7 @@ operation (see :ref:`extendedpatternmatching`). + Generation of inequalities. If a pattern intersects with a previous one, an inequality is added in the context of the second branch. See for example the definition of div2 below, where the second branch is - typed in a context where ∀ p, _ <> S (S p). + typed in a context where :g:`∀ p, _ <> S (S p)`. + Coercion. If the object being matched is coercible to an inductive type, the corresponding coercion will be automatically inserted. This also works with the previous mechanism. @@ -88,7 +88,7 @@ coercions. This controls the special treatment of pattern-matching generating equalities and inequalities when using |Program| (it is on by default). All - pattern-matchings and let-patterns are handled using the standard algorithm + pattern-matches and let-patterns are handled using the standard algorithm of |Coq| (see :ref:`extendedpatternmatching`) when this option is deactivated. @@ -108,9 +108,9 @@ typechecker will fall back directly to |Coq|’s usual typing of dependent pattern-matching if a return or in clause is specified. Likewise, the if construct is not treated specially by |Program| so boolean tests in the code are not automatically reflected in the obligations. One can -use the dec combinator to get the correct hypotheses as in: +use the :g:`dec` combinator to get the correct hypotheses as in: -.. coqtop:: none +.. coqtop:: in Require Import Program Arith. @@ -120,7 +120,7 @@ use the dec combinator to get the correct hypotheses as in: if dec (leb n 0) then 0 else S (pred n). -The let tupling construct :g:`let (x1, ..., xn) := t in b` does not +The :g:`let` tupling construct :g:`let (x1, ..., xn) := t in b` does not produce an equality, contrary to the let pattern construct :g:`let ’(x1, ..., xn) := t in b`. Also, :g:`term :>` explicitly asks the system to coerce term to its support type. It can be useful in notations, for @@ -200,7 +200,7 @@ The structural fixpoint operator behaves just like the one of |Coq| (see :cmd:`Fixpoint`), except it may also generate obligations. It works with mutually recursive definitions too. -.. coqtop:: reset none +.. coqtop:: reset in Require Import Program Arith. @@ -264,7 +264,7 @@ Program Lemma Definition` and use it as the goal afterwards. Otherwise the proof will be started with the elaborated version as a goal. The :g:`Program` prefix can similarly be used as a prefix for - :g:`Variable`, :g:`Hypothesis`, :g:`Axiom` etc... + :g:`Variable`, :g:`Hypothesis`, :g:`Axiom` etc. .. _solving_obligations: @@ -300,7 +300,7 @@ optional tactic is replaced by the default one if not specified. Start the proof of the next unsolved obligation. -.. cmd:: Solve Obligations {? of @ident} {? with @tactic} +.. cmd:: Solve Obligations {? {? of @ident} with @tactic} Tries to solve each obligation of ``ident`` using the given ``tactic`` or the default one. @@ -322,13 +322,13 @@ optional tactic is replaced by the default one if not specified. .. opt:: Transparent Obligations - Control whether all obligations should be declared as transparent + Controls whether all obligations should be declared as transparent (the default), or if the system should infer which obligations can be declared opaque. .. opt:: Hide Obligations - Control whether obligations appearing in the + Controls whether obligations appearing in the term should be hidden as implicit arguments of the special constantProgram.Tactics.obligation. diff --git a/doc/sphinx/addendum/ring.rst b/doc/sphinx/addendum/ring.rst index 6a9b343ba8..d5c33dc1d4 100644 --- a/doc/sphinx/addendum/ring.rst +++ b/doc/sphinx/addendum/ring.rst @@ -13,7 +13,7 @@ The ring and field tactic families :Author: Bruno Barras, Benjamin Grégoire, Assia Mahboubi, Laurent Théry [#f1]_ -This chapter presents the tactics dedicated to deal with ring and +This chapter presents the tactics dedicated to dealing with ring and field equations. What does this tactic do? @@ -36,7 +36,7 @@ is strictly less than the following monomial according to the lexicographic order. It is an easy theorem to show that every polynomial is equivalent (modulo the ring properties) to exactly one canonical sum. This canonical sum is called the normal form of the polynomial. In fact, the actual representation shares -monomials with same prefixes. So what does ring? It normalizes polynomials over +monomials with same prefixes. So what does the ``ring`` tactic do? It normalizes polynomials over any ring or semi-ring structure. The basic use of ``ring`` is to simplify ring expressions, so that the user does not have to deal manually with the theorems of associativity and commutativity. @@ -59,9 +59,8 @@ The variables map It is frequent to have an expression built with :math:`+` and :math:`\times`, but rarely on variables only. Let us associate a number to each subterm of a -ring expression in the Gallina language. For example in the ring |nat|, consider -the expression: - +ring expression in the Gallina language. For example, consider this expression +in the semiring ``nat``: :: @@ -104,7 +103,7 @@ Concrete usage in Coq .. tacn:: ring The ``ring`` tactic solves equations upon polynomial expressions of a ring -(or semi-ring) structure. It proceeds by normalizing both hand sides +(or semi-ring) structure. It proceeds by normalizing both sides of the equation (w.r.t. associativity, commutativity and distributivity, constant propagation, rewriting of monomials) and comparing syntactically the results. @@ -112,9 +111,9 @@ comparing syntactically the results. .. tacn:: ring_simplify ``ring_simplify`` applies the normalization procedure described above to -the terms given. The tactic then replaces all occurrences of the terms +the given terms. The tactic then replaces all occurrences of the terms given in the conclusion of the goal by their normal forms. If no term -is given, then the conclusion should be an equation and both hand +is given, then the conclusion should be an equation and both sides are normalized. The tactic can also be applied in a hypothesis. The tactic must be loaded by ``Require Import Ring``. The ring structures @@ -187,7 +186,7 @@ Error messages: .. exn:: Cannot find a declared ring structure for equality @term. - Same as above is the case of the ``ring`` tactic. + Same as above in the case of the ``ring`` tactic. Adding a ring structure @@ -198,8 +197,8 @@ carrier set, an equality, and ring operations: ``Ring_theory.ring_theory`` and ``Ring_theory.semi_ring_theory``) satisfies the ring axioms. Semi- rings (rings without + inverse) are also supported. The equality can be either Leibniz equality, or any relation declared as a setoid (see -:ref:`tactics-enabled-on-user-provided-relations`). The definition of ring and semi-rings (see module -``Ring_theory``) is: +:ref:`tactics-enabled-on-user-provided-relations`). +The definitions of ring and semiring (see module ``Ring_theory``) are: .. coqtop:: in @@ -305,7 +304,7 @@ The syntax for adding a new ring is .. cmd:: Add Ring @ident : @term {? ( @ring_mod {* , @ring_mod } )} -The :n:`@ident` is not relevant. It is just used for error messages. The +The :n:`@ident` is not relevant. It is used just for error messages. The :n:`@term` is a proof that the ring signature satisfies the (semi-)ring axioms. The optional list of modifiers is used to tailor the behavior of the tactic. The following list describes their syntax and effects: @@ -386,7 +385,7 @@ sign :n:`@term` div :n:`@term` allows ``ring`` and ``ring_simplify`` to use monomials with - coefficient other than 1 in the rewriting. The term :n:`@term` is a proof + coefficients other than 1 in the rewriting. The term :n:`@term` is a proof that a given division function satisfies the specification of an euclidean division function (:n:`@term` has to be a proof of ``Ring_theory.div_theory``). For example, this function is called when @@ -414,13 +413,13 @@ Error messages: How does it work? ---------------------- -The code of ring is a good example of tactic written using *reflection*. -What is reflection? Basically, it is writing |Coq| tactics in |Coq|, rather -than in |OCaml|. From the philosophical point of view, it is -using the ability of the Calculus of Constructions to speak and reason -about itself. For the ring tactic we used Coq as a programming -language and also as a proof environment to build a tactic and to -prove it correctness. +The code of ``ring`` is a good example of a tactic written using *reflection*. +What is reflection? Basically, using it means that a part of a tactic is written +in Gallina, Coq's language of terms, rather than |Ltac| or |OCaml|. From the +philosophical point of view, reflection is using the ability of the Calculus of +Constructions to speak and reason about itself. For the ``ring`` tactic we used +Coq as a programming language and also as a proof environment to build a tactic +and to prove its correctness. The interested reader is strongly advised to have a look at the file ``Ring_polynom.v``. Here a type for polynomials is defined: @@ -452,7 +451,7 @@ Polynomials in normal form are defined as: where ``Pinj n P`` denotes ``P`` in which :math:`V_i` is replaced by :math:`V_{i+n}` , and ``PX P n Q`` denotes :math:`P \otimes V_1^n \oplus Q'`, `Q'` being `Q` where :math:`V_i` is replaced by :math:`V_{i+1}`. -Variables maps are represented by list of ring elements, and two +Variable maps are represented by lists of ring elements, and two interpretation functions, one that maps a variables map and a polynomial to an element of the concrete ring, and the second one that does the same for normal forms: @@ -490,18 +489,18 @@ concrete expression `p’`, which is the concrete normal form of `p`. This is su `p’` |la| |le| ========= ====== ==== -The user do not see the right part of the diagram. From outside, the -tactic behaves like a |bdi| simplification extended with AC rewriting -rules. Basically, the proof is only the application of the main -correctness theorem to well-chosen arguments. +The user does not see the right part of the diagram. From outside, the +tactic behaves like a |bdi| simplification extended with rewriting rules +for associativity and commutativity. Basically, the proof is only the +application of the main correctness theorem to well-chosen arguments. Dealing with fields ------------------------ .. tacn:: field -The ``field`` tactic is an extension of the ``ring`` to deal with rational -expression. Given a rational expression :math:`F = 0`. It first reduces the +The ``field`` tactic is an extension of the ``ring`` tactic that deals with rational +expressions. Given a rational expression :math:`F = 0`. It first reduces the expression `F` to a common denominator :math:`N/D = 0` where `N` and `D` are two ring expressions. For example, if we take :math:`F = (1 − 1/x) x − x + 1`, this gives :math:`N = (x − 1) x − x^2 + x` and :math:`D = x`. It then calls ring to solve @@ -523,7 +522,7 @@ structures can be declared to the system with the ``Add Field`` command (in ``plugins/setoid_ring``). It is exported by module ``Rbase``, so that requiring ``Rbase`` or ``Reals`` is enough to use the field tactics on real numbers. Rational numbers in canonical form are also declared as -a field in module ``Qcanon``. +a field in the module ``Qcanon``. .. example:: @@ -559,8 +558,8 @@ a field in module ``Qcanon``. performs the simplification in the conclusion of the goal, :math:`F_1 = F_2` becomes :math:`N_1 / D_1 = N_2 / D_2`. A normalization step (the same as the one for rings) is then applied to :math:`N_1`, :math:`D_1`, - :math:`N_2` and :math:`D_2`. This way, polynomials remain in factorized form during the - fraction simplifications. This yields smaller expressions when + :math:`N_2` and :math:`D_2`. This way, polynomials remain in factorized form during + fraction simplification. This yields smaller expressions when reducing to the same denominator since common factors can be canceled. .. tacv:: field_simplify [{* @term }] @@ -657,7 +656,7 @@ The syntax for adding a new field is .. cmd:: Add Field @ident : @term {? ( @field_mod {* , @field_mod } )} -The :n:`@ident` is not relevant. It is just used for error +The :n:`@ident` is not relevant. It is used just for error messages. :n:`@term` is a proof that the field signature satisfies the (semi-)field axioms. The optional list of modifiers is used to tailor the behavior of the tactic. @@ -704,9 +703,8 @@ it using reflection (see :cite:`Bou97`). Later, it was rewritten by Patrick Loiseleur: the new tactic does not any more require ``ACDSimpl`` to compile and it makes use of |bdi|-reduction not only to replace the rewriting steps, but also to achieve the -interleaving of computation and reasoning (see :ref:`discussion_reflection`). He also wrote a -few |ML| code for the ``Add Ring`` command, that allow to register new rings -dynamically. +interleaving of computation and reasoning (see :ref:`discussion_reflection`). He also wrote +some |ML| code for the ``Add Ring`` command that allows registering new rings dynamically. Proofs terms generated by ring are quite small, they are linear in the number of :math:`\oplus` and :math:`\otimes` operations in the normalized terms. Type-checking @@ -733,15 +731,15 @@ Then it is rewritten to ``34 − x + 2 * x + 12``, very far from the expected re Here rewriting is not sufficient: you have to do some kind of reduction (some kind of computation) to achieve the normalization. -The tactic ``ring`` is not only faster than a classical one: using -reflection, we get for free integration of computation and reasoning -that would be very complex to implement in the classic fashion. +The tactic ``ring`` is not only faster than the old one: by using +reflection, we get for free the integration of computation and reasoning +that would be very difficult to implement without it. Is it the ultimate way to write tactics? The answer is: yes and no. -The ``ring`` tactic uses intensively the conversion rule of |Cic|, that is -replaces proof by computation the most as it is possible. It can be -useful in all situations where a classical tactic generates huge proof -terms. Symbolic Processing and Tautologies are in that case. But there +The ``ring`` tactic intensively uses the conversion rules of the Calculus of +Inductive Constructions, i.e. it replaces proofs by computations as much as possible. +It can be useful in all situations where a classical tactic generates huge proof +terms, like symbolic processing and tautologies. But there are also tactics like ``auto`` or ``linear`` that do many complex computations, using side-effects and backtracking, and generate a small proof term. Clearly, it would be significantly less efficient to replace them by @@ -750,12 +748,12 @@ tactics using reflection. Another idea suggested by Benjamin Werner: reflection could be used to couple an external tool (a rewriting program or a model checker) with |Coq|. We define (in |Coq|) a type of terms, a type of *traces*, and -prove a correction theorem that states that *replaying traces* is safe -w.r.t some interpretation. Then we let the external tool do every +prove a correctness theorem that states that *replaying traces* is safe +with respect to some interpretation. Then we let the external tool do every computation (using side-effects, backtracking, exception, or others features that are not available in pure lambda calculus) to produce -the trace: now we can check in |Coq| that the trace has the expected -semantic by applying the correction lemma. +the trace. Now we can check in |Coq| that the trace has the expected +semantics by applying the correctness theorem. diff --git a/doc/sphinx/language/cic.rst b/doc/sphinx/language/cic.rst index 98e81ebc65..6e0c1e1b61 100644 --- a/doc/sphinx/language/cic.rst +++ b/doc/sphinx/language/cic.rst @@ -723,6 +723,7 @@ each :math:`T` in :math:`(t:T)∈Γ_I` can be written as: :math:`∀Γ_P,∀Γ_{ the sort of the inductive type t (not to be confused with :math:`\Sort` which is the set of sorts). .. example:: + The declaration for parameterized lists is: .. math:: @@ -741,6 +742,7 @@ the sort of the inductive type t (not to be confused with :math:`\Sort` which is | cons : A -> list A -> list A. .. example:: + The declaration for a mutual inductive definition of tree and forest is: @@ -763,6 +765,7 @@ the sort of the inductive type t (not to be confused with :math:`\Sort` which is | consf : tree -> forest -> forest. .. example:: + The declaration for a mutual inductive definition of even and odd is: .. math:: @@ -811,6 +814,7 @@ contains an inductive declaration. E[Γ] ⊢ c : C .. example:: + Provided that our environment :math:`E` contains inductive definitions we showed before, these two inference rules above enable us to conclude that: @@ -919,6 +923,7 @@ condition* for a constant :math:`X` in the following cases: .. example:: + For instance, if one considers the following variant of a tree type branching over the natural numbers: @@ -985,6 +990,7 @@ the Type hierarchy. .. example:: + It is well known that the existential quantifier can be encoded as an inductive definition. The following declaration introduces the second- order existential quantifier :math:`∃ X.P(X)`. @@ -1102,6 +1108,7 @@ sorts at each instance of a pattern-matching (see Section :ref:`Destructors`). A an example, let us consider the following definition: .. example:: + .. coqtop:: in Inductive option (A:Type) : Type := @@ -1118,6 +1125,7 @@ if :g:`option` is applied to a type in :math:`\Prop`, then, the result is not se if set in :math:`\Prop`. .. example:: + .. coqtop:: all Check (fun A:Set => option A). @@ -1126,6 +1134,7 @@ if set in :math:`\Prop`. Here is another example. .. example:: + .. coqtop:: in Inductive prod (A B:Type) : Type := pair : A -> B -> prod A B. @@ -1136,6 +1145,7 @@ none in :math:`\Type`, and in :math:`\Type` otherwise. In all cases, the three k eliminations schemes are allowed. .. example:: + .. coqtop:: all Check (fun A:Set => prod A). @@ -1324,6 +1334,7 @@ the extraction mechanism. Assume :math:`A` and :math:`B` are two propositions, a logical disjunction :math:`A ∨ B` is defined inductively by: .. example:: + .. coqtop:: in Inductive or (A B:Prop) : Prop := @@ -1334,6 +1345,7 @@ The following definition which computes a boolean value by case over the proof of :g:`or A B` is not accepted: .. example:: + .. coqtop:: all Fail Definition choice (A B: Prop) (x:or A B) := @@ -1357,6 +1369,7 @@ property which are provably different, contradicting the proof- irrelevance property which is sometimes a useful axiom: .. example:: + .. coqtop:: all Axiom proof_irrelevance : forall (P : Prop) (x y : P), x=y. @@ -1390,6 +1403,7 @@ be used for rewriting not only in logical propositions but also in any type. .. example:: + .. coqtop:: all Print eq_rec. @@ -1421,6 +1435,7 @@ We write :math:`\{c\}^P` for :math:`\{c:C\}^P` with :math:`C` the type of :math: .. example:: + The following term in concrete syntax:: match t as l return P' with @@ -1485,6 +1500,7 @@ definition :math:`\ind{r}{Γ_I}{Γ_C}` with :math:`Γ_C = [c_1 :C_1 ;…;c_n :C_ .. example:: + Below is a typing rule for the term shown in the previous example: .. inference:: list example @@ -1634,6 +1650,7 @@ The following definitions are correct, we enter them using the :cmd:`Fixpoint` command and show the internal representation. .. example:: + .. coqtop:: all Fixpoint plus (n m:nat) {struct n} : nat := @@ -1810,6 +1827,7 @@ option ``-impredicative-set``. For example, using the ordinary `coqtop` command, the following is rejected, .. example:: + .. coqtop:: all Fail Definition id: Set := forall X:Set,X->X. diff --git a/doc/sphinx/language/coq-library.rst b/doc/sphinx/language/coq-library.rst index 52c56d2bd2..9de30e2190 100644 --- a/doc/sphinx/language/coq-library.rst +++ b/doc/sphinx/language/coq-library.rst @@ -848,6 +848,7 @@ Notation Interpretation Precedence Associativity .. example:: + .. coqtop:: all reset Require Import ZArith. @@ -887,6 +888,7 @@ Notation Interpretation =============== =================== .. example:: + .. coqtop:: all reset Require Import Reals. @@ -906,6 +908,7 @@ tactics (see Chapter :ref:`tactics`), there are also: Proves that two real integer constants are different. .. example:: + .. coqtop:: all reset Require Import DiscrR. @@ -919,6 +922,7 @@ tactics (see Chapter :ref:`tactics`), there are also: Allows unfolding the ``Rabs`` constant and splits corresponding conjunctions. .. example:: + .. coqtop:: all reset Require Import Reals. @@ -933,6 +937,7 @@ tactics (see Chapter :ref:`tactics`), there are also: corresponding to the condition on each operand of the product. .. example:: + .. coqtop:: all reset Require Import Reals. diff --git a/doc/sphinx/language/gallina-extensions.rst b/doc/sphinx/language/gallina-extensions.rst index 394b928ada..7dd0a6e383 100644 --- a/doc/sphinx/language/gallina-extensions.rst +++ b/doc/sphinx/language/gallina-extensions.rst @@ -70,7 +70,9 @@ generates a variant type definition with just one constructor: To build an object of type :n:`@ident`, one should provide the constructor :n:`@ident₀` with the appropriate number of terms filling the fields of the record. -.. example:: Let us define the rational :math:`1/2`: +.. example:: + + Let us define the rational :math:`1/2`: .. coqtop:: in @@ -1849,15 +1851,15 @@ are named as expected. .. example:: (continued) -.. coqtop:: all + .. coqtop:: all - Arguments p [s t] _ [u] _: rename. + Arguments p [s t] _ [u] _: rename. - Check (p r1 (u:=c)). + Check (p r1 (u:=c)). - Check (p (s:=a) (t:=b) r1 (u:=c) r2). + Check (p (s:=a) (t:=b) r1 (u:=c) r2). - Fail Arguments p [s t] _ [w] _ : assert. + Fail Arguments p [s t] _ [w] _ : assert. .. _displaying-implicit-args: diff --git a/doc/sphinx/language/gallina-specification-language.rst b/doc/sphinx/language/gallina-specification-language.rst index 8250b4b3d6..da5cd00d72 100644 --- a/doc/sphinx/language/gallina-specification-language.rst +++ b/doc/sphinx/language/gallina-specification-language.rst @@ -758,6 +758,7 @@ Simple inductive types the case of annotated inductive types — cf. next section). .. example:: + The set of natural numbers is defined as: .. coqtop:: all @@ -976,6 +977,7 @@ Mutually defined inductive types reason, the parameters must be strictly the same for each inductive types. .. example:: + The typical example of a mutual inductive data type is the one for trees and forests. We assume given two types :g:`A` and :g:`B` as variables. It can be declared the following way. @@ -1048,6 +1050,7 @@ of the type. For co-inductive types, the only elimination principle is case analysis. .. example:: + An example of a co-inductive type is the type of infinite sequences of natural numbers, usually called streams. @@ -1067,6 +1070,7 @@ Definition of co-inductive predicates and blocks of mutually co-inductive definitions are also allowed. .. example:: + An example of a co-inductive predicate is the extensional equality on streams: @@ -1129,6 +1133,7 @@ constructions. .. example:: + One can define the addition function as : .. coqtop:: all @@ -1201,6 +1206,7 @@ constructions. inductive types. .. example:: + The size of trees and forests can be defined the following way: .. coqtop:: all diff --git a/doc/sphinx/practical-tools/utilities.rst b/doc/sphinx/practical-tools/utilities.rst index bdaa2aa1a2..59bc2d22aa 100644 --- a/doc/sphinx/practical-tools/utilities.rst +++ b/doc/sphinx/practical-tools/utilities.rst @@ -218,6 +218,7 @@ file timing data: On ``Mac OS``, this works best if you’ve installed ``gnu-time``. .. example:: + For example, the output of ``make TIMED=1`` may look like this: @@ -295,6 +296,7 @@ file timing data: files which take effectively no time to compile. .. example:: + For example, the output table from ``make print-pretty-timed-diff`` may look like this: @@ -318,6 +320,7 @@ line timing data: line-by-line timing information. .. example:: + For example, running ``make all TIMING=1`` may result in a file like this: :: @@ -345,6 +348,7 @@ line timing data: This target requires python to build the table. .. example:: + For example, running ``print-pretty-single-time-diff`` might give a table like this: :: @@ -546,12 +550,12 @@ The printing for one token can be removed with Initially, the pretty-printing table contains the following mapping: -==== === ==== ===== === ==== ==== === -`->` → `<-` ← `*` × -`<=` ≤ `>=` ≥ `=>` ⇒ -`<>` ≠ `<->` ↔ `|-` ⊢ -`\/` ∨ `/\\` ∧ `~` ¬ -==== === ==== ===== === ==== ==== === +===== === ==== ===== === ==== ==== === +`->` → `<-` ← `*` × +`<=` ≤ `>=` ≥ `=>` ⇒ +`<>` ≠ `<->` ↔ `|-` ⊢ +`\\/` ∨ `/\\` ∧ `~` ¬ +===== === ==== ===== === ==== ==== === Any of these can be overwritten or suppressed using the printing commands. diff --git a/doc/sphinx/proof-engine/detailed-tactic-examples.rst b/doc/sphinx/proof-engine/detailed-tactic-examples.rst index 78719c1ef1..225df8d54c 100644 --- a/doc/sphinx/proof-engine/detailed-tactic-examples.rst +++ b/doc/sphinx/proof-engine/detailed-tactic-examples.rst @@ -341,8 +341,7 @@ involves conditional rewritings and shows how to deal with them using the optional tactic of the ``Hint Rewrite`` command. -.. example:: - Ackermann function +.. example:: Ackermann function .. coqtop:: in reset @@ -370,8 +369,7 @@ the optional tactic of the ``Hint Rewrite`` command. autorewrite with base0 using try reflexivity. -.. example:: - MacCarthy function +.. example:: MacCarthy function .. coqtop:: in reset diff --git a/doc/sphinx/proof-engine/proof-handling.rst b/doc/sphinx/proof-engine/proof-handling.rst index 44376080c3..a9d0c16376 100644 --- a/doc/sphinx/proof-engine/proof-handling.rst +++ b/doc/sphinx/proof-engine/proof-handling.rst @@ -375,6 +375,7 @@ or focus the next one. The following example script illustrates all these features: .. example:: + .. coqtop:: all Goal (((True /\ True) /\ True) /\ True) /\ True. @@ -511,6 +512,7 @@ Requesting information :token:`ident` .. example:: + .. coqtop:: all Show Match nat. diff --git a/doc/sphinx/proof-engine/ssreflect-proof-language.rst b/doc/sphinx/proof-engine/ssreflect-proof-language.rst index 6fb73a030f..8a2fc3996a 100644 --- a/doc/sphinx/proof-engine/ssreflect-proof-language.rst +++ b/doc/sphinx/proof-engine/ssreflect-proof-language.rst @@ -4632,6 +4632,7 @@ bookkeeping steps. .. example:: + The following example use the ``~~`` prenex notation for boolean negation: diff --git a/doc/sphinx/proof-engine/tactics.rst b/doc/sphinx/proof-engine/tactics.rst index 9b4d724e02..fdb04bf9a0 100644 --- a/doc/sphinx/proof-engine/tactics.rst +++ b/doc/sphinx/proof-engine/tactics.rst @@ -207,6 +207,7 @@ Applying theorems useful to advanced users. .. example:: + .. coqtop:: reset all Inductive Option : Set := @@ -281,7 +282,7 @@ Applying theorems :g:`t`:sub:`n` in the goal. See :tacn:`pattern` to transform the goal so that it gets the form :g:`(fun x => Q) u`:sub:`1` :g:`...` :g:`u`:sub:`n`. - .. exn:: Unable to unify ... with ... . + .. exn:: Unable to unify @term with @term. The apply tactic failed to match the conclusion of :token:`term` and the current goal. You can help the apply tactic by transforming your goal with @@ -366,6 +367,7 @@ Applying theorems .. warn:: When @term contains more than one non dependent product the tactic lapply only takes into account the first product. .. example:: + Assume we have a transitive relation ``R`` on ``nat``: .. coqtop:: reset in @@ -837,6 +839,7 @@ quantified variables or hypotheses until the goal is not any more a quantification or an implication. .. example:: + .. coqtop:: all Goal forall A B C:Prop, A \/ B /\ C -> (A -> C) -> C. @@ -958,6 +961,7 @@ quantification or an implication. .. exn:: Cannot move @ident after @ident : it depends on @ident. .. example:: + .. coqtop:: all Goal forall x :nat, x = 0 -> forall z y:nat, y=y-> 0=x. @@ -1082,6 +1086,7 @@ The name of the hypothesis in the proof-term, however, is left unchanged. obtain atomic ones. .. example:: + .. coqtop:: all Goal forall A B C:Prop, A /\ B /\ C \/ B /\ C \/ C /\ A -> C. @@ -1252,6 +1257,7 @@ Controlling the proof flow respect to some term. .. example:: + .. coqtop:: reset none Goal forall x y:nat, 0 <= x + y + y. @@ -1567,6 +1573,7 @@ analysis on inductive or co-inductive objects (see :ref:`inductive-definitions`) performs induction using this subterm. .. example:: + .. coqtop:: reset all Lemma induction_test : forall n:nat, n = n -> n <= n. @@ -1636,6 +1643,7 @@ analysis on inductive or co-inductive objects (see :ref:`inductive-definitions`) those are generalized as well in the statement to prove. .. example:: + .. coqtop:: reset all Lemma comm x y : x + y = y + x. @@ -1744,6 +1752,7 @@ analysis on inductive or co-inductive objects (see :ref:`inductive-definitions`) still get enough information in the proofs. .. example:: + .. coqtop:: reset all Lemma le_minus : forall n:nat, n < 1 -> n = 0. @@ -1809,6 +1818,7 @@ and an explanation of the underlying technique. Note that this tactic is only available after a ``Require Import FunInd``. .. example:: + .. coqtop:: reset all Require Import FunInd. @@ -2856,6 +2866,7 @@ the conversion in hypotheses :n:`{+ @ident}`. + A constant can be marked to be never unfolded by ``cbn`` or ``simpl``: .. example:: + .. coqtop:: all Arguments minus n m : simpl never. @@ -2868,6 +2879,7 @@ the conversion in hypotheses :n:`{+ @ident}`. ``/`` symbol in the argument list of the :cmd:`Arguments` vernacular command. .. example:: + .. coqtop:: all Definition fcomp A B C f (g : A -> B) (x : A) : C := f (g x). @@ -2880,6 +2892,7 @@ the conversion in hypotheses :n:`{+ @ident}`. always unfolded. .. example:: + .. coqtop:: all Definition volatile := fun x : nat => x. @@ -2890,6 +2903,7 @@ the conversion in hypotheses :n:`{+ @ident}`. such arguments. .. example:: + .. coqtop:: all Arguments minus !n !m. @@ -3180,6 +3194,7 @@ where :tacn:`auto` uses simple :tacn:`apply`). As a consequence, :tacn:`eauto` can solve such a goal: .. example:: + .. coqtop:: all Hint Resolve ex_intro. @@ -3748,6 +3763,7 @@ The following goal can be proved by :tacn:`tauto` whereas :tacn:`auto` would fail: .. example:: + .. coqtop:: reset all Goal forall (x:nat) (P:nat -> Prop), x = 0 \/ P x -> x <> 0 -> P x. @@ -3904,6 +3920,7 @@ equality must contain all the quantified variables in order for congruence to match against it. .. example:: + .. coqtop:: reset all Theorem T (A:Type) (f:A -> A) (g: A -> A -> A) a b: a=(f a) -> (g b (f a))=(f (f a)) -> (g a b)=(f (g b a)) -> (g a b)=a. @@ -3935,7 +3952,7 @@ match against it. discriminable equality but this proof could not be built in Coq because of dependently-typed functions. -.. exn:: Goal is solvable by congruence but some arguments are missing. Try congruence with ..., replacing metavariables by arbitrary terms. +.. exn:: Goal is solvable by congruence but some arguments are missing. Try congruence with {+ @term}, replacing metavariables by arbitrary terms. The decision procedure could solve the goal with the provision that additional arguments are supplied for some partially applied constructors. Any term of an @@ -3979,7 +3996,7 @@ succeeds, and results in an error otherwise. This tactic checks whether its arguments are unifiable, potentially instantiating existential variables. -.. exn:: Not unifiable. +.. exn:: Unable to unify @term with @term. .. tacv:: unify @term @term with @ident @@ -4315,6 +4332,7 @@ declare new field structures. All declared field structures can be printed with the Print Fields command. .. example:: + .. coqtop:: reset all Require Import Reals. @@ -4426,6 +4444,7 @@ Simple tactic macros A simple example has more value than a long explanation: .. example:: + .. coqtop:: reset all Ltac Solve := simpl; intros; auto. diff --git a/doc/sphinx/user-extensions/syntax-extensions.rst b/doc/sphinx/user-extensions/syntax-extensions.rst index dcefa293b1..37394386e6 100644 --- a/doc/sphinx/user-extensions/syntax-extensions.rst +++ b/doc/sphinx/user-extensions/syntax-extensions.rst @@ -146,7 +146,7 @@ expected to be inferred at typing time. Notation "x = y" := (@eq _ x y) (at level 70, no associativity). One can define *closed* notations whose both sides are symbols. In this case, -the default precedence level for the inner subexpression is 200, and the default +the default precedence level for the inner sub-expression is 200, and the default level for the notation itself is 0. .. coqtop:: in @@ -185,7 +185,7 @@ rules. Some simple left factorization work has to be done. Here is an example. Notation "x < y" := (lt x y) (at level 70). Notation "x < y < z" := (x < y /\ y < z) (at level 70). -In order to factorize the left part of the rules, the subexpression +In order to factorize the left part of the rules, the sub-expression referred by ``y`` has to be at the same level in both rules. However the default behavior puts ``y`` at the next level below 70 in the first rule (``no associativity`` is the default), and at the level 200 in the second @@ -209,7 +209,7 @@ of Coq predefined notations can be found in the chapter on :ref:`thecoqlibrary`. .. cmd:: Print Grammar pattern. This displays the state of the subparser of patterns (the parser used in the - grammar of the match with constructions). + grammar of the ``match with`` constructions). Displaying symbolic notations @@ -519,7 +519,7 @@ is just an identifier, one could have said ``p at level 99 as strict pattern``. Note also that in the absence of a ``as ident``, ``as strict pattern`` or -``as pattern`` modifiers, the default is to consider subexpressions occurring +``as pattern`` modifiers, the default is to consider sub-expressions occurring in binding position and parsed as terms to be ``as ident``. .. _NotationsWithBinders: @@ -650,7 +650,7 @@ example of recursive notation with closed binders: A recursive pattern for binders can be used in position of a recursive pattern for terms. Here is an example: -.. coqtop:: in +.. coqtop:: in Notation "'FUNAPP' x .. y , f" := (fun x => .. (fun y => (.. (f x) ..) y ) ..) @@ -691,6 +691,117 @@ side. E.g.: Notation "'apply_id' f a1 .. an" := (.. (f a1) .. an) (at level 10, f ident, a1, an at level 9). +Custom entries +~~~~~~~~~~~~~~ + +.. cmd:: Declare Custom Entry @ident + + This command allows to define new grammar entries, called *custom + entries*, that can later be referred to using the entry name + :n:`custom @ident`. For instance, we may want to define an ad hoc + parser for arithmetical operations and proceed as follows: + +.. coqtop:: all + + Inductive Expr := + | One : Expr + | Mul : Expr -> Expr -> Expr + | Add : Expr -> Expr -> Expr. + + Declare Custom Entry expr. + Notation "[ e ]" := e (e custom expr at level 2). + Notation "1" := One (in custom expr at level 0). + Notation "x y" := (Mul x y) (in custom expr at level 1, left associativity). + Notation "x + y" := (Add x y) (in custom expr at level 2, left associativity). + Notation "( x )" := x (in custom expr, x at level 2). + Notation "{ x }" := x (in custom expr, x constr). + Notation "x" := x (in custom expr at level 0, x ident). + + Axiom f : nat -> Expr. + Check fun x y z => [1 + y z + {f x}]. + Unset Printing Notations. + Check fun x y z => [1 + y z + {f x}]. + Set Printing Notations. + Check fun e => match e with + | [1 + 1] => [1] + | [x y + z] => [x + y z] + | y => [y + e] + end. + +Custom entries have levels, like the main grammar of terms and grammar +of patterns have. The lower level is 0 and this is the level used by +default to put rules delimited with tokens on both ends. The level is +left to be inferred by Coq when using :n:`in custom @ident``. The +level is otherwise given explicitly by using the syntax :n:`in custom +@ident at level @num`, where :n:`@num` refers to the level. + +Levels are cumulative: a notation at level ``n`` of which the left end +is a term shall use rules at level less than ``n`` to parse this +sub-term. More precisely, it shall use rules at level strictly less +than ``n`` if the rule is declared with ``right associativity`` and +rules at level less or equal than ``n`` if the rule is declared with +``left associativity``. Similarly, a notation at level ``n`` of which +the right end is a term shall use by default rules at level strictly +less than ``n`` to parse this sub-term if the rule is declared left +associative and rules at level less or equal than ``n`` if the rule is +declared right associative. This is what happens for instance in the +rule ``Notation "x + y" := (Add x y) (in custom expr at level 2, left +associativity)`` where ``x`` is any expression parsed in entry +``expr`` at level less or equal than ``2`` (including, recursively, +the given rule) and ``y`` is any expression parsed in entry ``expr`` +at level strictly less than ``2``. + +Rules associated to an entry can refer different sub-entries. The +grammar entry name ``constr`` can be used to refer to the main grammar +of term as in the rule ``Notation "{ x }" := x (in custom expr at +level 0, x constr)`` which indicates that the subterm ``x`` should be +parsed using the main grammar. If not indicated, the level is computed +as for notations in ``constr``, e.g. using 200 as default level for +inner sub-expressions. The level can otherwise be indicated explicitly +by using ``constr at level n`` for some ``n``, or ``constr at next +level``. + +Conversely, custom entries can be used to parse sub-expressions of the +main grammar, or from another custom entry as is the case in +:g:`Notation "[ e ]" := e (e custom expr at level 2)` to indicate that +``e`` has to be parsed at level ``2`` of the grammar associated to the +custom entry ``expr``. The level can be omitted, as in :g:`Notation "[ e +]" := e (e custom expr)`, in which case Coq tries to infer it. + +In the absence of an explicit entry for parsing or printing a +sub-expression of a notation in a custom entry, the default is to +consider that this sub-expression is parsed or printed in the same +custom entry where the notation is defined. In particular, if ``x at +level n`` is used for a sub-expression of a notation defined in custom +entry ``foo``, it shall be understood the same as ``x custom foo at +level n``. + +In general, rules are required to be *productive* on the right-hand +side, i.e. that they are bound to an expression which is not +reduced to a single variable. If the rule is not productive on the +right-hand side, as it is the case above for :g:`Notation "( x )" := x +(in custom expr at level 0, x at level 2)` and :g:`Notation "{ x }" := +x (in custom expr at level 0, x constr)`, it is used as a *grammar +coercion* which means that it is used to parse or print an expression +which is not available in the current grammar at the current level of +parsing or printing for this grammar but which is available in another +grammar or in another level of the current grammar. For instance, +:g:`Notation "( x )" := x (in custom expr at level 0, x at level 2)` +tells that parentheses can be inserted to parse or print an expression +declared at level ``2`` of ``expr`` whenever this expression is +expected to be used as a subterm at level 0 or 1. This allows for +instance to parse and print :g:`Add x y` as a subterm of :g:`Mul (Add +x y) z` using the syntax ``(x + y) z``. Similarly, :g:`Notation "{ x }" +:= x (in custom expr at level 0, x constr)` gives a way to let any +arbitrary expression which is not in handled by the custom entry +``expr`` be parsed or printed by the main grammar of term up to the +insertion of a pair of curly brackets. + +.. cmd:: Print Grammar @ident. + + This displays the state of the grammar for terms and grammar for + patterns associated to the custom entry :token:`ident`. + Summary ~~~~~~~ @@ -699,8 +810,8 @@ Summary Syntax of notations +++++++++++++++++++ -The different syntactic variants of the command Notation are given on the -following figure. The optional :production:`scope` is described in +The different syntactic forms taken by the commands declaring +notations are given below. The optional :production:`scope` is described in :ref:`Scopes`. .. productionlist:: coq @@ -711,22 +822,32 @@ following figure. The optional :production:`scope` is described in : | CoInductive `ind_body` [`decl_notation`] with … with `ind_body` [`decl_notation`]. : | Fixpoint `fix_body` [`decl_notation`] with … with `fix_body` [`decl_notation`]. : | CoFixpoint `cofix_body` [`decl_notation`] with … with `cofix_body` [`decl_notation`]. + : | [Local] Declare Custom Entry `ident`. decl_notation : [where `string` := `term` [: `scope`] and … and `string` := `term` [: `scope`]]. - modifiers : at level `natural` - : | `ident` , … , `ident` at level `natural` [`binderinterp`] + modifiers : at level `num` + : in custom `ident` + : in custom `ident` at level `num` + : | `ident` , … , `ident` at level `num` [`binderinterp`] : | `ident` , … , `ident` at next level [`binderinterp`] - : | `ident` ident - : | `ident` global - : | `ident` bigint - : | `ident` [strict] pattern [at level `natural`] - : | `ident` binder - : | `ident` closed binder + : | `ident` `explicit_subentry` : | left associativity : | right associativity : | no associativity : | only parsing : | only printing : | format `string` + explicit_subentry : ident + : | global + : | bigint + : | [strict] pattern [at level `num`] + : | binder + : | closed binder + : | constr [`binderinterp`] + : | constr at level `num` [`binderinterp`] + : | constr at next level [`binderinterp`] + : | custom [`binderinterp`] + : | custom at level `num` [`binderinterp`] + : | custom at next level [`binderinterp`] binderinterp : as ident : | as pattern : | as strict pattern @@ -734,10 +855,11 @@ following figure. The optional :production:`scope` is described in .. note:: No typing of the denoted expression is performed at definition time. Type-checking is done only at the time of use of the notation. -.. note:: Many examples of Notation may be found in the files composing +.. note:: Some examples of Notation may be found in the files composing the initial state of Coq (see directory :file:`$COQLIB/theories/Init`). -.. note:: The notation ``"{ x }"`` has a special status in such a way that +.. note:: The notation ``"{ x }"`` has a special status in the main grammars of + terms and patterns so that complex notations of the form ``"x + { y }"`` or ``"x * { y }"`` can be nested with correct precedences. Especially, every notation involving a pattern of the form ``"{ x }"`` is parsed as a notation where the @@ -754,13 +876,18 @@ following figure. The optional :production:`scope` is described in Persistence of notations ++++++++++++++++++++++++ -Notations do not survive the end of sections. +Neither notations nor custom entries survive the end of sections. .. cmd:: Local Notation @notation Notations survive modules unless the command ``Local Notation`` is used instead of :cmd:`Notation`. +.. cmd:: Local Declare Custom Entry @ident + + Custom entries survive modules unless the command ``Local Declare + Custom Entry`` is used instead of :cmd:`Declare Custom Entry`. + .. _Scopes: Interpretation scopes @@ -1010,7 +1137,7 @@ The ``function_scope`` interpretation scope .. index:: function_scope -The scope ``function_scope`` also has a special status. +The scope ``function_scope`` also has a special status. It is temporarily activated each time the argument of a global reference is recognized to be a ``Funclass`` istance, i.e., of type :g:`forall x:A, B` or :g:`A -> B`. @@ -1025,11 +1152,11 @@ Scopes` or :cmd:`Print Scope`. ``type_scope`` This scope includes infix * for product types and infix + for sum types. It - is delimited by key ``type``, and bound to the coercion class + is delimited by key ``type``, and bound to the coercion class ``Sortclass``, as described above. ``function_scope`` - This scope is delimited by key ``function``, and bound to the coercion class + This scope is delimited by key ``function``, and bound to the coercion class ``Funclass``, as described above. ``nat_scope`` @@ -1207,7 +1334,7 @@ tactic language. Tactic notations obey the following syntax: .. productionlist:: coq tacn : Tactic Notation [`tactic_level`] [`prod_item` … `prod_item`] := `tactic`. prod_item : `string` | `tactic_argument_type`(`ident`) - tactic_level : (at level `natural`) + tactic_level : (at level `num`) tactic_argument_type : ident | simple_intropattern | reference : | hyp | hyp_list | ne_hyp_list : | constr | uconstr | constr_list | ne_constr_list @@ -1328,7 +1455,9 @@ tactic language. Tactic notations obey the following syntax: .. [#and_or_levels] which are the levels effectively chosen in the current implementation of Coq -.. [#no_associativity] Coq accepts notations declared as ``no associative`` but the parser on - which Coq is built, namely Camlp4, currently does not implement the - ``no associativity`` and replaces it by a ``left associativity``; hence it is - the same for Coq: ``no associativity`` is in fact ``left associativity``. +.. [#no_associativity] Coq accepts notations declared as ``no + associativity`` but the parser on which Coq is built, namely + Camlp5, currently does not implement ``no associativity`` and + replaces it with ``left associativity``; hence it is the same for + Coq: ``no associativity`` is in fact ``left associativity``, for + the purposes of parsing diff --git a/doc/tools/coqrst/coqdomain.py b/doc/tools/coqrst/coqdomain.py index c9487abf03..e6b71a8293 100644 --- a/doc/tools/coqrst/coqdomain.py +++ b/doc/tools/coqrst/coqdomain.py @@ -571,6 +571,9 @@ class ExampleDirective(BaseAdmonition): http://docutils.sourceforge.net/docs/ref/rst/directives.html#generic-admonition for more details. + Optionally, any text immediately following the ``.. example::`` header is + used as the example's title. + Example:: .. example:: Adding a hint to a database @@ -583,13 +586,14 @@ class ExampleDirective(BaseAdmonition): """ node_class = nodes.admonition directive_name = "example" + optional_arguments = 1 def run(self): # ‘BaseAdmonition’ checks whether ‘node_class’ is ‘nodes.admonition’, # and uses arguments[0] as the title in that case (in other cases, the # title is unset, and it is instead set in the HTML visitor). - assert not self.arguments # Arguments have been parsed as content - self.arguments = ['Example'] + assert len(self.arguments) <= 1 + self.arguments = [": ".join(['Example'] + self.arguments)] self.options['classes'] = ['admonition', 'note'] return super().run() diff --git a/grammar/q_util.mli b/grammar/q_util.mli index 323a12357d..f3af318b60 100644 --- a/grammar/q_util.mli +++ b/grammar/q_util.mli @@ -48,3 +48,5 @@ val mlexpr_of_prod_entry_key : (string -> MLast.expr) -> user_symbol -> MLast.ex val type_of_user_symbol : user_symbol -> argument_type val parse_user_entry : string -> string -> user_symbol + +val mlexpr_of_symbol : user_symbol -> MLast.expr diff --git a/grammar/q_util.mlp b/grammar/q_util.mlp index 0b8d7fda7a..0e2bf55d86 100644 --- a/grammar/q_util.mlp +++ b/grammar/q_util.mlp @@ -128,3 +128,17 @@ let rec parse_user_entry s sep = let s = match s with "hyp" -> "var" | _ -> s in check_separator sep; Uentry s + +let rec mlexpr_of_symbol = function +| Ulist1 s -> <:expr< Extend.TUlist1 $mlexpr_of_symbol s$ >> +| Ulist1sep (s,sep) -> <:expr< Extend.TUlist1sep $mlexpr_of_symbol s$ $str:sep$ >> +| Ulist0 s -> <:expr< Extend.TUlist0 $mlexpr_of_symbol s$ >> +| Ulist0sep (s,sep) -> <:expr< Extend.TUlist0sep $mlexpr_of_symbol s$ $str:sep$ >> +| Uopt s -> <:expr< Extend.TUopt $mlexpr_of_symbol s$ >> +| Uentry e -> + let wit = <:expr< $lid:"wit_"^e$ >> in + <:expr< Extend.TUentry (Genarg.get_arg_tag $wit$) >> +| Uentryl (e, l) -> + assert (e = "tactic"); + let wit = <:expr< $lid:"wit_"^e$ >> in + <:expr< Extend.TUentryl (Genarg.get_arg_tag $wit$) $mlexpr_of_int l$>> diff --git a/grammar/tacextend.mlp b/grammar/tacextend.mlp index 02da61ef77..07239e7af0 100644 --- a/grammar/tacextend.mlp +++ b/grammar/tacextend.mlp @@ -15,20 +15,6 @@ open Argextend let plugin_name = <:expr< __coq_plugin_name >> -let rec mlexpr_of_symbol = function -| Ulist1 s -> <:expr< Extend.TUlist1 $mlexpr_of_symbol s$ >> -| Ulist1sep (s,sep) -> <:expr< Extend.TUlist1sep $mlexpr_of_symbol s$ $str:sep$ >> -| Ulist0 s -> <:expr< Extend.TUlist0 $mlexpr_of_symbol s$ >> -| Ulist0sep (s,sep) -> <:expr< Extend.TUlist0sep $mlexpr_of_symbol s$ $str:sep$ >> -| Uopt s -> <:expr< Extend.TUopt $mlexpr_of_symbol s$ >> -| Uentry e -> - let wit = <:expr< $lid:"wit_"^e$ >> in - <:expr< Extend.TUentry (Genarg.get_arg_tag $wit$) >> -| Uentryl (e, l) -> - assert (e = "tactic"); - let wit = <:expr< $lid:"wit_"^e$ >> in - <:expr< Extend.TUentryl (Genarg.get_arg_tag $wit$) $mlexpr_of_int l$>> - let rec mlexpr_of_clause = function | [] -> <:expr< TyNil >> | ExtTerminal s :: cl -> <:expr< TyIdent($str:s$, $mlexpr_of_clause cl$) >> diff --git a/grammar/vernacextend.mlp b/grammar/vernacextend.mlp index a2872d07f6..f30c96a7f5 100644 --- a/grammar/vernacextend.mlp +++ b/grammar/vernacextend.mlp @@ -14,134 +14,42 @@ open Q_util open Argextend type rule = { - r_head : string option; - (** The first terminal grammar token *) r_patt : extend_token list; (** The remaining tokens of the parsing rule *) r_class : MLast.expr option; (** An optional classifier for the STM *) r_branch : MLast.expr; (** The action performed by this rule. *) - r_depr : unit option; + r_depr : bool; (** Whether this entry is deprecated *) } -(** Quotation difference for match clauses *) - -let default_patt loc = - (<:patt< _ >>, ploc_vala None, <:expr< failwith "Extension: cannot occur" >>) - -let make_fun loc cl = - let l = cl @ [default_patt loc] in - MLast.ExFun (loc, ploc_vala l) (* correspond to <:expr< fun [ $list:l$ ] >> *) - -let rec make_patt = function - | [] -> <:patt< [] >> - | ExtNonTerminal (_, Some p) :: l -> - <:patt< [ $lid:p$ :: $make_patt l$ ] >> - | _::l -> make_patt l - -let rec make_let e = function - | [] -> e - | ExtNonTerminal (g, Some p) :: l -> - let t = type_of_user_symbol g in - let loc = MLast.loc_of_expr e in - let e = make_let e l in - <:expr< let $lid:p$ = Genarg.out_gen $make_rawwit loc t$ $lid:p$ in $e$ >> - | _::l -> make_let e l - -let make_clause { r_patt = pt; r_branch = e; } = - (make_patt pt, - ploc_vala None, - make_let e pt) - -(* To avoid warnings *) -let mk_ignore c pt = - let fold accu = function - | ExtNonTerminal (_, Some p) -> p :: accu - | _ -> accu - in - let names = List.fold_left fold [] pt in - let fold accu id = <:expr< let _ = $lid:id$ in $accu$ >> in - let names = List.fold_left fold <:expr< () >> names in - <:expr< do { let _ = $names$ in $c$ } >> - -let make_clause_classifier cg s { r_patt = pt; r_class = c; } = - match c ,cg with - | Some c, _ -> - (make_patt pt, - ploc_vala None, - make_let (mk_ignore c pt) pt) - | None, Some cg -> - (make_patt pt, - ploc_vala None, - <:expr< fun loc -> $cg$ $str:s$ >>) - | None, None -> prerr_endline - (("Vernac entry \""^s^"\" misses a classifier. "^ - "A classifier is a function that returns an expression "^ - "of type vernac_classification (see Vernacexpr). You can: ") ^ - "- " ^ ( - ("Use '... EXTEND "^s^" CLASSIFIED AS QUERY ...' if the "^ - "new vernacular command does not alter the system state;"))^ "\n" ^ - "- " ^ ( - ("Use '... EXTEND "^s^" CLASSIFIED AS SIDEFF ...' if the "^ - "new vernacular command alters the system state but not the "^ - "parser nor it starts a proof or ends one;"))^ "\n" ^ - "- " ^ ( - ("Use '... EXTEND "^s^" CLASSIFIED BY f ...' to specify "^ - "a global function f. The function f will be called passing "^ - "\""^s^"\" as the only argument;")) ^ "\n" ^ - "- " ^ ( - "Add a specific classifier in each clause using the syntax:" - ^ "\n" ^("'[...] => [ f ] -> [...]'. "))^ "\n" ^ - ("Specific classifiers have precedence over global "^ - "classifiers. Only one classifier is called.") ^ "\n"); - (make_patt pt, - ploc_vala None, - <:expr< fun () -> ( CErrors.anomaly (Pp.str "No classification given for command " ^ s ) ) >>) - -let make_fun_clauses loc s l = - let map c = - let depr = match c.r_depr with - | None -> false - | Some () -> true - in - let cl = make_fun loc [make_clause c] in - <:expr< ($mlexpr_of_bool depr$, $cl$)>> - in - mlexpr_of_list map l - -let make_fun_classifiers loc s c l = - let cl = List.map (fun x -> make_fun loc [make_clause_classifier c s x]) l in - mlexpr_of_list (fun x -> x) cl - -let make_prod_item = function - | ExtTerminal s -> <:expr< Egramml.GramTerminal $str:s$ >> - | ExtNonTerminal (g, ido) -> - let nt = type_of_user_symbol g in - let base s = <:expr< Pcoq.genarg_grammar ($mk_extraarg loc s$) >> in - let typ = match ido with None -> None | Some _ -> Some nt in - <:expr< Egramml.GramNonTerminal ( Loc.tag ( $mlexpr_of_option (make_rawwit loc) typ$ , - $mlexpr_of_prod_entry_key base g$ ) ) >> - -let mlexpr_of_clause cl = - let mkexpr { r_head = a; r_patt = b; } = match a with - | None -> mlexpr_of_list make_prod_item b - | Some a -> mlexpr_of_list make_prod_item (ExtTerminal a :: b) - in - mlexpr_of_list mkexpr cl +let rec make_patt r = function +| [] -> r +| ExtNonTerminal (_, Some p) :: l -> <:expr< fun $lid:p$ -> $make_patt r l$ >> +| ExtNonTerminal (_, None) :: l -> <:expr< fun _ -> $make_patt r l$ >> +| ExtTerminal _ :: l -> make_patt r l + +let rec mlexpr_of_clause = function +| [] -> <:expr< Vernacentries.TyNil >> +| ExtTerminal s :: cl -> <:expr< Vernacentries.TyTerminal ($str:s$, $mlexpr_of_clause cl$) >> +| ExtNonTerminal (g, id) :: cl -> + let id = mlexpr_of_option mlexpr_of_string id in + <:expr< Vernacentries.TyNonTerminal ($id$, $mlexpr_of_symbol g$, $mlexpr_of_clause cl$) >> + +let make_rule r = + let ty = mlexpr_of_clause r.r_patt in + let cmd = make_patt r.r_branch r.r_patt in + let make_classifier c = make_patt c r.r_patt in + let classif = mlexpr_of_option make_classifier r.r_class in + <:expr< Vernacentries.TyML ($mlexpr_of_bool r.r_depr$, $ty$, $cmd$, $classif$) >> let declare_command loc s c nt cl = let se = mlexpr_of_string s in - let gl = mlexpr_of_clause cl in - let funcl = make_fun_clauses loc s cl in - let classl = make_fun_classifiers loc s c cl in + let c = mlexpr_of_option (fun x -> x) c in + let rules = mlexpr_of_list make_rule cl in declare_str_items loc - [ <:str_item< do { - CList.iteri (fun i (depr, f) -> Vernacinterp.vinterp_add depr ($se$, i) f) $funcl$; - CList.iteri (fun i f -> Vernac_classifier.declare_vernac_classifier ($se$, i) f) $classl$; - CList.iteri (fun i r -> Egramml.extend_vernac_command_grammar ($se$, i) $nt$ r) $gl$; - } >> ] + [ <:str_item< Vernacentries.vernac_extend ?{ classifier = $c$ } ~{ command = $se$ } ?{ entry = $nt$ } $rules$ >> ] open Pcaml @@ -176,38 +84,25 @@ EXTEND ] ] ; deprecation: - [ [ "DEPRECATED" -> () ] ] + [ [ -> false | "DEPRECATED" -> true ] ] ; - (* spiwack: comment-by-guessing: it seems that the isolated string - (which otherwise could have been another argument) is not passed - to the VernacExtend interpreter function to discriminate between - the clauses. *) rule: - [ [ "["; s = STRING; l = LIST0 args; "]"; - d = OPT deprecation; c = OPT classifier; "->"; "["; e = Pcaml.expr; "]" -> - let () = if s = "" then failwith "Command name is empty." in - let b = <:expr< fun ~{atts} ~{st} -> ( let () = $e$ in st ) >> in - { r_head = Some s; r_patt = l; r_class = c; r_branch = b; r_depr = d; } - | "[" ; "-" ; l = LIST1 args ; "]" ; - d = OPT deprecation; c = OPT classifier; "->"; "["; e = Pcaml.expr; "]" -> + [ [ "["; OPT "-"; l = LIST1 args; "]"; + d = deprecation; c = OPT classifier; "->"; "["; e = Pcaml.expr; "]" -> let b = <:expr< fun ~{atts} ~{st} -> ( let () = $e$ in st ) >> in - { r_head = None; r_patt = l; r_class = c; r_branch = b; r_depr = d; } + { r_patt = l; r_class = c; r_branch = b; r_depr = d; } ] ] ; + (** The [OPT "-"] argument serves no purpose nowadays, it is left here for + backward compatibility. *) fun_rule: - [ [ "["; s = STRING; l = LIST0 args; "]"; - d = OPT deprecation; c = OPT classifier; "->"; "["; e = Pcaml.expr; "]" -> - let () = if s = "" then failwith "Command name is empty." in - let b = <:expr< $e$ >> in - { r_head = Some s; r_patt = l; r_class = c; r_branch = b; r_depr = d; } - | "[" ; "-" ; l = LIST1 args ; "]" ; - d = OPT deprecation; c = OPT classifier; "->"; "["; e = Pcaml.expr; "]" -> - let b = <:expr< $e$ >> in - { r_head = None; r_patt = l; r_class = c; r_branch = b; r_depr = d; } + [ [ "["; OPT "-"; l = LIST1 args; "]"; + d = deprecation; c = OPT classifier; "->"; "["; e = Pcaml.expr; "]" -> + { r_patt = l; r_class = c; r_branch = e; r_depr = d; } ] ] ; classifier: - [ [ "=>"; "["; c = Pcaml.expr; "]" -> <:expr< fun loc -> $c$>> ] ] + [ [ "=>"; "["; c = Pcaml.expr; "]" -> <:expr< $c$>> ] ] ; args: [ [ e = LIDENT; "("; s = LIDENT; ")" -> diff --git a/ide/coq.ml b/ide/coq.ml index 63986935aa..e948360191 100644 --- a/ide/coq.ml +++ b/ide/coq.ml @@ -530,20 +530,31 @@ let break_coqtop coqtop workers = module PrintOpt = struct - type t = string list + type _ t = + | BoolOpt : string list -> bool t + | StringOpt : string list -> string t + + let opt_name (type a) : a t -> string list = function + | BoolOpt l -> l + | StringOpt l -> l + + let opt_data (type a) (key : a t) (v : a) = match key with + | BoolOpt l -> Interface.BoolValue v + | StringOpt l -> Interface.StringValue v (* Boolean options *) - let implicit = ["Printing"; "Implicit"] - let coercions = ["Printing"; "Coercions"] - let raw_matching = ["Printing"; "Matching"] - let notations = ["Printing"; "Notations"] - let all_basic = ["Printing"; "All"] - let existential = ["Printing"; "Existential"; "Instances"] - let universes = ["Printing"; "Universes"] - let unfocused = ["Printing"; "Unfocused"] + let implicit = BoolOpt ["Printing"; "Implicit"] + let coercions = BoolOpt ["Printing"; "Coercions"] + let raw_matching = BoolOpt ["Printing"; "Matching"] + let notations = BoolOpt ["Printing"; "Notations"] + let all_basic = BoolOpt ["Printing"; "All"] + let existential = BoolOpt ["Printing"; "Existential"; "Instances"] + let universes = BoolOpt ["Printing"; "Universes"] + let unfocused = BoolOpt ["Printing"; "Unfocused"] + let diff = StringOpt ["Diffs"] - type bool_descr = { opts : t list; init : bool; label : string } + type 'a descr = { opts : 'a t list; init : 'a; label : string } let bool_items = [ { opts = [implicit]; init = false; label = "Display _implicit arguments" }; @@ -561,24 +572,32 @@ struct { opts = [unfocused]; init = false; label = "Display _unfocused goals" } ] + let diff_item = { opts = [diff]; init = "off"; label = "Display _proof diffs" } + (** The current status of the boolean options *) let current_state = Hashtbl.create 11 - let set opt v = Hashtbl.replace current_state opt v + let set (type a) (opt : a t) (v : a) = + Hashtbl.replace current_state (opt_name opt) (opt_data opt v) let reset () = let init_descr d = List.iter (fun o -> set o d.init) d.opts in - List.iter init_descr bool_items + List.iter init_descr bool_items; + List.iter (fun o -> set o diff_item.init) diff_item.opts let _ = reset () - let printing_unfocused () = Hashtbl.find current_state unfocused + let printing_unfocused () = + let BoolOpt unfocused = unfocused in + match Hashtbl.find current_state unfocused with + | Interface.BoolValue b -> b + | _ -> assert false (** Transmitting options to coqtop *) let enforce h k = - let mkopt o v acc = (o, Interface.BoolValue v) :: acc in + let mkopt o v acc = (o, v) :: acc in let opts = Hashtbl.fold mkopt current_state [] in eval_call (Xmlprotocol.set_options opts) h (function diff --git a/ide/coq.mli b/ide/coq.mli index 40a6dea8d3..3af0aa697e 100644 --- a/ide/coq.mli +++ b/ide/coq.mli @@ -134,13 +134,15 @@ val stop_worker: Interface.stop_worker_sty-> Interface.stop_worker_rty query module PrintOpt : sig - type t (** Representation of an option *) + type 'a t (** Representation of an option *) - type bool_descr = { opts : t list; init : bool; label : string } + type 'a descr = { opts : 'a t list; init : 'a; label : string } - val bool_items : bool_descr list + val bool_items : bool descr list - val set : t -> bool -> unit + val diff_item : string descr + + val set : 'a t -> 'a -> unit val printing_unfocused: unit -> bool diff --git a/ide/coqide.ml b/ide/coqide.ml index aa816f2b8b..09a82ba91e 100644 --- a/ide/coqide.ml +++ b/ide/coqide.ml @@ -826,6 +826,7 @@ let refresh_notebook_pos () = let menu = GAction.add_actions let item = GAction.add_action +let radio = GAction.add_radio_action (** Toggle items in menus for printing options *) @@ -1043,7 +1044,19 @@ let build_ui () = ~callback:(fun _ -> show_toolbar#set (not show_toolbar#get)); item "Query Pane" ~label:"_Query Pane" ~accel:"F1" - ~callback:(cb_on_current_term MiscMenu.show_hide_query_pane) + ~callback:(cb_on_current_term MiscMenu.show_hide_query_pane); + GAction.group_radio_actions + ~callback:begin function + | 0 -> List.iter (fun o -> Opt.set o "off") Opt.diff_item.Opt.opts + | 1 -> List.iter (fun o -> Opt.set o "on") Opt.diff_item.Opt.opts + | 2 -> List.iter (fun o -> Opt.set o "removed") Opt.diff_item.Opt.opts + | _ -> assert false + end + [ + radio "Unset diff" 0 ~label:"Unset _Diff"; + radio "Set diff" 1 ~label:"Set Di_ff"; + radio "Set removed diff" 2 ~label:"Set _Removed Diff"; + ]; ]; toggle_items view_menu Coq.PrintOpt.bool_items; @@ -1106,15 +1119,15 @@ let build_ui () = ]; alpha_items templates_menu "Template" Coq_commands.commands; - let qitem s sc ?(dots = true) = - let query = if dots then s ^ "..." else s in + let qitem s sc = + let query = s ^ "..." in item s ~label:("_"^s) ~accel:(modifier_for_queries#get^sc) ~callback:(Query.query query) in menu queries_menu [ item "Queries" ~label:"_Queries"; - qitem "Search" "K" ~dots:false; + qitem "Search" "K"; qitem "Check" "C"; qitem "Print" "P"; qitem "About" "A"; diff --git a/ide/coqide_ui.ml b/ide/coqide_ui.ml index 717c4000f5..91c529932f 100644 --- a/ide/coqide_ui.ml +++ b/ide/coqide_ui.ml @@ -86,6 +86,10 @@ let init () = \n <menuitem action='Display universe levels' />\ \n <menuitem action='Display all low-level contents' />\ \n <menuitem action='Display unfocused goals' />\ +\n <separator/>\ +\n <menuitem action='Unset diff' />\ +\n <menuitem action='Set diff' />\ +\n <menuitem action='Set removed diff' />\ \n </menu>\ \n <menu action='Navigation'>\ \n <menuitem action='Forward' />\ diff --git a/ide/idetop.ml b/ide/idetop.ml index 965bb913ff..417ade51fd 100644 --- a/ide/idetop.ml +++ b/ide/idetop.ml @@ -211,15 +211,13 @@ let add_diffs oldp newp intf = { intf with fg_goals = { first_goal with goal_hyp = hyps_pp_list; goal_ccl = concl_pp } :: tl } let goals () = - let oldp = - try Some (Proof_global.give_me_the_proof ()) - with Proof_global.NoCurrentProof -> None in let doc = get_doc () in set_doc @@ Stm.finish ~doc; try let newp = Proof_global.give_me_the_proof () in let intf = export_pre_goals (Proof.map_structured_proof newp process_goal) in if Proof_diffs.show_diffs () then + let oldp = Stm.get_prev_proof ~doc (Stm.get_current_state ~doc) in try Some (add_diffs oldp (Some newp) intf) with Pp_diff.Diff_Failure _ -> Some intf @@ -530,9 +528,6 @@ let () = Usage.add_to_usage "coqidetop" let islave_init ~opts extra_args = let args = parse extra_args in CoqworkmgrApi.(init High); - let open Coqargs in - if not opts.diffs_set then - Proof_diffs.write_diffs_option "on"; opts, args let () = diff --git a/interp/constrexpr.ml b/interp/constrexpr.ml index 521eeb8e96..d8dd4ef6dd 100644 --- a/interp/constrexpr.ml +++ b/interp/constrexpr.ml @@ -20,7 +20,10 @@ type universe_decl_expr = (lident list, Glob_term.glob_constraint list) UState.g type ident_decl = lident * universe_decl_expr option type name_decl = lname * universe_decl_expr option -type notation = string +type notation_entry = InConstrEntry | InCustomEntry of string +type notation_entry_level = InConstrEntrySomeLevel | InCustomEntryLevel of string * int +type notation_key = string +type notation = notation_entry_level * notation_key type 'a or_by_notation_r = | AN of 'a diff --git a/interp/constrexpr_ops.ml b/interp/constrexpr_ops.ml index 4b1af9147c..011c4a6e4e 100644 --- a/interp/constrexpr_ops.ml +++ b/interp/constrexpr_ops.ml @@ -16,6 +16,7 @@ open Libnames open Namegen open Glob_term open Constrexpr +open Notation open Decl_kinds (***********************) @@ -80,7 +81,7 @@ let rec cases_pattern_expr_eq p1 p2 = | CPatOr a1, CPatOr a2 -> List.equal cases_pattern_expr_eq a1 a2 | CPatNotation (n1, s1, l1), CPatNotation (n2, s2, l2) -> - String.equal n1 n2 && + notation_eq n1 n2 && cases_pattern_notation_substitution_eq s1 s2 && List.equal cases_pattern_expr_eq l1 l2 | CPatPrim i1, CPatPrim i2 -> @@ -165,7 +166,7 @@ let rec constr_expr_eq e1 e2 = | CCast(t1,c1), CCast(t2,c2) -> constr_expr_eq t1 t2 && cast_expr_eq c1 c2 | CNotation(n1, s1), CNotation(n2, s2) -> - String.equal n1 n2 && + notation_eq n1 n2 && constr_notation_substitution_eq s1 s2 | CPrim i1, CPrim i2 -> prim_token_eq i1 i2 diff --git a/interp/constrexpr_ops.mli b/interp/constrexpr_ops.mli index 46aef1c788..61e8aa1b51 100644 --- a/interp/constrexpr_ops.mli +++ b/interp/constrexpr_ops.mli @@ -107,8 +107,8 @@ val occur_var_constr_expr : Id.t -> constr_expr -> bool val split_at_annot : local_binder_expr list -> lident option -> local_binder_expr list * local_binder_expr list -val ntn_loc : ?loc:Loc.t -> constr_notation_substitution -> string -> (int * int) list -val patntn_loc : ?loc:Loc.t -> cases_pattern_notation_substitution -> string -> (int * int) list +val ntn_loc : ?loc:Loc.t -> constr_notation_substitution -> notation -> (int * int) list +val patntn_loc : ?loc:Loc.t -> cases_pattern_notation_substitution -> notation -> (int * int) list (** For cases pattern parsing errors *) val error_invalid_pattern_notation : ?loc:Loc.t -> unit -> 'a diff --git a/interp/constrextern.ml b/interp/constrextern.ml index 2538c77722..009894fddb 100644 --- a/interp/constrextern.ml +++ b/interp/constrextern.ml @@ -101,7 +101,7 @@ let _show_inactive_notations () = IRuleSet.iter (function | NotationRule (scopt, ntn) -> - Feedback.msg_notice (str ntn ++ show_scope scopt) + Feedback.msg_notice (pr_notation ntn ++ show_scope scopt) | SynDefRule kn -> Feedback.msg_notice (str (Names.KerName.to_string kn))) !inactive_notations_table @@ -113,14 +113,14 @@ let deactivate_notation nr = | NotationRule (scopt, ntn) -> match availability_of_notation (scopt, ntn) (scopt, []) with | None -> user_err ~hdr:"Notation" - (str ntn ++ spc () ++ str "does not exist" + (pr_notation ntn ++ spc () ++ str "does not exist" ++ (match scopt with | None -> spc () ++ str "in the empty scope." | Some _ -> show_scope scopt ++ str ".")) | Some _ -> if IRuleSet.mem nr !inactive_notations_table then Feedback.msg_warning - (str "Notation" ++ spc () ++ str ntn ++ spc () + (str "Notation" ++ spc () ++ pr_notation ntn ++ spc () ++ str "is already inactive" ++ show_scope scopt ++ str ".") else inactive_notations_table := IRuleSet.add nr !inactive_notations_table @@ -131,7 +131,7 @@ let reactivate_notation nr = with Not_found -> match nr with | NotationRule (scopt, ntn) -> - Feedback.msg_warning (str "Notation" ++ spc () ++ str ntn ++ spc () + Feedback.msg_warning (str "Notation" ++ spc () ++ pr_notation ntn ++ spc () ++ str "is already active" ++ show_scope scopt ++ str ".") | SynDefRule kn -> @@ -260,6 +260,14 @@ let insert_pat_alias ?loc p = function | Anonymous -> p | Name _ as na -> CAst.make ?loc @@ CPatAlias (p,(CAst.make ?loc na)) +let rec insert_coercion ?loc l c = match l with + | [] -> c + | ntn::l -> CAst.make ?loc @@ CNotation (ntn,([insert_coercion ?loc l c],[],[],[])) + +let rec insert_pat_coercion ?loc l c = match l with + | [] -> c + | ntn::l -> CAst.make ?loc @@ CPatNotation (ntn,([insert_pat_coercion ?loc l c],[]),[]) + (**********************************************************************) (* conversion of references *) @@ -325,16 +333,16 @@ let is_zero s = in aux 0 let make_notation_gen loc ntn mknot mkprim destprim l bl = - match ntn,List.map destprim l with + match snd ntn,List.map destprim l with (* Special case to avoid writing "- 3" for e.g. (Z.opp 3) *) | "- _", [Some (Numeral (p,true))] when not (is_zero p) -> assert (bl=[]); - mknot (loc,ntn,([mknot (loc,"( _ )",l,[])]),[]) + mknot (loc,ntn,([mknot (loc,(InConstrEntrySomeLevel,"( _ )"),l,[])]),[]) | _ -> match decompose_notation_key ntn, l with - | [Terminal "-"; Terminal x], [] when is_number x -> + | (InConstrEntrySomeLevel,[Terminal "-"; Terminal x]), [] when is_number x -> mkprim (loc, Numeral (x,false)) - | [Terminal x], [] when is_number x -> + | (InConstrEntrySomeLevel,[Terminal x]), [] when is_number x -> mkprim (loc, Numeral (x,true)) | _ -> mknot (loc,ntn,l,bl) @@ -367,31 +375,39 @@ let pattern_printable_in_both_syntax (ind,_ as c) = (List.for_all is_status_implicit params)&&(List.for_all (fun x -> not (is_status_implicit x)) args) ) impl_st -let lift f c = - let loc = c.CAst.loc in - CAst.make ?loc (f ?loc (DAst.get c)) - (* Better to use extern_glob_constr composed with injection/retraction ?? *) -let rec extern_cases_pattern_in_scope (scopes:local_scopes) vars pat = +let rec extern_cases_pattern_in_scope (custom,scopes as allscopes) vars pat = try if !Flags.in_debugger || !Flags.raw_print || !print_no_symbol then raise No_match; let (na,sc,p) = uninterp_prim_token_cases_pattern pat in + match availability_of_entry_coercion custom InConstrEntrySomeLevel with + | None -> raise No_match + | Some coercion -> match availability_of_prim_token p sc scopes with | None -> raise No_match | Some key -> let loc = cases_pattern_loc pat in - insert_pat_alias ?loc (insert_pat_delimiters ?loc (CAst.make ?loc @@ CPatPrim p) key) na + insert_pat_coercion ?loc coercion + (insert_pat_alias ?loc (insert_pat_delimiters ?loc (CAst.make ?loc @@ CPatPrim p) key) na) with No_match -> try if !Flags.in_debugger || !Flags.raw_print || !print_no_symbol then raise No_match; - extern_notation_pattern scopes vars pat + extern_notation_pattern allscopes vars pat (uninterp_cases_pattern_notations pat) with No_match -> - lift (fun ?loc -> function - | PatVar (Name id) -> CPatAtom (Some (qualid_of_ident ?loc id)) - | PatVar (Anonymous) -> CPatAtom None + let loc = pat.CAst.loc in + match DAst.get pat with + | PatVar (Name id) when entry_has_ident custom -> CAst.make ?loc (CPatAtom (Some (qualid_of_ident ?loc id))) + | pat -> + match availability_of_entry_coercion custom InConstrEntrySomeLevel with + | None -> raise No_match + | Some coercion -> + let allscopes = (InConstrEntrySomeLevel,scopes) in + let pat = match pat with + | PatVar (Name id) -> CAst.make ?loc (CPatAtom (Some (qualid_of_ident ?loc id))) + | PatVar (Anonymous) -> CAst.make ?loc (CPatAtom None) | PatCstr(cstrsp,args,na) -> - let args = List.map (extern_cases_pattern_in_scope scopes vars) args in + let args = List.map (extern_cases_pattern_in_scope allscopes vars) args in let p = try if !Flags.raw_print then raise Exit; @@ -424,26 +440,32 @@ let rec extern_cases_pattern_in_scope (scopes:local_scopes) vars pat = match drop_implicits_in_patt (ConstructRef cstrsp) 0 full_args with | Some true_args -> CPatCstr (c, None, true_args) | None -> CPatCstr (c, Some full_args, []) - in (insert_pat_alias ?loc (CAst.make ?loc p) na).v - ) pat + in + insert_pat_alias ?loc (CAst.make ?loc p) na + in + insert_pat_coercion coercion pat + and apply_notation_to_pattern ?loc gr ((subst,substlist),(nb_to_drop,more_args)) - (tmp_scope, scopes as allscopes) vars = + (custom, (tmp_scope, scopes) as allscopes) vars = function | NotationRule (sc,ntn) -> begin - match availability_of_notation (sc,ntn) allscopes with + match availability_of_entry_coercion custom (fst ntn) with + | None -> raise No_match + | Some coercion -> + match availability_of_notation (sc,ntn) (tmp_scope,scopes) with (* Uninterpretation is not allowed in current context *) | None -> raise No_match (* Uninterpretation is allowed in current context *) | Some (scopt,key) -> let scopes' = Option.List.cons scopt scopes in let l = - List.map (fun (c,(scopt,scl)) -> - extern_cases_pattern_in_scope (scopt,scl@scopes') vars c) + List.map (fun (c,(subentry,(scopt,scl))) -> + extern_cases_pattern_in_scope (subentry,(scopt,scl@scopes')) vars c) subst in let ll = - List.map (fun (c,(scopt,scl)) -> - let subscope = (scopt,scl@scopes') in + List.map (fun (c,(subentry,(scopt,scl))) -> + let subscope = (subentry,(scopt,scl@scopes')) in List.map (extern_cases_pattern_in_scope subscope vars) c) substlist in let l2 = List.map (extern_cases_pattern_in_scope allscopes vars) more_args in @@ -453,14 +475,15 @@ and apply_notation_to_pattern ?loc gr ((subst,substlist),(nb_to_drop,more_args)) |Some true_args -> true_args |None -> raise No_match in - insert_pat_delimiters ?loc - (make_pat_notation ?loc ntn (l,ll) l2') key + insert_pat_coercion coercion + (insert_pat_delimiters ?loc + (make_pat_notation ?loc ntn (l,ll) l2') key) end | SynDefRule kn -> let qid = shortest_qualid_of_syndef ?loc vars kn in let l1 = - List.rev_map (fun (c,(scopt,scl)) -> - extern_cases_pattern_in_scope (scopt,scl@scopes) vars c) + List.rev_map (fun (c,(subentry,(scopt,scl))) -> + extern_cases_pattern_in_scope (subentry,(scopt,scl@scopes)) vars c) subst in let l2 = List.map (extern_cases_pattern_in_scope allscopes vars) more_args in let l2' = if !asymmetric_patterns then l2 @@ -471,7 +494,7 @@ and apply_notation_to_pattern ?loc gr ((subst,substlist),(nb_to_drop,more_args)) in assert (List.is_empty substlist); mkPat ?loc qid (List.rev_append l1 l2') -and extern_notation_pattern (tmp_scope,scopes as allscopes) vars t = function +and extern_notation_pattern allscopes vars t = function | [] -> raise No_match | (keyrule,pat,n as _rule)::rules -> try @@ -498,35 +521,38 @@ let rec extern_notation_ind_pattern allscopes vars ind args = function with No_match -> extern_notation_ind_pattern allscopes vars ind args rules -let extern_ind_pattern_in_scope (scopes:local_scopes) vars ind args = +let extern_ind_pattern_in_scope (custom,scopes as allscopes) vars ind args = (* pboutill: There are letins in pat which is incompatible with notations and not explicit application. *) if !Flags.in_debugger||Inductiveops.inductive_has_local_defs ind then let c = extern_reference vars (IndRef ind) in - let args = List.map (extern_cases_pattern_in_scope scopes vars) args in + let args = List.map (extern_cases_pattern_in_scope allscopes vars) args in CAst.make @@ CPatCstr (c, Some (add_patt_for_params ind args), []) else try if !Flags.raw_print || !print_no_symbol then raise No_match; let (sc,p) = uninterp_prim_token_ind_pattern ind args in + match availability_of_entry_coercion custom InConstrEntrySomeLevel with + | None -> raise No_match + | Some coercion -> match availability_of_prim_token p sc scopes with | None -> raise No_match | Some key -> - insert_pat_delimiters (CAst.make @@ CPatPrim p) key + insert_pat_coercion coercion (insert_pat_delimiters (CAst.make @@ CPatPrim p) key) with No_match -> try if !Flags.raw_print || !print_no_symbol then raise No_match; - extern_notation_ind_pattern scopes vars ind args + extern_notation_ind_pattern allscopes vars ind args (uninterp_ind_pattern_notations ind) with No_match -> let c = extern_reference vars (IndRef ind) in - let args = List.map (extern_cases_pattern_in_scope scopes vars) args in + let args = List.map (extern_cases_pattern_in_scope allscopes vars) args in match drop_implicits_in_patt (IndRef ind) 0 args with |Some true_args -> CAst.make @@ CPatCstr (c, None, true_args) |None -> CAst.make @@ CPatCstr (c, Some args, []) let extern_cases_pattern vars p = - extern_cases_pattern_in_scope (None,[]) vars p + extern_cases_pattern_in_scope (InConstrEntrySomeLevel,(None,[])) vars p (**********************************************************************) (* Externalising applications *) @@ -640,12 +666,12 @@ let extern_app inctx impl (cf,f) us args = else explicitize inctx impl (cf, CAst.make @@ CRef (f,us)) args -let rec fill_arg_scopes args subscopes scopes = match args, subscopes with +let rec fill_arg_scopes args subscopes (entry,(_,scopes) as all) = match args, subscopes with | [], _ -> [] | a :: args, scopt :: subscopes -> - (a, (scopt, scopes)) :: fill_arg_scopes args subscopes scopes + (a, (entry, (scopt, scopes))) :: fill_arg_scopes args subscopes all | a :: args, [] -> - (a, (None, scopes)) :: fill_arg_scopes args [] scopes + (a, (entry, (None, scopes))) :: fill_arg_scopes args [] all let extern_args extern env args = let map (arg, argscopes) = lazy (extern argscopes env arg) in @@ -697,12 +723,15 @@ let rec flatten_application c = match DAst.get c with (* mapping glob_constr to numerals (in presence of coercions, choose the *) (* one with no delimiter if possible) *) -let extern_possible_prim_token scopes r = +let extern_possible_prim_token (custom,scopes) r = try let (sc,n) = uninterp_prim_token r in + match availability_of_entry_coercion custom InConstrEntrySomeLevel with + | None -> raise No_match + | Some coercion -> match availability_of_prim_token n sc scopes with | None -> None - | Some key -> Some (insert_delimiters (CAst.make ?loc:(loc_of_glob_constr r) @@ CPrim n) key) + | Some key -> Some (insert_coercion coercion (insert_delimiters (CAst.make ?loc:(loc_of_glob_constr r) @@ CPrim n) key)) with No_match -> None @@ -737,7 +766,13 @@ let extern_glob_sort = function let extern_universes = function | Some _ as l when !print_universes -> l | _ -> None - + +let extern_ref vars ref us = + extern_global (select_stronger_impargs (implicits_of_global ref)) + (extern_reference vars ref) (extern_universes us) + +let extern_var ?loc id = CRef (qualid_of_ident ?loc id,None) + let rec extern inctx scopes vars r = let r' = remove_coercions inctx r in try @@ -748,12 +783,27 @@ let rec extern inctx scopes vars r = let r'' = flatten_application r' in if !Flags.raw_print || !print_no_symbol then raise No_match; extern_notation scopes vars r'' (uninterp_notations r'') - with No_match -> lift (fun ?loc -> function - | GRef (ref,us) -> - extern_global (select_stronger_impargs (implicits_of_global ref)) - (extern_reference vars ref) (extern_universes us) + with No_match -> + let loc = r'.CAst.loc in + match DAst.get r' with + | GRef (ref,us) when entry_has_global (fst scopes) -> CAst.make ?loc (extern_ref vars ref us) + + | GVar id when entry_has_ident (fst scopes) -> CAst.make ?loc (extern_var ?loc id) + + | c -> + + match availability_of_entry_coercion (fst scopes) InConstrEntrySomeLevel with + | None -> raise No_match + | Some coercion -> - | GVar id -> CRef (qualid_of_ident ?loc id,None) + let scopes = (InConstrEntrySomeLevel, snd scopes) in + let c = match c with + + (* The remaining cases are only for the constr entry *) + + | GRef (ref,us) -> extern_ref vars ref us + + | GVar id -> extern_var ?loc id | GEvar (n,[]) when !print_meta_as_hole -> CHole (None, IntroAnonymous, None) @@ -770,7 +820,7 @@ let rec extern inctx scopes vars r = (match DAst.get f with | GRef (ref,us) -> let subscopes = find_arguments_scope ref in - let args = fill_arg_scopes args subscopes (snd scopes) in + let args = fill_arg_scopes args subscopes scopes in begin try if !Flags.raw_print then raise Exit; @@ -921,12 +971,13 @@ let rec extern inctx scopes vars r = | GProj (p, c) -> let pr = extern_reference ?loc Id.Set.empty (ConstRef (Projection.constant p)) in CProj (pr, sub_extern inctx scopes vars c) - ) r' -and extern_typ (_,scopes) = - extern true (Notation.current_type_scope_name (),scopes) + in insert_coercion coercion (CAst.make ?loc c) + +and extern_typ (subentry,(_,scopes)) = + extern true (subentry,(Notation.current_type_scope_name (),scopes)) -and sub_extern inctx (_,scopes) = extern inctx (None,scopes) +and sub_extern inctx (subentry,(_,scopes)) = extern inctx (subentry,(None,scopes)) and factorize_prod scopes vars na bk aty c = let store, get = set_temporary_memory () in @@ -1019,7 +1070,7 @@ and extern_eqn inctx scopes vars {CAst.loc;v=(ids,pll,c)} = let pll = List.map (List.map (extern_cases_pattern_in_scope scopes vars)) pll in make ?loc (pll,extern inctx scopes vars c) -and extern_notation (tmp_scope,scopes as allscopes) vars t = function +and extern_notation (custom,scopes as allscopes) vars t = function | [] -> raise No_match | (keyrule,pat,n as _rule)::rules -> let loc = Glob_ops.loc_of_glob_constr t in @@ -1066,40 +1117,43 @@ and extern_notation (tmp_scope,scopes as allscopes) vars t = function let e = match keyrule with | NotationRule (sc,ntn) -> - (match availability_of_notation (sc,ntn) allscopes with + (match availability_of_entry_coercion custom (fst ntn) with + | None -> raise No_match + | Some coercion -> + match availability_of_notation (sc,ntn) scopes with (* Uninterpretation is not allowed in current context *) | None -> raise No_match (* Uninterpretation is allowed in current context *) | Some (scopt,key) -> - let scopes' = Option.List.cons scopt scopes in + let scopes' = Option.List.cons scopt (snd scopes) in let l = - List.map (fun (c,(scopt,scl)) -> + List.map (fun (c,(subentry,(scopt,scl))) -> extern (* assuming no overloading: *) true - (scopt,scl@scopes') vars c) + (subentry,(scopt,scl@scopes')) vars c) terms in let ll = - List.map (fun (c,(scopt,scl)) -> - List.map (extern true (scopt,scl@scopes') vars) c) + List.map (fun (c,(subentry,(scopt,scl))) -> + List.map (extern true (subentry,(scopt,scl@scopes')) vars) c) termlists in let bl = - List.map (fun (bl,(scopt,scl)) -> - mkCPatOr (List.map (extern_cases_pattern_in_scope (scopt,scl@scopes') vars) bl)) + List.map (fun (bl,(subentry,(scopt,scl))) -> + mkCPatOr (List.map (extern_cases_pattern_in_scope (subentry,(scopt,scl@scopes')) vars) bl)) binders in let bll = - List.map (fun (bl,(scopt,scl)) -> - pi3 (extern_local_binder (scopt,scl@scopes') vars bl)) + List.map (fun (bl,(subentry,(scopt,scl))) -> + pi3 (extern_local_binder (subentry,(scopt,scl@scopes')) vars bl)) binderlists in - insert_delimiters (make_notation loc ntn (l,ll,bl,bll)) key) + insert_coercion coercion (insert_delimiters (make_notation loc ntn (l,ll,bl,bll)) key)) | SynDefRule kn -> let l = - List.map (fun (c,(scopt,scl)) -> - extern true (scopt,scl@scopes) vars c, None) + List.map (fun (c,(subentry,(scopt,scl))) -> + extern true (subentry,(scopt,scl@snd scopes)) vars c, None) terms in let a = CRef (shortest_qualid_of_syndef ?loc vars kn,None) in CAst.make ?loc @@ if List.is_empty l then a else CApp ((None, CAst.make a),l) in if List.is_empty args then e else - let args = fill_arg_scopes args argsscopes scopes in + let args = fill_arg_scopes args argsscopes allscopes in let args = extern_args (extern true) vars args in CAst.make ?loc @@ explicitize false argsimpls (None,e) args with @@ -1113,10 +1167,10 @@ and extern_recursion_order scopes vars = function let extern_glob_constr vars c = - extern false (None,[]) vars c + extern false (InConstrEntrySomeLevel,(None,[])) vars c let extern_glob_type vars c = - extern_typ (None,[]) vars c + extern_typ (InConstrEntrySomeLevel,(None,[])) vars c (******************************************************************) (* Main translation function from constr -> constr_expr *) @@ -1132,7 +1186,7 @@ let extern_constr_gen lax goal_concl_style scopt env sigma t = let avoid = if goal_concl_style then vars_of_env env else Id.Set.empty in let r = Detyping.detype Detyping.Later ~lax:lax goal_concl_style avoid env sigma t in let vars = vars_of_env env in - extern false (scopt,[]) vars r + extern false (InConstrEntrySomeLevel,(scopt,[])) vars r let extern_constr_in_scope goal_concl_style scope env sigma t = extern_constr_gen false goal_concl_style (Some scope) env sigma t @@ -1153,7 +1207,7 @@ let extern_closed_glob ?lax goal_concl_style env sigma t = Detyping.detype_closed_glob ?lax goal_concl_style avoid env sigma t in let vars = vars_of_env env in - extern false (None,[]) vars r + extern false (InConstrEntrySomeLevel,(None,[])) vars r (******************************************************************) (* Main translation function from pattern -> constr_expr *) @@ -1262,10 +1316,10 @@ let rec glob_of_pat avoid env sigma pat = DAst.make @@ match pat with | PSort s -> GSort s let extern_constr_pattern env sigma pat = - extern true (None,[]) Id.Set.empty (glob_of_pat Id.Set.empty env sigma pat) + extern true (InConstrEntrySomeLevel,(None,[])) Id.Set.empty (glob_of_pat Id.Set.empty env sigma pat) let extern_rel_context where env sigma sign = let a = detype_rel_context Detyping.Later where Id.Set.empty (names_of_rel_context env,env) sigma sign in let vars = vars_of_env env in let a = List.map (extended_glob_local_binder_of_decl) a in - pi3 (extern_local_binder (None,[]) vars a) + pi3 (extern_local_binder (InConstrEntrySomeLevel,(None,[])) vars a) diff --git a/interp/constrintern.ml b/interp/constrintern.ml index 715823e5d0..1c8d957014 100644 --- a/interp/constrintern.ml +++ b/interp/constrintern.ml @@ -218,30 +218,36 @@ let expand_notation_string ntn n = (* This contracts the special case of "{ _ }" for sumbool, sumor notations *) (* Remark: expansion of squash at definition is done in metasyntax.ml *) let contract_curly_brackets ntn (l,ll,bl,bll) = + match ntn with + | InCustomEntryLevel _,_ -> ntn,(l,ll,bl,bll) + | InConstrEntrySomeLevel, ntn -> let ntn' = ref ntn in let rec contract_squash n = function | [] -> [] - | { CAst.v = CNotation ("{ _ }",([a],[],[],[])) } :: l -> + | { CAst.v = CNotation ((InConstrEntrySomeLevel,"{ _ }"),([a],[],[],[])) } :: l -> ntn' := expand_notation_string !ntn' n; contract_squash n (a::l) | a :: l -> a::contract_squash (n+1) l in let l = contract_squash 0 l in (* side effect; don't inline *) - !ntn',(l,ll,bl,bll) + (InConstrEntrySomeLevel,!ntn'),(l,ll,bl,bll) let contract_curly_brackets_pat ntn (l,ll) = + match ntn with + | InCustomEntryLevel _,_ -> ntn,(l,ll) + | InConstrEntrySomeLevel, ntn -> let ntn' = ref ntn in let rec contract_squash n = function | [] -> [] - | { CAst.v = CPatNotation ("{ _ }",([a],[]),[]) } :: l -> + | { CAst.v = CPatNotation ((InConstrEntrySomeLevel,"{ _ }"),([a],[]),[]) } :: l -> ntn' := expand_notation_string !ntn' n; contract_squash n (a::l) | a :: l -> a::contract_squash (n+1) l in let l = contract_squash 0 l in (* side effect; don't inline *) - !ntn',(l,ll) + (InConstrEntrySomeLevel,!ntn'),(l,ll) type intern_env = { ids: Names.Id.Set.t; @@ -819,7 +825,7 @@ let split_by_type ids subst = | [] -> assert false | a::l -> l, Id.Map.add id (a,scl) s in let (terms,termlists,binders,binderlists),subst = - List.fold_left (fun ((terms,termlists,binders,binderlists),(terms',termlists',binders',binderlists')) (id,(scl,typ)) -> + List.fold_left (fun ((terms,termlists,binders,binderlists),(terms',termlists',binders',binderlists')) (id,((_,scl),typ)) -> match typ with | NtnTypeConstr -> let terms,terms' = bind id scl terms terms' in @@ -847,10 +853,10 @@ let split_by_type ids subst = subst let split_by_type_pat ?loc ids subst = - let bind id scl l s = + let bind id (_,scopes) l s = match l with | [] -> assert false - | a::l -> l, Id.Map.add id (a,scl) s in + | a::l -> l, Id.Map.add id (a,scopes) s in let (terms,termlists),subst = List.fold_left (fun ((terms,termlists),(terms',termlists')) (id,(scl,typ)) -> match typ with @@ -866,7 +872,7 @@ let split_by_type_pat ?loc ids subst = subst let make_subst ids l = - let fold accu (id, scl) a = Id.Map.add id (a, scl) accu in + let fold accu (id, scopes) a = Id.Map.add id (a, scopes) accu in List.fold_left2 fold Id.Map.empty ids l let intern_notation intern env ntnvars loc ntn fullargs = @@ -1555,11 +1561,11 @@ let drop_notations_pattern looked_for genv = (* but not scopes in expl_pl *) let (argscs1,_) = find_remaining_scopes expl_pl pl g in DAst.make ?loc @@ RCPatCstr (g, List.map2 (in_pat_sc scopes) argscs1 expl_pl @ List.map (in_pat false scopes) pl, []) - | CPatNotation ("- _",([a],[]),[]) when is_non_zero_pat a -> + | CPatNotation ((InConstrEntrySomeLevel,"- _"),([a],[]),[]) when is_non_zero_pat a -> let p = match a.CAst.v with CPatPrim (Numeral (p, _)) -> p | _ -> assert false in let pat, _df = Notation.interp_prim_token_cases_pattern_expr ?loc (ensure_kind false loc) (Numeral (p,false)) scopes in rcp_of_glob scopes pat - | CPatNotation ("( _ )",([a],[]),[]) -> + | CPatNotation ((InConstrEntrySomeLevel,"( _ )"),([a],[]),[]) -> in_pat top scopes a | CPatNotation (ntn,fullargs,extrargs) -> let ntn,(terms,termlists) = contract_curly_brackets_pat ntn fullargs in @@ -1872,10 +1878,10 @@ let internalize globalenv env pattern_mode (_, ntnvars as lvar) c = DAst.make ?loc @@ GLetIn (na.CAst.v, inc1, int, intern (push_name_env ntnvars (impls_term_list inc1) env na) c2) - | CNotation ("- _", ([a],[],[],[])) when is_non_zero a -> + | CNotation ((InConstrEntrySomeLevel,"- _"), ([a],[],[],[])) when is_non_zero a -> let p = match a.CAst.v with CPrim (Numeral (p, _)) -> p | _ -> assert false in intern env (CAst.make ?loc @@ CPrim (Numeral (p,false))) - | CNotation ("( _ )",([a],[],[],[])) -> intern env a + | CNotation ((InConstrEntrySomeLevel,"( _ )"),([a],[],[],[])) -> intern env a | CNotation (ntn,args) -> intern_notation intern env ntnvars loc ntn args | CGeneralization (b,a,c) -> diff --git a/interp/declare.ml b/interp/declare.ml index 0222aeb283..2b2ca36edc 100644 --- a/interp/declare.ml +++ b/interp/declare.ml @@ -471,24 +471,20 @@ let assumption_message id = discussion on coqdev: "Chapter 4 of the Reference Manual", 8/10/2015) *) Flags.if_verbose Feedback.msg_info (Id.print id ++ str " is declared") -(** Global universe names, in a different summary *) +(** Monomorphic universes need to survive sections. *) -type universe_context_decl = polymorphic * Univ.ContextSet.t - -let cache_universe_context (p, ctx) = - Global.push_context_set p ctx; - if p then Lib.add_section_context ctx - -let input_universe_context : universe_context_decl -> Libobject.obj = +let input_universe_context : Univ.ContextSet.t -> Libobject.obj = declare_object - { (default_object "Global universe context state") with - cache_function = (fun (na, pi) -> cache_universe_context pi); - load_function = (fun _ (_, pi) -> cache_universe_context pi); - discharge_function = (fun (_, (p, _ as x)) -> if p then None else Some x); - classify_function = (fun a -> Keep a) } + { (default_object "Monomorphic section universes") with + cache_function = (fun (na, uctx) -> Global.push_context_set false uctx); + discharge_function = (fun (_, x) -> Some x); + classify_function = (fun a -> Dispose) } let declare_universe_context poly ctx = - Lib.add_anonymous_leaf (input_universe_context (poly, ctx)) + if poly then + (Global.push_context_set true ctx; Lib.add_section_context ctx) + else + Lib.add_anonymous_leaf (input_universe_context ctx) (** Global universes are not substitutive objects but global objects bound at the *library* or *module* level. The polymorphic flag is @@ -597,27 +593,8 @@ let do_universe poly l = ignore(Lib.add_leaf id (input_universe (src, lev)))) l -type constraint_decl = polymorphic * Univ.Constraint.t - -let cache_constraints (na, (p, c)) = - let ctx = - Univ.ContextSet.add_constraints c - Univ.ContextSet.empty (* No declared universes here, just constraints *) - in cache_universe_context (p,ctx) - -let discharge_constraints (_, (p, c as a)) = - if p then None else Some a - -let input_constraints : constraint_decl -> Libobject.obj = - let open Libobject in - declare_object - { (default_object "Global universe constraints") with - cache_function = cache_constraints; - load_function = (fun _ -> cache_constraints); - discharge_function = discharge_constraints; - classify_function = (fun a -> Keep a) } - let do_constraint poly l = + let open Univ in let u_of_id x = let level = Pretyping.interp_known_glob_level (Evd.from_env (Global.env ())) x in UnivNames.is_polymorphic level, level @@ -639,7 +616,8 @@ let do_constraint poly l = let constraints = List.fold_left (fun acc (l, d, r) -> let p, lu = u_of_id l and p', ru = u_of_id r in check_poly p p'; - Univ.Constraint.add (lu, d, ru) acc) - Univ.Constraint.empty l + Constraint.add (lu, d, ru) acc) + Constraint.empty l in - Lib.add_anonymous_leaf (input_constraints (poly, constraints)) + let uctx = ContextSet.add_constraints constraints ContextSet.empty in + declare_universe_context poly uctx diff --git a/interp/dumpglob.ml b/interp/dumpglob.ml index 5bf46282fd..ccad6b19eb 100644 --- a/interp/dumpglob.ml +++ b/interp/dumpglob.ml @@ -167,7 +167,7 @@ let dump_modref ?loc mp ty = let dump_libref ?loc dp ty = dump_ref ?loc (Names.DirPath.to_string dp) "<>" "<>" ty -let cook_notation df sc = +let cook_notation (from,df) sc = (* We encode notations so that they are space-free and still human-readable *) (* - all spaces are replaced by _ *) (* - all _ denoting a non-terminal symbol are replaced by x *) @@ -203,7 +203,9 @@ let cook_notation df sc = if !i <= l then (set ntn !j '_'; incr j; incr i) done; let df = Bytes.sub_string ntn 0 !j in - match sc with Some sc -> ":" ^ sc ^ ":" ^ df | _ -> "::" ^ df + let df_sc = match sc with Some sc -> ":" ^ sc ^ ":" ^ df | _ -> "::" ^ df in + let from_df_sc = match from with Constrexpr.InCustomEntryLevel (from,_) -> ":" ^ from ^ df_sc | Constrexpr.InConstrEntrySomeLevel -> ":" ^ df_sc in + from_df_sc let dump_notation_location posl df (((path,secpath),_),sc) = if dump () then diff --git a/interp/implicit_quantifiers.ml b/interp/implicit_quantifiers.ml index 288a0bfe00..4f3037b1fc 100644 --- a/interp/implicit_quantifiers.ml +++ b/interp/implicit_quantifiers.ml @@ -98,7 +98,7 @@ let free_vars_of_constr_expr c ?(bound=Id.Set.empty) l = let rec aux bdvars l c = match CAst.(c.v) with | CRef (qid,_) when qualid_is_ident qid -> found c.CAst.loc (qualid_basename qid) bdvars l - | CNotation ("{ _ : _ | _ }", ({ CAst.v = CRef (qid,_) } :: _, [], [], [])) when + | CNotation ((InConstrEntrySomeLevel,"{ _ : _ | _ }"), ({ CAst.v = CRef (qid,_) } :: _, [], [], [])) when qualid_is_ident qid && not (Id.Set.mem (qualid_basename qid) bdvars) -> Constrexpr_ops.fold_constr_expr_with_binders (fun a l -> Id.Set.add a l) aux (Id.Set.add (qualid_basename qid) bdvars) l c | _ -> Constrexpr_ops.fold_constr_expr_with_binders (fun a l -> Id.Set.add a l) aux bdvars l c diff --git a/interp/notation.ml b/interp/notation.ml index 05fcd0e7f5..625d072b9f 100644 --- a/interp/notation.ml +++ b/interp/notation.ml @@ -39,6 +39,30 @@ open Context.Named.Declaration expression, set this scope to be the current scope *) +let notation_entry_eq s1 s2 = match (s1,s2) with +| InConstrEntry, InConstrEntry -> true +| InCustomEntry s1, InCustomEntry s2 -> String.equal s1 s2 +| (InConstrEntry | InCustomEntry _), _ -> false + +let notation_entry_level_eq s1 s2 = match (s1,s2) with +| InConstrEntrySomeLevel, InConstrEntrySomeLevel -> true +| InCustomEntryLevel (s1,n1), InCustomEntryLevel (s2,n2) -> String.equal s1 s2 && n1 = n2 +| (InConstrEntrySomeLevel | InCustomEntryLevel _), _ -> false + +let notation_eq (from1,ntn1) (from2,ntn2) = + notation_entry_level_eq from1 from2 && String.equal ntn1 ntn2 + +let pr_notation (from,ntn) = qstring ntn ++ match from with InConstrEntrySomeLevel -> mt () | InCustomEntryLevel (s,n) -> str " in custom " ++ str s + +module NotationOrd = + struct + type t = notation + let compare = Pervasives.compare + end + +module NotationSet = Set.Make(NotationOrd) +module NotationMap = CMap.Make(NotationOrd) + (**********************************************************************) (* Scope of symbols *) @@ -51,7 +75,7 @@ type notation_data = { } type scope = { - notations: notation_data String.Map.t; + notations: notation_data NotationMap.t; delimiters: delimiters option } @@ -62,7 +86,7 @@ let scope_map = ref String.Map.empty let delimiters_map = ref String.Map.empty let empty_scope = { - notations = String.Map.empty; + notations = NotationMap.empty; delimiters = None } @@ -71,6 +95,9 @@ let default_scope = "" (* empty name, not available from outside *) let init_scope_map () = scope_map := String.Map.add default_scope empty_scope !scope_map +(**********************************************************************) +(* Operations on scopes *) + let declare_scope scope = try let _ = String.Map.find scope !scope_map in () with Not_found -> @@ -101,12 +128,12 @@ let normalize_scope sc = (**********************************************************************) (* The global stack of scopes *) -type scope_elem = Scope of scope_name | SingleNotation of string +type scope_elem = Scope of scope_name | SingleNotation of notation type scopes = scope_elem list let scope_eq s1 s2 = match s1, s2 with -| Scope s1, Scope s2 -| SingleNotation s1, SingleNotation s2 -> String.equal s1 s2 +| Scope s1, Scope s2 -> String.equal s1 s2 +| SingleNotation s1, SingleNotation s2 -> notation_eq s1 s2 | Scope _, SingleNotation _ | SingleNotation _, Scope _ -> false @@ -158,8 +185,6 @@ let push_scope sc scopes = Scope sc :: scopes let push_scopes = List.fold_right push_scope -type local_scopes = tmp_scope_name option * scope_name list - let make_current_scopes (tmp_scope,scopes) = Option.fold_right push_scope tmp_scope (push_scopes scopes !scope_stack) @@ -376,7 +401,7 @@ let rec find_without_delimiters find (ntn_scope,ntn) = function end | SingleNotation ntn' :: scopes -> begin match ntn_scope, ntn with - | None, Some ntn when String.equal ntn ntn' -> + | None, Some ntn when notation_eq ntn ntn' -> Some (None, None) | _ -> find_without_delimiters find (ntn_scope,ntn) scopes @@ -390,7 +415,7 @@ let rec find_without_delimiters find (ntn_scope,ntn) = function let warn_notation_overridden = CWarnings.create ~name:"notation-overridden" ~category:"parsing" (fun (ntn,which_scope) -> - str "Notation" ++ spc () ++ str ntn ++ spc () + str "Notation" ++ spc () ++ pr_notation ntn ++ spc () ++ strbrk "was already used" ++ which_scope ++ str ".") let declare_notation_interpretation ntn scopt pat df ~onlyprint = @@ -398,7 +423,7 @@ let declare_notation_interpretation ntn scopt pat df ~onlyprint = let sc = find_scope scope in if not onlyprint then begin let () = - if String.Map.mem ntn sc.notations then + if NotationMap.mem ntn sc.notations then let which_scope = match scopt with | None -> mt () | Some _ -> spc () ++ strbrk "in scope" ++ spc () ++ str scope in @@ -408,7 +433,7 @@ let declare_notation_interpretation ntn scopt pat df ~onlyprint = not_interp = pat; not_location = df; } in - let sc = { sc with notations = String.Map.add ntn notdata sc.notations } in + let sc = { sc with notations = NotationMap.add ntn notdata sc.notations } in scope_map := String.Map.add scope sc !scope_map end; begin match scopt with @@ -425,7 +450,7 @@ let rec find_interpretation ntn find = function | Scope scope :: scopes -> (try let (pat,df) = find scope in pat,(df,Some scope) with Not_found -> find_interpretation ntn find scopes) - | SingleNotation ntn'::scopes when String.equal ntn' ntn -> + | SingleNotation ntn'::scopes when notation_eq ntn' ntn -> (try let (pat,df) = find default_scope in pat,(df,None) with Not_found -> (* e.g. because single notation only for constr, not cases_pattern *) @@ -434,12 +459,12 @@ let rec find_interpretation ntn find = function find_interpretation ntn find scopes let find_notation ntn sc = - let n = String.Map.find ntn (find_scope sc).notations in + let n = NotationMap.find ntn (find_scope sc).notations in (n.not_interp, n.not_location) let notation_of_prim_token = function - | Numeral (n,true) -> n - | Numeral (n,false) -> "- "^n + | Numeral (n,true) -> InConstrEntrySomeLevel, n + | Numeral (n,false) -> InConstrEntrySomeLevel, "- "^n | String _ -> raise Not_found let find_prim_token check_allowed ?loc p sc = @@ -459,13 +484,13 @@ let find_prim_token check_allowed ?loc p sc = let interp_prim_token_gen ?loc g p local_scopes = let scopes = make_current_scopes local_scopes in - let p_as_ntn = try notation_of_prim_token p with Not_found -> "" in + let p_as_ntn = try notation_of_prim_token p with Not_found -> InConstrEntrySomeLevel,"" in try find_interpretation p_as_ntn (find_prim_token ?loc g p) scopes with Not_found -> user_err ?loc ~hdr:"interp_prim_token" ((match p with | Numeral _ -> - str "No interpretation for numeral " ++ str (notation_of_prim_token p) + str "No interpretation for numeral " ++ pr_notation (notation_of_prim_token p) | String s -> str "No interpretation for string " ++ qs s) ++ str ".") let interp_prim_token ?loc = @@ -490,7 +515,7 @@ let interp_notation ?loc ntn local_scopes = try find_interpretation ntn (find_notation ntn) scopes with Not_found -> user_err ?loc - (str "Unknown interpretation for notation \"" ++ str ntn ++ str "\".") + (str "Unknown interpretation for notation " ++ pr_notation ntn ++ str ".") let uninterp_notations c = List.map_append (fun key -> keymap_find key !notations_key_table) @@ -504,9 +529,125 @@ let uninterp_ind_pattern_notations ind = let availability_of_notation (ntn_scope,ntn) scopes = let f scope = - String.Map.mem ntn (String.Map.find scope !scope_map).notations in + NotationMap.mem ntn (String.Map.find scope !scope_map).notations in find_without_delimiters f (ntn_scope,Some ntn) (make_current_scopes scopes) +(* We support coercions from a custom entry at some level to an entry + at some level (possibly the same), and from and to the constr entry. E.g.: + + Notation "[ expr ]" := expr (expr custom group at level 1). + Notation "( x )" := x (in custom group at level 0, x at level 1). + Notation "{ x }" := x (in custom group at level 0, x constr). + + Supporting any level is maybe overkill in that coercions are + commonly from the lowest level of the source entry to the highest + level of the target entry. *) + +type entry_coercion = notation list + +module EntryCoercionOrd = + struct + type t = notation_entry * notation_entry + let compare = Pervasives.compare + end + +module EntryCoercionMap = Map.Make(EntryCoercionOrd) + +let entry_coercion_map = ref EntryCoercionMap.empty + +let level_ord lev lev' = + match lev, lev' with + | None, _ -> true + | _, None -> true + | Some n, Some n' -> n <= n' + +let rec search nfrom nto = function + | [] -> raise Not_found + | ((pfrom,pto),coe)::l -> + if level_ord pfrom nfrom && level_ord nto pto then coe else search nfrom nto l + +let decompose_custom_entry = function + | InConstrEntrySomeLevel -> InConstrEntry, None + | InCustomEntryLevel (s,n) -> InCustomEntry s, Some n + +let availability_of_entry_coercion entry entry' = + let entry, lev = decompose_custom_entry entry in + let entry', lev' = decompose_custom_entry entry' in + if notation_entry_eq entry entry' && level_ord lev' lev then Some [] + else + try Some (search lev lev' (EntryCoercionMap.find (entry,entry') !entry_coercion_map)) + with Not_found -> None + +let better_path ((lev1,lev2),path) ((lev1',lev2'),path') = + (* better = shorter and lower source and higher target *) + level_ord lev1 lev1' && level_ord lev2' lev2 && List.length path <= List.length path' + +let shorter_path (_,path) (_,path') = + List.length path <= List.length path' + +let rec insert_coercion_path path = function + | [] -> [path] + | path'::paths as allpaths -> + (* If better or equal we keep the more recent one *) + if better_path path path' then path::paths + else if better_path path' path then allpaths + else if shorter_path path path' then path::allpaths + else path'::insert_coercion_path path paths + +let declare_entry_coercion (entry,_ as ntn) entry' = + let entry, lev = decompose_custom_entry entry in + let entry', lev' = decompose_custom_entry entry' in + (* Transitive closure *) + let toaddleft = + EntryCoercionMap.fold (fun (entry'',entry''') paths l -> + List.fold_right (fun ((lev'',lev'''),path) l -> + if notation_entry_eq entry entry''' && level_ord lev lev''' && + not (notation_entry_eq entry' entry'') + then ((entry'',entry'),((lev'',lev'),path@[ntn]))::l else l) paths l) + !entry_coercion_map [] in + let toaddright = + EntryCoercionMap.fold (fun (entry'',entry''') paths l -> + List.fold_right (fun ((lev'',lev'''),path) l -> + if entry' = entry'' && level_ord lev' lev'' && entry <> entry''' + then ((entry,entry'''),((lev,lev'''),path@[ntn]))::l else l) paths l) + !entry_coercion_map [] in + entry_coercion_map := + List.fold_right (fun (pair,path) -> + let olds = try EntryCoercionMap.find pair !entry_coercion_map with Not_found -> [] in + EntryCoercionMap.add pair (insert_coercion_path path olds)) + (((entry,entry'),((lev,lev'),[ntn]))::toaddright@toaddleft) + !entry_coercion_map + +let entry_has_global_map = ref String.Map.empty + +let declare_custom_entry_has_global s n = + try + let p = String.Map.find s !entry_has_global_map in + user_err (str "Custom entry " ++ str s ++ + str " has already a rule for global references at level " ++ int p ++ str ".") + with Not_found -> + entry_has_global_map := String.Map.add s n !entry_has_global_map + +let entry_has_global = function + | InConstrEntrySomeLevel -> true + | InCustomEntryLevel (s,n) -> + try String.Map.find s !entry_has_global_map <= n with Not_found -> false + +let entry_has_ident_map = ref String.Map.empty + +let declare_custom_entry_has_ident s n = + try + let p = String.Map.find s !entry_has_ident_map in + user_err (str "Custom entry " ++ str s ++ + str " has already a rule for global references at level " ++ int p ++ str ".") + with Not_found -> + entry_has_ident_map := String.Map.add s n !entry_has_ident_map + +let entry_has_ident = function + | InConstrEntrySomeLevel -> true + | InCustomEntryLevel (s,n) -> + try String.Map.find s !entry_has_ident_map <= n with Not_found -> false + let uninterp_prim_token c = try let (sc,numpr,_) = @@ -565,7 +706,8 @@ let ntpe_eq t1 t2 = match t1, t2 with | NtnTypeBinderList, NtnTypeBinderList -> true | (NtnTypeConstr | NtnTypeBinder _ | NtnTypeConstrList | NtnTypeBinderList), _ -> false -let var_attributes_eq (_, (sc1, tp1)) (_, (sc2, tp2)) = +let var_attributes_eq (_, ((entry1, sc1), tp1)) (_, ((entry2, sc2), tp2)) = + notation_entry_level_eq entry1 entry2 && pair_eq (Option.equal String.equal) (List.equal String.equal) sc1 sc2 && ntpe_eq tp1 tp2 @@ -577,7 +719,7 @@ let exists_notation_in_scope scopt ntn onlyprint r = let scope = match scopt with Some s -> s | None -> default_scope in try let sc = String.Map.find scope !scope_map in - let n = String.Map.find ntn sc.notations in + let n = NotationMap.find ntn sc.notations in interpretation_eq n.not_interp r with Not_found -> false @@ -793,10 +935,10 @@ let rec string_of_symbol = function let l = List.flatten (List.map string_of_symbol l) in "_"::l@".."::l@["_"] | Break _ -> [] -let make_notation_key symbols = - String.concat " " (List.flatten (List.map string_of_symbol symbols)) +let make_notation_key from symbols = + (from,String.concat " " (List.flatten (List.map string_of_symbol symbols))) -let decompose_notation_key s = +let decompose_notation_key (from,s) = let len = String.length s in let rec decomp_ntn dirs n = if n>=len then List.rev dirs else @@ -811,7 +953,7 @@ let decompose_notation_key s = | s -> Terminal (String.drop_simple_quotes s) in decomp_ntn (tok::dirs) (pos+1) in - decomp_ntn [] 0 + from, decomp_ntn [] 0 (************) (* Printing *) @@ -840,14 +982,14 @@ let pr_notation_info prglob ntn c = let pr_named_scope prglob scope sc = (if String.equal scope default_scope then - match String.Map.cardinal sc.notations with + match NotationMap.cardinal sc.notations with | 0 -> str "No lonely notation" | n -> str "Lonely notation" ++ (if Int.equal n 1 then mt() else str"s") else str "Scope " ++ str scope ++ fnl () ++ pr_delimiters_info sc.delimiters) ++ fnl () ++ pr_scope_classes scope - ++ String.Map.fold + ++ NotationMap.fold (fun ntn { not_interp = (_, r); not_location = (_, df) } strm -> pr_notation_info prglob df r ++ fnl () ++ strm) sc.notations (mt ()) @@ -862,11 +1004,11 @@ let pr_scopes prglob = let rec find_default ntn = function | [] -> None | Scope scope :: scopes -> - if String.Map.mem ntn (find_scope scope).notations then + if NotationMap.mem ntn (find_scope scope).notations then Some scope else find_default ntn scopes | SingleNotation ntn' :: scopes -> - if String.equal ntn ntn' then Some default_scope + if notation_eq ntn ntn' then Some default_scope else find_default ntn scopes let factorize_entries = function @@ -875,7 +1017,7 @@ let factorize_entries = function let (ntn,l_of_ntn,rest) = List.fold_left (fun (a',l,rest) (a,c) -> - if String.equal a a' then (a',c::l,rest) else (a,[c],(a',l)::rest)) + if notation_eq a a' then (a',c::l,rest) else (a,[c],(a',l)::rest)) (ntn,[c],[]) l in (ntn,l_of_ntn)::rest @@ -930,15 +1072,15 @@ let possible_notations ntn = (* Only "_ U _" format *) [ntn] else - let ntn' = make_notation_key (raw_analyze_notation_tokens toks) in + let _,ntn' = make_notation_key None (raw_analyze_notation_tokens toks) in if String.equal ntn ntn' then (* Only symbols *) [ntn] else [ntn;ntn'] let browse_notation strict ntn map = let ntns = possible_notations ntn in - let find ntn' ntn = + let find (from,ntn' as fullntn') ntn = if String.contains ntn ' ' then String.equal ntn ntn' else - let toks = decompose_notation_key ntn' in + let _,toks = decompose_notation_key fullntn' in let get_terminals = function Terminal ntn -> Some ntn | _ -> None in let trms = List.map_filter get_terminals toks in if strict then String.List.equal [ntn] trms @@ -947,10 +1089,10 @@ let browse_notation strict ntn map = let l = String.Map.fold (fun scope_name sc -> - String.Map.fold (fun ntn { not_interp = (_, r); not_location = df } l -> + NotationMap.fold (fun ntn { not_interp = (_, r); not_location = df } l -> if List.exists (find ntn) ntns then (ntn,(scope_name,r,df))::l else l) sc.notations) map [] in - List.sort (fun x y -> String.compare (fst x) (fst y)) l + List.sort (fun x y -> String.compare (snd (fst x)) (snd (fst y))) l let global_reference_of_notation test (ntn,(sc,c,_)) = match c with @@ -1011,9 +1153,9 @@ let locate_notation prglob ntn scope = let collect_notation_in_scope scope sc known = assert (not (String.equal scope default_scope)); - String.Map.fold + NotationMap.fold (fun ntn { not_interp = (_, r); not_location = (_, df) } (l,known as acc) -> - if String.List.mem ntn known then acc else ((df,r)::l,ntn::known)) + if List.mem_f notation_eq ntn known then acc else ((df,r)::l,ntn::known)) sc.notations ([],known) let collect_notations stack = @@ -1026,10 +1168,10 @@ let collect_notations stack = collect_notation_in_scope scope (find_scope scope) knownntn in ((scope,l)::all,knownntn) | SingleNotation ntn -> - if String.List.mem ntn knownntn then (all,knownntn) + if List.mem_f notation_eq ntn knownntn then (all,knownntn) else let { not_interp = (_, r); not_location = (_, df) } = - String.Map.find ntn (find_scope default_scope).notations in + NotationMap.find ntn (find_scope default_scope).notations in let all' = match all with | (s,lonelyntn)::rest when String.equal s default_scope -> (s,(df,r)::lonelyntn)::rest @@ -1063,15 +1205,20 @@ let pr_visibility prglob = function let freeze _ = (!scope_map, !scope_stack, !arguments_scope, - !delimiters_map, !notations_key_table, !scope_class_map) + !delimiters_map, !notations_key_table, !scope_class_map, + !entry_coercion_map, !entry_has_global_map, + !entry_has_ident_map) -let unfreeze (scm,scs,asc,dlm,fkm,clsc) = +let unfreeze (scm,scs,asc,dlm,fkm,clsc,coe,globs,ids) = scope_map := scm; scope_stack := scs; delimiters_map := dlm; arguments_scope := asc; notations_key_table := fkm; - scope_class_map := clsc + scope_class_map := clsc; + entry_coercion_map := coe; + entry_has_global_map := globs; + entry_has_ident_map := ids let init () = init_scope_map (); diff --git a/interp/notation.mli b/interp/notation.mli index b177b7f1e0..c921606484 100644 --- a/interp/notation.mli +++ b/interp/notation.mli @@ -17,6 +17,21 @@ open Notation_term (** Notations *) +val pr_notation : notation -> Pp.t +(** Printing *) + +val notation_entry_eq : notation_entry -> notation_entry -> bool +(** Equality on [notation_entry]. *) + +val notation_entry_level_eq : notation_entry_level -> notation_entry_level -> bool +(** Equality on [notation_entry_level]. *) + +val notation_eq : notation -> notation -> bool +(** Equality on [notation]. *) + +module NotationSet : Set.S with type elt = notation +module NotationMap : CMap.ExtS with type key = notation and module Set := NotationSet + (** {6 Scopes } *) (** A scope is a set of interpreters for symbols + optional interpreter and printers for integers + optional delimiters *) @@ -25,8 +40,6 @@ type delimiters = string type scope type scopes (** = [scope_name list] *) -type local_scopes = tmp_scope_name option * scope_name list - val declare_scope : scope_name -> unit val current_scopes : unit -> scopes @@ -84,11 +97,11 @@ val declare_string_interpreter : scope_name -> required_module -> (** Return the [term]/[cases_pattern] bound to a primitive token in a given scope context*) -val interp_prim_token : ?loc:Loc.t -> prim_token -> local_scopes -> +val interp_prim_token : ?loc:Loc.t -> prim_token -> subscopes -> glob_constr * (notation_location * scope_name option) (* This function returns a glob_const representing a pattern *) val interp_prim_token_cases_pattern_expr : ?loc:Loc.t -> (GlobRef.t -> unit) -> prim_token -> - local_scopes -> glob_constr * (notation_location * scope_name option) + subscopes -> glob_constr * (notation_location * scope_name option) (** Return the primitive token associated to a [term]/[cases_pattern]; raise [No_match] if no such token *) @@ -101,7 +114,7 @@ val uninterp_prim_token_ind_pattern : inductive -> cases_pattern list -> scope_name * prim_token val availability_of_prim_token : - prim_token -> scope_name -> local_scopes -> delimiters option option + prim_token -> scope_name -> subscopes -> delimiters option option (** {6 Declare and interpret back and forth a notation } *) @@ -116,7 +129,7 @@ val declare_notation_interpretation : notation -> scope_name option -> val declare_uninterpretation : interp_rule -> interpretation -> unit (** Return the interpretation bound to a notation *) -val interp_notation : ?loc:Loc.t -> notation -> local_scopes -> +val interp_notation : ?loc:Loc.t -> notation -> subscopes -> interpretation * (notation_location * scope_name option) type notation_rule = interp_rule * interpretation * int option @@ -129,13 +142,13 @@ val uninterp_ind_pattern_notations : inductive -> notation_rule list (** Test if a notation is available in the scopes context [scopes]; if available, the result is not None; the first argument is itself not None if a delimiters is needed *) -val availability_of_notation : scope_name option * notation -> local_scopes -> +val availability_of_notation : scope_name option * notation -> subscopes -> (scope_name option * delimiters option) option (** {6 Miscellaneous} *) val interp_notation_as_global_reference : ?loc:Loc.t -> (GlobRef.t -> bool) -> - notation -> delimiters option -> GlobRef.t + notation_key -> delimiters option -> GlobRef.t (** Checks for already existing notations *) val exists_notation_in_scope : scope_name option -> notation -> @@ -177,8 +190,8 @@ type symbol = val symbol_eq : symbol -> symbol -> bool (** Make/decompose a notation of the form "_ U _" *) -val make_notation_key : symbol list -> notation -val decompose_notation_key : notation -> symbol list +val make_notation_key : notation_entry_level -> symbol list -> notation +val decompose_notation_key : notation -> notation_entry_level * symbol list (** Decompose a notation of the form "a 'U' b" *) val decompose_raw_notation : string -> symbol list @@ -187,11 +200,21 @@ val decompose_raw_notation : string -> symbol list val pr_scope_class : scope_class -> Pp.t val pr_scope : (glob_constr -> Pp.t) -> scope_name -> Pp.t val pr_scopes : (glob_constr -> Pp.t) -> Pp.t -val locate_notation : (glob_constr -> Pp.t) -> notation -> +val locate_notation : (glob_constr -> Pp.t) -> notation_key -> scope_name option -> Pp.t val pr_visibility: (glob_constr -> Pp.t) -> scope_name option -> Pp.t +type entry_coercion = notation list +val declare_entry_coercion : notation -> notation_entry_level -> unit +val availability_of_entry_coercion : notation_entry_level -> notation_entry_level -> entry_coercion option + +val declare_custom_entry_has_global : string -> int -> unit +val declare_custom_entry_has_ident : string -> int -> unit + +val entry_has_global : notation_entry_level -> bool +val entry_has_ident : notation_entry_level -> bool + (** Rem: printing rules for primitive token are canonical *) val with_notation_protection : ('a -> 'b) -> 'a -> 'b diff --git a/interp/notation_ops.ml b/interp/notation_ops.ml index 7cde563cd2..06943ce7b9 100644 --- a/interp/notation_ops.ml +++ b/interp/notation_ops.ml @@ -1008,9 +1008,9 @@ let remove_sigma x (terms,termlists,binders,binderlists) = let remove_bindinglist_sigma x (terms,termlists,binders,binderlists) = (terms,termlists,binders,Id.List.remove_assoc x binderlists) -let add_ldots_var metas = (ldots_var,((None,[]),NtnTypeConstr))::metas +let add_ldots_var metas = (ldots_var,((Constrexpr.InConstrEntrySomeLevel,(None,[])),NtnTypeConstr))::metas -let add_meta_bindinglist x metas = (x,((None,[]),NtnTypeBinderList))::metas +let add_meta_bindinglist x metas = (x,((Constrexpr.InConstrEntrySomeLevel,(None,[])),NtnTypeBinderList))::metas (* This tells if letins in the middle of binders should be included in the sequence of binders *) @@ -1055,7 +1055,7 @@ let match_binderlist match_fun alp metas sigma rest x y iter termin revert = let alp,sigma = bind_bindinglist_env alp sigma x bl in match_fun alp metas sigma rest termin -let add_meta_term x metas = (x,((None,[]),NtnTypeConstr))::metas +let add_meta_term x metas = (x,((Constrexpr.InConstrEntrySomeLevel,(None,[])),NtnTypeConstr))::metas (* Should reuse the scope of the partner of x! *) let match_termlist match_fun alp metas sigma rest x y iter termin revert = let rec aux sigma acc rest = diff --git a/interp/notation_ops.mli b/interp/notation_ops.mli index f038b5be1a..58fa221b16 100644 --- a/interp/notation_ops.mli +++ b/interp/notation_ops.mli @@ -53,18 +53,18 @@ val glob_constr_of_notation_constr : ?loc:Loc.t -> notation_constr -> glob_const exception No_match val match_notation_constr : bool -> 'a glob_constr_g -> interpretation -> - ('a glob_constr_g * subscopes) list * ('a glob_constr_g list * subscopes) list * - ('a cases_pattern_disjunction_g * subscopes) list * - ('a extended_glob_local_binder_g list * subscopes) list + ('a glob_constr_g * extended_subscopes) list * ('a glob_constr_g list * extended_subscopes) list * + ('a cases_pattern_disjunction_g * extended_subscopes) list * + ('a extended_glob_local_binder_g list * extended_subscopes) list val match_notation_constr_cases_pattern : 'a cases_pattern_g -> interpretation -> - (('a cases_pattern_g * subscopes) list * ('a cases_pattern_g list * subscopes) list) * + (('a cases_pattern_g * extended_subscopes) list * ('a cases_pattern_g list * extended_subscopes) list) * (int * 'a cases_pattern_g list) val match_notation_constr_ind_pattern : inductive -> 'a cases_pattern_g list -> interpretation -> - (('a cases_pattern_g * subscopes) list * ('a cases_pattern_g list * subscopes) list) * + (('a cases_pattern_g * extended_subscopes) list * ('a cases_pattern_g list * extended_subscopes) list) * (int * 'a cases_pattern_g list) (** {5 Matching a notation pattern against a [glob_constr]} *) diff --git a/interp/notation_term.ml b/interp/notation_term.ml index 6d9effcef4..942ea5ff3f 100644 --- a/interp/notation_term.ml +++ b/interp/notation_term.ml @@ -58,6 +58,8 @@ type tmp_scope_name = scope_name type subscopes = tmp_scope_name option * scope_name list +type extended_subscopes = Constrexpr.notation_entry_level * subscopes + (** Type of the meta-variables of an notation_constr: in a recursive pattern x..y, x carries the sequence of objects bound to the list x..y *) @@ -86,7 +88,7 @@ type notation_var_internalization_type = (** This characterizes to what a notation is interpreted to *) type interpretation = - (Id.t * (subscopes * notation_var_instance_type)) list * + (Id.t * (extended_subscopes * notation_var_instance_type)) list * notation_constr type reversibility_status = APrioriReversible | HasLtac | NonInjective of Id.t list diff --git a/interp/syntax_def.ml b/interp/syntax_def.ml index a4f20fd739..e3d490a1ad 100644 --- a/interp/syntax_def.ml +++ b/interp/syntax_def.ml @@ -77,8 +77,8 @@ type syndef_interpretation = (Id.t * subscopes) list * notation_constr (* Coercions to the general format of notation that also supports variables bound to list of expressions *) -let in_pat (ids,ac) = (List.map (fun (id,sc) -> (id,(sc,NtnTypeConstr))) ids,ac) -let out_pat (ids,ac) = (List.map (fun (id,(sc,typ)) -> (id,sc)) ids,ac) +let in_pat (ids,ac) = (List.map (fun (id,sc) -> (id,((Constrexpr.InConstrEntrySomeLevel,sc),NtnTypeConstr))) ids,ac) +let out_pat (ids,ac) = (List.map (fun (id,((_,sc),typ)) -> (id,sc)) ids,ac) let declare_syntactic_definition local id onlyparse pat = let _ = add_leaf id (in_syntax_constant (local,in_pat pat,onlyparse)) in () diff --git a/kernel/cbytegen.ml b/kernel/cbytegen.ml index 4613cd3214..e336ea922d 100644 --- a/kernel/cbytegen.ml +++ b/kernel/cbytegen.ml @@ -501,6 +501,9 @@ let rec compile_lam env cenv lam sz cont = if Array.is_empty args then compile_fv_elem cenv (FVevar evk) sz cont else + (** Arguments are reversed in evar instances *) + let args = Array.copy args in + let () = Array.rev args in comp_app compile_fv_elem (compile_lam env) cenv (FVevar evk) args sz cont | Lconst (kn,u) -> compile_constant env cenv kn u [||] sz cont diff --git a/kernel/context.ml b/kernel/context.ml index 831dc850fb..4a7204b75c 100644 --- a/kernel/context.ml +++ b/kernel/context.ml @@ -149,6 +149,10 @@ struct | LocalAssum (na, ty) -> na, None, ty | LocalDef (na, v, ty) -> na, Some v, ty + let drop_body = function + | LocalAssum _ as d -> d + | LocalDef (na, v, ty) -> LocalAssum (na, ty) + end (** Rel-context is represented as a list of declarations. @@ -211,6 +215,8 @@ struct | Declaration.LocalAssum _ :: ctx -> aux (false::l) ctx in aux [] l + let drop_bodies l = List.Smart.map Declaration.drop_body l + (** [extended_list n Γ] builds an instance [args] such that [Γ,Δ ⊢ args:Γ] with n = |Δ| and with the {e local definitions} of [Γ] skipped in [args]. Example: for [x:T, y:=c, z:U] and [n]=2, it gives [Rel 5, Rel 3]. *) @@ -348,6 +354,10 @@ struct | id, None, ty -> LocalAssum (id, ty) | id, Some v, ty -> LocalDef (id, v, ty) + let drop_body = function + | LocalAssum _ as d -> d + | LocalDef (id, v, ty) -> LocalAssum (id, ty) + let of_rel_decl f = function | Rel.Declaration.LocalAssum (na,t) -> LocalAssum (f na, t) @@ -403,6 +413,8 @@ struct let to_vars l = List.fold_left (fun accu decl -> Id.Set.add (Declaration.get_id decl) accu) Id.Set.empty l + let drop_bodies l = List.Smart.map Declaration.drop_body l + (** [instance_from_named_context Ω] builds an instance [args] such that [Ω ⊢ args:Ω] where [Ω] is a named context and with the local definitions of [Ω] skipped. Example: for [id1:T,id2:=c,id3:U], it diff --git a/kernel/context.mli b/kernel/context.mli index 957ac4b3d6..2b0d36cb8c 100644 --- a/kernel/context.mli +++ b/kernel/context.mli @@ -85,6 +85,9 @@ sig val fold_constr : ('c -> 'a -> 'a) -> ('c, 'c) pt -> 'a -> 'a val to_tuple : ('c, 't) pt -> Name.t * 'c option * 't + + (** Turn [LocalDef] into [LocalAssum], identity otherwise. *) + val drop_body : ('c, 't) pt -> ('c, 't) pt end (** Rel-context is represented as a list of declarations. @@ -129,6 +132,9 @@ sig and each {e local definition} is mapped to [false]. *) val to_tags : ('c, 't) pt -> bool list + (** Turn all [LocalDef] into [LocalAssum], leave [LocalAssum] unchanged. *) + val drop_bodies : ('c, 't) pt -> ('c, 't) pt + (** [extended_list mk n Γ] builds an instance [args] such that [Γ,Δ ⊢ args:Γ] with n = |Δ| and with the {e local definitions} of [Γ] skipped in [args] where [mk] is used to build the corresponding variables. @@ -202,6 +208,9 @@ sig val to_tuple : ('c, 't) pt -> Id.t * 'c option * 't val of_tuple : Id.t * 'c option * 't -> ('c, 't) pt + (** Turn [LocalDef] into [LocalAssum], identity otherwise. *) + val drop_body : ('c, 't) pt -> ('c, 't) pt + (** Convert [Rel.Declaration.t] value to the corresponding [Named.Declaration.t] value. The function provided as the first parameter determines how to translate "names" to "ids". *) val of_rel_decl : (Name.t -> Id.t) -> ('c, 't) Rel.Declaration.pt -> ('c, 't) pt @@ -249,6 +258,9 @@ sig (** Return the set of all identifiers bound in a given named-context. *) val to_vars : ('c, 't) pt -> Id.Set.t + (** Turn all [LocalDef] into [LocalAssum], leave [LocalAssum] unchanged. *) + val drop_bodies : ('c, 't) pt -> ('c, 't) pt + (** [to_instance Ω] builds an instance [args] such that [Ω ⊢ args:Ω] where [Ω] is a named-context and with the local definitions of [Ω] skipped. Example: for [id1:T,id2:=c,id3:U], it diff --git a/kernel/nativeconv.ml b/kernel/nativeconv.ml index e97dbd0d67..931b8bbc86 100644 --- a/kernel/nativeconv.ml +++ b/kernel/nativeconv.ml @@ -135,7 +135,18 @@ and conv_fix env lvl t1 f1 t2 f2 cu = else aux (i+1) (conv_val env CONV flvl fi1 fi2 cu) in aux 0 cu +let warn_no_native_compiler = + let open Pp in + CWarnings.create ~name:"native-compiler-disabled" ~category:"native-compiler" + (fun () -> strbrk "Native compiler is disabled," ++ + strbrk " falling back to VM conversion test.") + let native_conv_gen pb sigma env univs t1 t2 = + if not Coq_config.native_compiler then begin + warn_no_native_compiler (); + Vconv.vm_conv_gen pb env univs t1 t2 + end + else let ml_filename, prefix = get_ml_filename () in let code, upds = mk_conv_code env sigma prefix t1 t2 in match compile ml_filename code ~profile:false with @@ -152,19 +163,8 @@ let native_conv_gen pb sigma env univs t1 t2 = end | _ -> anomaly (Pp.str "Compilation failure.") -let warn_no_native_compiler = - let open Pp in - CWarnings.create ~name:"native-compiler-disabled" ~category:"native-compiler" - (fun () -> strbrk "Native compiler is disabled," ++ - strbrk " falling back to VM conversion test.") - (* Wrapper for [native_conv] above *) let native_conv cv_pb sigma env t1 t2 = - if not Coq_config.native_compiler then begin - warn_no_native_compiler (); - Vconv.vm_conv cv_pb env t1 t2 - end - else let univs = Environ.universes env in let b = if cv_pb = CUMUL then Constr.leq_constr_univs univs t1 t2 diff --git a/kernel/nativelib.ml b/kernel/nativelib.ml index 31ad364911..f784509b6f 100644 --- a/kernel/nativelib.ml +++ b/kernel/nativelib.ml @@ -67,6 +67,7 @@ let warn_native_compiler_failed = CWarnings.create ~name:"native-compiler-failed" ~category:"native-compiler" print let call_compiler ?profile:(profile=false) ml_filename = + let () = assert Coq_config.native_compiler in let load_path = !get_load_paths () in let load_path = List.map (fun dn -> dn / output_dir) load_path in let include_dirs = List.flatten (List.map (fun x -> ["-I"; x]) (include_dirs () @ load_path)) in diff --git a/library/goptions.ml b/library/goptions.ml index f14ad333e9..eafcb8fea6 100644 --- a/library/goptions.ml +++ b/library/goptions.ml @@ -318,26 +318,35 @@ let set_option_value ?(locality = OptDefault) check_and_cast key v = | Some (name, depr, (read,write,append)) -> write locality (check_and_cast v (read ())) -let bad_type_error () = user_err Pp.(str "Bad type of value for this option.") +let show_value_type = function + | BoolValue _ -> "bool" + | IntValue _ -> "int" + | StringValue _ -> "string" + | StringOptValue _ -> "string" + +let bad_type_error opt_value actual_type = + user_err Pp.(str "Bad type of value for this option:" ++ spc() ++ + str "expected " ++ str (show_value_type opt_value) ++ + str ", got " ++ str actual_type ++ str ".") let check_int_value v = function | IntValue _ -> IntValue v - | _ -> bad_type_error () + | optv -> bad_type_error optv "int" let check_bool_value v = function | BoolValue _ -> BoolValue v - | _ -> bad_type_error () + | optv -> bad_type_error optv "bool" let check_string_value v = function | StringValue _ -> StringValue v | StringOptValue _ -> StringOptValue (Some v) - | _ -> bad_type_error () + | optv -> bad_type_error optv "string" let check_unset_value v = function | BoolValue _ -> BoolValue false | IntValue _ -> IntValue None | StringOptValue _ -> StringOptValue None - | _ -> bad_type_error () + | optv -> bad_type_error optv "nothing" (* Nota: For compatibility reasons, some errors are treated as warning. This allows a script to refer to an option that doesn't diff --git a/library/lib.ml b/library/lib.ml index 8b83261e48..8ebe44890c 100644 --- a/library/lib.ml +++ b/library/lib.ml @@ -26,13 +26,11 @@ type node = | Leaf of obj | CompilingLibrary of object_prefix | OpenedModule of is_type * export * object_prefix * Summary.frozen - | ClosedModule of library_segment | OpenedSection of object_prefix * Summary.frozen - | ClosedSection of library_segment -and library_entry = object_name * node +type library_entry = object_name * node -and library_segment = library_entry list +type library_segment = library_entry list type lib_objects = (Names.Id.t * obj) list @@ -73,10 +71,6 @@ let classify_segment seg = clean ((id,o')::substl, keepl, anticipl) stk | Anticipate o' -> clean (substl, keepl, o'::anticipl) stk) - | (_,ClosedSection _) :: stk -> clean acc stk - (* LEM; TODO: Understand what this does and see if what I do is the - correct thing for ClosedMod(ule|type) *) - | (_,ClosedModule _) :: stk -> clean acc stk | (_,OpenedSection _) :: _ -> user_err Pp.(str "there are still opened sections") | (_,OpenedModule (ty,_,_,_)) :: _ -> user_err ~hdr:"Lib.classify_segment" @@ -307,7 +301,6 @@ let end_mod is_type = in let (after,mark,before) = split_lib_at_opening oname in lib_state := { !lib_state with lib_stk = before }; - add_entry oname (ClosedModule (List.rev (mark::after))); let prefix = !lib_state.path_prefix in recalc_path_prefix (); (oname, prefix, fs, after) @@ -555,7 +548,6 @@ let discharge_item ((sp,_ as oname),e) = match e with | Leaf lobj -> Option.map (fun o -> (basename sp,o)) (discharge_object (oname,lobj)) - | ClosedSection _ | ClosedModule _ -> None | OpenedSection _ | OpenedModule _ | CompilingLibrary _ -> anomaly (Pp.str "discharge_item.") @@ -570,7 +562,6 @@ let close_section () = let (secdecls,mark,before) = split_lib_at_opening oname in lib_state := { !lib_state with lib_stk = before }; pop_path_prefix (); - add_entry oname (ClosedSection (List.rev (mark::secdecls))); let newdecls = List.map discharge_item secdecls in Summary.unfreeze_summaries fs; List.iter (Option.iter (fun (id,o) -> add_discharged_leaf id o)) newdecls @@ -589,10 +580,8 @@ let freeze ~marshallable = | n, (CompilingLibrary _ as x) -> Some (n,x) | n, OpenedModule (it,e,op,_) -> Some(n,OpenedModule(it,e,op,Summary.empty_frozen)) - | n, ClosedModule _ -> Some (n,ClosedModule []) | n, OpenedSection (op, _) -> - Some(n,OpenedSection(op,Summary.empty_frozen)) - | n, ClosedSection _ -> Some (n,ClosedSection [])) + Some(n,OpenedSection(op,Summary.empty_frozen))) !lib_state.lib_stk in { !lib_state with lib_stk } | _ -> diff --git a/library/lib.mli b/library/lib.mli index c6856a55b4..9933b762ba 100644 --- a/library/lib.mli +++ b/library/lib.mli @@ -23,11 +23,9 @@ type node = | Leaf of Libobject.obj | CompilingLibrary of Libnames.object_prefix | OpenedModule of is_type * export * Libnames.object_prefix * Summary.frozen - | ClosedModule of library_segment | OpenedSection of Libnames.object_prefix * Summary.frozen - | ClosedSection of library_segment -and library_segment = (Libnames.object_name * node) list +type library_segment = (Libnames.object_name * node) list type lib_objects = (Id.t * Libobject.obj) list diff --git a/parsing/extend.ml b/parsing/extend.ml index f57e32c884..6fe2956643 100644 --- a/parsing/extend.ml +++ b/parsing/extend.ml @@ -34,14 +34,12 @@ type production_level = (** User-level types used to tell how to parse or interpret of the non-terminal *) type 'a constr_entry_key_gen = - | ETName - | ETReference + | ETIdent + | ETGlobal | ETBigint | ETBinder of bool (* open list of binders if true, closed list of binders otherwise *) - | ETConstr of 'a - | ETConstrAsBinder of Notation_term.constr_as_binder_kind * 'a + | ETConstr of Constrexpr.notation_entry * Notation_term.constr_as_binder_kind option * 'a | ETPattern of bool * int option (* true = strict pattern, i.e. not a single variable *) - | ETOther of string * string (** Entries level (left-hand side of grammar rules) *) @@ -63,9 +61,8 @@ type constr_prod_entry_key = | ETProdName (* Parsed as a name (ident or _) *) | ETProdReference (* Parsed as a global reference *) | ETProdBigint (* Parsed as an (unbounded) integer *) - | ETProdConstr of (production_level * production_position) (* Parsed as constr or pattern *) + | ETProdConstr of Constrexpr.notation_entry * (production_level * production_position) (* Parsed as constr or pattern, or a subentry of those *) | ETProdPattern of int (* Parsed as pattern as a binder (as subpart of a constr) *) - | ETProdOther of string * string (* Intended for embedding custom entries in constr or pattern *) | ETProdConstrList of (production_level * production_position) * Tok.t list (* Parsed as non-empty list of constr *) | ETProdBinderList of binder_entry_kind (* Parsed as non-empty list of local binders *) diff --git a/parsing/g_constr.mlg b/parsing/g_constr.mlg index b2913d5d4f..49e1cd7ec9 100644 --- a/parsing/g_constr.mlg +++ b/parsing/g_constr.mlg @@ -225,11 +225,11 @@ GRAMMAR EXTEND Gram | "("; c = operconstr LEVEL "200"; ")" -> { (match c.CAst.v with | CPrim (Numeral (n,true)) -> - CAst.make ~loc @@ CNotation("( _ )",([c],[],[],[])) + CAst.make ~loc @@ CNotation((InConstrEntrySomeLevel,"( _ )"),([c],[],[],[])) | _ -> c) } | "{|"; c = record_declaration; "|}" -> { c } | "{"; c = binder_constr ; "}" -> - { CAst.make ~loc @@ CNotation(("{ _ }"),([c],[],[],[])) } + { CAst.make ~loc @@ CNotation((InConstrEntrySomeLevel,"{ _ }"),([c],[],[],[])) } | "`{"; c = operconstr LEVEL "200"; "}" -> { CAst.make ~loc @@ CGeneralization (Implicit, None, c) } | "`("; c = operconstr LEVEL "200"; ")" -> @@ -411,13 +411,13 @@ GRAMMAR EXTEND Gram | "("; p = pattern LEVEL "200"; ")" -> { (match p.CAst.v with | CPatPrim (Numeral (n,true)) -> - CAst.make ~loc @@ CPatNotation("( _ )",([p],[]),[]) + CAst.make ~loc @@ CPatNotation((InConstrEntrySomeLevel,"( _ )"),([p],[]),[]) | _ -> p) } | "("; p = pattern LEVEL "200"; ":"; ty = lconstr; ")" -> { let p = match p with | { CAst.v = CPatPrim (Numeral (n,true)) } -> - CAst.make ~loc @@ CPatNotation("( _ )",([p],[]),[]) + CAst.make ~loc @@ CPatNotation((InConstrEntrySomeLevel,"( _ )"),([p],[]),[]) | _ -> p in CAst.make ~loc @@ CPatCast (p, ty) } diff --git a/parsing/notation_gram.ml b/parsing/notation_gram.ml index 346350641f..d8c08803b6 100644 --- a/parsing/notation_gram.ml +++ b/parsing/notation_gram.ml @@ -17,7 +17,8 @@ type precedence = int type parenRelation = L | E | Any | Prec of precedence type tolerability = precedence * parenRelation -type level = precedence * tolerability list * constr_entry_key list +type level = Constrexpr.notation_entry * precedence * tolerability list * constr_entry_key list + (* first argument is InCustomEntry s for custom entries *) type grammar_constr_prod_item = | GramConstrTerminal of Tok.t diff --git a/parsing/notgram_ops.ml b/parsing/notgram_ops.ml index 071e6db205..c36b3b17bf 100644 --- a/parsing/notgram_ops.ml +++ b/parsing/notgram_ops.ml @@ -11,55 +11,59 @@ open Pp open CErrors open Util -open Extend +open Notation open Notation_gram (* Uninterpreted notation levels *) -let notation_level_map = Summary.ref ~name:"notation_level_map" String.Map.empty +let notation_level_map = Summary.ref ~name:"notation_level_map" NotationMap.empty let declare_notation_level ?(onlyprint=false) ntn level = - if String.Map.mem ntn !notation_level_map then - anomaly (str "Notation " ++ str ntn ++ str " is already assigned a level."); - notation_level_map := String.Map.add ntn (level,onlyprint) !notation_level_map + if NotationMap.mem ntn !notation_level_map then + anomaly (str "Notation " ++ pr_notation ntn ++ str " is already assigned a level."); + notation_level_map := NotationMap.add ntn (level,onlyprint) !notation_level_map let level_of_notation ?(onlyprint=false) ntn = - let (level,onlyprint') = String.Map.find ntn !notation_level_map in + let (level,onlyprint') = NotationMap.find ntn !notation_level_map in if onlyprint' && not onlyprint then raise Not_found; level (**********************************************************************) -(* Operations on scopes *) +(* Equality *) + +open Extend let parenRelation_eq t1 t2 = match t1, t2 with | L, L | E, E | Any, Any -> true | Prec l1, Prec l2 -> Int.equal l1 l2 | _ -> false -let production_level_eq l1 l2 = true (* (l1 = l2) *) +let production_position_eq pp1 pp2 = match (pp1,pp2) with +| BorderProd (side1,assoc1), BorderProd (side2,assoc2) -> side1 = side2 && assoc1 = assoc2 +| InternalProd, InternalProd -> true +| (BorderProd _ | InternalProd), _ -> false -let production_position_eq pp1 pp2 = true (* pp1 = pp2 *) (* match pp1, pp2 with +let production_level_eq l1 l2 = match (l1,l2) with | NextLevel, NextLevel -> true | NumLevel n1, NumLevel n2 -> Int.equal n1 n2 -| (NextLevel | NumLevel _), _ -> false *) +| (NextLevel | NumLevel _), _ -> false let constr_entry_key_eq eq v1 v2 = match v1, v2 with -| ETName, ETName -> true -| ETReference, ETReference -> true +| ETIdent, ETIdent -> true +| ETGlobal, ETGlobal -> true | ETBigint, ETBigint -> true | ETBinder b1, ETBinder b2 -> b1 == b2 -| ETConstr lev1, ETConstr lev2 -> eq lev1 lev2 -| ETConstrAsBinder (bk1,lev1), ETConstrAsBinder (bk2,lev2) -> eq lev1 lev2 && bk1 = bk2 +| ETConstr (s1,bko1,lev1), ETConstr (s2,bko2,lev2) -> + notation_entry_eq s1 s2 && eq lev1 lev2 && Option.equal (=) bko1 bko2 | ETPattern (b1,n1), ETPattern (b2,n2) -> b1 = b2 && Option.equal Int.equal n1 n2 -| ETOther (s1,s1'), ETOther (s2,s2') -> String.equal s1 s2 && String.equal s1' s2' -| (ETName | ETReference | ETBigint | ETBinder _ | ETConstr _ | ETPattern _ | ETOther _ | ETConstrAsBinder _), _ -> false +| (ETIdent | ETGlobal | ETBigint | ETBinder _ | ETConstr _ | ETPattern _), _ -> false -let level_eq_gen strict (l1, t1, u1) (l2, t2, u2) = +let level_eq_gen strict (s1, l1, t1, u1) (s2, l2, t2, u2) = let tolerability_eq (i1, r1) (i2, r2) = Int.equal i1 i2 && parenRelation_eq r1 r2 in let prod_eq (l1,pp1) (l2,pp2) = - if strict then production_level_eq l1 l2 && production_position_eq pp1 pp2 - else production_level_eq l1 l2 in - Int.equal l1 l2 && List.equal tolerability_eq t1 t2 + not strict || + (production_level_eq l1 l2 && production_position_eq pp1 pp2) in + notation_entry_eq s1 s2 && Int.equal l1 l2 && List.equal tolerability_eq t1 t2 && List.equal (constr_entry_key_eq prod_eq) u1 u2 let level_eq = level_eq_gen false diff --git a/parsing/pcoq.ml b/parsing/pcoq.ml index 6726603e60..eb3e633892 100644 --- a/parsing/pcoq.ml +++ b/parsing/pcoq.ml @@ -271,14 +271,21 @@ type gram_reinit = gram_assoc * gram_position type extend_rule = | ExtendRule : 'a G.entry * gram_reinit option * 'a extend_statement -> extend_rule +module EntryCommand = Dyn.Make () +module EntryData = struct type _ t = Ex : 'b G.entry String.Map.t -> ('a * 'b) t end +module EntryDataMap = EntryCommand.Map(EntryData) + type ext_kind = | ByGrammar of extend_rule | ByEXTEND of (unit -> unit) * (unit -> unit) + | ByEntry : ('a * 'b) EntryCommand.tag * string * 'b G.entry -> ext_kind (** The list of extensions *) let camlp5_state = ref [] +let camlp5_entries = ref EntryDataMap.empty + (** Deletion *) let grammar_delete e reinit (pos,rls) = @@ -344,7 +351,7 @@ module Gram = let rec remove_grammars n = if n>0 then - (match !camlp5_state with + match !camlp5_state with | [] -> anomaly ~label:"Pcoq.remove_grammars" (Pp.str "too many rules to remove.") | ByGrammar (ExtendRule (g, reinit, ext)) :: t -> grammar_delete g reinit (of_coq_extend_statement ext); @@ -355,7 +362,17 @@ let rec remove_grammars n = camlp5_state := t; remove_grammars n; redo(); - camlp5_state := ByEXTEND (undo,redo) :: !camlp5_state) + camlp5_state := ByEXTEND (undo,redo) :: !camlp5_state + | ByEntry (tag, name, e) :: t -> + G.Unsafe.clear_entry e; + camlp5_state := t; + let EntryData.Ex entries = + try EntryDataMap.find tag !camlp5_entries + with Not_found -> EntryData.Ex String.Map.empty + in + let entries = String.Map.remove name entries in + camlp5_entries := EntryDataMap.add tag (EntryData.Ex entries) !camlp5_entries; + remove_grammars (n - 1) let make_rule r = [None, None, r] @@ -517,59 +534,119 @@ module GrammarInterpMap = GrammarCommand.Map(GrammarInterp) let grammar_interp = ref GrammarInterpMap.empty -let (grammar_stack : (int * GrammarCommand.t * GramState.t) list ref) = ref [] +type ('a, 'b) entry_extension = 'a -> GramState.t -> string list * GramState.t + +module EntryInterp = struct type _ t = Ex : ('a, 'b) entry_extension -> ('a * 'b) t end +module EntryInterpMap = EntryCommand.Map(EntryInterp) + +let entry_interp = ref EntryInterpMap.empty + +type grammar_entry = +| GramExt of int * GrammarCommand.t +| EntryExt : int * ('a * 'b) EntryCommand.tag * 'a -> grammar_entry + +let (grammar_stack : (grammar_entry * GramState.t) list ref) = ref [] type 'a grammar_command = 'a GrammarCommand.tag +type ('a, 'b) entry_command = ('a * 'b) EntryCommand.tag let create_grammar_command name interp : _ grammar_command = let obj = GrammarCommand.create name in let () = grammar_interp := GrammarInterpMap.add obj interp !grammar_interp in obj +let create_entry_command name (interp : ('a, 'b) entry_extension) : ('a, 'b) entry_command = + let obj = EntryCommand.create name in + let () = entry_interp := EntryInterpMap.add obj (EntryInterp.Ex interp) !entry_interp in + obj + let extend_grammar_command tag g = let modify = GrammarInterpMap.find tag !grammar_interp in let grammar_state = match !grammar_stack with | [] -> GramState.empty - | (_, _, st) :: _ -> st + | (_, st) :: _ -> st in let (rules, st) = modify g grammar_state in let iter (ExtendRule (e, reinit, ext)) = grammar_extend_sync e reinit ext in let () = List.iter iter rules in let nb = List.length rules in - grammar_stack := (nb, GrammarCommand.Dyn (tag, g), st) :: !grammar_stack + grammar_stack := (GramExt (nb, GrammarCommand.Dyn (tag, g)), st) :: !grammar_stack -let recover_grammar_command (type a) (tag : a grammar_command) : a list = - let filter : _ -> a option = fun (_, GrammarCommand.Dyn (tag', v), _) -> - match GrammarCommand.eq tag tag' with - | None -> None - | Some Refl -> Some v +let extend_entry_command (type a) (type b) (tag : (a, b) entry_command) (g : a) : b Gram.entry list = + let EntryInterp.Ex modify = EntryInterpMap.find tag !entry_interp in + let grammar_state = match !grammar_stack with + | [] -> GramState.empty + | (_, st) :: _ -> st in - List.map_filter filter !grammar_stack + let (names, st) = modify g grammar_state in + let entries = List.map (fun name -> Gram.entry_create name) names in + let iter name e = + camlp5_state := ByEntry (tag, name, e) :: !camlp5_state; + let EntryData.Ex old = + try EntryDataMap.find tag !camlp5_entries + with Not_found -> EntryData.Ex String.Map.empty + in + let entries = String.Map.add name e old in + camlp5_entries := EntryDataMap.add tag (EntryData.Ex entries) !camlp5_entries + in + let () = List.iter2 iter names entries in + let nb = List.length entries in + let () = grammar_stack := (EntryExt (nb, tag, g), st) :: !grammar_stack in + entries + +let find_custom_entry tag name = + let EntryData.Ex map = EntryDataMap.find tag !camlp5_entries in + String.Map.find name map -let extend_dyn_grammar (GrammarCommand.Dyn (tag, g)) = extend_grammar_command tag g +let extend_dyn_grammar (e, _) = match e with +| GramExt (_, (GrammarCommand.Dyn (tag, g))) -> extend_grammar_command tag g +| EntryExt (_, tag, g) -> ignore (extend_entry_command tag g) -(* Summary functions: the state of the lexer is included in that of the parser. +(** Registering extra grammar *) + +type any_entry = AnyEntry : 'a Gram.entry -> any_entry + +let grammar_names : any_entry list String.Map.t ref = ref String.Map.empty + +let register_grammars_by_name name grams = + grammar_names := String.Map.add name grams !grammar_names + +let find_grammars_by_name name = + try String.Map.find name !grammar_names + with Not_found -> + let fold (EntryDataMap.Any (tag, EntryData.Ex map)) accu = + try AnyEntry (String.Map.find name map) :: accu + with Not_found -> accu + in + EntryDataMap.fold fold !camlp5_entries [] + +(** Summary functions: the state of the lexer is included in that of the parser. Because the grammar affects the set of keywords when adding or removing grammar rules. *) -type frozen_t = (int * GrammarCommand.t * GramState.t) list * CLexer.keyword_state +type frozen_t = + (grammar_entry * GramState.t) list * + CLexer.keyword_state -let freeze _ : frozen_t = (!grammar_stack, CLexer.get_keyword_state ()) +let freeze _ : frozen_t = + (!grammar_stack, CLexer.get_keyword_state ()) (* We compare the current state of the grammar and the state to unfreeze, by computing the longest common suffixes *) let factorize_grams l1 l2 = if l1 == l2 then ([], [], l1) else List.share_tails l1 l2 -let number_of_entries gcl = - List.fold_left (fun n (p,_,_) -> n + p) 0 gcl +let rec number_of_entries accu = function +| [] -> accu +| ((GramExt (p, _) | EntryExt (p, _, _)), _) :: rem -> + number_of_entries (p + accu) rem let unfreeze (grams, lex) = let (undo, redo, common) = factorize_grams !grammar_stack grams in - let n = number_of_entries undo in + let n = number_of_entries 0 undo in remove_grammars n; grammar_stack := common; CLexer.set_keyword_state lex; - List.iter extend_dyn_grammar (List.rev_map pi2 redo) + List.iter extend_dyn_grammar (List.rev redo) (** No need to provide an init function : the grammar state is statically available, and already empty initially, while @@ -603,15 +680,3 @@ let () = Grammar.register0 wit_sort_family (Constr.sort_family); Grammar.register0 wit_constr (Constr.constr); () - -(** Registering extra grammar *) - -type any_entry = AnyEntry : 'a Entry.t -> any_entry - -let grammar_names : any_entry list String.Map.t ref = ref String.Map.empty - -let register_grammars_by_name name grams = - grammar_names := String.Map.add name grams !grammar_names - -let find_grammars_by_name name = - String.Map.find name !grammar_names diff --git a/parsing/pcoq.mli b/parsing/pcoq.mli index 029c437136..e12ccaa636 100644 --- a/parsing/pcoq.mli +++ b/parsing/pcoq.mli @@ -233,6 +233,8 @@ val grammar_extend : 'a Entry.t -> gram_reinit option -> module GramState : Store.S (** Auxiliary state of the grammar. Any added data must be marshallable. *) +(** {6 Extension with parsing rules} *) + type 'a grammar_command (** Type of synchronized parsing extensions. The ['a] type should be marshallable. *) @@ -253,8 +255,30 @@ val create_grammar_command : string -> 'a grammar_extension -> 'a grammar_comman val extend_grammar_command : 'a grammar_command -> 'a -> unit (** Extend the grammar of Coq with the given data. *) -val recover_grammar_command : 'a grammar_command -> 'a list -(** Recover the current stack of grammar extensions. *) +(** {6 Extension with parsing entries} *) + +type ('a, 'b) entry_command +(** Type of synchronized entry creation. The ['a] type should be + marshallable. *) + +type ('a, 'b) entry_extension = 'a -> GramState.t -> string list * GramState.t +(** Entry extension entry point. Given some ['a] and a current grammar state, + such a function must produce the list of entry extensions that will be + created and kept synchronized w.r.t. the summary, together + with a new state. It should be pure. *) + +val create_entry_command : string -> ('a, 'b) entry_extension -> ('a, 'b) entry_command +(** Create a new entry-creating command with the given name. The extension + function is called to generate the new entries for a given data. *) + +val extend_entry_command : ('a, 'b) entry_command -> 'a -> 'b Entry.t list +(** Create new synchronized entries using the provided data. *) + +val find_custom_entry : ('a, 'b) entry_command -> string -> 'b Entry.t +(** Find an entry generated by the synchronized system in the current state. + @raise Not_found if non-existent. *) + +(** {6 Protection w.r.t. backtrack} *) val with_grammar_rule_protection : ('a -> 'b) -> 'a -> 'b diff --git a/parsing/ppextend.ml b/parsing/ppextend.ml index d2b50fa83d..e1f5e20117 100644 --- a/parsing/ppextend.ml +++ b/parsing/ppextend.ml @@ -11,6 +11,7 @@ open Util open Pp open CErrors +open Notation open Notation_gram (*s Pretty-print. *) @@ -48,29 +49,29 @@ type unparsing_rule = unparsing list * precedence type extra_unparsing_rules = (string * string) list (* Concrete syntax for symbolic-extension table *) let notation_rules = - Summary.ref ~name:"notation-rules" (String.Map.empty : (unparsing_rule * extra_unparsing_rules * notation_grammar) String.Map.t) + Summary.ref ~name:"notation-rules" (NotationMap.empty : (unparsing_rule * extra_unparsing_rules * notation_grammar) NotationMap.t) let declare_notation_rule ntn ~extra unpl gram = - notation_rules := String.Map.add ntn (unpl,extra,gram) !notation_rules + notation_rules := NotationMap.add ntn (unpl,extra,gram) !notation_rules let find_notation_printing_rule ntn = - try pi1 (String.Map.find ntn !notation_rules) - with Not_found -> anomaly (str "No printing rule found for " ++ str ntn ++ str ".") + try pi1 (NotationMap.find ntn !notation_rules) + with Not_found -> anomaly (str "No printing rule found for " ++ pr_notation ntn ++ str ".") let find_notation_extra_printing_rules ntn = - try pi2 (String.Map.find ntn !notation_rules) + try pi2 (NotationMap.find ntn !notation_rules) with Not_found -> [] let find_notation_parsing_rules ntn = - try pi3 (String.Map.find ntn !notation_rules) - with Not_found -> anomaly (str "No parsing rule found for " ++ str ntn ++ str ".") + try pi3 (NotationMap.find ntn !notation_rules) + with Not_found -> anomaly (str "No parsing rule found for " ++ pr_notation ntn ++ str ".") let get_defined_notations () = - String.Set.elements @@ String.Map.domain !notation_rules + NotationSet.elements @@ NotationMap.domain !notation_rules let add_notation_extra_printing_rule ntn k v = try notation_rules := - let p, pp, gr = String.Map.find ntn !notation_rules in - String.Map.add ntn (p, (k,v) :: pp, gr) !notation_rules + let p, pp, gr = NotationMap.find ntn !notation_rules in + NotationMap.add ntn (p, (k,v) :: pp, gr) !notation_rules with Not_found -> user_err ~hdr:"add_notation_extra_printing_rule" (str "No such Notation.") diff --git a/parsing/ppextend.mli b/parsing/ppextend.mli index 9f61e121a4..7eb5967a3e 100644 --- a/parsing/ppextend.mli +++ b/parsing/ppextend.mli @@ -41,7 +41,6 @@ type unparsing = type unparsing_rule = unparsing list * precedence type extra_unparsing_rules = (string * string) list - val declare_notation_rule : notation -> extra:extra_unparsing_rules -> unparsing_rule -> notation_grammar -> unit val find_notation_printing_rule : notation -> unparsing_rule val find_notation_extra_printing_rules : notation -> extra_unparsing_rules diff --git a/plugins/firstorder/ground.ml b/plugins/firstorder/ground.ml index 4e3ba57308..516b04ea21 100644 --- a/plugins/firstorder/ground.ml +++ b/plugins/firstorder/ground.ml @@ -13,23 +13,21 @@ open Formula open Sequent open Rules open Instances -open Constr open Tacmach.New open Tacticals.New +open Globnames let update_flags ()= - let predref=ref Names.Cpred.empty in - let f coe= - try - let kn= fst (destConst (Classops.get_coercion_value coe)) in - predref:=Names.Cpred.add kn !predref - with DestKO -> () + let f acc coe = + match coe.Classops.coe_value with + | ConstRef c -> Names.Cpred.add c acc + | _ -> acc in - List.iter f (Classops.coercions ()); + let pred = List.fold_left f Names.Cpred.empty (Classops.coercions ()) in red_flags:= CClosure.RedFlags.red_add_transparent CClosure.betaiotazeta - (Names.Id.Pred.full,Names.Cpred.complement !predref) + (Names.Id.Pred.full,Names.Cpred.complement pred) let ground_tac solver startseq = Proofview.Goal.enter begin fun gl -> diff --git a/plugins/ltac/tacentries.ml b/plugins/ltac/tacentries.ml index 4b834d66d3..636cb8ebf8 100644 --- a/plugins/ltac/tacentries.ml +++ b/plugins/ltac/tacentries.ml @@ -594,15 +594,6 @@ let rec clause_of_sign : type a. a ty_sig -> Genarg.ArgT.any Extend.user_symbol let clause_of_ty_ml = function | TyML (t,_) -> clause_of_sign t -let rec prj : type a b c. (a,b,c) Extend.ty_user_symbol -> (a,b,c) genarg_type = function - | TUentry a -> ExtraArg a - | TUentryl (a,l) -> ExtraArg a - | TUopt(o) -> OptArg (prj o) - | TUlist1 l -> ListArg (prj l) - | TUlist1sep (l,_) -> ListArg (prj l) - | TUlist0 l -> ListArg (prj l) - | TUlist0sep (l,_) -> ListArg (prj l) - let rec eval_sign : type a. a ty_sig -> a -> Geninterp.Val.t list -> Geninterp.interp_sign -> unit Proofview.tactic = fun sign tac -> match sign with @@ -617,7 +608,7 @@ let rec eval_sign : type a. a ty_sig -> a -> Geninterp.Val.t list -> Geninterp.i begin fun tac vals ist -> match vals with | [] -> assert false | v :: vals -> - let v' = Taccoerce.Value.cast (topwit (prj a)) v in + let v' = Taccoerce.Value.cast (topwit (Egramml.proj_symbol a)) v in f (tac v') vals ist end tac | TyAnonArg (a, sig') -> eval_sign sig' tac diff --git a/plugins/ssr/ssrvernac.ml4 b/plugins/ssr/ssrvernac.ml4 index 7ce2dd64af..989a6c5bf1 100644 --- a/plugins/ssr/ssrvernac.ml4 +++ b/plugins/ssr/ssrvernac.ml4 @@ -24,7 +24,6 @@ open Ltac_plugin open Notation_ops open Notation_term open Glob_term -open Globnames open Stdarg open Genarg open Decl_kinds @@ -218,8 +217,8 @@ let interp_search_notation ?loc tag okey = (Bytes.set s' i' '_'; loop (j + 1) (i' + 2)) else (String.blit s i s' i' m; loop (j + 1) (i' + m + 1)) in loop 0 1 in - let trim_ntn (pntn, m) = Bytes.sub_string pntn 1 (max 0 m) in - let pr_ntn ntn = str "(" ++ str ntn ++ str ")" in + let trim_ntn (pntn, m) = (InConstrEntrySomeLevel,Bytes.sub_string pntn 1 (max 0 m)) in + let pr_ntn ntn = str "(" ++ Notation.pr_notation ntn ++ str ")" in let pr_and_list pr = function | [x] -> pr x | x :: lx -> pr_list pr_comma pr lx ++ pr_comma () ++ str "and " ++ pr x @@ -294,7 +293,7 @@ let interp_search_notation ?loc tag okey = let scs' = List.remove (=) sc !scs in let w = pr_ntn ntn ++ str " is also defined " ++ pr_scs scs' in Feedback.msg_warning (hov 4 w) - else if String.string_contains ~where:ntn ~what:" .. " then + else if String.string_contains ~where:(snd ntn) ~what:" .. " then err (pr_ntn ntn ++ str " is an n-ary notation"); let nvars = List.filter (fun (_,(_,typ)) -> typ = NtnTypeConstr) nvars in let rec sub () = function @@ -359,13 +358,12 @@ let coerce_search_pattern_to_sort hpat = true, cp with _ -> false, [] in let coerce hp coe_index = - let coe = Classops.get_coercion_value coe_index in + let coe_ref = coe_index.Classops.coe_value in try - let coe_ref = global_of_constr coe in let n_imps = Option.get (Classops.hide_coercion coe_ref) in mkPApp (Pattern.PRef coe_ref) n_imps [|hp|] - with _ -> - errorstrm (str "need explicit coercion " ++ pr_constr_env env sigma coe ++ spc () + with Not_found | Option.IsNone -> + errorstrm (str "need explicit coercion " ++ pr_global coe_ref ++ spc () ++ str "to interpret head search pattern as type") in filter_head, List.fold_left coerce hpat' coe_path diff --git a/plugins/ssrmatching/ssrmatching.ml b/plugins/ssrmatching/ssrmatching.ml index 05eda14e90..30a998c6ce 100644 --- a/plugins/ssrmatching/ssrmatching.ml +++ b/plugins/ssrmatching/ssrmatching.ml @@ -929,7 +929,7 @@ let glob_cpattern gs p = | k, (v, Some t), _ as orig -> if k = 'x' then glob_ssrterm gs ('(', (v, Some t), None) else match t.CAst.v with - | CNotation("( _ in _ )", ([t1; t2], [], [], [])) -> + | CNotation((InConstrEntrySomeLevel,"( _ in _ )"), ([t1; t2], [], [], [])) -> (try match glob t1, glob t2 with | (r1, None), (r2, None) -> encode k "In" [r1;r2] | (r1, Some _), (r2, Some _) when isCVar t1 -> @@ -937,11 +937,11 @@ let glob_cpattern gs p = | (r1, Some _), (r2, Some _) -> encode k "In" [r1; r2] | _ -> CErrors.anomaly (str"where are we?.") with _ when isCVar t1 -> encode k "In" [bind_in t1 t2]) - | CNotation("( _ in _ in _ )", ([t1; t2; t3], [], [], [])) -> + | CNotation((InConstrEntrySomeLevel,"( _ in _ in _ )"), ([t1; t2; t3], [], [], [])) -> check_var t2; encode k "In" [fst (glob t1); bind_in t2 t3] - | CNotation("( _ as _ )", ([t1; t2], [], [], [])) -> + | CNotation((InConstrEntrySomeLevel,"( _ as _ )"), ([t1; t2], [], [], [])) -> encode k "As" [fst (glob t1); fst (glob t2)] - | CNotation("( _ as _ in _ )", ([t1; t2; t3], [], [], [])) -> + | CNotation((InConstrEntrySomeLevel,"( _ as _ in _ )"), ([t1; t2; t3], [], [], [])) -> check_var t2; encode k "As" [fst (glob t1); bind_in t2 t3] | _ -> glob_ssrterm gs orig ;; diff --git a/pretyping/cases.ml b/pretyping/cases.ml index 6a63fb02f8..ad33297f0a 100644 --- a/pretyping/cases.ml +++ b/pretyping/cases.ml @@ -373,6 +373,11 @@ let ltac_interp_realnames lvar = function | t, IsInd (ty,ind,realnal) -> t, IsInd (ty,ind,List.map (ltac_interp_name lvar) realnal) | _ as x -> x +let is_patvar pat = + match DAst.get pat with + | PatVar _ -> true + | _ -> false + let coerce_row typing_fun evdref env lvar pats (tomatch,(na,indopt)) = let loc = loc_of_glob_constr tomatch in let tycon,realnames = find_tomatch_tycon evdref env loc indopt in @@ -381,6 +386,7 @@ let coerce_row typing_fun evdref env lvar pats (tomatch,(na,indopt)) = let typ = nf_evar !evdref j.uj_type in lvar := make_return_predicate_ltac_lvar !evdref na tomatch j.uj_val !lvar; let t = + if realnames = None && pats <> [] && List.for_all is_patvar pats then NotInd (None,typ) else try try_find_ind env !evdref typ realnames with Not_found -> unify_tomatch_with_patterns evdref env loc typ pats realnames in diff --git a/pretyping/classops.ml b/pretyping/classops.ml index 7ac08e755e..542fb5456c 100644 --- a/pretyping/classops.ml +++ b/pretyping/classops.ml @@ -42,18 +42,15 @@ type coe_typ = GlobRef.t module CoeTypMap = Refmap_env type coe_info_typ = { - coe_value : constr; - coe_type : types; + coe_value : GlobRef.t; coe_local : bool; - coe_context : Univ.ContextSet.t; coe_is_identity : bool; coe_is_projection : Projection.Repr.t option; - coe_param : int } + coe_param : int; +} let coe_info_typ_equal c1 c2 = - let eq_constr c1 c2 = Termops.eq_constr Evd.empty (EConstr.of_constr c1) (EConstr.of_constr c2) in - eq_constr c1.coe_value c2.coe_value && - eq_constr c1.coe_type c2.coe_type && + GlobRef.equal c1.coe_value c2.coe_value && c1.coe_local == c2.coe_local && c1.coe_is_identity == c2.coe_is_identity && c1.coe_is_projection == c2.coe_is_projection && @@ -77,9 +74,7 @@ module IntMap = Map.Make(Int) let cl_typ_eq t1 t2 = Int.equal (cl_typ_ord t1 t2) 0 -type coe_index = coe_info_typ - -type inheritance_path = coe_index list +type inheritance_path = coe_info_typ list (* table des classes, des coercions et graphe d'heritage *) @@ -300,31 +295,25 @@ let lookup_path_to_fun_from env sigma s = let lookup_path_to_sort_from env sigma s = apply_on_class_of env sigma s lookup_path_to_sort_from_class +let mkNamed = function + | GlobRef.ConstRef c -> EConstr.mkConst c + | VarRef v -> EConstr.mkVar v + | ConstructRef c -> EConstr.mkConstruct c + | IndRef i -> EConstr.mkInd i + let get_coercion_constructor env coe = - let c, _ = - Reductionops.whd_all_stack env Evd.empty (EConstr.of_constr coe.coe_value) - in - match EConstr.kind Evd.empty (** FIXME *) c with - | Construct (cstr,u) -> - (cstr, Inductiveops.constructor_nrealargs cstr -1) - | _ -> - raise Not_found + let evd = Evd.from_env env in + let red x = fst (Reductionops.whd_all_stack env evd x) in + match EConstr.kind evd (red (mkNamed coe.coe_value)) with + | Constr.Construct (c, _) -> + c, Inductiveops.constructor_nrealargs c -1 + | _ -> raise Not_found let lookup_pattern_path_between env (s,t) = let i = inductive_class_of s in let j = inductive_class_of t in List.map (get_coercion_constructor env) (ClPairMap.find (i,j) !inheritance_graph) -(* coercion_value : coe_index -> unsafe_judgment * bool *) - -let coercion_value { coe_value = c; coe_type = t; coe_context = ctx; - coe_is_identity = b; coe_is_projection = b' } = - let subst, ctx = UnivGen.fresh_universe_context_set_instance ctx in - let c' = Vars.subst_univs_level_constr subst c - and t' = Vars.subst_univs_level_constr subst t in - (make_judge (EConstr.of_constr c') (EConstr.of_constr t'), b, b'), ctx - -(* pretty-print functions are now in Pretty *) (* rajouter une coercion dans le graphe *) let path_printer : (env -> Evd.evar_map -> (Bijint.Index.t * Bijint.Index.t) * inheritance_path -> Pp.t) ref = @@ -442,17 +431,13 @@ let cache_coercion env sigma (_, c) = let () = add_class c.coercion_target in let is, _ = class_info c.coercion_source in let it, _ = class_info c.coercion_target in - let value, ctx = UnivGen.fresh_global_instance env c.coercion_type in - let typ = Retyping.get_type_of env sigma (EConstr.of_constr value) in - let typ = EConstr.Unsafe.to_constr typ in let xf = - { coe_value = value; - coe_type = typ; - coe_context = ctx; + { coe_value = c.coercion_type; coe_local = c.coercion_local; coe_is_identity = c.coercion_is_id; coe_is_projection = c.coercion_is_proj; - coe_param = c.coercion_params } in + coe_param = c.coercion_params; + } in let () = add_new_coercion c.coercion_type xf in add_coercion_in_graph env sigma (xf,is,it) @@ -531,8 +516,6 @@ let declare_coercion coef ?(local = false) ~isid ~src:cls ~target:clt ~params:ps Lib.add_anonymous_leaf (inCoercion c) (* For printing purpose *) -let get_coercion_value v = v.coe_value - let pr_cl_index = Bijint.Index.print let classes () = Bijint.dom !class_tab diff --git a/pretyping/classops.mli b/pretyping/classops.mli index 8df085e15c..af00c0a8dc 100644 --- a/pretyping/classops.mli +++ b/pretyping/classops.mli @@ -39,16 +39,19 @@ type cl_info_typ = { type coe_typ = GlobRef.t (** This is the type of infos for declared coercions *) -type coe_info_typ +type coe_info_typ = { + coe_value : GlobRef.t; + coe_local : bool; + coe_is_identity : bool; + coe_is_projection : Projection.Repr.t option; + coe_param : int; +} (** [cl_index] is the type of class keys *) type cl_index -(** [coe_index] is the type of coercion keys *) -type coe_index - (** This is the type of paths from a class to another *) -type inheritance_path = coe_index list +type inheritance_path = coe_info_typ list (** {6 Access to classes infos } *) @@ -79,8 +82,6 @@ val declare_coercion : (** {6 Access to coercions infos } *) val coercion_exists : coe_typ -> bool -val coercion_value : coe_index -> (unsafe_judgment * bool * Projection.Repr.t option) Univ.in_universe_context_set - (** {6 Lookup functions for coercion paths } *) (** @raise Not_found in the following functions when no path exists *) @@ -105,10 +106,9 @@ val install_path_printer : val string_of_class : cl_typ -> string val pr_class : cl_typ -> Pp.t val pr_cl_index : cl_index -> Pp.t -val get_coercion_value : coe_index -> Constr.t val inheritance_graph : unit -> ((cl_index * cl_index) * inheritance_path) list val classes : unit -> cl_typ list -val coercions : unit -> coe_index list +val coercions : unit -> coe_info_typ list (** [hide_coercion] returns the number of params to skip if the coercion must be hidden, [None] otherwise; it raises [Not_found] if not a coercion *) diff --git a/pretyping/coercion.ml b/pretyping/coercion.ml index c6c2f57dd4..5e3821edf1 100644 --- a/pretyping/coercion.ml +++ b/pretyping/coercion.ml @@ -369,8 +369,11 @@ let apply_coercion env sigma p hj typ_cl = let j,t,evd = List.fold_left (fun (ja,typ_cl,sigma) i -> - let ((fv,isid,isproj),ctx) = coercion_value i in - let sigma = Evd.merge_context_set Evd.univ_flexible sigma ctx in + let isid = i.coe_is_identity in + let isproj = i.coe_is_projection in + let sigma, c = new_global sigma i.coe_value in + let typ = Retyping.get_type_of env sigma c in + let fv = make_judge c typ in let argl = (class_args_of env sigma typ_cl)@[ja.uj_val] in let sigma, jres = apply_coercion_args env sigma true isproj argl fv diff --git a/pretyping/vnorm.ml b/pretyping/vnorm.ml index c944080503..255707dc7b 100644 --- a/pretyping/vnorm.ml +++ b/pretyping/vnorm.ml @@ -209,6 +209,9 @@ and nf_evar env sigma evk stk = | Zapp args :: stk -> (** We assume that there is no consecutive Zapp nodes in a VM stack. Is that really an invariant? *) + (** Let-bound arguments are present in the evar arguments but not in the + type, so we turn the let into a product. *) + let hyps = Context.Named.drop_bodies hyps in let fold accu d = Term.mkNamedProd_or_LetIn d accu in let t = List.fold_left fold concl hyps in let t, args = nf_args env sigma args t in diff --git a/printing/ppconstr.ml b/printing/ppconstr.ml index e38da45b95..418e13759b 100644 --- a/printing/ppconstr.ml +++ b/printing/ppconstr.ml @@ -295,7 +295,7 @@ let tag_var = tag Tag.variable | CPatOr pl -> hov 0 (prlist_with_sep pr_spcbar (pr_patt mt (lpator,L)) pl), lpator - | CPatNotation ("( _ )",([p],[]),[]) -> + | CPatNotation ((_,"( _ )"),([p],[]),[]) -> pr_patt (fun()->str"(") (max_int,E) p ++ str")", latom | CPatNotation (s,(l,ll),args) -> @@ -665,7 +665,7 @@ let tag_var = tag Tag.variable | CastCoerce -> str ":>"), lcast ) - | CNotation ("( _ )",([t],[],[],[])) -> + | CNotation ((_,"( _ )"),([t],[],[],[])) -> return (pr (fun()->str"(") (max_int,L) t ++ str")", latom) | CNotation (s,env) -> pr_notation (pr mt) pr_patt (pr_binders_gen (pr mt ltop)) s env diff --git a/printing/prettyp.ml b/printing/prettyp.ml index 7258bb9b72..1810cc6588 100644 --- a/printing/prettyp.ml +++ b/printing/prettyp.ml @@ -657,14 +657,10 @@ let gallina_print_library_entry env sigma with_values ent = gallina_print_leaf_entry env sigma with_values (oname,lobj) | (oname,Lib.OpenedSection (dir,_)) -> Some (str " >>>>>>> Section " ++ pr_name oname) - | (oname,Lib.ClosedSection _) -> - Some (str " >>>>>>> Closed Section " ++ pr_name oname) | (_,Lib.CompilingLibrary { obj_dir; _ }) -> Some (str " >>>>>>> Library " ++ DirPath.print obj_dir) | (oname,Lib.OpenedModule _) -> Some (str " >>>>>>> Module " ++ pr_name oname) - | (oname,Lib.ClosedModule _) -> - Some (str " >>>>>>> Closed Module " ++ pr_name oname) let gallina_print_context env sigma with_values = let rec prec n = function @@ -793,9 +789,6 @@ let read_sec_context qid = let rec get_cxt in_cxt = function | (_,Lib.OpenedSection ({obj_dir;_},_) as hd)::rest -> if DirPath.equal dir obj_dir then (hd::in_cxt) else get_cxt (hd::in_cxt) rest - | (_,Lib.ClosedSection _)::rest -> - user_err Pp.(str "Cannot print the contents of a closed section.") - (* LEM: Actually, we could if we wanted to. *) | [] -> [] | hd::rest -> get_cxt (hd::in_cxt) rest in @@ -909,7 +902,7 @@ let inspect env sigma depth = open Classops -let print_coercion_value env sigma v = pr_lconstr_env env sigma (get_coercion_value v) +let print_coercion_value env sigma v = Printer.pr_global v.coe_value let print_class i = let cl,_ = class_info_from_index i in diff --git a/printing/printer.ml b/printing/printer.ml index a77c1ced56..5b3ead181f 100644 --- a/printing/printer.ml +++ b/printing/printer.ml @@ -82,11 +82,10 @@ let pr_econstr_n_core goal_concl_style env sigma n t = pr_constr_expr_n n (extern_constr goal_concl_style env sigma t) let pr_econstr_core goal_concl_style env sigma t = pr_constr_expr (extern_constr goal_concl_style env sigma t) -let pr_leconstr_core goal_concl_style env sigma t = - pr_lconstr_expr (extern_constr goal_concl_style env sigma t) +let pr_leconstr_core = Proof_diffs.pr_leconstr_core let pr_constr_n_env env sigma n c = pr_econstr_n_core false env sigma n (EConstr.of_constr c) -let pr_lconstr_env env sigma c = pr_leconstr_core false env sigma (EConstr.of_constr c) +let pr_lconstr_env = Proof_diffs.pr_lconstr_env let pr_constr_env env sigma c = pr_econstr_core false env sigma (EConstr.of_constr c) let _ = Hook.set Refine.pr_constr pr_constr_env @@ -133,8 +132,7 @@ let pr_lconstr_under_binders c = let pr_etype_core goal_concl_style env sigma t = pr_constr_expr (extern_type goal_concl_style env sigma t) -let pr_letype_core goal_concl_style env sigma t = - pr_lconstr_expr (extern_type goal_concl_style env sigma t) +let pr_letype_core = Proof_diffs.pr_letype_core let pr_ltype_env env sigma c = pr_letype_core false env sigma (EConstr.of_constr c) let pr_type_env env sigma c = pr_etype_core false env sigma (EConstr.of_constr c) diff --git a/printing/proof_diffs.ml b/printing/proof_diffs.ml index 7131ced15b..3a81e908a7 100644 --- a/printing/proof_diffs.ml +++ b/printing/proof_diffs.ml @@ -251,6 +251,11 @@ let pr_letype_core goal_concl_style env sigma t = let pp_of_type env sigma ty = pr_letype_core true env sigma EConstr.(of_constr ty) +let pr_leconstr_core goal_concl_style env sigma t = + Ppconstr.pr_lconstr_expr (Constrextern.extern_constr goal_concl_style env sigma t) + +let pr_lconstr_env env sigma c = pr_leconstr_core false env sigma (EConstr.of_constr c) + (* fetch info from a goal, returning (idents, map, concl_pp) where idents is a list with one entry for each hypothesis, each entry is the list of idents on the lhs of the hypothesis. map is a map from ident to hyp_info @@ -278,10 +283,13 @@ let goal_info goal sigma = line_idents := idents :: !line_idents; let mid = match body with - | Some x -> str " := " ++ pp_of_type env sigma ty ++ str " : " - | None -> str " : " in + | Some c -> + let pb = pr_lconstr_env env sigma c in + let pb = if Constr.isCast c then surround pb else pb in + str " := " ++ pb + | None -> mt() in let ts = pp_of_type env sigma ty in - let rhs_pp = mid ++ ts in + let rhs_pp = mid ++ str " : " ++ ts in let make_entry () = { idents; rhs_pp; done_ = false } in List.iter (fun ident -> map := (StringMap.add ident (make_entry ()) !map); ()) idents diff --git a/printing/proof_diffs.mli b/printing/proof_diffs.mli index 0d3b5821e5..482f03b686 100644 --- a/printing/proof_diffs.mli +++ b/printing/proof_diffs.mli @@ -30,6 +30,8 @@ val diff_first_goal : Proof.t option -> Proof.t option -> Pp.t list * Pp.t open Evd open Proof_type +open Environ +open Constr (** Computes the diff between two goals @@ -46,6 +48,10 @@ val diff_goals : ?prev_gs:(goal sigma) -> goal sigma option -> Pp.t (** Convert a string to a list of token strings using the lexer *) val tokenize_string : string -> string list +val pr_letype_core : bool -> Environ.env -> Evd.evar_map -> EConstr.types -> Pp.t +val pr_leconstr_core : bool -> Environ.env -> Evd.evar_map -> EConstr.constr -> Pp.t +val pr_lconstr_env : env -> evar_map -> constr -> Pp.t + (* Exposed for unit test, don't use these otherwise *) (* output channel for the test log file *) val log_out_ch : out_channel ref diff --git a/stm/stm.ml b/stm/stm.ml index e15b6048ba..2e9bf71e49 100644 --- a/stm/stm.ml +++ b/stm/stm.ml @@ -1103,7 +1103,8 @@ module Backtrack : sig val branches_of : Stateid.t -> backup (* Returns the state that the command should backtract to *) - val undo_vernac_classifier : vernac_control -> Stateid.t * vernac_when + val undo_vernac_classifier : vernac_control -> doc:doc -> Stateid.t * vernac_when + val get_prev_proof : doc:doc -> Stateid.t -> Proof.t option end = struct (* {{{ *) @@ -1161,7 +1162,17 @@ end = struct (* {{{ *) " If your use is intentional, you may want to disable this warning and pass" ^ " the \"-async-proofs-cache force\" option to Coq.")) - let undo_vernac_classifier v = + let back_tactic n (id,_,_,tactic,undo) = + let value = (if tactic then 1 else 0) - undo in + if Int.equal n 0 then `Stop id else `Cont (n-value) + + let get_proof ~doc id = + let open Vernacstate in + match state_of_id ~doc id with + | `Valid (Some vstate) -> Some (Proof_global.proof_of_state vstate.proof) + | _ -> None + + let undo_vernac_classifier v ~doc = if VCS.is_interactive () = `No && !cur_opt.async_proofs_cache <> Some Force then undo_costly_in_batch_mode v; try @@ -1185,9 +1196,7 @@ end = struct (* {{{ *) oid, VtNow | VernacUndo n -> let id = VCS.get_branch_pos (VCS.current_branch ()) in - let oid = fold_until (fun n (id,_,_,tactic,undo) -> - let value = (if tactic then 1 else 0) - undo in - if Int.equal n 0 then `Stop id else `Cont (n-value)) n id in + let oid = fold_until back_tactic n id in oid, VtLater | VernacUndoTo _ | VernacRestart as e -> @@ -1220,8 +1229,16 @@ end = struct (* {{{ *) CErrors.user_err ~hdr:"undo_vernac_classifier" Pp.(str "Cannot undo") + let get_prev_proof ~doc id = + try + let did = fold_until back_tactic 1 id in + get_proof ~doc did + with Not_found -> None + end (* }}} *) +let get_prev_proof = Backtrack.get_prev_proof + let hints = ref Aux_file.empty_aux_file let set_compilation_hints file = hints := Aux_file.load_aux_file_for file @@ -2785,7 +2802,7 @@ let process_transaction ~doc ?(newtip=Stateid.fresh ()) match c with (* Meta *) | VtMeta, _ -> - let id, w = Backtrack.undo_vernac_classifier expr in + let id, w = Backtrack.undo_vernac_classifier expr ~doc in process_back_meta_command ~newtip ~head id x w (* Query *) diff --git a/stm/stm.mli b/stm/stm.mli index 50e7f06095..7f70ea18da 100644 --- a/stm/stm.mli +++ b/stm/stm.mli @@ -110,6 +110,10 @@ val add : doc:doc -> ontop:Stateid.t -> ?newtip:Stateid.t -> bool -> Vernacexpr.vernac_control CAst.t -> doc * Stateid.t * [ `NewTip | `Unfocus of Stateid.t ] +(* Returns the proof state before the last tactic that was applied at or before +the specified state. Used to compute proof diffs. *) +val get_prev_proof : doc:doc -> Stateid.t -> Proof.t option + (* [query at ?report_with cmd] Executes [cmd] at a given state [at], throwing away side effects except messages. Feedback will be sent with [report_with], which defaults to the dummy state id *) diff --git a/stm/vernac_classifier.ml b/stm/vernac_classifier.ml index 6be80d29a5..2170477938 100644 --- a/stm/vernac_classifier.ml +++ b/stm/vernac_classifier.ml @@ -42,13 +42,6 @@ let string_of_vernac_when = function let string_of_vernac_classification (t,w) = string_of_vernac_type t ^ " " ^ string_of_vernac_when w -let classifiers = ref [] -let declare_vernac_classifier - (s : Vernacexpr.extend_name) - (f : Genarg.raw_generic_argument list -> unit -> vernac_classification) -= - classifiers := !classifiers @ [s,f] - let idents_of_name : Names.Name.t -> Names.Id.t list = function | Names.Anonymous -> [] @@ -162,6 +155,7 @@ let classify_vernac e = | VernacDeclareClass _ | VernacDeclareInstances _ | VernacRegister _ | VernacNameSectionHypSet _ + | VernacDeclareCustomEntry _ | VernacComments _ -> VtSideff [], VtLater (* Who knows *) | VernacLoad _ -> VtSideff [], VtNow @@ -194,7 +188,7 @@ let classify_vernac e = | VernacWriteState _ -> VtSideff [], VtNow (* Plugins should classify their commands *) | VernacExtend (s,l) -> - try List.assoc s !classifiers l () + try Vernacentries.get_vernac_classifier s l with Not_found -> anomaly(str"No classifier for"++spc()++str (fst s)++str".") in let rec static_control_classifier ~poly = function diff --git a/stm/vernac_classifier.mli b/stm/vernac_classifier.mli index 45fbfb42af..e82b191418 100644 --- a/stm/vernac_classifier.mli +++ b/stm/vernac_classifier.mli @@ -9,17 +9,12 @@ (************************************************************************) open Vernacexpr -open Genarg val string_of_vernac_classification : vernac_classification -> string (** What does a vernacular do *) val classify_vernac : vernac_control -> vernac_classification -(** Install a vernacular classifier for VernacExtend *) -val declare_vernac_classifier : - Vernacexpr.extend_name -> (raw_generic_argument list -> unit -> vernac_classification) -> unit - (** Standard constant classifiers *) val classify_as_query : vernac_classification val classify_as_sideeff : vernac_classification diff --git a/tactics/hints.ml b/tactics/hints.ml index 09b2e59cea..43a450ea71 100644 --- a/tactics/hints.ml +++ b/tactics/hints.ml @@ -886,20 +886,6 @@ let pr_hint_term env sigma ctx = function let sigma = Evd.merge_context_set Evd.univ_flexible sigma ctx in pr_econstr_env env sigma c -(** We need an object to record the side-effect of registering - global universes associated with a hint. *) -let cache_context_set (_,c) = - Global.push_context_set false c - -let input_context_set : Univ.ContextSet.t -> Libobject.obj = - let open Libobject in - declare_object - { (default_object "Global universe context") with - cache_function = cache_context_set; - load_function = (fun _ -> cache_context_set); - discharge_function = (fun (_,a) -> Some a); - classify_function = (fun a -> Keep a) } - let warn_polymorphic_hint = CWarnings.create ~name:"polymorphic-hint" ~category:"automation" (fun hint -> strbrk"Using polymorphic hint " ++ hint ++ @@ -919,7 +905,7 @@ let fresh_global_or_constr env sigma poly cr = else begin if isgr then warn_polymorphic_hint (pr_hint_term env sigma ctx cr); - Lib.add_anonymous_leaf (input_context_set ctx); + Declare.declare_universe_context false ctx; (c, Univ.ContextSet.empty) end @@ -1315,7 +1301,7 @@ let prepare_hint check (poly,local) env init (sigma,c) = let diff = Univ.ContextSet.diff (Evd.universe_context_set sigma) (Evd.universe_context_set init) in if poly then IsConstr (c', diff) else if local then IsConstr (c', diff) - else (Lib.add_anonymous_leaf (input_context_set diff); + else (Declare.declare_universe_context false diff; IsConstr (c', Univ.ContextSet.empty)) let project_hint ~poly pri l2r r = diff --git a/tactics/tactics.ml b/tactics/tactics.ml index 5fc34619e8..2a8ebe08ca 100644 --- a/tactics/tactics.ml +++ b/tactics/tactics.ml @@ -5063,6 +5063,7 @@ let constr_eq ~strict x y = let unify ?(state=full_transparent_state) x y = Proofview.Goal.enter begin fun gl -> + let env = Proofview.Goal.env gl in let sigma = Proofview.Goal.sigma gl in try let core_flags = @@ -5078,7 +5079,7 @@ let unify ?(state=full_transparent_state) x y = let sigma = w_unify (Tacmach.New.pf_env gl) sigma Reduction.CONV ~flags x y in Proofview.Unsafe.tclEVARS sigma with e when CErrors.noncritical e -> - Tacticals.New.tclFAIL 0 (str"Not unifiable") + Proofview.tclZERO (PretypeError (env, sigma, CannotUnify (x, y, None))) end module Simple = struct diff --git a/test-suite/Makefile b/test-suite/Makefile index 33b4023272..b8aac8b6f8 100644 --- a/test-suite/Makefile +++ b/test-suite/Makefile @@ -192,10 +192,6 @@ PRINT_LOGS?= TRAVIS?= # special because we want to print travis_fold directives ifdef APPVEYOR PRINT_LOGS:=APPVEYOR -else -ifdef CIRCLECI -PRINT_LOGS:=CIRCLECI -endif #CIRCLECI endif #APPVEYOR report: summary.log diff --git a/test-suite/bugs/closed/2733.v b/test-suite/bugs/closed/2733.v index 832de4f913..24dd30b32e 100644 --- a/test-suite/bugs/closed/2733.v +++ b/test-suite/bugs/closed/2733.v @@ -16,6 +16,21 @@ match k,l with |B,l' => Bcons true (Ncons 0 l') end. +(* At some time, the success of trullynul was dependent on the name of + the variables! *) + +Definition trullynul2 k {a} (l : alt_list k a) := +match k,l with + |N,l' => Ncons 0 (Bcons true l') + |B,l' => Bcons true (Ncons 0 l') +end. + +Definition trullynul3 k {z} (l : alt_list k z) := +match k,l with + |N,l' => Ncons 0 (Bcons true l') + |B,l' => Bcons true (Ncons 0 l') +end. + Fixpoint app (P : forall {k k'}, alt_list k k' -> alt_list k k') {t1 t2} (l : alt_list t1 t2) {struct l}: forall {t3}, alt_list t2 t3 -> alt_list t1 t3 := match l with diff --git a/test-suite/bugs/closed/8119.v b/test-suite/bugs/closed/8119.v new file mode 100644 index 0000000000..c6329a7328 --- /dev/null +++ b/test-suite/bugs/closed/8119.v @@ -0,0 +1,46 @@ +Require Import Coq.Strings.String. + +Section T. + Eval vm_compute in let x := tt in _. +(* Error: Anomaly "Uncaught exception Constr.DestKO." Please report at http://coq.inria.fr/bugs/. *) + Eval vm_compute in let _ := Set in _. +(* Error: Anomaly "Uncaught exception Constr.DestKO." Please report at http://coq.inria.fr/bugs/. *) + Eval vm_compute in let _ := Prop in _. +(* Error: Anomaly "Uncaught exception Constr.DestKO." Please report at http://coq.inria.fr/bugs/. *) +End T. + +Section U0. + Let n : unit := tt. + Eval vm_compute in _. +(* Error: Anomaly "Uncaught exception Constr.DestKO." Please report at http://coq.inria.fr/bugs/. *) + Goal exists tt : unit, tt = tt. eexists. vm_compute. Abort. +(* Error: Anomaly "Uncaught exception Constr.DestKO." Please report at http://coq.inria.fr/bugs/. *) +End U0. + +Section S0. + Let LF : string := String (Coq.Strings.Ascii.Ascii false true false true false false false false) "". + Eval vm_compute in _. +(* Error: Anomaly "Uncaught exception Constr.DestKO." Please report at http://coq.inria.fr/bugs/. *) + Goal exists tt : unit, tt = tt. eexists. vm_compute. Abort. +(* Error: Anomaly "Uncaught exception Constr.DestKO." Please report at http://coq.inria.fr/bugs/. *) +End S0. + +Class T := { }. +Section S1. + Context {p : T}. + Let LF : string := String (Coq.Strings.Ascii.Ascii false true false true false false false false) "". + Eval vm_compute in _. +(* Error: Anomaly "Uncaught exception Not_found." Please report at http://coq.inria.fr/bugs/. *) + Goal exists tt : unit, tt = tt. eexists. vm_compute. Abort. +(* Error: Anomaly "Uncaught exception Not_found." Please report at http://coq.inria.fr/bugs/. *) +End S1. + +Class M := { m : Type }. +Section S2. + Context {p : M}. + Let LF : string := String (Coq.Strings.Ascii.Ascii false true false true false false false false) "". + Eval vm_compute in _. +(* Error: Anomaly "File "pretyping/vnorm.ml", line 60, characters 9-15: Assertion failed." *) + Goal exists tt : unit, tt = tt. eexists. vm_compute. Abort. +(* Error: Anomaly "File "pretyping/vnorm.ml", line 60, characters 9-15: Assertion failed." *) +End S2. diff --git a/test-suite/coqdoc/links.html.out b/test-suite/coqdoc/links.html.out index 5e4b676c2f..d2d4d5d764 100644 --- a/test-suite/coqdoc/links.html.out +++ b/test-suite/coqdoc/links.html.out @@ -60,32 +60,32 @@ Various checks for coqdoc <span class="id" title="keyword">Definition</span> <a name="f"><span class="id" title="definition">f</span></a> := <span class="id" title="keyword">∀</span> <span class="id" title="var">C</span>:<span class="id" title="keyword">Prop</span>, <a class="idref" href="Coqdoc.links.html#C"><span class="id" title="variable">C</span></a>.<br/> <br/> -<span class="id" title="keyword">Notation</span> <a name="1a1c7f13320341c3638e9edcc3e6389d"><span class="id" title="notation">"</span></a>n ++ m" := (<a class="idref" href="http://coq.inria.fr/stdlib/Coq.Init.Peano.html#plus"><span class="id" title="abbreviation">plus</span></a> <span class="id" title="var">n</span> <span class="id" title="var">m</span>).<br/> +<span class="id" title="keyword">Notation</span> <a name="f03f7a04ef75ff3ac66ca5c23554e52e"><span class="id" title="notation">"</span></a>n ++ m" := (<a class="idref" href="http://coq.inria.fr/stdlib/Coq.Init.Peano.html#plus"><span class="id" title="abbreviation">plus</span></a> <span class="id" title="var">n</span> <span class="id" title="var">m</span>).<br/> <br/> -<span class="id" title="keyword">Notation</span> <a name="1a1c7f13320341c3638e9edcc3e6389d"><span class="id" title="notation">"</span></a>n ++ m" := (<a class="idref" href="http://coq.inria.fr/stdlib/Coq.Init.Peano.html#mult"><span class="id" title="abbreviation">mult</span></a> <span class="id" title="var">n</span> <span class="id" title="var">m</span>). +<span class="id" title="keyword">Notation</span> <a name="f03f7a04ef75ff3ac66ca5c23554e52e"><span class="id" title="notation">"</span></a>n ++ m" := (<a class="idref" href="http://coq.inria.fr/stdlib/Coq.Init.Peano.html#mult"><span class="id" title="abbreviation">mult</span></a> <span class="id" title="var">n</span> <span class="id" title="var">m</span>). <br/> -<span class="id" title="keyword">Notation</span> <a name="6b97e27793a3d22f5c0d1dd63170fd68"><span class="id" title="notation">"</span></a>n ** m" := (<a class="idref" href="http://coq.inria.fr/stdlib/Coq.Init.Peano.html#plus"><span class="id" title="abbreviation">plus</span></a> <span class="id" title="var">n</span> <span class="id" title="var">m</span>) (<span class="id" title="tactic">at</span> <span class="id" title="keyword">level</span> 60).<br/> +<span class="id" title="keyword">Notation</span> <a name="f07b3676d96b68749d342542fd80e2b0"><span class="id" title="notation">"</span></a>n ** m" := (<a class="idref" href="http://coq.inria.fr/stdlib/Coq.Init.Peano.html#plus"><span class="id" title="abbreviation">plus</span></a> <span class="id" title="var">n</span> <span class="id" title="var">m</span>) (<span class="id" title="tactic">at</span> <span class="id" title="keyword">level</span> 60).<br/> <br/> -<span class="id" title="keyword">Notation</span> <a name="3e01fbae4590c7b7699ff99ce61580e1"><span class="id" title="notation">"</span></a>n ▵ m" := (<a class="idref" href="http://coq.inria.fr/stdlib/Coq.Init.Peano.html#plus"><span class="id" title="abbreviation">plus</span></a> <span class="id" title="var">n</span> <span class="id" title="var">m</span>) (<span class="id" title="tactic">at</span> <span class="id" title="keyword">level</span> 60).<br/> +<span class="id" title="keyword">Notation</span> <a name="a647c51c9816a1b44fcfa5312db8344a"><span class="id" title="notation">"</span></a>n ▵ m" := (<a class="idref" href="http://coq.inria.fr/stdlib/Coq.Init.Peano.html#plus"><span class="id" title="abbreviation">plus</span></a> <span class="id" title="var">n</span> <span class="id" title="var">m</span>) (<span class="id" title="tactic">at</span> <span class="id" title="keyword">level</span> 60).<br/> <br/> -<span class="id" title="keyword">Notation</span> <a name="347f39a83bf7d45676cff54fd7e8966f"><span class="id" title="notation">"</span></a>n '_' ++ 'x' m" := (<a class="idref" href="http://coq.inria.fr/stdlib/Coq.Init.Peano.html#plus"><span class="id" title="abbreviation">plus</span></a> <span class="id" title="var">n</span> <span class="id" title="var">m</span>) (<span class="id" title="tactic">at</span> <span class="id" title="keyword">level</span> 3).<br/> +<span class="id" title="keyword">Notation</span> <a name="3dd9eae9daa65efe5444f5fc3529a2e7"><span class="id" title="notation">"</span></a>n '_' ++ 'x' m" := (<a class="idref" href="http://coq.inria.fr/stdlib/Coq.Init.Peano.html#plus"><span class="id" title="abbreviation">plus</span></a> <span class="id" title="var">n</span> <span class="id" title="var">m</span>) (<span class="id" title="tactic">at</span> <span class="id" title="keyword">level</span> 3).<br/> <br/> -<span class="id" title="keyword">Inductive</span> <a name="eq"><span class="id" title="inductive">eq</span></a> (<span class="id" title="var">A</span>:<span class="id" title="keyword">Type</span>) (<span class="id" title="var">x</span>:<a class="idref" href="Coqdoc.links.html#A"><span class="id" title="variable">A</span></a>) : <span class="id" title="var">A</span> <a class="idref" href="http://coq.inria.fr/stdlib/Coq.Init.Logic.html#d43e996736952df71ebeeae74d10a287"><span class="id" title="notation">→</span></a> <span class="id" title="keyword">Prop</span> := <a name="eq_refl"><span class="id" title="constructor">eq_refl</span></a> : <a class="idref" href="Coqdoc.links.html#x"><span class="id" title="variable">x</span></a> <a class="idref" href="Coqdoc.links.html#8f9364556521ebb498093f28eea2240f"><span class="id" title="notation">=</span></a> <a class="idref" href="Coqdoc.links.html#x"><span class="id" title="variable">x</span></a> <a class="idref" href="Coqdoc.links.html#8f9364556521ebb498093f28eea2240f"><span class="id" title="notation">:></span></a><a class="idref" href="Coqdoc.links.html#A"><span class="id" title="variable">A</span></a><br/> +<span class="id" title="keyword">Inductive</span> <a name="eq"><span class="id" title="inductive">eq</span></a> (<span class="id" title="var">A</span>:<span class="id" title="keyword">Type</span>) (<span class="id" title="var">x</span>:<a class="idref" href="Coqdoc.links.html#A"><span class="id" title="variable">A</span></a>) : <span class="id" title="var">A</span> <a class="idref" href="http://coq.inria.fr/stdlib/Coq.Init.Logic.html#1c93e43e07fbeaeb6a625cb6614beb5d"><span class="id" title="notation">→</span></a> <span class="id" title="keyword">Prop</span> := <a name="eq_refl"><span class="id" title="constructor">eq_refl</span></a> : <a class="idref" href="Coqdoc.links.html#x"><span class="id" title="variable">x</span></a> <a class="idref" href="Coqdoc.links.html#b8b2ebc8e1a8b9aa935c0702efb5dccf"><span class="id" title="notation">=</span></a> <a class="idref" href="Coqdoc.links.html#x"><span class="id" title="variable">x</span></a> <a class="idref" href="Coqdoc.links.html#b8b2ebc8e1a8b9aa935c0702efb5dccf"><span class="id" title="notation">:></span></a><a class="idref" href="Coqdoc.links.html#A"><span class="id" title="variable">A</span></a><br/> <br/> -<span class="id" title="keyword">where</span> <a name="8f9364556521ebb498093f28eea2240f"><span class="id" title="notation">"</span></a>x = y :> A" := (@<a class="idref" href="Coqdoc.links.html#eq"><span class="id" title="inductive">eq</span></a> <span class="id" title="var">A</span> <span class="id" title="var">x</span> <span class="id" title="var">y</span>) : <span class="id" title="var">type_scope</span>.<br/> +<span class="id" title="keyword">where</span> <a name="b8b2ebc8e1a8b9aa935c0702efb5dccf"><span class="id" title="notation">"</span></a>x = y :> A" := (@<a class="idref" href="Coqdoc.links.html#eq"><span class="id" title="inductive">eq</span></a> <span class="id" title="var">A</span> <span class="id" title="var">x</span> <span class="id" title="var">y</span>) : <span class="id" title="var">type_scope</span>.<br/> <br/> -<span class="id" title="keyword">Definition</span> <a name="eq0"><span class="id" title="definition">eq0</span></a> := 0 <a class="idref" href="Coqdoc.links.html#8f9364556521ebb498093f28eea2240f"><span class="id" title="notation">=</span></a> 0 <a class="idref" href="Coqdoc.links.html#8f9364556521ebb498093f28eea2240f"><span class="id" title="notation">:></span></a> <a class="idref" href="http://coq.inria.fr/stdlib/Coq.Init.Datatypes.html#nat"><span class="id" title="inductive">nat</span></a>.<br/> +<span class="id" title="keyword">Definition</span> <a name="eq0"><span class="id" title="definition">eq0</span></a> := 0 <a class="idref" href="Coqdoc.links.html#b8b2ebc8e1a8b9aa935c0702efb5dccf"><span class="id" title="notation">=</span></a> 0 <a class="idref" href="Coqdoc.links.html#b8b2ebc8e1a8b9aa935c0702efb5dccf"><span class="id" title="notation">:></span></a> <a class="idref" href="http://coq.inria.fr/stdlib/Coq.Init.Datatypes.html#nat"><span class="id" title="inductive">nat</span></a>.<br/> <br/> -<span class="id" title="keyword">Notation</span> <a name="548d1059c499c9b2a9b95b07e68c2090"><span class="id" title="notation">"</span></a>( x # y ; .. ; z )" := (<a class="idref" href="http://coq.inria.fr/stdlib/Coq.Init.Datatypes.html#pair"><span class="id" title="constructor">pair</span></a> .. (<a class="idref" href="http://coq.inria.fr/stdlib/Coq.Init.Datatypes.html#pair"><span class="id" title="constructor">pair</span></a> <span class="id" title="var">x</span> <span class="id" title="var">y</span>) .. <span class="id" title="var">z</span>).<br/> +<span class="id" title="keyword">Notation</span> <a name="2c0c193cd2aedf7ecdb713db64dbfce6"><span class="id" title="notation">"</span></a>( x # y ; .. ; z )" := (<a class="idref" href="http://coq.inria.fr/stdlib/Coq.Init.Datatypes.html#pair"><span class="id" title="constructor">pair</span></a> .. (<a class="idref" href="http://coq.inria.fr/stdlib/Coq.Init.Datatypes.html#pair"><span class="id" title="constructor">pair</span></a> <span class="id" title="var">x</span> <span class="id" title="var">y</span>) .. <span class="id" title="var">z</span>).<br/> <br/> -<span class="id" title="keyword">Definition</span> <a name="9f5a1d89cbd4d38f5e289576db7123d1"><span class="id" title="definition">b_α</span></a> := <a class="idref" href="http://coq.inria.fr/stdlib/Coq.Init.Datatypes.html#44400027531d4bc3f586a1997dc874c0"><span class="id" title="notation">(</span></a><a class="idref" href="Coqdoc.links.html#548d1059c499c9b2a9b95b07e68c2090"><span class="id" title="notation">(</span></a>0<a class="idref" href="Coqdoc.links.html#548d1059c499c9b2a9b95b07e68c2090"><span class="id" title="notation">#</span></a>0<a class="idref" href="Coqdoc.links.html#548d1059c499c9b2a9b95b07e68c2090"><span class="id" title="notation">;</span></a>0<a class="idref" href="Coqdoc.links.html#548d1059c499c9b2a9b95b07e68c2090"><span class="id" title="notation">)</span></a> <a class="idref" href="http://coq.inria.fr/stdlib/Coq.Init.Datatypes.html#44400027531d4bc3f586a1997dc874c0"><span class="id" title="notation">,</span></a> <a class="idref" href="http://coq.inria.fr/stdlib/Coq.Init.Datatypes.html#44400027531d4bc3f586a1997dc874c0"><span class="id" title="notation">(</span></a>0 <a class="idref" href="Coqdoc.links.html#6b97e27793a3d22f5c0d1dd63170fd68"><span class="id" title="notation">**</span></a> 0<a class="idref" href="http://coq.inria.fr/stdlib/Coq.Init.Datatypes.html#44400027531d4bc3f586a1997dc874c0"><span class="id" title="notation">))</span></a>.<br/> +<span class="id" title="keyword">Definition</span> <a name="9f5a1d89cbd4d38f5e289576db7123d1"><span class="id" title="definition">b_α</span></a> := <a class="idref" href="http://coq.inria.fr/stdlib/Coq.Init.Datatypes.html#e6756e10c36f149b18b4a8741ed83079"><span class="id" title="notation">(</span></a><a class="idref" href="Coqdoc.links.html#2c0c193cd2aedf7ecdb713db64dbfce6"><span class="id" title="notation">(</span></a>0<a class="idref" href="Coqdoc.links.html#2c0c193cd2aedf7ecdb713db64dbfce6"><span class="id" title="notation">#</span></a>0<a class="idref" href="Coqdoc.links.html#2c0c193cd2aedf7ecdb713db64dbfce6"><span class="id" title="notation">;</span></a>0<a class="idref" href="Coqdoc.links.html#2c0c193cd2aedf7ecdb713db64dbfce6"><span class="id" title="notation">)</span></a> <a class="idref" href="http://coq.inria.fr/stdlib/Coq.Init.Datatypes.html#e6756e10c36f149b18b4a8741ed83079"><span class="id" title="notation">,</span></a> <a class="idref" href="http://coq.inria.fr/stdlib/Coq.Init.Datatypes.html#e6756e10c36f149b18b4a8741ed83079"><span class="id" title="notation">(</span></a>0 <a class="idref" href="Coqdoc.links.html#f07b3676d96b68749d342542fd80e2b0"><span class="id" title="notation">**</span></a> 0<a class="idref" href="http://coq.inria.fr/stdlib/Coq.Init.Datatypes.html#e6756e10c36f149b18b4a8741ed83079"><span class="id" title="notation">))</span></a>.<br/> <br/> <span class="id" title="keyword">Notation</span> <a name="h"><span class="id" title="abbreviation">h</span></a> := <a class="idref" href="Coqdoc.links.html#a"><span class="id" title="definition">a</span></a>.<br/> @@ -97,7 +97,7 @@ Various checks for coqdoc <span class="id" title="keyword">Variables</span> <a name="test.b'"><span class="id" title="variable">b'</span></a> <a name="test.b2"><span class="id" title="variable">b2</span></a>: <a class="idref" href="http://coq.inria.fr/stdlib/Coq.Init.Datatypes.html#nat"><span class="id" title="inductive">nat</span></a>.<br/> <br/> - <span class="id" title="keyword">Notation</span> <a name="4ab0449b36c75cf94e08c5822ea83e3d"><span class="id" title="notation">"</span></a>n + m" := (<span class="id" title="var">n</span> <a class="idref" href="Coqdoc.links.html#3e01fbae4590c7b7699ff99ce61580e1"><span class="id" title="notation">▵</span></a> <span class="id" title="var">m</span>) : <span class="id" title="var">my_scope</span>.<br/> + <span class="id" title="keyword">Notation</span> <a name="2158f15740ce05a939b657be222c26d6"><span class="id" title="notation">"</span></a>n + m" := (<span class="id" title="var">n</span> <a class="idref" href="Coqdoc.links.html#a647c51c9816a1b44fcfa5312db8344a"><span class="id" title="notation">▵</span></a> <span class="id" title="var">m</span>) : <span class="id" title="var">my_scope</span>.<br/> <br/> <span class="id" title="keyword">Delimit</span> <span class="id" title="keyword">Scope</span> <span class="id" title="var">my_scope</span> <span class="id" title="keyword">with</span> <span class="id" title="var">my</span>.<br/> @@ -106,19 +106,19 @@ Various checks for coqdoc <span class="id" title="keyword">Notation</span> <a name="l"><span class="id" title="abbreviation">l</span></a> := 0.<br/> <br/> - <span class="id" title="keyword">Definition</span> <a name="ab410a966ac148e9b78c65c6cdf301fd"><span class="id" title="definition">α</span></a> := (0 <a class="idref" href="Coqdoc.links.html#4ab0449b36c75cf94e08c5822ea83e3d"><span class="id" title="notation">+</span></a> <a class="idref" href="Coqdoc.links.html#l"><span class="id" title="abbreviation">l</span></a>)%<span class="id" title="var">my</span>.<br/> + <span class="id" title="keyword">Definition</span> <a name="ab410a966ac148e9b78c65c6cdf301fd"><span class="id" title="definition">α</span></a> := (0 <a class="idref" href="Coqdoc.links.html#2158f15740ce05a939b657be222c26d6"><span class="id" title="notation">+</span></a> <a class="idref" href="Coqdoc.links.html#l"><span class="id" title="abbreviation">l</span></a>)%<span class="id" title="var">my</span>.<br/> <br/> - <span class="id" title="keyword">Definition</span> <a name="a'"><span class="id" title="definition">a'</span></a> <span class="id" title="var">b</span> := <a class="idref" href="Coqdoc.links.html#test.b'"><span class="id" title="variable">b'</span></a><a class="idref" href="Coqdoc.links.html#1a1c7f13320341c3638e9edcc3e6389d"><span class="id" title="notation">++</span></a>0<a class="idref" href="Coqdoc.links.html#1a1c7f13320341c3638e9edcc3e6389d"><span class="id" title="notation">++</span></a><a class="idref" href="Coqdoc.links.html#test.b2"><span class="id" title="variable">b2</span></a> <a class="idref" href="Coqdoc.links.html#347f39a83bf7d45676cff54fd7e8966f"><span class="id" title="notation">_</span></a> <a class="idref" href="Coqdoc.links.html#347f39a83bf7d45676cff54fd7e8966f"><span class="id" title="notation">++</span></a><a class="idref" href="Coqdoc.links.html#347f39a83bf7d45676cff54fd7e8966f"><span class="id" title="notation">x</span></a> <a class="idref" href="Coqdoc.links.html#b"><span class="id" title="variable">b</span></a>.<br/> + <span class="id" title="keyword">Definition</span> <a name="a'"><span class="id" title="definition">a'</span></a> <span class="id" title="var">b</span> := <a class="idref" href="Coqdoc.links.html#test.b'"><span class="id" title="variable">b'</span></a><a class="idref" href="Coqdoc.links.html#f03f7a04ef75ff3ac66ca5c23554e52e"><span class="id" title="notation">++</span></a>0<a class="idref" href="Coqdoc.links.html#f03f7a04ef75ff3ac66ca5c23554e52e"><span class="id" title="notation">++</span></a><a class="idref" href="Coqdoc.links.html#test.b2"><span class="id" title="variable">b2</span></a> <a class="idref" href="Coqdoc.links.html#3dd9eae9daa65efe5444f5fc3529a2e7"><span class="id" title="notation">_</span></a> <a class="idref" href="Coqdoc.links.html#3dd9eae9daa65efe5444f5fc3529a2e7"><span class="id" title="notation">++</span></a><a class="idref" href="Coqdoc.links.html#3dd9eae9daa65efe5444f5fc3529a2e7"><span class="id" title="notation">x</span></a> <a class="idref" href="Coqdoc.links.html#b"><span class="id" title="variable">b</span></a>.<br/> <br/> - <span class="id" title="keyword">Definition</span> <a name="c"><span class="id" title="definition">c</span></a> := <a class="idref" href="http://coq.inria.fr/stdlib/Coq.Init.Specif.html#5bf2050e90b21ebc82dc5463d1ba338e"><span class="id" title="notation">{</span></a><a class="idref" href="http://coq.inria.fr/stdlib/Coq.Init.Logic.html#True"><span class="id" title="inductive">True</span></a><a class="idref" href="http://coq.inria.fr/stdlib/Coq.Init.Specif.html#5bf2050e90b21ebc82dc5463d1ba338e"><span class="id" title="notation">}+{</span></a><a class="idref" href="http://coq.inria.fr/stdlib/Coq.Init.Logic.html#True"><span class="id" title="inductive">True</span></a><a class="idref" href="http://coq.inria.fr/stdlib/Coq.Init.Specif.html#5bf2050e90b21ebc82dc5463d1ba338e"><span class="id" title="notation">}</span></a>.<br/> + <span class="id" title="keyword">Definition</span> <a name="c"><span class="id" title="definition">c</span></a> := <a class="idref" href="http://coq.inria.fr/stdlib/Coq.Init.Specif.html#87727981cdc1579fef00b9d9c1d3b9da"><span class="id" title="notation">{</span></a><a class="idref" href="http://coq.inria.fr/stdlib/Coq.Init.Logic.html#True"><span class="id" title="inductive">True</span></a><a class="idref" href="http://coq.inria.fr/stdlib/Coq.Init.Specif.html#87727981cdc1579fef00b9d9c1d3b9da"><span class="id" title="notation">}+{</span></a><a class="idref" href="http://coq.inria.fr/stdlib/Coq.Init.Logic.html#True"><span class="id" title="inductive">True</span></a><a class="idref" href="http://coq.inria.fr/stdlib/Coq.Init.Specif.html#87727981cdc1579fef00b9d9c1d3b9da"><span class="id" title="notation">}</span></a>.<br/> <br/> - <span class="id" title="keyword">Definition</span> <a name="d"><span class="id" title="definition">d</span></a> := (1<a class="idref" href="http://coq.inria.fr/stdlib/Coq.Init.Peano.html#b3eea360671e1b32b18a26e15b3aace3"><span class="id" title="notation">+</span></a>2)%<span class="id" title="var">nat</span>.<br/> + <span class="id" title="keyword">Definition</span> <a name="d"><span class="id" title="definition">d</span></a> := (1<a class="idref" href="http://coq.inria.fr/stdlib/Coq.Init.Peano.html#0dacc1786c5ba797d47dd85006231633"><span class="id" title="notation">+</span></a>2)%<span class="id" title="var">nat</span>.<br/> <br/> - <span class="id" title="keyword">Lemma</span> <a name="e"><span class="id" title="lemma">e</span></a> : <a class="idref" href="http://coq.inria.fr/stdlib/Coq.Init.Datatypes.html#nat"><span class="id" title="inductive">nat</span></a> <a class="idref" href="http://coq.inria.fr/stdlib/Coq.Init.Datatypes.html#3dcaec3b772747610227247939f96b01"><span class="id" title="notation">+</span></a> <a class="idref" href="http://coq.inria.fr/stdlib/Coq.Init.Datatypes.html#nat"><span class="id" title="inductive">nat</span></a>.<br/> + <span class="id" title="keyword">Lemma</span> <a name="e"><span class="id" title="lemma">e</span></a> : <a class="idref" href="http://coq.inria.fr/stdlib/Coq.Init.Datatypes.html#nat"><span class="id" title="inductive">nat</span></a> <a class="idref" href="http://coq.inria.fr/stdlib/Coq.Init.Datatypes.html#e03f39daf98516fa530d3f6f5a1b4d92"><span class="id" title="notation">+</span></a> <a class="idref" href="http://coq.inria.fr/stdlib/Coq.Init.Datatypes.html#nat"><span class="id" title="inductive">nat</span></a>.<br/> <span class="id" title="var">Admitted</span>.<br/> <br/> @@ -137,7 +137,7 @@ Various checks for coqdoc <span class="id" title="keyword">Variables</span> <a name="test2.test.b2"><span class="id" title="variable">b2</span></a>: <a class="idref" href="http://coq.inria.fr/stdlib/Coq.Init.Datatypes.html#nat"><span class="id" title="inductive">nat</span></a>.<br/> <br/> - <span class="id" title="keyword">Definition</span> <a name="a''"><span class="id" title="definition">a''</span></a> <span class="id" title="var">b</span> := <a class="idref" href="Coqdoc.links.html#test2.b'"><span class="id" title="variable">b'</span></a> <a class="idref" href="Coqdoc.links.html#1a1c7f13320341c3638e9edcc3e6389d"><span class="id" title="notation">++</span></a> <a class="idref" href="http://coq.inria.fr/stdlib/Coq.Init.Datatypes.html#O"><span class="id" title="constructor">O</span></a> <a class="idref" href="Coqdoc.links.html#1a1c7f13320341c3638e9edcc3e6389d"><span class="id" title="notation">++</span></a> <a class="idref" href="Coqdoc.links.html#test2.test.b2"><span class="id" title="variable">b2</span></a> <a class="idref" href="Coqdoc.links.html#347f39a83bf7d45676cff54fd7e8966f"><span class="id" title="notation">_</span></a> <a class="idref" href="Coqdoc.links.html#347f39a83bf7d45676cff54fd7e8966f"><span class="id" title="notation">++</span></a> <a class="idref" href="Coqdoc.links.html#347f39a83bf7d45676cff54fd7e8966f"><span class="id" title="notation">x</span></a> <a class="idref" href="Coqdoc.links.html#b"><span class="id" title="variable">b</span></a> <a class="idref" href="http://coq.inria.fr/stdlib/Coq.Init.Peano.html#b3eea360671e1b32b18a26e15b3aace3"><span class="id" title="notation">+</span></a> <a class="idref" href="Coqdoc.links.html#h"><span class="id" title="abbreviation">h</span></a> 0.<br/> + <span class="id" title="keyword">Definition</span> <a name="a''"><span class="id" title="definition">a''</span></a> <span class="id" title="var">b</span> := <a class="idref" href="Coqdoc.links.html#test2.b'"><span class="id" title="variable">b'</span></a> <a class="idref" href="Coqdoc.links.html#f03f7a04ef75ff3ac66ca5c23554e52e"><span class="id" title="notation">++</span></a> <a class="idref" href="http://coq.inria.fr/stdlib/Coq.Init.Datatypes.html#O"><span class="id" title="constructor">O</span></a> <a class="idref" href="Coqdoc.links.html#f03f7a04ef75ff3ac66ca5c23554e52e"><span class="id" title="notation">++</span></a> <a class="idref" href="Coqdoc.links.html#test2.test.b2"><span class="id" title="variable">b2</span></a> <a class="idref" href="Coqdoc.links.html#3dd9eae9daa65efe5444f5fc3529a2e7"><span class="id" title="notation">_</span></a> <a class="idref" href="Coqdoc.links.html#3dd9eae9daa65efe5444f5fc3529a2e7"><span class="id" title="notation">++</span></a> <a class="idref" href="Coqdoc.links.html#3dd9eae9daa65efe5444f5fc3529a2e7"><span class="id" title="notation">x</span></a> <a class="idref" href="Coqdoc.links.html#b"><span class="id" title="variable">b</span></a> <a class="idref" href="http://coq.inria.fr/stdlib/Coq.Init.Peano.html#0dacc1786c5ba797d47dd85006231633"><span class="id" title="notation">+</span></a> <a class="idref" href="Coqdoc.links.html#h"><span class="id" title="abbreviation">h</span></a> 0.<br/> <br/> <span class="id" title="keyword">End</span> <a class="idref" href="Coqdoc.links.html#test2.test"><span class="id" title="section">test</span></a>.<br/> diff --git a/test-suite/coqdoc/links.tex.out b/test-suite/coqdoc/links.tex.out index f42db99dc2..24f96ff1e6 100644 --- a/test-suite/coqdoc/links.tex.out +++ b/test-suite/coqdoc/links.tex.out @@ -51,34 +51,34 @@ Various checks for coqdoc \coqdockw{Definition} \coqdef{Coqdoc.links.f}{f}{\coqdocdefinition{f}} := \coqdockw{\ensuremath{\forall}} \coqdocvar{C}:\coqdockw{Prop}, \coqdocvariable{C}.\coqdoceol \coqdocemptyline \coqdocnoindent -\coqdockw{Notation} \coqdef{Coqdoc.links.::x '++' x}{"}{"}n ++ m" := (\coqexternalref{plus}{http://coq.inria.fr/stdlib/Coq.Init.Peano}{\coqdocabbreviation{plus}} \coqdocvar{n} \coqdocvar{m}).\coqdoceol +\coqdockw{Notation} \coqdef{Coqdoc.links.:::x '++' x}{"}{"}n ++ m" := (\coqexternalref{plus}{http://coq.inria.fr/stdlib/Coq.Init.Peano}{\coqdocabbreviation{plus}} \coqdocvar{n} \coqdocvar{m}).\coqdoceol \coqdocemptyline \coqdocnoindent -\coqdockw{Notation} \coqdef{Coqdoc.links.::x '++' x}{"}{"}n ++ m" := (\coqexternalref{mult}{http://coq.inria.fr/stdlib/Coq.Init.Peano}{\coqdocabbreviation{mult}} \coqdocvar{n} \coqdocvar{m}). \coqdocemptyline +\coqdockw{Notation} \coqdef{Coqdoc.links.:::x '++' x}{"}{"}n ++ m" := (\coqexternalref{mult}{http://coq.inria.fr/stdlib/Coq.Init.Peano}{\coqdocabbreviation{mult}} \coqdocvar{n} \coqdocvar{m}). \coqdocemptyline \coqdocnoindent -\coqdockw{Notation} \coqdef{Coqdoc.links.::x '**' x}{"}{"}n ** m" := (\coqexternalref{plus}{http://coq.inria.fr/stdlib/Coq.Init.Peano}{\coqdocabbreviation{plus}} \coqdocvar{n} \coqdocvar{m}) (\coqdoctac{at} \coqdockw{level} 60).\coqdoceol +\coqdockw{Notation} \coqdef{Coqdoc.links.:::x '**' x}{"}{"}n ** m" := (\coqexternalref{plus}{http://coq.inria.fr/stdlib/Coq.Init.Peano}{\coqdocabbreviation{plus}} \coqdocvar{n} \coqdocvar{m}) (\coqdoctac{at} \coqdockw{level} 60).\coqdoceol \coqdocemptyline \coqdocnoindent -\coqdockw{Notation} \coqdef{Coqdoc.links.::x 'xE2x96xB5' x}{"}{"}n ▵ m" := (\coqexternalref{plus}{http://coq.inria.fr/stdlib/Coq.Init.Peano}{\coqdocabbreviation{plus}} \coqdocvar{n} \coqdocvar{m}) (\coqdoctac{at} \coqdockw{level} 60).\coqdoceol +\coqdockw{Notation} \coqdef{Coqdoc.links.:::x 'xE2x96xB5' x}{"}{"}n ▵ m" := (\coqexternalref{plus}{http://coq.inria.fr/stdlib/Coq.Init.Peano}{\coqdocabbreviation{plus}} \coqdocvar{n} \coqdocvar{m}) (\coqdoctac{at} \coqdockw{level} 60).\coqdoceol \coqdocemptyline \coqdocnoindent -\coqdockw{Notation} \coqdef{Coqdoc.links.::x ''' ''' '++' 'x' x}{"}{"}n '\_' ++ 'x' m" := (\coqexternalref{plus}{http://coq.inria.fr/stdlib/Coq.Init.Peano}{\coqdocabbreviation{plus}} \coqdocvar{n} \coqdocvar{m}) (\coqdoctac{at} \coqdockw{level} 3).\coqdoceol +\coqdockw{Notation} \coqdef{Coqdoc.links.:::x ''' ''' '++' 'x' x}{"}{"}n '\_' ++ 'x' m" := (\coqexternalref{plus}{http://coq.inria.fr/stdlib/Coq.Init.Peano}{\coqdocabbreviation{plus}} \coqdocvar{n} \coqdocvar{m}) (\coqdoctac{at} \coqdockw{level} 3).\coqdoceol \coqdocemptyline \coqdocnoindent -\coqdockw{Inductive} \coqdef{Coqdoc.links.eq}{eq}{\coqdocinductive{eq}} (\coqdocvar{A}:\coqdockw{Type}) (\coqdocvar{x}:\coqdocvariable{A}) : \coqdocvar{A} \coqexternalref{:type scope:x '->' x}{http://coq.inria.fr/stdlib/Coq.Init.Logic}{\coqdocnotation{\ensuremath{\rightarrow}}} \coqdockw{Prop} := \coqdef{Coqdoc.links.eq refl}{eq\_refl}{\coqdocconstructor{eq\_refl}} : \coqdocvariable{x} \coqref{Coqdoc.links.:type scope:x '=' x ':>' x}{\coqdocnotation{=}} \coqdocvariable{x} \coqref{Coqdoc.links.:type scope:x '=' x ':>' x}{\coqdocnotation{:>}}\coqdocvariable{A}\coqdoceol +\coqdockw{Inductive} \coqdef{Coqdoc.links.eq}{eq}{\coqdocinductive{eq}} (\coqdocvar{A}:\coqdockw{Type}) (\coqdocvar{x}:\coqdocvariable{A}) : \coqdocvar{A} \coqexternalref{::type scope:x '->' x}{http://coq.inria.fr/stdlib/Coq.Init.Logic}{\coqdocnotation{\ensuremath{\rightarrow}}} \coqdockw{Prop} := \coqdef{Coqdoc.links.eq refl}{eq\_refl}{\coqdocconstructor{eq\_refl}} : \coqdocvariable{x} \coqref{Coqdoc.links.::type scope:x '=' x ':>' x}{\coqdocnotation{=}} \coqdocvariable{x} \coqref{Coqdoc.links.::type scope:x '=' x ':>' x}{\coqdocnotation{:>}}\coqdocvariable{A}\coqdoceol \coqdocnoindent \coqdoceol \coqdocnoindent -\coqdockw{where} \coqdef{Coqdoc.links.:type scope:x '=' x ':>' x}{"}{"}x = y :> A" := (@\coqref{Coqdoc.links.eq}{\coqdocinductive{eq}} \coqdocvar{A} \coqdocvar{x} \coqdocvar{y}) : \coqdocvar{type\_scope}.\coqdoceol +\coqdockw{where} \coqdef{Coqdoc.links.::type scope:x '=' x ':>' x}{"}{"}x = y :> A" := (@\coqref{Coqdoc.links.eq}{\coqdocinductive{eq}} \coqdocvar{A} \coqdocvar{x} \coqdocvar{y}) : \coqdocvar{type\_scope}.\coqdoceol \coqdocemptyline \coqdocnoindent -\coqdockw{Definition} \coqdef{Coqdoc.links.eq0}{eq0}{\coqdocdefinition{eq0}} := 0 \coqref{Coqdoc.links.:type scope:x '=' x ':>' x}{\coqdocnotation{=}} 0 \coqref{Coqdoc.links.:type scope:x '=' x ':>' x}{\coqdocnotation{:>}} \coqexternalref{nat}{http://coq.inria.fr/stdlib/Coq.Init.Datatypes}{\coqdocinductive{nat}}.\coqdoceol +\coqdockw{Definition} \coqdef{Coqdoc.links.eq0}{eq0}{\coqdocdefinition{eq0}} := 0 \coqref{Coqdoc.links.::type scope:x '=' x ':>' x}{\coqdocnotation{=}} 0 \coqref{Coqdoc.links.::type scope:x '=' x ':>' x}{\coqdocnotation{:>}} \coqexternalref{nat}{http://coq.inria.fr/stdlib/Coq.Init.Datatypes}{\coqdocinductive{nat}}.\coqdoceol \coqdocemptyline \coqdocnoindent -\coqdockw{Notation} \coqdef{Coqdoc.links.::'(' x 'x23' x ';' '..' ';' x ')'}{"}{"}( x \# y ; .. ; z )" := (\coqexternalref{pair}{http://coq.inria.fr/stdlib/Coq.Init.Datatypes}{\coqdocconstructor{pair}} .. (\coqexternalref{pair}{http://coq.inria.fr/stdlib/Coq.Init.Datatypes}{\coqdocconstructor{pair}} \coqdocvar{x} \coqdocvar{y}) .. \coqdocvar{z}).\coqdoceol +\coqdockw{Notation} \coqdef{Coqdoc.links.:::'(' x 'x23' x ';' '..' ';' x ')'}{"}{"}( x \# y ; .. ; z )" := (\coqexternalref{pair}{http://coq.inria.fr/stdlib/Coq.Init.Datatypes}{\coqdocconstructor{pair}} .. (\coqexternalref{pair}{http://coq.inria.fr/stdlib/Coq.Init.Datatypes}{\coqdocconstructor{pair}} \coqdocvar{x} \coqdocvar{y}) .. \coqdocvar{z}).\coqdoceol \coqdocemptyline \coqdocnoindent -\coqdockw{Definition} \coqdef{Coqdoc.links.b xCExB1}{b\_α}{\coqdocdefinition{b\_α}} := \coqexternalref{:core scope:'(' x ',' x ',' '..' ',' x ')'}{http://coq.inria.fr/stdlib/Coq.Init.Datatypes}{\coqdocnotation{(}}\coqref{Coqdoc.links.::'(' x 'x23' x ';' '..' ';' x ')'}{\coqdocnotation{(}}0\coqref{Coqdoc.links.::'(' x 'x23' x ';' '..' ';' x ')'}{\coqdocnotation{\#}}0\coqref{Coqdoc.links.::'(' x 'x23' x ';' '..' ';' x ')'}{\coqdocnotation{;}}0\coqref{Coqdoc.links.::'(' x 'x23' x ';' '..' ';' x ')'}{\coqdocnotation{)}} \coqexternalref{:core scope:'(' x ',' x ',' '..' ',' x ')'}{http://coq.inria.fr/stdlib/Coq.Init.Datatypes}{\coqdocnotation{,}} \coqexternalref{:core scope:'(' x ',' x ',' '..' ',' x ')'}{http://coq.inria.fr/stdlib/Coq.Init.Datatypes}{\coqdocnotation{(}}0 \coqref{Coqdoc.links.::x '**' x}{\coqdocnotation{**}} 0\coqexternalref{:core scope:'(' x ',' x ',' '..' ',' x ')'}{http://coq.inria.fr/stdlib/Coq.Init.Datatypes}{\coqdocnotation{))}}.\coqdoceol +\coqdockw{Definition} \coqdef{Coqdoc.links.b xCExB1}{b\_α}{\coqdocdefinition{b\_α}} := \coqexternalref{::core scope:'(' x ',' x ',' '..' ',' x ')'}{http://coq.inria.fr/stdlib/Coq.Init.Datatypes}{\coqdocnotation{(}}\coqref{Coqdoc.links.:::'(' x 'x23' x ';' '..' ';' x ')'}{\coqdocnotation{(}}0\coqref{Coqdoc.links.:::'(' x 'x23' x ';' '..' ';' x ')'}{\coqdocnotation{\#}}0\coqref{Coqdoc.links.:::'(' x 'x23' x ';' '..' ';' x ')'}{\coqdocnotation{;}}0\coqref{Coqdoc.links.:::'(' x 'x23' x ';' '..' ';' x ')'}{\coqdocnotation{)}} \coqexternalref{::core scope:'(' x ',' x ',' '..' ',' x ')'}{http://coq.inria.fr/stdlib/Coq.Init.Datatypes}{\coqdocnotation{,}} \coqexternalref{::core scope:'(' x ',' x ',' '..' ',' x ')'}{http://coq.inria.fr/stdlib/Coq.Init.Datatypes}{\coqdocnotation{(}}0 \coqref{Coqdoc.links.:::x '**' x}{\coqdocnotation{**}} 0\coqexternalref{::core scope:'(' x ',' x ',' '..' ',' x ')'}{http://coq.inria.fr/stdlib/Coq.Init.Datatypes}{\coqdocnotation{))}}.\coqdoceol \coqdocemptyline \coqdocnoindent \coqdockw{Notation} \coqdef{Coqdoc.links.h}{h}{\coqdocabbreviation{h}} := \coqref{Coqdoc.links.a}{\coqdocdefinition{a}}.\coqdoceol @@ -90,7 +90,7 @@ Various checks for coqdoc \coqdockw{Variables} \coqdef{Coqdoc.links.test.b'}{b'}{\coqdocvariable{b'}} \coqdef{Coqdoc.links.test.b2}{b2}{\coqdocvariable{b2}}: \coqexternalref{nat}{http://coq.inria.fr/stdlib/Coq.Init.Datatypes}{\coqdocinductive{nat}}.\coqdoceol \coqdocemptyline \coqdocindent{2.00em} -\coqdockw{Notation} \coqdef{Coqdoc.links.test.:my scope:x '+' x}{"}{"}n + m" := (\coqdocvar{n} \coqref{Coqdoc.links.::x 'xE2x96xB5' x}{\coqdocnotation{▵}} \coqdocvar{m}) : \coqdocvar{my\_scope}.\coqdoceol +\coqdockw{Notation} \coqdef{Coqdoc.links.test.::my scope:x '+' x}{"}{"}n + m" := (\coqdocvar{n} \coqref{Coqdoc.links.:::x 'xE2x96xB5' x}{\coqdocnotation{▵}} \coqdocvar{m}) : \coqdocvar{my\_scope}.\coqdoceol \coqdocemptyline \coqdocindent{2.00em} \coqdockw{Delimit} \coqdockw{Scope} \coqdocvar{my\_scope} \coqdockw{with} \coqdocvar{my}.\coqdoceol @@ -99,19 +99,19 @@ Various checks for coqdoc \coqdockw{Notation} \coqdef{Coqdoc.links.l}{l}{\coqdocabbreviation{l}} := 0.\coqdoceol \coqdocemptyline \coqdocindent{2.00em} -\coqdockw{Definition} \coqdef{Coqdoc.links.xCExB1}{α}{\coqdocdefinition{α}} := (0 \coqref{Coqdoc.links.test.:my scope:x '+' x}{\coqdocnotation{+}} \coqref{Coqdoc.links.l}{\coqdocabbreviation{l}})\%\coqdocvar{my}.\coqdoceol +\coqdockw{Definition} \coqdef{Coqdoc.links.xCExB1}{α}{\coqdocdefinition{α}} := (0 \coqref{Coqdoc.links.test.::my scope:x '+' x}{\coqdocnotation{+}} \coqref{Coqdoc.links.l}{\coqdocabbreviation{l}})\%\coqdocvar{my}.\coqdoceol \coqdocemptyline \coqdocindent{2.00em} -\coqdockw{Definition} \coqdef{Coqdoc.links.a'}{a'}{\coqdocdefinition{a'}} \coqdocvar{b} := \coqdocvariable{b'}\coqref{Coqdoc.links.::x '++' x}{\coqdocnotation{++}}0\coqref{Coqdoc.links.::x '++' x}{\coqdocnotation{++}}\coqdocvariable{b2} \coqref{Coqdoc.links.::x ''' ''' '++' 'x' x}{\coqdocnotation{\_}} \coqref{Coqdoc.links.::x ''' ''' '++' 'x' x}{\coqdocnotation{++}}\coqref{Coqdoc.links.::x ''' ''' '++' 'x' x}{\coqdocnotation{x}} \coqdocvariable{b}.\coqdoceol +\coqdockw{Definition} \coqdef{Coqdoc.links.a'}{a'}{\coqdocdefinition{a'}} \coqdocvar{b} := \coqdocvariable{b'}\coqref{Coqdoc.links.:::x '++' x}{\coqdocnotation{++}}0\coqref{Coqdoc.links.:::x '++' x}{\coqdocnotation{++}}\coqdocvariable{b2} \coqref{Coqdoc.links.:::x ''' ''' '++' 'x' x}{\coqdocnotation{\_}} \coqref{Coqdoc.links.:::x ''' ''' '++' 'x' x}{\coqdocnotation{++}}\coqref{Coqdoc.links.:::x ''' ''' '++' 'x' x}{\coqdocnotation{x}} \coqdocvariable{b}.\coqdoceol \coqdocemptyline \coqdocindent{2.00em} -\coqdockw{Definition} \coqdef{Coqdoc.links.c}{c}{\coqdocdefinition{c}} := \coqexternalref{:type scope:'x7B' x 'x7D' '+' 'x7B' x 'x7D'}{http://coq.inria.fr/stdlib/Coq.Init.Specif}{\coqdocnotation{\{}}\coqexternalref{True}{http://coq.inria.fr/stdlib/Coq.Init.Logic}{\coqdocinductive{True}}\coqexternalref{:type scope:'x7B' x 'x7D' '+' 'x7B' x 'x7D'}{http://coq.inria.fr/stdlib/Coq.Init.Specif}{\coqdocnotation{\}+\{}}\coqexternalref{True}{http://coq.inria.fr/stdlib/Coq.Init.Logic}{\coqdocinductive{True}}\coqexternalref{:type scope:'x7B' x 'x7D' '+' 'x7B' x 'x7D'}{http://coq.inria.fr/stdlib/Coq.Init.Specif}{\coqdocnotation{\}}}.\coqdoceol +\coqdockw{Definition} \coqdef{Coqdoc.links.c}{c}{\coqdocdefinition{c}} := \coqexternalref{::type scope:'x7B' x 'x7D' '+' 'x7B' x 'x7D'}{http://coq.inria.fr/stdlib/Coq.Init.Specif}{\coqdocnotation{\{}}\coqexternalref{True}{http://coq.inria.fr/stdlib/Coq.Init.Logic}{\coqdocinductive{True}}\coqexternalref{::type scope:'x7B' x 'x7D' '+' 'x7B' x 'x7D'}{http://coq.inria.fr/stdlib/Coq.Init.Specif}{\coqdocnotation{\}+\{}}\coqexternalref{True}{http://coq.inria.fr/stdlib/Coq.Init.Logic}{\coqdocinductive{True}}\coqexternalref{::type scope:'x7B' x 'x7D' '+' 'x7B' x 'x7D'}{http://coq.inria.fr/stdlib/Coq.Init.Specif}{\coqdocnotation{\}}}.\coqdoceol \coqdocemptyline \coqdocindent{2.00em} -\coqdockw{Definition} \coqdef{Coqdoc.links.d}{d}{\coqdocdefinition{d}} := (1\coqexternalref{:nat scope:x '+' x}{http://coq.inria.fr/stdlib/Coq.Init.Peano}{\coqdocnotation{+}}2)\%\coqdocvar{nat}.\coqdoceol +\coqdockw{Definition} \coqdef{Coqdoc.links.d}{d}{\coqdocdefinition{d}} := (1\coqexternalref{::nat scope:x '+' x}{http://coq.inria.fr/stdlib/Coq.Init.Peano}{\coqdocnotation{+}}2)\%\coqdocvar{nat}.\coqdoceol \coqdocemptyline \coqdocindent{2.00em} -\coqdockw{Lemma} \coqdef{Coqdoc.links.e}{e}{\coqdoclemma{e}} : \coqexternalref{nat}{http://coq.inria.fr/stdlib/Coq.Init.Datatypes}{\coqdocinductive{nat}} \coqexternalref{:type scope:x '+' x}{http://coq.inria.fr/stdlib/Coq.Init.Datatypes}{\coqdocnotation{+}} \coqexternalref{nat}{http://coq.inria.fr/stdlib/Coq.Init.Datatypes}{\coqdocinductive{nat}}.\coqdoceol +\coqdockw{Lemma} \coqdef{Coqdoc.links.e}{e}{\coqdoclemma{e}} : \coqexternalref{nat}{http://coq.inria.fr/stdlib/Coq.Init.Datatypes}{\coqdocinductive{nat}} \coqexternalref{::type scope:x '+' x}{http://coq.inria.fr/stdlib/Coq.Init.Datatypes}{\coqdocnotation{+}} \coqexternalref{nat}{http://coq.inria.fr/stdlib/Coq.Init.Datatypes}{\coqdocinductive{nat}}.\coqdoceol \coqdocindent{2.00em} \coqdocvar{Admitted}.\coqdoceol \coqdocemptyline @@ -131,7 +131,7 @@ Various checks for coqdoc \coqdockw{Variables} \coqdef{Coqdoc.links.test2.test.b2}{b2}{\coqdocvariable{b2}}: \coqexternalref{nat}{http://coq.inria.fr/stdlib/Coq.Init.Datatypes}{\coqdocinductive{nat}}.\coqdoceol \coqdocemptyline \coqdocindent{3.00em} -\coqdockw{Definition} \coqdef{Coqdoc.links.a''}{a'{}'}{\coqdocdefinition{a'{}'}} \coqdocvar{b} := \coqdocvariable{b'} \coqref{Coqdoc.links.::x '++' x}{\coqdocnotation{++}} \coqexternalref{O}{http://coq.inria.fr/stdlib/Coq.Init.Datatypes}{\coqdocconstructor{O}} \coqref{Coqdoc.links.::x '++' x}{\coqdocnotation{++}} \coqdocvariable{b2} \coqref{Coqdoc.links.::x ''' ''' '++' 'x' x}{\coqdocnotation{\_}} \coqref{Coqdoc.links.::x ''' ''' '++' 'x' x}{\coqdocnotation{++}} \coqref{Coqdoc.links.::x ''' ''' '++' 'x' x}{\coqdocnotation{x}} \coqdocvariable{b} \coqexternalref{:nat scope:x '+' x}{http://coq.inria.fr/stdlib/Coq.Init.Peano}{\coqdocnotation{+}} \coqref{Coqdoc.links.h}{\coqdocabbreviation{h}} 0.\coqdoceol +\coqdockw{Definition} \coqdef{Coqdoc.links.a''}{a'{}'}{\coqdocdefinition{a'{}'}} \coqdocvar{b} := \coqdocvariable{b'} \coqref{Coqdoc.links.:::x '++' x}{\coqdocnotation{++}} \coqexternalref{O}{http://coq.inria.fr/stdlib/Coq.Init.Datatypes}{\coqdocconstructor{O}} \coqref{Coqdoc.links.:::x '++' x}{\coqdocnotation{++}} \coqdocvariable{b2} \coqref{Coqdoc.links.:::x ''' ''' '++' 'x' x}{\coqdocnotation{\_}} \coqref{Coqdoc.links.:::x ''' ''' '++' 'x' x}{\coqdocnotation{++}} \coqref{Coqdoc.links.:::x ''' ''' '++' 'x' x}{\coqdocnotation{x}} \coqdocvariable{b} \coqexternalref{::nat scope:x '+' x}{http://coq.inria.fr/stdlib/Coq.Init.Peano}{\coqdocnotation{+}} \coqref{Coqdoc.links.h}{\coqdocabbreviation{h}} 0.\coqdoceol \coqdocemptyline \coqdocindent{2.00em} \coqdockw{End} \coqref{Coqdoc.links.test2.test}{\coqdocsection{test}}.\coqdoceol diff --git a/test-suite/output/BadOptionValueType.out b/test-suite/output/BadOptionValueType.out new file mode 100644 index 0000000000..34d8518a75 --- /dev/null +++ b/test-suite/output/BadOptionValueType.out @@ -0,0 +1,8 @@ +The command has indeed failed with message: +Bad type of value for this option: expected int, got string. +The command has indeed failed with message: +Bad type of value for this option: expected bool, got string. +The command has indeed failed with message: +Bad type of value for this option: expected bool, got int. +The command has indeed failed with message: +Bad type of value for this option: expected bool, got int. diff --git a/test-suite/output/BadOptionValueType.v b/test-suite/output/BadOptionValueType.v new file mode 100644 index 0000000000..b61c3757ba --- /dev/null +++ b/test-suite/output/BadOptionValueType.v @@ -0,0 +1,4 @@ +Fail Set Default Timeout "2". +Fail Set Debug Eauto "yes". +Fail Set Debug Eauto 1. +Fail Set Implicit Arguments 1. diff --git a/test-suite/output/Cases.out b/test-suite/output/Cases.out index 419dcadb4c..dfab400baa 100644 --- a/test-suite/output/Cases.out +++ b/test-suite/output/Cases.out @@ -169,3 +169,5 @@ fun x : K => match x with | _ => 2 end : K -> nat +The command has indeed failed with message: +Pattern "S _, _" is redundant in this clause. diff --git a/test-suite/output/Cases.v b/test-suite/output/Cases.v index 4740c009a4..e4fa7044e7 100644 --- a/test-suite/output/Cases.v +++ b/test-suite/output/Cases.v @@ -217,3 +217,6 @@ Check fun x => match x with a3 | a4 => 3 | _ => 2 end. Check fun x => match x with a3 => 3 | a2 | a1 => 4 | _ => 2 end. Check fun x => match x with a4 => 3 | a2 | a1 => 4 | _ => 2 end. Check fun x => match x with a3 | a4 | a1 => 3 | _ => 2 end. + +(* Test redundant clause within a disjunctive pattern *) +Fail Check fun n m => match n, m with 0, 0 | _, S _ | S 0, _ | S (S _ | _), _ => false end. diff --git a/test-suite/output/Notations4.out b/test-suite/output/Notations4.out new file mode 100644 index 0000000000..cef7d1a702 --- /dev/null +++ b/test-suite/output/Notations4.out @@ -0,0 +1,17 @@ +[< 0 > + < 1 > * < 2 >] + : nat +[<< # 0 >>] + : option nat +[1 {f 1}] + : Expr +fun (x : nat) (y z : Expr) => [1 + y z + {f x}] + : nat -> Expr -> Expr -> Expr +fun e : Expr => +match e with +| [x y + z] => [x + y z] +| [1 + 1] => [1] +| _ => [e + e] +end + : Expr -> Expr +[(1 + 1)] + : Expr diff --git a/test-suite/output/Notations4.v b/test-suite/output/Notations4.v new file mode 100644 index 0000000000..9738ce5a5e --- /dev/null +++ b/test-suite/output/Notations4.v @@ -0,0 +1,68 @@ +(* An example with constr subentries *) + +Module A. + +Declare Custom Entry myconstr. + +Notation "[ x ]" := x (x custom myconstr at level 6). +Notation "x + y" := (Nat.add x y) (in custom myconstr at level 5). +Notation "x * y" := (Nat.mul x y) (in custom myconstr at level 4). +Notation "< x >" := x (in custom myconstr at level 3, x constr at level 10). +Check [ < 0 > + < 1 > * < 2 >]. + +Declare Custom Entry anotherconstr. + +Notation "[ x ]" := x (x custom myconstr at level 6). +Notation "<< x >>" := x (in custom myconstr at level 3, x custom anotherconstr at level 10). +Notation "# x" := (Some x) (in custom anotherconstr at level 8, x constr at level 9). +Check [ << # 0 >> ]. + +End A. + +Module B. + +Inductive Expr := + | Mul : Expr -> Expr -> Expr + | Add : Expr -> Expr -> Expr + | One : Expr. + +Declare Custom Entry expr. +Notation "[ expr ]" := expr (expr custom expr at level 2). +Notation "1" := One (in custom expr at level 0). +Notation "x y" := (Mul x y) (in custom expr at level 1, left associativity). +Notation "x + y" := (Add x y) (in custom expr at level 2, left associativity). +Notation "( x )" := x (in custom expr at level 0, x at level 2). +Notation "{ x }" := x (in custom expr at level 0, x constr). +Notation "x" := x (in custom expr at level 0, x ident). + +Axiom f : nat -> Expr. +Check [1 {f 1}]. +Check fun x y z => [1 + y z + {f x}]. +Check fun e => match e with +| [x y + z] => [x + y z] +| [1 + 1] => [1] +| y => [y + e] +end. + +End B. + +Module C. + +Inductive Expr := + | Add : Expr -> Expr -> Expr + | One : Expr. + +Declare Custom Entry expr. +Notation "[ expr ]" := expr (expr custom expr at level 1). +Notation "1" := One (in custom expr at level 0). +Notation "x + y" := (Add x y) (in custom expr at level 2, left associativity). +Notation "( x )" := x (in custom expr at level 0, x at level 2). + +(* Check the use of a two-steps coercion from constr to expr 1 then + from expr 0 to expr 2 (note that camlp5 parsing is more tolerant + and does not require parentheses to parse from level 2 while at + level 1) *) + +Check [1 + 1]. + +End C. diff --git a/test-suite/output/ssr_explain_match.out b/test-suite/output/ssr_explain_match.out index fa2393b910..32cfb354bf 100644 --- a/test-suite/output/ssr_explain_match.out +++ b/test-suite/output/ssr_explain_match.out @@ -1,35 +1,35 @@ File "stdin", line 12, characters 0-61: -Warning: Notation _ - _ was already used in scope nat_scope. +Warning: Notation "_ - _" was already used in scope nat_scope. [notation-overridden,parsing] File "stdin", line 12, characters 0-61: -Warning: Notation _ <= _ was already used in scope nat_scope. +Warning: Notation "_ <= _" was already used in scope nat_scope. [notation-overridden,parsing] File "stdin", line 12, characters 0-61: -Warning: Notation _ < _ was already used in scope nat_scope. +Warning: Notation "_ < _" was already used in scope nat_scope. [notation-overridden,parsing] File "stdin", line 12, characters 0-61: -Warning: Notation _ >= _ was already used in scope nat_scope. +Warning: Notation "_ >= _" was already used in scope nat_scope. [notation-overridden,parsing] File "stdin", line 12, characters 0-61: -Warning: Notation _ > _ was already used in scope nat_scope. +Warning: Notation "_ > _" was already used in scope nat_scope. [notation-overridden,parsing] File "stdin", line 12, characters 0-61: -Warning: Notation _ <= _ <= _ was already used in scope nat_scope. +Warning: Notation "_ <= _ <= _" was already used in scope nat_scope. [notation-overridden,parsing] File "stdin", line 12, characters 0-61: -Warning: Notation _ < _ <= _ was already used in scope nat_scope. +Warning: Notation "_ < _ <= _" was already used in scope nat_scope. [notation-overridden,parsing] File "stdin", line 12, characters 0-61: -Warning: Notation _ <= _ < _ was already used in scope nat_scope. +Warning: Notation "_ <= _ < _" was already used in scope nat_scope. [notation-overridden,parsing] File "stdin", line 12, characters 0-61: -Warning: Notation _ < _ < _ was already used in scope nat_scope. +Warning: Notation "_ < _ < _" was already used in scope nat_scope. [notation-overridden,parsing] File "stdin", line 12, characters 0-61: -Warning: Notation _ + _ was already used in scope nat_scope. +Warning: Notation "_ + _" was already used in scope nat_scope. [notation-overridden,parsing] File "stdin", line 12, characters 0-61: -Warning: Notation _ * _ was already used in scope nat_scope. +Warning: Notation "_ * _" was already used in scope nat_scope. [notation-overridden,parsing] BEGIN INSTANCES instance: (x + y + z) matches: (x + y + z) diff --git a/test-suite/success/Notations2.v b/test-suite/success/Notations2.v index 7c2cf3ee52..1b33863e3b 100644 --- a/test-suite/success/Notations2.v +++ b/test-suite/success/Notations2.v @@ -126,3 +126,31 @@ Notation "'myexists' x , p" := (ex (fun x => p)) (at level 200, x ident, p at level 200, right associativity) : type_scope. Check myexists I, I = 0. (* Should not be seen as a constructor *) End M14. + +(* 15. Testing different ways to give the same levels without failing *) + +Module M15. + Local Notation "###### x" := (S x) (right associativity, at level 79, x at next level). + Fail Local Notation "###### x" := (S x) (right associativity, at level 79). + Local Notation "###### x" := (S x) (at level 79). +End M15. + +(* 16. Some test about custom entries *) +Module M16. + (* Test locality *) + Local Declare Custom Entry foo. + Fail Notation "#" := 0 (in custom foo). (* Should be local *) + Local Notation "#" := 0 (in custom foo). + + (* Test import *) + Module A. + Declare Custom Entry foo2. + End A. + Fail Notation "##" := 0 (in custom foo2). + Import A. + Local Notation "##" := 0 (in custom foo2). + + (* Test Print Grammar *) + Print Grammar foo. + Print Grammar foo2. +End M16. diff --git a/theories/Vectors/VectorDef.v b/theories/Vectors/VectorDef.v index f6f3cafa21..ba3e411091 100644 --- a/theories/Vectors/VectorDef.v +++ b/theories/Vectors/VectorDef.v @@ -312,5 +312,6 @@ Notation "h :: t" := (h :: t) (at level 60, right associativity) Notation "[ x ]" := (x :: []) : vector_scope. Notation "[ x ; y ; .. ; z ]" := (cons _ x _ (cons _ y _ .. (cons _ z _ (nil _)) ..)) : vector_scope. Notation "v [@ p ]" := (nth v p) (at level 1, format "v [@ p ]") : vector_scope. +Infix "++" := append : vector_scope. Open Scope vector_scope. End VectorNotations. diff --git a/tools/coqdoc/index.ml b/tools/coqdoc/index.ml index 885324aa02..724d3838b0 100644 --- a/tools/coqdoc/index.ml +++ b/tools/coqdoc/index.ml @@ -185,7 +185,8 @@ let type_name = function let prepare_entry s = function | Notation -> (* We decode the encoding done in Dumpglob.cook_notation of coqtop *) - (* Encoded notations have the form section:sc:x_'++'_x where: *) + (* Encoded notations have the form section:entry:sc:x_'++'_x *) + (* where: *) (* - the section, if any, ends with a "." *) (* - the scope can be empty *) (* - tokens are separated with "_" *) @@ -202,10 +203,12 @@ let prepare_entry s = function let err () = eprintf "Invalid notation in globalization file\n"; exit 1 in let h = try String.index_from s 0 ':' with _ -> err () in let i = try String.index_from s (h+1) ':' with _ -> err () in - let sc = String.sub s (h+1) (i-h-1) in - let ntn = Bytes.make (String.length s - i) ' ' in + let m = try String.index_from s (i+1) ':' with _ -> err () in + let entry = String.sub s (h+1) (i-h-1) in + let sc = String.sub s (i+1) (m-i-1) in + let ntn = Bytes.make (String.length s - m) ' ' in let k = ref 0 in - let j = ref (i+1) in + let j = ref (m+1) in let quoted = ref false in let l = String.length s - 1 in while !j <= l do @@ -227,7 +230,8 @@ let prepare_entry s = function incr j done; let ntn = Bytes.sub_string ntn 0 !k in - if sc = "" then ntn else ntn ^ " (" ^ sc ^ ")" + let ntn = if sc = "" then ntn else ntn ^ " (" ^ sc ^ ")" in + if entry = "" then ntn else entry ^ ":" ^ ntn | _ -> s diff --git a/toplevel/coqloop.ml b/toplevel/coqloop.ml index 7b7e1b16c0..9e16b97608 100644 --- a/toplevel/coqloop.ml +++ b/toplevel/coqloop.ml @@ -376,7 +376,8 @@ let rec vernac_loop ~state = else (Feedback.msg_warning (str "There is no ML toplevel."); vernac_loop ~state) | {v=VernacControl c; loc} -> let nstate = Vernac.process_expr ~state (make ?loc c) in - top_goal_print state.proof nstate.proof; + let dproof = Stm.get_prev_proof ~doc:state.doc (Stm.get_current_state ~doc:state.doc) in + top_goal_print dproof nstate.proof; vernac_loop ~state:nstate with | Stm.End_of_input -> diff --git a/vernac/egramcoq.ml b/vernac/egramcoq.ml index 3281b75aaa..16101396cf 100644 --- a/vernac/egramcoq.ml +++ b/vernac/egramcoq.ml @@ -54,6 +54,17 @@ let default_pattern_levels = let default_constr_levels = (default_levels, default_pattern_levels) +let find_levels levels = function + | InConstrEntry -> levels, String.Map.find "constr" levels + | InCustomEntry s -> + try levels, String.Map.find s levels + with Not_found -> + String.Map.add s ([],[]) levels, ([],[]) + +let save_levels levels custom lev = + let s = match custom with InConstrEntry -> "constr" | InCustomEntry s -> s in + String.Map.add s lev levels + (* At a same level, LeftA takes precedence over RightA and NoneA *) (* In case, several associativity exists for a level, we make two levels, *) (* first LeftA, then RightA and NoneA together *) @@ -125,24 +136,24 @@ let rec list_mem_assoc_triple x = function let register_empty_levels accu forpat levels = let rec filter accu = function | [] -> ([], accu) - | n :: rem -> + | (where,n) :: rem -> let rem, accu = filter accu rem in - let (clev, plev) = accu in + let accu, (clev, plev) = find_levels accu where in let levels = if forpat then plev else clev in if not (list_mem_assoc_triple n levels) then let nlev, ans = find_position_gen levels true None (Some n) in let nlev = if forpat then (clev, nlev) else (nlev, plev) in - ans :: rem, nlev + (where, ans) :: rem, save_levels accu where nlev else rem, accu in filter accu levels -let find_position accu forpat assoc level = - let (clev, plev) = accu in +let find_position accu custom forpat assoc level = + let accu, (clev, plev) = find_levels accu custom in let levels = if forpat then plev else clev in let nlev, ans = find_position_gen levels false assoc level in let nlev = if forpat then (clev, nlev) else (nlev, plev) in - (ans, nlev) + (ans, save_levels accu custom nlev) (**************************************************************************) (* @@ -231,7 +242,7 @@ type (_, _) entry = | TTName : ('self, lname) entry | TTReference : ('self, qualid) entry | TTBigint : ('self, Constrexpr.raw_natural_number) entry -| TTConstr : prod_info * 'r target -> ('r, 'r) entry +| TTConstr : notation_entry * prod_info * 'r target -> ('r, 'r) entry | TTConstrList : prod_info * Tok.t list * 'r target -> ('r, 'r list) entry | TTPattern : int -> ('self, cases_pattern_expr) entry | TTOpenBinderList : ('self, local_binder_expr list) entry @@ -239,17 +250,58 @@ type (_, _) entry = type _ any_entry = TTAny : ('s, 'r) entry -> 's any_entry +let constr_custom_entry : (string, Constrexpr.constr_expr) entry_command = + create_entry_command "constr" (fun s st -> [s], st) +let pattern_custom_entry : (string, Constrexpr.cases_pattern_expr) entry_command = + create_entry_command "pattern" (fun s st -> [s], st) + +let custom_entry_locality = Summary.ref ~name:"LOCAL-CUSTOM-ENTRY" String.Set.empty +(** If the entry is present then local *) + +let create_custom_entry ~local s = + if List.mem s ["constr";"pattern";"ident";"global";"binder";"bigint"] then + user_err Pp.(quote (str s) ++ str " is a reserved entry name."); + let sc = "constr:"^s in + let sp = "pattern:"^s in + let _ = extend_entry_command constr_custom_entry sc in + let _ = extend_entry_command pattern_custom_entry sp in + let () = if local then custom_entry_locality := String.Set.add s !custom_entry_locality in + () + +let find_custom_entry s = + let sc = "constr:"^s in + let sp = "pattern:"^s in + try (find_custom_entry constr_custom_entry sc, find_custom_entry pattern_custom_entry sp) + with Not_found -> user_err Pp.(str "Undeclared custom entry: " ++ str s ++ str ".") + +let locality_of_custom_entry s = String.Set.mem s !custom_entry_locality + (* This computes the name of the level where to add a new rule *) -let interp_constr_entry_key : type r. r target -> int -> r Entry.t * int option = - fun forpat level -> match forpat with +let interp_constr_entry_key : type r. _ -> r target -> int -> r Entry.t * int option = + fun custom forpat level -> + match custom with + | InCustomEntry s -> + (let (entry_for_constr, entry_for_patttern) = find_custom_entry s in + match forpat with + | ForConstr -> entry_for_constr, Some level + | ForPattern -> entry_for_patttern, Some level) + | InConstrEntry -> + match forpat with | ForConstr -> if level = 200 then Constr.binder_constr, None else Constr.operconstr, Some level | ForPattern -> Constr.pattern, Some level -let target_entry : type s. s target -> s Entry.t = function -| ForConstr -> Constr.operconstr -| ForPattern -> Constr.pattern +let target_entry : type s. notation_entry -> s target -> s Entry.t = function +| InConstrEntry -> + (function + | ForConstr -> Constr.operconstr + | ForPattern -> Constr.pattern) +| InCustomEntry s -> + let (entry_for_constr, entry_for_patttern) = find_custom_entry s in + function + | ForConstr -> entry_for_constr + | ForPattern -> entry_for_patttern let is_self from e = match e with | (NumLevel n, BorderProd (Right, _ (* Some(NonA|LeftA) *))) -> false @@ -273,11 +325,11 @@ let make_sep_rules = function let r = mkrule (List.rev tkl) in Arules [r] -let symbol_of_target : type s. _ -> _ -> _ -> s target -> (s, s) symbol = fun p assoc from forpat -> - if is_binder_level from p then Aentryl (target_entry forpat, "200") +let symbol_of_target : type s. _ -> _ -> _ -> _ -> s target -> (s, s) symbol = fun custom p assoc from forpat -> + if custom = InConstrEntry && is_binder_level from p then Aentryl (target_entry InConstrEntry forpat, "200") else if is_self from p then Aself else - let g = target_entry forpat in + let g = target_entry custom forpat in let lev = adjust_level assoc from p in begin match lev with | None -> Aentry g @@ -286,11 +338,11 @@ let symbol_of_target : type s. _ -> _ -> _ -> s target -> (s, s) symbol = fun p end let symbol_of_entry : type s r. _ -> _ -> (s, r) entry -> (s, r) symbol = fun assoc from typ -> match typ with -| TTConstr (p, forpat) -> symbol_of_target p assoc from forpat +| TTConstr (s, p, forpat) -> symbol_of_target s p assoc from forpat | TTConstrList (typ', [], forpat) -> - Alist1 (symbol_of_target typ' assoc from forpat) + Alist1 (symbol_of_target InConstrEntry typ' assoc from forpat) | TTConstrList (typ', tkl, forpat) -> - Alist1sep (symbol_of_target typ' assoc from forpat, make_sep_rules tkl) + Alist1sep (symbol_of_target InConstrEntry typ' assoc from forpat, make_sep_rules tkl) | TTPattern p -> Aentryl (Constr.pattern, string_of_int p) | TTClosedBinderList [] -> Alist1 (Aentry Constr.binder) | TTClosedBinderList tkl -> Alist1sep (Aentry Constr.binder, make_sep_rules tkl) @@ -303,9 +355,8 @@ let interp_entry forpat e = match e with | ETProdName -> TTAny TTName | ETProdReference -> TTAny TTReference | ETProdBigint -> TTAny TTBigint -| ETProdConstr p -> TTAny (TTConstr (p, forpat)) +| ETProdConstr (s,p) -> TTAny (TTConstr (s, p, forpat)) | ETProdPattern p -> TTAny (TTPattern p) -| ETProdOther _ -> assert false (** not used *) | ETProdConstrList (p, tkl) -> TTAny (TTConstrList (p, tkl, forpat)) | ETProdBinderList ETBinderOpen -> TTAny TTOpenBinderList | ETProdBinderList (ETBinderClosed tkl) -> TTAny (TTClosedBinderList tkl) @@ -420,21 +471,23 @@ let target_to_bool : type r. r target -> bool = function | ForConstr -> false | ForPattern -> true -let prepare_empty_levels forpat (pos,p4assoc,name,reinit) = +let prepare_empty_levels forpat (where,(pos,p4assoc,name,reinit)) = let empty = (pos, [(name, p4assoc, [])]) in - if forpat then ExtendRule (Constr.pattern, reinit, empty) - else ExtendRule (Constr.operconstr, reinit, empty) - -let rec pure_sublevels : type a b c. int option -> (a, b, c) rule -> int list = fun level r -> match r with -| Stop -> [] -| Next (rem, Aentryl (_, i)) -> - let i = int_of_string i in - let rem = pure_sublevels level rem in - begin match level with - | Some j when Int.equal i j -> rem - | _ -> i :: rem - end -| Next (rem, _) -> pure_sublevels level rem + ExtendRule (target_entry where forpat, reinit, empty) + +let rec pure_sublevels' custom assoc from forpat level = function +| [] -> [] +| GramConstrNonTerminal (e,_) :: rem -> + let rem = pure_sublevels' custom assoc from forpat level rem in + let push where p rem = + match symbol_of_target custom p assoc from forpat with + | Aentryl (_,i) when level <> Some (int_of_string i) -> (where,int_of_string i) :: rem + | _ -> rem in + (match e with + | ETProdPattern i -> push InConstrEntry (NumLevel i,InternalProd) rem + | ETProdConstr (s,p) -> push s p rem + | _ -> rem) +| (GramConstrTerminal _ | GramConstrListMark _) :: rem -> pure_sublevels' custom assoc from forpat level rem let make_act : type r. r target -> _ -> r gen_eval = function | ForConstr -> fun notation loc env -> @@ -445,17 +498,17 @@ let make_act : type r. r target -> _ -> r gen_eval = function CAst.make ~loc @@ CPatNotation (notation, env, []) let extend_constr state forpat ng = - let n,_,_ = ng.notgram_level in + let custom,n,_,_ = ng.notgram_level in let assoc = ng.notgram_assoc in - let (entry, level) = interp_constr_entry_key forpat n in + let (entry, level) = interp_constr_entry_key custom forpat n in let fold (accu, state) pt = let AnyTyRule r = make_ty_rule assoc n forpat pt in let symbs = ty_erase r in - let pure_sublevels = pure_sublevels level symbs in + let pure_sublevels = pure_sublevels' custom assoc n forpat level pt in let isforpat = target_to_bool forpat in let needed_levels, state = register_empty_levels state isforpat pure_sublevels in - let (pos,p4assoc,name,reinit), state = find_position state isforpat assoc level in - let empty_rules = List.map (prepare_empty_levels isforpat) needed_levels in + let (pos,p4assoc,name,reinit), state = find_position state custom isforpat assoc level in + let empty_rules = List.map (prepare_empty_levels forpat) needed_levels in let empty = { constrs = []; constrlists = []; binders = []; binderlists = [] } in let act = ty_eval r (make_act forpat ng.notgram_notation) empty in let rule = (name, p4assoc, [Rule (symbs, act)]) in @@ -468,7 +521,7 @@ let constr_levels = GramState.field () let extend_constr_notation ng state = let levels = match GramState.get state constr_levels with - | None -> default_constr_levels + | None -> String.Map.add "constr" default_constr_levels String.Map.empty | Some lev -> lev in (* Add the notation in constr *) diff --git a/vernac/egramcoq.mli b/vernac/egramcoq.mli index b0341e6a17..3a6f8ae015 100644 --- a/vernac/egramcoq.mli +++ b/vernac/egramcoq.mli @@ -17,3 +17,6 @@ val extend_constr_grammar : Notation_gram.one_notation_grammar -> unit (** Add a term notation rule to the parsing system. *) + +val create_custom_entry : local:bool -> string -> unit +val locality_of_custom_entry : string -> bool diff --git a/vernac/egramml.ml b/vernac/egramml.ml index 048d4d93a0..c5dedc880e 100644 --- a/vernac/egramml.ml +++ b/vernac/egramml.ml @@ -64,6 +64,15 @@ let make_rule f prod = let act = ty_eval ty_rule f in Extend.Rule (symb, act) +let rec proj_symbol : type a b c. (a, b, c) ty_user_symbol -> (a, b, c) genarg_type = function +| TUentry a -> ExtraArg a +| TUentryl (a,l) -> ExtraArg a +| TUopt(o) -> OptArg (proj_symbol o) +| TUlist1 l -> ListArg (proj_symbol l) +| TUlist1sep (l,_) -> ListArg (proj_symbol l) +| TUlist0 l -> ListArg (proj_symbol l) +| TUlist0sep (l,_) -> ListArg (proj_symbol l) + (** Vernac grammar extensions *) let vernac_exts = ref [] diff --git a/vernac/egramml.mli b/vernac/egramml.mli index a5ee036db5..c4f4fcfaa4 100644 --- a/vernac/egramml.mli +++ b/vernac/egramml.mli @@ -26,6 +26,8 @@ val extend_vernac_command_grammar : val get_extend_vernac_rule : Vernacexpr.extend_name -> vernac_expr grammar_prod_item list +val proj_symbol : ('a, 'b, 'c) Extend.ty_user_symbol -> ('a, 'b, 'c) Genarg.genarg_type + (** Utility function reused in Egramcoq : *) val make_rule : diff --git a/vernac/g_vernac.mlg b/vernac/g_vernac.mlg index a35a1998d3..b959f2afa9 100644 --- a/vernac/g_vernac.mlg +++ b/vernac/g_vernac.mlg @@ -1087,6 +1087,11 @@ GRAMMAR EXTEND Gram r = red_expr -> { VernacDeclareReduction (s,r) } +(* factorized here, though relevant for syntax extensions *) + + | IDENT "Declare"; IDENT "Custom"; IDENT "Entry"; s = IDENT -> + { VernacDeclareCustomEntry s } + ] ]; END @@ -1153,6 +1158,9 @@ GRAMMAR EXTEND Gram ; syntax_modifier: [ [ "at"; IDENT "level"; n = natural -> { SetLevel n } + | "in"; IDENT "custom"; x = IDENT -> { SetCustomEntry (x,None) } + | "in"; IDENT "custom"; x = IDENT; "at"; IDENT "level"; n = natural -> + { SetCustomEntry (x,Some n) } | IDENT "left"; IDENT "associativity" -> { SetAssoc LeftA } | IDENT "right"; IDENT "associativity" -> { SetAssoc RightA } | IDENT "no"; IDENT "associativity" -> { SetAssoc NonA } @@ -1166,23 +1174,27 @@ GRAMMAR EXTEND Gram | { CAst.v = k }, Some s -> SetFormat(k,s) | s, None -> SetFormat ("text",s) end } | x = IDENT; ","; l = LIST1 [id = IDENT -> { id } ] SEP ","; "at"; - lev = level -> { SetItemLevel (x::l,lev) } - | x = IDENT; "at"; lev = level -> { SetItemLevel ([x],lev) } - | x = IDENT; "at"; lev = level; b = constr_as_binder_kind -> { SetItemLevelAsBinder ([x],b,Some lev) } - | x = IDENT; b = constr_as_binder_kind -> { SetItemLevelAsBinder ([x],b,None) } + lev = level -> { SetItemLevel (x::l,None,Some lev) } + | x = IDENT; "at"; lev = level -> { SetItemLevel ([x],None,Some lev) } + | x = IDENT; "at"; lev = level; b = constr_as_binder_kind -> + { SetItemLevel ([x],Some b,Some lev) } + | x = IDENT; b = constr_as_binder_kind -> { SetItemLevel ([x],Some b,None) } | x = IDENT; typ = syntax_extension_type -> { SetEntryType (x,typ) } ] ] ; syntax_extension_type: - [ [ IDENT "ident" -> { ETName } | IDENT "global" -> { ETReference } + [ [ IDENT "ident" -> { ETIdent } | IDENT "global" -> { ETGlobal } | IDENT "bigint" -> { ETBigint } | IDENT "binder" -> { ETBinder true } - | IDENT "constr"; n = OPT at_level; b = constr_as_binder_kind -> { ETConstrAsBinder (b,n) } + | IDENT "constr" -> { ETConstr (InConstrEntry,None,None) } + | IDENT "constr"; n = OPT at_level; b = OPT constr_as_binder_kind -> { ETConstr (InConstrEntry,b,n) } | IDENT "pattern" -> { ETPattern (false,None) } | IDENT "pattern"; "at"; IDENT "level"; n = natural -> { ETPattern (false,Some n) } | IDENT "strict"; IDENT "pattern" -> { ETPattern (true,None) } | IDENT "strict"; IDENT "pattern"; "at"; IDENT "level"; n = natural -> { ETPattern (true,Some n) } | IDENT "closed"; IDENT "binder" -> { ETBinder false } + | IDENT "custom"; x = IDENT; n = OPT at_level; b = OPT constr_as_binder_kind -> + { ETConstr (InCustomEntry x,b,n) } ] ] ; at_level: diff --git a/vernac/himsg.ml b/vernac/himsg.ml index e208d176bb..b9c47ff475 100644 --- a/vernac/himsg.ml +++ b/vernac/himsg.ml @@ -1227,12 +1227,7 @@ let explain_wrong_numarg_inductive env ind n = str " expects " ++ decline_string n "argument" ++ str "." let explain_unused_clause env pats = -(* Without localisation - let s = if List.length pats > 1 then "s" else "" in - (str ("Unused clause with pattern"^s) ++ spc () ++ - hov 0 (pr_sequence pr_cases_pattern pats) ++ str ")") -*) - str "This clause is redundant." + str "Pattern \"" ++ hov 0 (prlist_with_sep pr_comma pr_cases_pattern pats) ++ strbrk "\" is redundant in this clause." let explain_non_exhaustive env pats = str "Non exhaustive pattern-matching: no clause found for " ++ diff --git a/vernac/metasyntax.ml b/vernac/metasyntax.ml index 33e6229b29..d66a121437 100644 --- a/vernac/metasyntax.ml +++ b/vernac/metasyntax.ml @@ -283,20 +283,30 @@ let error_not_same_scope x y = (**********************************************************************) (* Build pretty-printing rules *) +let pr_notation_entry = function + | InConstrEntry -> str "constr" + | InCustomEntry s -> str "custom " ++ str s + let prec_assoc = function | RightA -> (L,E) | LeftA -> (E,L) | NonA -> (L,L) -let precedence_of_position_and_level from = function +let precedence_of_position_and_level from_level = function | NumLevel n, BorderProd (_,None) -> n, Prec n | NumLevel n, BorderProd (b,Some a) -> n, let (lp,rp) = prec_assoc a in if b == Left then lp else rp | NumLevel n, InternalProd -> n, Prec n - | NextLevel, _ -> from, L - -let precedence_of_entry_type from = function - | ETConstr x | ETConstrAsBinder (_,x) -> precedence_of_position_and_level from x + | NextLevel, _ -> from_level, L + +let precedence_of_entry_type (from_custom,from_level) = function + | ETConstr (custom,_,x) when notation_entry_eq custom from_custom -> + precedence_of_position_and_level from_level x + | ETConstr (custom,_,(NumLevel n,_)) -> n, Prec n + | ETConstr (custom,_,(NextLevel,_)) -> + user_err (strbrk "\"next level\" is only for sub-expressions in the same entry as where the notation is (" ++ + quote (pr_notation_entry custom) ++ strbrk " is different from " ++ + quote (pr_notation_entry from_custom) ++ str ").") | ETPattern (_,n) -> let n = match n with None -> 0 | Some n -> n in n, Prec n | _ -> 0, E (* should not matter *) @@ -367,15 +377,14 @@ let unparsing_metavar i from typs = let x = List.nth typs (i-1) in let prec = snd (precedence_of_entry_type from x) in match x with - | ETConstr _ | ETConstrAsBinder _ | ETReference | ETBigint -> + | ETConstr _ | ETGlobal | ETBigint -> UnpMetaVar (i,prec) | ETPattern _ -> UnpBinderMetaVar (i,prec) - | ETName -> - UnpBinderMetaVar (i,Prec 0) + | ETIdent -> + UnpBinderMetaVar (i,prec) | ETBinder isopen -> assert false - | ETOther _ -> failwith "TODO" (* Heuristics for building default printing rules *) @@ -561,11 +570,10 @@ let hunks_of_format (from,(vars,typs)) symfmt = (**********************************************************************) (* Build parsing rules *) -let assoc_of_type n (_,typ) = precedence_of_entry_type n typ +let assoc_of_type from n (_,typ) = precedence_of_entry_type (from,n) typ let is_not_small_constr = function ETProdConstr _ -> true - | ETProdOther("constr","binder_constr") -> true | _ -> false let rec define_keywords_aux = function @@ -595,9 +603,9 @@ let distribute a ll = List.map (fun l -> a @ l) ll t;sep;t;...;t;sep;t;...;t;sep;t (p+n times) t;sep;t;...;t;sep;t;...;t;sep;t;LIST1(t,sep) *) -let expand_list_rule typ tkl x n p ll = +let expand_list_rule s typ tkl x n p ll = let camlp5_message_name = Some (add_suffix x ("_"^string_of_int n)) in - let main = GramConstrNonTerminal (ETProdConstr typ, camlp5_message_name) in + let main = GramConstrNonTerminal (ETProdConstr (s,typ), camlp5_message_name) in let tks = List.map (fun x -> GramConstrTerminal x) tkl in let rec aux i hds ll = if i < p then aux (i+1) (main :: tks @ hds) ll @@ -613,7 +621,7 @@ let expand_list_rule typ tkl x n p ll = let is_constr_typ typ x etyps = match List.assoc x etyps with - | ETConstr typ' | ETConstrAsBinder (_,typ') -> typ = typ' + | ETConstr (_,_,typ') -> typ = typ' | _ -> false let include_possible_similar_trailing_pattern typ etyps sl l = @@ -627,13 +635,12 @@ let include_possible_similar_trailing_pattern typ etyps sl l = try_aux 0 l let prod_entry_type = function - | ETName -> ETProdName - | ETReference -> ETProdReference + | ETIdent -> ETProdName + | ETGlobal -> ETProdReference | ETBigint -> ETProdBigint | ETBinder _ -> assert false (* See check_binder_type *) - | ETConstr p | ETConstrAsBinder (_,p) -> ETProdConstr p + | ETConstr (s,_,p) -> ETProdConstr (s,p) | ETPattern (_,n) -> ETProdPattern (match n with None -> 0 | Some n -> n) - | ETOther (s,t) -> ETProdOther (s,t) let make_production etyps symbols = let rec aux = function @@ -651,9 +658,9 @@ let make_production etyps symbols = | Break _ -> [] | _ -> anomaly (Pp.str "Found a non terminal token in recursive notation separator.")) sl) in match List.assoc x etyps with - | ETConstr typ -> + | ETConstr (s,_,typ) -> let p,l' = include_possible_similar_trailing_pattern typ etyps sl l in - expand_list_rule typ tkl x 1 p (aux l') + expand_list_rule s typ tkl x 1 p (aux l') | ETBinder o -> check_open_binder o sl x; let typ = if o then (assert (tkl = []); ETBinderOpen) else ETBinderClosed tkl in @@ -675,8 +682,7 @@ let rec find_symbols c_current c_next c_last = function (x,c_next)::(find_symbols c_next c_next c_last sl') let border = function - | (_,ETConstr(_,BorderProd (_,a))) :: _ -> a - | (_,(ETConstrAsBinder(_,(_,BorderProd (_,a))))) :: _ -> a + | (_,(ETConstr(_,_,(_,BorderProd (_,a))))) :: _ -> a | _ -> None let recompute_assoc typs = @@ -698,23 +704,24 @@ let pr_arg_level from (lev,typ) = | (n,_) -> str "Unknown level" in Ppvernac.pr_set_entry_type (fun _ -> (*TO CHECK*) mt()) typ ++ (match typ with - | ETConstr _ | ETConstrAsBinder _ | ETPattern _ -> spc () ++ pplev lev + | ETConstr _ | ETPattern _ -> spc () ++ pplev lev | _ -> mt ()) -let pr_level ntn (from,args,typs) = - str "at level " ++ int from ++ spc () ++ str "with arguments" ++ spc() ++ - prlist_with_sep pr_comma (pr_arg_level from) (List.combine args typs) +let pr_level ntn (from,fromlevel,args,typs) = + (match from with InConstrEntry -> mt () | InCustomEntry s -> str "in " ++ str s ++ spc()) ++ + str "at level " ++ int fromlevel ++ spc () ++ str "with arguments" ++ spc() ++ + prlist_with_sep pr_comma (pr_arg_level fromlevel) (List.combine args typs) let error_incompatible_level ntn oldprec prec = user_err - (str "Notation " ++ qstring ntn ++ str " is already defined" ++ spc() ++ + (str "Notation " ++ pr_notation ntn ++ str " is already defined" ++ spc() ++ pr_level ntn oldprec ++ spc() ++ str "while it is now required to be" ++ spc() ++ pr_level ntn prec ++ str ".") let error_parsing_incompatible_level ntn ntn' oldprec prec = user_err - (str "Notation " ++ qstring ntn ++ str " relies on a parsing rule for " ++ qstring ntn' ++ spc() ++ + (str "Notation " ++ pr_notation ntn ++ str " relies on a parsing rule for " ++ pr_notation ntn' ++ spc() ++ str " which is already defined" ++ spc() ++ pr_level ntn oldprec ++ spc() ++ str "while it is now required to be" ++ spc() ++ @@ -738,7 +745,7 @@ type syntax_extension_obj = locality_flag * syntax_extension let check_and_extend_constr_grammar ntn rule = try let ntn_for_grammar = rule.notgram_notation in - if String.equal ntn ntn_for_grammar then raise Not_found; + if notation_eq ntn ntn_for_grammar then raise Not_found; let prec = rule.notgram_level in let oldprec = Notgram_ops.level_of_notation ntn_for_grammar in if not (Notgram_ops.level_eq prec oldprec) then error_parsing_incompatible_level ntn ntn_for_grammar oldprec prec; @@ -760,7 +767,7 @@ let cache_one_syntax_extension se = if not onlyprint then List.iter (check_and_extend_constr_grammar ntn) se.synext_notgram.notgram_rules; (* Declare the notation rule *) declare_notation_rule ntn - ~extra:se.synext_extra (se.synext_unparsing, pi1 prec) se.synext_notgram + ~extra:se.synext_extra (se.synext_unparsing, let (_,lev,_,_) = prec in lev) se.synext_notgram end let cache_syntax_extension (_, (_, sy)) = @@ -797,7 +804,9 @@ module NotationMods = struct type notation_modifier = { assoc : gram_assoc option; level : int option; + custom : notation_entry; etyps : (Id.t * simple_constr_prod_entry_key) list; + subtyps : (Id.t * production_level) list; (* common to syn_data below *) only_parsing : bool; @@ -810,7 +819,9 @@ type notation_modifier = { let default = { assoc = None; level = None; + custom = InConstrEntry; etyps = []; + subtyps = []; only_parsing = false; only_printing = false; compat = None; @@ -821,53 +832,75 @@ let default = { end let interp_modifiers modl = let open NotationMods in - let rec interp acc = function - | [] -> acc + let rec interp subtyps acc = function + | [] -> subtyps, acc | SetEntryType (s,typ) :: l -> let id = Id.of_string s in if Id.List.mem_assoc id acc.etyps then user_err ~hdr:"Metasyntax.interp_modifiers" (str s ++ str " is already assigned to an entry or constr level."); - interp { acc with etyps = (id,typ) :: acc.etyps; } l - | SetItemLevel ([],n) :: l -> - interp acc l - | SetItemLevelAsBinder ([],_,_) :: l -> - interp acc l - | SetItemLevel (s::idl,n) :: l -> + interp subtyps { acc with etyps = (id,typ) :: acc.etyps; } l + | SetItemLevel ([],bko,n) :: l -> + interp subtyps acc l + | SetItemLevel (s::idl,bko,n) :: l -> let id = Id.of_string s in if Id.List.mem_assoc id acc.etyps then user_err ~hdr:"Metasyntax.interp_modifiers" (str s ++ str " is already assigned to an entry or constr level."); - let typ = ETConstr (Some n) in - interp { acc with etyps = (id,typ)::acc.etyps; } (SetItemLevel (idl,n)::l) - | SetItemLevelAsBinder (s::idl,bk,n) :: l -> - let id = Id.of_string s in - if Id.List.mem_assoc id acc.etyps then - user_err ~hdr:"Metasyntax.interp_modifiers" - (str s ++ str " is already assigned to an entry or constr level."); - let typ = ETConstrAsBinder (bk,n) in - interp { acc with etyps = (id,typ)::acc.etyps; } (SetItemLevelAsBinder (idl,bk,n)::l) + interp ((id,bko,n)::subtyps) acc (SetItemLevel (idl,bko,n)::l) | SetLevel n :: l -> - interp { acc with level = Some n; } l + (match acc.custom with + | InCustomEntry s -> + if acc.level <> None then + user_err (str ("isolated \"at level " ^ string_of_int n ^ "\" unexpected.")) + else + user_err (str ("use \"in custom " ^ s ^ " at level " ^ string_of_int n ^ + "\"") ++ spc () ++ str "rather than" ++ spc () ++ + str ("\"at level " ^ string_of_int n ^ "\"") ++ + spc () ++ str "isolated.") + | InConstrEntry -> + if acc.level <> None then + user_err (str "A level is already assigned."); + interp subtyps { acc with level = Some n; } l) + | SetCustomEntry (s,n) :: l -> + if acc.level <> None then + (if n = None then + user_err (str ("use \"in custom " ^ s ^ " at level " ^ + string_of_int (Option.get acc.level) ^ + "\"") ++ spc () ++ str "rather than" ++ spc () ++ + str ("\"at level " ^ + string_of_int (Option.get acc.level) ^ "\"") ++ + spc () ++ str "isolated.") + else + user_err (str ("isolated \"at level " ^ string_of_int (Option.get acc.level) ^ "\" unexpected."))); + if acc.custom <> InConstrEntry then + user_err (str "Entry is already assigned to custom " ++ str s ++ (match acc.level with None -> mt () | Some lev -> str " at level " ++ int lev) ++ str "."); + interp subtyps { acc with custom = InCustomEntry s; level = n } l | SetAssoc a :: l -> if not (Option.is_empty acc.assoc) then user_err Pp.(str "An associativity is given more than once."); - interp { acc with assoc = Some a; } l + interp subtyps { acc with assoc = Some a; } l | SetOnlyParsing :: l -> - interp { acc with only_parsing = true; } l + interp subtyps { acc with only_parsing = true; } l | SetOnlyPrinting :: l -> - interp { acc with only_printing = true; } l + interp subtyps { acc with only_printing = true; } l | SetCompatVersion v :: l -> - interp { acc with compat = Some v; } l + interp subtyps { acc with compat = Some v; } l | SetFormat ("text",s) :: l -> if not (Option.is_empty acc.format) then user_err Pp.(str "A format is given more than once."); - interp { acc with format = Some s; } l - | SetFormat (k,{CAst.v=s}) :: l -> - interp { acc with extra = (k,s)::acc.extra; } l - in interp default modl + interp subtyps { acc with format = Some s; } l + | SetFormat (k,s) :: l -> + interp subtyps { acc with extra = (k,s.CAst.v)::acc.extra; } l + in + let subtyps,mods = interp [] default modl in + (* interpret item levels wrt to main entry *) + let extra_etyps = List.map (fun (id,bko,n) -> (id,ETConstr (mods.custom,bko,n))) subtyps in + { mods with etyps = extra_etyps@mods.etyps } let check_infix_modifiers modifiers = - let t = (interp_modifiers modifiers).NotationMods.etyps in - if not (List.is_empty t) then + let mods = interp_modifiers modifiers in + let t = mods.NotationMods.etyps in + let u = mods.NotationMods.subtyps in + if not (List.is_empty t) || not (List.is_empty u) then user_err Pp.(str "Explicit entry level or type unexpected in infix notation.") let check_useless_entry_types recvars mainvars etyps = @@ -908,21 +941,18 @@ let get_compat_version mods = (* Compute precedences from modifiers (or find default ones) *) -let set_entry_type etyps (x,typ) = +let set_entry_type from etyps (x,typ) = let typ = try match List.assoc x etyps, typ with - | ETConstr (Some n), (_,BorderProd (left,_)) -> - ETConstr (n,BorderProd (left,None)) - | ETConstr (Some n), (_,InternalProd) -> ETConstr (n,InternalProd) - | ETConstrAsBinder (bk, Some n), (_,BorderProd (left,_)) -> - ETConstrAsBinder (bk, (n,BorderProd (left,None))) - | ETConstrAsBinder (bk, Some n), (_,InternalProd) -> - ETConstrAsBinder (bk, (n,InternalProd)) + | ETConstr (s,bko,Some n), (_,BorderProd (left,_)) -> + ETConstr (s,bko,(n,BorderProd (left,None))) + | ETConstr (s,bko,Some n), (_,InternalProd) -> + ETConstr (s,bko,(n,InternalProd)) | ETPattern (b,n), _ -> ETPattern (b,n) - | (ETName | ETBigint | ETReference | ETBinder _ | ETOther _ as x), _ -> x - | ETConstr None, _ -> ETConstr typ - | ETConstrAsBinder (bk,None), _ -> ETConstrAsBinder (bk,typ) - with Not_found -> ETConstr typ + | (ETIdent | ETBigint | ETGlobal | ETBinder _ as x), _ -> x + | ETConstr (s,bko,None), _ -> ETConstr (s,bko,typ) + with Not_found -> + ETConstr (from,None,typ) in (x,typ) let join_auxiliary_recursive_types recvars etyps = @@ -942,8 +972,8 @@ let join_auxiliary_recursive_types recvars etyps = let internalization_type_of_entry_type = function | ETBinder _ -> NtnInternTypeOnlyBinder - | ETConstr _ | ETConstrAsBinder _ | ETBigint | ETReference - | ETName | ETPattern _ | ETOther _ -> NtnInternTypeAny + | ETConstr _ | ETBigint | ETGlobal + | ETIdent | ETPattern _ -> NtnInternTypeAny let set_internalization_type typs = List.map (fun (_, e) -> internalization_type_of_entry_type e) typs @@ -954,20 +984,28 @@ let make_internalization_vars recvars mainvars typs = maintyps @ extratyps let make_interpretation_type isrec isonlybinding = function - | ETConstr _ -> - if isrec then NtnTypeConstrList else - if isonlybinding then - (* Parsed as constr, but interpreted as a binder: default is to parse it as an ident only *) - NtnTypeBinder (NtnBinderParsedAsConstr AsIdent) - else NtnTypeConstr - | ETConstrAsBinder (bk,_) -> NtnTypeBinder (NtnBinderParsedAsConstr bk) - | ETName -> NtnTypeBinder NtnParsedAsIdent + (* Parsed as constr list *) + | ETConstr (_,None,_) when isrec -> NtnTypeConstrList + (* Parsed as constr, but interpreted as a binder: default is to parse it as an ident only *) + | ETConstr (_,Some bk,_) -> NtnTypeBinder (NtnBinderParsedAsConstr bk) + | ETConstr (_,None,_) when isonlybinding -> NtnTypeBinder (NtnBinderParsedAsConstr AsIdent) + (* Parsed as constr, interpreted as constr *) + | ETConstr (_,None,_) -> NtnTypeConstr + (* Others *) + | ETIdent -> NtnTypeBinder NtnParsedAsIdent | ETPattern (ppstrict,_) -> NtnTypeBinder (NtnParsedAsPattern ppstrict) (* Parsed as ident/pattern, primarily interpreted as binder; maybe strict at printing *) - | ETBigint | ETReference | ETOther _ -> NtnTypeConstr + | ETBigint | ETGlobal -> NtnTypeConstr | ETBinder _ -> if isrec then NtnTypeBinderList else anomaly Pp.(str "Type binder is only for use in recursive notations for binders.") +let subentry_of_constr_prod_entry = function + | ETConstr (InCustomEntry s,_,(NumLevel n,_)) -> InCustomEntryLevel (s,n) + (* level and use of parentheses for coercion is hard-wired for "constr"; + we don't remember the level *) + | ETConstr (InConstrEntry,_,_) -> InConstrEntrySomeLevel + | _ -> InConstrEntrySomeLevel + let make_interpretation_vars recvars allvars typs = let eq_subscope (sc1, l1) (sc2, l2) = Option.equal String.equal sc1 sc2 && @@ -983,7 +1021,9 @@ let make_interpretation_vars recvars allvars typs = let mainvars = Id.Map.filter (fun x _ -> not (Id.List.mem x useless_recvars)) allvars in Id.Map.mapi (fun x (isonlybinding, sc) -> - (sc, make_interpretation_type (Id.List.mem_assoc x recvars) isonlybinding (Id.List.assoc x typs))) mainvars + let typ = Id.List.assoc x typs in + ((subentry_of_constr_prod_entry typ,sc), + make_interpretation_type (Id.List.mem_assoc x recvars) isonlybinding typ)) mainvars let check_rule_productivity l = if List.for_all (function NonTerminal _ | Break _ -> true | _ -> false) l then @@ -1009,17 +1049,42 @@ let warn_non_reversible_notation = str " not occur in the right-hand side." ++ spc() ++ strbrk "The notation will not be used for printing as it is not reversible.") -let is_not_printable onlyparse reversibility = function -| NVar _ -> - if not onlyparse then warn_notation_bound_to_variable (); - true +let make_custom_entry custom level = + match custom with + | InConstrEntry -> InConstrEntrySomeLevel + | InCustomEntry s -> InCustomEntryLevel (s,level) + +type entry_coercion_kind = + | IsEntryCoercion of notation_entry_level + | IsEntryGlobal of string * int + | IsEntryIdent of string * int + +let is_coercion = function + | Some (custom,n,_,[e]) -> + (match e, custom with + | ETConstr _, _ -> + let customkey = make_custom_entry custom n in + let subentry = subentry_of_constr_prod_entry e in + if notation_entry_level_eq subentry customkey then None + else Some (IsEntryCoercion subentry) + | ETGlobal, InCustomEntry s -> Some (IsEntryGlobal (s,n)) + | ETIdent, InCustomEntry s -> Some (IsEntryIdent (s,n)) + | _ -> None) + | Some _ -> assert false + | None -> None + +let printability level onlyparse reversibility = function +| NVar _ when reversibility = APrioriReversible -> + let coe = is_coercion level in + if not onlyparse && coe = None then + warn_notation_bound_to_variable (); + true, coe | _ -> - if not onlyparse && reversibility <> APrioriReversible then + (if not onlyparse && reversibility <> APrioriReversible then (warn_non_reversible_notation reversibility; true) - else onlyparse + else onlyparse),None - -let find_precedence lev etyps symbols onlyprint = +let find_precedence custom lev etyps symbols onlyprint = let first_symbol = let rec aux = function | Break _ :: t -> aux t @@ -1043,10 +1108,9 @@ let find_precedence lev etyps symbols onlyprint = else [],Option.get lev else user_err Pp.(str "The level of the leftmost non-terminal cannot be changed.") in - (try match List.assoc x etyps with - | ETConstr _ -> test () - | ETConstrAsBinder (_,Some _) -> test () - | (ETName | ETBigint | ETReference) -> + (try match List.assoc x etyps, custom with + | ETConstr (s,_,Some _), s' when s = s' -> test () + | (ETIdent | ETBigint | ETGlobal), _ -> begin match lev with | None -> ([Feedback.msg_info ?loc:None ,strbrk "Setting notation at level 0."],0) @@ -1055,7 +1119,7 @@ let find_precedence lev etyps symbols onlyprint = | _ -> user_err Pp.(str "A notation starting with an atomic expression must be at level 0.") end - | (ETPattern _ | ETBinder _ | ETOther _ | ETConstrAsBinder _) -> + | (ETPattern _ | ETBinder _ | ETConstr _), _ -> (* Give a default ? *) if Option.is_empty lev then user_err Pp.(str "Need an explicit level.") @@ -1073,7 +1137,7 @@ let find_precedence lev etyps symbols onlyprint = [],Option.get lev let check_curly_brackets_notation_exists () = - try let _ = Notgram_ops.level_of_notation "{ _ }" in () + try let _ = Notgram_ops.level_of_notation (InConstrEntrySomeLevel,"{ _ }") in () with Not_found -> user_err Pp.(str "Notations involving patterns of the form \"{ _ }\" are treated \n\ specially and require that the notation \"{ _ }\" is already reserved.") @@ -1103,7 +1167,7 @@ let remove_curly_brackets l = module SynData = struct - type subentry_types = (Id.t * (production_level * production_position) constr_entry_key_gen) list + type subentry_types = (Id.t * constr_entry_key) list (* XXX: Document *) type syn_data = { @@ -1137,7 +1201,7 @@ module SynData = struct end -let find_subentry_types n assoc etyps symbols = +let find_subentry_types from n assoc etyps symbols = let innerlevel = NumLevel 200 in let typs = find_symbols @@ -1145,11 +1209,21 @@ let find_subentry_types n assoc etyps symbols = (innerlevel,InternalProd) (NumLevel n,BorderProd(Right,assoc)) symbols in - let sy_typs = List.map (set_entry_type etyps) typs in - let prec = List.map (assoc_of_type n) sy_typs in + let sy_typs = List.map (set_entry_type from etyps) typs in + let prec = List.map (assoc_of_type from n) sy_typs in sy_typs, prec -let compute_syntax_data df modifiers = +let check_locality_compatibility local custom i_typs = + if not local then + let subcustom = List.map_filter (function _,ETConstr (InCustomEntry s,_,_) -> Some s | _ -> None) i_typs in + let allcustoms = match custom with InCustomEntry s -> s::subcustom | _ -> subcustom in + List.iter (fun s -> + if Egramcoq.locality_of_custom_entry s then + user_err (strbrk "Notation has to be declared local as it depends on custom entry " ++ str s ++ + strbrk " which is local.")) + (List.uniquize allcustoms) + +let compute_syntax_data local df modifiers = let open SynData in let open NotationMods in let mods = interp_modifiers modifiers in @@ -1162,25 +1236,28 @@ let compute_syntax_data df modifiers = let _ = check_binder_type recvars mods.etyps in (* Notations for interp and grammar *) - let ntn_for_interp = make_notation_key symbols in - let symbols_for_grammar = remove_curly_brackets symbols in + let msgs,n = find_precedence mods.custom mods.level mods.etyps symbols onlyprint in + let custom = make_custom_entry mods.custom n in + let ntn_for_interp = make_notation_key custom symbols in + let symbols_for_grammar = + if custom = InConstrEntrySomeLevel then remove_curly_brackets symbols else symbols in let need_squash = not (List.equal Notation.symbol_eq symbols symbols_for_grammar) in - let ntn_for_grammar = if need_squash then make_notation_key symbols_for_grammar else ntn_for_interp in - if not onlyprint then check_rule_productivity symbols_for_grammar; - let msgs,n = find_precedence mods.level mods.etyps symbols onlyprint in + let ntn_for_grammar = if need_squash then make_notation_key custom symbols_for_grammar else ntn_for_interp in + if mods.custom = InConstrEntry && not onlyprint then check_rule_productivity symbols_for_grammar; (* To globalize... *) let etyps = join_auxiliary_recursive_types recvars mods.etyps in let sy_typs, prec = - find_subentry_types n assoc etyps symbols in + find_subentry_types mods.custom n assoc etyps symbols in let sy_typs_for_grammar, prec_for_grammar = if need_squash then - find_subentry_types n assoc etyps symbols_for_grammar + find_subentry_types mods.custom n assoc etyps symbols_for_grammar else sy_typs, prec in let i_typs = set_internalization_type sy_typs in + check_locality_compatibility local mods.custom sy_typs; let pa_sy_data = (sy_typs_for_grammar,symbols_for_grammar) in let pp_sy_data = (sy_typs,symbols) in - let sy_fulldata = (ntn_for_grammar,(n,prec_for_grammar,List.map snd sy_typs_for_grammar),need_squash) in + let sy_fulldata = (ntn_for_grammar,(mods.custom,n,prec_for_grammar,List.map snd sy_typs_for_grammar),need_squash) in let df' = ((Lib.library_dp(),Lib.current_dirpath true),df) in let i_data = ntn_for_interp, df' in @@ -1199,15 +1276,15 @@ let compute_syntax_data df modifiers = mainvars; intern_typs = i_typs; - level = (n,prec,List.map snd sy_typs); + level = (mods.custom,n,prec,List.map snd sy_typs); pa_syntax_data = pa_sy_data; pp_syntax_data = pp_sy_data; not_data = sy_fulldata; } -let compute_pure_syntax_data df mods = +let compute_pure_syntax_data local df mods = let open SynData in - let sd = compute_syntax_data df mods in + let sd = compute_syntax_data local df mods in let msgs = if sd.only_parsing then (Feedback.msg_warning ?loc:None, @@ -1222,6 +1299,7 @@ type notation_obj = { notobj_local : bool; notobj_scope : scope_name option; notobj_interp : interpretation; + notobj_coercion : entry_coercion_kind option; notobj_onlyparse : bool; notobj_onlyprint : bool; notobj_compat : Flags.compat_version option; @@ -1243,7 +1321,13 @@ let open_notation i (_, nobj) = let () = Notation.declare_notation_interpretation ntn scope pat df ~onlyprint in (* Declare the uninterpretation *) if not nobj.notobj_onlyparse then - Notation.declare_uninterpretation (NotationRule (scope, ntn)) pat + Notation.declare_uninterpretation (NotationRule (scope, ntn)) pat; + (* Declare a possible coercion *) + (match nobj.notobj_coercion with + | Some (IsEntryCoercion entry) -> Notation.declare_entry_coercion ntn entry + | Some (IsEntryGlobal (entry,n)) -> Notation.declare_custom_entry_has_global entry n + | Some (IsEntryIdent (entry,n)) -> Notation.declare_custom_entry_has_ident entry n + | None -> ()) end let cache_notation o = @@ -1301,7 +1385,7 @@ let recover_notation_syntax ntn = raise NoSyntaxRule let recover_squash_syntax sy = - let sq = recover_notation_syntax "{ _ }" in + let sq = recover_notation_syntax (InConstrEntrySomeLevel,"{ _ }") in sy :: sq.synext_notgram.notgram_rules (**********************************************************************) @@ -1336,8 +1420,9 @@ let make_pp_rule level (typs,symbols) fmt = (* let make_syntax_rules i_typs (ntn,prec,need_squash) sy_data fmt extra onlyprint compat = *) let make_syntax_rules (sd : SynData.syn_data) = let open SynData in let ntn_for_grammar, prec_for_grammar, need_squash = sd.not_data in + let custom,level,_,_ = sd.level in let pa_rule = make_pa_rule prec_for_grammar sd.pa_syntax_data ntn_for_grammar need_squash in - let pp_rule = make_pp_rule (pi1 sd.level) sd.pp_syntax_data sd.format in { + let pp_rule = make_pp_rule (custom,level) sd.pp_syntax_data sd.format in { synext_level = sd.level; synext_notation = fst sd.info; synext_notgram = { notgram_onlyprinting = sd.only_printing; notgram_rules = pa_rule }; @@ -1355,7 +1440,7 @@ let to_map l = let add_notation_in_scope local df env c mods scope = let open SynData in - let sd = compute_syntax_data df mods in + let sd = compute_syntax_data local df mods in (* Prepare the interpretation *) (* Prepare the parsing and printing rules *) let sy_rules = make_syntax_rules sd in @@ -1367,13 +1452,14 @@ let add_notation_in_scope local df env c mods scope = let (acvars, ac, reversibility) = interp_notation_constr env nenv c in let interp = make_interpretation_vars sd.recvars acvars (fst sd.pa_syntax_data) in let map (x, _) = try Some (x, Id.Map.find x interp) with Not_found -> None in - let onlyparse = is_not_printable sd.only_parsing reversibility ac in + let onlyparse,coe = printability (Some sd.level) sd.only_parsing reversibility ac in let notation = { notobj_local = local; notobj_scope = scope; notobj_interp = (List.map_filter map i_vars, ac); (** Order is important here! *) notobj_onlyparse = onlyparse; + notobj_coercion = coe; notobj_onlyprint = sd.only_printing; notobj_compat = sd.compat; notobj_notation = sd.info; @@ -1387,16 +1473,17 @@ let add_notation_in_scope local df env c mods scope = let add_notation_interpretation_core local df env ?(impls=empty_internalization_env) c scope onlyparse onlyprint compat = let (recvars,mainvars,symbs) = analyze_notation_tokens ~onlyprint df in (* Recover types of variables and pa/pp rules; redeclare them if needed *) - let i_typs, onlyprint = if not (is_numeral symbs) then begin - let sy = recover_notation_syntax (make_notation_key symbs) in + let level, i_typs, onlyprint = if not (is_numeral symbs) then begin + let sy = recover_notation_syntax (make_notation_key InConstrEntrySomeLevel symbs) in let () = Lib.add_anonymous_leaf (inSyntaxExtension (local,sy)) in (** If the only printing flag has been explicitly requested, put it back *) let onlyprint = onlyprint || sy.synext_notgram.notgram_onlyprinting in - pi3 sy.synext_level, onlyprint - end else [], false in + let _,_,_,typs = sy.synext_level in + Some sy.synext_level, typs, onlyprint + end else None, [], false in (* Declare interpretation *) let path = (Lib.library_dp(), Lib.current_dirpath true) in - let df' = (make_notation_key symbs, (path,df)) in + let df' = (make_notation_key InConstrEntrySomeLevel symbs, (path,df)) in let i_vars = make_internalization_vars recvars mainvars (List.map internalization_type_of_entry_type i_typs) in let nenv = { ninterp_var_type = to_map i_vars; @@ -1405,13 +1492,14 @@ let add_notation_interpretation_core local df env ?(impls=empty_internalization_ let (acvars, ac, reversibility) = interp_notation_constr env ~impls nenv c in let interp = make_interpretation_vars recvars acvars (List.combine mainvars i_typs) in let map (x, _) = try Some (x, Id.Map.find x interp) with Not_found -> None in - let onlyparse = is_not_printable onlyparse reversibility ac in + let onlyparse,coe = printability level onlyparse reversibility ac in let notation = { notobj_local = local; notobj_scope = scope; notobj_interp = (List.map_filter map i_vars, ac); (** Order is important here! *) notobj_onlyparse = onlyparse; + notobj_coercion = coe; notobj_onlyprint = onlyprint; notobj_compat = compat; notobj_notation = df'; @@ -1422,7 +1510,7 @@ let add_notation_interpretation_core local df env ?(impls=empty_internalization_ (* Notations without interpretation (Reserved Notation) *) let add_syntax_extension local ({CAst.loc;v=df},mods) = let open SynData in - let psd = compute_pure_syntax_data df mods in + let psd = compute_pure_syntax_data local df mods in let sy_rules = make_syntax_rules {psd with compat = None} in Flags.if_verbose (List.iter (fun (f,x) -> f x)) psd.msgs; Lib.add_anonymous_leaf (inSyntaxExtension(local,sy_rules)) @@ -1462,7 +1550,7 @@ let add_notation local env c ({CAst.loc;v=df},modifiers) sc = let add_notation_extra_printing_rule df k v = let notk = let _,_, symbs = analyze_notation_tokens ~onlyprint:true df in - make_notation_key symbs in + make_notation_key InConstrEntrySomeLevel symbs in add_notation_extra_printing_rule notk k v (* Infix notations *) @@ -1546,7 +1634,35 @@ let add_syntactic_definition env ident (vars,c) local onlyparse = List.map map vars, reversibility, pat in let onlyparse = match onlyparse with - | None when (is_not_printable false reversibility pat) -> Some Flags.Current + | None when fst (printability None false reversibility pat) -> Some Flags.Current | p -> p in Syntax_def.declare_syntactic_definition local ident onlyparse (vars,pat) + +(**********************************************************************) +(* Declaration of custom entry *) + +let load_custom_entry _ _ = () + +let open_custom_entry _ (_,(local,s)) = + Egramcoq.create_custom_entry ~local s + +let cache_custom_entry o = + load_custom_entry 1 o; + open_custom_entry 1 o + +let subst_custom_entry (subst,x) = x + +let classify_custom_entry (local,s as o) = + if local then Dispose else Substitute o + +let inCustomEntry : locality_flag * string -> obj = + declare_object {(default_object "CUSTOM-ENTRIES") with + cache_function = cache_custom_entry; + open_function = open_custom_entry; + load_function = load_custom_entry; + subst_function = subst_custom_entry; + classify_function = classify_custom_entry} + +let declare_custom_entry local s = + Lib.add_anonymous_leaf (inCustomEntry (local,s)) diff --git a/vernac/metasyntax.mli b/vernac/metasyntax.mli index f6de75b079..73bee7121b 100644 --- a/vernac/metasyntax.mli +++ b/vernac/metasyntax.mli @@ -60,3 +60,5 @@ val pr_grammar : string -> Pp.t val check_infix_modifiers : syntax_modifier list -> unit val with_syntax_protection : ('a -> 'b) -> 'a -> 'b + +val declare_custom_entry : locality_flag -> string -> unit diff --git a/vernac/ppvernac.ml b/vernac/ppvernac.ml index e5547d9b75..93e4e89a12 100644 --- a/vernac/ppvernac.ml +++ b/vernac/ppvernac.ml @@ -97,25 +97,27 @@ open Pputils let sep = fun _ -> spc() let sep_v2 = fun _ -> str"," ++ spc() + let pr_notation_entry = function + | InConstrEntry -> keyword "constr" + | InCustomEntry s -> keyword "custom" ++ spc () ++ str s + let pr_at_level = function | NumLevel n -> keyword "at" ++ spc () ++ keyword "level" ++ spc () ++ int n | NextLevel -> keyword "at" ++ spc () ++ keyword "next" ++ spc () ++ keyword "level" let pr_constr_as_binder_kind = let open Notation_term in function - | AsIdent -> keyword "as ident" - | AsIdentOrPattern -> keyword "as pattern" - | AsStrictPattern -> keyword "as strict pattern" + | AsIdent -> spc () ++ keyword "as ident" + | AsIdentOrPattern -> spc () ++ keyword "as pattern" + | AsStrictPattern -> spc () ++ keyword "as strict pattern" let pr_strict b = if b then str "strict " else mt () let pr_set_entry_type pr = function - | ETName -> str"ident" - | ETReference -> str"global" + | ETIdent -> str"ident" + | ETGlobal -> str"global" | ETPattern (b,None) -> pr_strict b ++ str"pattern" | ETPattern (b,Some n) -> pr_strict b ++ str"pattern" ++ spc () ++ pr_at_level (NumLevel n) - | ETConstr lev -> str"constr" ++ pr lev - | ETOther (_,e) -> str e - | ETConstrAsBinder (bk,lev) -> pr lev ++ spc () ++ pr_constr_as_binder_kind bk + | ETConstr (s,bko,lev) -> pr_notation_entry s ++ pr lev ++ pr_opt pr_constr_as_binder_kind bko | ETBigint -> str "bigint" | ETBinder true -> str "binder" | ETBinder false -> str "closed binder" @@ -378,12 +380,11 @@ open Pputils let pr_thm_token k = keyword (Kindops.string_of_theorem_kind k) let pr_syntax_modifier = function - | SetItemLevel (l,n) -> - prlist_with_sep sep_v2 str l ++ spc () ++ pr_at_level n - | SetItemLevelAsBinder (l,bk,n) -> - prlist_with_sep sep_v2 str l ++ - spc() ++ pr_at_level_opt n ++ spc() ++ pr_constr_as_binder_kind bk + | SetItemLevel (l,bko,n) -> + prlist_with_sep sep_v2 str l ++ spc () ++ pr_at_level_opt n ++ + pr_opt pr_constr_as_binder_kind bko | SetLevel n -> pr_at_level (NumLevel n) + | SetCustomEntry (s,n) -> keyword "in" ++ spc() ++ keyword "custom" ++ spc() ++ str s ++ (match n with None -> mt () | Some n -> pr_at_level (NumLevel n)) | SetAssoc LeftA -> keyword "left associativity" | SetAssoc RightA -> keyword "right associativity" | SetAssoc NonA -> keyword "no associativity" @@ -674,6 +675,10 @@ open Pputils return ( keyword "Format Notation " ++ qs s ++ spc () ++ qs k ++ spc() ++ qs v ) + | VernacDeclareCustomEntry s -> + return ( + keyword "Declare Custom Entry " ++ str s + ) (* Gallina *) | VernacDefinition ((discharge,kind),id,b) -> (* A verifier... *) diff --git a/vernac/vernacentries.ml b/vernac/vernacentries.ml index b6bc76a2ed..9824172315 100644 --- a/vernac/vernacentries.ml +++ b/vernac/vernacentries.ml @@ -431,6 +431,10 @@ let vernac_notation ~atts = let local = enforce_module_locality atts.locality in Metasyntax.add_notation local (Global.env()) +let vernac_custom_entry ~atts s = + let local = enforce_module_locality atts.locality in + Metasyntax.declare_custom_entry local s + (***********) (* Gallina *) @@ -2096,6 +2100,8 @@ let interp ?proof ~atts ~st c = vernac_notation ~atts c infpl sc | VernacNotationAddFormat(n,k,v) -> Metasyntax.add_notation_extra_printing_rule n k v + | VernacDeclareCustomEntry s -> + vernac_custom_entry ~atts s (* Gallina *) | VernacDefinition ((discharge,kind),lid,d) -> @@ -2224,6 +2230,7 @@ let check_vernac_supports_locality c l = | Some _, ( VernacOpenCloseScope _ | VernacSyntaxExtension _ | VernacInfix _ | VernacNotation _ + | VernacDeclareCustomEntry _ | VernacDefinition _ | VernacFixpoint _ | VernacCoFixpoint _ | VernacAssumption _ | VernacStartTheoremProof _ | VernacCoercion _ | VernacIdentityCoercion _ @@ -2436,3 +2443,121 @@ let interp ?verbosely ?proof ~st cmd = let exn = CErrors.push exn in Vernacstate.invalidate_cache (); iraise exn + +(** VERNAC EXTEND registering *) + +open Genarg +open Extend + +type classifier = Genarg.raw_generic_argument list -> vernac_classification + +type (_, _) ty_sig = +| TyNil : (atts:atts -> st:Vernacstate.t -> Vernacstate.t, Vernacexpr.vernac_classification) ty_sig +| TyTerminal : string * ('r, 's) ty_sig -> ('r, 's) ty_sig +| TyNonTerminal : + string option * ('a, 'b, 'c) Extend.ty_user_symbol * ('r, 's) ty_sig -> ('a -> 'r, 'a -> 's) ty_sig + +type ty_ml = TyML : bool * ('r, 's) ty_sig * 'r * 's option -> ty_ml + +let type_error () = CErrors.anomaly (Pp.str "Ill-typed VERNAC EXTEND") + +let rec untype_classifier : type r s. (r, s) ty_sig -> s -> classifier = function +| TyNil -> fun f args -> + begin match args with + | [] -> f + | _ :: _ -> type_error () + end +| TyTerminal (_, ty) -> fun f args -> untype_classifier ty f args +| TyNonTerminal (_, tu, ty) -> fun f args -> + begin match args with + | [] -> type_error () + | Genarg.GenArg (Rawwit tag, v) :: args -> + match Genarg.genarg_type_eq tag (Egramml.proj_symbol tu) with + | None -> type_error () + | Some Refl -> untype_classifier ty (f v) args + end + +(** Stupid GADTs forces us to duplicate the definition just for typing *) +let rec untype_command : type r s. (r, s) ty_sig -> r -> plugin_args vernac_command = function +| TyNil -> fun f args -> + begin match args with + | [] -> f + | _ :: _ -> type_error () + end +| TyTerminal (_, ty) -> fun f args -> untype_command ty f args +| TyNonTerminal (_, tu, ty) -> fun f args -> + begin match args with + | [] -> type_error () + | Genarg.GenArg (Rawwit tag, v) :: args -> + match Genarg.genarg_type_eq tag (Egramml.proj_symbol tu) with + | None -> type_error () + | Some Refl -> untype_command ty (f v) args + end + +let rec untype_user_symbol : type s a b c. (a, b, c) Extend.ty_user_symbol -> (s, a) Extend.symbol = function +| TUlist1 l -> Alist1 (untype_user_symbol l) +| TUlist1sep (l, s) -> Alist1sep (untype_user_symbol l, Atoken (CLexer.terminal s)) +| TUlist0 l -> Alist0 (untype_user_symbol l) +| TUlist0sep (l, s) -> Alist0sep (untype_user_symbol l, Atoken (CLexer.terminal s)) +| TUopt o -> Aopt (untype_user_symbol o) +| TUentry a -> Aentry (Pcoq.genarg_grammar (ExtraArg a)) +| TUentryl (a, i) -> Aentryl (Pcoq.genarg_grammar (ExtraArg a), string_of_int i) + +let rec untype_grammar : type r s. (r, s) ty_sig -> vernac_expr Egramml.grammar_prod_item list = function +| TyNil -> [] +| TyTerminal (tok, ty) -> Egramml.GramTerminal tok :: untype_grammar ty +| TyNonTerminal (id, tu, ty) -> + let t = Option.map (fun _ -> rawwit (Egramml.proj_symbol tu)) id in + let symb = untype_user_symbol tu in + Egramml.GramNonTerminal (Loc.tag (t, symb)) :: untype_grammar ty + +let _ = untype_classifier, untype_command, untype_grammar, untype_user_symbol + +let classifiers : classifier array String.Map.t ref = ref String.Map.empty + +let get_vernac_classifier (name, i) args = + (String.Map.find name !classifiers).(i) args + +let declare_vernac_classifier name f = + classifiers := String.Map.add name f !classifiers + +let vernac_extend ~command ?classifier ?entry ext = + let get_classifier (TyML (_, ty, _, cl)) = match cl with + | Some cl -> untype_classifier ty cl + | None -> + match classifier with + | Some cl -> fun _ -> cl command + | None -> + let e = match entry with + | None -> "COMMAND" + | Some e -> Pcoq.Gram.Entry.name e + in + let msg = Printf.sprintf "\ + Vernac entry \"%s\" misses a classifier. \ + A classifier is a function that returns an expression \ + of type vernac_classification (see Vernacexpr). You can: \n\ + - Use '... EXTEND %s CLASSIFIED AS QUERY ...' if the \ + new vernacular command does not alter the system state;\n\ + - Use '... EXTEND %s CLASSIFIED AS SIDEFF ...' if the \ + new vernacular command alters the system state but not the \ + parser nor it starts a proof or ends one;\n\ + - Use '... EXTEND %s CLASSIFIED BY f ...' to specify \ + a global function f. The function f will be called passing\ + \"%s\" as the only argument;\n\ + - Add a specific classifier in each clause using the syntax:\n\ + '[...] => [ f ] -> [...]'.\n\ + Specific classifiers have precedence over global \ + classifiers. Only one classifier is called." + command e e e command + in + CErrors.user_err (Pp.strbrk msg) + in + let cl = Array.map_of_list get_classifier ext in + let iter i (TyML (depr, ty, f, _)) = + let f = untype_command ty f in + let r = untype_grammar ty in + let () = vinterp_add depr (command, i) f in + Egramml.extend_vernac_command_grammar (command, i) entry r + in + let () = declare_vernac_classifier command cl in + List.iteri iter ext diff --git a/vernac/vernacentries.mli b/vernac/vernacentries.mli index 79f9c05ad8..fb2a30bac7 100644 --- a/vernac/vernacentries.mli +++ b/vernac/vernacentries.mli @@ -42,3 +42,33 @@ val universe_polymorphism_option_name : string list (** Elaborate a [atts] record out of a list of flags. Also returns whether polymorphism is explicitly (un)set. *) val attributes_of_flags : Vernacexpr.vernac_flags -> Vernacinterp.atts -> bool option * Vernacinterp.atts + +(** {5 VERNAC EXTEND} *) + +type classifier = Genarg.raw_generic_argument list -> Vernacexpr.vernac_classification + +type (_, _) ty_sig = +| TyNil : (atts:Vernacinterp.atts -> st:Vernacstate.t -> Vernacstate.t, Vernacexpr.vernac_classification) ty_sig +| TyTerminal : string * ('r, 's) ty_sig -> ('r, 's) ty_sig +| TyNonTerminal : + string option * + ('a, 'b, 'c) Extend.ty_user_symbol * ('r, 's) ty_sig -> + ('a -> 'r, 'a -> 's) ty_sig + +type ty_ml = TyML : bool (** deprecated *) * ('r, 's) ty_sig * 'r * 's option -> ty_ml + +(** Wrapper to dynamically extend vernacular commands. *) +val vernac_extend : + command:string -> + ?classifier:(string -> Vernacexpr.vernac_classification) -> + ?entry:Vernacexpr.vernac_expr Pcoq.Entry.t -> + ty_ml list -> unit + +(** {5 STM classifiers} *) + +val get_vernac_classifier : + Vernacexpr.extend_name -> classifier + +(** Low-level API, not for casual user. *) +val declare_vernac_classifier : + string -> classifier array -> unit diff --git a/vernac/vernacexpr.ml b/vernac/vernacexpr.ml index e97cac818a..8fb74e6d78 100644 --- a/vernac/vernacexpr.ml +++ b/vernac/vernacexpr.ml @@ -211,9 +211,9 @@ type proof_expr = ident_decl * (local_binder_expr list * constr_expr) type syntax_modifier = - | SetItemLevel of string list * Extend.production_level - | SetItemLevelAsBinder of string list * Notation_term.constr_as_binder_kind * Extend.production_level option + | SetItemLevel of string list * Notation_term.constr_as_binder_kind option * Extend.production_level option | SetLevel of int + | SetCustomEntry of string * int option | SetAssoc of Extend.gram_assoc | SetEntryType of string * Extend.simple_constr_prod_entry_key | SetOnlyParsing @@ -333,6 +333,7 @@ type nonrec vernac_expr = constr_expr * (lstring * syntax_modifier list) * scope_name option | VernacNotationAddFormat of string * string * string + | VernacDeclareCustomEntry of string (* Gallina *) | VernacDefinition of (Decl_kinds.discharge * Decl_kinds.definition_object_kind) * name_decl * definition_expr |