diff options
144 files changed, 3603 insertions, 1130 deletions
diff --git a/.gitignore b/.gitignore index b857b754a0..267534365a 100644 --- a/.gitignore +++ b/.gitignore @@ -53,6 +53,7 @@ _build myocamlbuild_config.ml config/Makefile config/coq_config.ml +config/coq_config.py config/Info-*.plist dev/ocamldebug-coq dev/camlp5.dbg @@ -1,15 +1,7 @@ -# TODO: Move to META.in once coq_makefile2 is merged. -# We need to reuse: -# - The variable substitution mechanism. -# - Sourcing of "coq_install_path" and "coq_version" variables. -# -# With this rules, we would have: -# version = ${coq_version} -# and -# linkopts(byte) = "-dllpath ${coq_install_path}/kernel/byterun/ -dllib -lcoqrun" +# TODO: Generate automatically with Dune description = "The Coq Proof Assistant Plugin API" -version = "8.7" +version = "8.8" directory = "" requires = "camlp5" @@ -17,7 +9,7 @@ requires = "camlp5" package "config" ( description = "Coq Configuration Variables" - version = "8.7" + version = "8.8" directory = "config" @@ -25,7 +17,7 @@ package "config" ( package "clib" ( description = "Base General Coq Library" - version = "8.7" + version = "8.8" directory = "clib" requires = "str, unix, threads" @@ -37,7 +29,7 @@ package "clib" ( package "lib" ( description = "Base Coq-Specific Library" - version = "8.7" + version = "8.8" directory = "lib" @@ -51,7 +43,7 @@ package "lib" ( package "vm" ( description = "Coq VM" - version = "8.7" + version = "8.8" directory = "kernel/byterun" @@ -73,7 +65,7 @@ package "vm" ( package "kernel" ( description = "Coq's Kernel" - version = "8.7" + version = "8.8" directory = "kernel" @@ -87,7 +79,7 @@ package "kernel" ( package "library" ( description = "Coq Libraries (vo) support" - version = "8.7" + version = "8.8" requires = "coq.kernel" @@ -101,7 +93,7 @@ package "library" ( package "intf" ( description = "Coq Public Data Types" - version = "8.7" + version = "8.8" requires = "coq.library" @@ -114,7 +106,7 @@ package "intf" ( package "engine" ( description = "Coq Tactic Engine" - version = "8.7" + version = "8.8" requires = "coq.library" directory = "engine" @@ -127,7 +119,7 @@ package "engine" ( package "pretyping" ( description = "Coq Pretyper" - version = "8.7" + version = "8.8" requires = "coq.engine" directory = "pretyping" @@ -140,7 +132,7 @@ package "pretyping" ( package "interp" ( description = "Coq Term Interpretation" - version = "8.7" + version = "8.8" requires = "coq.pretyping" directory = "interp" @@ -153,7 +145,7 @@ package "interp" ( package "grammar" ( description = "Coq Base Grammar" - version = "8.7" + version = "8.8" requires = "coq.interp" directory = "grammar" @@ -165,7 +157,7 @@ package "grammar" ( package "proofs" ( description = "Coq Proof Engine" - version = "8.7" + version = "8.8" requires = "coq.interp" directory = "proofs" @@ -178,7 +170,7 @@ package "proofs" ( package "parsing" ( description = "Coq Parsing Engine" - version = "8.7" + version = "8.8" requires = "camlp5.gramlib, coq.proofs" directory = "parsing" @@ -191,7 +183,7 @@ package "parsing" ( package "printing" ( description = "Coq Printing Engine" - version = "8.7" + version = "8.8" requires = "coq.parsing" directory = "printing" @@ -204,7 +196,7 @@ package "printing" ( package "tactics" ( description = "Coq Basic Tactics" - version = "8.7" + version = "8.8" requires = "coq.printing" directory = "tactics" @@ -217,7 +209,7 @@ package "tactics" ( package "vernac" ( description = "Coq Vernacular Interpreter" - version = "8.7" + version = "8.8" requires = "coq.tactics" directory = "vernac" @@ -230,7 +222,7 @@ package "vernac" ( package "stm" ( description = "Coq State Transactional Machine" - version = "8.7" + version = "8.8" requires = "coq.vernac" directory = "stm" @@ -243,7 +235,7 @@ package "stm" ( package "toplevel" ( description = "Coq Toplevel" - version = "8.7" + version = "8.8" requires = "coq.stm" directory = "toplevel" @@ -256,7 +248,7 @@ package "toplevel" ( package "idetop" ( description = "Coq IDE Libraries" - version = "8.7" + version = "8.8" requires = "coq.toplevel" directory = "ide" @@ -270,7 +262,7 @@ package "idetop" ( package "ide" ( description = "Coq IDE Libraries" - version = "8.7" + version = "8.8" # XXX Add GTK requires = "coq.toplevel" @@ -284,14 +276,14 @@ package "ide" ( package "plugins" ( description = "Coq built-in plugins" - version = "8.7" + version = "8.8" directory = "plugins" package "ltac" ( description = "Coq LTAC Plugin" - version = "8.7" + version = "8.8" requires = "coq.stm" directory = "ltac" @@ -304,7 +296,7 @@ package "plugins" ( package "tauto" ( description = "Coq tauto plugin" - version = "8.7" + version = "8.8" requires = "coq.plugins.ltac" directory = "ltac" @@ -316,7 +308,7 @@ package "plugins" ( package "omega" ( description = "Coq omega plugin" - version = "8.7" + version = "8.8" requires = "coq.plugins.ltac" directory = "omega" @@ -328,7 +320,7 @@ package "plugins" ( package "romega" ( description = "Coq romega plugin" - version = "8.7" + version = "8.8" requires = "coq.plugins.omega" directory = "romega" @@ -340,7 +332,7 @@ package "plugins" ( package "micromega" ( description = "Coq micromega plugin" - version = "8.7" + version = "8.8" requires = "num,coq.plugins.ltac" directory = "micromega" @@ -352,7 +344,7 @@ package "plugins" ( package "quote" ( description = "Coq quote plugin" - version = "8.7" + version = "8.8" requires = "coq.plugins.ltac" directory = "quote" @@ -364,7 +356,7 @@ package "plugins" ( package "newring" ( description = "Coq newring plugin" - version = "8.7" + version = "8.8" requires = "coq.plugins.quote" directory = "setoid_ring" @@ -376,7 +368,7 @@ package "plugins" ( package "fourier" ( description = "Coq fourier plugin" - version = "8.7" + version = "8.8" requires = "coq.plugins.ltac" directory = "fourier" @@ -388,7 +380,7 @@ package "plugins" ( package "extraction" ( description = "Coq extraction plugin" - version = "8.7" + version = "8.8" requires = "coq.plugins.ltac" directory = "extraction" @@ -400,7 +392,7 @@ package "plugins" ( package "cc" ( description = "Coq cc plugin" - version = "8.7" + version = "8.8" requires = "coq.plugins.ltac" directory = "cc" @@ -412,7 +404,7 @@ package "plugins" ( package "ground" ( description = "Coq ground plugin" - version = "8.7" + version = "8.8" requires = "coq.plugins.ltac" directory = "firstorder" @@ -424,7 +416,7 @@ package "plugins" ( package "rtauto" ( description = "Coq rtauto plugin" - version = "8.7" + version = "8.8" requires = "coq.plugins.ltac" directory = "rtauto" @@ -436,7 +428,7 @@ package "plugins" ( package "btauto" ( description = "Coq btauto plugin" - version = "8.7" + version = "8.8" requires = "coq.plugins.ltac" directory = "btauto" @@ -448,7 +440,7 @@ package "plugins" ( package "recdef" ( description = "Coq recdef plugin" - version = "8.7" + version = "8.8" requires = "coq.plugins.extraction" directory = "funind" @@ -460,7 +452,7 @@ package "plugins" ( package "nsatz" ( description = "Coq nsatz plugin" - version = "8.7" + version = "8.8" requires = "num,coq.plugins.ltac" directory = "nsatz" @@ -472,7 +464,7 @@ package "plugins" ( package "natsyntax" ( description = "Coq natsyntax plugin" - version = "8.7" + version = "8.8" requires = "" directory = "syntax" @@ -484,7 +476,7 @@ package "plugins" ( package "zsyntax" ( description = "Coq zsyntax plugin" - version = "8.7" + version = "8.8" requires = "" directory = "syntax" @@ -496,7 +488,7 @@ package "plugins" ( package "rsyntax" ( description = "Coq rsyntax plugin" - version = "8.7" + version = "8.8" requires = "" directory = "syntax" @@ -508,7 +500,7 @@ package "plugins" ( package "int31syntax" ( description = "Coq int31syntax plugin" - version = "8.7" + version = "8.8" requires = "" directory = "syntax" @@ -520,7 +512,7 @@ package "plugins" ( package "asciisyntax" ( description = "Coq asciisyntax plugin" - version = "8.7" + version = "8.8" requires = "" directory = "syntax" @@ -532,7 +524,7 @@ package "plugins" ( package "stringsyntax" ( description = "Coq stringsyntax plugin" - version = "8.7" + version = "8.8" requires = "coq.plugins.asciisyntax" directory = "syntax" @@ -544,7 +536,7 @@ package "plugins" ( package "derive" ( description = "Coq derive plugin" - version = "8.7" + version = "8.8" requires = "" directory = "derive" @@ -556,7 +548,7 @@ package "plugins" ( package "ssrmatching" ( description = "Coq ssrmatching plugin" - version = "8.7" + version = "8.8" requires = "coq.plugins.ltac" directory = "ssrmatching" @@ -568,7 +560,7 @@ package "plugins" ( package "ssreflect" ( description = "Coq ssreflect plugin" - version = "8.7" + version = "8.8" requires = "coq.plugins.ssrmatching" directory = "ssr" diff --git a/Makefile.doc b/Makefile.doc index a98f35a1c1..587c5ccbf2 100644 --- a/Makefile.doc +++ b/Makefile.doc @@ -70,7 +70,7 @@ REFMANCOQTEXFILES:=$(addprefix doc/refman/, \ REFMANTEXFILES:=$(addprefix doc/refman/, \ headers.sty Reference-Manual.tex \ - RefMan-pre.tex RefMan-int.tex RefMan-com.tex \ + RefMan-pre.tex RefMan-com.tex \ RefMan-uti.tex RefMan-ide.tex RefMan-modr.tex \ AsyncProofs.tex RefMan-ssr.tex) \ $(REFMANCOQTEXFILES) \ diff --git a/configure.ml b/configure.ml index 4726831e44..6c052b63b6 100644 --- a/configure.ml +++ b/configure.ml @@ -1371,3 +1371,13 @@ let write_macos_metadata exec = let () = if arch = "Darwin" then List.iter write_macos_metadata distributed_exec + +let write_configpy f = + safe_remove f; + let o = open_out f in + let pr s = fprintf o s in + let pr_s = pr "%s = '%s'\n" in + pr "# DO NOT EDIT THIS FILE: automatically generated by ../configure\n"; + pr_s "version" coq_version + +let _ = write_configpy "config/coq_config.py" diff --git a/dev/base_include b/dev/base_include index 3320a2a942..1fb80dc074 100644 --- a/dev/base_include +++ b/dev/base_include @@ -230,7 +230,7 @@ let pf_e gl s = let _ = Flags.in_debugger := false let _ = Flags.in_toplevel := true let _ = Constrextern.set_extern_reference - (fun ?loc _ r -> Libnames.Qualid (loc,Nametab.shortest_qualid_of_global Id.Set.empty r));; + (fun ?loc _ r -> CAst.make ?loc @@ Libnames.Qualid (Nametab.shortest_qualid_of_global Id.Set.empty r));; let go () = Coqloop.loop ~time:false ~state:Option.(get !Coqloop.drop_last_doc) diff --git a/dev/ci/user-overlays/06831-ejgallego-located+vernac_2.sh b/dev/ci/user-overlays/06831-ejgallego-located+vernac_2.sh new file mode 100644 index 0000000000..df3e9cef28 --- /dev/null +++ b/dev/ci/user-overlays/06831-ejgallego-located+vernac_2.sh @@ -0,0 +1,14 @@ +if [ "$CI_PULL_REQUEST" = "6831" ] || [ "$CI_BRANCH" = "located+vernac_2" ]; then + + ltac2_CI_BRANCH=located+vernac_2 + ltac2_CI_GITURL=https://github.com/ejgallego/ltac2 + + Equations_CI_BRANCH=located+vernac_2 + Equations_CI_GITURL=https://github.com/ejgallego/Coq-Equations + + # fiat_parsers_CI_BRANCH=located+vernac + # fiat_parsers_CI_GITURL=https://github.com/ejgallego/fiat + + Elpi_CI_BRANCH=located+vernac_2 + Elpi_CI_GITURL=https://github.com/ejgallego/coq-elpi.git +fi diff --git a/dev/ci/user-overlays/06837-ejgallego-located+libnames.sh b/dev/ci/user-overlays/06837-ejgallego-located+libnames.sh new file mode 100644 index 0000000000..a785290e7c --- /dev/null +++ b/dev/ci/user-overlays/06837-ejgallego-located+libnames.sh @@ -0,0 +1,15 @@ +if [ "$CI_PULL_REQUEST" = "6837" ] || [ "$CI_BRANCH" = "located+libnames" ]; then + + ltac2_CI_BRANCH=located+libnames + ltac2_CI_GITURL=https://github.com/ejgallego/ltac2 + + Equations_CI_BRANCH=located+libnames + Equations_CI_GITURL=https://github.com/ejgallego/Coq-Equations + + Elpi_CI_BRANCH=located+libnames + Elpi_CI_GITURL=https://github.com/ejgallego/coq-elpi.git + + coq_dpdgraph_CI_BRANCH=located+libnames + coq_dpdgraph_CI_GITURL=https://github.com/ejgallego/coq-dpdgraph.git + +fi diff --git a/dev/ci/user-overlays/06869-ejgallego-ssr+correct_packing.sh b/dev/ci/user-overlays/06869-ejgallego-ssr+correct_packing.sh new file mode 100644 index 0000000000..5dedca0ca5 --- /dev/null +++ b/dev/ci/user-overlays/06869-ejgallego-ssr+correct_packing.sh @@ -0,0 +1,12 @@ +if [ "$CI_PULL_REQUEST" = "6869" ] || [ "$CI_BRANCH" = "ssr+correct_packing" ]; then + + Equations_CI_BRANCH=ssr+correct_packing + Equations_CI_GITURL=https://github.com/ejgallego/Coq-Equations + + ltac2_CI_BRANCH=ssr+correct_packing + ltac2_CI_GITURL=https://github.com/ejgallego/ltac2 + + Elpi_CI_BRANCH=ssr+correct_packing + Elpi_CI_GITURL=https://github.com/ejgallego/coq-elpi.git + +fi diff --git a/dev/top_printers.ml b/dev/top_printers.ml index 74cdd788b4..ba0c54407c 100644 --- a/dev/top_printers.ml +++ b/dev/top_printers.ml @@ -547,7 +547,7 @@ let encode_path ?loc prefix mpdir suffix id = | Some (mp,dir) -> (DirPath.repr (dirpath_of_string (ModPath.to_string mp))@ DirPath.repr dir) in - Qualid (Loc.tag ?loc @@ make_qualid + CAst.make ?loc @@ Qualid (make_qualid (DirPath.make (List.rev (Id.of_string prefix::dir@suffix))) id) let raw_string_of_ref ?loc _ = function @@ -567,9 +567,9 @@ let raw_string_of_ref ?loc _ = function encode_path ?loc "SECVAR" None [] id let short_string_of_ref ?loc _ = function - | VarRef id -> Ident (Loc.tag ?loc id) - | ConstRef cst -> Ident (Loc.tag ?loc @@ Label.to_id (pi3 (Constant.repr3 cst))) - | IndRef (kn,0) -> Ident (Loc.tag ?loc @@ Label.to_id (pi3 (MutInd.repr3 kn))) + | VarRef id -> CAst.make ?loc @@ Ident id + | ConstRef cst -> CAst.make ?loc @@ Ident (Label.to_id (pi3 (Constant.repr3 cst))) + | IndRef (kn,0) -> CAst.make ?loc @@ Ident (Label.to_id (pi3 (MutInd.repr3 kn))) | IndRef (kn,i) -> encode_path ?loc "IND" None [Label.to_id (pi3 (MutInd.repr3 kn))] (Id.of_string ("_"^string_of_int i)) diff --git a/dev/top_printers.mli b/dev/top_printers.mli index e47be638aa..dad6dcc1c0 100644 --- a/dev/top_printers.mli +++ b/dev/top_printers.mli @@ -153,7 +153,7 @@ val ppnamedcontextval : Environ.named_context_val -> unit val ppenv : Environ.env -> unit val ppenvwithcst : Environ.env -> unit -val pptac : Tacexpr.glob_tactic_expr -> unit +val pptac : Ltac_plugin.Tacexpr.glob_tactic_expr -> unit val ppobj : Libobject.obj -> unit diff --git a/doc/refman/RefMan-int.tex b/doc/refman/RefMan-int.tex deleted file mode 100644 index f802a35950..0000000000 --- a/doc/refman/RefMan-int.tex +++ /dev/null @@ -1,143 +0,0 @@ -%BEGIN LATEX -\setheaders{Introduction} -%END LATEX -\chapter*{Introduction} -%HEVEA\cutname{introduction.html} - -This document is the Reference Manual of version \coqversion{} of the \Coq\ -proof assistant. A companion volume, the \Coq\ Tutorial, is provided -for the beginners. It is advised to read the Tutorial first. -A book~\cite{CoqArt} on practical uses of the \Coq{} system was published in 2004 and is a good support for both the beginner and -the advanced user. - -%The system \Coq\ is designed to develop mathematical proofs. It can be -%used by mathematicians to develop mathematical theories and by -%computer scientists to write formal specifications, -The \Coq{} system is designed to develop mathematical proofs, and -especially to write formal specifications, programs and to verify that -programs are correct with respect to their specification. It provides -a specification language named \gallina. Terms of \gallina\ can -represent programs as well as properties of these programs and proofs -of these properties. Using the so-called \textit{Curry-Howard - isomorphism}, programs, properties and proofs are formalized in the -same language called \textit{Calculus of Inductive Constructions}, -that is a $\lambda$-calculus with a rich type system. All logical -judgments in \Coq\ are typing judgments. The very heart of the Coq -system is the type-checking algorithm that checks the correctness of -proofs, in other words that checks that a program complies to its -specification. \Coq\ also provides an interactive proof assistant to -build proofs using specific programs called \textit{tactics}. - -All services of the \Coq\ proof assistant are accessible by -interpretation of a command language called \textit{the vernacular}. - -\Coq\ has an interactive mode in which commands are interpreted as the -user types them in from the keyboard and a compiled mode where -commands are processed from a file. - -\begin{itemize} -\item The interactive mode may be used as a debugging mode in which - the user can develop his theories and proofs step by step, - backtracking if needed and so on. The interactive mode is run with - the {\tt coqtop} command from the operating system (which we shall - assume to be some variety of UNIX in the rest of this document). -\item The compiled mode acts as a proof checker taking a file - containing a whole development in order to ensure its correctness. - Moreover, \Coq's compiler provides an output file containing a - compact representation of its input. The compiled mode is run with - the {\tt coqc} command from the operating system. - -\end{itemize} -These two modes are documented in Chapter~\ref{Addoc-coqc}. - -Other modes of interaction with \Coq{} are possible: through an emacs -shell window, an emacs generic user-interface for proof assistant -({\ProofGeneral}~\cite{ProofGeneral}) or through a customized interface -(PCoq~\cite{Pcoq}). These facilities are not documented here. There -is also a \Coq{} Integrated Development Environment described in -Chapter~\ref{Addoc-coqide}. - -\section*{How to read this book} - -This is a Reference Manual, not a User Manual, so it is not made for a -continuous reading. However, it has some structure that is explained -below. - -\begin{itemize} -\item The first part describes the specification language, - Gallina. Chapters~\ref{Gallina} and~\ref{Gallina-extension} - describe the concrete syntax as well as the meaning of programs, - theorems and proofs in the Calculus of Inductive - Constructions. Chapter~\ref{Theories} describes the standard library - of \Coq. Chapter~\ref{Cic} is a mathematical description of the - formalism. Chapter~\ref{chapter:Modules} describes the module system. - -\item The second part describes the proof engine. It is divided in - five chapters. Chapter~\ref{Vernacular-commands} presents all - commands (we call them \emph{vernacular commands}) that are not - directly related to interactive proving: requests to the - environment, complete or partial evaluation, loading and compiling - files. How to start and stop proofs, do multiple proofs in parallel - is explained in Chapter~\ref{Proof-handling}. In - Chapter~\ref{Tactics}, all commands that realize one or more steps - of the proof are presented: we call them \emph{tactics}. The - language to combine these tactics into complex proof strategies is - given in Chapter~\ref{TacticLanguage}. Examples of tactics are - described in Chapter~\ref{Tactics-examples}. - -%\item The third part describes how to extend the system in two ways: -% adding parsing and pretty-printing rules -% (Chapter~\ref{Addoc-syntax}) and writing new tactics -% (Chapter~\ref{TacticLanguage}). - -\item The third part describes how to extend the syntax of \Coq. It -corresponds to the Chapter~\ref{Addoc-syntax}. - -\item In the fourth part more practical tools are documented. First in - Chapter~\ref{Addoc-coqc}, the usage of \texttt{coqc} (batch mode) - and \texttt{coqtop} (interactive mode) with their options is - described. Then, in Chapter~\ref{Utilities}, - various utilities that come with the \Coq\ distribution are - presented. - Finally, Chapter~\ref{Addoc-coqide} describes the \Coq{} integrated - development environment. - -\item The fifth part documents a number of advanced features, including - coercions, canonical structures, typeclasses, program extraction, and - specialized solvers and tactics. See the table of contents for a complete - list. -\end{itemize} - -At the end of the document, after the global index, the user can find -specific indexes for tactics, vernacular commands, and error -messages. - -\section*{List of additional documentation} - -This manual does not contain all the documentation the user may need -about \Coq{}. Various informations can be found in the following -documents: -\begin{description} - -\item[Tutorial] - A companion volume to this reference manual, the \Coq{} Tutorial, is - aimed at gently introducing new users to developing proofs in \Coq{} - without assuming prior knowledge of type theory. In a second step, the - user can read also the tutorial on recursive types (document {\tt - RecTutorial.ps}). - -\item[Installation] A text file INSTALL that comes with the sources - explains how to install \Coq{}. - -\item[The \Coq{} standard library] -A commented version of sources of the \Coq{} standard library -(including only the specifications, the proofs are removed) -is given in the additional document {\tt Library.ps}. - -\end{description} - - -%%% Local Variables: -%%% mode: latex -%%% TeX-master: "Reference-Manual" -%%% End: diff --git a/doc/refman/Reference-Manual.tex b/doc/refman/Reference-Manual.tex index fc1c01cf24..1bd79d5112 100644 --- a/doc/refman/Reference-Manual.tex +++ b/doc/refman/Reference-Manual.tex @@ -85,7 +85,6 @@ Options A and B of the licence are {\em not} elected.} %END LATEX %\defaultheaders -\include{RefMan-int}% Introduction \include{RefMan-pre}% Credits %BEGIN LATEX diff --git a/doc/sphinx/_static/notations.css b/doc/sphinx/_static/notations.css index 1ae7a7cd7f..9b7b826d58 100644 --- a/doc/sphinx/_static/notations.css +++ b/doc/sphinx/_static/notations.css @@ -158,11 +158,6 @@ dt > .property { color: #FFFFFF; } -/* FIXME: Specific to the RTD theme */ -a:visited { - color: #2980B9; -} - /* Pygments for Coq is confused by ‘…’ */ code span.error { background: inherit !important; diff --git a/doc/sphinx/biblio.bib b/doc/sphinx/biblio.bib new file mode 100644 index 0000000000..4a9bd6c1a0 --- /dev/null +++ b/doc/sphinx/biblio.bib @@ -0,0 +1,1397 @@ +@String{jfp = "Journal of Functional Programming"} +@String{lncs = "Lecture Notes in Computer Science"} +@String{lnai = "Lecture Notes in Artificial Intelligence"} +@String{SV = "{Sprin-ger-Verlag}"} + +@InProceedings{Aud91, + author = {Ph. Audebaud}, + booktitle = {Proceedings of the sixth Conf. on Logic in Computer Science.}, + publisher = {IEEE}, + title = {Partial {Objects} in the {Calculus of Constructions}}, + year = {1991} +} + +@PhDThesis{Aud92, + author = {Ph. Audebaud}, + school = {{Universit\'e} Bordeaux I}, + title = {Extension du Calcul des Constructions par Points fixes}, + year = {1992} +} + +@InProceedings{Audebaud92b, + author = {Ph. Audebaud}, + booktitle = {{Proceedings of the 1992 Workshop on Types for Proofs and Programs}}, + editor = {{B. Nordstr\"om and K. Petersson and G. Plotkin}}, + note = {Also Research Report LIP-ENS-Lyon}, + pages = {21--34}, + title = {{CC+ : an extension of the Calculus of Constructions with fixpoints}}, + year = {1992} +} + +@InProceedings{Augustsson85, + author = {L. Augustsson}, + title = {{Compiling Pattern Matching}}, + booktitle = {Conference Functional Programming and +Computer Architecture}, + year = {1985} +} + +@Article{BaCo85, + author = {J.L. Bates and R.L. Constable}, + journal = {ACM transactions on Programming Languages and Systems}, + title = {Proofs as {Programs}}, + volume = {7}, + year = {1985} +} + +@Book{Bar81, + author = {H.P. Barendregt}, + publisher = {North-Holland}, + title = {The Lambda Calculus its Syntax and Semantics}, + year = {1981} +} + +@TechReport{Bar91, + author = {H. Barendregt}, + institution = {Catholic University Nijmegen}, + note = {In Handbook of Logic in Computer Science, Vol II}, + number = {91-19}, + title = {Lambda {Calculi with Types}}, + year = {1991} +} + +@Article{BeKe92, + author = {G. Bellin and J. Ketonen}, + journal = {Theoretical Computer Science}, + pages = {115--142}, + title = {A decision procedure revisited : Notes on direct logic, linear logic and its implementation}, + volume = {95}, + year = {1992} +} + +@Book{Bee85, + author = {M.J. Beeson}, + publisher = SV, + title = {Foundations of Constructive Mathematics, Metamathematical Studies}, + year = {1985} +} + +@Book{Bis67, + author = {E. Bishop}, + publisher = {McGraw-Hill}, + title = {Foundations of Constructive Analysis}, + year = {1967} +} + +@Book{BoMo79, + author = {R.S. Boyer and J.S. Moore}, + key = {BoMo79}, + publisher = {Academic Press}, + series = {ACM Monograph}, + title = {A computational logic}, + year = {1979} +} + +@MastersThesis{Bou92, + author = {S. Boutin}, + month = sep, + school = {{Universit\'e Paris 7}}, + title = {Certification d'un compilateur {ML en Coq}}, + year = {1992} +} + +@InProceedings{Bou97, + title = {Using reflection to build efficient and certified decision procedure +s}, + author = {S. Boutin}, + booktitle = {TACS'97}, + editor = {Martin Abadi and Takahashi Ito}, + publisher = SV, + series = lncs, + volume = 1281, + year = {1997} +} + +@PhDThesis{Bou97These, + author = {S. Boutin}, + title = {R\'eflexions sur les quotients}, + school = {Paris 7}, + year = 1997, + type = {th\`ese d'Universit\'e}, + month = apr +} + +@Article{Bru72, + author = {N.J. de Bruijn}, + journal = {Indag. Math.}, + title = {{Lambda-Calculus Notation with Nameless Dummies, a Tool for Automatic Formula Manipulation, with Application to the Church-Rosser Theorem}}, + volume = {34}, + year = {1972} +} + + +@InCollection{Bru80, + author = {N.J. de Bruijn}, + booktitle = {to H.B. Curry : Essays on Combinatory Logic, Lambda Calculus and Formalism.}, + editor = {J.P. Seldin and J.R. Hindley}, + publisher = {Academic Press}, + title = {A survey of the project {Automath}}, + year = {1980} +} + +@TechReport{COQ93, + author = {G. Dowek and A. Felty and H. Herbelin and G. Huet and C. Murthy and C. Parent and C. Paulin-Mohring and B. Werner}, + institution = {INRIA}, + month = may, + number = {154}, + title = {{The Coq Proof Assistant User's Guide Version 5.8}}, + year = {1993} +} + +@TechReport{COQ02, + author = {The Coq Development Team}, + institution = {INRIA}, + month = Feb, + number = {255}, + title = {{The Coq Proof Assistant Reference Manual Version 7.2}}, + year = {2002} +} + +@TechReport{CPar93, + author = {C. Parent}, + institution = {Ecole {Normale} {Sup\'erieure} de {Lyon}}, + month = oct, + note = {Also in~\cite{Nijmegen93}}, + number = {93-29}, + title = {Developing certified programs in the system {Coq}- {The} {Program} tactic}, + year = {1993} +} + +@PhDThesis{CPar95, + author = {C. Parent}, + school = {Ecole {Normale} {Sup\'erieure} de {Lyon}}, + title = {{Synth\`ese de preuves de programmes dans le Calcul des Constructions Inductives}}, + year = {1995} +} + +@Book{Caml, + author = {P. Weis and X. Leroy}, + publisher = {InterEditions}, + title = {Le langage Caml}, + year = {1993} +} + +@InProceedings{ChiPotSimp03, + author = {Laurent Chicli and Lo\"{\i}c Pottier and Carlos Simpson}, + title = {Mathematical Quotients and Quotient Types in Coq}, + booktitle = {TYPES}, + crossref = {DBLP:conf/types/2002}, + year = {2002} +} + +@TechReport{CoC89, + author = {Projet Formel}, + institution = {INRIA}, + number = {110}, + title = {{The Calculus of Constructions. Documentation and user's guide, Version 4.10}}, + year = {1989} +} + +@InProceedings{CoHu85a, + author = {Th. Coquand and G. Huet}, + address = {Linz}, + booktitle = {EUROCAL'85}, + publisher = SV, + series = LNCS, + title = {{Constructions : A Higher Order Proof System for Mechanizing Mathematics}}, + volume = {203}, + year = {1985} +} + +@InProceedings{CoHu85b, + author = {Th. Coquand and G. Huet}, + booktitle = {Logic Colloquium'85}, + editor = {The Paris Logic Group}, + publisher = {North-Holland}, + title = {{Concepts Math\'ematiques et Informatiques formalis\'es dans le Calcul des Constructions}}, + year = {1987} +} + +@Article{CoHu86, + author = {Th. Coquand and G. Huet}, + journal = {Information and Computation}, + number = {2/3}, + title = {The {Calculus of Constructions}}, + volume = {76}, + year = {1988} +} + +@InProceedings{CoPa89, + author = {Th. Coquand and C. Paulin-Mohring}, + booktitle = {Proceedings of Colog'88}, + editor = {P. Martin-L\"of and G. Mints}, + publisher = SV, + series = LNCS, + title = {Inductively defined types}, + volume = {417}, + year = {1990} +} + +@Book{Con86, + author = {R.L. {Constable et al.}}, + publisher = {Prentice-Hall}, + title = {{Implementing Mathematics with the Nuprl Proof Development System}}, + year = {1986} +} + +@PhDThesis{Coq85, + author = {Th. Coquand}, + month = jan, + school = {Universit\'e Paris~7}, + title = {Une Th\'eorie des Constructions}, + year = {1985} +} + +@InProceedings{Coq86, + author = {Th. Coquand}, + address = {Cambridge, MA}, + booktitle = {Symposium on Logic in Computer Science}, + publisher = {IEEE Computer Society Press}, + title = {{An Analysis of Girard's Paradox}}, + year = {1986} +} + +@InProceedings{Coq90, + author = {Th. Coquand}, + booktitle = {Logic and Computer Science}, + editor = {P. Oddifredi}, + note = {INRIA Research Report 1088, also in~\cite{CoC89}}, + publisher = {Academic Press}, + title = {{Metamathematical Investigations of a Calculus of Constructions}}, + year = {1990} +} + +@InProceedings{Coq91, + author = {Th. Coquand}, + booktitle = {Proceedings 9th Int. Congress of Logic, Methodology and Philosophy of Science}, + title = {{A New Paradox in Type Theory}}, + month = {August}, + year = {1991} +} + +@InProceedings{Coq92, + author = {Th. Coquand}, + title = {{Pattern Matching with Dependent Types}}, + year = {1992}, + booktitle = {Proceedings of the 1992 Workshop on Types for Proofs and Programs} +} + +@InProceedings{Coquand93, + author = {Th. Coquand}, + booktitle = {Types for Proofs and Programs}, + editor = {H. Barendregt and T. Nipokow}, + publisher = SV, + series = LNCS, + title = {{Infinite objects in Type Theory}}, + volume = {806}, + year = {1993}, + pages = {62-78} +} + +@inproceedings{Corbineau08types, + author = {P. Corbineau}, + title = {A Declarative Language for the Coq Proof Assistant}, + editor = {M. Miculan and I. Scagnetto and F. Honsell}, + booktitle = {TYPES '07, Cividale del Friuli, Revised Selected Papers}, + publisher = {Springer}, + series = LNCS, + volume = {4941}, + year = {2007}, + pages = {69-84}, + ee = {http://dx.doi.org/10.1007/978-3-540-68103-8_5}, +} + +@PhDThesis{Cor97, + author = {C. Cornes}, + month = nov, + school = {{Universit\'e Paris 7}}, + title = {Conception d'un langage de haut niveau de représentation de preuves}, + type = {Th\`ese de Doctorat}, + year = {1997} +} + +@MastersThesis{Cou94a, + author = {J. Courant}, + month = sep, + school = {DEA d'Informatique, ENS Lyon}, + title = {Explicitation de preuves par r\'ecurrence implicite}, + year = {1994} +} + +@book{Cur58, + author = {Haskell B. Curry and Robert Feys and William Craig}, + title = {Combinatory Logic}, + volume = 1, + publisher = "North-Holland", + year = 1958, + note = {{\S{9E}}}, +} + +@InProceedings{Del99, + author = {Delahaye, D.}, + title = {Information Retrieval in a Coq Proof Library using + Type Isomorphisms}, + booktitle = {Proceedings of TYPES '99, L\"okeberg}, + publisher = SV, + series = lncs, + year = {1999}, + url = + "\\{\sf ftp://ftp.inria.fr/INRIA/Projects/coq/David.Delahaye/papers/}"# + "{\sf TYPES99-SIsos.ps.gz}" +} + +@InProceedings{Del00, + author = {Delahaye, D.}, + title = {A {T}actic {L}anguage for the {S}ystem {{\sf Coq}}}, + booktitle = {Proceedings of Logic for Programming and Automated Reasoning + (LPAR), Reunion Island}, + publisher = SV, + series = LNCS, + volume = {1955}, + pages = {85--95}, + month = {November}, + year = {2000}, + url = + "{\sf ftp://ftp.inria.fr/INRIA/Projects/coq/David.Delahaye/papers/}"# + "{\sf LPAR2000-ltac.ps.gz}" +} + +@InProceedings{DelMay01, + author = {Delahaye, D. and Mayero, M.}, + title = {{\tt Field}: une proc\'edure de d\'ecision pour les nombres r\'eels en {\Coq}}, + booktitle = {Journ\'ees Francophones des Langages Applicatifs, Pontarlier}, + publisher = {INRIA}, + month = {Janvier}, + year = {2001}, + url = + "\\{\sf ftp://ftp.inria.fr/INRIA/Projects/coq/David.Delahaye/papers/}"# + "{\sf JFLA2000-Field.ps.gz}" +} + +@TechReport{Dow90, + author = {G. Dowek}, + institution = {INRIA}, + number = {1283}, + title = {Naming and Scoping in a Mathematical Vernacular}, + type = {Research Report}, + year = {1990} +} + +@Article{Dow91a, + author = {G. Dowek}, + journal = {Compte-Rendus de l'Acad\'emie des Sciences}, + note = {The undecidability of Third Order Pattern Matching in Calculi with Dependent Types or Type Constructors}, + number = {12}, + pages = {951--956}, + title = {L'Ind\'ecidabilit\'e du Filtrage du Troisi\`eme Ordre dans les Calculs avec Types D\'ependants ou Constructeurs de Types}, + volume = {I, 312}, + year = {1991} +} + +@InProceedings{Dow91b, + author = {G. Dowek}, + booktitle = {Proceedings of Mathematical Foundation of Computer Science}, + note = {Also INRIA Research Report}, + pages = {151--160}, + publisher = SV, + series = LNCS, + title = {A Second Order Pattern Matching Algorithm in the Cube of Typed $\lambda$-calculi}, + volume = {520}, + year = {1991} +} + +@PhDThesis{Dow91c, + author = {G. Dowek}, + month = dec, + school = {Universit\'e Paris 7}, + title = {D\'emonstration automatique dans le Calcul des Constructions}, + year = {1991} +} + +@Article{Dow92a, + author = {G. Dowek}, + title = {The Undecidability of Pattern Matching in Calculi where Primitive Recursive Functions are Representable}, + year = 1993, + journal = {Theoretical Computer Science}, + volume = 107, + number = 2, + pages = {349-356} +} + +@Article{Dow94a, + author = {G. Dowek}, + journal = {Annals of Pure and Applied Logic}, + volume = {69}, + pages = {135--155}, + title = {Third order matching is decidable}, + year = {1994} +} + +@InProceedings{Dow94b, + author = {G. Dowek}, + booktitle = {Proceedings of the second international conference on typed lambda calculus and applications}, + title = {Lambda-calculus, Combinators and the Comprehension Schema}, + year = {1995} +} + +@InProceedings{Dyb91, + author = {P. Dybjer}, + booktitle = {Logical Frameworks}, + editor = {G. Huet and G. Plotkin}, + pages = {59--79}, + publisher = {Cambridge University Press}, + title = {Inductive sets and families in {Martin-Löf's} + Type Theory and their set-theoretic semantics: An inversion principle for {Martin-L\"of's} type theory}, + volume = {14}, + year = {1991} +} + +@Article{Dyc92, + author = {Roy Dyckhoff}, + journal = {The Journal of Symbolic Logic}, + month = sep, + number = {3}, + title = {Contraction-free sequent calculi for intuitionistic logic}, + volume = {57}, + year = {1992} +} + +@MastersThesis{Fil94, + author = {J.-C. Filli\^atre}, + month = sep, + school = {DEA d'Informatique, ENS Lyon}, + title = {Une proc\'edure de d\'ecision pour le Calcul des Pr\'edicats Direct. Étude et impl\'ementation dans le syst\`eme {\Coq}}, + year = {1994} +} + +@TechReport{Filliatre95, + author = {J.-C. Filli\^atre}, + institution = {LIP-ENS-Lyon}, + title = {A decision procedure for Direct Predicate Calculus}, + type = {Research report}, + number = {96--25}, + year = {1995} +} + +@Article{Filliatre03jfp, + author = {J.-C. Filliâtre}, + title = {Verification of Non-Functional Programs + using Interpretations in Type Theory}, + journal = jfp, + volume = 13, + number = 4, + pages = {709--745}, + month = jul, + year = 2003, + note = {[English translation of \cite{Filliatre99}]}, + url = {http://www.lri.fr/~filliatr/ftp/publis/jphd.ps.gz}, + topics = {team, lri}, + type_publi = {irevcomlec} +} + +@PhDThesis{Filliatre99, + author = {J.-C. Filli\^atre}, + title = {Preuve de programmes imp\'eratifs en th\'eorie des types}, + type = {Thèse de Doctorat}, + school = {Universit\'e Paris-Sud}, + year = 1999, + month = {July}, + url = {\url{http://www.lri.fr/~filliatr/ftp/publis/these.ps.gz}} +} + +@Unpublished{Filliatre99c, + author = {J.-C. Filli\^atre}, + title = {{Formal Proof of a Program: Find}}, + month = {January}, + year = 2000, + note = {Submitted to \emph{Science of Computer Programming}}, + url = {\url{http://www.lri.fr/~filliatr/ftp/publis/find.ps.gz}} +} + +@InProceedings{FilliatreMagaud99, + author = {J.-C. Filli\^atre and N. Magaud}, + title = {Certification of sorting algorithms in the system {\Coq}}, + booktitle = {Theorem Proving in Higher Order Logics: + Emerging Trends}, + year = 1999, + url = {\url{http://www.lri.fr/~filliatr/ftp/publis/Filliatre-Magaud.ps.gz}} +} + +@Unpublished{Fle90, + author = {E. Fleury}, + month = jul, + note = {Rapport de Stage}, + title = {Implantation des algorithmes de {Floyd et de Dijkstra} dans le {Calcul des Constructions}}, + year = {1990} +} + +@Book{Fourier, + author = {Jean-Baptiste-Joseph Fourier}, + publisher = {Gauthier-Villars}, + title = {Fourier's method to solve linear + inequations/equations systems.}, + year = {1890} +} + +@InProceedings{Gim94, + author = {E. Gim\'enez}, + booktitle = {Types'94 : Types for Proofs and Programs}, + note = {Extended version in LIP research report 95-07, ENS Lyon}, + publisher = SV, + series = LNCS, + title = {Codifying guarded definitions with recursive schemes}, + volume = {996}, + year = {1994} +} + +@PhDThesis{Gim96, + author = {E. Gim\'enez}, + title = {Un calcul des constructions infinies et son application \'a la v\'erification de syst\`emes communicants}, + school = {\'Ecole Normale Sup\'erieure de Lyon}, + year = {1996} +} + +@TechReport{Gim98, + author = {E. Gim\'enez}, + title = {A Tutorial on Recursive Types in Coq}, + institution = {INRIA}, + year = 1998, + month = mar +} + +@Unpublished{GimCas05, + author = {E. Gim\'enez and P. Cast\'eran}, + title = {A Tutorial on [Co-]Inductive Types in Coq}, + institution = {INRIA}, + year = 2005, + month = jan, + note = {available at \url{http://coq.inria.fr/doc}} +} + +@InProceedings{Gimenez95b, + author = {E. Gim\'enez}, + booktitle = {Workshop on Types for Proofs and Programs}, + series = LNCS, + number = {1158}, + pages = {135-152}, + title = {An application of co-Inductive types in Coq: + verification of the Alternating Bit Protocol}, + editorS = {S. Berardi and M. Coppo}, + publisher = SV, + year = {1995} +} + +@InProceedings{Gir70, + author = {J.-Y. Girard}, + booktitle = {Proceedings of the 2nd Scandinavian Logic Symposium}, + publisher = {North-Holland}, + title = {Une extension de l'interpr\'etation de {G\"odel} \`a l'analyse, et son application \`a l'\'elimination des coupures dans l'analyse et la th\'eorie des types}, + year = {1970} +} + +@PhDThesis{Gir72, + author = {J.-Y. Girard}, + school = {Universit\'e Paris~7}, + title = {Interpr\'etation fonctionnelle et \'elimination des coupures de l'arithm\'etique d'ordre sup\'erieur}, + year = {1972} +} + +@Book{Gir89, + author = {J.-Y. Girard and Y. Lafont and P. Taylor}, + publisher = {Cambridge University Press}, + series = {Cambridge Tracts in Theoretical Computer Science 7}, + title = {Proofs and Types}, + year = {1989} +} + +@TechReport{Har95, + author = {John Harrison}, + title = {Metatheory and Reflection in Theorem Proving: A Survey and Critique}, + institution = {SRI International Cambridge Computer Science Research Centre,}, + year = 1995, + type = {Technical Report}, + number = {CRC-053}, + abstract = {http://www.cl.cam.ac.uk/users/jrh/papers.html} +} + +@MastersThesis{Hir94, + author = {D. Hirschkoff}, + month = sep, + school = {DEA IARFA, Ecole des Ponts et Chauss\'ees, Paris}, + title = {Écriture d'une tactique arithm\'etique pour le syst\`eme {\Coq}}, + year = {1994} +} + +@InProceedings{HofStr98, + author = {Martin Hofmann and Thomas Streicher}, + title = {The groupoid interpretation of type theory}, + booktitle = {Proceedings of the meeting Twenty-five years of constructive type theory}, + publisher = {Oxford University Press}, + year = {1998} +} + +@InCollection{How80, + author = {W.A. Howard}, + booktitle = {to H.B. Curry : Essays on Combinatory Logic, Lambda Calculus and Formalism.}, + editor = {J.P. Seldin and J.R. Hindley}, + note = {Unpublished 1969 Manuscript}, + publisher = {Academic Press}, + title = {The Formulae-as-Types Notion of Constructions}, + year = {1980} +} + +@InProceedings{Hue87tapsoft, + author = {G. Huet}, + title = {Programming of Future Generation Computers}, + booktitle = {Proceedings of TAPSOFT87}, + series = LNCS, + volume = 249, + pages = {276--286}, + year = 1987, + publisher = SV +} + +@InProceedings{Hue87, + author = {G. Huet}, + booktitle = {Programming of Future Generation Computers}, + editor = {K. Fuchi and M. Nivat}, + note = {Also in \cite{Hue87tapsoft}}, + publisher = {Elsevier Science}, + title = {Induction Principles Formalized in the {Calculus of Constructions}}, + year = {1988} +} + +@InProceedings{Hue88, + author = {G. Huet}, + booktitle = {A perspective in Theoretical Computer Science. Commemorative Volume for Gift Siromoney}, + editor = {R. Narasimhan}, + note = {Also in~\cite{CoC89}}, + publisher = {World Scientific Publishing}, + title = {{The Constructive Engine}}, + year = {1989} +} + +@Unpublished{Hue88b, + author = {G. Huet}, + title = {Extending the Calculus of Constructions with Type:Type}, + year = 1988, + note = {Unpublished} +} + +@Book{Hue89, + editor = {G. Huet}, + publisher = {Addison-Wesley}, + series = {The UT Year of Programming Series}, + title = {Logical Foundations of Functional Programming}, + year = {1989} +} + +@InProceedings{Hue92, + author = {G. Huet}, + booktitle = {Proceedings of 12th FST/TCS Conference, New Delhi}, + pages = {229--240}, + publisher = SV, + series = LNCS, + title = {The Gallina Specification Language : A case study}, + volume = {652}, + year = {1992} +} + +@Article{Hue94, + author = {G. Huet}, + journal = {J. Functional Programming}, + pages = {371--394}, + publisher = {Cambridge University Press}, + title = {Residual theory in $\lambda$-calculus: a formal development}, + volume = {4,3}, + year = {1994} +} + +@InCollection{HuetLevy79, + author = {G. Huet and J.-J. L\'{e}vy}, + title = {Call by Need Computations in Non-Ambigous +Linear Term Rewriting Systems}, + note = {Also research report 359, INRIA, 1979}, + booktitle = {Computational Logic, Essays in Honor of +Alan Robinson}, + editor = {J.-L. Lassez and G. Plotkin}, + publisher = {The MIT press}, + year = {1991} +} + +@Article{KeWe84, + author = {J. Ketonen and R. Weyhrauch}, + journal = {Theoretical Computer Science}, + pages = {297--307}, + title = {A decidable fragment of {P}redicate {C}alculus}, + volume = {32}, + year = {1984} +} + +@Book{Kle52, + author = {S.C. Kleene}, + publisher = {North-Holland}, + series = {Bibliotheca Mathematica}, + title = {Introduction to Metamathematics}, + year = {1952} +} + +@Book{Kri90, + author = {J.-L. Krivine}, + publisher = {Masson}, + series = {Etudes et recherche en informatique}, + title = {Lambda-calcul {types et mod\`eles}}, + year = {1990} +} + +@Book{LE92, + editor = {G. Huet and G. Plotkin}, + publisher = {Cambridge University Press}, + title = {Logical Environments}, + year = {1992} +} + +@Book{LF91, + editor = {G. Huet and G. Plotkin}, + publisher = {Cambridge University Press}, + title = {Logical Frameworks}, + year = {1991} +} + +@Article{Laville91, + author = {A. Laville}, + title = {Comparison of Priority Rules in Pattern +Matching and Term Rewriting}, + journal = {Journal of Symbolic Computation}, + volume = {11}, + pages = {321--347}, + year = {1991} +} + +@InProceedings{LePa94, + author = {F. Leclerc and C. Paulin-Mohring}, + booktitle = {{Types for Proofs and Programs, Types' 93}}, + editor = {H. Barendregt and T. Nipkow}, + publisher = SV, + series = {LNCS}, + title = {{Programming with Streams in Coq. A case study : The Sieve of Eratosthenes}}, + volume = {806}, + year = {1994} +} + +@TechReport{Leroy90, + author = {X. Leroy}, + title = {The {ZINC} experiment: an economical implementation +of the {ML} language}, + institution = {INRIA}, + number = {117}, + year = {1990} +} + +@InProceedings{Let02, + author = {P. Letouzey}, + title = {A New Extraction for Coq}, + booktitle = {TYPES}, + year = 2002, + crossref = {DBLP:conf/types/2002}, + url = {draft at \url{http://www.irif.fr/~letouzey/download/extraction2002.pdf}} +} + +@PhDThesis{Luo90, + author = {Z. Luo}, + title = {An Extended Calculus of Constructions}, + school = {University of Edinburgh}, + year = {1990} +} + +@inproceedings{Luttik97specificationof, + Author = {Sebastiaan P. Luttik and Eelco Visser}, + Booktitle = {2nd International Workshop on the Theory and Practice of Algebraic Specifications (ASF+SDF'97), Electronic Workshops in Computing}, + Publisher = {Springer-Verlag}, + Title = {Specification of Rewriting Strategies}, + Year = {1997}} + +@Book{MaL84, + author = {{P. Martin-L\"of}}, + publisher = {Bibliopolis}, + series = {Studies in Proof Theory}, + title = {Intuitionistic Type Theory}, + year = {1984} +} + +@Article{MaSi94, + author = {P. Manoury and M. Simonot}, + title = {Automatizing Termination Proofs of Recursively Defined Functions.}, + journal = {TCS}, + volume = {135}, + number = {2}, + year = {1994}, + pages = {319-343}, +} + +@InProceedings{Miquel00, + author = {A. Miquel}, + title = {A Model for Impredicative Type Systems with Universes, +Intersection Types and Subtyping}, + booktitle = {{Proceedings of the 15th Annual IEEE Symposium on Logic in Computer Science (LICS'00)}}, + publisher = {IEEE Computer Society Press}, + year = {2000} +} + +@PhDThesis{Miquel01a, + author = {A. Miquel}, + title = {Le Calcul des Constructions implicite: syntaxe et s\'emantique}, + month = {dec}, + school = {{Universit\'e Paris 7}}, + year = {2001} +} + +@InProceedings{Miquel01b, + author = {A. Miquel}, + title = {The Implicit Calculus of Constructions: Extending Pure Type Systems with an Intersection Type Binder and Subtyping}, + booktitle = {{Proceedings of the fifth International Conference on Typed Lambda Calculi and Applications (TLCA01), Krakow, Poland}}, + publisher = SV, + series = {LNCS}, + number = 2044, + year = {2001} +} + +@InProceedings{MiWer02, + author = {A. Miquel and B. Werner}, + title = {The Not So Simple Proof-Irrelevant Model of CC}, + booktitle = {TYPES}, + year = {2002}, + pages = {240-258}, + ee = {http://link.springer.de/link/service/series/0558/bibs/2646/26460240.htm}, + crossref = {DBLP:conf/types/2002}, + bibsource = {DBLP, http://dblp.uni-trier.de} +} + +@proceedings{DBLP:conf/types/2002, + editor = {H. Geuvers and F. Wiedijk}, + title = {Types for Proofs and Programs, Second International Workshop, + TYPES 2002, Berg en Dal, The Netherlands, April 24-28, 2002, + Selected Papers}, + booktitle = {TYPES}, + publisher = SV, + series = LNCS, + volume = {2646}, + year = {2003}, + isbn = {3-540-14031-X}, + bibsource = {DBLP, http://dblp.uni-trier.de} +} + +@InProceedings{Moh89a, + author = {C. Paulin-Mohring}, + address = {Austin}, + booktitle = {Sixteenth Annual ACM Symposium on Principles of Programming Languages}, + month = jan, + publisher = {ACM}, + title = {Extracting ${F}_{\omega}$'s programs from proofs in the {Calculus of Constructions}}, + year = {1989} +} + +@PhDThesis{Moh89b, + author = {C. Paulin-Mohring}, + month = jan, + school = {{Universit\'e Paris 7}}, + title = {Extraction de programmes dans le {Calcul des Constructions}}, + year = {1989} +} + +@InProceedings{Moh93, + author = {C. Paulin-Mohring}, + booktitle = {Proceedings of the conference Typed Lambda Calculi and Applications}, + editor = {M. Bezem and J.-F. Groote}, + note = {Also LIP research report 92-49, ENS Lyon}, + number = {664}, + publisher = SV, + series = {LNCS}, + title = {{Inductive Definitions in the System Coq - Rules and Properties}}, + year = {1993} +} + +@Book{Moh97, + author = {C. Paulin-Mohring}, + month = jan, + publisher = {{ENS Lyon}}, + title = {{Le syst\`eme Coq. \mbox{Th\`ese d'habilitation}}}, + year = {1997} +} + +@MastersThesis{Mun94, + author = {C. Muñoz}, + month = sep, + school = {DEA d'Informatique Fondamentale, Universit\'e Paris 7}, + title = {D\'emonstration automatique dans la logique propositionnelle intuitionniste}, + year = {1994} +} + +@PhDThesis{Mun97d, + author = {C. Mu{\~{n}}oz}, + title = {Un calcul de substitutions pour la repr\'esentation + de preuves partielles en th\'eorie de types}, + school = {Universit\'e Paris 7}, + year = {1997}, + note = {Version en anglais disponible comme rapport de + recherche INRIA RR-3309}, + type = {Th\`ese de Doctorat} +} + +@Book{NoPS90, + author = {B. {Nordstr\"om} and K. Peterson and J. Smith}, + booktitle = {Information Processing 83}, + publisher = {Oxford Science Publications}, + series = {International Series of Monographs on Computer Science}, + title = {Programming in {Martin-L\"of's} Type Theory}, + year = {1990} +} + +@Article{Nor88, + author = {B. {Nordstr\"om}}, + journal = {BIT}, + title = {Terminating General Recursion}, + volume = {28}, + year = {1988} +} + +@Book{Odi90, + editor = {P. Odifreddi}, + publisher = {Academic Press}, + title = {Logic and Computer Science}, + year = {1990} +} + +@InProceedings{PaMS92, + author = {M. Parigot and P. Manoury and M. Simonot}, + address = {St. Petersburg, Russia}, + booktitle = {Logic Programming and automated reasoning}, + editor = {A. Voronkov}, + month = jul, + number = {624}, + publisher = SV, + series = {LNCS}, + title = {{ProPre : A Programming language with proofs}}, + year = {1992} +} + +@Article{PaWe92, + author = {C. Paulin-Mohring and B. Werner}, + journal = {Journal of Symbolic Computation}, + pages = {607--640}, + title = {{Synthesis of ML programs in the system Coq}}, + volume = {15}, + year = {1993} +} + +@Article{Par92, + author = {M. Parigot}, + journal = {Theoretical Computer Science}, + number = {2}, + pages = {335--356}, + title = {{Recursive Programming with Proofs}}, + volume = {94}, + year = {1992} +} + +@InProceedings{Parent95b, + author = {C. Parent}, + booktitle = {{Mathematics of Program Construction'95}}, + publisher = SV, + series = {LNCS}, + title = {{Synthesizing proofs from programs in +the Calculus of Inductive Constructions}}, + volume = {947}, + year = {1995} +} + +@InProceedings{Prasad93, + author = {K.V. Prasad}, + booktitle = {{Proceedings of CONCUR'93}}, + publisher = SV, + series = {LNCS}, + title = {{Programming with broadcasts}}, + volume = {715}, + year = {1993} +} + +@Book{RC95, + author = {di~Cosmo, R.}, + title = {Isomorphisms of Types: from $\lambda$-calculus to information + retrieval and language design}, + series = {Progress in Theoretical Computer Science}, + publisher = {Birkhauser}, + year = {1995}, + note = {ISBN-0-8176-3763-X} +} + +@TechReport{Rou92, + author = {J. Rouyer}, + institution = {INRIA}, + month = nov, + number = {1795}, + title = {{Développement de l'Algorithme d'Unification dans le Calcul des Constructions}}, + year = {1992} +} + +@Article{Rushby98, + title = {Subtypes for Specifications: Predicate Subtyping in + {PVS}}, + author = {John Rushby and Sam Owre and N. Shankar}, + journal = {IEEE Transactions on Software Engineering}, + pages = {709--720}, + volume = 24, + number = 9, + month = sep, + year = 1998 +} + +@TechReport{Saibi94, + author = {A. Sa\"{\i}bi}, + institution = {INRIA}, + month = dec, + number = {2345}, + title = {{Axiomatization of a lambda-calculus with explicit-substitutions in the Coq System}}, + year = {1994} +} + + +@MastersThesis{Ter92, + author = {D. Terrasse}, + month = sep, + school = {IARFA}, + title = {{Traduction de TYPOL en COQ. Application \`a Mini ML}}, + year = {1992} +} + +@TechReport{ThBeKa92, + author = {L. Th\'ery and Y. Bertot and G. Kahn}, + institution = {INRIA Sophia}, + month = may, + number = {1684}, + title = {Real theorem provers deserve real user-interfaces}, + type = {Research Report}, + year = {1992} +} + +@Book{TrDa89, + author = {A.S. Troelstra and D. van Dalen}, + publisher = {North-Holland}, + series = {Studies in Logic and the foundations of Mathematics, volumes 121 and 123}, + title = {Constructivism in Mathematics, an introduction}, + year = {1988} +} + +@PhDThesis{Wer94, + author = {B. Werner}, + school = {Universit\'e Paris 7}, + title = {Une th\'eorie des constructions inductives}, + type = {Th\`ese de Doctorat}, + year = {1994} +} + +@PhDThesis{Bar99, + author = {B. Barras}, + school = {Universit\'e Paris 7}, + title = {Auto-validation d'un système de preuves avec familles inductives}, + type = {Th\`ese de Doctorat}, + year = {1999} +} + +@Unpublished{ddr98, + author = {D. de Rauglaudre}, + title = {Camlp4 version 1.07.2}, + year = {1998}, + note = {In Camlp4 distribution} +} + +@Article{dowek93, + author = {G. Dowek}, + title = {{A Complete Proof Synthesis Method for the Cube of Type Systems}}, + journal = {Journal Logic Computation}, + volume = {3}, + number = {3}, + pages = {287--315}, + month = {June}, + year = {1993} +} + +@InProceedings{manoury94, + author = {P. Manoury}, + title = {{A User's Friendly Syntax to Define +Recursive Functions as Typed $\lambda-$Terms}}, + booktitle = {{Types for Proofs and Programs, TYPES'94}}, + series = {LNCS}, + volume = {996}, + month = jun, + year = {1994} +} + +@TechReport{maranget94, + author = {L. Maranget}, + institution = {INRIA}, + number = {2385}, + title = {{Two Techniques for Compiling Lazy Pattern Matching}}, + year = {1994} +} + +@InProceedings{puel-suarez90, + author = {L.Puel and A. Su\'arez}, + booktitle = {{Conference Lisp and Functional Programming}}, + series = {ACM}, + publisher = SV, + title = {{Compiling Pattern Matching by Term +Decomposition}}, + year = {1990} +} + +@MastersThesis{saidi94, + author = {H. Saidi}, + month = sep, + school = {DEA d'Informatique Fondamentale, Universit\'e Paris 7}, + title = {R\'esolution d'\'equations dans le syst\`eme T + de G\"odel}, + year = {1994} +} + +@inproceedings{sozeau06, + author = {Matthieu Sozeau}, + title = {Subset Coercions in {C}oq}, + year = {2007}, + booktitle = {TYPES'06}, + pages = {237-252}, + volume = {4502}, + publisher = "Springer", + series = {LNCS} +} + +@inproceedings{sozeau08, + Author = {Matthieu Sozeau and Nicolas Oury}, + booktitle = {TPHOLs'08}, + Pdf = {http://www.lri.fr/~sozeau/research/publications/drafts/classes.pdf}, + Title = {{F}irst-{C}lass {T}ype {C}lasses}, + Year = {2008}, +} + +@Misc{streicher93semantical, + author = {T. Streicher}, + title = {Semantical Investigations into Intensional Type Theory}, + note = {Habilitationsschrift, LMU Munchen.}, + year = {1993} +} + +@Misc{Pcoq, + author = {Lemme Team}, + title = {Pcoq a graphical user-interface for {Coq}}, + note = {\url{http://www-sop.inria.fr/lemme/pcoq/}} +} + +@Misc{ProofGeneral, + author = {David Aspinall}, + title = {Proof General}, + note = {\url{https://proofgeneral.github.io/}} +} + +@Book{CoqArt, + title = {Interactive Theorem Proving and Program Development. + Coq'Art: The Calculus of Inductive Constructions}, + author = {Yves Bertot and Pierre Castéran}, + publisher = {Springer Verlag}, + series = {Texts in Theoretical Computer Science. An EATCS series}, + year = 2004 +} + +@InCollection{wadler87, + author = {P. Wadler}, + title = {Efficient Compilation of Pattern Matching}, + booktitle = {The Implementation of Functional Programming +Languages}, + editor = {S.L. Peyton Jones}, + publisher = {Prentice-Hall}, + year = {1987} +} + +@inproceedings{DBLP:conf/types/CornesT95, + author = {Cristina Cornes and + Delphine Terrasse}, + title = {Automating Inversion of Inductive Predicates in Coq}, + booktitle = {TYPES}, + year = {1995}, + pages = {85-104}, + crossref = {DBLP:conf/types/1995}, + bibsource = {DBLP, http://dblp.uni-trier.de} +} +@proceedings{DBLP:conf/types/1995, + editor = {Stefano Berardi and + Mario Coppo}, + title = {Types for Proofs and Programs, International Workshop TYPES'95, + Torino, Italy, June 5-8, 1995, Selected Papers}, + booktitle = {TYPES}, + publisher = {Springer}, + series = {Lecture Notes in Computer Science}, + volume = {1158}, + year = {1996}, + isbn = {3-540-61780-9}, + bibsource = {DBLP, http://dblp.uni-trier.de} +} + +@inproceedings{DBLP:conf/types/McBride00, + author = {Conor McBride}, + title = {Elimination with a Motive}, + booktitle = {TYPES}, + year = {2000}, + pages = {197-216}, + ee = {http://link.springer.de/link/service/series/0558/bibs/2277/22770197.htm}, + crossref = {DBLP:conf/types/2000}, + bibsource = {DBLP, http://dblp.uni-trier.de} +} + +@proceedings{DBLP:conf/types/2000, + editor = {Paul Callaghan and + Zhaohui Luo and + James McKinna and + Robert Pollack}, + title = {Types for Proofs and Programs, International Workshop, TYPES + 2000, Durham, UK, December 8-12, 2000, Selected Papers}, + booktitle = {TYPES}, + publisher = {Springer}, + series = {Lecture Notes in Computer Science}, + volume = {2277}, + year = {2002}, + isbn = {3-540-43287-6}, + bibsource = {DBLP, http://dblp.uni-trier.de} +} + +@INPROCEEDINGS{sugar, + author = {Alessandro Giovini and Teo Mora and Gianfranco Niesi and Lorenzo Robbiano and Carlo Traverso}, + title = {"One sugar cube, please" or Selection strategies in the Buchberger algorithm}, + booktitle = { Proceedings of the ISSAC'91, ACM Press}, + year = {1991}, + pages = {5--4}, + publisher = {} +} + +@article{LeeWerner11, + author = {Gyesik Lee and + Benjamin Werner}, + title = {Proof-irrelevant model of {CC} with predicative induction + and judgmental equality}, + journal = {Logical Methods in Computer Science}, + volume = {7}, + number = {4}, + year = {2011}, + ee = {http://dx.doi.org/10.2168/LMCS-7(4:5)2011}, + bibsource = {DBLP, http://dblp.uni-trier.de} +} + +@Comment{cross-references, must be at end} + +@Book{Bastad92, + editor = {B. Nordstr\"om and K. Petersson and G. Plotkin}, + publisher = {Available by ftp at site ftp.inria.fr}, + title = {Proceedings of the 1992 Workshop on Types for Proofs and Programs}, + year = {1992} +} + +@Book{Nijmegen93, + editor = {H. Barendregt and T. Nipkow}, + publisher = SV, + series = LNCS, + title = {Types for Proofs and Programs}, + volume = {806}, + year = {1994} +} + +@article{ TheOmegaPaper, + author = "W. Pugh", + title = "The Omega test: a fast and practical integer programming algorithm for dependence analysis", + journal = "Communication of the ACM", + pages = "102--114", + year = "1992", +} + +@inproceedings{CSwcu, + hal_id = {hal-00816703}, + url = {http://hal.inria.fr/hal-00816703}, + title = {{Canonical Structures for the working Coq user}}, + author = {Mahboubi, Assia and Tassi, Enrico}, + booktitle = {{ITP 2013, 4th Conference on Interactive Theorem Proving}}, + publisher = {Springer}, + pages = {19-34}, + address = {Rennes, France}, + volume = {7998}, + editor = {Sandrine Blazy and Christine Paulin and David Pichardie }, + series = {LNCS }, + doi = {10.1007/978-3-642-39634-2\_5 }, + year = {2013}, +} + +@article{CSlessadhoc, + author = {Gonthier, Georges and Ziliani, Beta and Nanevski, Aleksandar and Dreyer, Derek}, + title = {How to Make Ad Hoc Proof Automation Less Ad Hoc}, + journal = {SIGPLAN Not.}, + issue_date = {September 2011}, + volume = {46}, + number = {9}, + month = sep, + year = {2011}, + issn = {0362-1340}, + pages = {163--175}, + numpages = {13}, + url = {http://doi.acm.org/10.1145/2034574.2034798}, + doi = {10.1145/2034574.2034798}, + acmid = {2034798}, + publisher = {ACM}, + address = {New York, NY, USA}, + keywords = {canonical structures, coq, custom proof automation, hoare type theory, interactive theorem proving, tactics, type classes}, +} + +@inproceedings{CompiledStrongReduction, + author = {Benjamin Gr{\'{e}}goire and + Xavier Leroy}, + editor = {Mitchell Wand and + Simon L. Peyton Jones}, + title = {A compiled implementation of strong reduction}, + booktitle = {Proceedings of the Seventh {ACM} {SIGPLAN} International Conference + on Functional Programming {(ICFP} '02), Pittsburgh, Pennsylvania, + USA, October 4-6, 2002.}, + pages = {235--246}, + publisher = {{ACM}}, + year = {2002}, + url = {http://doi.acm.org/10.1145/581478.581501}, + doi = {10.1145/581478.581501}, + timestamp = {Tue, 11 Jun 2013 13:49:16 +0200}, + biburl = {http://dblp.uni-trier.de/rec/bib/conf/icfp/GregoireL02}, + bibsource = {dblp computer science bibliography, http://dblp.org} +} + +@inproceedings{FullReduction, + author = {Mathieu Boespflug and + Maxime D{\'{e}}n{\`{e}}s and + Benjamin Gr{\'{e}}goire}, + editor = {Jean{-}Pierre Jouannaud and + Zhong Shao}, + title = {Full Reduction at Full Throttle}, + booktitle = {Certified Programs and Proofs - First International Conference, {CPP} + 2011, Kenting, Taiwan, December 7-9, 2011. Proceedings}, + series = {Lecture Notes in Computer Science}, + volume = {7086}, + pages = {362--377}, + publisher = {Springer}, + year = {2011}, + url = {http://dx.doi.org/10.1007/978-3-642-25379-9_26}, + doi = {10.1007/978-3-642-25379-9_26}, + timestamp = {Thu, 17 Nov 2011 13:33:48 +0100}, + biburl = {http://dblp.uni-trier.de/rec/bib/conf/cpp/BoespflugDG11}, + bibsource = {dblp computer science bibliography, http://dblp.org} +} diff --git a/doc/sphinx/conf.py b/doc/sphinx/conf.py index 0bff41a259..12aeee3f91 100755 --- a/doc/sphinx/conf.py +++ b/doc/sphinx/conf.py @@ -10,7 +10,7 @@ ## # (see LICENSE file for the text of the license) ## ########################################################################## # -# Coq 8.5 documentation build configuration file, created by +# Coq documentation build configuration file, created by # sphinx-quickstart on Wed May 11 11:23:13 2016. # # This file is execfile()d with the current directory set to its @@ -32,6 +32,9 @@ sys.setrecursionlimit(1500) # add these directories to sys.path here. If the directory is relative to the # documentation root, use os.path.abspath to make it absolute, like shown here. sys.path.append(os.path.abspath('../tools/')) +sys.path.append(os.path.abspath('../../config/')) + +import coq_config # -- General configuration ------------------------------------------------ @@ -64,7 +67,7 @@ master_doc = 'index' # General information about the project. project = 'Coq' -copyright = '2016, Inria' +copyright = '1999-2018, Inria' author = 'The Coq Development Team' # The version info for the project you're documenting, acts as replacement for @@ -72,9 +75,9 @@ author = 'The Coq Development Team' # built documents. # # The short X.Y version. -version = '8.7' +version = coq_config.version # The full version, including alpha/beta/rc tags. -release = '8.7.dev' +release = coq_config.version # The language for content autogenerated by Sphinx. Refer to documentation # for a list of supported languages. @@ -92,7 +95,7 @@ language = None # List of patterns, relative to source directory, that match files and # directories to ignore when looking for source files. # This patterns also effect to html_static_path and html_extra_path -exclude_patterns = ['_build', 'Thumbs.db', '.DS_Store'] +exclude_patterns = ['_build', 'Thumbs.db', '.DS_Store', 'introduction.rst'] # The reST default role (used for this markup: `text`) to use for all # documents. @@ -143,6 +146,14 @@ html_theme = 'sphinx_rtd_theme' # documentation. #html_theme_options = {} +html_context = { + 'display_github': True, + 'github_user': 'coq', + 'github_repo': 'coq', + 'github_version': 'master', + 'conf_py_path': '/doc/sphinx/' +} + # Add any paths that contain custom themes here, relative to this directory. import sphinx_rtd_theme html_theme_path = [sphinx_rtd_theme.get_html_theme_path()] @@ -230,9 +241,6 @@ html_use_smartypants = False # FIXME wrap code in <code> tags, otherwise quotesg # implements a search results scorer. If empty, the default will be used. #html_search_scorer = 'scorer.js' -# Output file base name for HTML help builder. -htmlhelp_basename = 'Coq85doc' - # -- Options for LaTeX output --------------------------------------------- ########################### @@ -264,10 +272,10 @@ latex_additional_files = ["_static/coqnotations.sty"] # Grouping the document tree into LaTeX files. List of tuples # (source start file, target name, title, # author, documentclass [howto, manual, or own class]). -latex_documents = [ - (master_doc, 'Coq85.tex', 'Coq 8.5 Documentation', - 'The Coq Development Team (edited by C. Pit-Claudel)', 'manual'), -] +# latex_documents = [ +# (master_doc, 'CoqRefMan.tex', 'Coq Documentation', +# 'The Coq Development Team', 'manual'), +#] # The name of an image file (relative to this directory) to place at the top of # the title page. @@ -294,10 +302,10 @@ latex_documents = [ # One entry per manual page. List of tuples # (source start file, name, description, authors, manual section). -man_pages = [ - (master_doc, 'coq85', 'Coq 8.5 Documentation', - [author], 1) -] +#man_pages = [ +# (master_doc, 'coq', 'Coq Documentation', +# [author], 1) +#] # If true, show URL addresses after external links. #man_show_urls = False @@ -308,11 +316,11 @@ man_pages = [ # Grouping the document tree into Texinfo files. List of tuples # (source start file, target name, title, author, # dir menu entry, description, category) -texinfo_documents = [ - (master_doc, 'Coq85', 'Coq 8.5 Documentation', - author, 'Coq85', 'One line description of project.', - 'Miscellaneous'), -] +#texinfo_documents = [ +# (master_doc, 'Coq', 'Coq Documentation', +# author, 'Coq', 'One line description of project.', +# 'Miscellaneous'), +#] # Documents to append as an appendix to all manuals. #texinfo_appendices = [] @@ -330,10 +338,10 @@ texinfo_documents = [ # -- Options for Epub output ---------------------------------------------- # Bibliographic Dublin Core info. -epub_title = project -epub_author = author -epub_publisher = author -epub_copyright = copyright +#epub_title = project +#epub_author = author +#epub_publisher = author +#epub_copyright = copyright # The basename for the epub file. It defaults to the project name. #epub_basename = project diff --git a/doc/sphinx/coq-cmdindex.rst b/doc/sphinx/coq-cmdindex.rst new file mode 100644 index 0000000000..7df6cb36c5 --- /dev/null +++ b/doc/sphinx/coq-cmdindex.rst @@ -0,0 +1,5 @@ +.. hack to get index in TOC + +----------------- +Command index +----------------- diff --git a/doc/sphinx/coq-exnindex.rst b/doc/sphinx/coq-exnindex.rst new file mode 100644 index 0000000000..100c57b085 --- /dev/null +++ b/doc/sphinx/coq-exnindex.rst @@ -0,0 +1,5 @@ +.. hack to get index in TOC + +---------------------- +Errors, warnings index +---------------------- diff --git a/doc/sphinx/coq-optindex.rst b/doc/sphinx/coq-optindex.rst new file mode 100644 index 0000000000..f8046a800b --- /dev/null +++ b/doc/sphinx/coq-optindex.rst @@ -0,0 +1,5 @@ +.. hack to get index in TOC + +----------------- +Option index +----------------- diff --git a/doc/sphinx/coq-tacindex.rst b/doc/sphinx/coq-tacindex.rst new file mode 100644 index 0000000000..588104f465 --- /dev/null +++ b/doc/sphinx/coq-tacindex.rst @@ -0,0 +1,5 @@ +.. hack to get index in TOC + +------------- +Tactic index +------------- diff --git a/doc/sphinx/genindex.rst b/doc/sphinx/genindex.rst new file mode 100644 index 0000000000..a991c7f9f8 --- /dev/null +++ b/doc/sphinx/genindex.rst @@ -0,0 +1,5 @@ +.. hack to get index in TOC + +----- +Index +----- diff --git a/doc/sphinx/index.rst b/doc/sphinx/index.rst index e69de29bb2..7b8bc2bae6 100644 --- a/doc/sphinx/index.rst +++ b/doc/sphinx/index.rst @@ -0,0 +1,50 @@ +.. _introduction: + +.. include:: preamble.rst +.. include:: replaces.rst + +Introduction +=========================================== + +.. include:: introduction.rst + +------------------ +Table of contents +------------------ + +.. toctree:: + :caption: The language + +.. toctree:: + :caption: The proof engine + +.. toctree:: + :caption: User extensions + +.. toctree:: + :caption: Practical tools + +.. toctree:: + :caption: Addendum + +.. toctree:: + :caption: Reference + + zebibliography + +.. toctree:: + :caption: Indexes + + genindex + coq-cmdindex + coq-tacindex + coq-optindex + coq-exnindex + +.. No entries yet + * :index:`thmindex` + +This material (the Coq Reference Manual) may be distributed only subject to the +terms and conditions set forth in the Open Publication License, v1.0 or later +(the latest version is presently available at +http://www.opencontent.org/openpub). Options A and B are not elected. diff --git a/doc/sphinx/introduction.rst b/doc/sphinx/introduction.rst new file mode 100644 index 0000000000..514745c1bf --- /dev/null +++ b/doc/sphinx/introduction.rst @@ -0,0 +1,119 @@ +------------------------ +Introduction +------------------------ + +This document is the Reference Manual of version of the |Coq| proof +assistant. A companion volume, the |Coq| Tutorial, is provided for the +beginners. It is advised to read the Tutorial first. A +book :cite:`CoqArt` on practical uses of the |Coq| system was +published in 2004 and is a good support for both the beginner and the +advanced user. + +The |Coq| system is designed to develop mathematical proofs, and +especially to write formal specifications, programs and to verify that +programs are correct with respect to their specification. It provides a +specification language named |Gallina|. Terms of |Gallina| can represent +programs as well as properties of these programs and proofs of these +properties. Using the so-called *Curry-Howard isomorphism*, programs, +properties and proofs are formalized in the same language called +*Calculus of Inductive Constructions*, that is a +:math:`\lambda`-calculus with a rich type system. All logical judgments +in |Coq| are typing judgments. The very heart of the |Coq| system is the +type-checking algorithm that checks the correctness of proofs, in other +words that checks that a program complies to its specification. |Coq| also +provides an interactive proof assistant to build proofs using specific +programs called *tactics*. + +All services of the |Coq| proof assistant are accessible by interpretation +of a command language called *the vernacular*. + +Coq has an interactive mode in which commands are interpreted as the +user types them in from the keyboard and a compiled mode where commands +are processed from a file. + +- The interactive mode may be used as a debugging mode in which the + user can develop his theories and proofs step by step, backtracking + if needed and so on. The interactive mode is run with the `coqtop` + command from the operating system (which we shall assume to be some + variety of UNIX in the rest of this document). + +- The compiled mode acts as a proof checker taking a file containing a + whole development in order to ensure its correctness. Moreover, + |Coq|’s compiler provides an output file containing a compact + representation of its input. The compiled mode is run with the `coqc` + command from the operating system. + +These two modes are documented in Chapter :ref:`thecoqcommands`. + +Other modes of interaction with |Coq| are possible: through an emacs shell +window, an emacs generic user-interface for proof assistant (Proof +General :cite:`ProofGeneral`) or through a customized +interface (PCoq :cite:`Pcoq`). These facilities are not +documented here. There is also a |Coq| Integrated Development Environment +described in :ref:`coqintegrateddevelopmentenvironment`. + +How to read this book +===================== + +This is a Reference Manual, not a User Manual, so it is not made for a +continuous reading. However, it has some structure that is explained +below. + +- The first part describes the specification language, |Gallina|. + Chapters :ref:`thegallinaspecificationlanguage` and :ref:`extensionsofgallina` describe the concrete + syntax as well as the meaning of programs, theorems and proofs in the + Calculus of Inductive Constructions. Chapter :ref:`thecoqlibrary` describes the + standard library of |Coq|. Chapter :ref:`calculusofinductiveconstructions` is a mathematical description + of the formalism. Chapter :ref:`themodulesystem` describes the module + system. + +- The second part describes the proof engine. It is divided in five + chapters. Chapter :ref:`vernacularcommands` presents all commands (we + call them *vernacular commands*) that are not directly related to + interactive proving: requests to the environment, complete or partial + evaluation, loading and compiling files. How to start and stop + proofs, do multiple proofs in parallel is explained in + Chapter :ref:`proofhandling`. In Chapter :ref:`tactics`, all commands that + realize one or more steps of the proof are presented: we call them + *tactics*. The language to combine these tactics into complex proof + strategies is given in Chapter :ref:`thetacticlanguage`. Examples of tactics + are described in Chapter :ref:`detailedexamplesoftactics`. + +- The third part describes how to extend the syntax of |Coq|. It + corresponds to the Chapter :ref:`syntaxextensionsandinterpretationscopes`. + +- In the fourth part more practical tools are documented. First in + Chapter :ref:`thecoqcommands`, the usage of `coqc` (batch mode) and + `coqtop` (interactive mode) with their options is described. Then, + in Chapter :ref:`utilities`, various utilities that come with the + |Coq| distribution are presented. Finally, Chapter :ref:`coqintegrateddevelopmentenvironment` + describes the |Coq| integrated development environment. + +- The fifth part documents a number of advanced features, including coercions, + canonical structures, typeclasses, program extraction, and specialized + solvers and tactics. See the table of contents for a complete list. + +At the end of the document, after the global index, the user can find +specific indexes for tactics, vernacular commands, and error messages. + +List of additional documentation +================================ + +This manual does not contain all the documentation the user may need +about |Coq|. Various informations can be found in the following documents: + +Tutorial + A companion volume to this reference manual, the |Coq| Tutorial, is + aimed at gently introducing new users to developing proofs in |Coq| + without assuming prior knowledge of type theory. In a second step, + the user can read also the tutorial on recursive types (document + `RecTutorial.ps`). + +Installation + A text file `INSTALL` that comes with the sources explains how to + install |Coq|. + +The |Coq| standard library + A commented version of sources of the |Coq| standard library + (including only the specifications, the proofs are removed) is given + in the additional document `Library.ps`. diff --git a/doc/sphinx/preamble.rst b/doc/sphinx/preamble.rst new file mode 100644 index 0000000000..395f558a85 --- /dev/null +++ b/doc/sphinx/preamble.rst @@ -0,0 +1,92 @@ +.. preamble:: + + \[ + \newcommand{\alors}{\textsf{then}} + \newcommand{\alter}{\textsf{alter}} + \newcommand{\as}{\kw{as}} + \newcommand{\Assum}[3]{\kw{Assum}(#1)(#2:#3)} + \newcommand{\bool}{\textsf{bool}} + \newcommand{\case}{\kw{case}} + \newcommand{\conc}{\textsf{conc}} + \newcommand{\cons}{\textsf{cons}} + \newcommand{\consf}{\textsf{consf}} + \newcommand{\conshl}{\textsf{cons\_hl}} + \newcommand{\Def}[4]{\kw{Def}(#1)(#2:=#3:#4)} + \newcommand{\emptyf}{\textsf{emptyf}} + \newcommand{\End}{\kw{End}} + \newcommand{\endkw}{\kw{end}} + \newcommand{\EqSt}{\textsf{EqSt}} + \newcommand{\even}{\textsf{even}} + \newcommand{\evenO}{\textsf{even_O}} + \newcommand{\evenS}{\textsf{even_S}} + \newcommand{\false}{\textsf{false}} + \newcommand{\filter}{\textsf{filter}} + \newcommand{\Fix}{\kw{Fix}} + \newcommand{\fix}{\kw{fix}} + \newcommand{\for}{\textsf{for}} + \newcommand{\forest}{\textsf{forest}} + \newcommand{\from}{\textsf{from}} + \newcommand{\Functor}{\kw{Functor}} + \newcommand{\haslength}{\textsf{has\_length}} + \newcommand{\hd}{\textsf{hd}} + \newcommand{\ident}{\textsf{ident}} + \newcommand{\In}{\kw{in}} + \newcommand{\Ind}[4]{\kw{Ind}[#2](#3:=#4)} + \newcommand{\ind}[3]{\kw{Ind}~[#1]\left(#2\mathrm{~:=~}#3\right)} + \newcommand{\Indp}[5]{\kw{Ind}_{#5}(#1)[#2](#3:=#4)} + \newcommand{\Indpstr}[6]{\kw{Ind}_{#5}(#1)[#2](#3:=#4)/{#6}} + \newcommand{\injective}{\kw{injective}} + \newcommand{\kw}[1]{\textsf{#1}} + \newcommand{\lb}{\lambda} + \newcommand{\length}{\textsf{length}} + \newcommand{\letin}[3]{\kw{let}~#1:=#2~\kw{in}~#3} + \newcommand{\List}{\textsf{list}} + \newcommand{\lra}{\longrightarrow} + \newcommand{\Match}{\kw{match}} + \newcommand{\Mod}[3]{{\kw{Mod}}({#1}:{#2}\,\zeroone{:={#3}})} + \newcommand{\ModA}[2]{{\kw{ModA}}({#1}=={#2})} + \newcommand{\ModS}[2]{{\kw{Mod}}({#1}:{#2})} + \newcommand{\ModType}[2]{{\kw{ModType}}({#1}:={#2})} + \newcommand{\mto}{.\;} + \newcommand{\Nat}{\mathbb{N}} + \newcommand{\nat}{\textsf{nat}} + \newcommand{\Nil}{\textsf{nil}} + \newcommand{\nilhl}{\textsf{nil\_hl}} + \newcommand{\nO}{\textsf{O}} + \newcommand{\node}{\textsf{node}} + \newcommand{\nS}{\textsf{S}} + \newcommand{\odd}{\textsf{odd}} + \newcommand{\oddS}{\textsf{odd_S}} + \newcommand{\ovl}[1]{\overline{#1}} + \newcommand{\Pair}{\textsf{pair}} + \newcommand{\Prod}{\textsf{prod}} + \newcommand{\Prop}{\textsf{Prop}} + \newcommand{\return}{\kw{return}} + \newcommand{\Set}{\textsf{Set}} + \newcommand{\si}{\textsf{if}} + \newcommand{\sinon}{\textsf{else}} + \newcommand{\Sort}{\cal S} + \newcommand{\Str}{\textsf{Stream}} + \newcommand{\Struct}{\kw{Struct}} + \newcommand{\subst}[3]{#1\{#2/#3\}} + \newcommand{\tl}{\textsf{tl}} + \newcommand{\tree}{\textsf{tree}} + \newcommand{\true}{\textsf{true}} + \newcommand{\Type}{\textsf{Type}} + \newcommand{\unfold}{\textsf{unfold}} + \newcommand{\WEV}[3]{\mbox{$#1[] \vdash #2 \lra #3$}} + \newcommand{\WEVT}[3]{\mbox{$#1[] \vdash #2 \lra$}\\ \mbox{$ #3$}} + \newcommand{\WF}[2]{{\cal W\!F}(#1)[#2]} + \newcommand{\WFE}[1]{\WF{E}{#1}} + \newcommand{\WFT}[2]{#1[] \vdash {\cal W\!F}(#2)} + \newcommand{\WFTWOLINES}[2]{{\cal W\!F}\begin{array}{l}(#1)\\\mbox{}[{#2}]\end{array}} + \newcommand{\with}{\kw{with}} + \newcommand{\WS}[3]{#1[] \vdash #2 <: #3} + \newcommand{\WSE}[2]{\WS{E}{#1}{#2}} + \newcommand{\WT}[4]{#1[#2] \vdash #3 : #4} + \newcommand{\WTE}[3]{\WT{E}{#1}{#2}{#3}} + \newcommand{\WTEG}[2]{\WTE{\Gamma}{#1}{#2}} + \newcommand{\WTM}[3]{\WT{#1}{}{#2}{#3}} + \newcommand{\zeroone}[1]{[{#1}]} + \newcommand{\zeros}{\textsf{zeros}} + \] diff --git a/doc/sphinx/replaces.rst b/doc/sphinx/replaces.rst new file mode 100644 index 0000000000..2c38219b97 --- /dev/null +++ b/doc/sphinx/replaces.rst @@ -0,0 +1,78 @@ +.. some handy replacements for common items + +.. role:: smallcaps + +.. |A_1| replace:: `A`\ :math:`_{1}` +.. |A_n| replace:: `A`\ :math:`_{n}` +.. |arg_1| replace:: `arg`\ :math:`_{1}` +.. |arg_n| replace:: `arg`\ :math:`_{n}` +.. |bdi| replace:: :math:`\beta\delta\iota` +.. |binder_1| replace:: `binder`\ :math:`_{1}` +.. |binder_n| replace:: `binder`\ :math:`_{n}` +.. |binders_1| replace:: `binders`\ :math:`_{1}` +.. |binders_n| replace:: `binders`\ :math:`_{n}` +.. |C_1| replace:: `C`\ :math:`_{1}` +.. |c_1| replace:: `c`\ :math:`_{1}` +.. |C_2| replace:: `C`\ :math:`_{2}` +.. |c_i| replace:: `c`\ :math:`_{i}` +.. |c_n| replace:: `c`\ :math:`_{n}` +.. |Cic| replace:: :smallcaps:`Cic` +.. |class_1| replace:: `class`\ :math:`_{1}` +.. |class_2| replace:: `class`\ :math:`_{2}` +.. |Coq| replace:: :smallcaps:`Coq` +.. |CoqIDE| replace:: :smallcaps:`CoqIDE` +.. |eq_beta_delta_iota_zeta| replace:: `=`\ :math:`_{\small{\beta\delta\iota\zeta}}` +.. |Gallina| replace:: :smallcaps:`Gallina` +.. |ident_0| replace:: `ident`\ :math:`_{0}` +.. |ident_1,1| replace:: `ident`\ :math:`_{1,1}` +.. |ident_1,k_1| replace:: `ident`\ :math:`_{1,k_1}`) +.. |ident_1| replace:: `ident`\ :math:`_{1}` +.. |ident_2| replace:: `ident`\ :math:`_{2}` +.. |ident_3| replace:: `ident`\ :math:`_{3}` +.. |ident_i| replace:: `ident`\ :math:`_{i}` +.. |ident_j| replace:: `ident`\ :math:`_{j}` +.. |ident_k| replace:: `ident`\ :math:`_{k}` +.. |ident_n,1| replace:: `ident`\ :math:`_{n,1}` +.. |ident_n,k_n| replace:: `ident`\ :math:`_{n,k_n}` +.. |ident_n| replace:: `ident`\ :math:`_{n}` +.. |L_tac| replace:: `L`:sub:`tac` +.. |ML| replace:: :smallcaps:`ML` +.. |mod_0| replace:: `mod`\ :math:`_{0}` +.. |mod_1| replace:: `mod`\ :math:`_{1}` +.. |mod_2| replace:: `mod`\ :math:`_{1}` +.. |mod_n| replace:: `mod`\ :math:`_{n}` +.. |module_0| replace:: `module`\ :math:`_{0}` +.. |module_1| replace:: `module`\ :math:`_{1}` +.. |module_expression_0| replace:: `module_expression`\ :math:`_{0}` +.. |module_expression_1| replace:: `module_expression`\ :math:`_{1}` +.. |module_expression_i| replace:: `module_expression`\ :math:`_{i}` +.. |module_expression_n| replace:: `module_expression`\ :math:`_{n}` +.. |module_n| replace:: `module`\ :math:`_{n}` +.. |module_type_0| replace:: `module_type`\ :math:`_{0}` +.. |module_type_1| replace:: `module_type`\ :math:`_{1}` +.. |module_type_i| replace:: `module_type`\ :math:`_{i}` +.. |module_type_n| replace:: `module_type`\ :math:`_{n}` +.. |N| replace:: ``N`` +.. |nat| replace:: ``nat`` +.. |Ocaml| replace:: :smallcaps:`OCaml` +.. |p_1| replace:: `p`\ :math:`_{1}` +.. |p_i| replace:: `p`\ :math:`_{i}` +.. |p_n| replace:: `p`\ :math:`_{n}` +.. |Program| replace:: :strong:`Program` +.. |t_1| replace:: `t`\ :math:`_{1}` +.. |t_i| replace:: `t`\ :math:`_{i}` +.. |t_m| replace:: `t`\ :math:`_{m}` +.. |t_n| replace:: `t`\ :math:`_{n}` +.. |term_0| replace:: `term`\ :math:`_{0}` +.. |term_1| replace:: `term`\ :math:`_{1}` +.. |term_2| replace:: `term`\ :math:`_{2}` +.. |term_n| replace:: `term`\ :math:`_{n}` +.. |type_0| replace:: `type`\ :math:`_{0}` +.. |type_1| replace:: `type`\ :math:`_{1}` +.. |type_2| replace:: `type`\ :math:`_{2}` +.. |type_3| replace:: `type`\ :math:`_{3}` +.. |type_n| replace:: `type`\ :math:`_{n}` +.. |x_1| replace:: `x`\ :math:`_{1}` +.. |x_i| replace:: `x`\ :math:`_{i}` +.. |x_n| replace:: `x`\ :math:`_{n}` +.. |Z| replace:: ``Z`` diff --git a/doc/sphinx/zebibliography.rst b/doc/sphinx/zebibliography.rst new file mode 100644 index 0000000000..0000caa301 --- /dev/null +++ b/doc/sphinx/zebibliography.rst @@ -0,0 +1,8 @@ +.. _bibliography: + +============ +Bibliography +============ + +.. bibliography:: biblio.bib + :cited: diff --git a/doc/tools/coqrst/coqdomain.py b/doc/tools/coqrst/coqdomain.py index 18f32d7a8a..663ab9d371 100644 --- a/doc/tools/coqrst/coqdomain.py +++ b/doc/tools/coqrst/coqdomain.py @@ -28,8 +28,10 @@ from docutils.parsers.rst.directives.admonitions import BaseAdmonition from sphinx import addnodes from sphinx.roles import XRefRole from sphinx.util.nodes import set_source_info, set_role_source_info, make_refnode +from sphinx.util.logging import getLogger from sphinx.directives import ObjectDescription from sphinx.domains import Domain, ObjType, Index +from sphinx.domains.std import token_xrefs from sphinx.ext.mathbase import MathDirective, displaymath from . import coqdoc @@ -155,6 +157,9 @@ class CoqObject(ObjectDescription): """Create a target and an index entry for name""" if name: target = self._add_target(signode, name) + # remove trailing . , found in commands, but not ... (ellipsis) + if name[-1] == "." and not name[-3:] == "..." : + name = name[0:-1] self._add_index_entry(name, target) return target @@ -173,19 +178,19 @@ class NotationObject(CoqObject): class TacticObject(PlainObject): """An object to represent Coq tactics""" subdomain = "tac" - index_suffix = "(tactic)" + index_suffix = "(tac)" annotation = None class GallinaObject(PlainObject): """An object to represent Coq theorems""" subdomain = "thm" - index_suffix = "(theorem)" + index_suffix = "(thm)" annotation = "Theorem" class VernacObject(NotationObject): """An object to represent Coq commands""" subdomain = "cmd" - index_suffix = "(command)" + index_suffix = "(cmd)" annotation = "Command" def _name_from_signature(self, signature): @@ -193,33 +198,72 @@ class VernacObject(NotationObject): class VernacVariantObject(VernacObject): """An object to represent variants of Coq commands""" - index_suffix = "(command variant)" + index_suffix = "(cmdv)" annotation = "Variant" class TacticNotationObject(NotationObject): """An object to represent Coq tactic notations""" subdomain = "tacn" - index_suffix = "(tactic notation)" + index_suffix = "(tacn)" annotation = None class TacticNotationVariantObject(TacticNotationObject): """An object to represent variants of Coq tactic notations""" - index_suffix = "(tactic variant)" + index_suffix = "(tacnv)" annotation = "Variant" class OptionObject(NotationObject): - """An object to represent variants of Coq options""" + """An object to represent Coq options""" subdomain = "opt" - index_suffix = "(option)" + index_suffix = "(opt)" annotation = "Option" def _name_from_signature(self, signature): return stringify_with_ellipses(signature) +class ProductionObject(NotationObject): + """An object to represent grammar productions""" + subdomain = "prodn" + index_suffix = None + annotation = None + + # override to create link targets for production left-hand sides + def run(self): + env = self.state.document.settings.env + objects = env.domaindata['std']['objects'] + + class ProdnError(Exception): + """Exception for ill-formed prodn""" + pass + + [idx, node] = super().run() + try: + # find LHS of production + inline_lhs = node[0][0][0][0] # may be fragile !!! + lhs_str = str(inline_lhs) + if lhs_str[0:7] != "<inline": + raise ProdnError("Expected atom on LHS") + lhs = inline_lhs[0] + # register link target + subnode = addnodes.production() + subnode['tokenname'] = lhs + idname = 'grammar-token-%s' % subnode['tokenname'] + if idname not in self.state.document.ids: + subnode['ids'].append(idname) + self.state.document.note_implicit_target(subnode, subnode) + objects['token', subnode['tokenname']] = env.docname, idname + subnode.extend(token_xrefs(lhs)) + # patch in link target + inline_lhs['ids'].append(idname) + except ProdnError as err: + getLogger(__name__).warning("Could not create link target for prodn: " + str(err) + + "\nSphinx represents the prodn as: " + str(node) + "\n") + return [idx, node] + class ExceptionObject(NotationObject): """An object to represent Coq errors.""" subdomain = "exn" - index_suffix = "(error)" + index_suffix = "(err)" annotation = "Error" # Uses “exn” since “err” already is a CSS class added by “writer_aux”. @@ -371,6 +415,7 @@ class InferenceDirective(Directive): required_arguments = 1 optional_arguments = 0 has_content = True + final_argument_whitespace = True def make_math_node(self, latex): node = displaymath() @@ -601,11 +646,13 @@ class CoqOptionIndex(CoqSubdomainsIndex): class CoqGallinaIndex(CoqSubdomainsIndex): name, localname, shortname, subdomains = "thmindex", "Gallina Index", "theorems", ["thm"] -class CoqExceptionIndex(CoqSubdomainsIndex): - name, localname, shortname, subdomains = "exnindex", "Error Index", "errors", ["exn"] +# we specify an index to make productions fit into the framework of notations +# but not likely to include a link to this index +class CoqProductionIndex(CoqSubdomainsIndex): + name, localname, shortname, subdomains = "prodnindex", "Production Index", "productions", ["prodn"] -class CoqWarningIndex(CoqSubdomainsIndex): - name, localname, shortname, subdomains = "warnindex", "Warning Index", "warnings", ["warn"] +class CoqExceptionIndex(CoqSubdomainsIndex): + name, localname, shortname, subdomains = "exnindex", "Errors and Warnings Index", "errors", ["exn", "warn"] class IndexXRefRole(XRefRole): """A link to one of our domain-specific indices.""" @@ -664,8 +711,9 @@ class CoqDomain(Domain): 'tacv': ObjType('tacv', 'tacn'), 'opt': ObjType('opt', 'opt'), 'thm': ObjType('thm', 'thm'), + 'prodn': ObjType('prodn', 'prodn'), 'exn': ObjType('exn', 'exn'), - 'warn': ObjType('warn', 'warn'), + 'warn': ObjType('warn', 'exn'), 'index': ObjType('index', 'index', searchprio=-1) } @@ -680,6 +728,7 @@ class CoqDomain(Domain): 'tacv': TacticNotationVariantObject, 'opt': OptionObject, 'thm': GallinaObject, + 'prodn' : ProductionObject, 'exn': ExceptionObject, 'warn': WarningObject, } @@ -691,6 +740,7 @@ class CoqDomain(Domain): 'tacn': XRefRole(), 'opt': XRefRole(), 'thm': XRefRole(), + 'prodn' : XRefRole(), 'exn': XRefRole(), 'warn': XRefRole(), # This one is special @@ -704,7 +754,7 @@ class CoqDomain(Domain): 'l': LtacRole, #FIXME unused? } - indices = [CoqVernacIndex, CoqTacticIndex, CoqOptionIndex, CoqGallinaIndex, CoqExceptionIndex, CoqWarningIndex] + indices = [CoqVernacIndex, CoqTacticIndex, CoqOptionIndex, CoqGallinaIndex, CoqProductionIndex, CoqExceptionIndex] data_version = 1 initial_data = { @@ -716,6 +766,7 @@ class CoqDomain(Domain): 'tacn': {}, 'opt': {}, 'thm': {}, + 'prodn' : {}, 'exn': {}, 'warn': {}, } @@ -807,6 +858,7 @@ def setup(app): app.connect('doctree-resolved', simplify_source_code_blocks_for_latex) # Add extra styles + app.add_stylesheet("fonts.css") app.add_stylesheet("ansi.css") app.add_stylesheet("coqdoc.css") app.add_javascript("notations.js") diff --git a/doc/tools/coqrst/notations/TacticNotations.g b/doc/tools/coqrst/notations/TacticNotations.g index 72ae8eb6be..5176c51d28 100644 --- a/doc/tools/coqrst/notations/TacticNotations.g +++ b/doc/tools/coqrst/notations/TacticNotations.g @@ -15,16 +15,18 @@ grammar TacticNotations; top: blocks EOF; blocks: block ((whitespace)? block)*; -block: atomic | hole | repeat | curlies; +block: atomic | meta | hole | repeat | curlies; repeat: LGROUP (ATOM)? WHITESPACE blocks (WHITESPACE)? RBRACE; curlies: LBRACE (whitespace)? blocks (whitespace)? RBRACE; whitespace: WHITESPACE; +meta: METACHAR; atomic: ATOM; hole: ID; LGROUP: '{' [+*?]; LBRACE: '{'; RBRACE: '}'; -ATOM: ~[@{} ]+; +METACHAR: '%' [|()]; +ATOM: '@' | ~[@{} ]+; ID: '@' [a-zA-Z0-9_]+; WHITESPACE: ' '+; diff --git a/doc/tools/coqrst/notations/TacticNotations.tokens b/doc/tools/coqrst/notations/TacticNotations.tokens index 4d41a38837..76ed2b065b 100644 --- a/doc/tools/coqrst/notations/TacticNotations.tokens +++ b/doc/tools/coqrst/notations/TacticNotations.tokens @@ -1,8 +1,9 @@ LGROUP=1 LBRACE=2 RBRACE=3 -ATOM=4 -ID=5 -WHITESPACE=6 +METACHAR=4 +ATOM=5 +ID=6 +WHITESPACE=7 '{'=2 '}'=3 diff --git a/doc/tools/coqrst/notations/TacticNotationsLexer.py b/doc/tools/coqrst/notations/TacticNotationsLexer.py index 4cac071ac3..ffa774b9ba 100644 --- a/doc/tools/coqrst/notations/TacticNotationsLexer.py +++ b/doc/tools/coqrst/notations/TacticNotationsLexer.py @@ -7,21 +7,24 @@ import sys def serializedATN(): with StringIO() as buf: - buf.write("\3\u608b\ua72a\u8133\ub9ed\u417c\u3be7\u7786\u5964\2\b") - buf.write("&\b\1\4\2\t\2\4\3\t\3\4\4\t\4\4\5\t\5\4\6\t\6\4\7\t\7") - buf.write("\3\2\3\2\3\2\3\3\3\3\3\4\3\4\3\5\6\5\30\n\5\r\5\16\5\31") - buf.write("\3\6\3\6\6\6\36\n\6\r\6\16\6\37\3\7\6\7#\n\7\r\7\16\7") - buf.write("$\2\2\b\3\3\5\4\7\5\t\6\13\7\r\b\3\2\5\4\2,-AA\6\2\"\"") - buf.write("BB}}\177\177\6\2\62;C\\aac|\2(\2\3\3\2\2\2\2\5\3\2\2\2") - buf.write("\2\7\3\2\2\2\2\t\3\2\2\2\2\13\3\2\2\2\2\r\3\2\2\2\3\17") - buf.write("\3\2\2\2\5\22\3\2\2\2\7\24\3\2\2\2\t\27\3\2\2\2\13\33") - buf.write("\3\2\2\2\r\"\3\2\2\2\17\20\7}\2\2\20\21\t\2\2\2\21\4\3") - buf.write("\2\2\2\22\23\7}\2\2\23\6\3\2\2\2\24\25\7\177\2\2\25\b") - buf.write("\3\2\2\2\26\30\n\3\2\2\27\26\3\2\2\2\30\31\3\2\2\2\31") - buf.write("\27\3\2\2\2\31\32\3\2\2\2\32\n\3\2\2\2\33\35\7B\2\2\34") - buf.write("\36\t\4\2\2\35\34\3\2\2\2\36\37\3\2\2\2\37\35\3\2\2\2") - buf.write("\37 \3\2\2\2 \f\3\2\2\2!#\7\"\2\2\"!\3\2\2\2#$\3\2\2\2") - buf.write("$\"\3\2\2\2$%\3\2\2\2%\16\3\2\2\2\6\2\31\37$\2") + buf.write("\3\u608b\ua72a\u8133\ub9ed\u417c\u3be7\u7786\u5964\2\t") + buf.write(".\b\1\4\2\t\2\4\3\t\3\4\4\t\4\4\5\t\5\4\6\t\6\4\7\t\7") + buf.write("\4\b\t\b\3\2\3\2\3\2\3\3\3\3\3\4\3\4\3\5\3\5\3\5\3\6\3") + buf.write("\6\6\6\36\n\6\r\6\16\6\37\5\6\"\n\6\3\7\3\7\6\7&\n\7\r") + buf.write("\7\16\7\'\3\b\6\b+\n\b\r\b\16\b,\2\2\t\3\3\5\4\7\5\t\6") + buf.write("\13\7\r\b\17\t\3\2\6\4\2,-AA\4\2*+~~\6\2\"\"BB}}\177\177") + buf.write("\6\2\62;C\\aac|\2\61\2\3\3\2\2\2\2\5\3\2\2\2\2\7\3\2\2") + buf.write("\2\2\t\3\2\2\2\2\13\3\2\2\2\2\r\3\2\2\2\2\17\3\2\2\2\3") + buf.write("\21\3\2\2\2\5\24\3\2\2\2\7\26\3\2\2\2\t\30\3\2\2\2\13") + buf.write("!\3\2\2\2\r#\3\2\2\2\17*\3\2\2\2\21\22\7}\2\2\22\23\t") + buf.write("\2\2\2\23\4\3\2\2\2\24\25\7}\2\2\25\6\3\2\2\2\26\27\7") + buf.write("\177\2\2\27\b\3\2\2\2\30\31\7\'\2\2\31\32\t\3\2\2\32\n") + buf.write("\3\2\2\2\33\"\7B\2\2\34\36\n\4\2\2\35\34\3\2\2\2\36\37") + buf.write("\3\2\2\2\37\35\3\2\2\2\37 \3\2\2\2 \"\3\2\2\2!\33\3\2") + buf.write("\2\2!\35\3\2\2\2\"\f\3\2\2\2#%\7B\2\2$&\t\5\2\2%$\3\2") + buf.write("\2\2&\'\3\2\2\2\'%\3\2\2\2\'(\3\2\2\2(\16\3\2\2\2)+\7") + buf.write("\"\2\2*)\3\2\2\2+,\3\2\2\2,*\3\2\2\2,-\3\2\2\2-\20\3\2") + buf.write("\2\2\7\2\37!\',\2") return buf.getvalue() @@ -34,9 +37,10 @@ class TacticNotationsLexer(Lexer): LGROUP = 1 LBRACE = 2 RBRACE = 3 - ATOM = 4 - ID = 5 - WHITESPACE = 6 + METACHAR = 4 + ATOM = 5 + ID = 6 + WHITESPACE = 7 channelNames = [ u"DEFAULT_TOKEN_CHANNEL", u"HIDDEN" ] @@ -46,9 +50,10 @@ class TacticNotationsLexer(Lexer): "'{'", "'}'" ] symbolicNames = [ "<INVALID>", - "LGROUP", "LBRACE", "RBRACE", "ATOM", "ID", "WHITESPACE" ] + "LGROUP", "LBRACE", "RBRACE", "METACHAR", "ATOM", "ID", "WHITESPACE" ] - ruleNames = [ "LGROUP", "LBRACE", "RBRACE", "ATOM", "ID", "WHITESPACE" ] + ruleNames = [ "LGROUP", "LBRACE", "RBRACE", "METACHAR", "ATOM", "ID", + "WHITESPACE" ] grammarFileName = "TacticNotations.g" diff --git a/doc/tools/coqrst/notations/TacticNotationsLexer.tokens b/doc/tools/coqrst/notations/TacticNotationsLexer.tokens index 4d41a38837..76ed2b065b 100644 --- a/doc/tools/coqrst/notations/TacticNotationsLexer.tokens +++ b/doc/tools/coqrst/notations/TacticNotationsLexer.tokens @@ -1,8 +1,9 @@ LGROUP=1 LBRACE=2 RBRACE=3 -ATOM=4 -ID=5 -WHITESPACE=6 +METACHAR=4 +ATOM=5 +ID=6 +WHITESPACE=7 '{'=2 '}'=3 diff --git a/doc/tools/coqrst/notations/TacticNotationsParser.py b/doc/tools/coqrst/notations/TacticNotationsParser.py index 357902ddb5..c7e28af52b 100644 --- a/doc/tools/coqrst/notations/TacticNotationsParser.py +++ b/doc/tools/coqrst/notations/TacticNotationsParser.py @@ -7,28 +7,29 @@ import sys def serializedATN(): with StringIO() as buf: - buf.write("\3\u608b\ua72a\u8133\ub9ed\u417c\u3be7\u7786\u5964\3\b") - buf.write("A\4\2\t\2\4\3\t\3\4\4\t\4\4\5\t\5\4\6\t\6\4\7\t\7\4\b") - buf.write("\t\b\4\t\t\t\3\2\3\2\3\2\3\3\3\3\5\3\30\n\3\3\3\7\3\33") - buf.write("\n\3\f\3\16\3\36\13\3\3\4\3\4\3\4\3\4\5\4$\n\4\3\5\3\5") - buf.write("\5\5(\n\5\3\5\3\5\3\5\5\5-\n\5\3\5\3\5\3\6\3\6\5\6\63") - buf.write("\n\6\3\6\3\6\5\6\67\n\6\3\6\3\6\3\7\3\7\3\b\3\b\3\t\3") - buf.write("\t\3\t\2\2\n\2\4\6\b\n\f\16\20\2\2\2A\2\22\3\2\2\2\4\25") - buf.write("\3\2\2\2\6#\3\2\2\2\b%\3\2\2\2\n\60\3\2\2\2\f:\3\2\2\2") - buf.write("\16<\3\2\2\2\20>\3\2\2\2\22\23\5\4\3\2\23\24\7\2\2\3\24") - buf.write("\3\3\2\2\2\25\34\5\6\4\2\26\30\5\f\7\2\27\26\3\2\2\2\27") - buf.write("\30\3\2\2\2\30\31\3\2\2\2\31\33\5\6\4\2\32\27\3\2\2\2") - buf.write("\33\36\3\2\2\2\34\32\3\2\2\2\34\35\3\2\2\2\35\5\3\2\2") - buf.write("\2\36\34\3\2\2\2\37$\5\16\b\2 $\5\20\t\2!$\5\b\5\2\"$") - buf.write("\5\n\6\2#\37\3\2\2\2# \3\2\2\2#!\3\2\2\2#\"\3\2\2\2$\7") - buf.write("\3\2\2\2%\'\7\3\2\2&(\7\6\2\2\'&\3\2\2\2\'(\3\2\2\2()") - buf.write("\3\2\2\2)*\7\b\2\2*,\5\4\3\2+-\7\b\2\2,+\3\2\2\2,-\3\2") - buf.write("\2\2-.\3\2\2\2./\7\5\2\2/\t\3\2\2\2\60\62\7\4\2\2\61\63") - buf.write("\5\f\7\2\62\61\3\2\2\2\62\63\3\2\2\2\63\64\3\2\2\2\64") - buf.write("\66\5\4\3\2\65\67\5\f\7\2\66\65\3\2\2\2\66\67\3\2\2\2") - buf.write("\678\3\2\2\289\7\5\2\29\13\3\2\2\2:;\7\b\2\2;\r\3\2\2") - buf.write("\2<=\7\6\2\2=\17\3\2\2\2>?\7\7\2\2?\21\3\2\2\2\t\27\34") - buf.write("#\',\62\66") + buf.write("\3\u608b\ua72a\u8133\ub9ed\u417c\u3be7\u7786\u5964\3\t") + buf.write("F\4\2\t\2\4\3\t\3\4\4\t\4\4\5\t\5\4\6\t\6\4\7\t\7\4\b") + buf.write("\t\b\4\t\t\t\4\n\t\n\3\2\3\2\3\2\3\3\3\3\5\3\32\n\3\3") + buf.write("\3\7\3\35\n\3\f\3\16\3 \13\3\3\4\3\4\3\4\3\4\3\4\5\4\'") + buf.write("\n\4\3\5\3\5\5\5+\n\5\3\5\3\5\3\5\5\5\60\n\5\3\5\3\5\3") + buf.write("\6\3\6\5\6\66\n\6\3\6\3\6\5\6:\n\6\3\6\3\6\3\7\3\7\3\b") + buf.write("\3\b\3\t\3\t\3\n\3\n\3\n\2\2\13\2\4\6\b\n\f\16\20\22\2") + buf.write("\2\2F\2\24\3\2\2\2\4\27\3\2\2\2\6&\3\2\2\2\b(\3\2\2\2") + buf.write("\n\63\3\2\2\2\f=\3\2\2\2\16?\3\2\2\2\20A\3\2\2\2\22C\3") + buf.write("\2\2\2\24\25\5\4\3\2\25\26\7\2\2\3\26\3\3\2\2\2\27\36") + buf.write("\5\6\4\2\30\32\5\f\7\2\31\30\3\2\2\2\31\32\3\2\2\2\32") + buf.write("\33\3\2\2\2\33\35\5\6\4\2\34\31\3\2\2\2\35 \3\2\2\2\36") + buf.write("\34\3\2\2\2\36\37\3\2\2\2\37\5\3\2\2\2 \36\3\2\2\2!\'") + buf.write("\5\20\t\2\"\'\5\16\b\2#\'\5\22\n\2$\'\5\b\5\2%\'\5\n\6") + buf.write("\2&!\3\2\2\2&\"\3\2\2\2&#\3\2\2\2&$\3\2\2\2&%\3\2\2\2") + buf.write("\'\7\3\2\2\2(*\7\3\2\2)+\7\7\2\2*)\3\2\2\2*+\3\2\2\2+") + buf.write(",\3\2\2\2,-\7\t\2\2-/\5\4\3\2.\60\7\t\2\2/.\3\2\2\2/\60") + buf.write("\3\2\2\2\60\61\3\2\2\2\61\62\7\5\2\2\62\t\3\2\2\2\63\65") + buf.write("\7\4\2\2\64\66\5\f\7\2\65\64\3\2\2\2\65\66\3\2\2\2\66") + buf.write("\67\3\2\2\2\679\5\4\3\28:\5\f\7\298\3\2\2\29:\3\2\2\2") + buf.write(":;\3\2\2\2;<\7\5\2\2<\13\3\2\2\2=>\7\t\2\2>\r\3\2\2\2") + buf.write("?@\7\6\2\2@\17\3\2\2\2AB\7\7\2\2B\21\3\2\2\2CD\7\b\2\2") + buf.write("D\23\3\2\2\2\t\31\36&*/\659") return buf.getvalue() @@ -44,8 +45,8 @@ class TacticNotationsParser ( Parser ): literalNames = [ "<INVALID>", "<INVALID>", "'{'", "'}'" ] - symbolicNames = [ "<INVALID>", "LGROUP", "LBRACE", "RBRACE", "ATOM", - "ID", "WHITESPACE" ] + symbolicNames = [ "<INVALID>", "LGROUP", "LBRACE", "RBRACE", "METACHAR", + "ATOM", "ID", "WHITESPACE" ] RULE_top = 0 RULE_blocks = 1 @@ -53,19 +54,21 @@ class TacticNotationsParser ( Parser ): RULE_repeat = 3 RULE_curlies = 4 RULE_whitespace = 5 - RULE_atomic = 6 - RULE_hole = 7 + RULE_meta = 6 + RULE_atomic = 7 + RULE_hole = 8 ruleNames = [ "top", "blocks", "block", "repeat", "curlies", "whitespace", - "atomic", "hole" ] + "meta", "atomic", "hole" ] EOF = Token.EOF LGROUP=1 LBRACE=2 RBRACE=3 - ATOM=4 - ID=5 - WHITESPACE=6 + METACHAR=4 + ATOM=5 + ID=6 + WHITESPACE=7 def __init__(self, input:TokenStream, output:TextIO = sys.stdout): super().__init__(input, output) @@ -106,9 +109,9 @@ class TacticNotationsParser ( Parser ): self.enterRule(localctx, 0, self.RULE_top) try: self.enterOuterAlt(localctx, 1) - self.state = 16 + self.state = 18 self.blocks() - self.state = 17 + self.state = 19 self.match(TacticNotationsParser.EOF) except RecognitionException as re: localctx.exception = re @@ -157,24 +160,24 @@ class TacticNotationsParser ( Parser ): self._la = 0 # Token type try: self.enterOuterAlt(localctx, 1) - self.state = 19 + self.state = 21 self.block() - self.state = 26 + self.state = 28 self._errHandler.sync(self) _alt = self._interp.adaptivePredict(self._input,1,self._ctx) while _alt!=2 and _alt!=ATN.INVALID_ALT_NUMBER: if _alt==1: - self.state = 21 + self.state = 23 self._errHandler.sync(self) _la = self._input.LA(1) if _la==TacticNotationsParser.WHITESPACE: - self.state = 20 + self.state = 22 self.whitespace() - self.state = 23 + self.state = 25 self.block() - self.state = 28 + self.state = 30 self._errHandler.sync(self) _alt = self._interp.adaptivePredict(self._input,1,self._ctx) @@ -196,6 +199,10 @@ class TacticNotationsParser ( Parser ): return self.getTypedRuleContext(TacticNotationsParser.AtomicContext,0) + def meta(self): + return self.getTypedRuleContext(TacticNotationsParser.MetaContext,0) + + def hole(self): return self.getTypedRuleContext(TacticNotationsParser.HoleContext,0) @@ -225,27 +232,32 @@ class TacticNotationsParser ( Parser ): localctx = TacticNotationsParser.BlockContext(self, self._ctx, self.state) self.enterRule(localctx, 4, self.RULE_block) try: - self.state = 33 + self.state = 36 self._errHandler.sync(self) token = self._input.LA(1) if token in [TacticNotationsParser.ATOM]: self.enterOuterAlt(localctx, 1) - self.state = 29 + self.state = 31 self.atomic() pass - elif token in [TacticNotationsParser.ID]: + elif token in [TacticNotationsParser.METACHAR]: self.enterOuterAlt(localctx, 2) - self.state = 30 + self.state = 32 + self.meta() + pass + elif token in [TacticNotationsParser.ID]: + self.enterOuterAlt(localctx, 3) + self.state = 33 self.hole() pass elif token in [TacticNotationsParser.LGROUP]: - self.enterOuterAlt(localctx, 3) - self.state = 31 + self.enterOuterAlt(localctx, 4) + self.state = 34 self.repeat() pass elif token in [TacticNotationsParser.LBRACE]: - self.enterOuterAlt(localctx, 4) - self.state = 32 + self.enterOuterAlt(localctx, 5) + self.state = 35 self.curlies() pass else: @@ -303,29 +315,29 @@ class TacticNotationsParser ( Parser ): self._la = 0 # Token type try: self.enterOuterAlt(localctx, 1) - self.state = 35 + self.state = 38 self.match(TacticNotationsParser.LGROUP) - self.state = 37 + self.state = 40 self._errHandler.sync(self) _la = self._input.LA(1) if _la==TacticNotationsParser.ATOM: - self.state = 36 + self.state = 39 self.match(TacticNotationsParser.ATOM) - self.state = 39 + self.state = 42 self.match(TacticNotationsParser.WHITESPACE) - self.state = 40 + self.state = 43 self.blocks() - self.state = 42 + self.state = 45 self._errHandler.sync(self) _la = self._input.LA(1) if _la==TacticNotationsParser.WHITESPACE: - self.state = 41 + self.state = 44 self.match(TacticNotationsParser.WHITESPACE) - self.state = 44 + self.state = 47 self.match(TacticNotationsParser.RBRACE) except RecognitionException as re: localctx.exception = re @@ -377,27 +389,27 @@ class TacticNotationsParser ( Parser ): self._la = 0 # Token type try: self.enterOuterAlt(localctx, 1) - self.state = 46 + self.state = 49 self.match(TacticNotationsParser.LBRACE) - self.state = 48 + self.state = 51 self._errHandler.sync(self) _la = self._input.LA(1) if _la==TacticNotationsParser.WHITESPACE: - self.state = 47 + self.state = 50 self.whitespace() - self.state = 50 + self.state = 53 self.blocks() - self.state = 52 + self.state = 55 self._errHandler.sync(self) _la = self._input.LA(1) if _la==TacticNotationsParser.WHITESPACE: - self.state = 51 + self.state = 54 self.whitespace() - self.state = 54 + self.state = 57 self.match(TacticNotationsParser.RBRACE) except RecognitionException as re: localctx.exception = re @@ -434,7 +446,7 @@ class TacticNotationsParser ( Parser ): self.enterRule(localctx, 10, self.RULE_whitespace) try: self.enterOuterAlt(localctx, 1) - self.state = 56 + self.state = 59 self.match(TacticNotationsParser.WHITESPACE) except RecognitionException as re: localctx.exception = re @@ -444,6 +456,43 @@ class TacticNotationsParser ( Parser ): self.exitRule() return localctx + class MetaContext(ParserRuleContext): + + def __init__(self, parser, parent:ParserRuleContext=None, invokingState:int=-1): + super().__init__(parent, invokingState) + self.parser = parser + + def METACHAR(self): + return self.getToken(TacticNotationsParser.METACHAR, 0) + + def getRuleIndex(self): + return TacticNotationsParser.RULE_meta + + def accept(self, visitor:ParseTreeVisitor): + if hasattr( visitor, "visitMeta" ): + return visitor.visitMeta(self) + else: + return visitor.visitChildren(self) + + + + + def meta(self): + + localctx = TacticNotationsParser.MetaContext(self, self._ctx, self.state) + self.enterRule(localctx, 12, self.RULE_meta) + try: + self.enterOuterAlt(localctx, 1) + self.state = 61 + self.match(TacticNotationsParser.METACHAR) + except RecognitionException as re: + localctx.exception = re + self._errHandler.reportError(self, re) + self._errHandler.recover(self, re) + finally: + self.exitRule() + return localctx + class AtomicContext(ParserRuleContext): def __init__(self, parser, parent:ParserRuleContext=None, invokingState:int=-1): @@ -468,10 +517,10 @@ class TacticNotationsParser ( Parser ): def atomic(self): localctx = TacticNotationsParser.AtomicContext(self, self._ctx, self.state) - self.enterRule(localctx, 12, self.RULE_atomic) + self.enterRule(localctx, 14, self.RULE_atomic) try: self.enterOuterAlt(localctx, 1) - self.state = 58 + self.state = 63 self.match(TacticNotationsParser.ATOM) except RecognitionException as re: localctx.exception = re @@ -505,10 +554,10 @@ class TacticNotationsParser ( Parser ): def hole(self): localctx = TacticNotationsParser.HoleContext(self, self._ctx, self.state) - self.enterRule(localctx, 14, self.RULE_hole) + self.enterRule(localctx, 16, self.RULE_hole) try: self.enterOuterAlt(localctx, 1) - self.state = 60 + self.state = 65 self.match(TacticNotationsParser.ID) except RecognitionException as re: localctx.exception = re diff --git a/doc/tools/coqrst/notations/TacticNotationsVisitor.py b/doc/tools/coqrst/notations/TacticNotationsVisitor.py index 80e69d4335..c0bcc4af37 100644 --- a/doc/tools/coqrst/notations/TacticNotationsVisitor.py +++ b/doc/tools/coqrst/notations/TacticNotationsVisitor.py @@ -39,6 +39,11 @@ class TacticNotationsVisitor(ParseTreeVisitor): return self.visitChildren(ctx) + # Visit a parse tree produced by TacticNotationsParser#meta. + def visitMeta(self, ctx:TacticNotationsParser.MetaContext): + return self.visitChildren(ctx) + + # Visit a parse tree produced by TacticNotationsParser#atomic. def visitAtomic(self, ctx:TacticNotationsParser.AtomicContext): return self.visitChildren(ctx) @@ -50,4 +55,4 @@ class TacticNotationsVisitor(ParseTreeVisitor): -del TacticNotationsParser
\ No newline at end of file +del TacticNotationsParser diff --git a/doc/tools/coqrst/notations/html.py b/doc/tools/coqrst/notations/html.py index d91bbb64c4..44212d7889 100644 --- a/doc/tools/coqrst/notations/html.py +++ b/doc/tools/coqrst/notations/html.py @@ -42,6 +42,9 @@ class TacticNotationsToHTMLVisitor(TacticNotationsVisitor): def visitHole(self, ctx:TacticNotationsParser.HoleContext): tags.span(ctx.ID().getText()[1:], _class="hole") + def visitMeta(self, ctx:TacticNotationsParser.MetaContext): + tags.span(ctx.METACHAR().getText()[1:], _class="meta") + def visitWhitespace(self, ctx:TacticNotationsParser.WhitespaceContext): tags.span(" ") # TODO: no need for a <span> here diff --git a/doc/tools/coqrst/notations/parsing.py b/doc/tools/coqrst/notations/parsing.py index 73be6f26ed..506240d907 100644 --- a/doc/tools/coqrst/notations/parsing.py +++ b/doc/tools/coqrst/notations/parsing.py @@ -12,7 +12,7 @@ from .TacticNotationsParser import TacticNotationsParser from antlr4 import CommonTokenStream, InputStream -SUBSTITUTIONS = [("@bindings_list", "{+ (@id := @val) }"), +SUBSTITUTIONS = [#("@bindings_list", "{+ (@id := @val) }"), ("@qualid_or_string", "@id|@string")] def substitute(notation): diff --git a/doc/tools/coqrst/notations/plain.py b/doc/tools/coqrst/notations/plain.py index 5d4501892f..f6e82fc68e 100644 --- a/doc/tools/coqrst/notations/plain.py +++ b/doc/tools/coqrst/notations/plain.py @@ -41,6 +41,9 @@ class TacticNotationsToDotsVisitor(TacticNotationsVisitor): def visitHole(self, ctx:TacticNotationsParser.HoleContext): self.buffer.write("‘{}’".format(ctx.ID().getText()[1:])) + def visitMeta(self, ctx:TacticNotationsParser.MetaContext): + self.buffer.write(ctx.METACHAR().getText()[1:]) + def visitWhitespace(self, ctx:TacticNotationsParser.WhitespaceContext): self.buffer.write(" ") diff --git a/doc/tools/coqrst/notations/regexp.py b/doc/tools/coqrst/notations/regexp.py index cac6aaecbb..ea820c719e 100644 --- a/doc/tools/coqrst/notations/regexp.py +++ b/doc/tools/coqrst/notations/regexp.py @@ -47,6 +47,9 @@ class TacticNotationsToRegexpVisitor(TacticNotationsVisitor): def visitHole(self, ctx:TacticNotationsParser.HoleContext): self.buffer.write("([^();. \n]+)") # FIXME could allow more things + def visitMeta(self, ctx:TacticNotationsParser.MetaContext): + self.buffer.write(re.escape(ctx.METACHAR().getText()[1:])) + def visitWhitespace(self, ctx:TacticNotationsParser.WhitespaceContext): self.buffer.write(r"\s+") diff --git a/doc/tools/coqrst/notations/sphinx.py b/doc/tools/coqrst/notations/sphinx.py index 889bf70a46..26a5f69680 100644 --- a/doc/tools/coqrst/notations/sphinx.py +++ b/doc/tools/coqrst/notations/sphinx.py @@ -20,6 +20,8 @@ from .TacticNotationsVisitor import TacticNotationsVisitor from docutils import nodes from sphinx import addnodes +import sys + class TacticNotationsToSphinxVisitor(TacticNotationsVisitor): def defaultResult(self): return [] @@ -62,6 +64,12 @@ class TacticNotationsToSphinxVisitor(TacticNotationsVisitor): node = nodes.inline(hole, token_name, classes=["hole"]) return [addnodes.pending_xref(token_name, node, reftype='token', refdomain='std', reftarget=token_name)] + def visitMeta(self, ctx:TacticNotationsParser.MetaContext): + meta = ctx.METACHAR().getText() + metachar = meta[1:] # remove escape char + token_name = metachar + return [nodes.inline(metachar, token_name, classes=["meta"])] + def visitWhitespace(self, ctx:TacticNotationsParser.WhitespaceContext): return [nodes.Text(" ")] diff --git a/engine/uState.ml b/engine/uState.ml index 1dd8acd0db..6c8dbe3f44 100644 --- a/engine/uState.ml +++ b/engine/uState.ml @@ -296,7 +296,7 @@ let constrain_variables diff ctx = let reference_of_level uctx = let map, map_rev = uctx.uctx_names in fun l -> - try Libnames.Ident (Loc.tag @@ Option.get (Univ.LMap.find l map_rev).uname) + try CAst.make @@ Libnames.Ident (Option.get (Univ.LMap.find l map_rev).uname) with Not_found | Option.IsNone -> Universes.reference_of_level l diff --git a/engine/universes.ml b/engine/universes.ml index ddc9beff49..e5f9212a71 100644 --- a/engine/universes.ml +++ b/engine/universes.ml @@ -21,7 +21,7 @@ open Nametab module UPairs = OrderedType.UnorderedPair(Univ.Level) module UPairSet = Set.Make (UPairs) -let reference_of_level l = +let reference_of_level l = CAst.make @@ match Level.name l with | Some (d, n as na) -> let qid = @@ -29,8 +29,8 @@ let reference_of_level l = with Not_found -> let name = Id.of_string_soft (string_of_int n) in Libnames.make_qualid d name - in Libnames.Qualid (Loc.tag @@ qid) - | None -> Libnames.Ident (Loc.tag @@ Id.of_string_soft (Level.to_string l)) + in Libnames.Qualid qid + | None -> Libnames.Ident Id.(of_string_soft (Level.to_string l)) let pr_with_global_universes l = Libnames.pr_reference (reference_of_level l) diff --git a/ide/ide_slave.ml b/ide/ide_slave.ml index 55b4fa87e6..6b7efc839e 100644 --- a/ide/ide_slave.ml +++ b/ide/ide_slave.ml @@ -63,7 +63,7 @@ let is_known_option cmd = match Vernacprop.under_control cmd with (** Check whether a command is forbidden in the IDE *) -let ide_cmd_checks ~id (loc,ast) = +let ide_cmd_checks ~id {CAst.loc;v=ast} = let user_error s = CErrors.user_err ?loc ~hdr:"IDE" (str s) in let warn msg = Feedback.(feedback ~id (Message (Warning, loc, strbrk msg))) in if is_debug ast then @@ -120,7 +120,7 @@ let query (route, (s,id)) = let annotate phrase = let doc = get_doc () in - let (loc, ast) = + let {CAst.loc;v=ast} = let pa = Pcoq.Gram.parsable (Stream.of_string phrase) in Stm.parse_sentence ~doc (Stm.get_current_state ~doc) pa in @@ -289,7 +289,7 @@ let pattern_of_string ?env s = let dirpath_of_string_list s = let path = String.concat "." s in let m = Pcoq.parse_string Pcoq.Constr.global path in - let (_, qid) = Libnames.qualid_of_reference m in + let {CAst.v=qid} = Libnames.qualid_of_reference m in let id = try Nametab.full_name_module qid with Not_found -> diff --git a/interp/constrexpr_ops.ml b/interp/constrexpr_ops.ml index 8bf530e7f3..4ee13c961f 100644 --- a/interp/constrexpr_ops.ml +++ b/interp/constrexpr_ops.ml @@ -10,6 +10,7 @@ open Pp open Util +open CAst open Names open Nameops open Libnames @@ -278,7 +279,7 @@ let rec cases_pattern_fold_names f a pt = match CAst.(pt.v) with List.fold_left (cases_pattern_fold_names f) (List.fold_left (cases_pattern_fold_names f) a (patl@List.flatten patll)) patl' | CPatDelimiters (_,pat) -> cases_pattern_fold_names f a pat - | CPatAtom (Some (Ident (_,id))) when not (is_constructor id) -> f id a + | CPatAtom (Some {v=Ident id}) when not (is_constructor id) -> f id a | CPatPrim _ | CPatAtom _ -> a | CPatCast ({CAst.loc},_) -> CErrors.user_err ?loc ~hdr:"cases_pattern_fold_names" @@ -361,7 +362,7 @@ let fold_constr_expr_with_binders g f n acc = CAst.with_val (function let free_vars_of_constr_expr c = let rec aux bdvars l = function - | { CAst.v = CRef (Ident (_,id),_) } -> if Id.List.mem id bdvars then l else Id.Set.add id l + | { CAst.v = CRef ({v=Ident id},_) } -> if Id.List.mem id bdvars then l else Id.Set.add id l | c -> fold_constr_expr_with_binders (fun a l -> a::l) aux bdvars l c in aux [] Id.Set.empty c @@ -439,8 +440,8 @@ let map_constr_expr_with_binders g f e = CAst.map (function (* Used in constrintern *) let rec replace_vars_constr_expr l = function - | { CAst.loc; v = CRef (Ident (loc_id,id),us) } as x -> - (try CAst.make ?loc @@ CRef (Ident (loc_id,Id.Map.find id l),us) with Not_found -> x) + | { CAst.loc; v = CRef ({v=Ident id},us) } as x -> + (try CAst.make ?loc @@ CRef (make ?loc @@ Ident (Id.Map.find id l),us) with Not_found -> x) | c -> map_constr_expr_with_binders Id.Map.remove replace_vars_constr_expr l c @@ -511,7 +512,7 @@ let split_at_annot bl na = (** Pseudo-constructors *) -let mkIdentC id = CAst.make @@ CRef (Ident (Loc.tag id),None) +let mkIdentC id = CAst.make @@ CRef (make @@ Ident id,None) let mkRefC r = CAst.make @@ CRef (r,None) let mkCastC (a,k) = CAst.make @@ CCast (a,k) let mkLambdaC (idl,bk,a,b) = CAst.make @@ CLambdaN ([CLocalAssum (idl,bk,a)],b) @@ -530,21 +531,21 @@ let mkCProdN ?loc bll c = let mkCLambdaN ?loc bll c = CAst.make ?loc @@ CLambdaN (bll,c) -let coerce_reference_to_id = function - | Ident (_,id) -> id - | Qualid (loc,_) -> +let coerce_reference_to_id = CAst.with_loc_val (fun ?loc -> function + | Ident id -> id + | Qualid _ -> CErrors.user_err ?loc ~hdr:"coerce_reference_to_id" - (str "This expression should be a simple identifier.") + (str "This expression should be a simple identifier.")) let coerce_to_id = function - | { CAst.v = CRef (Ident (loc,id),None) } -> CAst.make ?loc id + | { CAst.loc; v = CRef ({v=Ident id},None) } -> CAst.make ?loc id | { CAst.loc; _ } -> CErrors.user_err ?loc ~hdr:"coerce_to_id" (str "This expression should be a simple identifier.") let coerce_to_name = function - | { CAst.v = CRef (Ident (loc,id),None) } -> CAst.make ?loc @@ Name id - | { CAst.loc; CAst.v = CHole (None,Misctypes.IntroAnonymous,None) } -> CAst.make ?loc Anonymous + | { CAst.loc; v = CRef ({v=Ident id},None) } -> CAst.make ?loc @@ Name id + | { CAst.loc; v = CHole (None,Misctypes.IntroAnonymous,None) } -> CAst.make ?loc Anonymous | { CAst.loc; _ } -> CErrors.user_err ?loc ~hdr:"coerce_to_name" (str "This expression should be a name.") @@ -570,7 +571,7 @@ let rec coerce_to_cases_pattern_expr c = CAst.map_with_loc (fun ?loc -> function CPatAtom (Some r) | CHole (None,Misctypes.IntroAnonymous,None) -> CPatAtom None - | CLetIn ({CAst.loc;v=Name id},b,None,{ CAst.v = CRef (Ident (_,id'),None) }) when Id.equal id id' -> + | CLetIn ({CAst.loc;v=Name id},b,None,{ CAst.v = CRef ({v=Ident id'},None) }) when Id.equal id id' -> CPatAlias (coerce_to_cases_pattern_expr b, CAst.(make ?loc @@ Name id)) | CApp ((None,p),args) when List.for_all (fun (_,e) -> e=None) args -> (mkAppPattern (coerce_to_cases_pattern_expr p) (List.map (fun (a,_) -> coerce_to_cases_pattern_expr a) args)).CAst.v diff --git a/interp/constrextern.ml b/interp/constrextern.ml index 9efaff3b9f..19444988b9 100644 --- a/interp/constrextern.ml +++ b/interp/constrextern.ml @@ -215,7 +215,7 @@ let is_record indsp = let encode_record r = let indsp = global_inductive r in if not (is_record indsp) then - user_err ?loc:(loc_of_reference r) ~hdr:"encode_record" + user_err ?loc:r.CAst.loc ~hdr:"encode_record" (str "This type is not a structure type."); indsp @@ -271,14 +271,14 @@ let extern_evar n l = CEvar (n,l) may be inaccurate *) let default_extern_reference ?loc vars r = - Qualid (Loc.tag ?loc @@ shortest_qualid_of_global vars r) + make @@ Qualid (shortest_qualid_of_global vars r) let my_extern_reference = ref default_extern_reference let set_extern_reference f = my_extern_reference := f let get_extern_reference () = !my_extern_reference -let extern_reference ?loc vars l = !my_extern_reference ?loc vars l +let extern_reference ?loc vars l = !my_extern_reference vars l (**********************************************************************) (* mapping patterns to cases_pattern_expr *) @@ -389,7 +389,7 @@ let rec extern_cases_pattern_in_scope (scopes:local_scopes) vars pat = (uninterp_cases_pattern_notations pat) with No_match -> lift (fun ?loc -> function - | PatVar (Name id) -> CPatAtom (Some (Ident (loc,id))) + | PatVar (Name id) -> CPatAtom (Some (make ?loc @@ Ident id)) | PatVar (Anonymous) -> CPatAtom None | PatCstr(cstrsp,args,na) -> let args = List.map (extern_cases_pattern_in_scope scopes vars) args in @@ -407,7 +407,7 @@ let rec extern_cases_pattern_in_scope (scopes:local_scopes) vars pat = (* we don't want to have 'x := _' in our patterns *) acc | Some c, _ -> - ((extern_reference ?loc Id.Set.empty (ConstRef c), pat) :: acc) + ((extern_reference ?loc Id.Set.empty (ConstRef c), pat) :: acc) | _ -> raise No_match in ip q tail acc | _ -> assert false @@ -415,7 +415,7 @@ let rec extern_cases_pattern_in_scope (scopes:local_scopes) vars pat = CPatRecord(List.rev (ip projs args [])) with Not_found | No_match | Exit -> - let c = extern_reference ?loc Id.Set.empty (ConstructRef cstrsp) in + let c = extern_reference Id.Set.empty (ConstructRef cstrsp) in if !asymmetric_patterns then if pattern_printable_in_both_syntax cstrsp then CPatCstr (c, None, args) @@ -458,7 +458,7 @@ and apply_notation_to_pattern ?loc gr ((subst,substlist),(nb_to_drop,more_args)) (make_pat_notation ?loc ntn (l,ll) l2') key end | SynDefRule kn -> - let qid = Qualid (Loc.tag ?loc @@ shortest_qualid_of_syndef vars kn) in + let qid = make ?loc @@ Qualid (shortest_qualid_of_syndef vars kn) in let l1 = List.rev_map (fun (c,(scopt,scl)) -> extern_cases_pattern_in_scope (scopt,scl@scopes) vars c) @@ -484,7 +484,7 @@ and extern_notation_pattern (tmp_scope,scopes as allscopes) vars t = function (match_notation_constr_cases_pattern t pat) allscopes vars keyrule in insert_pat_alias ?loc p na | PatVar Anonymous -> CAst.make ?loc @@ CPatAtom None - | PatVar (Name id) -> CAst.make ?loc @@ CPatAtom (Some (Ident (loc,id))) + | PatVar (Name id) -> CAst.make ?loc @@ CPatAtom (Some (make ?loc @@ Ident id)) with No_match -> extern_notation_pattern allscopes vars t rules @@ -745,9 +745,9 @@ let rec extern inctx scopes vars r = with No_match -> lift (fun ?loc -> function | GRef (ref,us) -> extern_global (select_stronger_impargs (implicits_of_global ref)) - (extern_reference ?loc vars ref) (extern_universes us) + (extern_reference vars ref) (extern_universes us) - | GVar id -> CRef (Ident (loc,id),None) + | GVar id -> CRef (make ?loc @@ Ident id,None) | GEvar (n,[]) when !print_meta_as_hole -> CHole (None, Misctypes.IntroAnonymous, None) @@ -763,7 +763,6 @@ let rec extern inctx scopes vars r = | GApp (f,args) -> (match DAst.get f with | GRef (ref,us) -> - let rloc = f.CAst.loc in let subscopes = find_arguments_scope ref in let args = fill_arg_scopes args subscopes (snd scopes) in begin @@ -802,7 +801,7 @@ let rec extern inctx scopes vars r = (* we give up since the constructor is not complete *) | (arg, scopes) :: tail -> let head = extern true scopes vars arg in - ip q locs' tail ((extern_reference ?loc Id.Set.empty (ConstRef c), head) :: acc) + ip q locs' tail ((extern_reference ?loc Id.Set.empty (ConstRef c), head) :: acc) in CRecord (List.rev (ip projs locals args [])) with @@ -810,7 +809,7 @@ let rec extern inctx scopes vars r = let args = extern_args (extern true) vars args in extern_app inctx (select_stronger_impargs (implicits_of_global ref)) - (Some ref,extern_reference ?loc:rloc vars ref) (extern_universes us) args + (Some ref,extern_reference ?loc vars ref) (extern_universes us) args end | _ -> @@ -850,7 +849,7 @@ let rec extern inctx scopes vars r = | Name _, _ -> Some (CAst.make na) in (sub_extern false scopes vars tm, na', - Option.map (fun (loc,(ind,nal)) -> + Option.map (fun {CAst.loc;v=(ind,nal)} -> let args = List.map (fun x -> DAst.make @@ PatVar x) nal in let fullargs = add_cpatt_for_params ind args in extern_ind_pattern_in_scope scopes vars ind fullargs @@ -929,7 +928,7 @@ and factorize_prod scopes vars na bk aty c = | Name id, GCases (LetPatternStyle, None, [(e,(Anonymous,None))],(_::_ as eqns)) when is_gvar id e && List.length (store (factorize_eqns eqns)) = 1 -> (match get () with - | [(_,(ids,disj_of_patl,b))] -> + | [{CAst.v=(ids,disj_of_patl,b)}] -> let disjpat = List.map (function [pat] -> pat | _ -> assert false) disj_of_patl in let disjpat = if occur_glob_constr id b then List.map (set_pat_alias id) disjpat else disjpat in let b = extern_typ scopes vars b in @@ -957,7 +956,7 @@ and factorize_lambda inctx scopes vars na bk aty c = | Name id, GCases (LetPatternStyle, None, [(e,(Anonymous,None))],(_::_ as eqns)) when is_gvar id e && List.length (store (factorize_eqns eqns)) = 1 -> (match get () with - | [(_,(ids,disj_of_patl,b))] -> + | [{CAst.v=(ids,disj_of_patl,b)}] -> let disjpat = List.map (function [pat] -> pat | _ -> assert false) disj_of_patl in let disjpat = if occur_glob_constr id b then List.map (set_pat_alias id) disjpat else disjpat in let b = sub_extern inctx scopes vars b in @@ -1010,7 +1009,7 @@ and extern_local_binder scopes vars = function let (assums,ids,l) = extern_local_binder scopes vars l in (assums,ids, CLocalPattern(CAst.make @@ (p,ty)) :: l) -and extern_eqn inctx scopes vars (loc,(ids,pll,c)) = +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) @@ -1090,7 +1089,7 @@ and extern_notation (tmp_scope,scopes as allscopes) vars t = function List.map (fun (c,(scopt,scl)) -> extern true (scopt,scl@scopes) vars c, None) terms in - let a = CRef (Qualid (loc, shortest_qualid_of_syndef vars kn),None) in + let a = CRef (make ?loc @@ Qualid (shortest_qualid_of_syndef 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 @@ -1155,7 +1154,7 @@ let extern_closed_glob ?lax goal_concl_style env sigma t = let any_any_branch = (* | _ => _ *) - Loc.tag ([],[DAst.make @@ PatVar Anonymous], DAst.make @@ GHole (Evar_kinds.InternalHole,Misctypes.IntroAnonymous,None)) + CAst.make ([],[DAst.make @@ PatVar Anonymous], DAst.make @@ GHole (Evar_kinds.InternalHole,Misctypes.IntroAnonymous,None)) let compute_displayed_name_in_pattern sigma avoid na c = let open Namegen in diff --git a/interp/constrintern.ml b/interp/constrintern.ml index 918e12e5cb..f2cd07c94e 100644 --- a/interp/constrintern.ml +++ b/interp/constrintern.ml @@ -96,7 +96,7 @@ let is_global id = false let global_reference_of_reference ref = - locate_reference (snd (qualid_of_reference ref)) + locate_reference (qualid_of_reference ref).CAst.v let global_reference id = locate_reference (qualid_of_ident id) @@ -403,7 +403,7 @@ let intern_generalized_binder ?(global_level=false) intern_type ntnvars let name = let id = match ty with - | { CAst.v = CApp ((_, { CAst.v = CRef (Ident (loc,id),_) } ), _) } -> id + | { v = CApp ((_, { v = CRef ({v=Ident id},_) } ), _) } -> id | _ -> default_non_dependent_ident in Implicit_quantifiers.make_fresh ids' (Global.env ()) id in Name name @@ -524,7 +524,7 @@ let rec expand_binders ?loc mk bl c = | GLocalPattern ((disjpat,ids), id, bk, ty) -> let tm = DAst.make ?loc (GVar id) in (* Distribute the disjunctive patterns over the shared right-hand side *) - let eqnl = List.map (fun pat -> (loc,(ids,[pat],c))) disjpat in + let eqnl = List.map (fun pat -> CAst.make ?loc (ids,[pat],c)) disjpat in let c = DAst.make ?loc @@ GCases (Misctypes.LetPatternStyle, None, [tm,(Anonymous,None)], eqnl) in expand_binders ?loc mk bl (mk ?loc (Name id,Explicit,ty) c) @@ -554,8 +554,8 @@ let is_var store pat = | _ -> false let out_var pat = - match pat.CAst.v with - | CPatAtom (Some (Ident (_,id))) -> Name id + match pat.v with + | CPatAtom (Some ({v=Ident id})) -> Name id | CPatAtom None -> Anonymous | _ -> assert false @@ -621,18 +621,18 @@ let error_cannot_coerce_disjunctive_pattern_term ?loc () = let terms_of_binders bl = let rec term_of_pat pt = dmap_with_loc (fun ?loc -> function - | PatVar (Name id) -> CRef (Ident (loc,id), None) + | PatVar (Name id) -> CRef (make @@ Ident id, None) | PatVar (Anonymous) -> error_cannot_coerce_wildcard_term ?loc () | PatCstr (c,l,_) -> - let r = Qualid (loc,qualid_of_path (path_of_global (ConstructRef c))) in + let r = make ?loc @@ Qualid (qualid_of_path (path_of_global (ConstructRef c))) in let hole = CAst.make ?loc @@ CHole (None,Misctypes.IntroAnonymous,None) in let params = List.make (Inductiveops.inductive_nparams (fst c)) hole in CAppExpl ((None,r,None),params @ List.map term_of_pat l)) pt in let rec extract_variables l = match l with | bnd :: l -> - let loc = bnd.CAst.loc in + let loc = bnd.loc in begin match DAst.get bnd with - | GLocalAssum (Name id,_,_) -> (CAst.make ?loc @@ CRef (Ident (loc,id), None)) :: extract_variables l + | GLocalAssum (Name id,_,_) -> (CAst.make ?loc @@ CRef (make ?loc @@ Ident id, None)) :: extract_variables l | GLocalDef (Name id,_,_,_) -> extract_variables l | GLocalDef (Anonymous,_,_,_) | GLocalAssum (Anonymous,_,_) -> user_err Pp.(str "Cannot turn \"_\" into a term.") @@ -720,7 +720,7 @@ let instantiate_notation_constr loc intern intern_pat ntnvars subst infos c = let _,((disjpat,_),_),_ = intern_pat ntnvars nenv c in match disjpat with | [pat] -> (glob_constr_of_cases_pattern pat, None) - | _ -> error_cannot_coerce_disjunctive_pattern_term ?loc:c.CAst.loc () + | _ -> error_cannot_coerce_disjunctive_pattern_term ?loc:c.loc () in let terms = Id.Map.map mk_env terms in let binders = Id.Map.map mk_env' binders in @@ -805,7 +805,7 @@ let instantiate_notation_constr loc intern intern_pat ntnvars subst infos c = distinction *) let cases_pattern_of_name {loc;v=na} = - let atom = match na with Name id -> Some (Ident (loc,id)) | Anonymous -> None in + let atom = match na with Name id -> Some (make ?loc @@ Ident id) | Anonymous -> None in CAst.make ?loc (CPatAtom atom) let split_by_type ids subst = @@ -902,7 +902,7 @@ let intern_var env (ltacvars,ntnvars) namedctx loc id us = try let ty,expl_impls,impls,argsc = Id.Map.find id env.impls in let expl_impls = List.map - (fun id -> CAst.make ?loc @@ CRef (Ident (loc,id),None), Some (make ?loc @@ ExplByName id)) expl_impls in + (fun id -> CAst.make ?loc @@ CRef (make ?loc @@ Ident id,None), Some (make ?loc @@ ExplByName id)) expl_impls in let tys = string_of_ty ty in Dumpglob.dump_reference ?loc "<>" (Id.to_string id) tys; gvar (loc,id) us, make_implicits_list impls, argsc, expl_impls @@ -969,14 +969,14 @@ let dump_extended_global loc = function | TrueGlobal ref -> (*feedback_global loc ref;*) Dumpglob.add_glob ?loc ref | SynDef sp -> Dumpglob.add_glob_kn ?loc sp -let intern_extended_global_of_qualid (loc,qid) = +let intern_extended_global_of_qualid {loc;v=qid} = let r = Nametab.locate_extended qid in dump_extended_global loc r; r let intern_reference ref = let qid = qualid_of_reference ref in let r = try intern_extended_global_of_qualid qid - with Not_found -> error_global_not_found ?loc:(fst qid) (snd qid) + with Not_found -> error_global_not_found qid in Smartlocate.global_of_extended_global r @@ -993,8 +993,9 @@ let glob_sort_of_level (level: Misctypes.glob_level) : Misctypes.glob_sort = | Misctypes.GType info -> Misctypes.GType [sort_info_of_level_info info] (* Is it a global reference or a syntactic definition? *) -let intern_qualid loc qid intern env ntnvars us args = - match intern_extended_global_of_qualid (loc,qid) with +let intern_qualid qid intern env ntnvars us args = + let loc = qid.loc in + match intern_extended_global_of_qualid qid with | TrueGlobal ref -> (DAst.make ?loc @@ GRef (ref, us)), true, args | SynDef sp -> let (ids,c) = Syntax_def.search_syntactic_definition sp in @@ -1007,9 +1008,9 @@ let intern_qualid loc qid intern env ntnvars us args = let infos = (Id.Map.empty, env) in let projapp = match c with NRef _ -> true | _ -> false in let c = instantiate_notation_constr loc intern intern_cases_pattern_as_binder ntnvars subst infos c in - let loc = c.CAst.loc in + let loc = c.loc in let err () = - user_err ?loc (str "Notation " ++ pr_qualid qid + user_err ?loc (str "Notation " ++ pr_qualid qid.v ++ str " cannot have a universe instance," ++ str " its expanded head does not start with a reference") in @@ -1026,40 +1027,41 @@ let intern_qualid loc qid intern env ntnvars us args = | Some [s], GSort (Misctypes.GType []) -> DAst.make ?loc @@ GSort (glob_sort_of_level s) | Some [_old_level], GSort _new_sort -> (* TODO: add old_level and new_sort to the error message *) - user_err ?loc (str "Cannot change universe level of notation " ++ pr_qualid qid) + user_err ?loc (str "Cannot change universe level of notation " ++ pr_qualid qid.v) | Some _, _ -> err () in c, projapp, args2 (* Rule out section vars since these should have been found by intern_var *) -let intern_non_secvar_qualid loc qid intern env ntnvars us args = - let c, _, _ as r = intern_qualid loc qid intern env ntnvars us args in +let intern_non_secvar_qualid qid intern env ntnvars us args = + let c, _, _ as r = intern_qualid qid intern env ntnvars us args in match DAst.get c with | GRef (VarRef _, _) -> raise Not_found | _ -> r let intern_applied_reference intern env namedctx (_, ntnvars as lvar) us args = function - | Qualid (loc, qid) -> + | {loc; v=Qualid qid} -> + let qid = make ?loc qid in let r,projapp,args2 = - try intern_qualid loc qid intern env ntnvars us args - with Not_found -> error_global_not_found ?loc qid + try intern_qualid qid intern env ntnvars us args + with Not_found -> error_global_not_found qid in let x, imp, scopes, l = find_appl_head_data r in (x,imp,scopes,l), args2 - | Ident (loc, id) -> + | {loc; v=Ident id} -> try intern_var env lvar namedctx loc id us, args with Not_found -> - let qid = qualid_of_ident id in + let qid = make ?loc @@ qualid_of_ident id in try - let r, projapp, args2 = intern_non_secvar_qualid loc qid intern env ntnvars us args in + let r, projapp, args2 = intern_non_secvar_qualid qid intern env ntnvars us args in let x, imp, scopes, l = find_appl_head_data r in (x,imp,scopes,l), args2 with Not_found -> (* Extra allowance for non globalizing functions *) if !interning_grammar || env.unb then (gvar (loc,id) us, [], [], []), args - else error_global_not_found ?loc qid + else error_global_not_found qid let interp_reference vars r = let (r,_,_,_),_ = @@ -1255,8 +1257,8 @@ let find_constructor loc add_params ref = | None -> [] let find_pattern_variable = function - | Ident (loc,id) -> id - | Qualid (loc,_) as x -> raise (InternalizationError(loc,NotAConstructor x)) + | {v=Ident id} -> id + | {loc;v=Qualid _} as x -> raise (InternalizationError(loc,NotAConstructor x)) let check_duplicate loc fields = let eq (ref1, _) (ref2, _) = eq_reference ref1 ref2 in @@ -1289,7 +1291,7 @@ let sort_fields ~complete loc fields completer = let gr = global_reference_of_reference first_field_ref in (gr, Recordops.find_projection gr) with Not_found -> - user_err ?loc:(loc_of_reference first_field_ref) ~hdr:"intern" + user_err ?loc ~hdr:"intern" (pr_reference first_field_ref ++ str": Not a projection") in (* the number of parameters *) @@ -1297,7 +1299,7 @@ let sort_fields ~complete loc fields completer = (* the reference constructor of the record *) let base_constructor = let global_record_id = ConstructRef record.Recordops.s_CONST in - try Qualid (loc, shortest_qualid_of_global Id.Set.empty global_record_id) + try make ?loc @@ Qualid (shortest_qualid_of_global Id.Set.empty global_record_id) with Not_found -> anomaly (str "Environment corruption for records.") in let () = check_duplicate loc fields in @@ -1347,7 +1349,7 @@ let sort_fields ~complete loc fields completer = | (field_ref, field_value) :: fields -> let field_glob_ref = try global_reference_of_reference field_ref with Not_found -> - user_err ?loc:(loc_of_reference field_ref) ~hdr:"intern" + user_err ?loc ~hdr:"intern" (str "The field \"" ++ pr_reference field_ref ++ str "\" does not exist.") in let remaining_projs, (field_index, _) = let the_proj (idx, glob_id) = eq_gr field_glob_ref (ConstRef glob_id) in @@ -1476,9 +1478,9 @@ let drop_notations_pattern looked_for genv = | _ -> CErrors.anomaly Pp.(str "Invalid return pattern from Notation.interp_prim_token_cases_pattern_expr."))) x in let rec drop_syndef top scopes re pats = - let (loc,qid) = qualid_of_reference re in + let qid = qualid_of_reference re in try - match locate_extended qid with + match locate_extended qid.v with | SynDef sp -> let (vars,a) = Syntax_def.search_syntactic_definition sp in (match a with @@ -1496,16 +1498,16 @@ let drop_notations_pattern looked_for genv = (* Convention: do not deactivate implicit arguments and scopes for further arguments *) test_kind top g; let nvars = List.length vars in - if List.length pats < nvars then error_not_enough_arguments ?loc; + if List.length pats < nvars then error_not_enough_arguments ?loc:qid.loc; let pats1,pats2 = List.chop nvars pats in let subst = make_subst vars pats1 in - let idspl1 = List.map (in_not false loc scopes (subst, Id.Map.empty) []) args in + let idspl1 = List.map (in_not false qid.loc scopes (subst, Id.Map.empty) []) args in let (_,argscs) = find_remaining_scopes pats1 pats2 g in Some (g, idspl1, List.map2 (in_pat_sc scopes) argscs pats2) | _ -> raise Not_found) | TrueGlobal g -> test_kind top g; - Dumpglob.add_glob ?loc g; + Dumpglob.add_glob ?loc:qid.loc g; let (_,argscs) = find_remaining_scopes [] pats g in Some (g,[],List.map2 (fun x -> in_pat false (x,snd scopes)) argscs pats) with Not_found -> None @@ -1535,7 +1537,7 @@ let drop_notations_pattern looked_for genv = | None -> raise (InternalizationError (loc,NotAConstructor head)) end | CPatCstr (r, Some expl_pl, pl) -> - let g = try locate (snd (qualid_of_reference r)) + let g = try locate (qualid_of_reference r).v with Not_found -> raise (InternalizationError (loc,NotAConstructor r)) in if expl_pl == [] then @@ -1954,14 +1956,14 @@ let internalize globalenv env pattern_mode (_, ntnvars as lvar) c = let thevars, thepats = List.split l in let sub_rtn = (* Some (GSort (Loc.ghost,GType None)) *) None in let sub_tms = List.map (fun id -> (DAst.make @@ GVar id),(Name id,None)) thevars (* "match v1,..,vn" *) in - let main_sub_eqn = Loc.tag @@ + let main_sub_eqn = CAst.make @@ ([],thepats, (* "|p1,..,pn" *) Option.cata (intern_type env') (DAst.make ?loc @@ GHole(Evar_kinds.CasesType false,Misctypes.IntroAnonymous,None)) rtnpo) (* "=> P" if there were a return predicate P, and "=> _" otherwise *) in let catch_all_sub_eqn = if List.for_all (irrefutable globalenv) thepats then [] else - [Loc.tag @@ ([],List.make (List.length thepats) (DAst.make @@ PatVar Anonymous), (* "|_,..,_" *) + [CAst.make @@ ([],List.make (List.length thepats) (DAst.make @@ PatVar Anonymous), (* "|_,..,_" *) DAst.make @@ GHole(Evar_kinds.ImpossibleCase,Misctypes.IntroAnonymous,None))] (* "=> _" *) in Some (DAst.make @@ GCases(Term.RegularStyle,sub_rtn,sub_tms,main_sub_eqn::catch_all_sub_eqn)) in @@ -2077,7 +2079,7 @@ let internalize globalenv env pattern_mode (_, ntnvars as lvar) c = List.map (fun (asubst,pl) -> let rhs = replace_vars_constr_expr asubst rhs in let rhs' = intern {env with ids = env_ids} rhs in - (loc,(eqn_ids,pl,rhs'))) pll + CAst.make ?loc (eqn_ids,pl,rhs')) pll and intern_case_item env forbidden_names_for_gen (tm,na,t) = (* the "match" part *) @@ -2110,7 +2112,7 @@ let internalize globalenv env pattern_mode (_, ntnvars as lvar) c = match case_rel_ctxt,arg_pats with (* LetIn in the rel_context *) | LocalDef _ :: t, l when not with_letin -> - canonize_args t l forbidden_names match_acc ((Loc.tag Anonymous)::var_acc) + canonize_args t l forbidden_names match_acc ((CAst.make Anonymous)::var_acc) | [],[] -> (add_name match_acc na, var_acc) | (LocalAssum (cano_name,ty) | LocalDef (cano_name,_,ty)) :: t, c::tt -> @@ -2118,21 +2120,21 @@ let internalize globalenv env pattern_mode (_, ntnvars as lvar) c = | PatVar x -> let loc = c.CAst.loc in canonize_args t tt forbidden_names - (add_name match_acc CAst.(make ?loc x)) ((loc,x)::var_acc) + (add_name match_acc CAst.(make ?loc x)) (CAst.make ?loc x::var_acc) | _ -> let fresh = Namegen.next_name_away_with_default_using_types "iV" cano_name forbidden_names (EConstr.of_constr ty) in canonize_args t tt (Id.Set.add fresh forbidden_names) - ((fresh,c)::match_acc) ((cases_pattern_loc c,Name fresh)::var_acc) + ((fresh,c)::match_acc) ((CAst.make ?loc:(cases_pattern_loc c) @@ Name fresh)::var_acc) end | _ -> assert false in let _,args_rel = List.chop nparams (List.rev mip.Declarations.mind_arity_ctxt) in canonize_args args_rel l forbidden_names_for_gen [] [] in - match_to_do, Some (cases_pattern_expr_loc t,(ind,List.rev_map snd nal)) + match_to_do, Some (CAst.make ?loc:(cases_pattern_expr_loc t) (ind,List.rev_map (fun x -> x.v) nal)) | None -> [], None in - (tm',(na.CAst.v,typ)), extra_id, match_td + (tm',(na.CAst.v, typ)), extra_id, match_td and intern_impargs c env l subscopes args = let eargs, rargs = extract_explicit_arg l args in @@ -2164,7 +2166,7 @@ let internalize globalenv env pattern_mode (_, ntnvars as lvar) c = | (imp::impl', []) -> if not (Id.Map.is_empty eargs) then (let (id,(loc,_)) = Id.Map.choose eargs in - user_err ?loc (str "Not enough non implicit \ + user_err ?loc (str "Not enough non implicit \ arguments to accept the argument bound to " ++ Id.print id ++ str".")); [] diff --git a/interp/declare.ml b/interp/declare.ml index 7dd73fbb5c..c55a6c69ba 100644 --- a/interp/declare.ml +++ b/interp/declare.ml @@ -592,15 +592,10 @@ let input_constraints : constraint_decl -> Libobject.obj = discharge_function = discharge_constraints; classify_function = (fun a -> Keep a) } -let loc_of_glob_level = function - | Misctypes.GType (Misctypes.UNamed n) -> Libnames.loc_of_reference n - | _ -> None - let do_constraint poly l = let u_of_id x = let level = Pretyping.interp_known_glob_level (Evd.from_env (Global.env ())) x in - let loc = loc_of_glob_level x in - loc, Universes.is_polymorphic level, level + Universes.is_polymorphic level, level in let in_section = Lib.sections_are_opened () in let () = @@ -608,18 +603,17 @@ let do_constraint poly l = user_err ~hdr:"Constraint" (str"Cannot declare polymorphic constraints outside sections") in - let check_poly ?loc p loc' p' = + let check_poly p p' = if poly then () else if p || p' then - let loc = if p then loc else loc' in - user_err ?loc ~hdr:"Constraint" + user_err ~hdr:"Constraint" (str "Cannot declare a global constraint on " ++ str "a polymorphic universe, use " ++ str "Polymorphic Constraint instead") in let constraints = List.fold_left (fun acc (l, d, r) -> - let ploc, p, lu = u_of_id l and rloc, p', ru = u_of_id r in - check_poly ?loc:ploc p rloc p'; + 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 in diff --git a/interp/implicit_quantifiers.ml b/interp/implicit_quantifiers.ml index 7d919ec0c0..a1a3be70f1 100644 --- a/interp/implicit_quantifiers.ml +++ b/interp/implicit_quantifiers.ml @@ -94,8 +94,8 @@ let free_vars_of_constr_expr c ?(bound=Id.Set.empty) l = else l in let rec aux bdvars l c = match CAst.(c.v) with - | CRef (Ident (loc,id),_) -> found loc id bdvars l - | CNotation ("{ _ : _ | _ }", ({ CAst.v = CRef (Ident (_, id),_) } :: _, [], [], [])) when not (Id.Set.mem id bdvars) -> + | CRef ({CAst.v=Ident id},_) -> found c.CAst.loc id bdvars l + | CNotation ("{ _ : _ | _ }", ({ CAst.v = CRef ({CAst.v=Ident id},_) } :: _, [], [], [])) when not (Id.Set.mem id bdvars) -> Constrexpr_ops.fold_constr_expr_with_binders (fun a l -> Id.Set.add a l) aux (Id.Set.add id bdvars) l c | _ -> Constrexpr_ops.fold_constr_expr_with_binders (fun a l -> Id.Set.add a l) aux bdvars l c in aux bound l c @@ -194,7 +194,7 @@ let combine_params avoid fn applied needed = let combine_params_freevar = fun avoid (_, decl) -> let id' = next_name_away_from (RelDecl.get_name decl) avoid in - (CAst.make @@ CRef (Ident (Loc.tag id'),None), Id.Set.add id' avoid) + (CAst.make @@ CRef (CAst.make @@ Ident id',None), Id.Set.add id' avoid) let destClassApp cl = let open CAst in @@ -202,7 +202,7 @@ let destClassApp cl = match cl.v with | CApp ((None, { v = CRef (ref, inst) }), l) -> CAst.make ?loc (ref, List.map fst l, inst) | CAppExpl ((None, ref, inst), l) -> CAst.make ?loc (ref, l, inst) - | CRef (ref, inst) -> CAst.make ?loc:(loc_of_reference ref) (ref, [], inst) + | CRef (ref, inst) -> CAst.make ?loc:cl.loc (ref, [], inst) | _ -> raise Not_found let destClassAppExpl cl = @@ -210,15 +210,15 @@ let destClassAppExpl cl = let loc = cl.loc in match cl.v with | CApp ((None, { v = CRef (ref, inst) } ), l) -> CAst.make ?loc (ref, l, inst) - | CRef (ref, inst) -> CAst.make ?loc:(loc_of_reference ref) (ref, [], inst) + | CRef (ref, inst) -> CAst.make ?loc:cl.loc (ref, [], inst) | _ -> raise Not_found let implicit_application env ?(allow_partial=true) f ty = let is_class = try let ({CAst.v=(r, _, _)} as clapp) = destClassAppExpl ty in - let (loc, qid) = qualid_of_reference r in - let gr = Nametab.locate qid in + let qid = qualid_of_reference r in + let gr = Nametab.locate qid.CAst.v in if Typeclasses.is_class gr then Some (clapp, gr) else None with Not_found -> None in diff --git a/interp/modintern.ml b/interp/modintern.ml index 8876855853..dc93d8dc4d 100644 --- a/interp/modintern.ml +++ b/interp/modintern.ml @@ -45,7 +45,7 @@ let error_application_to_module_type loc = or both are searched. The returned kind is never ModAny, and it is equal to the input kind when this one isn't ModAny. *) -let lookup_module_or_modtype kind (loc,qid) = +let lookup_module_or_modtype kind {CAst.loc;v=qid} = try if kind == ModType then raise Not_found; let mp = Nametab.locate_module qid in @@ -60,9 +60,9 @@ let lookup_module_or_modtype kind (loc,qid) = let lookup_module lqid = fst (lookup_module_or_modtype Module lqid) let transl_with_decl env = function - | CWith_Module ((_,fqid),qid) -> + | CWith_Module ({CAst.v=fqid},qid) -> WithMod (fqid,lookup_module qid), Univ.ContextSet.empty - | CWith_Definition ((_,fqid),udecl,c) -> + | CWith_Definition ({CAst.v=fqid},udecl,c) -> let sigma, udecl = Univdecls.interp_univ_decl_opt env udecl in let c, ectx = interp_constr env sigma c in begin match UState.check_univ_decl ~poly:(Flags.is_universe_polymorphism()) ectx udecl with @@ -81,11 +81,11 @@ let loc_of_module l = l.CAst.loc (* Invariant : the returned kind is never ModAny, and it is equal to the input kind when this one isn't ModAny. *) -let rec interp_module_ast env kind m cst = match m.CAst.v with - | CMident qid -> - let (mp,kind) = lookup_module_or_modtype kind (m.CAst.loc,qid) in +let rec interp_module_ast env kind m cst = match m with + | {CAst.loc;v=CMident qid} -> + let (mp,kind) = lookup_module_or_modtype kind CAst.(make ?loc qid) in (MEident mp, kind, cst) - | CMapply (me1,me2) -> + | {CAst.loc;v=CMapply (me1,me2)} -> let me1',kind1, cst = interp_module_ast env kind me1 cst in let me2',kind2, cst = interp_module_ast env ModAny me2 cst in let mp2 = match me2' with @@ -95,7 +95,7 @@ let rec interp_module_ast env kind m cst = match m.CAst.v with if kind2 == ModType then error_application_to_module_type (loc_of_module me2); (MEapply (me1',mp2), kind1, cst) - | CMwith (me,decl) -> + | {CAst.loc;v=CMwith (me,decl)} -> let me,kind,cst = interp_module_ast env kind me cst in if kind == Module then error_incorrect_with_in_module m.CAst.loc; let decl, cst' = transl_with_decl env decl in diff --git a/interp/notation_ops.ml b/interp/notation_ops.ml index 77ef601b72..a0d69ce796 100644 --- a/interp/notation_ops.ml +++ b/interp/notation_ops.ml @@ -156,7 +156,7 @@ let protect g e na = let apply_cases_pattern ?loc ((ids,disjpat),id) c = let tm = DAst.make ?loc (GVar id) in - let eqns = List.map (fun pat -> (loc,(ids,[pat],c))) disjpat in + let eqns = List.map (fun pat -> (CAst.make ?loc (ids,[pat],c))) disjpat in DAst.make ?loc @@ GCases (LetPatternStyle, None, [tm,(Anonymous,None)], eqns) let glob_constr_of_notation_constr_with_binders ?loc g f e nc = @@ -192,7 +192,7 @@ let glob_constr_of_notation_constr_with_binders ?loc g f e nc = let e',nal' = List.fold_right (fun na (e',nal) -> let e',na' = protect g e' na in e',na'::nal) nal (e',[]) in - e',Some (Loc.tag ?loc (ind,nal')) in + e',Some (CAst.make ?loc (ind,nal')) in let e',na' = protect g e' na in (e',(f e tm,(na',t'))::tml')) tml (e,[]) in let fold (idl,e) na = let (e,disjpat,na) = g e na in ((Name.cons na idl,e),disjpat,na) in @@ -200,7 +200,7 @@ let glob_constr_of_notation_constr_with_binders ?loc g f e nc = let ((idl,e),patl) = List.fold_left_map (cases_pattern_fold_map ?loc fold) ([],e) patl in let disjpatl = product_of_cases_patterns patl in - List.map (fun patl -> Loc.tag (idl,patl,f e rhs)) disjpatl) eqnl in + List.map (fun patl -> CAst.make (idl,patl,f e rhs)) disjpatl) eqnl in GCases (sty,Option.map (f e') rtntypopt,tml',List.flatten eqnl') | NLetTuple (nal,(na,po),b,c) -> let e',nal = List.fold_left_map (protect g) e nal in @@ -411,13 +411,13 @@ let notation_constr_and_vars_of_glob_constr recvars a = | GProd (na,bk,ty,c) -> add_name found na; NProd (na,aux ty,aux c) | GLetIn (na,b,t,c) -> add_name found na; NLetIn (na,aux b,Option.map aux t, aux c) | GCases (sty,rtntypopt,tml,eqnl) -> - let f (_,(idl,pat,rhs)) = List.iter (add_id found) idl; (pat,aux rhs) in + let f {CAst.v=(idl,pat,rhs)} = List.iter (add_id found) idl; (pat,aux rhs) in NCases (sty,Option.map aux rtntypopt, List.map (fun (tm,(na,x)) -> add_name found na; Option.iter - (fun (_,(_,nl)) -> List.iter (add_name found) nl) x; - (aux tm,(na,Option.map (fun (_,(ind,nal)) -> (ind,nal)) x))) tml, + (fun {CAst.v=(_,nl)} -> List.iter (add_name found) nl) x; + (aux tm,(na,Option.map (fun {CAst.v=(ind,nal)} -> (ind,nal)) x))) tml, List.map f eqnl) | GLetTuple (nal,(na,po),b,c) -> add_name found na; @@ -661,7 +661,7 @@ let abstract_return_type_context pi mklam tml rtno = rtno let abstract_return_type_context_glob_constr tml rtn = - abstract_return_type_context (fun (_,(_,nal)) -> nal) + abstract_return_type_context (fun {CAst.v=(_,nal)} -> nal) (fun na c -> DAst.make @@ GLambda(na,Explicit,DAst.make @@ GHole(Evar_kinds.InternalHole,Misctypes.IntroAnonymous,None),c)) tml rtn @@ -1241,7 +1241,7 @@ and match_extended_binders ?loc isprod u alp metas na1 na2 bk t sigma b1 b2 = | Name p, GCases (LetPatternStyle,None,[(e,_)],(_::_ as eqns)), Name id when is_gvar p e && is_bindinglist_meta id metas && List.length (store (Detyping.factorize_eqns eqns)) = 1 -> (match get () with - | [(_,(ids,disj_of_patl,b1))] -> + | [{CAst.v=(ids,disj_of_patl,b1)}] -> let disjpat = List.map (function [pat] -> pat | _ -> assert false) disj_of_patl in let disjpat = if occur_glob_constr p b1 then List.map (set_pat_alias p) disjpat else disjpat in let alp,sigma = bind_bindinglist_env alp sigma id [DAst.make ?loc @@ GLocalPattern ((disjpat,ids),p,bk,t)] in @@ -1250,7 +1250,7 @@ and match_extended_binders ?loc isprod u alp metas na1 na2 bk t sigma b1 b2 = | Name p, GCases (LetPatternStyle,None,[(e,_)],(_::_ as eqns)), Name id when is_gvar p e && is_onlybinding_pattern_like_meta false id metas && List.length (store (Detyping.factorize_eqns eqns)) = 1 -> (match get () with - | [(_,(ids,disj_of_patl,b1))] -> + | [{CAst.v=(ids,disj_of_patl,b1)}] -> let disjpat = List.map (function [pat] -> pat | _ -> assert false) disj_of_patl in let disjpat = if occur_glob_constr p b1 then List.map (set_pat_alias p) disjpat else disjpat in let alp,sigma = bind_binding_env alp sigma id disjpat in @@ -1263,7 +1263,7 @@ and match_extended_binders ?loc isprod u alp metas na1 na2 bk t sigma b1 b2 = let (alp,sigma) = match_names metas (alp,sigma) na1 na2 in match_in u alp metas sigma b1 b2 -and match_equations u alp metas sigma (_,(ids,patl1,rhs1)) (patl2,rhs2) rest1 rest2 = +and match_equations u alp metas sigma {CAst.v=(ids,patl1,rhs1)} (patl2,rhs2) rest1 rest2 = (* patl1 and patl2 have the same length because they respectively correspond to some tml1 and tml2 that have the same length *) let allow_catchall = (rest2 = [] && ids = []) in @@ -1272,7 +1272,7 @@ and match_equations u alp metas sigma (_,(ids,patl1,rhs1)) (patl2,rhs2) rest1 re (alp,sigma) patl1 patl2 in match_in u alp metas sigma rhs1 rhs2 -and match_disjunctive_equations u alp metas sigma (_,(ids,disjpatl1,rhs1)) (disjpatl2,rhs2) _ _ = +and match_disjunctive_equations u alp metas sigma {CAst.v=(ids,disjpatl1,rhs1)} (disjpatl2,rhs2) _ _ = (* patl1 and patl2 have the same length because they respectively correspond to some tml1 and tml2 that have the same length *) let (alp,sigma) = diff --git a/interp/smartlocate.ml b/interp/smartlocate.ml index bc24a19de8..1f4a93a6f3 100644 --- a/interp/smartlocate.ml +++ b/interp/smartlocate.ml @@ -42,42 +42,38 @@ let global_of_extended_global = function | [],NApp (NRef ref,[]) -> ref | _ -> raise Not_found -let locate_global_with_alias ?(head=false) (loc,qid) = +let locate_global_with_alias ?(head=false) {CAst.loc; v=qid} = let ref = Nametab.locate_extended qid in try if head then global_of_extended_global_head ref else global_of_extended_global ref with Not_found -> - user_err ?loc (pr_qualid qid ++ + user_err ?loc (pr_qualid qid ++ str " is bound to a notation that does not denote a reference.") -let global_inductive_with_alias r = - let (loc,qid as lqid) = qualid_of_reference r in - try match locate_global_with_alias lqid with +let global_inductive_with_alias ({CAst.loc} as lr) = + let qid = qualid_of_reference lr in + try match locate_global_with_alias qid with | IndRef ind -> ind | ref -> - user_err ?loc:(loc_of_reference r) ~hdr:"global_inductive" - (pr_reference r ++ spc () ++ str "is not an inductive type.") - with Not_found -> Nametab.error_global_not_found ?loc qid + user_err ?loc ~hdr:"global_inductive" + (pr_reference lr ++ spc () ++ str "is not an inductive type.") + with Not_found -> Nametab.error_global_not_found qid let global_with_alias ?head r = - let (loc,qid as lqid) = qualid_of_reference r in - try locate_global_with_alias ?head lqid - with Not_found -> Nametab.error_global_not_found ?loc qid + let qid = qualid_of_reference r in + try locate_global_with_alias ?head qid + with Not_found -> Nametab.error_global_not_found qid -let smart_global ?head = function +let smart_global ?head = CAst.with_loc_val (fun ?loc -> function | AN r -> - global_with_alias ?head r - | ByNotation (loc,(ntn,sc)) -> - Notation.interp_notation_as_global_reference ?loc (fun _ -> true) ntn sc + global_with_alias ?head r + | ByNotation (ntn,sc) -> + Notation.interp_notation_as_global_reference ?loc (fun _ -> true) ntn sc) -let smart_global_inductive = function +let smart_global_inductive = CAst.with_loc_val (fun ?loc -> function | AN r -> - global_inductive_with_alias r - | ByNotation (loc,(ntn,sc)) -> - destIndRef - (Notation.interp_notation_as_global_reference ?loc isIndRef ntn sc) - -let loc_of_smart_reference = function - | AN r -> loc_of_reference r - | ByNotation (loc,(_,_)) -> loc + global_inductive_with_alias r + | ByNotation (ntn,sc) -> + destIndRef + (Notation.interp_notation_as_global_reference ?loc isIndRef ntn sc)) diff --git a/interp/smartlocate.mli b/interp/smartlocate.mli index 1123012510..7ff7e899e2 100644 --- a/interp/smartlocate.mli +++ b/interp/smartlocate.mli @@ -8,7 +8,6 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) -open Loc open Names open Libnames open Globnames @@ -19,7 +18,7 @@ open Misctypes if not bound in the global env; raise a [UserError] if bound to a syntactic def that does not denote a reference *) -val locate_global_with_alias : ?head:bool -> qualid located -> global_reference +val locate_global_with_alias : ?head:bool -> qualid CAst.t -> global_reference (** Extract a global_reference from a reference that can be an "alias" *) val global_of_extended_global : extended_global_reference -> global_reference @@ -38,6 +37,3 @@ val smart_global : ?head:bool -> reference or_by_notation -> global_reference (** The same for inductive types *) val smart_global_inductive : reference or_by_notation -> inductive - -(** Return the loc of a smart reference *) -val loc_of_smart_reference : reference or_by_notation -> Loc.t option diff --git a/interp/stdarg.ml b/interp/stdarg.ml index 5f1aad0c25..e5ed58be6b 100644 --- a/interp/stdarg.ml +++ b/interp/stdarg.ml @@ -8,7 +8,6 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) -open Misctypes open Genarg open Geninterp @@ -32,10 +31,6 @@ let wit_string : string uniform_genarg_type = let wit_pre_ident : string uniform_genarg_type = make0 "preident" -let loc_of_or_by_notation f = function - | AN c -> f c - | ByNotation (loc,(s,_)) -> loc - let wit_int_or_var = make0 ~dyn:(val_tag (topwit wit_int)) "int_or_var" diff --git a/interp/stdarg.mli b/interp/stdarg.mli index 948ec13810..53d1a522d3 100644 --- a/interp/stdarg.mli +++ b/interp/stdarg.mli @@ -22,9 +22,6 @@ open Misctypes open Tactypes open Genarg -(** FIXME: nothing to do there. *) -val loc_of_or_by_notation : ('a -> Loc.t option) -> 'a or_by_notation -> Loc.t option - val wit_unit : unit uniform_genarg_type val wit_bool : bool uniform_genarg_type @@ -39,7 +36,7 @@ val wit_pre_ident : string uniform_genarg_type val wit_int_or_var : (int or_var, int or_var, int) genarg_type -val wit_intro_pattern : (constr_expr intro_pattern_expr located, glob_constr_and_expr intro_pattern_expr located, intro_pattern) genarg_type +val wit_intro_pattern : (constr_expr intro_pattern_expr CAst.t, glob_constr_and_expr intro_pattern_expr CAst.t, intro_pattern) genarg_type val wit_ident : Id.t uniform_genarg_type @@ -88,7 +85,7 @@ val wit_reference : (reference, global_reference located or_var, global_referenc val wit_global : (reference, global_reference located or_var, global_reference) genarg_type val wit_clause : (lident Locus.clause_expr, lident Locus.clause_expr, Names.Id.t Locus.clause_expr) genarg_type val wit_quantified_hypothesis : quantified_hypothesis uniform_genarg_type -val wit_intropattern : (constr_expr intro_pattern_expr located, glob_constr_and_expr intro_pattern_expr located, intro_pattern) genarg_type +val wit_intropattern : (constr_expr intro_pattern_expr CAst.t, glob_constr_and_expr intro_pattern_expr CAst.t, intro_pattern) genarg_type val wit_redexpr : ((constr_expr,reference or_by_notation,constr_expr) red_expr_gen, (glob_constr_and_expr,evaluable_global_reference and_short_name or_var,glob_constr_pattern_and_expr) red_expr_gen, diff --git a/interp/tactypes.ml b/interp/tactypes.ml index fc0f8de5fd..83e42be89f 100644 --- a/interp/tactypes.ml +++ b/interp/tactypes.ml @@ -12,7 +12,6 @@ lower API. It's not clear whether this is a temporary API or if this is meant to stay. *) -open Loc open Names open Constrexpr open Pattern @@ -29,7 +28,7 @@ type 'a delayed_open = Environ.env -> Evd.evar_map -> Evd.evar_map * 'a type delayed_open_constr = EConstr.constr delayed_open type delayed_open_constr_with_bindings = EConstr.constr with_bindings delayed_open -type intro_pattern = delayed_open_constr intro_pattern_expr located -type intro_patterns = delayed_open_constr intro_pattern_expr located list -type or_and_intro_pattern = delayed_open_constr or_and_intro_pattern_expr located -type intro_pattern_naming = intro_pattern_naming_expr located +type intro_pattern = delayed_open_constr intro_pattern_expr CAst.t +type intro_patterns = delayed_open_constr intro_pattern_expr CAst.t list +type or_and_intro_pattern = delayed_open_constr or_and_intro_pattern_expr CAst.t +type intro_pattern_naming = intro_pattern_naming_expr CAst.t diff --git a/intf/constrexpr.ml b/intf/constrexpr.ml index 31f811bc8a..fda31756a9 100644 --- a/intf/constrexpr.ml +++ b/intf/constrexpr.ml @@ -143,8 +143,8 @@ type constr_pattern_expr = constr_expr (** Concrete syntax for modules and module types *) type with_declaration_ast = - | CWith_Module of Id.t list Loc.located * qualid Loc.located - | CWith_Definition of Id.t list Loc.located * universe_decl_expr option * constr_expr + | CWith_Module of Id.t list CAst.t * qualid CAst.t + | CWith_Definition of Id.t list CAst.t * universe_decl_expr option * constr_expr type module_ast_r = | CMident of qualid diff --git a/intf/glob_term.ml b/intf/glob_term.ml index 39a7b956ab..84be15552a 100644 --- a/intf/glob_term.ml +++ b/intf/glob_term.ml @@ -72,14 +72,14 @@ and 'a fix_kind_g = | GCoFix of int and 'a predicate_pattern_g = - Name.t * (inductive * Name.t list) Loc.located option + Name.t * (inductive * Name.t list) CAst.t option (** [(na,id)] = "as 'na' in 'id'" where if [id] is [Some(l,I,k,args)]. *) and 'a tomatch_tuple_g = ('a glob_constr_g * 'a predicate_pattern_g) and 'a tomatch_tuples_g = 'a tomatch_tuple_g list -and 'a cases_clause_g = (Id.t list * 'a cases_pattern_g list * 'a glob_constr_g) Loc.located +and 'a cases_clause_g = (Id.t list * 'a cases_pattern_g list * 'a glob_constr_g) CAst.t (** [(p,il,cl,t)] = "|'cl' => 't'". Precondition: the free variables of [t] are members of [il]. *) and 'a cases_clauses_g = 'a cases_clause_g list @@ -96,7 +96,7 @@ type fix_recursion_order = [ `any ] fix_recursion_order_g type any_glob_constr = AnyGlobConstr : 'r glob_constr_g -> any_glob_constr -type 'a disjunctive_cases_clause_g = (Id.t list * 'a cases_pattern_g list list * 'a glob_constr_g) Loc.located +type 'a disjunctive_cases_clause_g = (Id.t list * 'a cases_pattern_g list list * 'a glob_constr_g) CAst.t type 'a disjunctive_cases_clauses_g = 'a disjunctive_cases_clause_g list type 'a cases_pattern_disjunction_g = 'a cases_pattern_g list diff --git a/intf/misctypes.ml b/intf/misctypes.ml index 54a4861d09..9eb6f62cc3 100644 --- a/intf/misctypes.ml +++ b/intf/misctypes.ml @@ -35,12 +35,12 @@ and intro_pattern_naming_expr = and 'constr intro_pattern_action_expr = | IntroWildcard | IntroOrAndPattern of 'constr or_and_intro_pattern_expr - | IntroInjection of ('constr intro_pattern_expr) Loc.located list - | IntroApplyOn of 'constr Loc.located * 'constr intro_pattern_expr Loc.located + | IntroInjection of ('constr intro_pattern_expr) CAst.t list + | IntroApplyOn of 'constr CAst.t * 'constr intro_pattern_expr CAst.t | IntroRewrite of bool and 'constr or_and_intro_pattern_expr = - | IntroOrPattern of ('constr intro_pattern_expr) Loc.located list list - | IntroAndPattern of ('constr intro_pattern_expr) Loc.located list + | IntroOrPattern of ('constr intro_pattern_expr) CAst.t list list + | IntroAndPattern of ('constr intro_pattern_expr) CAst.t list (** Move destination for hypothesis *) @@ -95,7 +95,7 @@ type 'a cast_type = type quantified_hypothesis = AnonHyp of int | NamedHyp of Id.t -type 'a explicit_bindings = (quantified_hypothesis * 'a) Loc.located list +type 'a explicit_bindings = (quantified_hypothesis * 'a) CAst.t list type 'a bindings = | ImplicitBindings of 'a list @@ -113,9 +113,11 @@ type 'a or_var = type 'a and_short_name = 'a * lident option -type 'a or_by_notation = +type 'a or_by_notation_r = | AN of 'a - | ByNotation of (string * string option) Loc.located + | ByNotation of (string * string option) + +type 'a or_by_notation = 'a or_by_notation_r CAst.t (* NB: the last string in [ByNotation] is actually a [Notation.delimiters], but this formulation avoids a useless dependency. *) diff --git a/intf/vernacexpr.ml b/intf/vernacexpr.ml index dca4910574..df061bfb72 100644 --- a/intf/vernacexpr.ml +++ b/intf/vernacexpr.ml @@ -106,7 +106,7 @@ type comment = | CommentString of string | CommentInt of int -type reference_or_constr = +type reference_or_constr = | HintsReference of reference | HintsConstr of constr_expr diff --git a/library/libnames.ml b/library/libnames.ml index 81af5f2c9d..d847313221 100644 --- a/library/libnames.ml +++ b/library/libnames.ml @@ -190,54 +190,51 @@ let eq_global_dir_reference r1 r2 = match r1, r2 with | DirClosedSection dp1, DirClosedSection dp2 -> DirPath.equal dp1 dp2 | _ -> false -type reference = - | Qualid of qualid Loc.located - | Ident of Id.t Loc.located - -let qualid_of_reference = function - | Qualid (loc,qid) -> loc, qid - | Ident (loc,id) -> loc, qualid_of_ident id - -let string_of_reference = function - | Qualid (loc,qid) -> string_of_qualid qid - | Ident (loc,id) -> Id.to_string id - -let pr_reference = function - | Qualid (_,qid) -> pr_qualid qid - | Ident (_,id) -> Id.print id - -let loc_of_reference = function - | Qualid (loc,qid) -> loc - | Ident (loc,id) -> loc - -let eq_reference r1 r2 = match r1, r2 with -| Qualid (_, q1), Qualid (_, q2) -> qualid_eq q1 q2 -| Ident (_, id1), Ident (_, id2) -> Id.equal id1 id2 +type reference_r = + | Qualid of qualid + | Ident of Id.t +type reference = reference_r CAst.t + +let qualid_of_reference = CAst.map (function + | Qualid qid -> qid + | Ident id -> qualid_of_ident id) + +let string_of_reference = CAst.with_val (function + | Qualid qid -> string_of_qualid qid + | Ident id -> Id.to_string id) + +let pr_reference = CAst.with_val (function + | Qualid qid -> pr_qualid qid + | Ident id -> Id.print id) + +let eq_reference {CAst.v=r1} {CAst.v=r2} = match r1, r2 with +| Qualid q1, Qualid q2 -> qualid_eq q1 q2 +| Ident id1, Ident id2 -> Id.equal id1 id2 | _ -> false -let join_reference ns r = +let join_reference {CAst.loc=l1;v=ns} {CAst.loc=l2;v=r} = + CAst.make ?loc:(Loc.merge_opt l1 l2) ( match ns , r with - Qualid (_, q1), Qualid (loc, q2) -> + Qualid q1, Qualid q2 -> let (dp1,id1) = repr_qualid q1 in let (dp2,id2) = repr_qualid q2 in - Qualid (loc, - make_qualid + Qualid (make_qualid (append_dirpath (append_dirpath dp1 (dirpath_of_string (Names.Id.to_string id1))) dp2) id2) - | Qualid (_, q1), Ident (loc, id2) -> + | Qualid q1, Ident id2 -> let (dp1,id1) = repr_qualid q1 in - Qualid (loc, - make_qualid + Qualid (make_qualid (append_dirpath dp1 (dirpath_of_string (Names.Id.to_string id1))) id2) - | Ident (_, id1), Qualid (loc, q2) -> + | Ident id1, Qualid q2 -> let (dp2,id2) = repr_qualid q2 in - Qualid (loc, make_qualid + Qualid (make_qualid (append_dirpath (dirpath_of_string (Names.Id.to_string id1)) dp2) id2) - | Ident (_, id1), Ident (loc, id2) -> - Qualid (loc, make_qualid + | Ident id1, Ident id2 -> + Qualid (make_qualid (dirpath_of_string (Names.Id.to_string id1)) id2) + ) (* Default paths *) let default_library = Names.DirPath.initial (* = ["Top"] *) diff --git a/library/libnames.mli b/library/libnames.mli index afceef5305..9dad26129e 100644 --- a/library/libnames.mli +++ b/library/libnames.mli @@ -9,7 +9,6 @@ (************************************************************************) open Util -open Loc open Names (** {6 Dirpaths } *) @@ -137,15 +136,15 @@ val eq_global_dir_reference : global name (referred either by a qualified name or by a single name) or a variable *) -type reference = - | Qualid of qualid located - | Ident of Id.t located +type reference_r = + | Qualid of qualid + | Ident of Id.t +type reference = reference_r CAst.t val eq_reference : reference -> reference -> bool -val qualid_of_reference : reference -> qualid located +val qualid_of_reference : reference -> qualid CAst.t val string_of_reference : reference -> string val pr_reference : reference -> Pp.t -val loc_of_reference : reference -> Loc.t option val join_reference : reference -> reference -> reference (** some preset paths *) diff --git a/library/library.ml b/library/library.ml index fb9b54462e..56d2709d5b 100644 --- a/library/library.ml +++ b/library/library.ml @@ -577,7 +577,7 @@ let require_library_from_dirpath modrefl export = (* the function called by Vernacentries.vernac_import *) -let safe_locate_module (loc,qid) = +let safe_locate_module {CAst.loc;v=qid} = try Nametab.locate_module qid with Not_found -> user_err ?loc ~hdr:"import_library" @@ -595,7 +595,7 @@ let import_module export modl = | [] -> () | modl -> add_anonymous_leaf (in_import_library (List.rev modl, export)) in let rec aux acc = function - | (loc, dir as m) :: l -> + | ({CAst.loc; v=dir} as m) :: l -> let m,acc = try Nametab.locate_module dir, acc with Not_found-> flush acc; safe_locate_module m, [] in diff --git a/library/library.mli b/library/library.mli index 82a891acc0..0877ebb5a9 100644 --- a/library/library.mli +++ b/library/library.mli @@ -8,7 +8,6 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) -open Loc open Names open Libnames @@ -37,7 +36,7 @@ type seg_proofs = Constr.constr Future.computation array (** Open a module (or a library); if the boolean is true then it's also an export otherwise just a simple import *) -val import_module : bool -> qualid located list -> unit +val import_module : bool -> qualid CAst.t list -> unit (** Start the compilation of a file as a library. The first argument must be output file, and the diff --git a/library/nametab.ml b/library/nametab.ml index 0e996443f1..2046bf7580 100644 --- a/library/nametab.ml +++ b/library/nametab.ml @@ -18,8 +18,8 @@ open Globnames exception GlobalizationError of qualid -let error_global_not_found ?loc q = - Loc.raise ?loc (GlobalizationError q) +let error_global_not_found {CAst.loc;v} = + Loc.raise ?loc (GlobalizationError v) (* The visibility can be registered either - for all suffixes not shorter then a given int - when the object @@ -459,16 +459,16 @@ let global_of_path sp = let extended_global_of_path sp = ExtRefTab.find sp !the_ccitab -let global r = - let (loc,qid) = qualid_of_reference r in - try match locate_extended qid with +let global ({CAst.loc;v=r} as lr)= + let {CAst.loc; v} as qid = qualid_of_reference lr in + try match locate_extended v with | TrueGlobal ref -> ref | SynDef _ -> user_err ?loc ~hdr:"global" (str "Unexpected reference to a notation: " ++ - pr_qualid qid) + pr_qualid v) with Not_found -> - error_global_not_found ?loc qid + error_global_not_found qid (* Exists functions ********************************************************) @@ -539,13 +539,12 @@ let pr_global_env env ref = with Not_found as e -> if !Flags.debug then Feedback.msg_debug (Pp.str "pr_global_env not found"); raise e -let global_inductive r = - match global r with +let global_inductive ({CAst.loc; v=r} as lr) = + match global lr with | IndRef ind -> ind | ref -> - user_err ?loc:(loc_of_reference r) ~hdr:"global_inductive" - (pr_reference r ++ spc () ++ str "is not an inductive type") - + user_err ?loc ~hdr:"global_inductive" + (pr_reference lr ++ spc () ++ str "is not an inductive type") (********************************************************************) diff --git a/library/nametab.mli b/library/nametab.mli index 3802eaa9a3..cd28518ab6 100644 --- a/library/nametab.mli +++ b/library/nametab.mli @@ -61,7 +61,7 @@ open Globnames exception GlobalizationError of qualid (** Raises a globalization error *) -val error_global_not_found : ?loc:Loc.t -> qualid -> 'a +val error_global_not_found : qualid CAst.t -> 'a (** {6 Register visibility of things } *) diff --git a/parsing/egramcoq.ml b/parsing/egramcoq.ml index c0ead3a0a8..5f63d21c4d 100644 --- a/parsing/egramcoq.ml +++ b/parsing/egramcoq.ml @@ -312,7 +312,7 @@ let interp_entry forpat e = match e with let cases_pattern_expr_of_name { CAst.loc; v = na } = CAst.make ?loc @@ match na with | Anonymous -> CPatAtom None - | Name id -> CPatAtom (Some (Ident (Loc.tag ?loc id))) + | Name id -> CPatAtom (Some (CAst.make ?loc @@ Ident id)) type 'r env = { constrs : 'r list; diff --git a/parsing/g_constr.ml4 b/parsing/g_constr.ml4 index b4f09ee6a1..9c2806bead 100644 --- a/parsing/g_constr.ml4 +++ b/parsing/g_constr.ml4 @@ -200,11 +200,11 @@ GEXTEND Gram | "@"; f=global; i = instance; args=LIST0 NEXT -> CAst.make ~loc:!@loc @@ CAppExpl((None,f,i),args) | "@"; lid = pattern_identref; args=LIST1 identref -> let { CAst.loc = locid; v = id } = lid in - let args = List.map (fun x -> CAst.make @@ CRef (Ident Loc.(tag ?loc:x.CAst.loc x.CAst.v), None), None) args in + let args = List.map (fun x -> CAst.make @@ CRef (CAst.make ?loc:x.CAst.loc @@ Ident x.CAst.v, None), None) args in CAst.make ~loc:(!@loc) @@ CApp((None, CAst.make ?loc:locid @@ CPatVar id),args) ] | "9" [ ".."; c = operconstr LEVEL "0"; ".." -> - CAst.make ~loc:!@loc @@ CAppExpl ((None, Ident (Loc.tag ~loc:!@loc ldots_var),None),[c]) ] + CAst.make ~loc:!@loc @@ CAppExpl ((None, CAst.make ~loc:!@loc @@ Ident ldots_var, None),[c]) ] | "8" [ ] | "1" LEFTA [ c=operconstr; ".("; f=global; args=LIST0 appl_arg; ")" -> diff --git a/parsing/g_prim.ml4 b/parsing/g_prim.ml4 index a1d36b8220..b25ea766ae 100644 --- a/parsing/g_prim.ml4 +++ b/parsing/g_prim.ml4 @@ -62,8 +62,8 @@ GEXTEND Gram ] ] ; fullyqualid: - [ [ id = ident; (l,id')=fields -> Loc.tag ~loc:!@loc @@ id::List.rev (id'::l) - | id = ident -> Loc.tag ~loc:!@loc [id] + [ [ id = ident; (l,id')=fields -> CAst.make ~loc:!@loc @@ id::List.rev (id'::l) + | id = ident -> CAst.make ~loc:!@loc [id] ] ] ; basequalid: @@ -77,19 +77,19 @@ GEXTEND Gram ; reference: [ [ id = ident; (l,id') = fields -> - Qualid (Loc.tag ~loc:!@loc @@ local_make_qualid (l@[id]) id') - | id = ident -> Ident (Loc.tag ~loc:!@loc id) + CAst.make ~loc:!@loc @@ Qualid (local_make_qualid (l@[id]) id') + | id = ident -> CAst.make ~loc:!@loc @@ Ident id ] ] ; by_notation: - [ [ s = ne_string; sc = OPT ["%"; key = IDENT -> key ] -> Loc.tag ~loc:!@loc (s, sc) ] ] + [ [ s = ne_string; sc = OPT ["%"; key = IDENT -> key ] -> (s, sc) ] ] ; smart_global: - [ [ c = reference -> Misctypes.AN c - | ntn = by_notation -> Misctypes.ByNotation ntn ] ] + [ [ c = reference -> CAst.make ~loc:!@loc @@ Misctypes.AN c + | ntn = by_notation -> CAst.make ~loc:!@loc @@ Misctypes.ByNotation ntn ] ] ; qualid: - [ [ qid = basequalid -> Loc.tag ~loc:!@loc qid ] ] + [ [ qid = basequalid -> CAst.make ~loc:!@loc qid ] ] ; ne_string: [ [ s = STRING -> diff --git a/parsing/g_vernac.ml4 b/parsing/g_vernac.ml4 index f1ec496231..72c3cc14a1 100644 --- a/parsing/g_vernac.ml4 +++ b/parsing/g_vernac.ml4 @@ -554,7 +554,7 @@ GEXTEND Gram ] ] ; module_expr_atom: - [ [ qid = qualid -> CAst.make ~loc:!@loc @@ CMident (snd qid) | "("; me = module_expr; ")" -> me ] ] + [ [ qid = qualid -> CAst.make ~loc:!@loc @@ CMident (qid.CAst.v) | "("; me = module_expr; ")" -> me ] ] ; with_declaration: [ [ "Definition"; fqid = fullyqualid; udecl = OPT univ_decl; ":="; c = Constr.lconstr -> @@ -564,7 +564,7 @@ GEXTEND Gram ] ] ; module_type: - [ [ qid = qualid -> CAst.make ~loc:!@loc @@ CMident (snd qid) + [ [ qid = qualid -> CAst.make ~loc:!@loc @@ CMident (qid.CAst.v) | "("; mt = module_type; ")" -> mt | mty = module_type; me = module_expr_atom -> CAst.make ~loc:!@loc @@ CMapply (mty,me) @@ -624,9 +624,9 @@ GEXTEND Gram VernacSetStrategy l (* Canonical structure *) | IDENT "Canonical"; IDENT "Structure"; qid = global -> - VernacCanonical (AN qid) + VernacCanonical CAst.(make ~loc:!@loc @@ AN qid) | IDENT "Canonical"; IDENT "Structure"; ntn = by_notation -> - VernacCanonical (ByNotation ntn) + VernacCanonical CAst.(make ~loc:!@loc @@ ByNotation ntn) | IDENT "Canonical"; IDENT "Structure"; qid = global; d = def_body -> let s = coerce_reference_to_id qid in VernacDefinition ((NoDischarge,CanonicalStructure),((CAst.make (Name s)),None),d) @@ -640,10 +640,10 @@ GEXTEND Gram VernacIdentityCoercion (f, s, t) | IDENT "Coercion"; qid = global; ":"; s = class_rawexpr; ">->"; t = class_rawexpr -> - VernacCoercion (AN qid, s, t) + VernacCoercion (CAst.make ~loc:!@loc @@ AN qid, s, t) | IDENT "Coercion"; ntn = by_notation; ":"; s = class_rawexpr; ">->"; t = class_rawexpr -> - VernacCoercion (ByNotation ntn, s, t) + VernacCoercion (CAst.make ~loc:!@loc @@ ByNotation ntn, s, t) | IDENT "Context"; c = binders -> VernacContext c diff --git a/parsing/pcoq.mli b/parsing/pcoq.mli index e66aa4ade8..9f186224b9 100644 --- a/parsing/pcoq.mli +++ b/parsing/pcoq.mli @@ -8,7 +8,6 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) -open Loc open Names open Extend open Vernacexpr @@ -208,10 +207,10 @@ module Prim : val integer : int Gram.entry val string : string Gram.entry val lstring : lstring Gram.entry - val qualid : qualid located Gram.entry - val fullyqualid : Id.t list located Gram.entry + val qualid : qualid CAst.t Gram.entry + val fullyqualid : Id.t list CAst.t Gram.entry val reference : reference Gram.entry - val by_notation : (string * string option) Loc.located Gram.entry + val by_notation : (string * string option) Gram.entry val smart_global : reference or_by_notation Gram.entry val dirpath : DirPath.t Gram.entry val ne_string : string Gram.entry diff --git a/plugins/extraction/extract_env.ml b/plugins/extraction/extract_env.ml index a4e8c44cd0..397cb29208 100644 --- a/plugins/extraction/extract_env.ml +++ b/plugins/extraction/extract_env.ml @@ -597,8 +597,8 @@ let warns () = let rec locate_ref = function | [] -> [],[] | r::l -> - let q = snd (qualid_of_reference r) in - let mpo = try Some (Nametab.locate_module q) with Not_found -> None + let q = qualid_of_reference r in + let mpo = try Some (Nametab.locate_module q.CAst.v) with Not_found -> None and ro = try Some (Smartlocate.global_with_alias r) with Nametab.GlobalizationError _ | UserError _ -> None @@ -608,7 +608,7 @@ let rec locate_ref = function | None, Some r -> let refs,mps = locate_ref l in r::refs,mps | Some mp, None -> let refs,mps = locate_ref l in refs,mp::mps | Some mp, Some r -> - warning_ambiguous_name (q,mp,r); + warning_ambiguous_name (q.CAst.v,mp,r); let refs,mps = locate_ref l in refs,mp::mps (*s Recursive extraction in the Coq toplevel. The vernacular command is @@ -646,7 +646,7 @@ let separate_extraction lr = is \verb!Extraction! [qualid]. *) let simple_extraction r = - Vernacentries.dump_global (Misctypes.AN r); + Vernacentries.dump_global CAst.(make (Misctypes.AN r)); match locate_ref [r] with | ([], [mp]) as p -> full_extr None p | [r],[] -> diff --git a/plugins/extraction/extraction_plugin.mlpack b/plugins/extraction/extraction_plugin.mlpack index 9184f65017..7f98348e21 100644 --- a/plugins/extraction/extraction_plugin.mlpack +++ b/plugins/extraction/extraction_plugin.mlpack @@ -1,3 +1,4 @@ +Miniml Table Mlutil Modutil diff --git a/plugins/extraction/miniml.ml b/plugins/extraction/miniml.ml new file mode 100644 index 0000000000..e1e49d9269 --- /dev/null +++ b/plugins/extraction/miniml.ml @@ -0,0 +1,222 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +(*s Target language for extraction: a core ML called MiniML. *) + +open Names +open Globnames + +(* The [signature] type is used to know how many arguments a CIC + object expects, and what these arguments will become in the ML + object. *) + +(* We eliminate from terms: + 1) types + 2) logical parts + 3) user-declared implicit arguments of a constant of constructor +*) + +type kill_reason = + | Ktype + | Kprop + | Kimplicit of global_reference * int (* n-th arg of a cst or construct *) + +type sign = Keep | Kill of kill_reason + + +(* Convention: outmost lambda/product gives the head of the list. *) + +type signature = sign list + +(*s ML type expressions. *) + +type ml_type = + | Tarr of ml_type * ml_type + | Tglob of global_reference * ml_type list + | Tvar of int + | Tvar' of int (* same as Tvar, used to avoid clash *) + | Tmeta of ml_meta (* used during ML type reconstruction *) + | Tdummy of kill_reason + | Tunknown + | Taxiom + +and ml_meta = { id : int; mutable contents : ml_type option } + +(* ML type schema. + The integer is the number of variable in the schema. *) + +type ml_schema = int * ml_type + +(*s ML inductive types. *) + +type inductive_kind = + | Singleton + | Coinductive + | Standard + | Record of global_reference option list (* None for anonymous field *) + +(* A [ml_ind_packet] is the miniml counterpart of a [one_inductive_body]. + If the inductive is logical ([ip_logical = false]), then all other fields + are unused. Otherwise, + [ip_sign] is a signature concerning the arguments of the inductive, + [ip_vars] contains the names of the type variables surviving in ML, + [ip_types] contains the ML types of all constructors. +*) + +type ml_ind_packet = { + ip_typename : Id.t; + ip_consnames : Id.t array; + ip_logical : bool; + ip_sign : signature; + ip_vars : Id.t list; + ip_types : (ml_type list) array +} + +(* [ip_nparams] contains the number of parameters. *) + +type equiv = + | NoEquiv + | Equiv of KerName.t + | RenEquiv of string + +type ml_ind = { + ind_kind : inductive_kind; + ind_nparams : int; + ind_packets : ml_ind_packet array; + ind_equiv : equiv +} + +(*s ML terms. *) + +type ml_ident = + | Dummy + | Id of Id.t + | Tmp of Id.t + +(** We now store some typing information on constructors + and cases to avoid type-unsafe optimisations. This will be + either the type of the applied constructor or the type + of the head of the match. +*) + +(** Nota : the constructor [MLtuple] and the extension of [MLcase] + to general patterns have been proposed by P.N. Tollitte for + his Relation Extraction plugin. [MLtuple] is currently not + used by the main extraction, as well as deep patterns. *) + +type ml_branch = ml_ident list * ml_pattern * ml_ast + +and ml_ast = + | MLrel of int + | MLapp of ml_ast * ml_ast list + | MLlam of ml_ident * ml_ast + | MLletin of ml_ident * ml_ast * ml_ast + | MLglob of global_reference + | MLcons of ml_type * global_reference * ml_ast list + | MLtuple of ml_ast list + | MLcase of ml_type * ml_ast * ml_branch array + | MLfix of int * Id.t array * ml_ast array + | MLexn of string + | MLdummy of kill_reason + | MLaxiom + | MLmagic of ml_ast + +and ml_pattern = + | Pcons of global_reference * ml_pattern list + | Ptuple of ml_pattern list + | Prel of int (** Cf. the idents in the branch. [Prel 1] is the last one. *) + | Pwild + | Pusual of global_reference (** Shortcut for Pcons (r,[Prel n;...;Prel 1]) **) + +(*s ML declarations. *) + +type ml_decl = + | Dind of MutInd.t * ml_ind + | Dtype of global_reference * Id.t list * ml_type + | Dterm of global_reference * ml_ast * ml_type + | Dfix of global_reference array * ml_ast array * ml_type array + +type ml_spec = + | Sind of MutInd.t * ml_ind + | Stype of global_reference * Id.t list * ml_type option + | Sval of global_reference * ml_type + +type ml_specif = + | Spec of ml_spec + | Smodule of ml_module_type + | Smodtype of ml_module_type + +and ml_module_type = + | MTident of ModPath.t + | MTfunsig of MBId.t * ml_module_type * ml_module_type + | MTsig of ModPath.t * ml_module_sig + | MTwith of ml_module_type * ml_with_declaration + +and ml_with_declaration = + | ML_With_type of Id.t list * Id.t list * ml_type + | ML_With_module of Id.t list * ModPath.t + +and ml_module_sig = (Label.t * ml_specif) list + +type ml_structure_elem = + | SEdecl of ml_decl + | SEmodule of ml_module + | SEmodtype of ml_module_type + +and ml_module_expr = + | MEident of ModPath.t + | MEfunctor of MBId.t * ml_module_type * ml_module_expr + | MEstruct of ModPath.t * ml_module_structure + | MEapply of ml_module_expr * ml_module_expr + +and ml_module_structure = (Label.t * ml_structure_elem) list + +and ml_module = + { ml_mod_expr : ml_module_expr; + ml_mod_type : ml_module_type } + +(* NB: we do not translate the [mod_equiv] field, since [mod_equiv = mp] + implies that [mod_expr = MEBident mp]. Same with [msb_equiv]. *) + +type ml_structure = (ModPath.t * ml_module_structure) list + +type ml_signature = (ModPath.t * ml_module_sig) list + +type unsafe_needs = { + mldummy : bool; + tdummy : bool; + tunknown : bool; + magic : bool +} + +type language_descr = { + keywords : Id.Set.t; + + (* Concerning the source file *) + file_suffix : string; + file_naming : ModPath.t -> string; + (* the second argument is a comment to add to the preamble *) + preamble : + Id.t -> Pp.t option -> ModPath.t list -> unsafe_needs -> + Pp.t; + pp_struct : ml_structure -> Pp.t; + + (* Concerning a possible interface file *) + sig_suffix : string option; + (* the second argument is a comment to add to the preamble *) + sig_preamble : + Id.t -> Pp.t option -> ModPath.t list -> unsafe_needs -> + Pp.t; + pp_sig : ml_signature -> Pp.t; + + (* for an isolated declaration print *) + pp_decl : ml_decl -> Pp.t; + +} diff --git a/plugins/extraction/table.ml b/plugins/extraction/table.ml index 6c421491fc..54c6d9d729 100644 --- a/plugins/extraction/table.ml +++ b/plugins/extraction/table.ml @@ -899,7 +899,7 @@ let extract_constant_inline inline r ids s = let extract_inductive r s l optstr = check_inside_section (); let g = Smartlocate.global_with_alias r in - Dumpglob.add_glob ?loc:(loc_of_reference r) g; + Dumpglob.add_glob ?loc:r.CAst.loc g; match g with | IndRef ((kn,i) as ip) -> let mib = Global.lookup_mind kn in diff --git a/plugins/funind/g_indfun.ml4 b/plugins/funind/g_indfun.ml4 index 21d1339c5c..90af20b4ca 100644 --- a/plugins/funind/g_indfun.ml4 +++ b/plugins/funind/g_indfun.ml4 @@ -68,9 +68,9 @@ let pr_intro_as_pat _prc _ _ pat = str"<simple_intropattern>" | None -> mt () -let out_disjunctive = function - | loc, IntroAction (IntroOrAndPattern l) -> (loc,l) - | _ -> CErrors.user_err Pp.(str "Disjunctive or conjunctive intro pattern expected.") +let out_disjunctive = CAst.map (function + | IntroAction (IntroOrAndPattern l) -> l + | _ -> CErrors.user_err Pp.(str "Disjunctive or conjunctive intro pattern expected.")) ARGUMENT EXTEND with_names TYPED AS intropattern_opt PRINTED BY pr_intro_as_pat | [ "as" simple_intropattern(ipat) ] -> [ Some ipat ] diff --git a/plugins/funind/glob_term_to_relation.ml b/plugins/funind/glob_term_to_relation.ml index 7159614d94..49f7aae435 100644 --- a/plugins/funind/glob_term_to_relation.ml +++ b/plugins/funind/glob_term_to_relation.ml @@ -287,7 +287,7 @@ let make_discr_match_el = *) let make_discr_match_brl i = List.map_i - (fun j (_,(idl,patl,_)) -> Loc.tag @@ + (fun j {CAst.v=(idl,patl,_)} -> CAst.make @@ if Int.equal j i then (idl,patl, mkGRef (Lazy.force coq_True_ref)) else (idl,patl, mkGRef (Lazy.force coq_False_ref)) @@ -659,7 +659,7 @@ let rec build_entry_lc env funnames avoid rt : glob_constr build_entry_return = assert (Int.equal (Array.length case_pats) 2); let brl = List.map_i - (fun i x -> Loc.tag ([],[case_pats.(i)],x)) + (fun i x -> CAst.make ([],[case_pats.(i)],x)) 0 [lhs;rhs] in @@ -689,7 +689,7 @@ let rec build_entry_lc env funnames avoid rt : glob_constr build_entry_return = in let case_pats = build_constructors_of_type (fst ind) nal_as_glob_constr in assert (Int.equal (Array.length case_pats) 1); - let br = Loc.tag ([],[case_pats.(0)],e) in + let br = CAst.make ([],[case_pats.(0)],e) in let match_expr = mkGCases(None,[b,(Anonymous,None)],[br]) in build_entry_lc env funnames avoid match_expr @@ -756,7 +756,7 @@ and build_entry_lc_from_case_term env types funname make_discr patterns_to_preve | [] -> (* computed_branches *) {result = [];to_avoid = avoid} | br::brl' -> (* alpha conversion to prevent name clashes *) - let _,(idl,patl,return) = alpha_br avoid br in + let {CAst.v=(idl,patl,return)} = alpha_br avoid br in let new_avoid = idl@avoid in (* for now we can no more use idl as an identifier *) (* building a list of precondition stating that we are not in this branch (will be used in the following recursive calls) diff --git a/plugins/funind/glob_termops.ml b/plugins/funind/glob_termops.ml index 41eb48657a..40ea40b6b3 100644 --- a/plugins/funind/glob_termops.ml +++ b/plugins/funind/glob_termops.ml @@ -111,11 +111,11 @@ let change_vars = Miscops.map_cast_type (change_vars mapping) c) | GProj(p,c) -> GProj(p, change_vars mapping c) ) rt - and change_vars_br mapping ((loc,(idl,patl,res)) as br) = + and change_vars_br mapping ({CAst.loc;v=(idl,patl,res)} as br) = let new_mapping = List.fold_right Id.Map.remove idl mapping in if Id.Map.is_empty new_mapping then br - else (loc,(idl,patl,change_vars new_mapping res)) + else CAst.make ?loc (idl,patl,change_vars new_mapping res) in change_vars @@ -298,13 +298,13 @@ let rec alpha_rt excluded rt = in new_rt -and alpha_br excluded (loc,(ids,patl,res)) = +and alpha_br excluded {CAst.loc;v=(ids,patl,res)} = let new_patl,new_excluded,mapping = alpha_patl excluded patl in let new_ids = List.fold_right raw_get_pattern_id new_patl [] in let new_excluded = new_ids@excluded in let renamed_res = change_vars mapping res in let new_res = alpha_rt new_excluded renamed_res in - (loc,(new_ids,new_patl,new_res)) + CAst.make ?loc (new_ids,new_patl,new_res) (* [is_free_in id rt] checks if [id] is a free variable in [rt] @@ -348,7 +348,7 @@ let is_free_in id = | GCast (b,CastCoerce) -> is_free_in b | GProj (_,c) -> is_free_in c ) x - and is_free_in_br (_,(ids,_,rt)) = + and is_free_in_br {CAst.v=(ids,_,rt)} = (not (Id.List.mem id ids)) && is_free_in rt in is_free_in @@ -443,10 +443,10 @@ let replace_var_by_term x_id term = | GProj(p,c) -> GProj(p,replace_var_by_pattern c) ) x - and replace_var_by_pattern_br ((loc,(idl,patl,res)) as br) = + and replace_var_by_pattern_br ({CAst.loc;v=(idl,patl,res)} as br) = if List.exists (fun id -> Id.compare id x_id == 0) idl then br - else (loc,(idl,patl,replace_var_by_pattern res)) + else CAst.make ?loc (idl,patl,replace_var_by_pattern res) in replace_var_by_pattern @@ -547,8 +547,8 @@ let expand_as = List.map (expand_as_br map) brl) | GProj(p,c) -> GProj(p, expand_as map c) ) - and expand_as_br map (loc,(idl,cpl,rt)) = - (loc,(idl,cpl, expand_as (List.fold_left add_as map cpl) rt)) + and expand_as_br map {CAst.loc; v=(idl,cpl,rt)} = + CAst.make ?loc (idl,cpl, expand_as (List.fold_left add_as map cpl) rt) in expand_as Id.Map.empty diff --git a/plugins/funind/indfun.ml b/plugins/funind/indfun.ml index 13eda3952a..9c350483b3 100644 --- a/plugins/funind/indfun.ml +++ b/plugins/funind/indfun.ml @@ -93,7 +93,7 @@ let functional_induction with_clean c princl pat = in let encoded_pat_as_patlist = List.make (List.length args + List.length c_list - 1) None @ [pat] in - List.map2 (fun c pat -> ((None,Tacexpr.ElimOnConstr (fun env sigma -> (sigma,(c,NoBindings)) )),(None,pat),None)) + List.map2 (fun c pat -> ((None,Ltac_plugin.Tacexpr.ElimOnConstr (fun env sigma -> (sigma,(c,NoBindings)) )),(None,pat),None)) (args@c_list) encoded_pat_as_patlist in let princ' = Some (princ,bindings) in @@ -215,7 +215,7 @@ let is_rec names = List.exists (fun (e,_) -> lookup names e) el || List.exists (lookup_br names) brl | GProj(_,c) -> lookup names c - and lookup_br names (_,(idl,_,rt)) = + and lookup_br names {CAst.v=(idl,_,rt)} = let new_names = List.fold_right Id.Set.remove idl names in lookup new_names rt in @@ -356,7 +356,7 @@ let generate_principle (evd:Evd.evar_map ref) pconstants on_error (*i The next call to mk_rel_id is valid since we have just construct the graph Ensures by : do_built i*) - let f_R_mut = Ident (Loc.tag @@ mk_rel_id (List.nth names 0)) in + let f_R_mut = CAst.make @@ Ident (mk_rel_id (List.nth names 0)) in let ind_kn = fst (locate_with_msg (pr_reference f_R_mut++str ": Not an inductive type!") @@ -364,7 +364,7 @@ let generate_principle (evd:Evd.evar_map ref) pconstants on_error f_R_mut) in let fname_kn (((fname,_),_,_,_,_),_) = - let f_ref = Ident CAst.(with_loc_val (fun ?loc n -> (loc,n)) fname) in + let f_ref = CAst.map (fun n -> Ident n) fname in locate_with_msg (pr_reference f_ref++str ": Not an inductive type!") locate_constant @@ -472,7 +472,7 @@ let register_wf ?(is_mes=false) fname rec_impls wf_rel_expr wf_arg using_lemmas let unbounded_eq = let f_app_args = CAst.make @@ Constrexpr.CAppExpl( - (None,(Ident (Loc.tag fname)),None) , + (None,CAst.make @@ Ident fname,None) , (List.map (function | {CAst.v=Anonymous} -> assert false @@ -482,7 +482,7 @@ let register_wf ?(is_mes=false) fname rec_impls wf_rel_expr wf_arg using_lemmas ) ) in - CAst.make @@ Constrexpr.CApp ((None,Constrexpr_ops.mkRefC (Qualid (Loc.tag (qualid_of_string "Logic.eq")))), + CAst.make @@ Constrexpr.CApp ((None,Constrexpr_ops.mkRefC (CAst.make @@ Qualid (qualid_of_string "Logic.eq"))), [(f_app_args,None);(body,None)]) in let eq = Constrexpr_ops.mkCProdN args unbounded_eq in @@ -539,7 +539,7 @@ let register_mes fname rec_impls wf_mes_expr wf_rel_expr_opt wf_arg using_lemmas | None -> let ltof = let make_dir l = DirPath.make (List.rev_map Id.of_string l) in - Libnames.Qualid (Loc.tag @@ Libnames.qualid_of_path + CAst.make @@ Libnames.Qualid (Libnames.qualid_of_path (Libnames.make_path (make_dir ["Arith";"Wf_nat"]) (Id.of_string "ltof"))) in let fun_from_mes = @@ -724,7 +724,7 @@ let do_generate_principle pconstants on_error register_built interactive_proof let rec add_args id new_args = CAst.map (function | CRef (r,_) as b -> begin match r with - | Libnames.Ident(loc,fname) when Id.equal fname id -> + | {CAst.v=Libnames.Ident fname} when Id.equal fname id -> CAppExpl((None,r,None),new_args) | _ -> b end @@ -744,7 +744,7 @@ let rec add_args id new_args = CAst.map (function | CAppExpl((pf,r,us),exprl) -> begin match r with - | Libnames.Ident(loc,fname) when Id.equal fname id -> + | {CAst.v=Libnames.Ident fname} when Id.equal fname id -> CAppExpl((pf,r,us),new_args@(List.map (add_args id new_args) exprl)) | _ -> CAppExpl((pf,r,us),List.map (add_args id new_args) exprl) end @@ -883,7 +883,7 @@ let make_graph (f_ref:global_reference) = | Constrexpr.CLocalAssum (nal,_,_) -> List.map (fun {CAst.loc;v=n} -> CAst.make ?loc @@ - CRef(Libnames.Ident(loc, Nameops.Name.get_id n),None)) + CRef(CAst.make ?loc @@ Libnames.Ident(Nameops.Name.get_id n),None)) nal | Constrexpr.CLocalPattern _ -> assert false ) diff --git a/plugins/funind/indfun.mli b/plugins/funind/indfun.mli index 93e03852ec..dcc1c2ea6a 100644 --- a/plugins/funind/indfun.mli +++ b/plugins/funind/indfun.mli @@ -14,7 +14,7 @@ val functional_induction : bool -> EConstr.constr -> (EConstr.constr * EConstr.constr bindings) option -> - Tacexpr.or_and_intro_pattern option -> + Ltac_plugin.Tacexpr.or_and_intro_pattern option -> Goal.goal Evd.sigma -> Goal.goal list Evd.sigma diff --git a/plugins/funind/indfun_common.ml b/plugins/funind/indfun_common.ml index d6fd2f2a0f..a0b9217c75 100644 --- a/plugins/funind/indfun_common.ml +++ b/plugins/funind/indfun_common.ml @@ -32,7 +32,7 @@ let id_of_name = function | _ -> raise Not_found let locate ref = - let (loc,qid) = qualid_of_reference ref in + let {CAst.v=qid} = qualid_of_reference ref in Nametab.locate qid let locate_ind ref = @@ -100,13 +100,8 @@ let list_union_eq eq_fun l1 l2 = let list_add_set_eq eq_fun x l = if List.exists (eq_fun x) l then l else x::l - - - let const_of_id id = - let _,princ_ref = - qualid_of_reference (Libnames.Ident (Loc.tag id)) - in + let princ_ref = qualid_of_ident id in try Constrintern.locate_reference princ_ref with Not_found -> CErrors.user_err ~hdr:"IndFun.const_of_id" diff --git a/plugins/funind/invfun.ml b/plugins/funind/invfun.ml index b858e78d0e..2743a8a2f9 100644 --- a/plugins/funind/invfun.ml +++ b/plugins/funind/invfun.ml @@ -240,7 +240,7 @@ let prove_fun_correct evd funs_constr graphs_constr schemes lemmas_types_infos i List.map (fun decl -> List.map - (fun id -> Loc.tag @@ IntroNaming (IntroIdentifier id)) + (fun id -> CAst.make @@ IntroNaming (IntroIdentifier id)) (generate_fresh_id (Id.of_string "y") ids (List.length (fst (decompose_prod_assum evd (RelDecl.get_type decl))))) ) branches @@ -256,7 +256,7 @@ let prove_fun_correct evd funs_constr graphs_constr schemes lemmas_types_infos i (* We get the identifiers of this branch *) let pre_args = List.fold_right - (fun (_,pat) acc -> + (fun {CAst.v=pat} acc -> match pat with | IntroNaming (IntroIdentifier id) -> id::acc | _ -> anomaly (Pp.str "Not an identifier.") diff --git a/plugins/funind/recdef.ml b/plugins/funind/recdef.ml index 759c88633f..fb9ae64bf4 100644 --- a/plugins/funind/recdef.ml +++ b/plugins/funind/recdef.ml @@ -206,7 +206,7 @@ let (value_f: Constr.t list -> global_reference -> Constr.t) = (RegularStyle,None, [DAst.make @@ GApp(DAst.make @@ GRef(fterm,None), List.rev_map (fun x_id -> DAst.make @@ GVar x_id) rev_x_id_l), (Anonymous,None)], - [Loc.tag ([v_id], [DAst.make @@ PatCstr ((destIndRef (delayed_force coq_sig_ref),1), + [CAst.make ([v_id], [DAst.make @@ PatCstr ((destIndRef (delayed_force coq_sig_ref),1), [DAst.make @@ PatVar(Name v_id); DAst.make @@ PatVar Anonymous], Anonymous)], DAst.make @@ GVar v_id)]) @@ -899,8 +899,8 @@ let rec make_rewrite_list expr_info max = function Proofview.V82.of_tactic (general_rewrite_bindings false Locus.AllOccurrences true (* dep proofs also: *) true (mkVar hp, - ExplicitBindings[Loc.tag @@ (NamedHyp def, expr_info.f_constr); - Loc.tag @@ (NamedHyp k, f_S max)]) false) g) ) + ExplicitBindings[CAst.make @@ (NamedHyp def, expr_info.f_constr); + CAst.make @@ (NamedHyp k, f_S max)]) false) g) ) ) [make_rewrite_list expr_info max l; observe_tclTHENLIST (str "make_rewrite_list")[ (* x < S max proof *) @@ -926,8 +926,8 @@ let make_rewrite expr_info l hp max = (Proofview.V82.of_tactic (general_rewrite_bindings false Locus.AllOccurrences true (* dep proofs also: *) true (mkVar hp, - ExplicitBindings[Loc.tag @@ (NamedHyp def, expr_info.f_constr); - Loc.tag @@ (NamedHyp k, f_S (f_S max))]) false)) g) + ExplicitBindings[CAst.make @@ (NamedHyp def, expr_info.f_constr); + CAst.make @@ (NamedHyp k, f_S (f_S max))]) false)) g) [observe_tac(str "make_rewrite finalize") ( (* tclORELSE( h_reflexivity) *) (observe_tclTHENLIST (str "make_rewrite")[ @@ -1325,7 +1325,7 @@ let open_new_goal build_proof sigma using_lemmas ref_ goal_name (gls_type,decomp CErrors.user_err Pp.(str "\"abstract\" cannot handle existentials"); let hook _ _ = let opacity = - let na_ref = Libnames.Ident (Loc.tag na) in + let na_ref = CAst.make @@ Libnames.Ident na in let na_global = Smartlocate.global_with_alias na_ref in match na_global with ConstRef c -> is_opaque_constant c @@ -1579,7 +1579,7 @@ let recursive_definition is_mes function_name rec_impls type_of_f r rec_arg_num let hook _ _ = let term_ref = Nametab.locate (qualid_of_ident term_id) in let f_ref = declare_f function_name (IsProof Lemma) arg_types term_ref in - let _ = Extraction_plugin.Table.extraction_inline true [Ident (Loc.tag term_id)] in + let _ = Extraction_plugin.Table.extraction_inline true [CAst.make @@ Ident term_id] in (* message "start second proof"; *) let stop = try com_eqn (List.length res_vars) equation_id functional_ref f_ref term_ref (subst_var function_name equation_lemma_type); diff --git a/plugins/ltac/extratactics.ml4 b/plugins/ltac/extratactics.ml4 index 61632e388e..2e90ce90cc 100644 --- a/plugins/ltac/extratactics.ml4 +++ b/plugins/ltac/extratactics.ml4 @@ -264,7 +264,7 @@ let add_rewrite_hint ~poly bases ort t lcsr = (Declare.declare_universe_context false ctx; Univ.ContextSet.empty) in - Loc.tag ?loc:(Constrexpr_ops.constr_loc ce) ((c, ctx), ort, Option.map (in_gen (rawwit wit_ltac)) t) in + CAst.make ?loc:(Constrexpr_ops.constr_loc ce) ((c, ctx), ort, Option.map (in_gen (rawwit wit_ltac)) t) in let eqs = List.map f lcsr in let add_hints base = add_rew_rules base eqs in List.iter add_hints bases diff --git a/plugins/ltac/g_ltac.ml4 b/plugins/ltac/g_ltac.ml4 index 66268f9f9b..0c42a8bb28 100644 --- a/plugins/ltac/g_ltac.ml4 +++ b/plugins/ltac/g_ltac.ml4 @@ -38,11 +38,11 @@ let genarg_of_ipattern pat = in_gen (rawwit Stdarg.wit_intro_pattern) pat let genarg_of_uconstr c = in_gen (rawwit Stdarg.wit_uconstr) c let in_tac tac = in_gen (rawwit Tacarg.wit_ltac) tac -let reference_to_id = function - | Libnames.Ident (loc, id) -> CAst.make ?loc id - | Libnames.Qualid (loc,_) -> +let reference_to_id = CAst.map_with_loc (fun ?loc -> function + | Libnames.Ident id -> id + | Libnames.Qualid _ -> CErrors.user_err ?loc - (str "This expression should be a simple identifier.") + (str "This expression should be a simple identifier.")) let tactic_mode = Gram.entry_create "vernac:tactic_command" @@ -198,7 +198,8 @@ GEXTEND Gram verbose most of the time. *) fresh_id: [ [ s = STRING -> ArgArg s (*| id = ident -> ArgVar (!@loc,id)*) - | qid = qualid -> let (_pth,id) = Libnames.repr_qualid (snd qid) in ArgVar (CAst.make ~loc:!@loc id) ] ] + | qid = qualid -> let (_pth,id) = Libnames.repr_qualid qid.CAst.v in + ArgVar (CAst.make ~loc:!@loc id) ] ] ; constr_eval: [ [ IDENT "eval"; rtc = red_expr; "in"; c = Constr.constr -> @@ -472,7 +473,7 @@ END VERNAC COMMAND EXTEND VernacPrintLtac CLASSIFIED AS QUERY | [ "Print" "Ltac" reference(r) ] -> - [ Feedback.msg_notice (Tacintern.print_ltac (snd (Libnames.qualid_of_reference r))) ] + [ Feedback.msg_notice (Tacintern.print_ltac (Libnames.qualid_of_reference r).CAst.v) ] END VERNAC COMMAND EXTEND VernacLocateLtac CLASSIFIED AS QUERY @@ -507,8 +508,8 @@ VERNAC COMMAND FUNCTIONAL EXTEND VernacDeclareTacticDefinition | [ "Ltac" ne_ltac_tacdef_body_list_sep(l, "with") ] => [ VtSideff (List.map (function | TacticDefinition ({CAst.v=r},_) -> r - | TacticRedefinition (Ident (_,r),_) -> r - | TacticRedefinition (Qualid (_,q),_) -> snd(repr_qualid q)) l), VtLater + | TacticRedefinition ({CAst.v=Ident r},_) -> r + | TacticRedefinition ({CAst.v=Qualid q},_) -> snd(repr_qualid q)) l), VtLater ] -> [ fun ~atts ~st -> let open Vernacinterp in Tacentries.register_ltac (Locality.make_module_locality atts.locality) l; st diff --git a/plugins/ltac/g_obligations.ml4 b/plugins/ltac/g_obligations.ml4 index 54e2ba960d..352e92c2a3 100644 --- a/plugins/ltac/g_obligations.ml4 +++ b/plugins/ltac/g_obligations.ml4 @@ -49,7 +49,7 @@ module Tactic = Pltac open Pcoq -let sigref = mkRefC (Qualid (Loc.tag @@ Libnames.qualid_of_string "Coq.Init.Specif.sig")) +let sigref = mkRefC (CAst.make @@ Qualid (Libnames.qualid_of_string "Coq.Init.Specif.sig")) type 'a withtac_argtype = (Tacexpr.raw_tactic_expr option, 'a) Genarg.abstract_argument_type diff --git a/plugins/ltac/g_tactic.ml4 b/plugins/ltac/g_tactic.ml4 index 1b8a852d96..7534e27999 100644 --- a/plugins/ltac/g_tactic.ml4 +++ b/plugins/ltac/g_tactic.ml4 @@ -154,8 +154,7 @@ let mkTacCase with_evar = function (* Reinterpret ident as notations for variables in the context *) (* because we don't know if they are quantified or not *) | [(clear,ElimOnIdent id),(None,None),None],None -> - let id = CAst.(id.loc, id.v) in - TacCase (with_evar,(clear,(CAst.make @@ CRef (Ident id,None),NoBindings))) + TacCase (with_evar,(clear,(CAst.make @@ CRef (CAst.make ?loc:id.CAst.loc @@ Ident id.CAst.v,None),NoBindings))) | ic -> if List.exists (function ((_, ElimOnAnonHyp _),_,_) -> true | _ -> false) (fst ic) then @@ -175,7 +174,7 @@ let mkCLambdaN_simple bl c = match bl with let loc = Loc.merge_opt (List.hd (pi1 h)).CAst.loc (Constrexpr_ops.constr_loc c) in mkCLambdaN_simple_loc ?loc bl c -let loc_of_ne_list l = Loc.merge_opt (fst (List.hd l)) (fst (List.last l)) +let loc_of_ne_list l = Loc.merge_opt (List.hd l).CAst.loc (List.last l).CAst.loc let map_int_or_var f = function | ArgArg x -> ArgArg (f x) @@ -297,7 +296,7 @@ GEXTEND Gram (* (A & B & C) is translated into (A,(B,C)) *) let rec pairify = function | ([]|[_]|[_;_]) as l -> l - | t::q -> [t; Loc.tag ?loc:(loc_of_ne_list q) (IntroAction (IntroOrAndPattern (IntroAndPattern (pairify q))))] + | t::q -> [t; CAst.make ?loc:(loc_of_ne_list q) (IntroAction (IntroOrAndPattern (IntroAndPattern (pairify q))))] in IntroAndPattern (pairify (si::tc)) ] ] ; equality_intropattern: @@ -312,28 +311,28 @@ GEXTEND Gram ; nonsimple_intropattern: [ [ l = simple_intropattern -> l - | "*" -> Loc.tag ~loc:!@loc @@ IntroForthcoming true - | "**" -> Loc.tag ~loc:!@loc @@ IntroForthcoming false ]] + | "*" -> CAst.make ~loc:!@loc @@ IntroForthcoming true + | "**" -> CAst.make ~loc:!@loc @@ IntroForthcoming false ]] ; simple_intropattern: [ [ pat = simple_intropattern_closed; l = LIST0 ["%"; c = operconstr LEVEL "0" -> c] -> - let loc0,pat = pat in + let {CAst.loc=loc0;v=pat} = pat in let f c pat = let loc1 = Constrexpr_ops.constr_loc c in let loc = Loc.merge_opt loc0 loc1 in - IntroAction (IntroApplyOn ((loc1,c),(loc,pat))) in - Loc.tag ~loc:!@loc @@ List.fold_right f l pat ] ] + IntroAction (IntroApplyOn (CAst.(make ?loc:loc1 c),CAst.(make ?loc pat))) in + CAst.make ~loc:!@loc @@ List.fold_right f l pat ] ] ; simple_intropattern_closed: - [ [ pat = or_and_intropattern -> Loc.tag ~loc:!@loc @@ IntroAction (IntroOrAndPattern pat) - | pat = equality_intropattern -> Loc.tag ~loc:!@loc @@ IntroAction pat - | "_" -> Loc.tag ~loc:!@loc @@ IntroAction IntroWildcard - | pat = naming_intropattern -> Loc.tag ~loc:!@loc @@ IntroNaming pat ] ] + [ [ pat = or_and_intropattern -> CAst.make ~loc:!@loc @@ IntroAction (IntroOrAndPattern pat) + | pat = equality_intropattern -> CAst.make ~loc:!@loc @@ IntroAction pat + | "_" -> CAst.make ~loc:!@loc @@ IntroAction IntroWildcard + | pat = naming_intropattern -> CAst.make ~loc:!@loc @@ IntroNaming pat ] ] ; simple_binding: - [ [ "("; id = ident; ":="; c = lconstr; ")" -> Loc.tag ~loc:!@loc (NamedHyp id, c) - | "("; n = natural; ":="; c = lconstr; ")" -> Loc.tag ~loc:!@loc (AnonHyp n, c) ] ] + [ [ "("; id = ident; ":="; c = lconstr; ")" -> CAst.make ~loc:!@loc (NamedHyp id, c) + | "("; n = natural; ":="; c = lconstr; ")" -> CAst.make ~loc:!@loc (AnonHyp n, c) ] ] ; bindings: [ [ test_lpar_idnum_coloneq; bl = LIST1 simple_binding -> @@ -470,7 +469,7 @@ GEXTEND Gram | -> None ] ] ; or_and_intropattern_loc: - [ [ ipat = or_and_intropattern -> ArgArg (Loc.tag ~loc:!@loc ipat) + [ [ ipat = or_and_intropattern -> ArgArg (CAst.make ~loc:!@loc ipat) | locid = identref -> ArgVar locid ] ] ; as_or_and_ipat: @@ -478,13 +477,13 @@ GEXTEND Gram | -> None ] ] ; eqn_ipat: - [ [ IDENT "eqn"; ":"; pat = naming_intropattern -> Some (Loc.tag ~loc:!@loc pat) + [ [ IDENT "eqn"; ":"; pat = naming_intropattern -> Some (CAst.make ~loc:!@loc pat) | IDENT "_eqn"; ":"; pat = naming_intropattern -> let loc = !@loc in - warn_deprecated_eqn_syntax ~loc "H"; Some (Loc.tag ~loc pat) + warn_deprecated_eqn_syntax ~loc "H"; Some (CAst.make ~loc pat) | IDENT "_eqn" -> let loc = !@loc in - warn_deprecated_eqn_syntax ~loc "?"; Some (Loc.tag ~loc IntroAnonymous) + warn_deprecated_eqn_syntax ~loc "?"; Some (CAst.make ~loc IntroAnonymous) | -> None ] ] ; as_name: @@ -525,7 +524,7 @@ GEXTEND Gram IDENT "intros"; pl = ne_intropatterns -> TacAtom (Loc.tag ~loc:!@loc @@ TacIntroPattern (false,pl)) | IDENT "intros" -> - TacAtom (Loc.tag ~loc:!@loc @@ TacIntroPattern (false,[Loc.tag ~loc:!@loc @@IntroForthcoming false])) + TacAtom (Loc.tag ~loc:!@loc @@ TacIntroPattern (false,[CAst.make ~loc:!@loc @@IntroForthcoming false])) | IDENT "eintros"; pl = ne_intropatterns -> TacAtom (Loc.tag ~loc:!@loc @@ TacIntroPattern (true,pl)) @@ -577,31 +576,31 @@ GEXTEND Gram | IDENT "assert"; test_lpar_id_coloneq; "("; lid = identref; ":="; c = lconstr; ")" -> let { CAst.loc = loc; v = id } = lid in - TacAtom (Loc.tag ?loc @@ TacAssert (false,true,None,Some (Loc.tag ?loc @@ IntroNaming (IntroIdentifier id)),c)) + TacAtom (Loc.tag ?loc @@ TacAssert (false,true,None,Some (CAst.make ?loc @@ IntroNaming (IntroIdentifier id)),c)) | IDENT "eassert"; test_lpar_id_coloneq; "("; lid = identref; ":="; c = lconstr; ")" -> let { CAst.loc = loc; v = id } = lid in - TacAtom (Loc.tag ?loc @@ TacAssert (true,true,None,Some (Loc.tag ?loc @@ IntroNaming (IntroIdentifier id)),c)) + TacAtom (Loc.tag ?loc @@ TacAssert (true,true,None,Some (CAst.make ?loc @@ IntroNaming (IntroIdentifier id)),c)) (* Alternative syntax for "assert c as id by tac" *) | IDENT "assert"; test_lpar_id_colon; "("; lid = identref; ":"; c = lconstr; ")"; tac=by_tactic -> let { CAst.loc = loc; v = id } = lid in - TacAtom (Loc.tag ?loc @@ TacAssert (false,true,Some tac,Some (Loc.tag ?loc @@ IntroNaming (IntroIdentifier id)),c)) + TacAtom (Loc.tag ?loc @@ TacAssert (false,true,Some tac,Some (CAst.make ?loc @@ IntroNaming (IntroIdentifier id)),c)) | IDENT "eassert"; test_lpar_id_colon; "("; lid = identref; ":"; c = lconstr; ")"; tac=by_tactic -> let { CAst.loc = loc; v = id } = lid in - TacAtom (Loc.tag ?loc @@ TacAssert (true,true,Some tac,Some (Loc.tag ?loc @@ IntroNaming (IntroIdentifier id)),c)) + TacAtom (Loc.tag ?loc @@ TacAssert (true,true,Some tac,Some (CAst.make ?loc @@ IntroNaming (IntroIdentifier id)),c)) (* Alternative syntax for "enough c as id by tac" *) | IDENT "enough"; test_lpar_id_colon; "("; lid = identref; ":"; c = lconstr; ")"; tac=by_tactic -> let { CAst.loc = loc; v = id } = lid in - TacAtom (Loc.tag ?loc @@ TacAssert (false,false,Some tac,Some (Loc.tag ?loc @@ IntroNaming (IntroIdentifier id)),c)) + TacAtom (Loc.tag ?loc @@ TacAssert (false,false,Some tac,Some (CAst.make ?loc @@ IntroNaming (IntroIdentifier id)),c)) | IDENT "eenough"; test_lpar_id_colon; "("; lid = identref; ":"; c = lconstr; ")"; tac=by_tactic -> let { CAst.loc = loc; v = id } = lid in - TacAtom (Loc.tag ?loc @@ TacAssert (true,false,Some tac,Some (Loc.tag ?loc @@ IntroNaming (IntroIdentifier id)),c)) + TacAtom (Loc.tag ?loc @@ TacAssert (true,false,Some tac,Some (CAst.make ?loc @@ IntroNaming (IntroIdentifier id)),c)) | IDENT "assert"; c = constr; ipat = as_ipat; tac = by_tactic -> TacAtom (Loc.tag ~loc:!@loc @@ TacAssert (false,true,Some tac,ipat,c)) diff --git a/plugins/ltac/ltac_plugin.mlpack b/plugins/ltac/ltac_plugin.mlpack index 3972b7aac3..ec96e1bbdd 100644 --- a/plugins/ltac/ltac_plugin.mlpack +++ b/plugins/ltac/ltac_plugin.mlpack @@ -1,3 +1,4 @@ +Tacexpr Tacarg Tacsubst Tacenv diff --git a/plugins/ltac/pltac.mli b/plugins/ltac/pltac.mli index 699e231106..6637de745e 100644 --- a/plugins/ltac/pltac.mli +++ b/plugins/ltac/pltac.mli @@ -10,7 +10,6 @@ (** Ltac parsing entries *) -open Loc open Pcoq open Libnames open Constrexpr @@ -29,7 +28,7 @@ val quantified_hypothesis : quantified_hypothesis Gram.entry val destruction_arg : constr_expr with_bindings destruction_arg Gram.entry val int_or_var : int or_var Gram.entry val simple_tactic : raw_tactic_expr Gram.entry -val simple_intropattern : constr_expr intro_pattern_expr located Gram.entry +val simple_intropattern : constr_expr intro_pattern_expr CAst.t Gram.entry val in_clause : lident Locus.clause_expr Gram.entry val clause_dft_concl : lident Locus.clause_expr Gram.entry val tactic_arg : raw_tactic_arg Gram.entry diff --git a/plugins/ltac/pptactic.ml b/plugins/ltac/pptactic.ml index fbb70cca68..11bb7a2341 100644 --- a/plugins/ltac/pptactic.ml +++ b/plugins/ltac/pptactic.ml @@ -14,11 +14,9 @@ open Namegen open CErrors open Util open Constrexpr -open Tacexpr open Genarg open Geninterp open Stdarg -open Tacarg open Libnames open Notation_term open Misctypes @@ -29,6 +27,9 @@ open Pputils open Ppconstr open Printer +open Tacexpr +open Tacarg + module Tag = struct @@ -181,9 +182,9 @@ let string_of_genarg_arg (ArgumentType arg) = let pr_and_short_name pr (c,_) = pr c - let pr_or_by_notation f = function + let pr_or_by_notation f = CAst.with_val (function | AN v -> f v - | ByNotation (_,(s,sc)) -> qs s ++ pr_opt (fun sc -> str "%" ++ str sc) sc + | ByNotation (s,sc) -> qs s ++ pr_opt (fun sc -> str "%" ++ str sc) sc) let pr_located pr (loc,x) = pr x @@ -382,9 +383,9 @@ let string_of_genarg_arg (ArgumentType arg) = let pr_as_disjunctive_ipat prc ipatl = keyword "as" ++ spc () ++ - pr_or_var (fun (loc,p) -> Miscprint.pr_or_and_intro_pattern prc p) ipatl + pr_or_var (fun {CAst.loc;v=p} -> Miscprint.pr_or_and_intro_pattern prc p) ipatl - let pr_eqn_ipat (_,ipat) = keyword "eqn:" ++ Miscprint.pr_intro_pattern_naming ipat + let pr_eqn_ipat {CAst.v=ipat} = keyword "eqn:" ++ Miscprint.pr_intro_pattern_naming ipat let pr_with_induction_names prc = function | None, None -> mt () @@ -426,7 +427,7 @@ let string_of_genarg_arg (ArgumentType arg) = let pr_assumption prc prdc prlc ipat c = match ipat with (* Use this "optimisation" or use only the general case ?*) (* it seems that this "optimisation" is somehow more natural *) - | Some (_,IntroNaming (IntroIdentifier id)) -> + | Some {CAst.v=IntroNaming (IntroIdentifier id)} -> spc() ++ surround (pr_id id ++ str " :" ++ spc() ++ prlc c) | ipat -> spc() ++ prc c ++ pr_as_ipat prdc ipat @@ -744,7 +745,7 @@ let pr_goal_selector ~toplevel s = | TacIntroPattern (ev,(_::_ as p)) -> hov 1 (primitive (if ev then "eintros" else "intros") ++ (match p with - | [_,Misctypes.IntroForthcoming false] -> mt () + | [{CAst.v=Misctypes.IntroForthcoming false}] -> mt () | _ -> spc () ++ prlist_with_sep spc (Miscprint.pr_intro_pattern pr.pr_dconstr) p)) | TacApply (a,ev,cb,inhyp) -> hov 1 ( diff --git a/plugins/ltac/pptactic.mli b/plugins/ltac/pptactic.mli index 7e6c6b20ee..5951f2b119 100644 --- a/plugins/ltac/pptactic.mli +++ b/plugins/ltac/pptactic.mli @@ -17,8 +17,8 @@ open Names open Misctypes open Environ open Constrexpr -open Tacexpr open Notation_term +open Tacexpr type 'a grammar_tactic_prod_item_expr = | TacTerm of string diff --git a/plugins/ltac/rewrite.ml b/plugins/ltac/rewrite.ml index e0368153e5..d32a2faefc 100644 --- a/plugins/ltac/rewrite.ml +++ b/plugins/ltac/rewrite.ml @@ -1773,12 +1773,11 @@ let rec strategy_of_ast = function (* By default the strategy for "rewrite_db" is top-down *) -let mkappc s l = CAst.make @@ CAppExpl ((None,(Libnames.Ident (Loc.tag @@ Id.of_string s)),None),l) +let mkappc s l = CAst.make @@ CAppExpl ((None,CAst.make @@ Libnames.Ident (Id.of_string s),None),l) let declare_an_instance n s args = (((CAst.make @@ Name n),None), Explicit, - CAst.make @@ CAppExpl ((None, Qualid (Loc.tag @@ qualid_of_string s),None), - args)) + CAst.make @@ CAppExpl ((None, CAst.make @@ Qualid (qualid_of_string s),None), args)) let declare_instance a aeq n s = declare_an_instance n s [a;aeq] @@ -1792,17 +1791,17 @@ let anew_instance global binders instance fields = let declare_instance_refl global binders a aeq n lemma = let instance = declare_instance a aeq (add_suffix n "_Reflexive") "Coq.Classes.RelationClasses.Reflexive" in anew_instance global binders instance - [(Ident (Loc.tag @@ Id.of_string "reflexivity"),lemma)] + [(CAst.make @@ Ident (Id.of_string "reflexivity"),lemma)] let declare_instance_sym global binders a aeq n lemma = let instance = declare_instance a aeq (add_suffix n "_Symmetric") "Coq.Classes.RelationClasses.Symmetric" in anew_instance global binders instance - [(Ident (Loc.tag @@ Id.of_string "symmetry"),lemma)] + [(CAst.make @@ Ident (Id.of_string "symmetry"),lemma)] let declare_instance_trans global binders a aeq n lemma = let instance = declare_instance a aeq (add_suffix n "_Transitive") "Coq.Classes.RelationClasses.Transitive" in anew_instance global binders instance - [(Ident (Loc.tag @@ Id.of_string "transitivity"),lemma)] + [(CAst.make @@ Ident (Id.of_string "transitivity"),lemma)] let declare_relation ?locality ?(binders=[]) a aeq n refl symm trans = init_setoid (); @@ -1826,16 +1825,16 @@ let declare_relation ?locality ?(binders=[]) a aeq n refl symm trans = let instance = declare_instance a aeq n "Coq.Classes.RelationClasses.PreOrder" in ignore( anew_instance global binders instance - [(Ident (Loc.tag @@ Id.of_string "PreOrder_Reflexive"), lemma1); - (Ident (Loc.tag @@ Id.of_string "PreOrder_Transitive"),lemma3)]) + [(CAst.make @@ Ident (Id.of_string "PreOrder_Reflexive"), lemma1); + (CAst.make @@ Ident (Id.of_string "PreOrder_Transitive"),lemma3)]) | (None, Some lemma2, Some lemma3) -> let _lemma_sym = declare_instance_sym global binders a aeq n lemma2 in let _lemma_trans = declare_instance_trans global binders a aeq n lemma3 in let instance = declare_instance a aeq n "Coq.Classes.RelationClasses.PER" in ignore( anew_instance global binders instance - [(Ident (Loc.tag @@ Id.of_string "PER_Symmetric"), lemma2); - (Ident (Loc.tag @@ Id.of_string "PER_Transitive"),lemma3)]) + [(CAst.make @@ Ident (Id.of_string "PER_Symmetric"), lemma2); + (CAst.make @@ Ident (Id.of_string "PER_Transitive"),lemma3)]) | (Some lemma1, Some lemma2, Some lemma3) -> let _lemma_refl = declare_instance_refl global binders a aeq n lemma1 in let _lemma_sym = declare_instance_sym global binders a aeq n lemma2 in @@ -1843,9 +1842,9 @@ let declare_relation ?locality ?(binders=[]) a aeq n refl symm trans = let instance = declare_instance a aeq n "Coq.Classes.RelationClasses.Equivalence" in ignore( anew_instance global binders instance - [(Ident (Loc.tag @@ Id.of_string "Equivalence_Reflexive"), lemma1); - (Ident (Loc.tag @@ Id.of_string "Equivalence_Symmetric"), lemma2); - (Ident (Loc.tag @@ Id.of_string "Equivalence_Transitive"), lemma3)]) + [(CAst.make @@ Ident (Id.of_string "Equivalence_Reflexive"), lemma1); + (CAst.make @@ Ident (Id.of_string "Equivalence_Symmetric"), lemma2); + (CAst.make @@ Ident (Id.of_string "Equivalence_Transitive"), lemma3)]) let cHole = CAst.make @@ CHole (None, Misctypes.IntroAnonymous, None) @@ -1951,16 +1950,16 @@ let add_setoid global binders a aeq t n = let instance = declare_instance a aeq n "Coq.Classes.RelationClasses.Equivalence" in ignore( anew_instance global binders instance - [(Ident (Loc.tag @@ Id.of_string "Equivalence_Reflexive"), mkappc "Seq_refl" [a;aeq;t]); - (Ident (Loc.tag @@ Id.of_string "Equivalence_Symmetric"), mkappc "Seq_sym" [a;aeq;t]); - (Ident (Loc.tag @@ Id.of_string "Equivalence_Transitive"), mkappc "Seq_trans" [a;aeq;t])]) + [(CAst.make @@ Ident (Id.of_string "Equivalence_Reflexive"), mkappc "Seq_refl" [a;aeq;t]); + (CAst.make @@ Ident (Id.of_string "Equivalence_Symmetric"), mkappc "Seq_sym" [a;aeq;t]); + (CAst.make @@ Ident (Id.of_string "Equivalence_Transitive"), mkappc "Seq_trans" [a;aeq;t])]) let make_tactic name = let open Tacexpr in let tacpath = Libnames.qualid_of_string name in - let tacname = Qualid (Loc.tag tacpath) in - TacArg (Loc.tag @@ TacCall (Loc.tag (tacname, []))) + let tacname = CAst.make @@ Qualid tacpath in + TacArg (Loc.tag @@ (TacCall (Loc.tag (tacname, [])))) let warn_add_morphism_deprecated = CWarnings.create ~name:"add-morphism" ~category:"deprecated" (fun () -> @@ -2010,7 +2009,7 @@ let add_morphism glob binders m s n = let instance = (((CAst.make @@ Name instance_id),None), Explicit, CAst.make @@ CAppExpl ( - (None, Qualid (Loc.tag @@ Libnames.qualid_of_string "Coq.Classes.Morphisms.Proper"),None), + (None, CAst.make @@ Qualid (Libnames.qualid_of_string "Coq.Classes.Morphisms.Proper"),None), [cHole; s; m])) in let tac = Tacinterp.interp (make_tactic "add_morphism_tactic") in diff --git a/plugins/ltac/taccoerce.ml b/plugins/ltac/taccoerce.ml index 2c7ebb7458..3812a2ba29 100644 --- a/plugins/ltac/taccoerce.ml +++ b/plugins/ltac/taccoerce.ml @@ -147,7 +147,7 @@ let coerce_var_to_ident fresh env sigma v = let fail () = raise (CannotCoerceTo "a fresh identifier") in if has_type v (topwit wit_intro_pattern) then match out_gen (topwit wit_intro_pattern) v with - | _, IntroNaming (IntroIdentifier id) -> id + | { CAst.v=IntroNaming (IntroIdentifier id)} -> id | _ -> fail () else if has_type v (topwit wit_var) then out_gen (topwit wit_var) v @@ -171,7 +171,7 @@ let id_of_name = function let fail () = raise (CannotCoerceTo "an identifier") in if has_type v (topwit wit_intro_pattern) then match out_gen (topwit wit_intro_pattern) v with - | _, IntroNaming (IntroIdentifier id) -> id + | {CAst.v=IntroNaming (IntroIdentifier id)} -> id | _ -> fail () else if has_type v (topwit wit_var) then out_gen (topwit wit_var) v @@ -207,7 +207,7 @@ let id_of_name = function let coerce_to_intro_pattern env sigma v = if has_type v (topwit wit_intro_pattern) then - snd (out_gen (topwit wit_intro_pattern) v) + (out_gen (topwit wit_intro_pattern) v).CAst.v else if has_type v (topwit wit_var) then let id = out_gen (topwit wit_var) v in IntroNaming (IntroIdentifier id) @@ -226,7 +226,7 @@ let coerce_to_intro_pattern_naming env sigma v = let coerce_to_hint_base v = if has_type v (topwit wit_intro_pattern) then match out_gen (topwit wit_intro_pattern) v with - | _, IntroNaming (IntroIdentifier id) -> Id.to_string id + | {CAst.v=IntroNaming (IntroIdentifier id)} -> Id.to_string id | _ -> raise (CannotCoerceTo "a hint base name") else raise (CannotCoerceTo "a hint base name") @@ -239,7 +239,7 @@ let coerce_to_constr env v = let fail () = raise (CannotCoerceTo "a term") in if has_type v (topwit wit_intro_pattern) then match out_gen (topwit wit_intro_pattern) v with - | _, IntroNaming (IntroIdentifier id) -> + | {CAst.v=IntroNaming (IntroIdentifier id)} -> (try ([], constr_of_id env id) with Not_found -> fail ()) | _ -> fail () else if has_type v (topwit wit_constr) then @@ -268,7 +268,7 @@ let coerce_to_evaluable_ref env sigma v = let ev = if has_type v (topwit wit_intro_pattern) then match out_gen (topwit wit_intro_pattern) v with - | _, IntroNaming (IntroIdentifier id) when is_variable env id -> EvalVarRef id + | {CAst.v=IntroNaming (IntroIdentifier id)} when is_variable env id -> EvalVarRef id | _ -> fail () else if has_type v (topwit wit_var) then let id = out_gen (topwit wit_var) v in @@ -300,14 +300,14 @@ let coerce_to_intro_pattern_list ?loc env sigma v = match Value.to_list v with | None -> raise (CannotCoerceTo "an intro pattern list") | Some l -> - let map v = Loc.tag ?loc @@ coerce_to_intro_pattern env sigma v in + let map v = CAst.make ?loc @@ coerce_to_intro_pattern env sigma v in List.map map l let coerce_to_hyp env sigma v = let fail () = raise (CannotCoerceTo "a variable") in if has_type v (topwit wit_intro_pattern) then match out_gen (topwit wit_intro_pattern) v with - | _, IntroNaming (IntroIdentifier id) when is_variable env id -> id + | {CAst.v=IntroNaming (IntroIdentifier id)} when is_variable env id -> id | _ -> fail () else if has_type v (topwit wit_var) then let id = out_gen (topwit wit_var) v in @@ -340,7 +340,7 @@ let coerce_to_quantified_hypothesis sigma v = if has_type v (topwit wit_intro_pattern) then let v = out_gen (topwit wit_intro_pattern) v in match v with - | _, IntroNaming (IntroIdentifier id) -> NamedHyp id + | {CAst.v=IntroNaming (IntroIdentifier id)} -> NamedHyp id | _ -> raise (CannotCoerceTo "a quantified hypothesis") else if has_type v (topwit wit_var) then let id = out_gen (topwit wit_var) v in diff --git a/plugins/ltac/tacentries.ml b/plugins/ltac/tacentries.ml index 566fc28733..e510b9f591 100644 --- a/plugins/ltac/tacentries.ml +++ b/plugins/ltac/tacentries.ml @@ -450,11 +450,10 @@ let register_ltac local tacl = let () = if is_shadowed then warn_unusable_identifier id in NewTac id, body | Tacexpr.TacticRedefinition (ident, body) -> - let loc = loc_of_reference ident in let kn = - try Tacenv.locate_tactic (snd (qualid_of_reference ident)) + try Tacenv.locate_tactic (qualid_of_reference ident).CAst.v with Not_found -> - CErrors.user_err ?loc + CErrors.user_err ?loc:ident.CAst.loc (str "There is no Ltac named " ++ pr_reference ident ++ str ".") in UpdateTac kn, body diff --git a/plugins/ltac/tacexpr.ml b/plugins/ltac/tacexpr.ml new file mode 100644 index 0000000000..8b0c44041f --- /dev/null +++ b/plugins/ltac/tacexpr.ml @@ -0,0 +1,397 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +open Loc +open Names +open Constrexpr +open Libnames +open Genredexpr +open Genarg +open Pattern +open Misctypes +open Locus + +type ltac_constant = KerName.t + +type direction_flag = bool (* true = Left-to-right false = right-to-right *) +type lazy_flag = + | General (* returns all possible successes *) + | Select (* returns all successes of the first matching branch *) + | Once (* returns the first success in a maching branch + (not necessarily the first) *) +type global_flag = (* [gfail] or [fail] *) + | TacGlobal + | TacLocal +type evars_flag = bool (* true = pose evars false = fail on evars *) +type rec_flag = bool (* true = recursive false = not recursive *) +type advanced_flag = bool (* true = advanced false = basic *) +type letin_flag = bool (* true = use local def false = use Leibniz *) +type clear_flag = bool option (* true = clear hyp, false = keep hyp, None = use default *) + +type goal_selector = Vernacexpr.goal_selector = + | SelectNth of int + | SelectList of (int * int) list + | SelectId of Id.t + | SelectAll + +type 'a core_destruction_arg = 'a Misctypes.core_destruction_arg = + | ElimOnConstr of 'a + | ElimOnIdent of lident + | ElimOnAnonHyp of int + +type 'a destruction_arg = + clear_flag * 'a core_destruction_arg + +type inversion_kind = Misctypes.inversion_kind = + | SimpleInversion + | FullInversion + | FullInversionClear + +type ('c,'d,'id) inversion_strength = + | NonDepInversion of + inversion_kind * 'id list * 'd or_and_intro_pattern_expr CAst.t or_var option + | DepInversion of + inversion_kind * 'c option * 'd or_and_intro_pattern_expr CAst.t or_var option + | InversionUsing of 'c * 'id list + +type ('a,'b) location = HypLocation of 'a | ConclLocation of 'b + +type 'id message_token = + | MsgString of string + | MsgInt of int + | MsgIdent of 'id + +type ('dconstr,'id) induction_clause = + 'dconstr with_bindings destruction_arg * + (intro_pattern_naming_expr CAst.t option (* eqn:... *) + * 'dconstr or_and_intro_pattern_expr CAst.t or_var option) (* as ... *) + * 'id clause_expr option (* in ... *) + +type ('constr,'dconstr,'id) induction_clause_list = + ('dconstr,'id) induction_clause list + * 'constr with_bindings option (* using ... *) + +type 'a with_bindings_arg = clear_flag * 'a with_bindings + +(* Type of patterns *) +type 'a match_pattern = + | Term of 'a + | Subterm of Id.t option * 'a + +(* Type of hypotheses for a Match Context rule *) +type 'a match_context_hyps = + | Hyp of lname * 'a match_pattern + | Def of lname * 'a match_pattern * 'a match_pattern + +(* Type of a Match rule for Match Context and Match *) +type ('a,'t) match_rule = + | Pat of 'a match_context_hyps list * 'a match_pattern * 't + | All of 't + +(** Extension indentifiers for the TACTIC EXTEND mechanism. *) +type ml_tactic_name = { + (** Name of the plugin where the tactic is defined, typically coming from a + DECLARE PLUGIN statement in the source. *) + mltac_plugin : string; + (** Name of the tactic entry where the tactic is defined, typically found + after the TACTIC EXTEND statement in the source. *) + mltac_tactic : string; +} + +type ml_tactic_entry = { + mltac_name : ml_tactic_name; + mltac_index : int; +} + +(** Composite types *) + +type glob_constr_and_expr = Tactypes.glob_constr_and_expr + +type open_constr_expr = unit * constr_expr +type open_glob_constr = unit * glob_constr_and_expr + +type binding_bound_vars = Constr_matching.binding_bound_vars +type glob_constr_pattern_and_expr = binding_bound_vars * glob_constr_and_expr * constr_pattern + +type 'a delayed_open = Environ.env -> Evd.evar_map -> Evd.evar_map * 'a + +type delayed_open_constr_with_bindings = EConstr.constr with_bindings delayed_open + +type delayed_open_constr = EConstr.constr delayed_open + +type intro_pattern = delayed_open_constr intro_pattern_expr CAst.t +type intro_patterns = delayed_open_constr intro_pattern_expr CAst.t list +type or_and_intro_pattern = delayed_open_constr or_and_intro_pattern_expr CAst.t +type intro_pattern_naming = intro_pattern_naming_expr CAst.t + +(** Generic expressions for atomic tactics *) + +type 'a gen_atomic_tactic_expr = + (* Basic tactics *) + | TacIntroPattern of evars_flag * 'dtrm intro_pattern_expr CAst.t list + | TacApply of advanced_flag * evars_flag * 'trm with_bindings_arg list * + ('nam * 'dtrm intro_pattern_expr CAst.t option) option + | TacElim of evars_flag * 'trm with_bindings_arg * 'trm with_bindings option + | TacCase of evars_flag * 'trm with_bindings_arg + | TacMutualFix of Id.t * int * (Id.t * int * 'trm) list + | TacMutualCofix of Id.t * (Id.t * 'trm) list + | TacAssert of + evars_flag * bool * 'tacexpr option option * + 'dtrm intro_pattern_expr CAst.t option * 'trm + | TacGeneralize of ('trm with_occurrences * Name.t) list + | TacLetTac of evars_flag * Name.t * 'trm * 'nam clause_expr * letin_flag * + intro_pattern_naming_expr CAst.t option + + (* Derived basic tactics *) + | TacInductionDestruct of + rec_flag * evars_flag * ('trm,'dtrm,'nam) induction_clause_list + + (* Conversion *) + | TacReduce of ('trm,'cst,'pat) red_expr_gen * 'nam clause_expr + | TacChange of 'pat option * 'dtrm * 'nam clause_expr + + (* Equality and inversion *) + | TacRewrite of evars_flag * + (bool * multi * 'dtrm with_bindings_arg) list * 'nam clause_expr * + (* spiwack: using ['dtrm] here is a small hack, may not be + stable by a change in the representation of delayed + terms. Because, in fact, it is the whole "with_bindings" + which is delayed. But because the "t" level for ['dtrm] is + uninterpreted, it works fine here too, and avoid more + disruption of this file. *) + 'tacexpr option + | TacInversion of ('trm,'dtrm,'nam) inversion_strength * quantified_hypothesis + +constraint 'a = < + term:'trm; + dterm: 'dtrm; + pattern:'pat; + constant:'cst; + reference:'ref; + name:'nam; + tacexpr:'tacexpr; + level:'lev +> + +(** Possible arguments of a tactic definition *) + +type 'a gen_tactic_arg = + | TacGeneric of 'lev generic_argument + | ConstrMayEval of ('trm,'cst,'pat) may_eval + | Reference of 'ref + | TacCall of ('ref * 'a gen_tactic_arg list) Loc.located + | TacFreshId of string or_var list + | Tacexp of 'tacexpr + | TacPretype of 'trm + | TacNumgoals + +constraint 'a = < + term:'trm; + dterm: 'dtrm; + pattern:'pat; + constant:'cst; + reference:'ref; + name:'nam; + tacexpr:'tacexpr; + level:'lev +> + +(** Generic ltac expressions. + 't : terms, 'p : patterns, 'c : constants, 'i : inductive, + 'r : ltac refs, 'n : idents, 'l : levels *) + +and 'a gen_tactic_expr = + | TacAtom of ('a gen_atomic_tactic_expr) Loc.located + | TacThen of + 'a gen_tactic_expr * + 'a gen_tactic_expr + | TacDispatch of + 'a gen_tactic_expr list + | TacExtendTac of + 'a gen_tactic_expr array * + 'a gen_tactic_expr * + 'a gen_tactic_expr array + | TacThens of + 'a gen_tactic_expr * + 'a gen_tactic_expr list + | TacThens3parts of + 'a gen_tactic_expr * + 'a gen_tactic_expr array * + 'a gen_tactic_expr * + 'a gen_tactic_expr array + | TacFirst of 'a gen_tactic_expr list + | TacComplete of 'a gen_tactic_expr + | TacSolve of 'a gen_tactic_expr list + | TacTry of 'a gen_tactic_expr + | TacOr of + 'a gen_tactic_expr * + 'a gen_tactic_expr + | TacOnce of + 'a gen_tactic_expr + | TacExactlyOnce of + 'a gen_tactic_expr + | TacIfThenCatch of + 'a gen_tactic_expr * + 'a gen_tactic_expr * + 'a gen_tactic_expr + | TacOrelse of + 'a gen_tactic_expr * + 'a gen_tactic_expr + | TacDo of int or_var * 'a gen_tactic_expr + | TacTimeout of int or_var * 'a gen_tactic_expr + | TacTime of string option * 'a gen_tactic_expr + | TacRepeat of 'a gen_tactic_expr + | TacProgress of 'a gen_tactic_expr + | TacShowHyps of 'a gen_tactic_expr + | TacAbstract of + 'a gen_tactic_expr * Id.t option + | TacId of 'n message_token list + | TacFail of global_flag * int or_var * 'n message_token list + | TacInfo of 'a gen_tactic_expr + | TacLetIn of rec_flag * + (lname * 'a gen_tactic_arg) list * + 'a gen_tactic_expr + | TacMatch of lazy_flag * + 'a gen_tactic_expr * + ('p,'a gen_tactic_expr) match_rule list + | TacMatchGoal of lazy_flag * direction_flag * + ('p,'a gen_tactic_expr) match_rule list + | TacFun of 'a gen_tactic_fun_ast + | TacArg of 'a gen_tactic_arg located + | TacSelect of goal_selector * 'a gen_tactic_expr + (* For ML extensions *) + | TacML of (ml_tactic_entry * 'a gen_tactic_arg list) Loc.located + (* For syntax extensions *) + | TacAlias of (KerName.t * 'a gen_tactic_arg list) Loc.located + +constraint 'a = < + term:'t; + dterm: 'dtrm; + pattern:'p; + constant:'c; + reference:'r; + name:'n; + tacexpr:'tacexpr; + level:'l +> + +and 'a gen_tactic_fun_ast = + Name.t list * 'a gen_tactic_expr + +constraint 'a = < + term:'t; + dterm: 'dtrm; + pattern:'p; + constant:'c; + reference:'r; + name:'n; + tacexpr:'te; + level:'l +> + +(** Globalized tactics *) + +type g_trm = glob_constr_and_expr +type g_pat = glob_constr_pattern_and_expr +type g_cst = evaluable_global_reference and_short_name or_var +type g_ref = ltac_constant located or_var +type g_nam = lident + +type g_dispatch = < + term:g_trm; + dterm:g_trm; + pattern:g_pat; + constant:g_cst; + reference:g_ref; + name:g_nam; + tacexpr:glob_tactic_expr; + level:glevel +> + +and glob_tactic_expr = + g_dispatch gen_tactic_expr + +type glob_atomic_tactic_expr = + g_dispatch gen_atomic_tactic_expr + +type glob_tactic_arg = + g_dispatch gen_tactic_arg + +(** Raw tactics *) + +type r_trm = constr_expr +type r_pat = constr_pattern_expr +type r_cst = reference or_by_notation +type r_ref = reference +type r_nam = lident +type r_lev = rlevel + +type r_dispatch = < + term:r_trm; + dterm:r_trm; + pattern:r_pat; + constant:r_cst; + reference:r_ref; + name:r_nam; + tacexpr:raw_tactic_expr; + level:rlevel +> + +and raw_tactic_expr = + r_dispatch gen_tactic_expr + +type raw_atomic_tactic_expr = + r_dispatch gen_atomic_tactic_expr + +type raw_tactic_arg = + r_dispatch gen_tactic_arg + +(** Interpreted tactics *) + +type t_trm = EConstr.constr +type t_pat = constr_pattern +type t_cst = evaluable_global_reference +type t_ref = ltac_constant located +type t_nam = Id.t + +type t_dispatch = < + term:t_trm; + dterm:g_trm; + pattern:t_pat; + constant:t_cst; + reference:t_ref; + name:t_nam; + tacexpr:unit; + level:tlevel +> + +type atomic_tactic_expr = + t_dispatch gen_atomic_tactic_expr + +(** Misc *) + +type raw_red_expr = (r_trm, r_cst, r_pat) red_expr_gen +type glob_red_expr = (g_trm, g_cst, g_pat) red_expr_gen + +(** Traces *) + +type ltac_call_kind = + | LtacMLCall of glob_tactic_expr + | LtacNotationCall of KerName.t + | LtacNameCall of ltac_constant + | LtacAtomCall of glob_atomic_tactic_expr + | LtacVarCall of Id.t * glob_tactic_expr + | LtacConstrInterp of Glob_term.glob_constr * Ltac_pretype.ltac_var_map + +type ltac_trace = ltac_call_kind Loc.located list + +type tacdef_body = + | TacticDefinition of lident * raw_tactic_expr (* indicates that user employed ':=' in Ltac body *) + | TacticRedefinition of reference * raw_tactic_expr (* indicates that user employed '::=' in Ltac body *) diff --git a/plugins/ltac/tacexpr.mli b/plugins/ltac/tacexpr.mli index 6db808dd66..8b0c44041f 100644 --- a/plugins/ltac/tacexpr.mli +++ b/plugins/ltac/tacexpr.mli @@ -56,9 +56,9 @@ type inversion_kind = Misctypes.inversion_kind = type ('c,'d,'id) inversion_strength = | NonDepInversion of - inversion_kind * 'id list * 'd or_and_intro_pattern_expr located or_var option + inversion_kind * 'id list * 'd or_and_intro_pattern_expr CAst.t or_var option | DepInversion of - inversion_kind * 'c option * 'd or_and_intro_pattern_expr located or_var option + inversion_kind * 'c option * 'd or_and_intro_pattern_expr CAst.t or_var option | InversionUsing of 'c * 'id list type ('a,'b) location = HypLocation of 'a | ConclLocation of 'b @@ -70,8 +70,8 @@ type 'id message_token = type ('dconstr,'id) induction_clause = 'dconstr with_bindings destruction_arg * - (intro_pattern_naming_expr located option (* eqn:... *) - * 'dconstr or_and_intro_pattern_expr located or_var option) (* as ... *) + (intro_pattern_naming_expr CAst.t option (* eqn:... *) + * 'dconstr or_and_intro_pattern_expr CAst.t or_var option) (* as ... *) * 'id clause_expr option (* in ... *) type ('constr,'dconstr,'id) induction_clause_list = @@ -126,28 +126,28 @@ type delayed_open_constr_with_bindings = EConstr.constr with_bindings delayed_op type delayed_open_constr = EConstr.constr delayed_open -type intro_pattern = delayed_open_constr intro_pattern_expr located -type intro_patterns = delayed_open_constr intro_pattern_expr located list -type or_and_intro_pattern = delayed_open_constr or_and_intro_pattern_expr located -type intro_pattern_naming = intro_pattern_naming_expr located +type intro_pattern = delayed_open_constr intro_pattern_expr CAst.t +type intro_patterns = delayed_open_constr intro_pattern_expr CAst.t list +type or_and_intro_pattern = delayed_open_constr or_and_intro_pattern_expr CAst.t +type intro_pattern_naming = intro_pattern_naming_expr CAst.t (** Generic expressions for atomic tactics *) type 'a gen_atomic_tactic_expr = (* Basic tactics *) - | TacIntroPattern of evars_flag * 'dtrm intro_pattern_expr located list + | TacIntroPattern of evars_flag * 'dtrm intro_pattern_expr CAst.t list | TacApply of advanced_flag * evars_flag * 'trm with_bindings_arg list * - ('nam * 'dtrm intro_pattern_expr located option) option + ('nam * 'dtrm intro_pattern_expr CAst.t option) option | TacElim of evars_flag * 'trm with_bindings_arg * 'trm with_bindings option | TacCase of evars_flag * 'trm with_bindings_arg | TacMutualFix of Id.t * int * (Id.t * int * 'trm) list | TacMutualCofix of Id.t * (Id.t * 'trm) list | TacAssert of evars_flag * bool * 'tacexpr option option * - 'dtrm intro_pattern_expr located option * 'trm + 'dtrm intro_pattern_expr CAst.t option * 'trm | TacGeneralize of ('trm with_occurrences * Name.t) list | TacLetTac of evars_flag * Name.t * 'trm * 'nam clause_expr * letin_flag * - intro_pattern_naming_expr located option + intro_pattern_naming_expr CAst.t option (* Derived basic tactics *) | TacInductionDestruct of diff --git a/plugins/ltac/tacintern.ml b/plugins/ltac/tacintern.ml index 121075f728..9ad9e1520e 100644 --- a/plugins/ltac/tacintern.ml +++ b/plugins/ltac/tacintern.ml @@ -92,36 +92,36 @@ let intern_int_or_var = intern_or_var (fun (n : int) -> n) let intern_string_or_var = intern_or_var (fun (s : string) -> s) let intern_global_reference ist = function - | Ident (loc,id) when find_var id ist -> - ArgVar CAst.(make ?loc id) + | {CAst.loc;v=Ident id} when find_var id ist -> + ArgVar (make ?loc id) | r -> - let loc,_ as lqid = qualid_of_reference r in - try ArgArg (loc,locate_global_with_alias lqid) - with Not_found -> error_global_not_found (snd lqid) + let {CAst.loc} as lqid = qualid_of_reference r in + try ArgArg (loc,locate_global_with_alias lqid) + with Not_found -> error_global_not_found lqid let intern_ltac_variable ist = function - | Ident (loc,id) -> + | {loc;v=Ident id} -> if find_var id ist then (* A local variable of any type *) - ArgVar CAst.(make ?loc id) + ArgVar (make ?loc id) else raise Not_found | _ -> raise Not_found let intern_constr_reference strict ist = function - | Ident (_,id) as r when not strict && find_hyp id ist -> - (DAst.make @@ GVar id), Some (CAst.make @@ CRef (r,None)) - | Ident (_,id) as r when find_var id ist -> - (DAst.make @@ GVar id), if strict then None else Some (CAst.make @@ CRef (r,None)) + | {v=Ident id} as r when not strict && find_hyp id ist -> + (DAst.make @@ GVar id), Some (make @@ CRef (r,None)) + | {v=Ident id} as r when find_var id ist -> + (DAst.make @@ GVar id), if strict then None else Some (make @@ CRef (r,None)) | r -> - let loc,_ as lqid = qualid_of_reference r in + let {loc} as lqid = qualid_of_reference r in DAst.make @@ GRef (locate_global_with_alias lqid,None), - if strict then None else Some (CAst.make @@ CRef (r,None)) + if strict then None else Some (make @@ CRef (r,None)) (* Internalize an isolated reference in position of tactic *) let intern_isolated_global_tactic_reference r = - let (loc,qid) = qualid_of_reference r in + let {loc;v=qid} = qualid_of_reference r in TacCall (Loc.tag ?loc (ArgArg (loc,Tacenv.locate_tactic qid),[])) let intern_isolated_tactic_reference strict ist r = @@ -135,12 +135,12 @@ let intern_isolated_tactic_reference strict ist r = try ConstrMayEval (ConstrTerm (intern_constr_reference strict ist r)) with Not_found -> (* Reference not found *) - error_global_not_found (snd (qualid_of_reference r)) + error_global_not_found (qualid_of_reference r) (* Internalize an applied tactic reference *) let intern_applied_global_tactic_reference r = - let (loc,qid) = qualid_of_reference r in + let {loc;v=qid} = qualid_of_reference r in ArgArg (loc,Tacenv.locate_tactic qid) let intern_applied_tactic_reference ist r = @@ -151,7 +151,7 @@ let intern_applied_tactic_reference ist r = try intern_applied_global_tactic_reference r with Not_found -> (* Reference not found *) - error_global_not_found (snd (qualid_of_reference r)) + error_global_not_found (qualid_of_reference r) (* Intern a reference parsed in a non-tactic entry *) @@ -167,12 +167,12 @@ let intern_non_tactic_reference strict ist r = with Not_found -> (* By convention, use IntroIdentifier for unbound ident, when not in a def *) match r with - | Ident (loc,id) when not strict -> - let ipat = in_gen (glbwit wit_intro_pattern) (loc, IntroNaming (IntroIdentifier id)) in + | {loc;v=Ident id} when not strict -> + let ipat = in_gen (glbwit wit_intro_pattern) (make ?loc @@ IntroNaming (IntroIdentifier id)) in TacGeneric ipat | _ -> (* Reference not found *) - error_global_not_found (snd (qualid_of_reference r)) + error_global_not_found (qualid_of_reference r) let intern_message_token ist = function | (MsgString _ | MsgInt _ as x) -> x @@ -209,8 +209,8 @@ let intern_constr = intern_constr_gen false false let intern_type = intern_constr_gen false true (* Globalize bindings *) -let intern_binding ist (loc,(b,c)) = - (loc,(intern_binding_name ist b,intern_constr ist c)) +let intern_binding ist = map (fun (b,c) -> + intern_binding_name ist b,intern_constr ist c) let intern_bindings ist = function | NoBindings -> NoBindings @@ -223,12 +223,12 @@ let intern_constr_with_bindings ist (c,bl) = let intern_constr_with_bindings_arg ist (clear,c) = (clear,intern_constr_with_bindings ist c) -let rec intern_intro_pattern lf ist = function - | loc, IntroNaming pat -> - loc, IntroNaming (intern_intro_pattern_naming lf ist pat) - | loc, IntroAction pat -> - loc, IntroAction (intern_intro_pattern_action lf ist pat) - | loc, IntroForthcoming _ as x -> x +let rec intern_intro_pattern lf ist = map (function + | IntroNaming pat -> + IntroNaming (intern_intro_pattern_naming lf ist pat) + | IntroAction pat -> + IntroAction (intern_intro_pattern_action lf ist pat) + | IntroForthcoming _ as x -> x) and intern_intro_pattern_naming lf ist = function | IntroIdentifier id -> @@ -239,12 +239,12 @@ and intern_intro_pattern_naming lf ist = function and intern_intro_pattern_action lf ist = function | IntroOrAndPattern l -> - IntroOrAndPattern (intern_or_and_intro_pattern lf ist l) + IntroOrAndPattern (intern_or_and_intro_pattern lf ist l) | IntroInjection l -> - IntroInjection (List.map (intern_intro_pattern lf ist) l) + IntroInjection (List.map (intern_intro_pattern lf ist) l) | IntroWildcard | IntroRewrite _ as x -> x - | IntroApplyOn ((loc,c),pat) -> - IntroApplyOn ((loc,intern_constr ist c), intern_intro_pattern lf ist pat) + | IntroApplyOn ({loc;v=c},pat) -> + IntroApplyOn (make ?loc @@ intern_constr ist c, intern_intro_pattern lf ist pat) and intern_or_and_intro_pattern lf ist = function | IntroAndPattern l -> @@ -256,10 +256,10 @@ let intern_or_and_intro_pattern_loc lf ist = function | ArgVar {v=id} as x -> if find_var id ist then x else user_err Pp.(str "Disjunctive/conjunctive introduction pattern expected.") - | ArgArg (loc,l) -> ArgArg (loc,intern_or_and_intro_pattern lf ist l) + | ArgArg ll -> ArgArg (map (fun l -> intern_or_and_intro_pattern lf ist l) ll) -let intern_intro_pattern_naming_loc lf ist (loc,pat) = - (loc,intern_intro_pattern_naming lf ist pat) +let intern_intro_pattern_naming_loc lf ist = map (fun pat -> + intern_intro_pattern_naming lf ist pat) (* TODO: catch ltac vars *) let intern_destruction_arg ist = function @@ -268,15 +268,15 @@ let intern_destruction_arg ist = function | clear,ElimOnIdent {loc;v=id} -> if !strict_check then (* If in a defined tactic, no intros-until *) - let c, p = intern_constr ist (CAst.make @@ CRef (Ident (Loc.tag id), None)) in + let c, p = intern_constr ist (make @@ CRef (make @@ Ident id, None)) in match DAst.get c with - | GVar id -> clear,ElimOnIdent CAst.(make ?loc:c.loc id) + | GVar id -> clear,ElimOnIdent (make ?loc:c.loc id) | _ -> clear,ElimOnConstr ((c, p), NoBindings) else - clear,ElimOnIdent CAst.(make ?loc id) + clear,ElimOnIdent (make ?loc id) let short_name = function - | AN (Ident (loc,id)) when not !strict_check -> Some CAst.(make ?loc id) + | {v=AN {loc;v=Ident id}} when not !strict_check -> Some (make ?loc id) | _ -> None let intern_evaluable_global_reference ist r = @@ -284,21 +284,21 @@ let intern_evaluable_global_reference ist r = try evaluable_of_global_reference ist.genv (locate_global_with_alias ~head:true lqid) with Not_found -> match r with - | Ident (loc,id) when not !strict_check -> EvalVarRef id - | _ -> error_global_not_found (snd lqid) + | {loc;v=Ident id} when not !strict_check -> EvalVarRef id + | _ -> error_global_not_found lqid let intern_evaluable_reference_or_by_notation ist = function - | AN r -> intern_evaluable_global_reference ist r - | ByNotation (loc,(ntn,sc)) -> + | {v=AN r} -> intern_evaluable_global_reference ist r + | {v=ByNotation (ntn,sc);loc} -> evaluable_of_global_reference ist.genv (Notation.interp_notation_as_global_reference ?loc (function ConstRef _ | VarRef _ -> true | _ -> false) ntn sc) (* Globalize a reduction expression *) let intern_evaluable ist = function - | AN (Ident (loc,id)) when find_var id ist -> ArgVar CAst.(make ?loc id) - | AN (Ident (loc,id)) when not !strict_check && find_hyp id ist -> - ArgArg (EvalVarRef id, Some CAst.(make ?loc id)) + | {loc;v=AN {v=Ident id}} when find_var id ist -> ArgVar (make ?loc id) + | {loc;v=AN {v=Ident id}} when not !strict_check && find_hyp id ist -> + ArgArg (EvalVarRef id, Some (make ?loc id)) | r -> let e = intern_evaluable_reference_or_by_notation ist r in let na = short_name r in @@ -353,10 +353,9 @@ let intern_typed_pattern_or_ref_with_occurrences ist (l,p) = ref or a pattern seems interesting, with "head" reduction in case of an evaluable ref, and "strong" reduction in the subterm matched when a pattern *) - let loc = loc_of_smart_reference r in let r = match r with - | AN r -> r - | _ -> Qualid (loc,qualid_of_path (path_of_global (smart_global r))) in + | {v=AN r} -> r + | {loc} -> make ?loc @@ Qualid (qualid_of_path (path_of_global (smart_global r))) in let sign = { Constrintern.ltac_vars = ist.ltacvars; ltac_bound = Id.Set.empty; @@ -376,7 +375,7 @@ let intern_typed_pattern_or_ref_with_occurrences ist (l,p) = | Inl r -> interp_ref r | Inr { v = CAppExpl((None,r,None),[]) } -> (* We interpret similarly @ref and ref *) - interp_ref (AN r) + interp_ref (make @@ AN r) | Inr c -> Inr (snd (intern_typed_pattern ist ~as_type:false ~ltacvars:ist.ltacvars c))) @@ -385,13 +384,13 @@ let intern_typed_pattern_or_ref_with_occurrences ist (l,p) = let dump_glob_red_expr = function | Unfold occs -> List.iter (fun (_, r) -> try - Dumpglob.add_glob ?loc:(loc_of_or_by_notation Libnames.loc_of_reference r) + Dumpglob.add_glob ?loc:r.loc (Smartlocate.smart_global r) with e when CErrors.noncritical e -> ()) occs | Cbv grf | Lazy grf -> List.iter (fun r -> try - Dumpglob.add_glob ?loc:(loc_of_or_by_notation Libnames.loc_of_reference r) + Dumpglob.add_glob ?loc:r.loc (Smartlocate.smart_global r) with e when CErrors.noncritical e -> ()) grf.rConst | _ -> () @@ -817,7 +816,7 @@ let notation_subst bindings tac = let fold id c accu = let loc = Glob_ops.loc_of_glob_constr (fst c) in let c = ConstrMayEval (ConstrTerm c) in - (CAst.make ?loc @@ Name id, c) :: accu + (make ?loc @@ Name id, c) :: accu in let bindings = Id.Map.fold fold bindings [] in (** This is theoretically not correct due to potential variable capture, but diff --git a/plugins/ltac/tacinterp.ml b/plugins/ltac/tacinterp.ml index 991afe9c60..6a4bf577b1 100644 --- a/plugins/ltac/tacinterp.ml +++ b/plugins/ltac/tacinterp.ml @@ -247,7 +247,7 @@ let coerce_to_tactic loc id v = | _ -> fail () else fail () -let intro_pattern_of_ident id = (Loc.tag @@ IntroNaming (IntroIdentifier id)) +let intro_pattern_of_ident id = make @@ IntroNaming (IntroIdentifier id) let value_of_ident id = in_gen (topwit wit_intro_pattern) (intro_pattern_of_ident id) @@ -360,7 +360,7 @@ let interp_reference ist env sigma = function with Not_found -> try VarRef (get_id (Environ.lookup_named id env)) - with Not_found -> error_global_not_found ?loc (qualid_of_ident id) + with Not_found -> error_global_not_found (make ?loc @@ qualid_of_ident id) let try_interp_evaluable env (loc, id) = let v = Environ.lookup_named id env in @@ -376,14 +376,14 @@ let interp_evaluable ist env sigma = function with Not_found -> match r with | EvalConstRef _ -> r - | _ -> error_global_not_found ?loc (qualid_of_ident id) + | _ -> error_global_not_found (make ?loc @@ qualid_of_ident id) end | ArgArg (r,None) -> r | ArgVar {loc;v=id} -> try try_interp_ltac_var (coerce_to_evaluable_ref env sigma) ist (Some (env,sigma)) (make ?loc id) with Not_found -> try try_interp_evaluable env (loc, id) - with Not_found -> error_global_not_found ?loc (qualid_of_ident id) + with Not_found -> error_global_not_found (make ?loc @@ qualid_of_ident id) (* Interprets an hypothesis name *) let interp_occurrences ist occs = @@ -423,7 +423,7 @@ let extract_ltac_constr_values ist env = could barely be defined as a feature... *) (* Extract the identifier list from lfun: join all branches (what to do else?)*) -let rec intropattern_ids accu (loc,pat) = match pat with +let rec intropattern_ids accu {loc;v=pat} = match pat with | IntroNaming (IntroIdentifier id) -> Id.Set.add id accu | IntroAction (IntroOrAndPattern (IntroAndPattern l)) -> List.fold_left intropattern_ids accu l @@ -431,7 +431,7 @@ let rec intropattern_ids accu (loc,pat) = match pat with List.fold_left intropattern_ids accu (List.flatten ll) | IntroAction (IntroInjection l) -> List.fold_left intropattern_ids accu l - | IntroAction (IntroApplyOn ((_,c),pat)) -> intropattern_ids accu pat + | IntroAction (IntroApplyOn ({v=c},pat)) -> intropattern_ids accu pat | IntroNaming (IntroAnonymous | IntroFresh _) | IntroAction (IntroWildcard | IntroRewrite _) | IntroForthcoming _ -> accu @@ -439,9 +439,9 @@ let rec intropattern_ids accu (loc,pat) = match pat with let extract_ids ids lfun accu = let fold id v accu = if has_type v (topwit wit_intro_pattern) then - let (_, ipat) = out_gen (topwit wit_intro_pattern) v in + let {v=ipat} = out_gen (topwit wit_intro_pattern) v in if Id.List.mem id ids then accu - else intropattern_ids accu (Loc.tag ipat) + else intropattern_ids accu (make ipat) else accu in Id.Map.fold fold lfun accu @@ -642,7 +642,7 @@ let interp_closed_typed_pattern_with_occurrences ist env sigma (occs, a) = Inr (pattern_of_constr env sigma (EConstr.to_constr sigma c)) in (try try_interp_ltac_var coerce_eval_ref_or_constr ist (Some (env,sigma)) (make ?loc id) with Not_found -> - error_global_not_found ?loc (qualid_of_ident id)) + error_global_not_found (make ?loc @@ qualid_of_ident id)) | Inl (ArgArg _ as b) -> Inl (interp_evaluable ist env sigma b) | Inr c -> Inr (interp_typed_pattern ist env sigma c) in interp_occurrences ist occs, p @@ -762,15 +762,15 @@ let interp_message ist l = Ftactic.List.map (interp_message_token ist) l >>= fun l -> Ftactic.return (prlist_with_sep spc (fun x -> x) l) -let rec interp_intro_pattern ist env sigma = function - | loc, IntroAction pat -> - let (sigma,pat) = interp_intro_pattern_action ist env sigma pat in - sigma, (loc, IntroAction pat) - | loc, IntroNaming (IntroIdentifier id) -> - sigma, (loc, interp_intro_pattern_var loc ist env sigma id) - | loc, IntroNaming pat -> - sigma, (loc, IntroNaming (interp_intro_pattern_naming loc ist env sigma pat)) - | loc, IntroForthcoming _ as x -> sigma, x +let rec interp_intro_pattern ist env sigma = with_loc_val (fun ?loc -> function + | IntroAction pat -> + let (sigma,pat) = interp_intro_pattern_action ist env sigma pat in + sigma, make ?loc @@ IntroAction pat + | IntroNaming (IntroIdentifier id) -> + sigma, make ?loc @@ interp_intro_pattern_var loc ist env sigma id + | IntroNaming pat -> + sigma, make ?loc @@ IntroNaming (interp_intro_pattern_naming loc ist env sigma pat) + | IntroForthcoming _ as x -> sigma, make ?loc x) and interp_intro_pattern_naming loc ist env sigma = function | IntroFresh id -> IntroFresh (interp_ident ist env sigma id) @@ -784,10 +784,10 @@ and interp_intro_pattern_action ist env sigma = function | IntroInjection l -> let sigma,l = interp_intro_pattern_list_as_list ist env sigma l in sigma, IntroInjection l - | IntroApplyOn ((loc,c),ipat) -> + | IntroApplyOn ({loc;v=c},ipat) -> let c env sigma = interp_open_constr ist env sigma c in let sigma,ipat = interp_intro_pattern ist env sigma ipat in - sigma, IntroApplyOn ((loc,c),ipat) + sigma, IntroApplyOn (make ?loc c,ipat) | IntroWildcard | IntroRewrite _ as x -> sigma, x and interp_or_and_intro_pattern ist env sigma = function @@ -799,7 +799,7 @@ and interp_or_and_intro_pattern ist env sigma = function sigma, IntroOrPattern ll and interp_intro_pattern_list_as_list ist env sigma = function - | [loc,IntroNaming (IntroIdentifier id)] as l -> + | [{loc;v=IntroNaming (IntroIdentifier id)}] as l -> (try sigma, coerce_to_intro_pattern_list ?loc env sigma (Id.Map.find id ist.lfun) with Not_found | CannotCoerceTo _ -> List.fold_left_map (interp_intro_pattern ist env) sigma l) @@ -807,18 +807,18 @@ and interp_intro_pattern_list_as_list ist env sigma = function let interp_intro_pattern_naming_option ist env sigma = function | None -> None - | Some (loc,pat) -> Some (loc, interp_intro_pattern_naming loc ist env sigma pat) + | Some lpat -> Some (map_with_loc (fun ?loc pat -> interp_intro_pattern_naming loc ist env sigma pat) lpat) let interp_or_and_intro_pattern_option ist env sigma = function | None -> sigma, None | Some (ArgVar {loc;v=id}) -> (match interp_intro_pattern_var loc ist env sigma id with - | IntroAction (IntroOrAndPattern l) -> sigma, Some (loc,l) + | IntroAction (IntroOrAndPattern l) -> sigma, Some (make ?loc l) | _ -> user_err ?loc (str "Cannot coerce to a disjunctive/conjunctive pattern.")) - | Some (ArgArg (loc,l)) -> + | Some (ArgArg {loc;v=l}) -> let sigma,l = interp_or_and_intro_pattern ist env sigma l in - sigma, Some (loc,l) + sigma, Some (make ?loc l) let interp_intro_pattern_option ist env sigma = function | None -> sigma, None @@ -846,9 +846,9 @@ let interp_declared_or_quantified_hypothesis ist env sigma = function (coerce_to_decl_or_quant_hyp env sigma) ist (Some (env,sigma)) (make id) with Not_found -> NamedHyp id -let interp_binding ist env sigma (loc,(b,c)) = +let interp_binding ist env sigma {loc;v=(b,c)} = let sigma, c = interp_open_constr ist env sigma c in - sigma, (loc,(interp_binding_name ist env sigma b,c)) + sigma, (make ?loc (interp_binding_name ist env sigma b,c)) let interp_bindings ist env sigma = function | NoBindings -> @@ -873,7 +873,7 @@ let interp_open_constr_with_bindings ist env sigma (c,bl) = let loc_of_bindings = function | NoBindings -> None | ImplicitBindings l -> loc_of_glob_constr (fst (List.last l)) -| ExplicitBindings l -> fst (List.last l) +| ExplicitBindings l -> (List.last l).loc let interp_open_constr_with_bindings_loc ist ((c,_),bl as cb) = let loc1 = loc_of_glob_constr c in @@ -896,7 +896,7 @@ let interp_destruction_arg ist gl arg = in let try_cast_id id' = if Tactics.is_quantified_hypothesis id' gl - then keep,ElimOnIdent CAst.(make ?loc id') + then keep,ElimOnIdent (make ?loc id') else (keep, ElimOnConstr begin fun env sigma -> try (sigma, (constr_of_id env id', NoBindings)) @@ -911,7 +911,7 @@ let interp_destruction_arg ist gl arg = if has_type v (topwit wit_intro_pattern) then let v = out_gen (topwit wit_intro_pattern) v in match v with - | _, IntroNaming (IntroIdentifier id) -> try_cast_id id + | {v=IntroNaming (IntroIdentifier id)} -> try_cast_id id | _ -> error () else if has_type v (topwit wit_var) then let id = out_gen (topwit wit_var) v in @@ -924,9 +924,9 @@ let interp_destruction_arg ist gl arg = with Not_found -> (* We were in non strict (interactive) mode *) if Tactics.is_quantified_hypothesis id gl then - keep,ElimOnIdent CAst.(make ?loc id) + keep,ElimOnIdent (make ?loc id) else - let c = (DAst.make ?loc @@ GVar id,Some (CAst.make @@ CRef (Ident (loc,id),None))) in + let c = (DAst.make ?loc @@ GVar id,Some (make @@ CRef (make ?loc @@ Ident id,None))) in let f env sigma = let (sigma,c) = interp_open_constr ist env sigma c in (sigma, (c,NoBindings)) @@ -1221,7 +1221,7 @@ and interp_tacarg ist arg : Val.t Ftactic.t = | TacFreshId l -> Ftactic.enter begin fun gl -> let id = interp_fresh_id ist (pf_env gl) (project gl) l in - Ftactic.return (in_gen (topwit wit_intro_pattern) (Loc.tag @@ IntroNaming (IntroIdentifier id))) + Ftactic.return (in_gen (topwit wit_intro_pattern) (make @@ IntroNaming (IntroIdentifier id))) end | TacPretype c -> Ftactic.enter begin fun gl -> @@ -1576,7 +1576,7 @@ and interp_atomic ist tac : unit Proofview.tactic = let sigma = project gl in let l = List.map (fun (k,c) -> let loc, f = interp_open_constr_with_bindings_loc ist c in - (k,(loc,f))) cb + (k,(make ?loc f))) cb in let sigma,tac = match cl with | None -> sigma, Tactics.apply_with_delayed_bindings_gen a ev l @@ -1677,7 +1677,7 @@ and interp_atomic ist tac : unit Proofview.tactic = let flags = open_constr_use_classes_flags () in let (sigma,c_interp) = interp_open_constr ~flags ist env sigma c in let let_tac b na c cl eqpat = - let id = Option.default (Loc.tag IntroAnonymous) eqpat in + let id = Option.default (make IntroAnonymous) eqpat in let with_eq = if b then None else Some (true,id) in Tactics.letin_tac with_eq na c None cl in @@ -1689,7 +1689,7 @@ and interp_atomic ist tac : unit Proofview.tactic = else (* We try to keep the pattern structure as much as possible *) let let_pat_tac b na c cl eqpat = - let id = Option.default (Loc.tag IntroAnonymous) eqpat in + let id = Option.default (make IntroAnonymous) eqpat in let with_eq = if b then None else Some (true,id) in Tactics.letin_pat_tac ev with_eq na c cl in diff --git a/plugins/ltac/tacsubst.ml b/plugins/ltac/tacsubst.ml index 927139c1af..a1d8b087e8 100644 --- a/plugins/ltac/tacsubst.ml +++ b/plugins/ltac/tacsubst.ml @@ -33,8 +33,9 @@ let subst_glob_constr_and_expr subst (c, e) = let subst_glob_constr = subst_glob_constr_and_expr (* shortening *) -let subst_binding subst (loc,(b,c)) = - (loc,(subst_quantified_hypothesis subst b,subst_glob_constr subst c)) +let subst_binding subst = + CAst.map (fun (b,c) -> + subst_quantified_hypothesis subst b,subst_glob_constr subst c) let subst_bindings subst = function | NoBindings -> NoBindings @@ -47,13 +48,13 @@ let subst_glob_with_bindings subst (c,bl) = let subst_glob_with_bindings_arg subst (clear,c) = (clear,subst_glob_with_bindings subst c) -let rec subst_intro_pattern subst = function - | loc,IntroAction p -> loc, IntroAction (subst_intro_pattern_action subst p) - | loc, IntroNaming _ | loc, IntroForthcoming _ as x -> x +let rec subst_intro_pattern subst = CAst.map (function + | IntroAction p -> IntroAction (subst_intro_pattern_action subst p) + | IntroNaming _ | IntroForthcoming _ as x -> x) -and subst_intro_pattern_action subst = function - | IntroApplyOn ((loc,t),pat) -> - IntroApplyOn ((loc,subst_glob_constr subst t),subst_intro_pattern subst pat) +and subst_intro_pattern_action subst = let open CAst in function + | IntroApplyOn ({loc;v=t},pat) -> + IntroApplyOn (make ?loc @@ subst_glob_constr subst t,subst_intro_pattern subst pat) | IntroOrAndPattern l -> IntroOrAndPattern (subst_intro_or_and_pattern subst l) | IntroInjection l -> IntroInjection (List.map (subst_intro_pattern subst) l) diff --git a/plugins/micromega/coq_micromega.ml b/plugins/micromega/coq_micromega.ml index 52822e444a..168105e8fd 100644 --- a/plugins/micromega/coq_micromega.ml +++ b/plugins/micromega/coq_micromega.ml @@ -1991,7 +1991,7 @@ let micromega_gen let intro_vars = Tacticals.New.tclTHENLIST (List.map intro vars) in let intro_props = Tacticals.New.tclTHENLIST (List.map intro props) in - let ipat_of_name id = Some (Loc.tag @@ Misctypes.IntroNaming (Misctypes.IntroIdentifier id)) in + let ipat_of_name id = Some (CAst.make @@ Misctypes.IntroNaming (Misctypes.IntroIdentifier id)) in let goal_name = fresh_id Id.Set.empty (Names.Id.of_string "__arith") gl in let env' = List.map (fun (id,i) -> EConstr.mkVar id,i) vars in @@ -2106,7 +2106,7 @@ let micromega_genr prover tac = let intro_vars = Tacticals.New.tclTHENLIST (List.map intro vars) in let intro_props = Tacticals.New.tclTHENLIST (List.map intro props) in - let ipat_of_name id = Some (Loc.tag @@ Misctypes.IntroNaming (Misctypes.IntroIdentifier id)) in + let ipat_of_name id = Some (CAst.make @@ Misctypes.IntroNaming (Misctypes.IntroIdentifier id)) in let goal_name = fresh_id Id.Set.empty (Names.Id.of_string "__arith") gl in let env' = List.map (fun (id,i) -> EConstr.mkVar id,i) vars in diff --git a/plugins/setoid_ring/newring_ast.ml b/plugins/setoid_ring/newring_ast.ml new file mode 100644 index 0000000000..3eb68b5189 --- /dev/null +++ b/plugins/setoid_ring/newring_ast.ml @@ -0,0 +1,67 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +open Constr +open Libnames +open Constrexpr + +open Ltac_plugin +open Tacexpr + +type 'constr coeff_spec = + Computational of 'constr (* equality test *) + | Abstract (* coeffs = Z *) + | Morphism of 'constr (* general morphism *) + +type cst_tac_spec = + CstTac of raw_tactic_expr + | Closed of reference list + +type 'constr ring_mod = + Ring_kind of 'constr coeff_spec + | Const_tac of cst_tac_spec + | Pre_tac of raw_tactic_expr + | Post_tac of raw_tactic_expr + | Setoid of constr_expr * constr_expr + | Pow_spec of cst_tac_spec * constr_expr + (* Syntaxification tactic , correctness lemma *) + | Sign_spec of constr_expr + | Div_spec of constr_expr + +type 'constr field_mod = + Ring_mod of 'constr ring_mod + | Inject of constr_expr + +type ring_info = + { ring_carrier : types; + ring_req : constr; + ring_setoid : constr; + ring_ext : constr; + ring_morph : constr; + ring_th : constr; + ring_cst_tac : glob_tactic_expr; + ring_pow_tac : glob_tactic_expr; + ring_lemma1 : constr; + ring_lemma2 : constr; + ring_pre_tac : glob_tactic_expr; + ring_post_tac : glob_tactic_expr } + +type field_info = + { field_carrier : types; + field_req : constr; + field_cst_tac : glob_tactic_expr; + field_pow_tac : glob_tactic_expr; + field_ok : constr; + field_simpl_eq_ok : constr; + field_simpl_ok : constr; + field_simpl_eq_in_ok : constr; + field_cond : constr; + field_pre_tac : glob_tactic_expr; + field_post_tac : glob_tactic_expr } diff --git a/plugins/setoid_ring/newring_ast.mli b/plugins/setoid_ring/newring_ast.mli index 226c65125e..3eb68b5189 100644 --- a/plugins/setoid_ring/newring_ast.mli +++ b/plugins/setoid_ring/newring_ast.mli @@ -11,6 +11,8 @@ open Constr open Libnames open Constrexpr + +open Ltac_plugin open Tacexpr type 'constr coeff_spec = diff --git a/plugins/setoid_ring/newring_plugin.mlpack b/plugins/setoid_ring/newring_plugin.mlpack index 23663b4090..5aa79b5868 100644 --- a/plugins/setoid_ring/newring_plugin.mlpack +++ b/plugins/setoid_ring/newring_plugin.mlpack @@ -1,2 +1,3 @@ +Newring_ast Newring G_newring diff --git a/plugins/ssr/ssrcommon.ml b/plugins/ssr/ssrcommon.ml index f049963f1c..19abf6780c 100644 --- a/plugins/ssr/ssrcommon.ml +++ b/plugins/ssr/ssrcommon.ml @@ -853,7 +853,7 @@ open Util (** Constructors for constr_expr *) let mkCProp loc = CAst.make ?loc @@ CSort GProp let mkCType loc = CAst.make ?loc @@ CSort (GType []) -let mkCVar ?loc id = CAst.make ?loc @@ CRef (Ident (Loc.tag ?loc id), None) +let mkCVar ?loc id = CAst.make ?loc @@ CRef (CAst.make ?loc @@ Ident id, None) let rec mkCHoles ?loc n = if n <= 0 then [] else (CAst.make ?loc @@ CHole (None, IntroAnonymous, None)) :: mkCHoles ?loc (n - 1) let mkCHole loc = CAst.make ?loc @@ CHole (None, IntroAnonymous, None) diff --git a/plugins/ssr/ssrparser.ml4 b/plugins/ssr/ssrparser.ml4 index 2bed8b624b..0d82a9f096 100644 --- a/plugins/ssr/ssrparser.ml4 +++ b/plugins/ssr/ssrparser.ml4 @@ -541,7 +541,7 @@ END (* ipats *) -let remove_loc = snd +let remove_loc x = x.CAst.v let ipat_of_intro_pattern p = Misctypes.( let rec ipat_of_intro_pattern = function @@ -608,14 +608,15 @@ let interp_intro_pattern = interp_wit wit_intro_pattern let interp_introid ist gl id = Misctypes.( try IntroNaming (IntroIdentifier (hyp_id (snd (interp_hyp ist gl (SsrHyp (Loc.tag id)))))) - with _ -> snd(snd (interp_intro_pattern ist gl (Loc.tag @@ IntroNaming (IntroIdentifier id)))) + with _ -> (snd (interp_intro_pattern ist gl (CAst.make @@ IntroNaming (IntroIdentifier id)))).CAst.v ) let get_intro_id = function | IntroNaming (IntroIdentifier id) -> id | _ -> assert false -let rec add_intro_pattern_hyps (loc, ipat) hyps = Misctypes.( +let rec add_intro_pattern_hyps ipat hyps = Misctypes.( + let {CAst.loc=loc;v=ipat} = ipat in match ipat with | IntroNaming (IntroIdentifier id) -> if not_section_id id then SsrHyp (loc, id) :: hyps else @@ -646,7 +647,7 @@ let interp_ipat ist gl = | IPatClear clr -> let add_hyps (SsrHyp (loc, id) as hyp) hyps = if not (ltacvar id) then hyp :: hyps else - add_intro_pattern_hyps (loc, (interp_introid ist gl id)) hyps in + add_intro_pattern_hyps CAst.(make ?loc (interp_introid ist gl id)) hyps in let clr' = List.fold_right add_hyps clr [] in check_hyps_uniq [] clr'; IPatClear clr' | IPatCase(iorpat) -> @@ -1164,7 +1165,7 @@ ARGUMENT EXTEND ssrbvar TYPED AS constr PRINTED BY pr_ssrbvar END let bvar_lname = let open CAst in function - | { v = CRef (Ident (loc, id), _) } -> CAst.make ?loc @@ Name id + | { v = CRef ({loc;v=Ident id}, _) } -> CAst.make ?loc @@ Name id | { loc = loc } -> CAst.make ?loc Anonymous let pr_ssrbinder prc _ _ (_, c) = prc c @@ -1256,7 +1257,7 @@ END let pr_ssrfixfwd _ _ _ (id, fwd) = str " fix " ++ pr_id id ++ pr_fwd fwd let bvar_locid = function - | { CAst.v = CRef (Ident (loc, id), _) } -> CAst.make ?loc id + | { CAst.v = CRef ({CAst.loc=loc;v=Ident id}, _) } -> CAst.make ?loc id | _ -> CErrors.user_err (Pp.str "Missing identifier after \"(co)fix\"") diff --git a/plugins/ssr/ssrparser.mli b/plugins/ssr/ssrparser.mli index 1305503888..2ac7c7e264 100644 --- a/plugins/ssr/ssrparser.mli +++ b/plugins/ssr/ssrparser.mli @@ -10,6 +10,8 @@ (* This file is (C) Copyright 2006-2015 Microsoft Corporation and Inria. *) +open Ltac_plugin + val ssrtacarg : Tacexpr.raw_tactic_expr Pcoq.Gram.entry val wit_ssrtacarg : (Tacexpr.raw_tactic_expr, Tacexpr.glob_tactic_expr, Geninterp.Val.t) Genarg.genarg_type val pr_ssrtacarg : 'a -> 'b -> (Notation_term.tolerability -> 'c) -> 'c diff --git a/plugins/ssr/ssrtacticals.mli b/plugins/ssr/ssrtacticals.mli index 84b184713b..a5636ad0f0 100644 --- a/plugins/ssr/ssrtacticals.mli +++ b/plugins/ssr/ssrtacticals.mli @@ -10,21 +10,23 @@ (* This file is (C) Copyright 2006-2015 Microsoft Corporation and Inria. *) +open Ltac_plugin +open Ssrmatching_plugin val tclSEQAT : - Ltac_plugin.Tacinterp.interp_sign -> - Ltac_plugin.Tacinterp.Value.t -> + Tacinterp.interp_sign -> + Tacinterp.Value.t -> Ssrast.ssrdir -> int Misctypes.or_var * - (('a * Ltac_plugin.Tacinterp.Value.t option list) * - Ltac_plugin.Tacinterp.Value.t option) -> + (('a * Tacinterp.Value.t option list) * + Tacinterp.Value.t option) -> Tacmach.tactic val tclCLAUSES : unit Proofview.tactic -> (Ssrast.ssrhyps * ((Ssrast.ssrhyp_or_id * string) * - Ssrmatching_plugin.Ssrmatching.cpattern option) + Ssrmatching.cpattern option) option) list * Ssrast.ssrclseq -> unit Proofview.tactic @@ -34,12 +36,12 @@ val hinttac : bool -> bool * Tacinterp.Value.t option list -> Ssrast.v82tac val ssrdotac : - Ltac_plugin.Tacinterp.interp_sign -> + Tacinterp.interp_sign -> ((int Misctypes.or_var * Ssrast.ssrmmod) * - (bool * Ltac_plugin.Tacinterp.Value.t option list)) * + (bool * Tacinterp.Value.t option list)) * ((Ssrast.ssrhyps * ((Ssrast.ssrhyp_or_id * string) * - Ssrmatching_plugin.Ssrmatching.cpattern option) + Ssrmatching.cpattern option) option) list * Ssrast.ssrclseq) -> Goal.goal Evd.sigma -> Goal.goal list Evd.sigma diff --git a/plugins/ssr/ssrvernac.ml4 b/plugins/ssr/ssrvernac.ml4 index c3b6a7c59f..05dbf0a86d 100644 --- a/plugins/ssr/ssrvernac.ml4 +++ b/plugins/ssr/ssrvernac.ml4 @@ -432,7 +432,7 @@ END let interp_modloc mr = let interp_mod (_, mr) = - let (loc, qid) = qualid_of_reference mr in + let {CAst.loc=loc; v=qid} = qualid_of_reference mr in try Nametab.full_name_module qid with Not_found -> CErrors.user_err ?loc (str "No Module " ++ pr_qualid qid) in let mr_out, mr_in = List.partition fst mr in @@ -565,9 +565,9 @@ GEXTEND Gram gallina_ext: (* Canonical structure *) [[ IDENT "Canonical"; qid = Constr.global -> - Vernacexpr.VernacCanonical (AN qid) + Vernacexpr.VernacCanonical (CAst.make @@ AN qid) | IDENT "Canonical"; ntn = Prim.by_notation -> - Vernacexpr.VernacCanonical (ByNotation ntn) + Vernacexpr.VernacCanonical (CAst.make @@ ByNotation ntn) | IDENT "Canonical"; qid = Constr.global; d = G_vernac.def_body -> let s = coerce_reference_to_id qid in diff --git a/plugins/ssrmatching/ssrmatching.ml4 b/plugins/ssrmatching/ssrmatching.ml4 index 33b18001c9..6a1be9db06 100644 --- a/plugins/ssrmatching/ssrmatching.ml4 +++ b/plugins/ssrmatching/ssrmatching.ml4 @@ -131,8 +131,8 @@ let add_genarg tag pr = (** Constructors for cast type *) let dC t = CastConv t (** Constructors for constr_expr *) -let isCVar = function { CAst.v = CRef (Ident _, _) } -> true | _ -> false -let destCVar = function { CAst.v = CRef (Ident (_, id), _) } -> id | _ -> +let isCVar = function { CAst.v = CRef ({CAst.v=Ident _},_) } -> true | _ -> false +let destCVar = function { CAst.v = CRef ({CAst.v=Ident id},_) } -> id | _ -> CErrors.anomaly (str"not a CRef.") let isGLambda c = match DAst.get c with GLambda (Name _, _, _, _) -> true | _ -> false let destGLambda c = match DAst.get c with GLambda (Name id, _, _, c) -> (id, c) @@ -1012,8 +1012,8 @@ type pattern = Evd.evar_map * (constr, constr) ssrpattern let id_of_cpattern (_, (c1, c2), _) = let open CAst in match DAst.get c1, c2 with - | _, Some { v = CRef (Ident (_, x), _) } -> Some x - | _, Some { v = CAppExpl ((_, Ident (_, x), _), []) } -> Some x + | _, Some { v = CRef ({CAst.v=Ident x}, _) } -> Some x + | _, Some { v = CAppExpl ((_, {CAst.v=Ident x}, _), []) } -> Some x | GRef (VarRef x, _), None -> Some x | _ -> None let id_of_Cterm t = match id_of_cpattern t with diff --git a/plugins/ssrmatching/ssrmatching.mli b/plugins/ssrmatching/ssrmatching.mli index 07d0f97575..c55081e0f7 100644 --- a/plugins/ssrmatching/ssrmatching.mli +++ b/plugins/ssrmatching/ssrmatching.mli @@ -3,11 +3,13 @@ open Goal open Genarg -open Tacexpr open Environ open Evd open Constr +open Ltac_plugin +open Tacexpr + (** ******** Small Scale Reflection pattern matching facilities ************* *) (** Pattern parsing *) diff --git a/pretyping/cases.ml b/pretyping/cases.ml index 10e2592094..a5b7a9e6f0 100644 --- a/pretyping/cases.ml +++ b/pretyping/cases.ml @@ -347,7 +347,7 @@ let unify_tomatch_with_patterns evdref env loc typ pats realnames = let find_tomatch_tycon evdref env loc = function (* Try if some 'in I ...' is present and can be used as a constraint *) - | Some (_,(ind,realnal)) -> + | Some {CAst.v=(ind,realnal)} -> mk_tycon (inductive_template evdref env loc ind),Some (List.rev realnal) | None -> empty_tycon,None @@ -1565,7 +1565,7 @@ substituer après par les initiaux *) * and linearizing the _ patterns. * Syntactic correctness has already been done in constrintern *) let matx_of_eqns env eqns = - let build_eqn (loc,(ids,initial_lpat,initial_rhs)) = + let build_eqn {CAst.loc;v=(ids,initial_lpat,initial_rhs)} = let avoid = ids_of_named_context_val (named_context_val env) in let avoid = List.fold_left (fun accu id -> Id.Set.add id accu) avoid ids in let rhs = @@ -1883,8 +1883,8 @@ let extract_arity_signature ?(dolift=true) env0 lvar tomatchl tmsign = | None -> let sign = match bo with | None -> [LocalAssum (na, lift n typ)] | Some b -> [LocalDef (na, lift n b, lift n typ)] in sign,sign - | Some (loc,_) -> - user_err ?loc + | Some {CAst.loc} -> + user_err ?loc (str"Unexpected type annotation for a term of non inductive type.")) | IsInd (term,IndType(indf,realargs),_) -> let indf' = if dolift then lift_inductive_family n indf else indf in @@ -1894,7 +1894,7 @@ let extract_arity_signature ?(dolift=true) env0 lvar tomatchl tmsign = let arsign = List.map (fun d -> map_rel_decl EConstr.of_constr d) arsign in let realnal, realnal' = match t with - | Some (loc,(ind',realnal)) -> + | Some {CAst.loc;v=(ind',realnal)} -> if not (eq_ind ind ind') then user_err ?loc (str "Wrong inductive type."); if not (Int.equal nrealargs_ctxt (List.length realnal)) then diff --git a/pretyping/detyping.ml b/pretyping/detyping.ml index f98a3b0dbe..587892141c 100644 --- a/pretyping/detyping.ml +++ b/pretyping/detyping.ml @@ -71,17 +71,17 @@ let has_two_constructors lc = let isomorphic_to_tuple lc = Int.equal (Array.length lc) 1 -let encode_bool r = +let encode_bool ({CAst.loc} as r) = let (x,lc) = encode_inductive r in if not (has_two_constructors lc) then - user_err ?loc:(loc_of_reference r) ~hdr:"encode_if" + user_err ?loc ~hdr:"encode_if" (str "This type has not exactly two constructors."); x -let encode_tuple r = +let encode_tuple ({CAst.loc} as r) = let (x,lc) = encode_inductive r in if not (isomorphic_to_tuple lc) then - user_err ?loc:(loc_of_reference r) ~hdr:"encode_tuple" + user_err ?loc ~hdr:"encode_tuple" (str "This type cannot be seen as a tuple type."); x @@ -279,7 +279,7 @@ let _ = optwrite = (fun b -> print_allow_match_default_clause := b) } let rec join_eqns (ids,rhs as x) patll = function - | (loc,(ids',patl',rhs') as eqn')::rest -> + | ({CAst.loc; v=(ids',patl',rhs')} as eqn')::rest -> if not !Flags.raw_print && !print_factorize_match_patterns && List.eq_set Id.equal ids ids' && glob_constr_eq rhs rhs' then @@ -290,9 +290,9 @@ let rec join_eqns (ids,rhs as x) patll = function | [] -> patll, [] -let number_of_patterns (_gloc,(_ids,patll,_rhs)) = List.length patll +let number_of_patterns {CAst.v=(_ids,patll,_rhs)} = List.length patll -let is_default_candidate (_gloc,(ids,_patll,_rhs) ) = ids = [] +let is_default_candidate {CAst.v=(ids,_patll,_rhs)} = ids = [] let rec move_more_factorized_default_candidate_to_end eqn n = function | eqn' :: eqns -> @@ -316,22 +316,26 @@ let rec select_default_clause = function | [] -> None, [] let factorize_eqns eqns = + let open CAst in let rec aux found = function - | (loc,(ids,patl,rhs))::rest -> + | {loc;v=(ids,patl,rhs)}::rest -> let patll,rest = join_eqns (ids,rhs) [patl] rest in - aux ((loc,(ids,patll,rhs))::found) rest + aux (CAst.make ?loc (ids,patll,rhs)::found) rest | [] -> found in let eqns = aux [] (List.rev eqns) in let mk_anon patl = List.map (fun _ -> DAst.make @@ PatVar Anonymous) patl in + let open CAst in if not !Flags.raw_print && !print_allow_match_default_clause && eqns <> [] then match select_default_clause eqns with (* At least two clauses and the last one is disjunctive with no variables *) - | Some (gloc,([],patl::_::_,rhs)), (_::_ as eqns) -> eqns@[gloc,([],[mk_anon patl],rhs)] + | Some {loc=gloc;v=([],patl::_::_,rhs)}, (_::_ as eqns) -> + eqns@[CAst.make ?loc:gloc ([],[mk_anon patl],rhs)] (* Only one clause which is disjunctive with no variables: we keep at least one constructor *) (* so that it is not interpreted as a dummy "match" *) - | Some (gloc,([],patl::patl'::_,rhs)), [] -> [gloc,([],[patl;mk_anon patl'],rhs)] - | Some (_,((_::_,_,_ | _,([]|[_]),_))), _ -> assert false + | Some {loc=gloc;v=([],patl::patl'::_,rhs)}, [] -> + [CAst.make ?loc:gloc ([],[patl;mk_anon patl'],rhs)] + | Some {v=((_::_,_,_ | _,([]|[_]),_))}, _ -> assert false | None, eqns -> eqns else eqns @@ -460,7 +464,7 @@ let detype_case computable detype detype_eqns testdep avoid data p c bl = | _ -> Anonymous, typ in let aliastyp = if List.for_all (Name.equal Anonymous) nl then None - else Some (Loc.tag (indsp,nl)) in + else Some (CAst.make (indsp,nl)) in n, aliastyp, Some typ in let constructs = Array.init (Array.length bl) (fun i -> (indsp,i+1)) in @@ -726,7 +730,8 @@ and detype_eqns d flags avoid env sigma ci computable constructs consnargsl bl = try if !Flags.raw_print || not (reverse_matching ()) then raise Exit; let mat = build_tree Anonymous (snd flags) (avoid,env) sigma ci bl in - List.map (fun (ids,pat,((avoid,env),c)) -> Loc.tag (Id.Set.elements ids,[pat],detype d flags avoid env sigma c)) + List.map (fun (ids,pat,((avoid,env),c)) -> + CAst.make (Id.Set.elements ids,[pat],detype d flags avoid env sigma c)) mat with e when CErrors.noncritical e -> Array.to_list @@ -743,7 +748,7 @@ and detype_eqn d (lax,isgoal as flags) avoid env sigma constr construct_nargs br in let rec buildrec ids patlist avoid env l b = match EConstr.kind sigma b, l with - | _, [] -> Loc.tag @@ + | _, [] -> CAst.make @@ (Id.Set.elements ids, [DAst.make @@ PatCstr(constr, List.rev patlist,Anonymous)], detype d flags avoid env sigma b) @@ -934,22 +939,23 @@ let rec subst_glob_constr subst = DAst.map (function GLetIn (n,r1',t',r2') | GCases (sty,rtno,rl,branches) as raw -> + let open CAst in let rtno' = Option.smartmap (subst_glob_constr subst) rtno and rl' = List.smartmap (fun (a,x as y) -> let a' = subst_glob_constr subst a in let (n,topt) = x in let topt' = Option.smartmap - (fun ((loc,((sp,i),y) as t)) -> + (fun ({loc;v=((sp,i),y)} as t) -> let sp' = subst_mind subst sp in - if sp == sp' then t else (loc,((sp',i),y))) topt in + if sp == sp' then t else CAst.(make ?loc ((sp',i),y))) topt in if a == a' && topt == topt' then y else (a',(n,topt'))) rl and branches' = List.smartmap - (fun (loc,(idl,cpl,r) as branch) -> + (fun ({loc;v=(idl,cpl,r)} as branch) -> let cpl' = List.smartmap (subst_cases_pattern subst) cpl and r' = subst_glob_constr subst r in if cpl' == cpl && r' == r then branch else - (loc,(idl,cpl',r'))) + CAst.(make ?loc (idl,cpl',r'))) branches in if rtno' == rtno && rl' == rl && branches' == branches then raw else @@ -1014,9 +1020,9 @@ let simple_cases_matrix_of_branches ind brs = let mkPatVar na = DAst.make @@ PatVar na in let p = DAst.make @@ PatCstr ((ind,i+1),List.map mkPatVar nal,Anonymous) in let ids = List.map_filter Nameops.Name.to_option nal in - Loc.tag @@ (ids,[p],c)) + CAst.make @@ (ids,[p],c)) brs let return_type_of_predicate ind nrealargs_tags pred = let nal,p = it_destRLambda_or_LetIn_names (nrealargs_tags@[false]) pred in - (List.hd nal, Some (Loc.tag (ind, List.tl nal))), Some p + (List.hd nal, Some (CAst.make (ind, List.tl nal))), Some p diff --git a/pretyping/glob_ops.ml b/pretyping/glob_ops.ml index 2280ee2d47..74f2cefab6 100644 --- a/pretyping/glob_ops.ml +++ b/pretyping/glob_ops.ml @@ -9,6 +9,7 @@ (************************************************************************) open Util +open CAst open Names open Nameops open Globnames @@ -34,7 +35,7 @@ let set_pat_alias id = DAst.map (function let cases_predicate_names tml = List.flatten (List.map (function | (tm,(na,None)) -> [na] - | (tm,(na,Some (_,(_,nal)))) -> na::nal) tml) + | (tm,(na,Some {v=(_,nal)})) -> na::nal) tml) let mkGApp ?loc p t = DAst.make ?loc @@ match DAst.get p with @@ -79,13 +80,13 @@ let matching_var_kind_eq k1 k2 = match k1, k2 with | (FirstOrderPatVar _ | SecondOrderPatVar _), _ -> false let tomatch_tuple_eq f (c1, p1) (c2, p2) = - let eqp (_, (i1, na1)) (_, (i2, na2)) = + let eqp {CAst.v=(i1, na1)} {CAst.v=(i2, na2)} = eq_ind i1 i2 && List.equal Name.equal na1 na2 in let eq_pred (n1, o1) (n2, o2) = Name.equal n1 n2 && Option.equal eqp o1 o2 in f c1 c2 && eq_pred p1 p2 -and cases_clause_eq f (_, (id1, p1, c1)) (_, (id2, p2, c2)) = +and cases_clause_eq f {CAst.v=(id1, p1, c1)} {CAst.v=(id2, p2, c2)} = List.equal Id.equal id1 id2 && List.equal cases_pattern_eq p1 p2 && f c1 c2 let glob_decl_eq f (na1, bk1, c1, t1) (na2, bk2, c2, t2) = @@ -173,7 +174,7 @@ let map_glob_constr_left_to_right f = DAst.map (function | GCases (sty,rtntypopt,tml,pl) -> let comp1 = Option.map f rtntypopt in let comp2 = Util.List.map_left (fun (tm,x) -> (f tm,x)) tml in - let comp3 = Util.List.map_left (fun (loc,(idl,p,c)) -> (loc,(idl,p,f c))) pl in + let comp3 = Util.List.map_left (CAst.map (fun (idl,p,c) -> (idl,p,f c))) pl in GCases (sty,comp1,comp2,comp3) | GLetTuple (nal,(na,po),b,c) -> let comp1 = Option.map f po in @@ -211,7 +212,7 @@ let fold_glob_constr f acc = DAst.with_val (function | GLetIn (_,b,t,c) -> f (Option.fold_left f (f acc b) t) c | GCases (_,rtntypopt,tml,pl) -> - let fold_pattern acc (_,(idl,p,c)) = f acc c in + let fold_pattern acc {CAst.v=(idl,p,c)} = f acc c in List.fold_left fold_pattern (List.fold_left f (Option.fold_left f acc rtntypopt) (List.map fst tml)) pl @@ -244,9 +245,9 @@ let fold_glob_constr_with_binders g f v acc = DAst.(with_val (function | GLetIn (na,b,t,c) -> f (Name.fold_right g na v) (Option.fold_left (f v) (f v acc b) t) c | GCases (_,rtntypopt,tml,pl) -> - let fold_pattern acc (_,(idl,p,c)) = f (List.fold_right g idl v) acc c in + let fold_pattern acc {v=(idl,p,c)} = f (List.fold_right g idl v) acc c in let fold_tomatch (v',acc) (tm,(na,onal)) = - (Option.fold_left (fun v'' (_,(_,nal)) -> List.fold_right (Name.fold_right g) nal v'') + (Option.fold_left (fun v'' {v=(_,nal)} -> List.fold_right (Name.fold_right g) nal v'') (Name.fold_right g na v') onal, f v acc tm) in let (v',acc) = List.fold_left fold_tomatch (v,acc) tml in @@ -336,10 +337,10 @@ let bound_glob_vars = probably be no significant penalty in doing reallocation as pattern-matching expressions are usually rather small. *) -let map_inpattern_binders f ((loc,(id,nal)) as x) = +let map_inpattern_binders f ({loc;v=(id,nal)} as x) = let r = CList.smartmap f nal in if r == nal then x - else loc,(id,r) + else CAst.make ?loc (id,r) let map_tomatch_binders f ((c,(na,inp)) as x) : tomatch_tuple = let r = Option.smartmap (fun p -> map_inpattern_binders f p) inp in @@ -360,14 +361,14 @@ let rec map_case_pattern_binders f = DAst.map (function else PatCstr(c,rps,rna) ) -let map_cases_branch_binders f ((loc,(il,cll,rhs)) as x) : cases_clause = +let map_cases_branch_binders f ({CAst.loc;v=(il,cll,rhs)} as x) : cases_clause = (* spiwack: not sure if I must do something with the list of idents. It is intended to be a superset of the free variable of the right-hand side, if I understand correctly. But I'm not sure when or how they are used. *) let r = List.smartmap (fun cl -> map_case_pattern_binders f cl) cll in if r == cll then x - else loc,(il,r,rhs) + else CAst.make ?loc (il,r,rhs) let map_pattern_binders f tomatch branches = CList.smartmap (fun tm -> map_tomatch_binders f tm) tomatch, @@ -377,8 +378,8 @@ let map_pattern_binders f tomatch branches = let map_tomatch f (c,pp) : tomatch_tuple = f c , pp -let map_cases_branch f (loc,(il,cll,rhs)) : cases_clause = - loc , (il , cll , f rhs) +let map_cases_branch f = + CAst.map (fun (il,cll,rhs) -> (il , cll , f rhs)) let map_pattern f tomatch branches = List.map (fun tm -> map_tomatch f tm) tomatch, @@ -437,11 +438,11 @@ let rec rename_glob_vars l c = force @@ DAst.map_with_loc (fun ?loc -> function (* Lazy strategy: we fail if a collision with renaming occurs, rather than renaming further *) | GCases (ci,po,tomatchl,cls) -> let test_pred_pat (na,ino) = - test_na l na; Option.iter (fun (_,(_,nal)) -> List.iter (test_na l) nal) ino in + test_na l na; Option.iter (fun {v=(_,nal)} -> List.iter (test_na l) nal) ino in let test_clause idl = List.iter (test_id l) idl in let po = Option.map (rename_glob_vars l) po in let tomatchl = Util.List.map_left (fun (tm,x) -> test_pred_pat x; (rename_glob_vars l tm,x)) tomatchl in - let cls = Util.List.map_left (fun (loc,(idl,p,c)) -> test_clause idl; (loc,(idl,p,rename_glob_vars l c))) cls in + let cls = Util.List.map_left (CAst.map (fun (idl,p,c) -> test_clause idl; (idl,p,rename_glob_vars l c))) cls in GCases (ci,po,tomatchl,cls) | GLetTuple (nal,(na,po),c,b) -> List.iter (test_na l) (na::nal); diff --git a/pretyping/miscops.ml b/pretyping/miscops.ml index c5ce0496bc..0f0af5409e 100644 --- a/pretyping/miscops.ml +++ b/pretyping/miscops.ml @@ -65,7 +65,7 @@ let map_red_expr_gen f g h = function (** Mapping bindings *) let map_explicit_bindings f l = - let map (loc, (hyp, x)) = (loc, (hyp, f x)) in + let map = CAst.map (fun (hyp, x) -> (hyp, f x)) in List.map map l let map_bindings f = function diff --git a/pretyping/patternops.ml b/pretyping/patternops.ml index 3fab553cb0..dcb93bfb62 100644 --- a/pretyping/patternops.ml +++ b/pretyping/patternops.ml @@ -416,17 +416,17 @@ let rec pat_of_raw metas vars = DAst.with_loc_val (fun ?loc -> function | _ -> None in let get_ind = function - | (_,(_,[p],_))::_ -> get_ind p + | {CAst.v=(_,[p],_)}::_ -> get_ind p | _ -> None in let ind_tags,ind = match indnames with - | Some (_,(ind,nal)) -> Some (List.length nal), Some ind + | Some {CAst.v=(ind,nal)} -> Some (List.length nal), Some ind | None -> None, get_ind brs in let ext,brs = pats_of_glob_branches loc metas vars ind brs in let pred = match p,indnames with - | Some p, Some (_,(_,nal)) -> + | Some p, Some {CAst.v=(_,nal)} -> let nvars = na :: List.rev nal @ vars in rev_it_mkPLambda nal (mkPLambda na (pat_of_raw metas nvars p)) | None, _ -> PMeta None @@ -462,7 +462,7 @@ and pats_of_glob_branches loc metas vars ind brs = in let rec get_pat indexes = function | [] -> false, [] - | (loc',(_,[p], br)) :: brs -> + | {CAst.loc=loc';v=(_,[p], br)} :: brs -> begin match DAst.get p, DAst.get br, brs with | PatVar Anonymous, GHole _, [] -> true, [] (* ends with _ => _ *) @@ -484,7 +484,7 @@ and pats_of_glob_branches loc metas vars ind brs = | _ -> err ?loc:loc' (Pp.str "Non supported pattern.") end - | (loc,(_,_,_)) :: _ -> err ?loc (Pp.str "Non supported pattern.") + | {CAst.loc;v=(_,_,_)} :: _ -> err ?loc (Pp.str "Non supported pattern.") in get_pat Int.Set.empty brs diff --git a/pretyping/pretyping.ml b/pretyping/pretyping.ml index 4bcb7e459e..4962b89a09 100644 --- a/pretyping/pretyping.ml +++ b/pretyping/pretyping.ml @@ -180,20 +180,20 @@ let _ = (** Miscellaneous interpretation functions *) let interp_known_universe_level evd r = - let loc, qid = Libnames.qualid_of_reference r in + let qid = Libnames.qualid_of_reference r in try - match r with - | Libnames.Ident (loc, id) -> Evd.universe_of_name evd id + match r.CAst.v with + | Libnames.Ident id -> Evd.universe_of_name evd id | Libnames.Qualid _ -> raise Not_found with Not_found -> - let univ, k = Nametab.locate_universe qid in + let univ, k = Nametab.locate_universe qid.CAst.v in Univ.Level.make univ k let interp_universe_level_name ~anon_rigidity evd r = try evd, interp_known_universe_level evd r with Not_found -> match r with (* Qualified generated name *) - | Libnames.Qualid (loc, qid) -> + | {CAst.loc; v=Libnames.Qualid qid} -> let dp, i = Libnames.repr_qualid qid in let num = try int_of_string (Id.to_string i) @@ -206,7 +206,7 @@ let interp_universe_level_name ~anon_rigidity evd r = try Evd.add_global_univ evd level with UGraph.AlreadyDeclared -> evd in evd, level - | Libnames.Ident (loc, id) -> (* Undeclared *) + | {CAst.loc; v=Libnames.Ident id} -> (* Undeclared *) if not (is_strict_universe_declarations ()) then new_univ_level_variable ?loc ~name:id univ_rigid evd else user_err ?loc ~hdr:"interp_universe_level_name" diff --git a/pretyping/typeclasses_errors.ml b/pretyping/typeclasses_errors.ml index 6475388f9e..e10c81c24a 100644 --- a/pretyping/typeclasses_errors.ml +++ b/pretyping/typeclasses_errors.ml @@ -9,7 +9,6 @@ (************************************************************************) (*i*) -open Names open EConstr open Environ open Constrexpr @@ -20,7 +19,7 @@ type contexts = Parameters | Properties type typeclass_error = | NotAClass of constr - | UnboundMethod of global_reference * Id.t Loc.located (* Class name, method *) + | UnboundMethod of global_reference * Misctypes.lident (* Class name, method *) | MismatchedContextInstance of contexts * constr_expr list * Context.Rel.t (* found, expected *) exception TypeClassError of env * typeclass_error diff --git a/pretyping/typeclasses_errors.mli b/pretyping/typeclasses_errors.mli index ce647029f9..d98295658f 100644 --- a/pretyping/typeclasses_errors.mli +++ b/pretyping/typeclasses_errors.mli @@ -8,8 +8,6 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) -open Loc -open Names open EConstr open Environ open Constrexpr @@ -19,14 +17,14 @@ type contexts = Parameters | Properties type typeclass_error = | NotAClass of constr - | UnboundMethod of global_reference * Id.t located (** Class name, method *) + | UnboundMethod of global_reference * Misctypes.lident (** Class name, method *) | MismatchedContextInstance of contexts * constr_expr list * Context.Rel.t (** found, expected *) exception TypeClassError of env * typeclass_error val not_a_class : env -> constr -> 'a -val unbound_method : env -> global_reference -> Id.t located -> 'a +val unbound_method : env -> global_reference -> Misctypes.lident -> 'a val mismatched_ctx_inst : env -> contexts -> constr_expr list -> Context.Rel.t -> 'a diff --git a/printing/ppconstr.ml b/printing/ppconstr.ml index 8854ff8981..412a1cbb41 100644 --- a/printing/ppconstr.ml +++ b/printing/ppconstr.ml @@ -213,9 +213,9 @@ let tag_var = tag Tag.variable let pr_universe_instance l = pr_opt_no_spc (pr_univ_annot (prlist_with_sep spc pr_glob_sort_instance)) l - let pr_reference = function - | Qualid (_, qid) -> pr_qualid qid - | Ident (_, id) -> tag_var (pr_id id) + let pr_reference = CAst.with_val (function + | Qualid qid -> pr_qualid qid + | Ident id -> tag_var (pr_id id)) let pr_cref ref us = pr_reference ref ++ pr_universe_instance us @@ -565,8 +565,8 @@ let tag_var = tag Tag.variable return (p ++ prlist (pr spc (lapp,L)) l2, lapp) else return (p, lproj) - | CAppExpl ((None,Ident (_,var),us),[t]) - | CApp ((_, {CAst.v = CRef(Ident(_,var),us)}),[t,None]) + | CAppExpl ((None,{v=Ident var},us),[t]) + | CApp ((_, {v = CRef({v=Ident var},us)}),[t,None]) when Id.equal var Notation_ops.ldots_var -> return ( hov 0 (str ".." ++ pr spc (latom,E) t ++ spc () ++ str ".."), diff --git a/printing/pputils.ml b/printing/pputils.ml index 010b92f3e6..c14aa318e1 100644 --- a/printing/pputils.ml +++ b/printing/pputils.ml @@ -123,8 +123,8 @@ let pr_red_expr_env env sigma (pr_constr,pr_lconstr,pr_ref,pr_pattern) = pr_red_expr (pr_constr env sigma, pr_lconstr env sigma, pr_ref, pr_pattern env sigma) let pr_or_by_notation f = function - | AN v -> f v - | ByNotation (_,(s,sc)) -> qs s ++ pr_opt (fun sc -> str "%" ++ str sc) sc + | {CAst.loc; v=AN v} -> f v + | {CAst.loc; v=ByNotation (s,sc)} -> qs s ++ pr_opt (fun sc -> str "%" ++ str sc) sc let hov_if_not_empty n p = if Pp.ismt p then p else hov n p diff --git a/printing/ppvernac.ml b/printing/ppvernac.ml index ea1ca26fbe..5c5b7206a5 100644 --- a/printing/ppvernac.ml +++ b/printing/ppvernac.ml @@ -69,7 +69,7 @@ open Decl_kinds let pr_fqid fqid = str (string_of_fqid fqid) - let pr_lfqid (loc,fqid) = + let pr_lfqid {CAst.loc;v=fqid} = match loc with | None -> pr_fqid fqid | Some loc -> let (b,_) = Loc.unloc loc in @@ -238,7 +238,7 @@ open Decl_kinds keyword "Definition" ++ spc() ++ pr_lfqid id ++ pr_universe_decl udecl ++ str" := " ++ p | CWith_Module (id,qid) -> keyword "Module" ++ spc() ++ pr_lfqid id ++ str" := " ++ - pr_located pr_qualid qid + pr_ast pr_qualid qid let rec pr_module_ast leading_space pr_c = function | { loc ; v = CMident qid } -> diff --git a/printing/prettyp.ml b/printing/prettyp.ml index 9da94e42ae..1f17d844f7 100644 --- a/printing/prettyp.ml +++ b/printing/prettyp.ml @@ -15,6 +15,7 @@ open Pp open CErrors open Util +open CAst open Names open Nameops open Termops @@ -343,7 +344,7 @@ let register_locatable name f = exception ObjFound of logical_name let locate_any_name ref = - let (loc,qid) = qualid_of_reference ref in + let {v=qid} = qualid_of_reference ref in try Term (Nametab.locate qid) with Not_found -> try Syntactic (Nametab.locate_syndef qid) @@ -452,7 +453,7 @@ type locatable_kind = | LocAny let print_located_qualid name flags ref = - let (loc,qid) = qualid_of_reference ref in + let {v=qid} = qualid_of_reference ref in let located = match flags with | LocTerm -> locate_term qid | LocModule -> locate_modtype qid @ locate_module qid @@ -784,11 +785,11 @@ let print_full_pure_context env sigma = (* This is designed to print the contents of an opened section *) let read_sec_context r = - let loc,qid = qualid_of_reference r in + let qid = qualid_of_reference r in let dir = - try Nametab.locate_section qid + try Nametab.locate_section qid.v with Not_found -> - user_err ?loc ~hdr:"read_sec_context" (str "Unknown section.") in + user_err ?loc:qid.loc ~hdr:"read_sec_context" (str "Unknown section.") in 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 @@ -838,12 +839,12 @@ let print_any_name env sigma na udecl = let print_name env sigma na udecl = match na with - | ByNotation (loc,(ntn,sc)) -> + | {loc; v=ByNotation (ntn,sc)} -> print_any_name env sigma (Term (Notation.interp_notation_as_global_reference ?loc (fun _ -> true) ntn sc)) udecl - | AN ref -> + | {loc; v=AN ref} -> print_any_name env sigma (locate_any_name ref) udecl let print_opaque_name env sigma qid = @@ -891,12 +892,12 @@ let print_about_any ?loc env sigma k udecl = let print_about env sigma na udecl = match na with - | ByNotation (loc,(ntn,sc)) -> + | {loc;v=ByNotation (ntn,sc)} -> print_about_any ?loc env sigma (Term (Notation.interp_notation_as_global_reference ?loc (fun _ -> true) ntn sc)) udecl - | AN ref -> - print_about_any ?loc:(loc_of_reference ref) env sigma (locate_any_name ref) udecl + | {loc;v=AN ref} -> + print_about_any ?loc env sigma (locate_any_name ref) udecl (* for debug *) let inspect env sigma depth = diff --git a/printing/printer.ml b/printing/printer.ml index e50d302b33..199aa79c63 100644 --- a/printing/printer.ml +++ b/printing/printer.ml @@ -235,9 +235,9 @@ let qualid_of_global env r = let safe_gen f env sigma c = let orig_extern_ref = Constrextern.get_extern_reference () in let extern_ref ?loc vars r = - try orig_extern_ref ?loc vars r + try orig_extern_ref vars r with e when CErrors.noncritical e -> - Libnames.Qualid (Loc.tag ?loc @@ qualid_of_global env r) + CAst.make ?loc @@ Libnames.Qualid (qualid_of_global env r) in Constrextern.set_extern_reference extern_ref; try diff --git a/proofs/clenv.ml b/proofs/clenv.ml index 54ba19d6a9..03ff580ad3 100644 --- a/proofs/clenv.ml +++ b/proofs/clenv.ml @@ -416,7 +416,7 @@ let qhyp_eq h1 h2 = match h1, h2 with | _ -> false let check_bindings bl = - match List.duplicates qhyp_eq (List.map (fun x -> fst (snd x)) bl) with + match List.duplicates qhyp_eq (List.map (fun {CAst.v=x} -> fst x) bl) with | NamedHyp s :: _ -> user_err (str "The variable " ++ Id.print s ++ @@ -512,7 +512,7 @@ let clenv_match_args bl clenv = let mvs = clenv_independent clenv in check_bindings bl; List.fold_left - (fun clenv (loc,(b,c)) -> + (fun clenv {CAst.loc;v=(b,c)} -> let k = meta_of_binder clenv loc mvs b in if meta_defined clenv.evd k then if EConstr.eq_constr clenv.evd (EConstr.of_constr (fst (meta_fvalue clenv.evd k)).rebus) c then clenv @@ -710,7 +710,7 @@ let solve_evar_clause env sigma hyp_only clause = function error_not_right_number_missing_arguments len | ExplicitBindings lbind -> let () = check_bindings lbind in - let fold sigma (_, (binder, c)) = + let fold sigma {CAst.v=(binder, c)} = let ev = evar_of_binder clause.cl_holes binder in define_with_type sigma env ev c in diff --git a/proofs/miscprint.ml b/proofs/miscprint.ml index e363af644f..1a63ff6734 100644 --- a/proofs/miscprint.ml +++ b/proofs/miscprint.ml @@ -14,7 +14,7 @@ open Misctypes (** Printing of [intro_pattern] *) -let rec pr_intro_pattern prc (_,pat) = match pat with +let rec pr_intro_pattern prc {CAst.v=pat} = match pat with | IntroForthcoming true -> str "*" | IntroForthcoming false -> str "**" | IntroNaming p -> pr_intro_pattern_naming p @@ -31,7 +31,7 @@ and pr_intro_pattern_action prc = function | IntroInjection pl -> str "[=" ++ hv 0 (prlist_with_sep spc (pr_intro_pattern prc) pl) ++ str "]" - | IntroApplyOn ((_,c),pat) -> pr_intro_pattern prc pat ++ str "%" ++ prc c + | IntroApplyOn ({CAst.v=c},pat) -> pr_intro_pattern prc pat ++ str "%" ++ prc c | IntroRewrite true -> str "->" | IntroRewrite false -> str "<-" @@ -52,9 +52,9 @@ let pr_move_location pr_id = function | MoveLast -> str " at bottom" (** Printing of bindings *) -let pr_binding prc = function - | loc, (NamedHyp id, c) -> hov 1 (Names.Id.print id ++ str " := " ++ cut () ++ prc c) - | loc, (AnonHyp n, c) -> hov 1 (int n ++ str " := " ++ cut () ++ prc c) +let pr_binding prc = let open CAst in function + | {loc;v=(NamedHyp id, c)} -> hov 1 (Names.Id.print id ++ str " := " ++ cut () ++ prc c) + | {loc;v=(AnonHyp n, c)} -> hov 1 (int n ++ str " := " ++ cut () ++ prc c) let pr_bindings prc prlc = function | ImplicitBindings l -> diff --git a/proofs/miscprint.mli b/proofs/miscprint.mli index 762d7cc877..79790a277b 100644 --- a/proofs/miscprint.mli +++ b/proofs/miscprint.mli @@ -13,7 +13,7 @@ open Misctypes (** Printing of [intro_pattern] *) val pr_intro_pattern : - ('a -> Pp.t) -> 'a intro_pattern_expr Loc.located -> Pp.t + ('a -> Pp.t) -> 'a intro_pattern_expr CAst.t -> Pp.t val pr_or_and_intro_pattern : ('a -> Pp.t) -> 'a or_and_intro_pattern_expr -> Pp.t diff --git a/proofs/proof_global.ml b/proofs/proof_global.ml index 15f34ccc6b..d6c0e33414 100644 --- a/proofs/proof_global.ml +++ b/proofs/proof_global.ml @@ -207,7 +207,7 @@ let check_no_pending_proof () = let discard_gen id = pstates := List.filter (fun { pid = id' } -> not (Id.equal id id')) !pstates -let discard (loc,id) = +let discard {CAst.loc;v=id} = let n = List.length !pstates in discard_gen id; if Int.equal (List.length !pstates) n then @@ -297,13 +297,13 @@ let set_used_variables l = match entry with | LocalAssum (x,_) -> if Id.Set.mem x all_safe then orig - else (ctx, all_safe, (Loc.tag x)::to_clear) + else (ctx, all_safe, (CAst.make x)::to_clear) | LocalDef (x,bo, ty) as decl -> if Id.Set.mem x all_safe then orig else let vars = Id.Set.union (vars_of env bo) (vars_of env ty) in if Id.Set.subset vars all_safe then (decl :: ctx, Id.Set.add x all_safe, to_clear) - else (ctx, all_safe, (Loc.tag x) :: to_clear) in + else (ctx, all_safe, (CAst.make x) :: to_clear) in let ctx, _, to_clear = Environ.fold_named_context aux env ~init:(ctx,ctx_set,[]) in let to_clear = if !proof_using_auto_clear then to_clear else [] in diff --git a/proofs/proof_global.mli b/proofs/proof_global.mli index fb123fccb3..bf35fd6599 100644 --- a/proofs/proof_global.mli +++ b/proofs/proof_global.mli @@ -22,7 +22,7 @@ val check_no_pending_proof : unit -> unit val get_current_proof_name : unit -> Names.Id.t val get_all_proof_names : unit -> Names.Id.t list -val discard : Names.Id.t Loc.located -> unit +val discard : Misctypes.lident -> unit val discard_current : unit -> unit val discard_all : unit -> unit @@ -124,7 +124,7 @@ val set_endline_tactic : Genarg.glob_generic_argument -> unit * (w.r.t. type dependencies and let-ins covered by it) + a list of * ids to be cleared *) val set_used_variables : - Names.Id.t list -> Context.Named.t * Names.Id.t Loc.located list + Names.Id.t list -> Context.Named.t * Misctypes.lident list val get_used_variables : unit -> Context.Named.t option (** Get the universe declaration associated to the current proof. *) diff --git a/stm/stm.ml b/stm/stm.ml index b3da97c6e0..ad94b68077 100644 --- a/stm/stm.ml +++ b/stm/stm.ml @@ -1084,7 +1084,7 @@ let stm_vernac_interp ?proof ?route id st { verbose; loc; expr } : Vernacstate.t | VernacShow ShowScript -> ShowScript.show_script (); st (** XX we are ignoring control here *) | _ -> stm_pperr_endline Pp.(fun () -> str "interpreting " ++ Ppvernac.pr_vernac expr); - try Vernacentries.interp ?verbosely:(Some verbose) ?proof ~st (Loc.tag ?loc expr) + try Vernacentries.interp ?verbosely:(Some verbose) ?proof ~st (CAst.make ?loc expr) with e -> let e = CErrors.push e in Exninfo.iraise Hooks.(call_process_error_once e) @@ -2571,8 +2571,8 @@ let new_doc { doc_type ; iload_path; require_libs; stm_options } = let load_objs libs = let rq_file (dir, from, exp) = - let mp = Libnames.(Qualid (Loc.tag @@ qualid_of_string dir)) in - let mfrom = Option.map (fun fr -> Libnames.(Qualid (Loc.tag @@ qualid_of_string fr))) from in + let mp = CAst.make @@ Libnames.(Qualid (qualid_of_string dir)) in + let mfrom = Option.map (fun fr -> CAst.make @@ Libnames.(Qualid (qualid_of_string fr))) from in Flags.silently (Vernacentries.vernac_require mfrom exp) [mp] in List.(iter rq_file (rev libs)) in @@ -2992,7 +2992,7 @@ let parse_sentence ~doc sid pa = try match Pcoq.Gram.entry_parse Pcoq.main_entry pa with | None -> raise End_of_input - | Some (loc, cmd) -> Loc.tag ~loc cmd + | Some (loc, cmd) -> CAst.make ~loc cmd with e when CErrors.noncritical e -> let (e, info) = CErrors.push e in Exninfo.iraise (e, info)) @@ -3033,7 +3033,7 @@ let compute_indentation ?loc sid = Option.cata (fun loc -> eff_indent, len ) (0, 0) loc -let add ~doc ~ontop ?newtip verb (loc, ast) = +let add ~doc ~ontop ?newtip verb { CAst.loc; v=ast } = let cur_tip = VCS.cur_tip () in if not (Stateid.equal ontop cur_tip) then user_err ?loc ~hdr:"Stm.add" @@ -3063,7 +3063,7 @@ let query ~doc ~at ~route s = else Reach.known_state ~cache:`Yes at; try while true do - let loc, ast = parse_sentence ~doc at s in + let { CAst.loc; v=ast } = parse_sentence ~doc at s in let indentation, strlen = compute_indentation ?loc at in CWarnings.set_current_loc loc; let clas = Vernac_classifier.classify_vernac ast in diff --git a/stm/stm.mli b/stm/stm.mli index f967c98159..a8eb10fb33 100644 --- a/stm/stm.mli +++ b/stm/stm.mli @@ -80,7 +80,7 @@ val new_doc : stm_init_options -> doc * Stateid.t (* [parse_sentence sid pa] Reads a sentence from [pa] with parsing state [sid] Returns [End_of_input] if the stream ends *) val parse_sentence : doc:doc -> Stateid.t -> Pcoq.Gram.coq_parsable -> - Vernacexpr.vernac_control Loc.located + Vernacexpr.vernac_control CAst.t (* Reminder: A parsable [pa] is constructed using [Pcoq.Gram.coq_parsable stream], where [stream : char Stream.t]. *) @@ -94,7 +94,7 @@ exception End_of_input If [newtip] is provided, then the returned state id is guaranteed to be [newtip] *) val add : doc:doc -> ontop:Stateid.t -> ?newtip:Stateid.t -> - bool -> Vernacexpr.vernac_control Loc.located -> + bool -> Vernacexpr.vernac_control CAst.t -> doc * Stateid.t * [ `NewTip | `Unfocus of Stateid.t ] (* [query at ?report_with cmd] Executes [cmd] at a given state [at], diff --git a/tactics/autorewrite.ml b/tactics/autorewrite.ml index 780de89786..c3857e6b8b 100644 --- a/tactics/autorewrite.ml +++ b/tactics/autorewrite.ml @@ -85,7 +85,7 @@ let print_rewrite_hintdb env sigma bas = Pputils.pr_glb_generic (Global.env()) tac) (mt ()) h.rew_tac) (find_rewrites bas)) -type raw_rew_rule = (constr Univ.in_universe_context_set * bool * Genarg.raw_generic_argument option) Loc.located +type raw_rew_rule = (constr Univ.in_universe_context_set * bool * Genarg.raw_generic_argument option) CAst.t (* Applies all the rules of one base *) let one_base general_rewrite_maybe_in tac_main bas = @@ -275,7 +275,7 @@ let add_rew_rules base lrul = let intern tac = snd (Genintern.generic_intern ist tac) in let lrul = List.fold_left - (fun dn (loc,((c,ctx),b,t)) -> + (fun dn {CAst.loc;v=((c,ctx),b,t)} -> let sigma = Evd.merge_context_set Evd.univ_rigid sigma ctx in let info = find_applied_relation ?loc false env sigma c b in let pat = if b then info.hyp_left else info.hyp_right in diff --git a/tactics/autorewrite.mli b/tactics/autorewrite.mli index 96c08d58d7..03e9414e0f 100644 --- a/tactics/autorewrite.mli +++ b/tactics/autorewrite.mli @@ -14,7 +14,7 @@ open Constr open Equality (** Rewriting rules before tactic interpretation *) -type raw_rew_rule = (constr Univ.in_universe_context_set * bool * Genarg.raw_generic_argument option) Loc.located +type raw_rew_rule = (constr Univ.in_universe_context_set * bool * Genarg.raw_generic_argument option) CAst.t (** To add rewriting rules to a base *) val add_rew_rules : string -> raw_rew_rule list -> unit diff --git a/tactics/hints.ml b/tactics/hints.ml index f3e0619a2d..a285d6b93f 100644 --- a/tactics/hints.ml +++ b/tactics/hints.ml @@ -1279,7 +1279,7 @@ let interp_hints poly = prepare_hint true (poly,false) (Global.env()) Evd.empty (evd,c) in let fref r = let gr = global_with_alias r in - Dumpglob.add_glob ?loc:(loc_of_reference r) gr; + Dumpglob.add_glob ?loc:r.CAst.loc gr; gr in let fr r = evaluable_of_global_reference env (fref r) in let fi c = @@ -1306,7 +1306,7 @@ let interp_hints poly = let constr_hints_of_ind qid = let ind = global_inductive_with_alias qid in let mib,_ = Global.lookup_inductive ind in - Dumpglob.dump_reference ?loc:(fst (qualid_of_reference qid)) "<>" (string_of_reference qid) "ind"; + Dumpglob.dump_reference ?loc:qid.CAst.loc "<>" (string_of_reference qid) "ind"; List.init (nconstructors ind) (fun i -> let c = (ind,i+1) in let gr = ConstructRef c in diff --git a/tactics/inv.ml b/tactics/inv.ml index 280efdaece..067fc8941a 100644 --- a/tactics/inv.ml +++ b/tactics/inv.ml @@ -282,16 +282,17 @@ let generalizeRewriteIntros as_mode tac depids id = end let error_too_many_names pats = - let loc = Loc.merge_opt (fst (List.hd pats)) (fst (List.last pats)) in + let loc = Loc.merge_opt (List.hd pats).CAst.loc (List.last pats).CAst.loc in Proofview.tclENV >>= fun env -> Proofview.tclEVARMAP >>= fun sigma -> tclZEROMSG ?loc ( str "Unexpected " ++ str (String.plural (List.length pats) "introduction pattern") ++ - str ": " ++ pr_enum (Miscprint.pr_intro_pattern (fun c -> Printer.pr_constr_env env sigma (EConstr.Unsafe.to_constr (snd (c env Evd.empty))))) pats ++ + str ": " ++ pr_enum (Miscprint.pr_intro_pattern + (fun c -> Printer.pr_constr_env env sigma (EConstr.Unsafe.to_constr (snd (c env Evd.empty))))) pats ++ str ".") -let get_names (allow_conj,issimple) (loc, pat as x) = match pat with +let get_names (allow_conj,issimple) ({CAst.loc;v=pat} as x) = match pat with | IntroNaming IntroAnonymous | IntroForthcoming _ -> user_err Pp.(str "Anonymous pattern not allowed for inversion equations.") | IntroNaming (IntroFresh _) -> @@ -301,7 +302,8 @@ let get_names (allow_conj,issimple) (loc, pat as x) = match pat with | IntroAction (IntroRewrite _) -> user_err Pp.(str "Rewriting pattern not allowed for inversion equations.") | IntroAction (IntroOrAndPattern (IntroAndPattern [])) when allow_conj -> (None, []) - | IntroAction (IntroOrAndPattern (IntroAndPattern ((_,IntroNaming (IntroIdentifier id)) :: _ as l) | IntroOrPattern [(_,IntroNaming (IntroIdentifier id)) :: _ as l ])) + | IntroAction (IntroOrAndPattern (IntroAndPattern ({CAst.v=IntroNaming (IntroIdentifier id)} :: _ as l) + | IntroOrPattern [{CAst.v=IntroNaming (IntroIdentifier id)} :: _ as l])) when allow_conj -> (Some id,l) | IntroAction (IntroOrAndPattern (IntroAndPattern _)) -> if issimple then diff --git a/tactics/tacticals.ml b/tactics/tacticals.ml index 789cc35ee7..958a205a15 100644 --- a/tactics/tacticals.ml +++ b/tactics/tacticals.ml @@ -185,8 +185,8 @@ let check_or_and_pattern_size ?loc check_and names branchsigns = match names with | IntroAndPattern l -> if not (Int.equal n 1) then errn n; - let l' = List.filter (function _,IntroForthcoming _ -> true | _,IntroNaming _ | _,IntroAction _ -> false) l in - if l' != [] then errforthcoming ?loc:(fst (List.hd l')); + let l' = List.filter CAst.(function {v=IntroForthcoming _} -> true | {v=IntroNaming _} | {v=IntroAction _} -> false) l in + if l' != [] then errforthcoming ?loc:(List.hd l').CAst.loc; if check_and then let p1 = List.count (fun x -> x) branchsigns.(0) in let p2 = List.length branchsigns.(0) in @@ -194,7 +194,7 @@ let check_or_and_pattern_size ?loc check_and names branchsigns = if not (Int.equal p p1 || Int.equal p p2) then err1 p1 p2; if Int.equal p p1 then IntroAndPattern - (List.extend branchsigns.(0) (Loc.tag @@ IntroNaming IntroAnonymous) l) + (List.extend branchsigns.(0) (CAst.make @@ IntroNaming IntroAnonymous) l) else names else @@ -218,7 +218,7 @@ let get_and_check_or_and_pattern ?loc = get_and_check_or_and_pattern_gen ?loc tr let compute_induction_names_gen check_and branchletsigns = function | None -> Array.make (Array.length branchletsigns) [] - | Some (loc,names) -> + | Some {CAst.loc;v=names} -> let names = fix_empty_or_and_pattern (Array.length branchletsigns) names in get_and_check_or_and_pattern_gen check_and ?loc names branchletsigns diff --git a/tactics/tactics.ml b/tactics/tactics.ml index b111fd1ef8..df3cca1447 100644 --- a/tactics/tactics.ml +++ b/tactics/tactics.ml @@ -373,11 +373,11 @@ let default_id env sigma decl = type name_flag = | NamingAvoid of Id.Set.t | NamingBasedOn of Id.t * Id.Set.t - | NamingMustBe of Id.t Loc.located + | NamingMustBe of lident let naming_of_name = function | Anonymous -> NamingAvoid Id.Set.empty - | Name id -> NamingMustBe (Loc.tag id) + | Name id -> NamingMustBe (CAst.make id) let find_name mayrepl decl naming gl = match naming with | NamingAvoid idl -> @@ -386,7 +386,7 @@ let find_name mayrepl decl naming gl = match naming with let sigma = Tacmach.New.project gl in new_fresh_id idl (default_id env sigma decl) gl | NamingBasedOn (id,idl) -> new_fresh_id idl id gl - | NamingMustBe (loc,id) -> + | NamingMustBe {CAst.loc;v=id} -> (* When name is given, we allow to hide a global name *) let ids_of_hyps = Tacmach.New.pf_ids_set_of_hyps gl in if not mayrepl && Id.Set.mem id ids_of_hyps then @@ -480,7 +480,7 @@ let assert_before_gen b naming t = assert_before_then_gen b naming t (fun _ -> Proofview.tclUNIT ()) let assert_before na = assert_before_gen false (naming_of_name na) -let assert_before_replacing id = assert_before_gen true (NamingMustBe (Loc.tag id)) +let assert_before_replacing id = assert_before_gen true (NamingMustBe (CAst.make id)) let assert_after_then_gen b naming t tac = let open Context.Rel.Declaration in @@ -495,7 +495,7 @@ let assert_after_gen b naming t = assert_after_then_gen b naming t (fun _ -> (Proofview.tclUNIT ())) let assert_after na = assert_after_gen false (naming_of_name na) -let assert_after_replacing id = assert_after_gen true (NamingMustBe (Loc.tag id)) +let assert_after_replacing id = assert_after_gen true (NamingMustBe (CAst.make id)) (**************************************************************) (* Fixpoints and CoFixpoints *) @@ -984,7 +984,7 @@ let rec intro_then_gen name_flag move_flag force_flag dep_flag tac = end let intro_gen n m f d = intro_then_gen n m f d (fun _ -> Proofview.tclUNIT ()) -let intro_mustbe_force id = intro_gen (NamingMustBe (Loc.tag id)) MoveLast true false +let intro_mustbe_force id = intro_gen (NamingMustBe (CAst.make id)) MoveLast true false let intro_using id = intro_gen (NamingBasedOn (id, Id.Set.empty)) MoveLast false false let intro_then = intro_then_gen (NamingAvoid Id.Set.empty) MoveLast false false @@ -994,7 +994,7 @@ let intro_avoiding l = intro_gen (NamingAvoid l) MoveLast false false let intro_move_avoid idopt avoid hto = match idopt with | None -> intro_gen (NamingAvoid avoid) hto true false - | Some id -> intro_gen (NamingMustBe (Loc.tag id)) hto true false + | Some id -> intro_gen (NamingMustBe (CAst.make id)) hto true false let intro_move idopt hto = intro_move_avoid idopt Id.Set.empty hto @@ -1140,7 +1140,7 @@ let try_intros_until tac = function let rec intros_move = function | [] -> Proofview.tclUNIT () | (hyp,destopt) :: rest -> - Tacticals.New.tclTHEN (intro_gen (NamingMustBe (Loc.tag hyp)) destopt false false) + Tacticals.New.tclTHEN (intro_gen (NamingMustBe (CAst.make hyp)) destopt false false) (intros_move rest) (* Apply a tactic on a quantified hypothesis, an hypothesis in context @@ -1264,7 +1264,7 @@ let check_unresolved_evars_of_metas sigma clenv = (meta_list clenv.evd) let do_replace id = function - | NamingMustBe (_,id') when Option.equal Id.equal id (Some id') -> true + | NamingMustBe {CAst.v=id'} when Option.equal Id.equal id (Some id') -> true | _ -> false (* For a clenv expressing some lemma [C[?1:T1,...,?n:Tn] : P] and some @@ -1288,7 +1288,7 @@ let clenv_refine_in ?(sidecond_first=false) with_evars ?(with_classes=true) error_uninstantiated_metas new_hyp_typ clenv; let new_hyp_prf = clenv_value clenv in let exact_tac = Proofview.V82.tactic (Tacmach.refine_no_check new_hyp_prf) in - let naming = NamingMustBe (Loc.tag targetid) in + let naming = NamingMustBe (CAst.make targetid) in let with_clear = do_replace (Some id) naming in Tacticals.New.tclTHEN (Proofview.Unsafe.tclEVARS (clear_metas clenv.evd)) @@ -1633,7 +1633,8 @@ let tclORELSEOPT t k = Proofview.tclZERO ~info e | Some tac -> tac) -let general_apply with_delta with_destruct with_evars clear_flag (loc,(c,lbind : EConstr.constr with_bindings)) = +let general_apply with_delta with_destruct with_evars clear_flag + {CAst.loc;v=(c,lbind : EConstr.constr with_bindings)} = Proofview.Goal.enter begin fun gl -> let concl = Proofview.Goal.concl gl in let sigma = Tacmach.New.project gl in @@ -1714,13 +1715,13 @@ let rec apply_with_bindings_gen b e = function (apply_with_bindings_gen b e cbl) let apply_with_delayed_bindings_gen b e l = - let one k (loc, f) = + let one k {CAst.loc;v=f} = Proofview.Goal.enter begin fun gl -> let sigma = Tacmach.New.project gl in let env = Proofview.Goal.env gl in let (sigma, cb) = f env sigma in Tacticals.New.tclWITHHOLES e - (general_apply b b e k (loc,cb)) sigma + (general_apply b b e k CAst.(make ?loc cb)) sigma end in let rec aux = function @@ -1731,13 +1732,13 @@ let apply_with_delayed_bindings_gen b e l = (one k f) (aux cbl) in aux l -let apply_with_bindings cb = apply_with_bindings_gen false false [None,(Loc.tag cb)] +let apply_with_bindings cb = apply_with_bindings_gen false false [None,(CAst.make cb)] -let eapply_with_bindings cb = apply_with_bindings_gen false true [None,(Loc.tag cb)] +let eapply_with_bindings cb = apply_with_bindings_gen false true [None,(CAst.make cb)] -let apply c = apply_with_bindings_gen false false [None,(Loc.tag (c,NoBindings))] +let apply c = apply_with_bindings_gen false false [None,(CAst.make (c,NoBindings))] -let eapply c = apply_with_bindings_gen false true [None,(Loc.tag (c,NoBindings))] +let eapply c = apply_with_bindings_gen false true [None,(CAst.make (c,NoBindings))] let apply_list = function | c::l -> apply_with_bindings (c,ImplicitBindings l) @@ -1796,7 +1797,7 @@ let apply_in_once_main flags innerclause env sigma (loc,d,lbind) = aux (make_clenv_binding env sigma (d,thm) lbind) let apply_in_once sidecond_first with_delta with_destruct with_evars naming - id (clear_flag,(loc,(d,lbind))) tac = + id (clear_flag,{ CAst.loc; v= d,lbind}) tac = let open Context.Rel.Declaration in Proofview.Goal.enter begin fun gl -> let env = Proofview.Goal.env gl in @@ -1830,14 +1831,14 @@ let apply_in_once sidecond_first with_delta with_destruct with_evars naming end let apply_in_delayed_once sidecond_first with_delta with_destruct with_evars naming - id (clear_flag,(loc,f)) tac = + id (clear_flag,{CAst.loc;v=f}) tac = Proofview.Goal.enter begin fun gl -> let env = Proofview.Goal.env gl in let sigma = Tacmach.New.project gl in let (sigma, c) = f env sigma in Tacticals.New.tclWITHHOLES with_evars (apply_in_once sidecond_first with_delta with_destruct with_evars - naming id (clear_flag,(loc,c)) tac) + naming id (clear_flag,CAst.(make ?loc c)) tac) sigma end @@ -2032,7 +2033,7 @@ let clear_body ids = end let clear_wildcards ids = - Tacticals.New.tclMAP (fun (loc, id) -> clear [id]) ids + Tacticals.New.tclMAP (fun {CAst.loc;v=id} -> clear [id]) ids (* Takes a list of booleans, and introduces all the variables * quantified in the goal which are associated with a value @@ -2132,7 +2133,7 @@ let constructor_core with_evars cstr lbind = let env = Proofview.Goal.env gl in let (sigma, (cons, u)) = Evd.fresh_constructor_instance env sigma cstr in let cons = mkConstructU (cons, EInstance.make u) in - let apply_tac = general_apply true false with_evars None (Loc.tag (cons,lbind)) in + let apply_tac = general_apply true false with_evars None (CAst.make (cons,lbind)) in Tacticals.New.tclTHEN (Proofview.Unsafe.tclEVARS sigma) apply_tac end @@ -2234,7 +2235,7 @@ let intro_decomp_eq ?loc l thin tac id = match my_find_eq_data_decompose gl t with | Some (eq,u,eq_args) -> !intro_decomp_eq_function - (fun n -> tac ((Loc.tag id)::thin) (Some (true,n)) l) + (fun n -> tac ((CAst.make id)::thin) (Some (true,n)) l) (eq,t,eq_args) (c, t) | None -> Tacticals.New.tclZEROMSG (str "Not a primitive equality here.") @@ -2262,7 +2263,7 @@ let rewrite_hyp_then assert_style with_evars thin l2r id tac = Hook.get forward_subst_one true x (id,rhs,l2r) in let clear_var_and_eq id' = clear [id';id] in let early_clear id' thin = - List.filter (fun (_,id) -> not (Id.equal id id')) thin in + List.filter (fun {CAst.v=id} -> not (Id.equal id id')) thin in Proofview.Goal.enter begin fun gl -> let env = Proofview.Goal.env gl in let sigma = Tacmach.New.project gl in @@ -2298,29 +2299,29 @@ let rewrite_hyp_then assert_style with_evars thin l2r id tac = end let prepare_naming ?loc = function - | IntroIdentifier id -> NamingMustBe (Loc.tag ?loc id) + | IntroIdentifier id -> NamingMustBe (CAst.make ?loc id) | IntroAnonymous -> NamingAvoid Id.Set.empty | IntroFresh id -> NamingBasedOn (id, Id.Set.empty) -let rec explicit_intro_names = function -| (_, IntroForthcoming _) :: l -> explicit_intro_names l -| (_, IntroNaming (IntroIdentifier id)) :: l -> Id.Set.add id (explicit_intro_names l) -| (_, IntroAction (IntroOrAndPattern l)) :: l' -> +let rec explicit_intro_names = let open CAst in function +| {v=IntroForthcoming _} :: l -> explicit_intro_names l +| {v=IntroNaming (IntroIdentifier id)} :: l -> Id.Set.add id (explicit_intro_names l) +| {v=IntroAction (IntroOrAndPattern l)} :: l' -> let ll = match l with IntroAndPattern l -> [l] | IntroOrPattern ll -> ll in let fold accu l = Id.Set.union accu (explicit_intro_names (l@l')) in List.fold_left fold Id.Set.empty ll -| (_, IntroAction (IntroInjection l)) :: l' -> +| {v=IntroAction (IntroInjection l)} :: l' -> explicit_intro_names (l@l') -| (_, IntroAction (IntroApplyOn (c,pat))) :: l' -> +| {v=IntroAction (IntroApplyOn (c,pat))} :: l' -> explicit_intro_names (pat::l') -| (_, (IntroNaming (IntroAnonymous | IntroFresh _) - | IntroAction (IntroWildcard | IntroRewrite _))) :: l -> +| {v=(IntroNaming (IntroAnonymous | IntroFresh _) + | IntroAction (IntroWildcard | IntroRewrite _))} :: l -> explicit_intro_names l | [] -> Id.Set.empty -let rec check_name_unicity env ok seen = function -| (_, IntroForthcoming _) :: l -> check_name_unicity env ok seen l -| (loc, IntroNaming (IntroIdentifier id)) :: l -> +let rec check_name_unicity env ok seen = let open CAst in function +| {v=IntroForthcoming _} :: l -> check_name_unicity env ok seen l +| {loc;v=IntroNaming (IntroIdentifier id)} :: l -> (try ignore (if List.mem_f Id.equal id ok then raise Not_found else lookup_named id env); user_err ?loc (Id.print id ++ str" is already used.") @@ -2329,15 +2330,15 @@ let rec check_name_unicity env ok seen = function user_err ?loc (Id.print id ++ str" is used twice.") else check_name_unicity env ok (id::seen) l) -| (_, IntroAction (IntroOrAndPattern l)) :: l' -> +| {v=IntroAction (IntroOrAndPattern l)} :: l' -> let ll = match l with IntroAndPattern l -> [l] | IntroOrPattern ll -> ll in List.iter (fun l -> check_name_unicity env ok seen (l@l')) ll -| (_, IntroAction (IntroInjection l)) :: l' -> +| {v=IntroAction (IntroInjection l)} :: l' -> check_name_unicity env ok seen (l@l') -| (_, IntroAction (IntroApplyOn (c,pat))) :: l' -> +| {v=IntroAction (IntroApplyOn (c,pat))} :: l' -> check_name_unicity env ok seen (pat::l') -| (_, (IntroNaming (IntroAnonymous | IntroFresh _) - | IntroAction (IntroWildcard | IntroRewrite _))) :: l -> +| {v=(IntroNaming (IntroAnonymous | IntroFresh _) + | IntroAction (IntroWildcard | IntroRewrite _))} :: l -> check_name_unicity env ok seen l | [] -> () @@ -2345,13 +2346,13 @@ let wild_id = Id.of_string "_tmp" let rec list_mem_assoc_right id = function | [] -> false - | (x,id')::l -> Id.equal id id' || list_mem_assoc_right id l + | {CAst.v=id'}::l -> Id.equal id id' || list_mem_assoc_right id l let check_thin_clash_then id thin avoid tac = if list_mem_assoc_right id thin then let newid = next_ident_away (add_suffix id "'") avoid in let thin = - List.map (on_snd (fun id' -> if Id.equal id id' then newid else id')) thin in + List.map CAst.(map (fun id' -> if Id.equal id id' then newid else id')) thin in Tacticals.New.tclTHEN (rename_hyp [id,newid]) (tac thin) else tac thin @@ -2364,7 +2365,7 @@ let make_tmp_naming avoid l = function case of IntroFresh, we should use check_thin_clash_then anyway to prevent the case of an IntroFresh precisely using the wild_id *) | IntroWildcard -> NamingBasedOn (wild_id, Id.Set.union avoid (explicit_intro_names l)) - | pat -> NamingAvoid(Id.Set.union avoid (explicit_intro_names ((Loc.tag @@ IntroAction pat)::l))) + | pat -> NamingAvoid(Id.Set.union avoid (explicit_intro_names ((CAst.make @@ IntroAction pat)::l))) let fit_bound n = function | None -> true @@ -2400,8 +2401,8 @@ let rec intro_patterns_core with_evars b avoid ids thin destopt bound n tac = | [] -> (* Behave as IntroAnonymous *) intro_patterns_core with_evars b avoid ids thin destopt bound n tac - [Loc.tag @@ IntroNaming IntroAnonymous] - | (loc,pat) :: l -> + [CAst.make @@ IntroNaming IntroAnonymous] + | {CAst.loc;v=pat} :: l -> if exceed_bound n bound then error_unexpected_extra_pattern loc bound pat else match pat with | IntroForthcoming onlydeps -> @@ -2425,7 +2426,7 @@ and intro_pattern_naming loc with_evars b avoid ids pat thin destopt bound n tac match pat with | IntroIdentifier id -> check_thin_clash_then id thin avoid (fun thin -> - intro_then_gen (NamingMustBe (loc,id)) destopt true false + intro_then_gen (NamingMustBe CAst.(make ?loc id)) destopt true false (fun id -> intro_patterns_core with_evars b avoid (id::ids) thin destopt bound n tac l)) | IntroAnonymous -> intro_then_gen (NamingAvoid (Id.Set.union avoid (explicit_intro_names l))) @@ -2440,24 +2441,24 @@ and intro_pattern_naming loc with_evars b avoid ids pat thin destopt bound n tac and intro_pattern_action ?loc with_evars b style pat thin destopt tac id = match pat with | IntroWildcard -> - tac ((Loc.tag ?loc id)::thin) None [] + tac (CAst.(make ?loc id)::thin) None [] | IntroOrAndPattern ll -> intro_or_and_pattern ?loc with_evars b ll thin tac id | IntroInjection l' -> intro_decomp_eq ?loc l' thin tac id | IntroRewrite l2r -> rewrite_hyp_then style with_evars thin l2r id (fun thin -> tac thin None []) - | IntroApplyOn ((loc',f),(loc,pat)) -> + | IntroApplyOn ({CAst.loc=loc';v=f},{CAst.loc;v=pat}) -> let naming,tac_ipat = prepare_intros ?loc with_evars (IntroIdentifier id) destopt pat in let doclear = - if naming = NamingMustBe (Loc.tag ?loc id) then + if naming = NamingMustBe (CAst.make ?loc id) then Proofview.tclUNIT () (* apply_in_once do a replacement *) else clear [id] in let f env sigma = let (sigma, c) = f env sigma in (sigma,(c, NoBindings)) in - apply_in_delayed_once false true true with_evars naming id (None,(loc',f)) + apply_in_delayed_once false true true with_evars naming id (None,CAst.make ?loc:loc' f) (fun id -> Tacticals.New.tclTHENLIST [doclear; tac_ipat id; tac thin None []]) and prepare_intros ?loc with_evars dft destopt = function @@ -2491,7 +2492,7 @@ let intro_patterns_to with_evars destopt = destopt None let intro_pattern_to with_evars destopt pat = - intro_patterns_to with_evars destopt [Loc.tag pat] + intro_patterns_to with_evars destopt [CAst.make pat] let intro_patterns with_evars = intro_patterns_to with_evars MoveLast @@ -2506,11 +2507,11 @@ let intros_patterns with_evars = function let prepare_intros_opt with_evars dft destopt = function | None -> prepare_naming dft, (fun _id -> Proofview.tclUNIT ()) - | Some (loc,ipat) -> prepare_intros ?loc with_evars dft destopt ipat + | Some {CAst.loc;v=ipat} -> prepare_intros ?loc with_evars dft destopt ipat let ipat_of_name = function | Anonymous -> None - | Name id -> Some (Loc.tag @@ IntroNaming (IntroIdentifier id)) + | Name id -> Some (CAst.make @@ IntroNaming (IntroIdentifier id)) let head_ident sigma c = let c = fst (decompose_app sigma (snd (decompose_lam_assum sigma c))) in @@ -2541,7 +2542,7 @@ let general_apply_in sidecond_first with_delta with_destruct with_evars prepare_intros_opt with_evars (IntroIdentifier id) destopt ipat in let lemmas_target, last_lemma_target = let last,first = List.sep_last lemmas in - List.map (fun lem -> (NamingMustBe (Loc.tag id),lem)) first, (naming,last) + List.map (fun lem -> (NamingMustBe (CAst.make id),lem)) first, (naming,last) in (* We chain apply_in_once, ending with an intro pattern *) List.fold_right tac lemmas_target (tac last_lemma_target ipat_tac) id @@ -2556,7 +2557,7 @@ let general_apply_in sidecond_first with_delta with_destruct with_evars *) let apply_in simple with_evars id lemmas ipat = - let lemmas = List.map (fun (k,(loc,l)) -> k, (loc, (fun _ sigma -> (sigma,l)))) lemmas in + let lemmas = List.map (fun (k,{CAst.loc;v=l}) -> k, CAst.make ?loc (fun _ sigma -> (sigma,l))) lemmas in general_apply_in false simple simple with_evars id lemmas ipat let apply_delayed_in simple with_evars id lemmas ipat = @@ -2590,7 +2591,7 @@ let letin_tac_gen with_eq (id,depdecls,lastlhyp,ccl,c) ty = Evarsolve.refresh_universes ~onlyalg:true (Some false) env sigma t in let (sigma, (newcl, eq_tac)) = match with_eq with - | Some (lr,(loc,ido)) -> + | Some (lr,{CAst.loc;v=ido}) -> let heq = match ido with | IntroAnonymous -> new_fresh_id (Id.Set.singleton id) (add_prefix "Heq" id) gl | IntroFresh heq_base -> new_fresh_id (Id.Set.singleton id) heq_base gl @@ -2608,7 +2609,7 @@ let letin_tac_gen with_eq (id,depdecls,lastlhyp,ccl,c) ty = let ans = term, Tacticals.New.tclTHENLIST [ - intro_gen (NamingMustBe (loc,heq)) (decode_hyp lastlhyp) true false; + intro_gen (NamingMustBe CAst.(make ?loc heq)) (decode_hyp lastlhyp) true false; clear_body [heq;id]] in (sigma, ans) @@ -2618,7 +2619,7 @@ let letin_tac_gen with_eq (id,depdecls,lastlhyp,ccl,c) ty = Tacticals.New.tclTHENLIST [ Proofview.Unsafe.tclEVARS sigma; convert_concl_no_check newcl DEFAULTcast; - intro_gen (NamingMustBe (Loc.tag id)) (decode_hyp lastlhyp) true false; + intro_gen (NamingMustBe (CAst.make id)) (decode_hyp lastlhyp) true false; Tacticals.New.tclMAP convert_hyp_no_check depdecls; eq_tac ] end @@ -2643,7 +2644,7 @@ let mkletin_goal env sigma store with_eq dep (id,lastlhyp,ccl,c) ty = else LocalAssum (id,t) in match with_eq with - | Some (lr,(loc,ido)) -> + | Some (lr,{CAst.loc;v=ido}) -> let heq = match ido with | IntroAnonymous -> fresh_id_in_env (Id.Set.singleton id) (add_prefix "Heq" id) env | IntroFresh heq_base -> fresh_id_in_env (Id.Set.singleton id) heq_base env @@ -2957,7 +2958,7 @@ let specialize (c,lbind) ipat = (* TODO: add intro to be more homogeneous. It will break scripts but will be easy to fix *) (Tacticals.New.tclTHENLAST (cut typ) (exact_no_check term)) - | Some (loc,ipat) -> + | Some {CAst.loc;v=ipat} -> (* Like pose proof with extra support for "with" bindings *) (* even though the "with" bindings forces full application *) let naming,tac = prepare_intros ?loc false IntroAnonymous MoveLast ipat in @@ -3047,19 +3048,19 @@ let intropattern_of_name gl avoid = function | Anonymous -> IntroNaming IntroAnonymous | Name id -> IntroNaming (IntroIdentifier (new_fresh_id avoid id gl)) -let rec consume_pattern avoid na isdep gl = function - | [] -> ((Loc.tag @@ intropattern_of_name gl avoid na), []) - | (loc,IntroForthcoming true)::names when not isdep -> +let rec consume_pattern avoid na isdep gl = let open CAst in function + | [] -> ((CAst.make @@ intropattern_of_name gl avoid na), []) + | {loc;v=IntroForthcoming true}::names when not isdep -> consume_pattern avoid na isdep gl names - | (loc,IntroForthcoming _)::names as fullpat -> + | {loc;v=IntroForthcoming _}::names as fullpat -> let avoid = Id.Set.union avoid (explicit_intro_names names) in - ((loc,intropattern_of_name gl avoid na), fullpat) - | (loc,IntroNaming IntroAnonymous)::names -> + (CAst.make ?loc @@ intropattern_of_name gl avoid na, fullpat) + | {loc;v=IntroNaming IntroAnonymous}::names -> let avoid = Id.Set.union avoid (explicit_intro_names names) in - ((loc,intropattern_of_name gl avoid na), names) - | (loc,IntroNaming (IntroFresh id'))::names -> + (CAst.make ?loc @@ intropattern_of_name gl avoid na, names) + | {loc;v=IntroNaming (IntroFresh id')}::names -> let avoid = Id.Set.union avoid (explicit_intro_names names) in - ((loc,IntroNaming (IntroIdentifier (new_fresh_id avoid id' gl))), names) + (CAst.make ?loc @@ IntroNaming (IntroIdentifier (new_fresh_id avoid id' gl)), names) | pat::names -> (pat,names) let re_intro_dependent_hypotheses (lstatus,rstatus) (_,tophyp) = @@ -3123,9 +3124,9 @@ let induct_discharge with_evars dests avoid' tac (avoid,ra) names = (IndArg,_,depind,hyprecname) :: ra' -> Proofview.Goal.enter begin fun gl -> let (recpat,names) = match names with - | [loc,IntroNaming (IntroIdentifier id) as pat] -> + | [{CAst.loc;v=IntroNaming (IntroIdentifier id)} as pat] -> let id' = next_ident_away (add_prefix "IH" id) avoid in - (pat, [Loc.tag @@ IntroNaming (IntroIdentifier id')]) + (pat, [CAst.make @@ IntroNaming (IntroIdentifier id')]) | _ -> consume_pattern avoid (Name recvarname) deprec gl names in let dest = get_recarg_dest dests in dest_intro_patterns with_evars avoid thin dest [recpat] (fun ids thin -> @@ -4468,7 +4469,7 @@ let induction_gen_l isrec with_evars elim names lc = let newlc = ref [] in let lc = List.map (function | (c,None) -> c - | (c,Some(loc,eqname)) -> + | (c,Some{CAst.loc;v=eqname}) -> user_err ?loc (str "Do not know what to do with " ++ Miscprint.pr_intro_pattern_naming eqname)) lc in let rec atomize_list l = @@ -5022,14 +5023,14 @@ module Simple = struct let intro x = intro_move (Some x) MoveLast let apply c = - apply_with_bindings_gen false false [None,(Loc.tag (c,NoBindings))] + apply_with_bindings_gen false false [None,(CAst.make (c,NoBindings))] let eapply c = - apply_with_bindings_gen false true [None,(Loc.tag (c,NoBindings))] + apply_with_bindings_gen false true [None,(CAst.make (c,NoBindings))] let elim c = elim false None (c,NoBindings) None let case c = general_case_analysis false None (c,NoBindings) let apply_in id c = - apply_in false false id [None,(Loc.tag (c, NoBindings))] None + apply_in false false id [None,(CAst.make (c, NoBindings))] None end diff --git a/tactics/tactics.mli b/tactics/tactics.mli index 1c3b75e91c..079baa3efa 100644 --- a/tactics/tactics.mli +++ b/tactics/tactics.mli @@ -8,7 +8,6 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) -open Loc open Names open Constr open EConstr @@ -196,10 +195,10 @@ val apply : constr -> unit Proofview.tactic val eapply : constr -> unit Proofview.tactic val apply_with_bindings_gen : - advanced_flag -> evars_flag -> (clear_flag * constr with_bindings located) list -> unit Proofview.tactic + advanced_flag -> evars_flag -> (clear_flag * constr with_bindings CAst.t) list -> unit Proofview.tactic val apply_with_delayed_bindings_gen : - advanced_flag -> evars_flag -> (clear_flag * delayed_open_constr_with_bindings located) list -> unit Proofview.tactic + advanced_flag -> evars_flag -> (clear_flag * delayed_open_constr_with_bindings CAst.t) list -> unit Proofview.tactic val apply_with_bindings : constr with_bindings -> unit Proofview.tactic val eapply_with_bindings : constr with_bindings -> unit Proofview.tactic @@ -208,12 +207,12 @@ val cut_and_apply : constr -> unit Proofview.tactic val apply_in : advanced_flag -> evars_flag -> Id.t -> - (clear_flag * constr with_bindings located) list -> + (clear_flag * constr with_bindings CAst.t) list -> intro_pattern option -> unit Proofview.tactic val apply_delayed_in : advanced_flag -> evars_flag -> Id.t -> - (clear_flag * delayed_open_constr_with_bindings located) list -> + (clear_flag * delayed_open_constr_with_bindings CAst.t) list -> intro_pattern option -> unit Proofview.tactic (** {6 Elimination tactics. } *) diff --git a/toplevel/vernac.ml b/toplevel/vernac.ml index 56bdcc7e52..fdd0d4ed37 100644 --- a/toplevel/vernac.ml +++ b/toplevel/vernac.ml @@ -20,15 +20,14 @@ open Vernacprop Use the module Coqtoplevel, which catches these exceptions (the exceptions are explained only at the toplevel). *) -let checknav_simple (loc, cmd) = +let checknav_simple {CAst.loc;v=cmd} = if is_navigation_vernac cmd && not (is_reset cmd) then CErrors.user_err ?loc (str "Navigation commands forbidden in files.") -let checknav_deep (loc, ast) = +let checknav_deep {CAst.loc;v=ast} = if is_deep_navigation_vernac ast then CErrors.user_err ?loc (str "Navigation commands forbidden in nested commands.") - let disable_drop = function | Drop -> CErrors.user_err Pp.(str "Drop is forbidden.") | e -> e @@ -45,7 +44,7 @@ let vernac_echo ?loc in_chan = let open Loc in (* For coqtop -time, we display the position in the file, and a glimpse of the executed command *) -let pp_cmd_header ?loc com = +let pp_cmd_header {CAst.loc;v=com} = let shorten s = if Unicode.utf8_length s > 33 then (Unicode.utf8_sub s 0 30) ^ "..." else s in @@ -66,8 +65,8 @@ let pp_cmd_header ?loc com = (* This is a special case where we assume we are in console batch mode and take control of the console. *) -let print_cmd_header ?loc com = - Pp.pp_with !Topfmt.std_ft (pp_cmd_header ?loc com); +let print_cmd_header com = + Pp.pp_with !Topfmt.std_ft (pp_cmd_header com); Format.pp_print_flush !Topfmt.std_ft () (* Reenable when we get back to feedback printing *) @@ -85,14 +84,14 @@ module State = struct end -let interp_vernac ~time ~check ~interactive ~state (loc,com) = +let interp_vernac ~time ~check ~interactive ~state ({CAst.loc;_} as com) = let open State in try (* The -time option is only supported from console-based clients due to the way it prints. *) - if time then print_cmd_header ?loc com; - let com = if time then VernacTime(time,(CAst.make ?loc com)) else com in - let doc, nsid, ntip = Stm.add ~doc:state.doc ~ontop:state.sid (not !Flags.quiet) (loc,com) in + if time then print_cmd_header com; + let com = if time then CAst.make ?loc @@ VernacTime(time,com) else com in + let doc, nsid, ntip = Stm.add ~doc:state.doc ~ontop:state.sid (not !Flags.quiet) com in (* Main STM interaction *) if ntip <> `NewTip then @@ -131,7 +130,7 @@ let load_vernac_core ~time ~echo ~check ~interactive ~state file = (* we go out of the following infinite loop when a End_of_input is * raised, which means that we raised the end of the file being loaded *) while true do - let loc, ast = + let { CAst.loc; _ } as ast = Stm.parse_sentence ~doc:!rstate.doc !rstate.sid in_pa (* If an error in parsing occurs, we propagate the exception so the caller of load_vernac will take care of it. However, @@ -154,8 +153,8 @@ let load_vernac_core ~time ~echo ~check ~interactive ~state file = (* Printing of vernacs *) Option.iter (vernac_echo ?loc) in_echo; - checknav_simple (loc, ast); - let state = Flags.silently (interp_vernac ~time ~check ~interactive ~state:!rstate) (loc, ast) in + checknav_simple ast; + let state = Flags.silently (interp_vernac ~time ~check ~interactive ~state:!rstate) ast in rids := state.sid :: !rids; rstate := state; done; diff --git a/toplevel/vernac.mli b/toplevel/vernac.mli index 19bac45c37..51758642e7 100644 --- a/toplevel/vernac.mli +++ b/toplevel/vernac.mli @@ -23,7 +23,7 @@ end expected to handle and print errors in form of exceptions, however care is taken so the state machine is left in a consistent state. *) -val process_expr : time:bool -> state:State.t -> Vernacexpr.vernac_control Loc.located -> State.t +val process_expr : time:bool -> state:State.t -> Vernacexpr.vernac_control CAst.t -> State.t (** [load_vernac echo sid file] Loads [file] on top of [sid], will echo the commands if [echo] is set. Callers are expected to handle diff --git a/vernac/auto_ind_decl.ml b/vernac/auto_ind_decl.ml index 2879feba78..1a6b4dcdb2 100644 --- a/vernac/auto_ind_decl.ml +++ b/vernac/auto_ind_decl.ml @@ -86,12 +86,12 @@ let destruct_on c = destruct false None c None None let destruct_on_using c id = destruct false None c - (Some (Loc.tag @@ IntroOrPattern [[Loc.tag @@ IntroNaming IntroAnonymous]; - [Loc.tag @@ IntroNaming (IntroIdentifier id)]])) + (Some (CAst.make @@ IntroOrPattern [[CAst.make @@ IntroNaming IntroAnonymous]; + [CAst.make @@ IntroNaming (IntroIdentifier id)]])) None let destruct_on_as c l = - destruct false None c (Some (Loc.tag l)) None + destruct false None c (Some (CAst.make l)) None let inj_flags = Some { Equality.keep_proof_equalities = true; (* necessary *) @@ -620,8 +620,8 @@ repeat ( apply andb_prop in z;let z1:= fresh "Z" in destruct z as [z1 z]). Proofview.Goal.enter begin fun gl -> let fresht = fresh_id (Id.of_string "Z") gl in destruct_on_as (EConstr.mkVar freshz) - (IntroOrPattern [[Loc.tag @@ IntroNaming (IntroIdentifier fresht); - Loc.tag @@ IntroNaming (IntroIdentifier freshz)]]) + (IntroOrPattern [[CAst.make @@ IntroNaming (IntroIdentifier fresht); + CAst.make @@ IntroNaming (IntroIdentifier freshz)]]) end ]); (* diff --git a/vernac/classes.ml b/vernac/classes.ml index 192cc8a555..76d427add6 100644 --- a/vernac/classes.ml +++ b/vernac/classes.ml @@ -72,7 +72,7 @@ let existing_instance glob g info = let _, r = Term.decompose_prod_assum instance in match class_of_constr Evd.empty (EConstr.of_constr r) with | Some (_, ((tc,u), _)) -> add_instance (new_instance tc info glob c) - | None -> user_err ?loc:(loc_of_reference g) + | None -> user_err ?loc:g.CAst.loc ~hdr:"declare_instance" (Pp.str "Constant does not build instances of a declared type class.") @@ -227,10 +227,9 @@ let new_instance ?(abstract=false) ?(global=false) ?(refine= !refine_instance) let sigma, c = interp_casted_constr_evars env' sigma term cty in Some (Inr (c, subst)), sigma | Some (Inl props) -> - let get_id = - function - | Ident id' -> id' - | Qualid (loc,id') -> (Loc.tag ?loc @@ snd (repr_qualid id')) + let get_id = CAst.map (function + | Ident id' -> id' + | Qualid id' -> snd (repr_qualid id')) in let props, rest = List.fold_left @@ -238,7 +237,7 @@ let new_instance ?(abstract=false) ?(global=false) ?(refine= !refine_instance) if is_local_assum decl then try let is_id (id', _) = match RelDecl.get_name decl, get_id id' with - | Name id, (_, id') -> Id.equal id id' + | Name id, {CAst.v=id'} -> Id.equal id id' | Anonymous, _ -> false in let (loc_mid, c) = @@ -247,7 +246,7 @@ let new_instance ?(abstract=false) ?(global=false) ?(refine= !refine_instance) let rest' = List.filter (fun v -> not (is_id v)) rest in - let (loc, mid) = get_id loc_mid in + let {CAst.loc;v=mid} = get_id loc_mid in List.iter (fun (n, _, x) -> if Name.equal n (Name mid) then Option.iter (fun x -> Dumpglob.add_glob ?loc (ConstRef x)) x) diff --git a/vernac/comInductive.ml b/vernac/comInductive.ml index c59286d1a3..db2f16525b 100644 --- a/vernac/comInductive.ml +++ b/vernac/comInductive.ml @@ -46,8 +46,8 @@ let rec complete_conclusion a cs = CAst.map_with_loc (fun ?loc -> function user_err ?loc (strbrk"Cannot infer the non constant arguments of the conclusion of " ++ Id.print cs ++ str "."); - let args = List.map (fun id -> CAst.make ?loc @@ CRef(Ident(loc,id),None)) params in - CAppExpl ((None,Ident(loc,name),None),List.rev args) + let args = List.map (fun id -> CAst.(make ?loc @@ CRef(make ?loc @@ Ident id,None))) params in + CAppExpl ((None,CAst.make ?loc @@ Ident name,None),List.rev args) | c -> c ) diff --git a/vernac/comProgramFixpoint.ml b/vernac/comProgramFixpoint.ml index bd7ee0978f..b95741ca4d 100644 --- a/vernac/comProgramFixpoint.ml +++ b/vernac/comProgramFixpoint.ml @@ -44,7 +44,7 @@ let mkSubset sigma name typ prop = let sigT = Lazy.from_fun build_sigma_type -let make_qref s = Qualid (Loc.tag @@ qualid_of_string s) +let make_qref s = CAst.make @@ Qualid (qualid_of_string s) let lt_ref = make_qref "Init.Peano.lt" let rec telescope sigma l = diff --git a/vernac/himsg.ml b/vernac/himsg.ml index 131b1fab66..249e7893c2 100644 --- a/vernac/himsg.ml +++ b/vernac/himsg.ml @@ -1015,8 +1015,8 @@ let explain_not_a_class env c = let c = EConstr.to_constr Evd.empty c in pr_constr_env env Evd.empty c ++ str" is not a declared type class." -let explain_unbound_method env cid id = - str "Unbound method name " ++ Id.print (snd id) ++ spc () ++ +let explain_unbound_method env cid { CAst.v = id } = + str "Unbound method name " ++ Id.print (id) ++ spc () ++ str"of class" ++ spc () ++ pr_global cid ++ str "." let pr_constr_exprs exprs = diff --git a/vernac/indschemes.ml b/vernac/indschemes.ml index 27587416b1..32885ab88a 100644 --- a/vernac/indschemes.ml +++ b/vernac/indschemes.ml @@ -489,10 +489,9 @@ let do_combined_scheme name schemes = let open CAst in let csts = List.map (fun {CAst.loc;v} -> - let refe = Ident (Loc.tag ?loc v) in - let qualid = qualid_of_reference refe in - try Nametab.locate_constant (snd qualid) - with Not_found -> user_err Pp.(pr_qualid (snd qualid) ++ str " is not declared.")) + let qualid = qualid_of_ident v in + try Nametab.locate_constant qualid + with Not_found -> user_err ?loc Pp.(pr_qualid qualid ++ str " is not declared.")) schemes in let sigma,body,typ = build_combined_scheme (Global.env ()) csts in diff --git a/vernac/metasyntax.ml b/vernac/metasyntax.ml index a0baca62bc..feeca60753 100644 --- a/vernac/metasyntax.ml +++ b/vernac/metasyntax.ml @@ -1448,7 +1448,7 @@ let add_notation_extra_printing_rule df k v = (* Infix notations *) -let inject_var x = CAst.make @@ CRef (Ident (Loc.tag @@ Id.of_string x),None) +let inject_var x = CAst.make @@ CRef (CAst.make @@ Ident (Id.of_string x),None) let add_infix local env ({CAst.loc;v=inf},modifiers) pr sc = check_infix_modifiers modifiers; diff --git a/vernac/vernacentries.ml b/vernac/vernacentries.ml index 7764920d9f..3dbe8b0c09 100644 --- a/vernac/vernacentries.ml +++ b/vernac/vernacentries.ml @@ -185,28 +185,28 @@ let print_modules () = let print_module r = - let (loc,qid) = qualid_of_reference r in + let qid = qualid_of_reference r in try - let globdir = Nametab.locate_dir qid in + let globdir = Nametab.locate_dir qid.v in match globdir with DirModule { obj_dir; obj_mp; _ } -> Printmod.print_module (Printmod.printable_body obj_dir) obj_mp | _ -> raise Not_found with - Not_found -> user_err (str"Unknown Module " ++ pr_qualid qid) + Not_found -> user_err (str"Unknown Module " ++ pr_qualid qid.v) let print_modtype r = - let (loc,qid) = qualid_of_reference r in + let qid = qualid_of_reference r in try - let kn = Nametab.locate_modtype qid in + let kn = Nametab.locate_modtype qid.v in Printmod.print_modtype kn with Not_found -> (* Is there a module of this name ? If yes we display its type *) try - let mp = Nametab.locate_module qid in + let mp = Nametab.locate_module qid.v in Printmod.print_module false mp with Not_found -> - user_err (str"Unknown Module Type or Module " ++ pr_qualid qid) + user_err (str"Unknown Module Type or Module " ++ pr_qualid qid.v) let print_namespace ns = let ns = List.rev (Names.DirPath.repr ns) in @@ -390,7 +390,7 @@ let err_notfound_library ?loc ?from qid = (strbrk "Unable to locate library " ++ pr_qualid qid ++ prefix) let print_located_library r = - let (loc,qid) = qualid_of_reference r in + let {loc;v=qid} = qualid_of_reference r in try msg_found_library (Library.locate_qualified_library ~warn:false qid) with | Library.LibUnmappedDir -> err_unmapped_library ?loc qid @@ -398,13 +398,13 @@ let print_located_library r = let smart_global r = let gr = Smartlocate.smart_global r in - Dumpglob.add_glob ?loc:(Stdarg.loc_of_or_by_notation loc_of_reference r) gr; - gr + Dumpglob.add_glob ?loc:r.loc gr; + gr let dump_global r = try let gr = Smartlocate.smart_global r in - Dumpglob.add_glob ?loc:(Stdarg.loc_of_or_by_notation loc_of_reference r) gr + Dumpglob.add_glob ?loc:r.loc gr with e when CErrors.noncritical e -> () (**********) (* Syntax *) @@ -640,7 +640,7 @@ let vernac_scheme l = let vernac_combined_scheme lid l = if Dumpglob.dump () then (Dumpglob.dump_definition lid false "def"; - List.iter (fun {loc;v=id} -> dump_global (Misctypes.AN (Ident (Loc.tag ?loc id)))) l); + List.iter (fun {loc;v=id} -> dump_global (make ?loc @@ Misctypes.AN (make ?loc @@ Ident id))) l); Indschemes.do_combined_scheme lid l let vernac_universe ~atts l = @@ -679,7 +679,7 @@ let vernac_declare_module export {loc;v=id} binders_ast mty_ast = in Dumpglob.dump_moddef ?loc mp "mod"; Flags.if_verbose Feedback.msg_info (str "Module " ++ Id.print id ++ str " is declared"); - Option.iter (fun export -> vernac_import export [Ident (Loc.tag id)]) export + Option.iter (fun export -> vernac_import export [make @@ Ident id]) export let vernac_define_module export {loc;v=id} (binders_ast : module_binder list) mty_ast_o mexpr_ast_l = (* We check the state of the system (in section, in module type) @@ -704,7 +704,7 @@ let vernac_define_module export {loc;v=id} (binders_ast : module_binder list) mt List.iter (fun (export,id) -> Option.iter - (fun export -> vernac_import export [Ident (Loc.tag id)]) export + (fun export -> vernac_import export [make @@ Ident id]) export ) argsexport | _::_ -> let binders_ast = List.map @@ -719,14 +719,14 @@ let vernac_define_module export {loc;v=id} (binders_ast : module_binder list) mt Dumpglob.dump_moddef ?loc mp "mod"; Flags.if_verbose Feedback.msg_info (str "Module " ++ Id.print id ++ str " is defined"); - Option.iter (fun export -> vernac_import export [Ident (Loc.tag id)]) + Option.iter (fun export -> vernac_import export [make @@ Ident id]) export let vernac_end_module export {loc;v=id} = let mp = Declaremods.end_module () in Dumpglob.dump_modref ?loc mp "mod"; Flags.if_verbose Feedback.msg_info (str "Module " ++ Id.print id ++ str " is defined"); - Option.iter (fun export -> vernac_import export [Ident (Loc.tag ?loc id)]) export + Option.iter (fun export -> vernac_import export [make ?loc @@ Ident id]) export let vernac_declare_module_type {loc;v=id} binders_ast mty_sign mty_ast_l = if Lib.sections_are_opened () then @@ -751,7 +751,7 @@ let vernac_declare_module_type {loc;v=id} binders_ast mty_sign mty_ast_l = List.iter (fun (export,id) -> Option.iter - (fun export -> vernac_import export [Ident (Loc.tag id)]) export + (fun export -> vernac_import export [make ?loc @@ Ident id]) export ) argsexport | _ :: _ -> @@ -817,11 +817,11 @@ let vernac_require from import qidl = let root = match from with | None -> None | Some from -> - let (_, qid) = Libnames.qualid_of_reference from in - let (hd, tl) = Libnames.repr_qualid qid in + let qid = Libnames.qualid_of_reference from in + let (hd, tl) = Libnames.repr_qualid qid.v in Some (Libnames.add_dirpath_suffix hd tl) in - let locate (loc, qid) = + let locate {loc;v=qid} = try let warn = not !Flags.quiet in let (_, dir, f) = Library.locate_qualified_library ?root ~warn qid in @@ -832,7 +832,7 @@ let vernac_require from import qidl = in let modrefl = List.map locate qidl in if Dumpglob.dump () then - List.iter2 (fun (loc, _) dp -> Dumpglob.dump_libref ?loc dp "lib") qidl (List.map fst modrefl); + List.iter2 (fun {CAst.loc} dp -> Dumpglob.dump_libref ?loc dp "lib") qidl (List.map fst modrefl); Library.require_library_from_dirpath modrefl import (* Coercions and canonical structures *) @@ -907,7 +907,7 @@ let vernac_set_used_variables e = (str "Unknown variable: " ++ Id.print id)) l; let _, to_clear = Proof_global.set_used_variables l in - let to_clear = List.map snd to_clear in + let to_clear = List.map (fun x -> x.CAst.v) to_clear in Proof_global.with_current_proof begin fun _ p -> if List.is_empty to_clear then (p, ()) else @@ -1688,10 +1688,10 @@ let print_about_hyp_globs ?loc ref_or_by_not udecl glopt = (* FIXME error on non None udecl if we find the hyp. *) let glnumopt = query_command_selector ?loc glopt in let gl,id = - match glnumopt,ref_or_by_not with - | None,AN (Ident (_loc,id)) -> (* goal number not given, catch any failure *) + match glnumopt, ref_or_by_not.v with + | None,AN {v=Ident id} -> (* goal number not given, catch any failure *) (try get_nth_goal 1,id with _ -> raise NoHyp) - | Some n,AN (Ident (_loc,id)) -> (* goal number given, catch if wong *) + | Some n,AN {v=Ident id} -> (* goal number given, catch if wong *) (try get_nth_goal n,id with Failure _ -> user_err ?loc ~hdr:"print_about_hyp_globs" @@ -1774,7 +1774,7 @@ let vernac_print ~atts env sigma = | PrintStrategy r -> print_strategy r let global_module r = - let (loc,qid) = qualid_of_reference r in + let {loc;v=qid} = qualid_of_reference r in try Nametab.full_name_module qid with Not_found -> user_err ?loc ~hdr:"global_module" @@ -1858,10 +1858,10 @@ let vernac_search ~atts s gopt r = Search.prioritize_search) pr_search let vernac_locate = function - | LocateAny (AN qid) -> print_located_qualid qid - | LocateTerm (AN qid) -> print_located_term qid - | LocateAny (ByNotation (_, (ntn, sc))) (** TODO : handle Ltac notations *) - | LocateTerm (ByNotation (_, (ntn, sc))) -> + | LocateAny {v=AN qid} -> print_located_qualid qid + | LocateTerm {v=AN qid} -> print_located_term qid + | LocateAny {v=ByNotation (ntn, sc)} (** TODO : handle Ltac notations *) + | LocateTerm {v=ByNotation (ntn, sc)} -> let _, env = Pfedit.get_current_context () in Notation.locate_notation (Constrextern.without_symbols (pr_lglob_constr_env env)) ntn sc @@ -2259,7 +2259,7 @@ let with_fail st b f = | _ -> assert false end -let interp ?(verbosely=true) ?proof ~st (loc,c) = +let interp ?(verbosely=true) ?proof ~st {CAst.loc;v=c} = let orig_univ_poly = Flags.is_universe_polymorphism () in let orig_program_mode = Flags.is_program_mode () in let flags f atts = diff --git a/vernac/vernacentries.mli b/vernac/vernacentries.mli index 13ecaf37b9..f6199e8203 100644 --- a/vernac/vernacentries.mli +++ b/vernac/vernacentries.mli @@ -20,7 +20,7 @@ val vernac_require : val interp : ?verbosely:bool -> ?proof:Proof_global.closed_proof -> - st:Vernacstate.t -> Vernacexpr.vernac_control Loc.located -> Vernacstate.t + st:Vernacstate.t -> Vernacexpr.vernac_control CAst.t -> Vernacstate.t (** Prepare a "match" template for a given inductive type. For each branch of the match, we list the constructor name |