diff options
265 files changed, 11040 insertions, 2628 deletions
diff --git a/.bintray.json b/.bintray.json new file mode 100644 index 000000000..fb9e55368 --- /dev/null +++ b/.bintray.json @@ -0,0 +1,20 @@ +{ + "package": { + "name": "coq", + "repo": "coq", + "subject": "coq" + }, + + "version": { + "name": "8.8+alpha" + }, + + "files": + [ + {"includePattern": "_build/(.*\\.dmg)", "uploadPattern": "$1", + "matrixParams": { + "override": 1 } + } + ], + "publish": true +} diff --git a/.gitignore b/.gitignore index 71de7bb8d..36536ec96 100644 --- a/.gitignore +++ b/.gitignore @@ -84,6 +84,9 @@ test-suite/coq-makefile/*/subdir/done test-suite/coq-makefile/merlin1/.merlin test-suite/coq-makefile/plugin-reach-outside-API-and-fail/_CoqProject test-suite/coq-makefile/plugin-reach-outside-API-and-succeed-by-bypassing-the-API/_CoqProject +test-suite/coqdoc/Coqdoc.* +test-suite/coqdoc/index.html +test-suite/coqdoc/coqdoc.css # documentation diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index b47494d3a..8beeffcca 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -269,7 +269,6 @@ ci-coq-dpdgraph: <<: *ci-template-vars EXTRA_OPAM: "ocamlgraph" EXTRA_PACKAGES: "autoconf" - allow_failure: true ci-coquelicot: <<: *ci-template @@ -9,6 +9,7 @@ ## If you're mentionned here and want to update your information, ## either amend this file and commit it, or contact the coqdev list +Abhishek Anand <abhishek.anand.iitg@gmail.com> Abhishek Anand (@brixpro-home) <abhishek.anand.iitg@gmail.com> Jim Apple <github.public@jbapple.com> jbapple <github.public@jbapple.com> Bruno Barras <bruno.barras@inria.fr> barras <barras@85f007b7-540e-0410-9357-904b9bb8a0f7> Bruno Barras <bruno.barras@inria.fr> barras-local <barras-local@85f007b7-540e-0410-9357-904b9bb8a0f7> @@ -27,7 +28,7 @@ Judicaël Courant <courant@gforge> courant <courant@85f007b7-54 Pierre Courtieu <Pierre.Courtieu@cnam.fr> courtieu <courtieu@85f007b7-540e-0410-9357-904b9bb8a0f7> David Delahaye <delahaye@gforge> delahaye <delahaye@85f007b7-540e-0410-9357-904b9bb8a0f7> Maxime Dénès <mail@maximedenes.fr> mdenes <mdenes@85f007b7-540e-0410-9357-904b9bb8a0f7> -Daniel de Rauglaudre <daniel.de_rauglaudre@inria.fr> ddr <ddr@85f007b7-540e-0410-9357-904b9bb8a0f7> +Maxime Dénès <mail@maximedenes.fr> Maxime Denes <maximedenes@gillespie.inria.fr> Olivier Desmettre <desmettr@gforge> desmettr <desmettr@85f007b7-540e-0410-9357-904b9bb8a0f7> Damien Doligez <doligez@gforge> doligez <doligez@85f007b7-540e-0410-9357-904b9bb8a0f7> Jean-Christophe Filliâtre <Jean-Christophe.Filliatre@lri.fr> filliatr <filliatr@85f007b7-540e-0410-9357-904b9bb8a0f7> @@ -36,7 +37,10 @@ Julien Forest <julien.forest@ensiie.fr> jforest <jforest@85f007b7-540 Julien Forest <julien.forest@ensiie.fr> forest <jforest@mourvedre.ensiie.fr> Julien Forest <julien.forest@ensiie.fr> jforest <jforest@thune> Julien Forest <julien.forest@ensiie.fr> jforest <jforest@daneel.lan.home> +Julien Forest <julien.forest@ensiie.fr> Julien Forest <forest@ensiie.fr> Emilio Jesus Gallego Arias <e+git@x80.org> Emilio Jesús Gallego Arias <e+git@x80.org> +Gaëtan Gilbert <gaetan.gilbert@skyskimmer.net> <gaetan.gilbert@ens-lyon.fr> +Gaëtan Gilbert <gaetan.gilbert@skyskimmer.net> <gaetan.gilbert@skyskimmer.net> Stéphane Glondu <steph@glondu.net> glondu <glondu@85f007b7-540e-0410-9357-904b9bb8a0f7> Stéphane Glondu <steph@glondu.net> Stephane Glondu <steph@glondu.net> Benjamin Grégoire <benjamin.gregoire@inria.fr> Benjamin Gregoire <Benjamin.Gregoire@inria.fr> @@ -51,9 +55,12 @@ Tom Hutchinson <thutchin@gforge> thutchin <thutchin@85f007b7-5 Cezary Kaliszyk <cek@gforge> cek <cek@85f007b7-540e-0410-9357-904b9bb8a0f7> Florent Kirchner <fkirchne@gforge> fkirchne <fkirchne@85f007b7-540e-0410-9357-904b9bb8a0f7> Florent Kirchner <fkirchne@gforge> kirchner <kirchner@85f007b7-540e-0410-9357-904b9bb8a0f7> -Matej Kosik <matej.kosik@inria.fr> Matej Kosik <m4tej.kosik@gmail.com> +Matej KoÅ¡Ãk <matej.kosik@inria.fr> Matej Kosik <m4tej.kosik@gmail.com> +Matej KoÅ¡Ãk <matej.kosik@inria.fr> Matej Kosik <matej.kosik@inria.fr> Marc Lasson <marc.lasson@gmail.com> mlasson <marc.lasson@gmail.com> +William Lawvere <mundungus.corleone@gmail.com> william-lawvere <mundungus.corleone@gmail.com> Pierre Letouzey <pierre.letouzey@inria.fr> letouzey <letouzey@85f007b7-540e-0410-9357-904b9bb8a0f7> +Pierre Letouzey <pierre.letouzey@inria.fr> letouzey <pierre.letouzey@inria.fr> Assia Mahboubi <assia.mahboubi@inria.fr> amahboub <amahboub@85f007b7-540e-0410-9357-904b9bb8a0f7> Evgeny Makarov <emakarov@gforge> emakarov <emakarov@85f007b7-540e-0410-9357-904b9bb8a0f7> Gregory Malecha <gmalecha@eecs.harvard.edu> Gregory Malecha <gmalecha@cs.harvard.edu> @@ -68,15 +75,19 @@ Julien Narboux <jnarboux@gforge> jnarboux <jnarboux@85f007b7-5 Julien Narboux <jnarboux@gforge> narboux <narboux@85f007b7-540e-0410-9357-904b9bb8a0f7> Jean-Marc Notin <notin@gforge> notin,no-port-forwarding,no-agent-forwarding,no-X11-forwarding,no-pty <notin,no-port-forwarding,no-agent-forwarding,no-X11-forwarding,no-pty@85f007b7-540e-0410-9357-904b9bb8a0f7> Jean-Marc Notin <notin@gforge> notin <notin@85f007b7-540e-0410-9357-904b9bb8a0f7> -Russel O'Connor <roconnor@gforge> roconnor <roconnor@85f007b7-540e-0410-9357-904b9bb8a0f7> +Russell O'Connor <roconnor@blockstream.io> roconnor <roconnor@85f007b7-540e-0410-9357-904b9bb8a0f7> +Russell O'Connor <roconnor@blockstream.io> roconnor-blockstream <roconnor@blockstream.com> Christine Paulin <cpaulin@gforge> cpaulin <cpaulin@85f007b7-540e-0410-9357-904b9bb8a0f7> Christine Paulin <cpaulin@gforge> mohring <mohring@85f007b7-540e-0410-9357-904b9bb8a0f7> Pierre-Marie Pédrot <pierre-marie.pedrot@inria.fr> ppedrot <ppedrot@85f007b7-540e-0410-9357-904b9bb8a0f7> Loïc Pottier <pottier@gforge> pottier <pottier@85f007b7-540e-0410-9357-904b9bb8a0f7> Matthias Puech <puech@gforge> puech <puech@85f007b7-540e-0410-9357-904b9bb8a0f7> -Yann Régis-Gianas <yrg@pps.univ-paris-diderot.fr> regisgia <regisgia@85f007b7-540e-0410-9357-904b9bb8a0f7> +Lars Rasmusson <lars.rasmusson@sics.se> larsr <Lars.Rasmusson@sics.se> +Daniel de Rauglaudre <daniel.de_rauglaudre@inria.fr> ddr <ddr@85f007b7-540e-0410-9357-904b9bb8a0f7> Daniel de Rauglaudre <daniel.de_rauglaudre@inria.fr> Daniel de Rauglaudre <daniel.de_rauglaudre@inria.fr> Daniel de Rauglaudre <daniel.de_rauglaudre@inria.fr> Daniel De Rauglaudre <ddr@gforge> +Yann Régis-Gianas <yrg@pps.univ-paris-diderot.fr> regisgia <regisgia@85f007b7-540e-0410-9357-904b9bb8a0f7> +Yann Régis-Gianas <yrg@pps.univ-paris-diderot.fr> Regis-Gianas <yrg@pps.univ-paris-diderot.fr> Clément Renard <clrenard@gforge> clrenard <clrenard@85f007b7-540e-0410-9357-904b9bb8a0f7> Claudio Sacerdoti Coen <sacerdot@gforge> sacerdot <sacerdot@85f007b7-540e-0410-9357-904b9bb8a0f7> Vincent Siles <vsiles@gforge> vsiles <vsiles@85f007b7-540e-0410-9357-904b9bb8a0f7> diff --git a/.travis.yml b/.travis.yml index 9c7ad553f..2d6d9a2a6 100644 --- a/.travis.yml +++ b/.travis.yml @@ -32,6 +32,7 @@ env: - COMPILER="system" - CAMLP5_VER="6.14" - NATIVE_COMP="yes" + - COQ_DEST="-local" # Main test suites matrix: - TEST_TARGET="test-suite" COMPILER="4.02.3+32bit" @@ -62,7 +63,6 @@ env: matrix: allow_failures: - - env: TEST_TARGET="ci-coq-dpdgraph" EXTRA_OPAM="ocamlgraph" - env: TEST_TARGET="ci-geocoq TIMED=1" include: @@ -139,11 +139,45 @@ matrix: env: - TEST_TARGET="test-suite" - COMPILER="4.02.3" + - CAMLP5_VER="6.17" - NATIVE_COMP="no" + - COQ_DEST="-local" before_install: - brew update - - brew install opam - - brew install gnu-time + - brew install opam gnu-time + + - os: osx + env: + - TEST_TARGET="" + - COMPILER="4.02.3" + - CAMLP5_VER="6.17" + - NATIVE_COMP="no" + - COQ_DEST="-prefix ${PWD}/_install" + - EXTRA_CONF="-coqide opt -warn-error" + - EXTRA_OPAM="lablgtk-extras" + before_install: + - brew update + - brew install opam gnu-time gtk+ expat gtksourceview libxml2 gdk-pixbuf python3 + - pip3 install macpack + before_deploy: + - dev/build/osx/make-macos-dmg.sh + deploy: + - provider: bintray + user: maximedenes + file: .bintray.json + key: + secure: "gUvXWwWR0gicDqsKOnBfe45taToSFied6gN8tCa5IOtl6E6gFoHoPZ83ZWXQsZP50oMDFS5eji0VQAFGEbOsGrTZaD9Y9Jnu34NND78SWL1tsJ6nHO3aCAoMpB0N3+oRuF6S+9HStU6KXWqgj+GeU4vZ4TOlG01RGctJa6U3vII=" + skip_cleanup: true + on: + all_branches: true + - provider: releases + api_key: + secure: "Z/ewvydCLXEhlBBtQGYm2nZ8o+2RP+MwA5uEDuu6mEpZttUZAYaoHivChxADLXz8LNKvUloIeBeIL/PrLk6QnhSur/s2iEYHssrnl99SkAPtoWggyfsdacuKLMkpLoZGOBIEYKPuXuEZyqvugSUO42rSya1zdjcnXc4l+E/bXMc=" + file: _build/*.dmg + skip_cleanup: true + on: + tags: true + repo: coq/coq before_install: - if [ "${TRAVIS_PULL_REQUEST}" != "false" ]; then echo "Tested commit (followed by parent commits):"; git log -1; for commit in `git log -1 --format="%P"`; do echo; git log -1 $commit; done; fi @@ -159,7 +193,7 @@ script: - set -e - echo 'Configuring Coq...' && echo -en 'travis_fold:start:coq.config\\r' -- ./configure -local -native-compiler ${NATIVE_COMP} ${EXTRA_CONF} +- ./configure ${COQ_DEST} -native-compiler ${NATIVE_COMP} ${EXTRA_CONF} - echo -en 'travis_fold:end:coq.config\\r' - echo 'Building Coq...' && echo -en 'travis_fold:start:coq.build\\r' diff --git a/API/API.ml b/API/API.ml index c952e123d..c4bcef6f6 100644 --- a/API/API.ml +++ b/API/API.ml @@ -43,7 +43,7 @@ module Cbytecodes = Cbytecodes (* module Copcodes *) module Cemitcodes = Cemitcodes (* module Nativevalues *) -(* module Primitives *) +(* module CPrimitives *) module Opaqueproof = Opaqueproof module Declareops = Declareops module Retroknowledge = Retroknowledge @@ -169,7 +169,6 @@ module Stdarg = Stdarg module Genintern = Genintern module Constrexpr_ops = Constrexpr_ops module Notation_ops = Notation_ops -module Ppextend = Ppextend module Notation = Notation module Dumpglob = Dumpglob (* module Syntax_def *) diff --git a/API/API.mli b/API/API.mli index a0e77edd1..8b0bef48c 100644 --- a/API/API.mli +++ b/API/API.mli @@ -1280,23 +1280,28 @@ sig | Algebraic of module_expression | Struct of module_signature | FullStruct - and module_body = + and 'a generic_module_body = { mod_mp : Names.ModPath.t; - mod_expr : module_implementation; + mod_expr : 'a; mod_type : module_signature; mod_type_alg : module_expression option; mod_constraints : Univ.ContextSet.t; mod_delta : Mod_subst.delta_resolver; - mod_retroknowledge : Retroknowledge.action list + mod_retroknowledge : 'a module_retroknowledge; } and module_signature = (module_type_body,structure_body) functorize - and module_type_body = module_body + and module_body = module_implementation generic_module_body + and module_type_body = unit generic_module_body and structure_body = (Names.Label.t * structure_field_body) list and structure_field_body = | SFBconst of constant_body | SFBmind of mutual_inductive_body | SFBmodule of module_body | SFBmodtype of module_type_body + and _ module_retroknowledge = + | ModBodyRK : + Retroknowledge.action list -> module_implementation module_retroknowledge + | ModTypeRK : unit module_retroknowledge end module Declareops : @@ -2107,6 +2112,7 @@ sig val coq_not_ref : Globnames.global_reference lazy_t val coq_or_ref : Globnames.global_reference lazy_t val build_coq_and : Globnames.global_reference Util.delayed + val build_coq_or : Globnames.global_reference Util.delayed val build_coq_I : Globnames.global_reference Util.delayed val coq_reference : string -> string list -> string -> Globnames.global_reference end @@ -3072,55 +3078,67 @@ end (* XXX: Located manually from intf *) module Glob_term : sig - type cases_pattern_r = + type 'a cases_pattern_r = | PatVar of Names.Name.t - | PatCstr of Names.constructor * cases_pattern list * Names.Name.t - and cases_pattern = cases_pattern_r CAst.t + | PatCstr of Names.constructor * 'a cases_pattern_g list * Names.Name.t + and 'a cases_pattern_g = ('a cases_pattern_r, 'a) DAst.t + type cases_pattern = [ `any ] cases_pattern_g type existential_name = Names.Id.t - type glob_constr_r = + type 'a glob_constr_r = | GRef of Globnames.global_reference * Misctypes.glob_level list option (** An identifier that represents a reference to an object defined either in the (global) environment or in the (local) context. *) | GVar of Names.Id.t (** An identifier that cannot be regarded as "GRef". Bound variables are typically represented this way. *) - | GEvar of existential_name * (Names.Id.t * glob_constr) list + | GEvar of existential_name * (Names.Id.t * 'a glob_constr_g) list | GPatVar of Evar_kinds.matching_var_kind - | GApp of glob_constr * glob_constr list - | GLambda of Names.Name.t * Decl_kinds.binding_kind * glob_constr * glob_constr - | GProd of Names.Name.t * Decl_kinds.binding_kind * glob_constr * glob_constr - | GLetIn of Names.Name.t * glob_constr * glob_constr option * glob_constr - | GCases of Term.case_style * glob_constr option * tomatch_tuples * cases_clauses - | GLetTuple of Names.Name.t list * (Names.Name.t * glob_constr option) * glob_constr * glob_constr - | GIf of glob_constr * (Names.Name.t * glob_constr option) * glob_constr * glob_constr - | GRec of fix_kind * Names.Id.t array * glob_decl list array * - glob_constr array * glob_constr array + | GApp of 'a glob_constr_g * 'a glob_constr_g list + | GLambda of Names.Name.t * Decl_kinds.binding_kind * 'a glob_constr_g * 'a glob_constr_g + | GProd of Names.Name.t * Decl_kinds.binding_kind * 'a glob_constr_g * 'a glob_constr_g + | GLetIn of Names.Name.t * 'a glob_constr_g * 'a glob_constr_g option * 'a glob_constr_g + | GCases of Term.case_style * 'a glob_constr_g option * 'a tomatch_tuples_g * 'a cases_clauses_g + | GLetTuple of Names.Name.t list * (Names.Name.t * 'a glob_constr_g option) * 'a glob_constr_g * 'a glob_constr_g + | GIf of 'a glob_constr_g * (Names.Name.t * 'a glob_constr_g option) * 'a glob_constr_g * 'a glob_constr_g + | GRec of 'a fix_kind_g * Names.Id.t array * 'a glob_decl_g list array * + 'a glob_constr_g array * 'a glob_constr_g array | GSort of Misctypes.glob_sort | GHole of Evar_kinds.t * Misctypes.intro_pattern_naming_expr * Genarg.glob_generic_argument option - | GCast of glob_constr * glob_constr Misctypes.cast_type + | GCast of 'a glob_constr_g * 'a glob_constr_g Misctypes.cast_type - and glob_constr = glob_constr_r CAst.t + and 'a glob_constr_g = ('a glob_constr_r, 'a) DAst.t - and glob_decl = Names.Name.t * Decl_kinds.binding_kind * glob_constr option * glob_constr + and 'a glob_decl_g = Names.Name.t * Decl_kinds.binding_kind * 'a glob_constr_g option * 'a glob_constr_g - and fix_recursion_order = + and 'a fix_recursion_order_g = | GStructRec - | GWfRec of glob_constr - | GMeasureRec of glob_constr * glob_constr option + | GWfRec of 'a glob_constr_g + | GMeasureRec of 'a glob_constr_g * 'a glob_constr_g option - and fix_kind = - | GFix of ((int option * fix_recursion_order) array * int) + and 'a fix_kind_g = + | GFix of ((int option * 'a fix_recursion_order_g) array * int) | GCoFix of int - and predicate_pattern = + and 'a predicate_pattern_g = Names.Name.t * (Names.inductive * Names.Name.t list) Loc.located option - and tomatch_tuple = (glob_constr * predicate_pattern) + and 'a tomatch_tuple_g = ('a glob_constr_g * 'a predicate_pattern_g) - and tomatch_tuples = tomatch_tuple list + and 'a tomatch_tuples_g = 'a tomatch_tuple_g list - and cases_clause = (Names.Id.t list * cases_pattern list * glob_constr) Loc.located - and cases_clauses = cases_clause list + and 'a cases_clause_g = (Names.Id.t list * 'a cases_pattern_g list * 'a glob_constr_g) Loc.located + and 'a cases_clauses_g = 'a cases_clause_g list + + type glob_constr = [ `any ] glob_constr_g + type tomatch_tuple = [ `any ] tomatch_tuple_g + type tomatch_tuples = [ `any ] tomatch_tuples_g + type cases_clause = [ `any ] cases_clause_g + type cases_clauses = [ `any ] cases_clauses_g + type glob_decl = [ `any ] glob_decl_g + type fix_kind = [ `any ] fix_kind_g + type predicate_pattern = [ `any ] predicate_pattern_g + type any_glob_constr = + | AnyGlobConstr : 'r glob_constr_g -> any_glob_constr (** A globalised term together with a closure representing the value of its free variables. Intended for use when these variables are taken @@ -3184,6 +3202,10 @@ sig | NCast of notation_constr * notation_constr Misctypes.cast_type type interpretation = (Names.Id.t * (subscopes * notation_var_instance_type)) list * notation_constr + type precedence = int + type parenRelation = + | L | E | Any | Prec of precedence + type tolerability = precedence * parenRelation end module Tactypes : @@ -3782,6 +3804,12 @@ sig | DefaultInline | InlineAt of int + type cumulative_inductive_parsing_flag = + | GlobalCumulativity + | GlobalNonCumulativity + | LocalCumulativity + | LocalNonCumulativity + type vernac_expr = | VernacLoad of verbose_flag * string | VernacTime of vernac_expr Loc.located @@ -3806,7 +3834,7 @@ sig | VernacExactProof of Constrexpr.constr_expr | VernacAssumption of (Decl_kinds.locality option * Decl_kinds.assumption_object_kind) * inline * (plident list * Constrexpr.constr_expr) with_coercion list - | VernacInductive of Decl_kinds.cumulative_inductive_flag * Decl_kinds.private_flag * inductive_flag * (inductive_expr * decl_notation list) list + | VernacInductive of cumulative_inductive_parsing_flag * Decl_kinds.private_flag * inductive_flag * (inductive_expr * decl_notation list) list | VernacFixpoint of Decl_kinds.locality option * (fixpoint_expr * decl_notation list) list | VernacCoFixpoint of @@ -3970,11 +3998,14 @@ end module Detyping : sig + type 'a delay = + | Now : 'a delay + | Later : [ `thunk ] delay val print_universes : bool ref val print_evar_arguments : bool ref - val detype : ?lax:bool -> bool -> Names.Id.t list -> Environ.env -> Evd.evar_map -> EConstr.constr -> Glob_term.glob_constr + val detype : 'a delay -> ?lax:bool -> bool -> Names.Id.t list -> Environ.env -> Evd.evar_map -> EConstr.constr -> 'a Glob_term.glob_constr_g val subst_glob_constr : Mod_subst.substitution -> Glob_term.glob_constr -> Glob_term.glob_constr - val set_detype_anonymous : (?loc:Loc.t -> int -> Glob_term.glob_constr) -> unit + val set_detype_anonymous : (?loc:Loc.t -> int -> Names.Id.t) -> unit end module Indrec : @@ -4007,18 +4038,11 @@ sig expand_evars : bool } - type pure_open_constr = Evd.evar_map * EConstr.constr - type glob_constr_ltac_closure = Glob_term.ltac_var_map * Glob_term.glob_constr - val understand_ltac : inference_flags -> Environ.env -> Evd.evar_map -> Glob_term.ltac_var_map -> - typing_constraint -> Glob_term.glob_constr -> pure_open_constr + typing_constraint -> Glob_term.glob_constr -> Evd.evar_map * EConstr.t val understand_tcc : ?flags:inference_flags -> Environ.env -> Evd.evar_map -> ?expected_type:typing_constraint -> Glob_term.glob_constr -> Evd.evar_map * EConstr.constr - val type_uconstr : - ?flags:inference_flags -> - ?expected_type:typing_constraint -> - Geninterp.interp_sign -> Glob_term.closed_glob_constr -> EConstr.constr Tactypes.delayed_open val understand : ?flags:inference_flags -> ?expected_type:typing_constraint -> Environ.env -> Evd.evar_map -> Glob_term.glob_constr -> Constr.t Evd.in_evar_universe_context val check_evars : Environ.env -> Evd.evar_map -> Evd.evar_map -> EConstr.constr -> unit @@ -4173,22 +4197,12 @@ sig 'a -> Notation_term.notation_constr -> Glob_term.glob_constr end -module Ppextend : -sig - - type precedence = int - type parenRelation = - | L | E | Any | Prec of precedence - type tolerability = precedence * parenRelation - -end - module Notation : sig type cases_pattern_status = bool type required_module = Libnames.full_path * string list type 'a prim_token_interpreter = ?loc:Loc.t -> 'a -> Glob_term.glob_constr - type 'a prim_token_uninterpreter = Glob_term.glob_constr list * (Glob_term.glob_constr -> 'a option) * cases_pattern_status + type 'a prim_token_uninterpreter = Glob_term.glob_constr list * (Glob_term.any_glob_constr -> 'a option) * cases_pattern_status type delimiters = string type local_scopes = Notation_term.tmp_scope_name option * Notation_term.scope_name list type notation_location = (Names.DirPath.t * Names.DirPath.t) * string @@ -4283,10 +4297,10 @@ module Constrextern : sig val extern_glob_constr : Names.Id.Set.t -> Glob_term.glob_constr -> Constrexpr.constr_expr val extern_glob_type : Names.Id.Set.t -> Glob_term.glob_constr -> Constrexpr.constr_expr - val extern_constr : ?lax:bool -> bool -> Environ.env -> Evd.evar_map -> Constr.t -> Constrexpr.constr_expr + val extern_constr : ?lax:bool -> bool -> Environ.env -> Evd.evar_map -> EConstr.t -> Constrexpr.constr_expr val without_symbols : ('a -> 'b) -> 'a -> 'b val print_universes : bool ref - val extern_type : bool -> Environ.env -> Evd.evar_map -> Term.types -> Constrexpr.constr_expr + val extern_type : bool -> Environ.env -> Evd.evar_map -> EConstr.t -> Constrexpr.constr_expr val with_universes : ('a -> 'b) -> 'a -> 'b val set_extern_reference : (?loc:Loc.t -> Names.Id.Set.t -> Globnames.global_reference -> Libnames.reference) -> unit @@ -4387,16 +4401,16 @@ end module Evar_refiner : sig + type glob_constr_ltac_closure = Glob_term.ltac_var_map * Glob_term.glob_constr + val w_refine : Evar.t * Evd.evar_info -> - Pretyping.glob_constr_ltac_closure -> Evd.evar_map -> Evd.evar_map + glob_constr_ltac_closure -> Evd.evar_map -> Evd.evar_map end module Proof_type : sig - type prim_rule = - | Cut of bool * bool * Names.Id.t * Term.types - | Refine of Constr.t + type prim_rule = Refine of Constr.t type tactic = Goal.goal Evd.sigma -> Goal.goal list Evd.sigma end @@ -4874,7 +4888,7 @@ sig val pr_with_comments : ?loc:Loc.t -> Pp.t -> Pp.t val pr_lident : Names.Id.t Loc.located -> Pp.t val pr_lname : Names.Name.t Loc.located -> Pp.t - val prec_less : int -> int * Ppextend.parenRelation -> bool + val prec_less : int -> int * Notation_term.parenRelation -> bool val pr_constr_expr : Constrexpr.constr_expr -> Pp.t val pr_lconstr_expr : Constrexpr.constr_expr -> Pp.t val pr_constr_pattern_expr : Constrexpr.constr_pattern_expr -> Pp.t @@ -5235,7 +5249,7 @@ sig val build_selector : Environ.env -> Evd.evar_map -> int -> EConstr.constr -> EConstr.types -> - EConstr.constr -> EConstr.constr -> Evd.evar_map * EConstr.constr + EConstr.constr -> EConstr.constr -> EConstr.constr val replace : EConstr.constr -> EConstr.constr -> unit Proofview.tactic val general_rewrite : orientation -> Locus.occurrences -> freeze_evars_flag -> dep_proof_flag -> @@ -1,12 +1,20 @@ -To be inserted at the proper place: +Changes beyond 8.7 +================== Notations - Recursive notations with the recursive pattern repeating on the right (e.g. "( x ; .. ; y ; z )") now supported. -Changes beyond V8.6 -=================== +Tactics + +- On Linux, "native_compute" calls can be profiled using the "perf" + utility. The command "Set NativeCompute Profiling" enables + profiling, and "Set NativeCompute Profile Filename" customizes + the profile filename. + +Changes from 8.6.1 to 8.7+beta +============================== Tactics @@ -46,19 +54,46 @@ Tactics - In "Tactic Notation" or "TACTIC EXTEND", entry "constr_with_bindings" now uses type classes and rejects terms with unresolved holes, like entry "constr" does. To get the former behavior use - "open_constr_with_bindings" (possible source of incompatibility. + "open_constr_with_bindings" (possible source of incompatibility). - New e-variants eassert, eenough, epose proof, eset, eremember, epose which behave like the corresponding variants with no "e" but turn unresolved implicit arguments into existential variables, on the shelf, rather than failing. +- Tactic injection has become more powerful (closes BZ#4890) and its + documentation has been updated. +- New variants of the `first` and `solve` tacticals that do not rely + on parsing rules, meant to define tactic notations. +- Added support for side effects hooks in `cbv`, `cbn` and `simpl`. + The side effects are provided via a plugin: + https://github.com/herbelin/reduction-effects/ +- It is now possible to take hint database names as parameters in a + Ltac definition or a Tactic Notation. +- New option `Set Ltac Batch Debug` on top of `Set Ltac Debug` for + non-interactive Ltac debug output. -Vernacular Commands +Gallina + +- Now supporting all kinds of binders, including 'pat, in syntax of record fields. -- Goals context can be printed in a more compact way when "Set - Printing Compact Contexts" is activated. +Vernacular Commands +- Goals context can be printed in a more compact way when `Set + Printing Compact Contexts` is activated. +- Unfocused goals can be printed with the `Set Printing Unfocused` + option. +- `Print` now shows the types of let-bindings. +- The compatibility options for printing primitive projections + (`Set Printing Primitive Projection Parameters` and + `Set Printing Primitive Projection Compatibility`) are now off by default. +- Possibility to unset the printing of notations in a more fine grained + fashion than `Unset Printing Notations` is provided without any + user-syntax. The goal is that someone creates a plugin to experiment + such a user-syntax, to be later integrated in Coq when stabilized. +- `About` now tells if a reference is a coercion. - The deprecated `Save` vernacular and its form `Save Theorem id` to close proofs have been removed from the syntax. Please use `Qed`. +- `Search` now sorts results by relevance (the relevance metric is a + weighted sum of number of distinct symbols and size of the term). Standard Library @@ -68,7 +103,10 @@ Standard Library and, consequently, choice of representatives in equivalence classes. Various proof-theoretic characterizations of choice over setoids in file ChoiceFacts.v. -- The BigN, BigZ, BigZ libraries are not part anymore of Coq standard +- New lemmas about iff and about orders on positive and Z. +- New lemmas on powerRZ. +- Strengthened statement of JMeq_eq_dep (closes BZ#4912). +- The BigN, BigZ, BigZ libraries are no longer part of the Coq standard library, they are now provided by a separate repository https://github.com/coq/bignums The split has been done just after the Int31 library. @@ -81,6 +119,9 @@ Standard Library Plugins +- The Ssreflect plugin is now distributed with Coq. Its documentation has + been integrated as a chapter of the reference manual. This chapter is + work in progress so feedback is welcome. - The mathematical proof language (also known as declarative mode) was removed. - A new command Extraction TestCompile has been introduced, not meant for the general user but instead for Coq's test-suite. @@ -122,14 +163,77 @@ Build Infrastructure Universes - Cumulative inductive types. see prefixes "Cumulative", "NonCumulative" - for inductive definitions and the option "Set Inductive Cumulativity" + for inductive definitions and the option "Set Polymorphic Inductive Cumulativity" in the reference manual. +- New syntax `foo@{_}` to instantiate a polymorphic definition with + anonymous universes (can also be used with `Type`). + +XML Protocol and internal changes + +See dev/doc/changes.txt + +Many bugfixes including BZ#1859, BZ#2884, BZ#3613, BZ#3943, BZ#3994, +BZ#4250, BZ#4709, BZ#4720, BZ#4824, BZ#4844, BZ#4911, BZ#5026, BZ#5233, +BZ#5275, BZ#5315, BZ#5336, BZ#5360, BZ#5390, BZ#5414, BZ#5417, BZ#5420, +BZ#5439, BZ#5449, BZ#5475, BZ#5476, BZ#5482, BZ#5501, BZ#5507, BZ#5520, +BZ#5523, BZ#5524, BZ#5553, BZ#5577, BZ#5578, BZ#5589, BZ#5597, BZ#5598, +BZ#5607, BZ#5618, BZ#5619, BZ#5620, BZ#5641, BZ#5648, BZ#5651, BZ#5671. -XML Protocol +Many bugfixes on OS X and Windows (now the test-suite passes on these +platforms too). + +Many optimizations. + +Many documentation improvements. + +Changes from 8.6 to 8.6.1 +========================= -- The `query` call has been modified, now it carries a mandatory - "route_id" integer parameter, that associated the result of such - query with its generated feedback. +- Fix #5380: Default colors for CoqIDE are actually applied. +- Fix plugin warnings +- Document named evars (including Show ident) +- Fix Bug #5574, document function scope +- Adding a test case as requested in bug 5205. +- Fix Bug #5568, no dup notation warnings on repeated module imports +- Fix documentation of Typeclasses eauto := +- Refactor documentation of records. +- Protecting from warnings while compiling 8.6 +- Fixing an inconsistency between configure and configure.ml +- Add test-suite checks for coqchk with constraints +- Fix bug #5019 (looping zify on dependent types) +- Fix bug 5550: "typeclasses eauto with" does not work with section variables. +- Bug 5546, qualify datatype constructors when needed in Show Match +- Bug #5535, test for Show with -emacs +- Fix bug #5486, don't reverse ids in tuples +- Fixing #5522 (anomaly with free vars of pat) +- Fix bug #5526, don't check for nonlinearity in notation if printing only +- Fix bug #5255 +- Fix bug #3659: -time should understand multibyte encodings. +- FIx bug #5300: Anomaly: Uncaught exception Not_found" in "Print Assumptions". +- Fix outdated description in RefMan. +- Repairing `Set Rewriting Schemes` +- Fixing #5487 (v8.5 regression on ltac-matching expressions with evars). +- Fix description of command-line arguments for Add (Rec) LoadPath +- Fix bug #5377: @? patterns broken. +- add XML protocol doc +- Fix anomaly when doing [all:Check _.] during a proof. +- Correction of bug #4306 +- Fix #5435: [Eval native_compute in] raises anomaly. +- Instances should obey universe binders even when defined by tactics. +- Intern names bound in match patterns +- funind: Ignore missing info for current function +- Do not typecheck twice the type of opaque constants. +- show unused intro pattern warning +- [future] Be eager when "chaining" already resolved future values. +- Opaque side effects +- Fix #5132: coq_makefile generates incorrect install goal +- Run non-tactic comands without resilient_command +- Univs: fix bug #5365, generation of u+k <= v constraints +- make `emit' tail recursive +- Don't require printing-only notation to be productive +- Fix the way setoid_rewrite handles bindings. +- Fix for bug 5244 - set printing width ignored when given enough space +- Fix bug 4969, autoapply was not tagging shelved subgoals correctly Changes from V8.6beta1 to V8.6 ============================== diff --git a/CONTRIBUTING.md b/CONTRIBUTING.md new file mode 100644 index 000000000..05f21895e --- /dev/null +++ b/CONTRIBUTING.md @@ -0,0 +1,55 @@ +# Contributing to Coq + +Thank you for your interest in contributing to Coq! There are many ways to contribute, and we appreciate all of them. + +## Bug Reports + +Bug reports are enormously useful to identify issues with Coq; we can't fix what we don't know about. Bug reports should all be filed on the [Coq Bugzilla](https://coq.inria.fr/bugs/) (you'll have to make an account). You can file a bug for any of the following: + +- An anomaly. These are always considered bugs, so Coq will even ask you to file a bug report! +- An error you didn't expect. If you're not sure whether it's a bug or intentional, feel free to file a bug anyway. We may want to improve the documentation or error message. +- Missing documentation. It's helpful to track where the documentation should be improved, so please file a bug if you can't find or don't understand some bit of documentation. +- An error message that wasn't as helpful as you'd like. Bonus points for suggesting what information would have helped you. +- Bugs in CoqIDE should also be filed on the Bugzilla. Bugs in the Emacs plugin should be filed against [ProofGeneral](https://github.com/ProofGeneral/PG/issues), or against [company-coq](https://github.com/cpitclaudel/company-coq/issues) if they are specific to company-coq features. + +It would help if you search the existing issues before reporting a bug. This can be difficult, so consider it extra credit. We don't mind duplicate bug reports. + +When it applies, it's extremely helpful for bug reports to include sample code, and much better if the code is self-contained and complete. It's not necessary to minimize your bug or identify precisely where the issue is, since someone else can often do this if you include a complete example. We tend to include the code in the bug description itself, but if you have a very large input file then you can add it as an attachment. + +If you want to minimize your bug (or help minimize someone else's) for more extra credit, then you can use the [Coq bug minimizer](https://github.com/JasonGross/coq-tools) (specifically, the bug minimizer is the `find-bug.py` script in that repo). + +## Pull requests + +If you want to contribute a bug fix or feature yourself, pull requests on the [GitHub repository](https://github.com/coq/coq) are the way to contribute directly to the Coq implementation. We recommend you create a fork of the repository on GitHub and push your changes to a new "topic branch" in that fork. From there you can follow the [GitHub pull request documentation](https://help.github.com/articles/about-pull-requests/) to get your changes reviewed and pulled into the Coq source repository. + +Documentation for getting started with the Coq sources is located in various files in [`dev/doc`](/dev/doc) (for example, [debugging.md](/dev/doc/debugging.md)). For further help with the Coq sources, feel free to join the [Coq Gitter chat](https://gitter.im/coq/coq) and ask questions. + +Please make pull requests against the `master` branch. + +It's helpful to run the Coq test suite with `make test-suite` before submitting your change. Travis CI runs this test suite and a much larger one including external Coq developments on every pull request, but these results take significantly longer to come back (on the order of a few hours). Running the test suite locally will take somewhere around 10-15 minutes. + +Don't be alarmed if the pull request process takes some time. It can take a few days to get feedback, approval on the final changes, and then a merge. Coq doesn't release new versions very frequently so it can take a few months for your change to land in a released version. That said, you can start using the latest Coq `master` branch to take advantage of all the new features, improvements, and fixes. + +Here are a few tags Coq developers may add to your PR and what they mean. In general feedback and requests for you as the pull request author will be in the comments and tags are only used to organize pull requests. + +- [needs: rebase](https://github.com/coq/coq/pulls?utf8=%E2%9C%93&q=is%3Aopen%20is%3Apr%20label%3A%22needs%3A%20rebase%22%20) indicates the PR should be rebased on top of the latest `master` branch. See the [GitHub documentation](https://help.github.com/articles/about-git-rebase/) for a brief introduction to using `git rebase`. +- [needs: fixing](https://github.com/coq/coq/pulls?q=is%3Aopen+is%3Apr+label%3A%22needs%3A+fixing%22) indicates the PR needs a fix, as discussed in the comments. +- [needs: testing](https://github.com/coq/coq/pulls?q=is%3Aopen+is%3Apr+label%3A%22needs%3A+testing%22) indicates the PR needs testing. This is often used when testing beyond what the test suite can handle is required. For example, performance benchmarking is currently performed with a different infrastructure. Unless some followup is specifically requested you aren't expected to do this additional testing. + +## Documentation + +Currently the process for contributing to the documentation is the same as for changing anything else in Coq, so please submit a pull request as described above. + +Bugzilla includes a component to mark bugs related to documentation. You can view a list of documentation-related bugs using a [Bugzilla search](https://coq.inria.fr/bugs/buglist.cgi?component=Doc&list_id=455006&product=Coq&resolution=---). Many of these bugs can be fixed by contributing writing, without knowledge of Coq's OCaml source code. + +The sources for the [Coq reference manual](https://coq.inria.fr/distrib/current/refman/) are at [`doc/refman`](/doc/refman). These are written in LaTeX and compiled to HTML with [HeVeA](http://hevea.inria.fr/). + +## Contributing outside this repository + +There are many useful ways to contribute to the Coq ecosystem that don't involve the Coq repository. + +Tutorials to teach Coq, and especially to teach particular advanced features, would be much appreciated. Some tutorials are listed on the [Coq website](https://coq.inria.fr/documentation). If you would like to add a link to this list, please make a pull request against the Coq website repository at https://github.com/coq/www. + +Ask and answer questions on [Stack Exchange](https://stackexchange.com/filters/299857/questions-tagged-coq-on-stackexchange-sites) which has a helpful community of Coq users. + +Hang out on the Coq IRC channel, `irc://irc.freenode.net/#coq`, and help answer questions. @@ -54,6 +54,7 @@ FIND_SKIP_DIRS:='(' \ -name "$${GIT_DIR}" -o \ -name '_build' -o \ -name '_build_ci' -o \ + -name 'user-contrib' -o \ -name 'coq-makefile' -o \ -name '.opamcache' -o \ -name '.coq-native' \ diff --git a/Makefile.build b/Makefile.build index b45c6427a..26a40c6cc 100644 --- a/Makefile.build +++ b/Makefile.build @@ -31,7 +31,7 @@ TIMED ?= # When $(TIMED) is set, the time command used by default is $(STDTIME) # (see below), unless the following variable is non-empty. For instance, -# it could be set to "'/usr/bin/time -p'". +# it could be set to "'/usr/bin/env time -p'". TIMECMD ?= # When non-empty, -time is passed to coqc and the output is recorded @@ -46,9 +46,6 @@ NO_RECALC_DEPS ?= # Non-empty runs the checker on all produced .vo files: VALIDATE ?= -# Is "-xml" when building XML library: -COQ_XML ?= - # Output file names for timed builds TIME_OF_BUILD_FILE ?= time-of-build.log TIME_OF_BUILD_BEFORE_FILE ?= time-of-build-before.log @@ -167,11 +164,11 @@ DEPENDENCIES := \ ########################################################################### # Default timing command -# Use /usr/bin/time on linux, gtime on Mac OS +# Use /usr/bin/env time on linux, gtime on Mac OS TIMEFMT?="$* (real: %e, user: %U, sys: %S, mem: %M ko)" ifneq (,$(TIMED)) -ifeq (0,$(shell /usr/bin/time -f $(TIMEFMT) true >/dev/null 2>/dev/null; echo $$?)) -STDTIME?=/usr/bin/time -f $(TIMEFMT) +ifeq (0,$(shell /usr/bin/env time -f $(TIMEFMT) true >/dev/null 2>/dev/null; echo $$?)) +STDTIME?=/usr/bin/env time -f $(TIMEFMT) else ifeq (0,$(shell gtime -f $(TIMEFMT) true >/dev/null 2>/dev/null; echo $$?)) STDTIME?=gtime -f $(TIMEFMT) @@ -180,7 +177,7 @@ STDTIME?=time endif endif else -STDTIME?=/usr/bin/time -f $(TIMEFMT) +STDTIME?=/usr/bin/env time -f $(TIMEFMT) endif TIMER=$(if $(TIMED), $(STDTIME), $(TIMECMD)) @@ -189,7 +186,7 @@ TIMER=$(if $(TIMED), $(STDTIME), $(TIMECMD)) # the output format of the unix command time. For instance: # TIME="%C (%U user, %S sys, %e total, %M maxres)" -COQOPTS=$(COQ_XML) $(NATIVECOMPUTE) +COQOPTS=$(NATIVECOMPUTE) BOOTCOQC=$(TIMER) $(COQTOPBEST) -boot $(COQOPTS) -compile LOCALINCLUDES=$(if $(filter plugins/%,$<),-I lib -I API -open API $(addprefix -I plugins/,$(PLUGINDIRS)),$(addprefix -I ,$(SRCDIRS))) @@ -273,9 +270,6 @@ $(error This Makefile needs GNU Make 3.81 or later (that is a version that suppo endif VO_TOOLS_DEP := $(COQTOPBEST) -ifdef COQ_XML - VO_TOOLS_DEP += $(COQDOC) -endif ifdef VALIDATE VO_TOOLS_DEP += $(CHICKEN) endif @@ -540,7 +534,7 @@ MAKE_TSOPTS=-C test-suite -s VERBOSE=$(VERBOSE) check: validate test-suite -test-suite: world $(ALLSTDLIB).v +test-suite: world byte $(ALLSTDLIB).v $(MAKE) $(MAKE_TSOPTS) clean $(MAKE) $(MAKE_TSOPTS) all @@ -707,9 +701,9 @@ TIMING_EXTRA = endif theories/Init/%.vo theories/Init/%.glob: theories/Init/%.v $(VO_TOOLS_DEP) - $(SHOW)'COQC $(COQ_XML) -noinit $<' + $(SHOW)'COQC -noinit $<' $(HIDE)rm -f theories/Init/$*.glob - $(HIDE)$(BOOTCOQC) $< $(COQ_XML) -noinit -R theories Coq $(TIMING_ARG) $(TIMING_EXTRA) + $(HIDE)$(BOOTCOQC) $< -noinit -R theories Coq $(TIMING_ARG) $(TIMING_EXTRA) # MExtraction.v generates the ml core file of the micromega tactic. # We check that this generated code is still in sync with the version diff --git a/Makefile.ci b/Makefile.ci index fd5975f72..b5a26d96e 100644 --- a/Makefile.ci +++ b/Makefile.ci @@ -22,6 +22,6 @@ CI_TARGETS=ci-all \ .PHONY: $(CI_TARGETS) -# Generic rule, we use make to easy travis integraton with mixed rules +# Generic rule, we use make to ease travis integration with mixed rules $(CI_TARGETS): ci-%: +./dev/ci/ci-wrapper.sh ci-$*.sh diff --git a/Makefile.common b/Makefile.common index afd6164fc..ccbe9261e 100644 --- a/Makefile.common +++ b/Makefile.common @@ -105,7 +105,7 @@ BYTERUN:=$(addprefix kernel/byterun/, \ CORECMA:=lib/clib.cma lib/lib.cma kernel/kernel.cma intf/intf.cma library/library.cma \ engine/engine.cma pretyping/pretyping.cma interp/interp.cma proofs/proofs.cma \ parsing/parsing.cma printing/printing.cma tactics/tactics.cma vernac/vernac.cma \ - stm/stm.cma toplevel/toplevel.cma parsing/highparsing.cma API/API.cma + parsing/highparsing.cma stm/stm.cma toplevel/toplevel.cma API/API.cma TOPLOOPCMA:=stm/proofworkertop.cma stm/tacworkertop.cma stm/queryworkertop.cma diff --git a/Makefile.doc b/Makefile.doc index 6a81b292e..dd7717359 100644 --- a/Makefile.doc +++ b/Makefile.doc @@ -36,7 +36,7 @@ HEVEA:=hevea HACHA:=hacha HEVEAOPTS:=-fix -exec xxdate.exe HEVEALIB:=/usr/local/lib/hevea:/usr/lib/hevea -HTMLSTYLE:=simple +HTMLSTYLE:=coqremote export TEXINPUTS:=$(HEVEALIB): ifdef COQDOC_NOBOOT COQTEXOPTS:=-n 72 -sl -small @@ -62,7 +62,7 @@ REFMANTEXFILES:=$(addprefix doc/refman/, \ headers.sty Reference-Manual.tex \ RefMan-pre.tex RefMan-int.tex RefMan-com.tex \ RefMan-uti.tex RefMan-ide.tex RefMan-add.tex RefMan-modr.tex \ - AsyncProofs.tex ) \ + AsyncProofs.tex RefMan-ssr.tex) \ $(REFMANCOQTEXFILES) \ REFMANEPSFILES:=doc/refman/coqide.eps doc/refman/coqide-queries.eps @@ -216,7 +216,15 @@ doc/refman/html/index.html: doc/refman/Reference-Manual.html $(REFMANPNGFILES) \ (cd doc/refman/html; $(HACHA) -nolinks -tocbis -o toc.html ../styles.hva ../Reference-Manual.html) $(INSTALLLIB) doc/refman/cover.html doc/refman/html/index.html @touch $(INDEXES) - -$(INSTALLLIB) doc/common/styles/html/$(HTMLSTYLE)/*.css doc/refman/html + (cd doc/common/styles/html/$(HTMLSTYLE);\ + for f in `find . -name \*.css`; do \ + install -m 644 -D $$f ../../../../refman/html/$$f;\ + done) + (cd doc/common/styles/html/$(HTMLSTYLE);\ + for f in `find . -name coqdoc.css -o -name style.css`; do \ + install -m 644 -D $$f ../../../../refman/html/;\ + done) + install -m 644 doc/common/styles/html/$(HTMLSTYLE)/*.css doc/refman/html refman-quick: (cd doc/refman;\ @@ -479,6 +487,12 @@ $(OCAMLDOCDIR)/%.pdf: $(OCAMLDOCDIR)/%.tex $(HIDE)(cd $(OCAMLDOCDIR) ; pdflatex -interaction=batchmode $*.tex && pdflatex -interaction=batchmode $*.tex) $(HIDE)(cd doc/tools/; show_latex_messages -no-overfull ../../$(OCAMLDOCDIR)/$*.log) +########################################################################### +# local web server +########################################################################### + +serve-refman-8080: refman + cd doc/refman/html; python3 -m http.server 8080 # For emacs: # Local Variables: diff --git a/Makefile.ide b/Makefile.ide index b534b385b..542d8c252 100644 --- a/Makefile.ide +++ b/Makefile.ide @@ -55,7 +55,8 @@ IDEFILES=$(wildcard ide/*.lang) ide/coq_style.xml ide/coq.png ide/MacOS/default_ GTKSHARE=$(shell pkg-config --variable=prefix gtk+-2.0)/share GTKBIN=$(shell pkg-config --variable=prefix gtk+-2.0)/bin GTKLIBS=$(shell pkg-config --variable=libdir gtk+-2.0) - +PIXBUFBIN=$(shell pkg-config --variable=prefix gdk-pixbuf-2.0)/bin +SOURCEVIEWSHARE=$(shell pkg-config --variable=prefix gtksourceview-2.0)/share ########################################################################### # CoqIde special targets @@ -127,21 +128,24 @@ ide/%.cmx: ide/%.ml ## Install targets #################### -.PHONY: install-coqide install-ide-bin install-ide-toploop install-ide-files install-ide-info install-ide-devfiles install-ide-byte +.PHONY: install-coqide install-ide-bin install-ide-toploop install-ide-files install-ide-info install-ide-devfiles install-ide-byte install-ide-toploop-byte install-coqide-byte ifeq ($(HASCOQIDE),no) install-coqide: install-ide-toploop else install-coqide: install-ide-bin install-ide-toploop install-ide-files install-ide-info install-ide-devfiles endif +ifeq ($(HASCOQIDE),no) +install-coqide-byte: install-ide-toploop-byte +else +install-coqide-byte: install-ide-toploop-byte install-ide-byte +endif # Apparently, coqide.byte is not meant to be installed install-ide-byte: $(MKDIR) $(FULLCOQLIB) $(INSTALLSH) $(FULLCOQLIB) $(IDECMA) - $(MKDIR) $(FULLCOQLIB)/toploop - $(INSTALLBIN) $(IDETOPLOOPCMA) $(FULLCOQLIB)/toploop/ install-ide-bin: $(MKDIR) $(FULLBINDIR) @@ -151,6 +155,10 @@ install-ide-toploop: ifeq ($(BEST),opt) $(INSTALLBIN) $(IDETOPLOOPCMA:.cma=.cmxs) $(FULLCOQLIB)/toploop/ endif +install-ide-toploop-byte: +ifneq ($(BEST),opt) + $(INSTALLBIN) $(IDETOPLOOPCMA) $(FULLCOQLIB)/toploop/ +endif install-ide-devfiles: $(MKDIR) $(FULLCOQLIB) @@ -193,15 +201,14 @@ $(COQIDEAPP)/Contents/Resources/share: $(COQIDEAPP)/Contents $(MKDIR) $@/coq/ $(INSTALLLIB) ide/coq.png ide/*.lang ide/coq_style.xml $@/coq/ $(MKDIR) $@/gtksourceview-2.0/{language-specs,styles} - $(INSTALLLIB) "$(GTKSHARE)/"gtksourceview-2.0/language-specs/{def.lang,language2.rng} $@/gtksourceview-2.0/language-specs/ - $(INSTALLLIB) "$(GTKSHARE)/"gtksourceview-2.0/styles/{styles.rng,classic.xml} $@/gtksourceview-2.0/styles/ + $(INSTALLLIB) "$(SOURCEVIEWSHARE)/"gtksourceview-2.0/language-specs/{def.lang,language2.rng} $@/gtksourceview-2.0/language-specs/ + $(INSTALLLIB) "$(SOURCEVIEWSHARE)/"gtksourceview-2.0/styles/{styles.rng,classic.xml} $@/gtksourceview-2.0/styles/ cp -R "$(GTKSHARE)/"locale $@ - cp -R "$(GTKSHARE)/"icons $@ cp -R "$(GTKSHARE)/"themes $@ $(COQIDEAPP)/Contents/Resources/loaders: $(COQIDEAPP)/Contents $(MKDIR) $@ - $(INSTALLLIB) $$("$(GTKBIN)/gdk-pixbuf-query-loaders" | sed -n -e '5 s!.*= \(.*\)$$!\1!p')/libpixbufloader-png.so $@ + $(INSTALLLIB) $$("$(PIXBUFBIN)/gdk-pixbuf-query-loaders" | sed -n -e '5 s!.*= \(.*\)$$!\1!p')/libpixbufloader-png.so $@ $(COQIDEAPP)/Contents/Resources/immodules: $(COQIDEAPP)/Contents $(MKDIR) $@ @@ -212,7 +219,7 @@ $(COQIDEAPP)/Contents/Resources/etc: $(COQIDEAPP)/Contents/Resources/lib $(MKDIR) $@/xdg/coq $(INSTALLLIB) ide/MacOS/default_accel_map $@/xdg/coq/coqide.keys $(MKDIR) $@/gtk-2.0 - { "$(GTKBIN)/gdk-pixbuf-query-loaders" $@/../loaders/*.so |\ + { "$(PIXBUFBIN)/gdk-pixbuf-query-loaders" $@/../loaders/*.so |\ sed -e "s!/.*\(/loaders/.*.so\)!@executable_path/../Resources/\1!"; } \ > $@/gtk-2.0/gdk-pixbuf.loaders { "$(GTKBIN)/gtk-query-immodules-2.0" $@/../immodules/*.so |\ @@ -224,32 +231,11 @@ $(COQIDEAPP)/Contents/Resources/etc: $(COQIDEAPP)/Contents/Resources/lib $(COQIDEAPP)/Contents/Resources/lib: $(COQIDEAPP)/Contents/Resources/immodules $(COQIDEAPP)/Contents/Resources/loaders $(COQIDEAPP)/Contents $(COQIDEINAPP) $(MKDIR) $@ - $(INSTALLLIB) $(GTKLIBS)/charset.alias $@/ - $(MKDIR) $@/pango/1.8.0/modules - $(INSTALLLIB) "$(GTKLIBS)/pango/1.8.0/modules/"*.so $@/pango/1.8.0/modules/ - { "$(GTKBIN)/pango-querymodules" $@/pango/1.8.0/modules/*.so |\ - sed -e "s!/.*\(/pango/1.8.0/modules/.*.so\)!@executable_path/../Resources/lib\1!"; } \ - > $@/pango/1.8.0/modules.cache - - for i in $$(otool -L $(COQIDEINAPP) |sed -n -e "\@$(GTKLIBS)@ s/[^/]*\(\/[^ ]*\) .*$$/\1/p"); \ - do cp $$i $@/; \ - ide/MacOS/relatify_with-respect-to_.sh $@/$$(basename $$i) $(GTKLIBS) $@; \ - done - for i in $@/../loaders/*.so $@/../immodules/*.so $@/pango/1.8.0/modules/*.so; \ - do \ - for j in $$(otool -L $$i | sed -n -e "\@$(GTKLIBS)@ s/[^/]*\(\/[^ ]*\) .*$$/\1/p"); \ - do cp $$j $@/; ide/MacOS/relatify_with-respect-to_.sh $@/$$(basename $$j) $(GTKLIBS) $@; done; \ - ide/MacOS/relatify_with-respect-to_.sh $$i $(GTKLIBS) $@; \ - done - EXTRAWORK=1; \ - while [ $${EXTRAWORK} -eq 1 ]; \ - do EXTRAWORK=0; \ - for i in $@/*.dylib; \ - do for j in $$(otool -L $$i | sed -n -e "\@$(GTKLIBS)@ s/[^/]*\(\/[^ ]*\) .*$$/\1/p"); \ - do EXTRAWORK=1; cp $$j $@/; ide/MacOS/relatify_with-respect-to_.sh $@/$$(basename $$j) $(GTKLIBS) $@; done; \ - done; \ + macpack -d ../Resources/lib $(COQIDEINAPP) + for i in $@/../loaders/*.so $@/../immodules/*.so; \ + do \ + macpack -d ../lib $$i; \ done - ide/MacOS/relatify_with-respect-to_.sh $(COQIDEINAPP) $(GTKLIBS) $@ $(COQIDEAPP)/Contents/Resources:$(COQIDEAPP)/Contents/Resources/etc $(COQIDEAPP)/Contents/Resources/share $(INSTALLLIB) ide/MacOS/*.icns $@ diff --git a/Makefile.install b/Makefile.install index 02ae724df..85ffc93d5 100644 --- a/Makefile.install +++ b/Makefile.install @@ -74,7 +74,7 @@ ifeq ($(BEST),opt) $(INSTALLBIN) $(TOPLOOPCMA:.cma=.cmxs) $(FULLCOQLIB)/toploop/ endif -install-byte: install-ide-byte +install-byte: install-coqide-byte $(MKDIR) $(FULLBINDIR) $(INSTALLBIN) $(COQTOPBYTE) $(FULLBINDIR) $(INSTALLBIN) $(TOPLOOPCMA) $(FULLCOQLIB)/toploop/ diff --git a/README.ci.md b/README.ci.md index 9e25390d7..cf9da5094 100644 --- a/README.ci.md +++ b/README.ci.md @@ -1,30 +1,42 @@ **WARNING:** This document is a work in progress and intended as a RFC. -If you are not a Coq Developer, don't follow this instructions yet. +If you are not a Coq Developer, don't follow these instructions yet. Introduction ============ -The Coq Travis CI infrastructure is meant to provide lightweight -automatics testing of pull requests. -If you are on GitLab, their integrated CI is also set up. +As of 2017, Coq's Git repository includes a `.travis.yml` file, a +`.gitlab-ci.yml` file, and supporting scripts, that enable lightweight +Continuous Integration (CI) tests to be run on clones of that repository stored +at Github or on a GitLab instance, respectively. This affords two benefits. -More comprehensive testing is the responsability of Coq's [Jenkins CI -server](https://ci.inria.fr/coq/) see, [XXX: add document] for -instructions on how to add your development to Jenkins. +First, it allows developers working on Coq itself to perform CI on their own +Git remotes, thereby enabling them to catch and fix problems with their +proposed changes before submitting pull requests to Coq itself. This in turn +reduces the risk of a faulty PR being opened against the official Coq +repository. -How to submit your development for Coq CI -========================================= +Secondly, it allows developers working on a library dependent on Coq to have +that library included in the Travis CI tests invoked by the official Coq +repository on GitHub. + +(More comprehensive testing than is provided by the Travis CI and GitLab CI +integration is the responsibility of Coq's [Jenkins CI +server](https://ci.inria.fr/coq/) see, [XXX: add document] for instructions on +how to add your development to Jenkins.) + +How to submit your library for inclusion in Coq's Travis CI builds +================================================================== CI provides a convenient way to perform testing of Coq changes versus a set of curated libraries. Are you an author of a Coq library who would be interested in having -the latest Coq changes validated against your development? +the latest Coq changes validated against it? -If so, keep reading! Getting Coq changes tested against your library -is easy, all that you need to do is: +If so, all you need to do is: -1. Put you development in a public repository tracking coq trunk. +1. Put your library in a public repository tracking the `master` + branch of Coq's Git repository. 2. Make sure that your development builds in less than 35 minutes. 3. Submit a PR adding your development. 4. ? @@ -47,3 +47,7 @@ Send your bug reports by filling a form at [coq.inria.fr/bugs](http://coq.inria. To be effective, bug reports should mention the OCaml version used to compile and run Coq, the Coq version (`coqtop -v`), the configuration used, and include a complete source example leading to the bug. + +## Contributing + +Guidelines for contributing to Coq in various ways are listed in the [contributor's guide](CONTRIBUTING.md). diff --git a/appveyor.yml b/appveyor.yml index ec6ded721..64c1bedb5 100644 --- a/appveyor.yml +++ b/appveyor.yml @@ -8,19 +8,24 @@ image: - Visual Studio 2017 environment: - CYGROOT: C:\cygwin64 CYGMIRROR: http://ftp.inf.tu-dresden.de/software/windows/cygwin32 - CYGCACHE: C:\cygwin64\var\cache\setup - opam_url: https://github.com/fdopen/opam-repository-mingw/releases/download/0.0.0.1/opam64.tar.xz - -install: -- cmd: '%CYGROOT%\setup-x86_64.exe -qnNdO -R %CYGROOT% -l %CYGCACHE% -s - %CYGMIRROR% -P rsync -P patch -P diffutils -P curl -P make -P unzip -P git -p m4 - -P perl -P findutils -P time' -- cmd: '%CYGROOT%/bin/bash -l %APPVEYOR_BUILD_FOLDER%/dev/build/windows/appveyor.sh' + matrix: + - USEOPAM: true + ARCH: 64 + - USEOPAM: false + ARCH: 32 + - USEOPAM: false + ARCH: 64 build_script: -- cmd: '%CYGROOT%/bin/bash -lc "cd $APPVEYOR_BUILD_FOLDER && ./configure -local && make"' +- cmd: 'call %APPVEYOR_BUILD_FOLDER%\dev\ci\appveyor.bat' + +test: off + +artifacts: + - path: 'dev\nsis\*.exe' + name: installer + + - path: 'coq-opensource-archive-*.zip' + name: opensource-archive -test_script: -- cmd: '%CYGROOT%/bin/bash -lc "cd $APPVEYOR_BUILD_FOLDER && make -C test-suite && make validate"' diff --git a/checker/cic.mli b/checker/cic.mli index 59dd5bc4d..753fd0fc0 100644 --- a/checker/cic.mli +++ b/checker/cic.mli @@ -385,9 +385,9 @@ and module_implementation = | Struct of module_signature (** interactive body *) | FullStruct (** special case of [Struct] : the body is exactly [mod_type] *) -and module_body = +and 'a generic_module_body = { mod_mp : module_path; (** absolute path of the module *) - mod_expr : module_implementation; (** implementation *) + mod_expr : 'a; (** implementation *) mod_type : module_signature; (** expanded type *) (** algebraic type, kept if it's relevant for extraction *) mod_type_alg : module_expression option; @@ -395,13 +395,19 @@ and module_body = mod_constraints : Univ.ContextSet.t; (** quotiented set of equivalent constants and inductive names *) mod_delta : delta_resolver; - mod_retroknowledge : action list } + mod_retroknowledge : 'a module_retroknowledge; } + +and module_body = module_implementation generic_module_body (** A [module_type_body] is just a [module_body] with no - implementation ([mod_expr] always [Abstract]) and also - an empty [mod_retroknowledge] *) + implementation and also an empty [mod_retroknowledge] *) + +and module_type_body = unit generic_module_body -and module_type_body = module_body +and _ module_retroknowledge = +| ModBodyRK : + action list -> module_implementation module_retroknowledge +| ModTypeRK : unit module_retroknowledge (*************************************************************************) (** {4 From safe_typing.ml} *) diff --git a/checker/declarations.ml b/checker/declarations.ml index 093d999a3..884a1ef18 100644 --- a/checker/declarations.ml +++ b/checker/declarations.ml @@ -583,24 +583,30 @@ let rec subst_expr sub = function | MEwith (me,wd)-> MEwith (subst_expr sub me, subst_with_body sub wd) let rec subst_expression sub me = - functor_map (subst_module sub) (subst_expr sub) me + functor_map (subst_module_type sub) (subst_expr sub) me and subst_signature sub sign = - functor_map (subst_module sub) (subst_structure sub) sign + functor_map (subst_module_type sub) (subst_structure sub) sign and subst_structure sub struc = let subst_body = function | SFBconst cb -> SFBconst (subst_const_body sub cb) | SFBmind mib -> SFBmind (subst_mind sub mib) | SFBmodule mb -> SFBmodule (subst_module sub mb) - | SFBmodtype mtb -> SFBmodtype (subst_module sub mtb) + | SFBmodtype mtb -> SFBmodtype (subst_module_type sub mtb) in List.map (fun (l,b) -> (l,subst_body b)) struc -and subst_module sub mb = +and subst_body : 'a. (_ -> 'a -> 'a) -> _ -> 'a generic_module_body -> 'a generic_module_body = + fun subst_impl sub mb -> { mb with mod_mp = subst_mp sub mb.mod_mp; - mod_expr = - implem_map (subst_signature sub) (subst_expression sub) mb.mod_expr; + mod_expr = subst_impl sub mb.mod_expr; mod_type = subst_signature sub mb.mod_type; mod_type_alg = Option.smartmap (subst_expression sub) mb.mod_type_alg } + +and subst_module sub mb = + subst_body (fun sub e -> implem_map (subst_signature sub) (subst_expression sub) e) sub mb + +and subst_module_type sub mb = + subst_body (fun _ () -> ()) sub mb diff --git a/checker/mod_checking.ml b/checker/mod_checking.ml index b6816dd48..3c9e1cac5 100644 --- a/checker/mod_checking.ml +++ b/checker/mod_checking.ml @@ -70,12 +70,12 @@ let lookup_module mp env = let mk_mtb mp sign delta = { mod_mp = mp; - mod_expr = Abstract; + mod_expr = (); mod_type = sign; mod_type_alg = None; mod_constraints = Univ.ContextSet.empty; mod_delta = delta; - mod_retroknowledge = []; } + mod_retroknowledge = ModTypeRK; } let rec check_module env mp mb = let (_:module_signature) = diff --git a/checker/modops.ml b/checker/modops.ml index 79cd5c29f..f0abc39ea 100644 --- a/checker/modops.ml +++ b/checker/modops.ml @@ -49,7 +49,7 @@ let destr_functor = function | NoFunctor _ -> error_not_a_functor () let module_body_of_type mp mtb = - { mtb with mod_mp = mp; mod_expr = Abstract } + { mtb with mod_mp = mp; mod_expr = Abstract; mod_retroknowledge = ModBodyRK [] } let rec add_structure mp sign resolver env = let add_one env (l,elem) = @@ -93,17 +93,19 @@ let strengthen_const mp_from l cb resolver = let rec strengthen_mod mp_from mp_to mb = if Declarations.mp_in_delta mb.mod_mp mb.mod_delta then mb - else strengthen_body true mp_from mp_to mb + else + let mk_expr mp_to = Algebraic (NoFunctor (MEident mp_to)) in + strengthen_body mk_expr mp_from mp_to mb -and strengthen_body is_mod mp_from mp_to mb = +and strengthen_body : 'a. (_ -> 'a) -> _ -> _ -> 'a generic_module_body -> 'a generic_module_body = + fun mk_expr mp_from mp_to mb -> match mb.mod_type with | MoreFunctor _ -> mb | NoFunctor sign -> let resolve_out,sign_out = strengthen_sig mp_from sign mp_to mb.mod_delta in { mb with - mod_expr = - (if is_mod then Algebraic (NoFunctor (MEident mp_to)) else Abstract); + mod_expr = mk_expr mp_to; mod_type = NoFunctor sign_out; mod_delta = resolve_out } @@ -130,7 +132,7 @@ and strengthen_sig mp_from sign mp_to resolver = resolve_out,item::rest' let strengthen mtb mp = - strengthen_body false mtb.mod_mp mp mtb + strengthen_body ignore mtb.mod_mp mp mtb let subst_and_strengthen mb mp = strengthen_mod mb.mod_mp mp (subst_module (map_mp mb.mod_mp mp) mb) @@ -138,9 +140,9 @@ let subst_and_strengthen mb mp = let module_type_of_module mp mb = let mtb = { mb with - mod_expr = Abstract; + mod_expr = (); mod_type_alg = None; - mod_retroknowledge = [] } + mod_retroknowledge = ModTypeRK } in match mp with | Some mp -> strengthen {mtb with mod_mp = mp} mp diff --git a/checker/subtyping.ml b/checker/subtyping.ml index 68a467bea..98a9c8250 100644 --- a/checker/subtyping.ml +++ b/checker/subtyping.ml @@ -393,7 +393,7 @@ and check_modtypes env mtb1 mtb2 subst1 subst2 equiv = mod_type = body_t1; mod_type_alg = None; mod_constraints = mtb1.mod_constraints; - mod_retroknowledge = []; + mod_retroknowledge = ModBodyRK []; mod_delta = mtb1.mod_delta} env in check_structure env body_t1 body_t2 equiv diff --git a/checker/values.ml b/checker/values.ml index c95c3f1b2..afde84854 100644 --- a/checker/values.ml +++ b/checker/values.ml @@ -13,7 +13,7 @@ To ensure this file is up-to-date, 'make' now compares the md5 of cic.mli with a copy we maintain here: -MD5 c802f941f368bedd96e931cda0559d67 checker/cic.mli +MD5 62a4037e9e584d508909d631c5e8a759 checker/cic.mli *) @@ -54,6 +54,7 @@ let v_enum name n = Sum(name,n,[||]) let v_pair v1 v2 = v_tuple "*" [|v1; v2|] let v_bool = v_enum "bool" 2 +let v_unit = v_enum "unit" 1 let v_ref v = v_tuple "ref" [|v|] let v_set v = @@ -311,13 +312,13 @@ and v_impl = Sum ("module_impl",2, (* Abstract, FullStruct *) [|[|v_mexpr|]; (* Algebraic *) [|v_sign|]|]) (* Struct *) -and v_noimpl = v_enum "no_impl" 1 (* Abstract is mandatory for mtb *) +and v_noimpl = v_unit and v_module = Tuple ("module_body", [|v_mp;v_impl;v_sign;Opt v_mexpr;v_context_set;v_resolver;Any|]) and v_modtype = Tuple ("module_type_body", - [|v_mp;v_noimpl;v_sign;Opt v_mexpr;v_context_set;v_resolver;Any|]) + [|v_mp;v_noimpl;v_sign;Opt v_mexpr;v_context_set;v_resolver;v_unit|]) (** kernel/safe_typing *) diff --git a/configure.ml b/configure.ml index 4eac8eacc..b5e456779 100644 --- a/configure.ml +++ b/configure.ml @@ -11,11 +11,11 @@ #load "str.cma" open Printf -let coq_version = "8.7+alpha" -let coq_macos_version = "8.6.90" (** "[...] should be a string comprised of +let coq_version = "8.8+alpha" +let coq_macos_version = "8.7.90" (** "[...] should be a string comprised of three non-negative, period-separated integers [...]" *) -let vo_magic = 8691 -let state_magic = 58691 +let vo_magic = 8791 +let state_magic = 58791 let distributed_exec = ["coqtop";"coqc";"coqchk";"coqdoc";"coqmktop";"coqworkmgr"; "coqdoc";"coq_makefile";"coq-tex";"gallina";"coqwc";"csdpcert";"coqdep"] diff --git a/dev/README b/dev/README index 814f60957..b446c3e97 100644 --- a/dev/README +++ b/dev/README @@ -40,10 +40,6 @@ Documentation of ML interfaces using ocamldoc (directory ocamldoc/html) Other development tools (directory tools) ----------------------- -Makefile.dir: makefile dedicated to intensive work in a given directory -Makefile.subdir: makefile dedicated to intensive work in a given subdirectory -Makefile.devel: utilities to automatically launch coq in various states -Makefile.common: used by other Makefiles objects.el: various development utilities at emacs level anomaly-traces-parser.el: a .emacs-ready elisp snippet to parse location of Anomaly backtraces and jump to them conveniently from diff --git a/dev/TODO b/dev/TODO deleted file mode 100644 index e62ee6e53..000000000 --- a/dev/TODO +++ /dev/null @@ -1,22 +0,0 @@ - - o options de la ligne de commande - - reporter les options de l'ancien script coqtop sur le nouveau coqtop.ml - - o arguments implicites - - les calculer une fois pour toutes à la déclaration (dans Declare) - et stocker cette information dans le in_variable, in_constant, etc. - - o Environnements compilés (type Environ.compiled_env) - - pas de timestamp mais plutôt un checksum avec Digest (mais comment ?) - - o Efficacité - - utiliser DOPL plutôt que DOPN (sauf pour Case) - - batch mode => pas de undo, ni de reset - - conversion : déplier la constante la plus récente - - un cache pour type_of_const, type_of_inductive, type_of_constructor, - lookup_mind_specif - - o Toplevel - - parsing de la ligne de commande : utiliser Arg ??? - - diff --git a/dev/build/osx/make-macos-dmg.sh b/dev/build/osx/make-macos-dmg.sh index b43ada907..cbe2a5186 100755 --- a/dev/build/osx/make-macos-dmg.sh +++ b/dev/build/osx/make-macos-dmg.sh @@ -4,19 +4,13 @@ set -e # Configuration setup -eval `opam config env` -make distclean OUTDIR=$PWD/_install DMGDIR=$PWD/_dmg -./configure -debug -prefix $OUTDIR -native-compiler no VERSION=$(sed -n -e '/^let coq_version/ s/^[^"]*"\([^"]*\)"$/\1/p' configure.ml) APP=bin/CoqIDE_${VERSION}.app # Create a .app file with CoqIDE -~/.local/bin/jhbuild run make -j -l2 $APP - -# Build Coq and run test-suite -make && make check +make -j $NJOBS -l2 $APP # Add Coq to the .app file make OLDROOT=$OUTDIR COQINSTALLPREFIX=$APP/Contents/Resources/ install-coq install-ide-toploop @@ -29,7 +23,9 @@ mkdir -p $DMGDIR ln -sf /Applications $DMGDIR/Applications cp -r $APP $DMGDIR +mkdir -p _build + # Temporary countermeasure to hdiutil error 5341 -head -c9703424 /dev/urandom > $DMGDIR/.padding +# head -c9703424 /dev/urandom > $DMGDIR/.padding -hdiutil create -imagekey zlib-level=9 -volname CoqIDE_$VERSION -srcfolder $DMGDIR -ov -format UDZO CoqIDE_$VERSION.dmg +hdiutil create -imagekey zlib-level=9 -volname CoqIDE_$VERSION -srcfolder $DMGDIR -ov -format UDZO _build/CoqIDE_$VERSION.dmg diff --git a/dev/build/windows/MakeCoq_MinGW.bat b/dev/build/windows/MakeCoq_MinGW.bat index b2efe2ddd..a420b5d8b 100644 --- a/dev/build/windows/MakeCoq_MinGW.bat +++ b/dev/build/windows/MakeCoq_MinGW.bat @@ -344,6 +344,9 @@ IF EXIST "%CYGWIN_INSTALLDIR_WFMT%\etc\setup\installed.db" ( IF NOT "%CYGWIN_QUIET%" == "Y" ( SET RUNSETUP=Y ) +IF "%COQREGTESTING%" == "Y" ( + SET RUNSETUP=Y +) IF "%RUNSETUP%"=="Y" ( %SETUP% ^ diff --git a/dev/build/windows/makecoq_mingw.sh b/dev/build/windows/makecoq_mingw.sh index e17923951..f3e4cec0b 100644 --- a/dev/build/windows/makecoq_mingw.sh +++ b/dev/build/windows/makecoq_mingw.sh @@ -1058,13 +1058,18 @@ function copq_coq_gtk { install_rec "$PREFIX/share/themes/" '*' "$PREFIXCOQ/share/themes" # This below item look like a bug in make install + if [ -d "$PREFIXCOQ/share/coq/" ] ; then + COQSHARE="$PREFIXCOQ/share/coq/" + else + COQSHARE="$PREFIXCOQ/share/" + fi if [[ ! $COQ_VERSION == 8.4* ]] ; then - mv "$PREFIXCOQ/share/coq/"*.lang "$PREFIXCOQ/share/gtksourceview-2.0/language-specs" - mv "$PREFIXCOQ/share/coq/"*.xml "$PREFIXCOQ/share/gtksourceview-2.0/styles" + mv "$COQSHARE"*.lang "$PREFIXCOQ/share/gtksourceview-2.0/language-specs" + mv "$COQSHARE"*.xml "$PREFIXCOQ/share/gtksourceview-2.0/styles" fi mkdir -p "$PREFIXCOQ/ide" - mv "$PREFIXCOQ/share/coq/"*.png "$PREFIXCOQ/ide" - rmdir "$PREFIXCOQ/share/coq" + mv "$COQSHARE"*.png "$PREFIXCOQ/ide" + rmdir "$PREFIXCOQ/share/coq" || true fi } @@ -1119,11 +1124,11 @@ function make_coq { then if [ "$INSTALLMODE" == "relocatable" ]; then # HACK: for relocatable builds, first configure with ./, then build but before install reconfigure with the real target path - logn configure ./configure -debug -with-doc no -prefix ./ -libdir ./lib -mandir ./man + ./configure -with-doc no -prefix ./ -libdir ./lib -mandir ./man elif [ "$INSTALLMODE" == "absolute" ]; then - logn configure ./configure -debug -with-doc no -prefix "$PREFIXCOQ" -libdir "$PREFIXCOQ/lib" -mandir "$PREFIXCOQ/man" + ./configure -with-doc no -prefix "$PREFIXCOQ" -libdir "$PREFIXCOQ/lib" -mandir "$PREFIXCOQ/man" else - logn configure ./configure -debug -with-doc no -prefix "$PREFIXCOQ" + ./configure -with-doc no -prefix "$PREFIXCOQ" fi # The windows resource compiler binary name is hard coded @@ -1134,17 +1139,17 @@ function make_coq { if [[ $COQ_VERSION == 8.4* ]] ; then log1 make else - log1 make $MAKE_OPT + make $MAKE_OPT fi if [ "$INSTALLMODE" == "relocatable" ]; then - logn reconfigure ./configure -debug -with-doc no -prefix "$PREFIXCOQ" -libdir "$PREFIXCOQ/lib" -mandir "$PREFIXCOQ/man" + ./configure -with-doc no -prefix "$PREFIXCOQ" -libdir "$PREFIXCOQ/lib" -mandir "$PREFIXCOQ/man" fi - log2 make install - log1 copy_coq_dlls + make install + copy_coq_dlls if [ "$INSTALLOCAML" == "Y" ]; then - log1 copy_coq_objects + copy_coq_objects fi copq_coq_gtk @@ -1267,7 +1272,7 @@ function get_cygwin_mingw_sources { function make_coq_installer { make_coq make_mingw_make - # get_cygwin_mingw_sources + get_cygwin_mingw_sources # Prepare the file lists for the installer. We created to file list dumps of the target folder during the build: # ocaml: ocaml + menhir + camlp5 + findlib diff --git a/dev/ci/appveyor.bat b/dev/ci/appveyor.bat new file mode 100644 index 000000000..ca6a5643c --- /dev/null +++ b/dev/ci/appveyor.bat @@ -0,0 +1,35 @@ +REM This script either runs the test suite with OPAM (if USEOPAM is true) or +REM builds the Coq binary packages for windows (if USEOPAM is false). + +if %ARCH% == 32 ( + SET ARCHLONG=i686 + SET CYGROOT=C:\cygwin + SET SETUP=setup-x86.exe +) + +if %ARCH% == 64 ( + SET ARCHLONG=x86_64 + SET CYGROOT=C:\cygwin64 + SET SETUP=setup-x86_64.exe +) + +SET CYGCACHE=%CYGROOT%\var\cache\setup +SET APPVEYOR_BUILD_FOLDER_MFMT=%APPVEYOR_BUILD_FOLDER:\=/% +SET APPVEYOR_BUILD_FOLDER_CFMT=%APPVEYOR_BUILD_FOLDER_MFMT:C:/=/cygdrive/c/% +SET DESTCOQ=C:\coq%ARCH%_inst +SET COQREGTESTING=Y + +if %USEOPAM% == false ( + call %APPVEYOR_BUILD_FOLDER%\dev\build\windows\MakeCoq_MinGW.bat -threads=1 ^ + -arch=%ARCH% -installer=Y -coqver=%APPVEYOR_BUILD_FOLDER_CFMT% ^ + -destcyg=%CYGROOT% -destcoq=%DESTCOQ% -cygcache=%CYGCACHE% ^ + -setup %CYGROOT%\%SETUP% + copy "%CYGROOT%\build\coq-local\dev\nsis\*.exe" dev\nsis + 7z a coq-opensource-archive-%ARCHLONG%.zip %CYGROOT%\build\tarballs\* +) + +if %USEOPAM% == true ( + %CYGROOT%\%SETUP% -qnNdO -R %CYGROOT% -l %CYGCACHE% -s %CYGMIRROR% ^ + -P rsync -P patch -P diffutils -P make -P unzip -P m4 -P findutils -P time + %CYGROOT%/bin/bash -l %APPVEYOR_BUILD_FOLDER%/dev/ci/appveyor.sh +) diff --git a/dev/build/windows/appveyor.sh b/dev/ci/appveyor.sh index 53f7a2346..524a55a42 100644 --- a/dev/build/windows/appveyor.sh +++ b/dev/ci/appveyor.sh @@ -1,8 +1,9 @@ #!/bin/bash set -e -x -wget $opam_url +wget https://github.com/fdopen/opam-repository-mingw/releases/download/0.0.0.1/opam64.tar.xz tar -xf opam64.tar.xz bash opam64/install.sh opam init -a mingw https://github.com/fdopen/opam-repository-mingw.git --comp 4.02.3+mingw64c --switch 4.02.3+mingw64c eval $(opam config env) opam install -y ocamlfind camlp5 +cd $APPVEYOR_BUILD_FOLDER && ./configure -local && make && make byte && make -C test-suite all INTERACTIVE= && make validate diff --git a/dev/ci/ci-basic-overlay.sh b/dev/ci/ci-basic-overlay.sh index 4b3b44875..8e7265969 100644 --- a/dev/ci/ci-basic-overlay.sh +++ b/dev/ci/ci-basic-overlay.sh @@ -114,7 +114,9 @@ ######################################################################## # SF ######################################################################## -: ${sf_CI_TARURL:=https://www.cis.upenn.edu/~bcpierce/sf/current/sf.tgz} +: ${sf_lf_CI_TARURL:=https://www.cis.upenn.edu/~bcpierce/sf/lf-current/lf.tgz} +: ${sf_plf_CI_TARURL:=https://www.cis.upenn.edu/~bcpierce/sf/plf-current/plf.tgz} +: ${sf_vfa_CI_TARURL:=https://www.cis.upenn.edu/~bcpierce/sf/vfa-current/vfa.tgz} ######################################################################## # TLC @@ -125,5 +127,5 @@ ######################################################################## # Bignums ######################################################################## -: ${bignums_CI_BRANCH:=master} -: ${bignums_CI_GITURL:=https://github.com/coq/bignums.git} +: ${bignums_CI_BRANCH:=fix-thunk-printer} +: ${bignums_CI_GITURL:=https://github.com/ppedrot/bignums.git} diff --git a/dev/ci/ci-coq-dpdgraph.sh b/dev/ci/ci-coq-dpdgraph.sh index e8018158b..b610f7000 100755 --- a/dev/ci/ci-coq-dpdgraph.sh +++ b/dev/ci/ci-coq-dpdgraph.sh @@ -7,4 +7,4 @@ coq_dpdgraph_CI_DIR=${CI_BUILD_DIR}/coq-dpdgraph git_checkout ${coq_dpdgraph_CI_BRANCH} ${coq_dpdgraph_CI_GITURL} ${coq_dpdgraph_CI_DIR} -( cd ${coq_dpdgraph_CI_DIR} && autoconf && ./configure && make -j ${NJOBS} && make tests && (make tests | tee tmp.log) && (if grep DIFFERENCES tmp.log ; then exit 1 ; else exit 0 ; fi) ) +( cd ${coq_dpdgraph_CI_DIR} && autoconf && ./configure && make -j ${NJOBS} && make test-suite ) diff --git a/dev/ci/ci-sf.sh b/dev/ci/ci-sf.sh index 6e6c7012b..272041205 100755 --- a/dev/ci/ci-sf.sh +++ b/dev/ci/ci-sf.sh @@ -4,11 +4,18 @@ ci_dir="$(dirname "$0")" source ${ci_dir}/ci-common.sh # XXX: Needs fixing to properly set the build directory. -wget ${sf_CI_TARURL} -tar xvfz sf.tgz +wget ${sf_lf_CI_TARURL} +wget ${sf_plf_CI_TARURL} +wget ${sf_vfa_CI_TARURL} +tar xvfz lf.tgz +tar xvfz plf.tgz +tar xvfz vfa.tgz -sed -i.bak '15i From Coq Require Extraction.' sf/Extraction.v +sed -i.bak '1i From Coq Require Extraction.' lf/Extraction.v +sed -i.bak '1i From Coq Require Extraction.' vfa/Extract.v -( cd sf && sed -i.bak 's/(K,N)/((K,N))/' LibTactics.v && make clean && make ) +( cd lf && make clean && make ) +( cd plf && sed -i.bak 's/(K,N)/((K,N))/' LibTactics.v && make clean && make ) +( cd vfa && make clean && make ) diff --git a/dev/db_printers.ml b/dev/db_printers.ml deleted file mode 100644 index f4b4a425e..000000000 --- a/dev/db_printers.ml +++ /dev/null @@ -1,16 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2017 *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) -open Pp -open Names - -let pp s = pp (hov 0 s) - -let prid id = Format.print_string (Id.to_string id) -let prsp sp = Format.print_string (DirPath.to_string sp) - - diff --git a/dev/doc/api.txt b/dev/doc/api.txt deleted file mode 100644 index 5827257b5..000000000 --- a/dev/doc/api.txt +++ /dev/null @@ -1,10 +0,0 @@ -Recommendations in using the API: - -The type of terms: constr (see kernel/constr.ml and kernel/term.ml) - -- On type constr, the canonical equality on CIC (up to - alpha-conversion and cast removal) is Constr.equal -- The type constr is abstract, use mkRel, mkSort, etc. to build - elements in constr; use "kind_of_term" to analyze the head of a - constr; use destRel, destSort, etc. when the head constructor is - known diff --git a/dev/doc/changes.txt b/dev/doc/changes.txt index a48c491d3..0f1a28028 100644 --- a/dev/doc/changes.txt +++ b/dev/doc/changes.txt @@ -188,6 +188,9 @@ In Coqlib / reference location: - The tclWEAK_PROGRESS and tclNOTSAMEGOAL tacticals were removed. Their usecase was very specific. Use tclPROGRESS instead. +- New (internal) tactical `tclINDEPENDENTL` that combined with enter_one allows + to iterate a non-unit tactic on all goals and access their returned values. + - The unsafe flag of the Refine.refine function and its variants has been renamed and dualized into typecheck and has been made mandatory. diff --git a/dev/doc/debugging.txt b/dev/doc/debugging.md index 3e2b435b3..7e9373b29 100644 --- a/dev/doc/debugging.txt +++ b/dev/doc/debugging.md @@ -25,8 +25,9 @@ Debugging from Coq toplevel using Caml trace mechanism Debugging from Caml debugger ============================ - Needs tuareg mode in Emacs - Coq must be configured with -debug and -local (./configure -debug -local) + Requires [Tuareg mode](https://github.com/ocaml/tuareg) in Emacs.\ + Coq must be configured with `-local` (`./configure -local`) and the + byte-code version of `coqtop` must have been generated with `make byte`. 1. M-x camldebug 2. give the binary name bin/coqtop.byte @@ -53,6 +54,9 @@ Debugging from Caml debugger of each of error* functions or anomaly* functions in lib/util.ml - If "source db" fails, do a "make printers" and try again (it should build top_printers.cmo and the core cma files). + - If you have the OCAMLRUNPARAM environment variable set, Coq may hang on + startup when run from the debugger. If this happens, unset the variable, + re-start Emacs, and run the debugger again. Global gprof-based profiling ============================ @@ -65,14 +69,14 @@ Global gprof-based profiling Per function profiling ====================== - 1. To profile function foo in file bar.ml, add the following lines, just - after the definition of the function: + To profile function foo in file bar.ml, add the following lines, just + after the definition of the function: let fookey = Profile.declare_profile "foo";; let foo a b c = Profile.profile3 fookey foo a b c;; - where foo is assumed to have three arguments (adapt using - Profile.profile1, Profile. profile2, etc). + where foo is assumed to have three arguments (adapt using + Profile.profile1, Profile. profile2, etc). - This has the effect to cumulate the time passed in foo under a - line of name "foo" which is displayed at the time coqtop exits. + This has the effect to cumulate the time passed in foo under a + line of name "foo" which is displayed at the time coqtop exits. diff --git a/dev/doc/notes-on-conversion b/dev/doc/notes-on-conversion.v index a81f170c6..a81f170c6 100644 --- a/dev/doc/notes-on-conversion +++ b/dev/doc/notes-on-conversion.v diff --git a/dev/tools/Makefile.devel b/dev/tools/Makefile.devel deleted file mode 100644 index ffdb1bdca..000000000 --- a/dev/tools/Makefile.devel +++ /dev/null @@ -1,74 +0,0 @@ -# to be linked to makefile (lowercase - takes precedence over Makefile) -# in main directory -# make devel in main directory should do this for you. - -TOPDIR=. -BASEDIR= - -SOURCEDIRS=lib kernel library pretyping parsing proofs tactics toplevel API - -default: usage noargument - -usage:: - @echo Usage: make \<target\> - @echo Targets are: - -usage:: - @echo " setup-devel -- set the devel makefile" -setup-devel: - @ln -sfv dev/tools/Makefile.devel makefile - @(for i in $(SOURCEDIRS); do \ - (cd $(TOPDIR)/$$i; ln -sfv ../dev/tools/Makefile.dir Makefile) \ - done) - - -usage:: - @echo " clean-devel -- clear all devel files" -clean-devel: - echo rm -f makefile .depend.devel - echo rm -f $(foreach dir,$(SOURCEDIRS), $(TOPDIR)/$(dir)/Makefile) - - -usage:: - @echo " coqtop -- make until the bytecode executable, make the link" -coqtop: bin/coqtop.byte - ln -sf bin/coqtop.byte coqtop - - -usage:: - @echo " quick -- make bytecode executable and states" -quick: - $(MAKE) states BEST=byte - -include Makefile - -include $(TOPDIR)/dev/tools/Makefile.common - -# this file is better described in dev/tools/Makefile.dir -include .depend.devel - -#if dev/tools/Makefile.local exists, it is included -ifneq ($(wildcard $(TOPDIR)/dev/tools/Makefile.local),) -include $(TOPDIR)/dev/tools/Makefile.local -endif - - -usage:: - @echo " total -- runs coqtop with all theories required" -total: - ledit ./bin/coqtop.byte $(foreach th,$(THEORIESVO),-require $(notdir $(basename $(th)))) - - -usage:: - @echo " run -- makes and runs bytecode coqtop using ledit and the history file" - @echo " if you want to pass arguments to coqtop, use make run ARG=<args>" -run: $(TOPDIR)/coqtop - ledit -h $(TOPDIR)/dev/debug_history -x $(TOPDIR)/coqtop $(ARG) $(ARGS) - - -usage:: - @echo " vars -- echos commands to set COQTOP and COQBIN variables" -vars: - @(cd $(TOPDIR); \ - echo export COQTOP=`pwd`/ ; \ - echo export COQBIN=`pwd`/bin/ ) diff --git a/dev/tools/Makefile.dir b/dev/tools/Makefile.dir deleted file mode 100644 index 1a1bb90b4..000000000 --- a/dev/tools/Makefile.dir +++ /dev/null @@ -1,131 +0,0 @@ -# make a link to this file if you are working hard in one directory of Coq -# ln -s ../dev/tools/Makefile.dir Makefile -# if you are working in a sub/dir/ make a link to dev/tools/Makefile.subdir instead -# this Makefile provides many useful facilities to develop Coq -# it is not completely compatible with .ml4 files unfortunately - -ifndef TOPDIR -TOPDIR=.. -endif - -# this complicated thing should work for subsubdirs as well -BASEDIR=$(shell (dir=`pwd`; cd $(TOPDIR); top=`pwd`; echo $$dir | sed -e "s|$$top/||")) - -noargs: dir - -test-dir: - @echo TOPDIR=$(TOPDIR) - @echo BASEDIR=$(BASEDIR) - -include $(TOPDIR)/dev/tools/Makefile.common - -# make this directory -dir: - $(MAKE) -C $(TOPDIR) $(notdir $(BASEDIR)) - -# make all cmo's in this directory. Useful in case the main Makefile is not -# up-to-date -all: - @( ( for i in *.ml; do \ - echo -n $(BASEDIR)/`basename $$i .ml`.cmo "" ; \ - done; \ - for i in *.ml4; do \ - echo -n $(BASEDIR)/`basename $$i .ml4`.cmo "" ; \ - done ) \ - | xargs $(MAKE) -C $(TOPDIR) ) - -# lists all files that should be compiled in this directory -list: - @(for i in *.mli; do \ - ls -l `basename $$i .mli`.cmi; \ - done) - @(for i in *.ml; do \ - ls -l `basename $$i .ml`.cmo; \ - done) - @(for i in *.ml4; do \ - ls -l `basename $$i .ml4`.cmo; \ - done) - - -clean:: - rm -f *.cmi *.cmo *.cmx *.o - - -# if grammar.cmo files cannot be compiled and main .depend cannot be -# rebuilt, this is quite useful -depend: - (cd $(TOPDIR); ocamldep -I $(BASEDIR) $(BASEDIR)/*.ml $(BASEDIR)/*.mli > .depend.devel) - - -# displays the dependency graph of the current directory (vertically, -# unlike in doc/) -graph: - (ocamldep *.ml *.mli | ocamldot | dot -Tps | gv -) & - - -# the pretty entry draws a dependency graph marking red those nodes -# which do not have their .cmo files - -.INTERMEDIATE: depend.dot depend.2.dot -.PHONY: depend.ps - -depend.dot: - ocamldep *.ml *.mli | ocamldot > $@ - -depend.2.dot: depend.dot - (i=`cat $< | wc -l`; i=`expr $$i - 1`; head -n $$i $<) > $@ - (for ml in *.ml; do \ - base=`basename $$ml .ml`; \ - fst=`echo $$base | cut -c1 | tr [:lower:] [:upper:]`; \ - rest=`echo $$base | cut -c2-`; \ - name=`echo $$fst $$rest | tr -d " "`; \ - cmo=$$base.cmo; \ - if [ ! -e $$cmo ]; then \ - echo \"$$name\" [color=red]\; >> $@;\ - fi;\ - done;\ - echo } >> $@) - -depend.ps: depend.2.dot - dot -Tps $< > $@ - -clean:: - rm -f depend.ps - -pretty: depend.ps - (gv -spartan $<; rm $<) & -# gv -spartan $< & - - - -# generating file.ml.mli by tricking make to pass -i to ocamlc - -%.ml.mli: FORCE - @(cmo=`basename $@ .ml.mli`.cmo ; \ - mv -f $$cmo $$cmo.tmp ; \ - $(MAKE) -s -C $(TOPDIR) $(BASEDIR)/$$cmo CAMLDEBUG=-i > $@ ; \ - echo Generated interface file $@ ; \ - mv -f $$cmo.tmp $$cmo) - -%.annot: FORCE - @(cmo=`basename $@ .annot`.cmo ; \ - mv -f $$cmo $$cmo.tmp ; \ - $(MAKE) -s -C $(TOPDIR) $(BASEDIR)/$$cmo CAMLDEBUG=-dtypes ; \ - echo Generated annotation file $@ ; \ - mv -f $$cmo.tmp $$cmo) - -FORCE: - -clean:: - rm -f *.ml.mli - -# this is not perfect but mostly WORKS! It just calls the main makefile - -%.cmi: FORCE - $(MAKE) -C $(TOPDIR) $(BASEDIR)/$@ - -%.cmo: FORCE - $(MAKE) -C $(TOPDIR) $(BASEDIR)/$@ - -coqtop: - $(MAKE) -C $(TOPDIR) bin/coqtop.byte diff --git a/dev/tools/Makefile.subdir b/dev/tools/Makefile.subdir deleted file mode 100644 index cb914bd12..000000000 --- a/dev/tools/Makefile.subdir +++ /dev/null @@ -1,7 +0,0 @@ -# if you work in a sub/sub-rectory of Coq -# you should make a link to that makefile -# ln -s ../../dev/tools/Makefile.subdir Makefile -# in order to have all the facilities of dev/tools/Makefile.dir - -TOPDIR=../.. -include $(TOPDIR)/dev/tools/Makefile.dir diff --git a/dev/v8-syntax/.gitignore b/dev/v8-syntax/.gitignore new file mode 100644 index 000000000..89e3509b0 --- /dev/null +++ b/dev/v8-syntax/.gitignore @@ -0,0 +1,6 @@ +# byproducts of check-grammar +def +df +use +use-k +use-t diff --git a/dev/v8-syntax/syntax-v8.tex b/dev/v8-syntax/syntax-v8.tex index fa2864cec..6b7960c92 100644 --- a/dev/v8-syntax/syntax-v8.tex +++ b/dev/v8-syntax/syntax-v8.tex @@ -1158,7 +1158,7 @@ $$ \nlsep \TERM{Abort}~\NT{ident} \nlsep \TERM{Existential}~\NT{num}~\KWD{:=}~\NT{constr-body} \nlsep \TERM{Qed} -\nlsep \TERM{Save}~\NT{ident}} +\nlsep \TERM{Save}~\NT{ident} \nlsep \TERM{Defined}~\OPT{\NT{ident}} \nlsep \TERM{Suspend} \nlsep \TERM{Resume}~\OPT{\NT{ident}} diff --git a/doc/Makefile.rt b/doc/Makefile.rt deleted file mode 100644 index 6c3281346..000000000 --- a/doc/Makefile.rt +++ /dev/null @@ -1,43 +0,0 @@ -# Makefile for building Coq Technical Reports - -# if coqc,coqtop,coq-tex are not in your PATH, you need the environment -# variable COQBIN to be correctly set -# (COQTOP is autodetected) -# (some files are preprocessed using Coq and some part of the documentation -# is automatically built from the theories sources) - -# To compile documentation, you need the following tools: -# Dvi: latex (latex2e), bibtex, makeindex, dviselect (package RPM dviutils) -# Ps: dvips, psutils (ftp://ftp.dcs.ed.ac.uk/pub/ajcd/psutils.tar.gz) -# Pdf: pdflatex -# Html: -# - hevea: http://para.inria.fr/~maranget/hevea/ -# - htmlSplit: http://coq.inria.fr/~delahaye -# Rapports INRIA: dviselect, rrkit (par Michel Mauny) - -include ./Makefile - -################### -# RT -################### -# Fabrication d'un RT INRIA (utilise rrkit de Michel Mauny) -rt/Reference-Manual-RT.dvi: refman/Reference-Manual.dvi rt/RefMan-cover.tex - dviselect -i refman/Reference-Manual.dvi -o rt/RefMan-body.dvi 3: - (cd rt; $(LATEX) RefMan-cover.tex) - set a=`tail -1 refman/Reference-Manual.log`;\ - set a=expr \("$$a" : '.*(\(.*\) pages.*'\) % 2;\ - (cd rt; if $(TEST) "$$a = 0";\ - then rrkit RefMan-cover.dvi RefMan-body.dvi Reference-Manual-RT.dvi;\ - else rrkit -odd RefMan-cover.dvi RefMan-body.dvi Reference-Manual-RT.dvi;\ - fi) - -# Fabrication d'un RT INRIA (utilise rrkit de Michel Mauny) -rt/Tutorial-RT.dvi : tutorial/Tutorial.v.dvi rt/Tutorial-cover.tex - dviselect -i rt/Tutorial.v.dvi -o rt/Tutorial-body.dvi 3: - (cd rt; $(LATEX) Tutorial-cover.tex) - set a=`tail -1 tutorial/Tutorial.v.log`;\ - set a=expr \("$$a" : '.*(\(.*\) pages.*'\) % 2;\ - (cd rt; if $(TEST) "$$a = 0";\ - then rrkit Tutorial-cover.dvi Tutorial-body.dvi Tutorial-RT.dvi;\ - else rrkit -odd Tutorial-cover.dvi Tutorial-body.dvi Tutorial-RT.dvi;\ - fi) diff --git a/doc/RecTutorial/RecTutorial.v b/doc/RecTutorial/RecTutorial.v index 8cfeebc28..4b0ab3125 100644 --- a/doc/RecTutorial/RecTutorial.v +++ b/doc/RecTutorial/RecTutorial.v @@ -1,3 +1,5 @@ +Unset Automatic Introduction. + Check (forall A:Type, (exists x:A, forall (y:A), x <> y) -> 2 = 3). @@ -69,13 +71,13 @@ Check (Prop::Set::nil). Require Import Bvector. -Print vector. +Print Vector.t. -Check (Vnil nat). +Check (Vector.nil nat). -Check (fun (A:Type)(a:A)=> Vcons _ a _ (Vnil _)). +Check (fun (A:Type)(a:A)=> Vector.cons _ a _ (Vector.nil _)). -Check (Vcons _ 5 _ (Vcons _ 3 _ (Vnil _))). +Check (Vector.cons _ 5 _ (Vector.cons _ 3 _ (Vector.nil _))). Lemma eq_3_3 : 2 + 1 = 3. Proof. @@ -146,6 +148,7 @@ Proof. intros; absurd (p < p); eauto with arith. Qed. +Require Extraction. Extraction max. @@ -300,8 +303,8 @@ Section Le_case_analysis. (HS : forall m, n <= m -> Q (S m)). Check ( match H in (_ <= q) return (Q q) with - | le_n => H0 - | le_S m Hm => HS m Hm + | le_n _ => H0 + | le_S _ m Hm => HS m Hm end ). @@ -317,16 +320,16 @@ Proof. Qed. Definition Vtail_total - (A : Type) (n : nat) (v : vector A n) : vector A (pred n):= -match v in (vector _ n0) return (vector A (pred n0)) with -| Vnil => Vnil A -| Vcons _ n0 v0 => v0 + (A : Type) (n : nat) (v : Vector.t A n) : Vector.t A (pred n):= +match v in (Vector.t _ n0) return (Vector.t A (pred n0)) with +| Vector.nil _ => Vector.nil A +| Vector.cons _ _ n0 v0 => v0 end. -Definition Vtail' (A:Type)(n:nat)(v:vector A n) : vector A (pred n). +Definition Vtail' (A:Type)(n:nat)(v:Vector.t A n) : Vector.t A (pred n). intros A n v; case v. simpl. - exact (Vnil A). + exact (Vector.nil A). simpl. auto. Defined. @@ -498,10 +501,8 @@ Inductive typ : Type := Definition typ_inject: typ. split. -exact typ. +Fail exact typ. (* -Defined. - Error: Universe Inconsistency. *) Abort. @@ -920,7 +921,6 @@ Defined. Print minus_decrease. - Definition div_aux (x y:nat)(H: Acc lt x):nat. fix 3. intros. @@ -969,40 +969,40 @@ let rec div_aux x y = | Right -> div_aux (minus x y) y) *) -Lemma vector0_is_vnil : forall (A:Type)(v:vector A 0), v = Vnil A. +Lemma vector0_is_vnil : forall (A:Type)(v:Vector.t A 0), v = Vector.nil A. Proof. intros A v;inversion v. Abort. (* - Lemma vector0_is_vnil_aux : forall (A:Type)(n:nat)(v:vector A n), - n= 0 -> v = Vnil A. + Lemma vector0_is_vnil_aux : forall (A:Type)(n:nat)(v:Vector.t A n), + n= 0 -> v = Vector.nil A. Toplevel input, characters 40281-40287 -> Lemma vector0_is_vnil_aux : forall (A:Set)(n:nat)(v:vector A n), n= 0 -> v = Vnil A. +> Lemma vector0_is_vnil_aux : forall (A:Set)(n:nat)(v:Vector.t A n), n= 0 -> v = Vector.nil A. > ^^^^^^ Error: In environment A : Set n : nat -v : vector A n +v : Vector.t A n e : n = 0 -The term "Vnil A" has type "vector A 0" while it is expected to have type - "vector A n" +The term "Vector.nil A" has type "Vector.t A 0" while it is expected to have type + "Vector.t A n" *) Require Import JMeq. (* On devrait changer Set en Type ? *) -Lemma vector0_is_vnil_aux : forall (A:Type)(n:nat)(v:vector A n), - n= 0 -> JMeq v (Vnil A). +Lemma vector0_is_vnil_aux : forall (A:Type)(n:nat)(v:Vector.t A n), + n= 0 -> JMeq v (Vector.nil A). Proof. destruct v. auto. intro; discriminate. Qed. -Lemma vector0_is_vnil : forall (A:Type)(v:vector A 0), v = Vnil A. +Lemma vector0_is_vnil : forall (A:Type)(v:Vector.t A 0), v = Vector.nil A. Proof. intros a v;apply JMeq_eq. apply vector0_is_vnil_aux. @@ -1010,56 +1010,56 @@ Proof. Qed. -Implicit Arguments Vcons [A n]. -Implicit Arguments Vnil [A]. -Implicit Arguments Vhead [A n]. -Implicit Arguments Vtail [A n]. +Implicit Arguments Vector.cons [A n]. +Implicit Arguments Vector.nil [A]. +Implicit Arguments Vector.hd [A n]. +Implicit Arguments Vector.tl [A n]. -Definition Vid : forall (A : Type)(n:nat), vector A n -> vector A n. +Definition Vid : forall (A : Type)(n:nat), Vector.t A n -> Vector.t A n. Proof. destruct n; intro v. - exact Vnil. - exact (Vcons (Vhead v) (Vtail v)). + exact Vector.nil. + exact (Vector.cons (Vector.hd v) (Vector.tl v)). Defined. -Eval simpl in (fun (A:Type)(v:vector A 0) => (Vid _ _ v)). +Eval simpl in (fun (A:Type)(v:Vector.t A 0) => (Vid _ _ v)). -Eval simpl in (fun (A:Type)(v:vector A 0) => v). +Eval simpl in (fun (A:Type)(v:Vector.t A 0) => v). -Lemma Vid_eq : forall (n:nat) (A:Type)(v:vector A n), v=(Vid _ n v). +Lemma Vid_eq : forall (n:nat) (A:Type)(v:Vector.t A n), v=(Vid _ n v). Proof. destruct v. reflexivity. reflexivity. Defined. -Theorem zero_nil : forall A (v:vector A 0), v = Vnil. +Theorem zero_nil : forall A (v:Vector.t A 0), v = Vector.nil. Proof. intros. - change (Vnil (A:=A)) with (Vid _ 0 v). + change (Vector.nil (A:=A)) with (Vid _ 0 v). apply Vid_eq. Defined. Theorem decomp : - forall (A : Type) (n : nat) (v : vector A (S n)), - v = Vcons (Vhead v) (Vtail v). + forall (A : Type) (n : nat) (v : Vector.t A (S n)), + v = Vector.cons (Vector.hd v) (Vector.tl v). Proof. intros. - change (Vcons (Vhead v) (Vtail v)) with (Vid _ (S n) v). + change (Vector.cons (Vector.hd v) (Vector.tl v)) with (Vid _ (S n) v). apply Vid_eq. Defined. Definition vector_double_rect : - forall (A:Type) (P: forall (n:nat),(vector A n)->(vector A n) -> Type), - P 0 Vnil Vnil -> - (forall n (v1 v2 : vector A n) a b, P n v1 v2 -> - P (S n) (Vcons a v1) (Vcons b v2)) -> - forall n (v1 v2 : vector A n), P n v1 v2. + forall (A:Type) (P: forall (n:nat),(Vector.t A n)->(Vector.t A n) -> Type), + P 0 Vector.nil Vector.nil -> + (forall n (v1 v2 : Vector.t A n) a b, P n v1 v2 -> + P (S n) (Vector.cons a v1) (Vector.cons b v2)) -> + forall n (v1 v2 : Vector.t A n), P n v1 v2. induction n. intros; rewrite (zero_nil _ v1); rewrite (zero_nil _ v2). auto. @@ -1069,24 +1069,23 @@ Defined. Require Import Bool. -Definition bitwise_or n v1 v2 : vector bool n := - vector_double_rect bool (fun n v1 v2 => vector bool n) - Vnil - (fun n v1 v2 a b r => Vcons (orb a b) r) n v1 v2. - +Definition bitwise_or n v1 v2 : Vector.t bool n := + vector_double_rect bool (fun n v1 v2 => Vector.t bool n) + Vector.nil + (fun n v1 v2 a b r => Vector.cons (orb a b) r) n v1 v2. -Fixpoint vector_nth (A:Type)(n:nat)(p:nat)(v:vector A p){struct v} +Fixpoint vector_nth (A:Type)(n:nat)(p:nat)(v:Vector.t A p){struct v} : option A := match n,v with - _ , Vnil => None - | 0 , Vcons b _ _ => Some b - | S n', Vcons _ p' v' => vector_nth A n' p' v' + _ , Vector.nil => None + | 0 , Vector.cons b _ => Some b + | S n', @Vector.cons _ _ p' v' => vector_nth A n' p' v' end. Implicit Arguments vector_nth [A p]. -Lemma nth_bitwise : forall (n:nat) (v1 v2: vector bool n) i a b, +Lemma nth_bitwise : forall (n:nat) (v1 v2: Vector.t bool n) i a b, vector_nth i v1 = Some a -> vector_nth i v2 = Some b -> vector_nth i (bitwise_or _ v1 v2) = Some (orb a b). diff --git a/doc/common/styles/html/coqremote/modules/node/node.css b/doc/common/styles/html/coqremote/modules/node/node.css new file mode 100644 index 000000000..60d01308e --- /dev/null +++ b/doc/common/styles/html/coqremote/modules/node/node.css @@ -0,0 +1,43 @@ + +.node-unpublished { + background-color: #fff4f4; +} +.preview .node { + background-color: #ffffea; +} +#node-admin-filter ul { + list-style-type: none; + padding: 0; + margin: 0; + width: 100%; +} +#node-admin-buttons { + float: left; /* LTR */ + margin-left: 0.5em; /* LTR */ + clear: right; /* LTR */ +} +td.revision-current { + background: #ffc; +} +.node-form .form-text { + display: block; + width: 95%; +} +.node-form .container-inline .form-text { + display: inline; + width: auto; +} +.node-form .standard { + clear: both; +} +.node-form textarea { + display: block; + width: 95%; +} +.node-form .attachments fieldset { + float: none; + display: block; +} +.terms-inline { + display: inline; +} diff --git a/doc/common/styles/html/coqremote/modules/system/defaults.css b/doc/common/styles/html/coqremote/modules/system/defaults.css new file mode 100644 index 000000000..eb983b7f8 --- /dev/null +++ b/doc/common/styles/html/coqremote/modules/system/defaults.css @@ -0,0 +1,52 @@ + +/* +** HTML elements +*/ +fieldset { + margin-bottom: 1em; + padding: .5em; +} +form { + margin: 0; + padding: 0; +} +hr { + height: 1px; + border: 1px solid gray; +} +img { + border: 0; +} +table { + border-collapse: collapse; +} +th { + text-align: left; /* LTR */ + padding-right: 1em; /* LTR */ + border-bottom: 3px solid #ccc; +} + +/* +** Markup free clearing +** Details: http://www.positioniseverything.net/easyclearing.html +*/ +.clear-block:after { + content: "."; + display: block; + height: 0; + clear: both; + visibility: hidden; +} + +.clear-block { + display: inline-block; +} + +/* Hides from IE-mac \*/ +* html .clear-block { + height: 1%; +} +.clear-block { + display: block; +} +/* End hide from IE-mac */ diff --git a/doc/common/styles/html/coqremote/modules/system/system.css b/doc/common/styles/html/coqremote/modules/system/system.css new file mode 100644 index 000000000..9371bb479 --- /dev/null +++ b/doc/common/styles/html/coqremote/modules/system/system.css @@ -0,0 +1,543 @@ + +/* +** HTML elements +*/ +body.drag { + cursor: move; +} +th.active img { + display: inline; +} +tr.even, tr.odd { + background-color: #eee; + border-bottom: 1px solid #ccc; + padding: 0.1em 0.6em; +} +tr.drag { + background-color: #fffff0; +} +tr.drag-previous { + background-color: #ffd; +} +td.active { + background-color: #ddd; +} +td.checkbox, th.checkbox { + text-align: center; +} +tbody { + border-top: 1px solid #ccc; +} +tbody th { + border-bottom: 1px solid #ccc; +} +thead th { + text-align: left; /* LTR */ + padding-right: 1em; /* LTR */ + border-bottom: 3px solid #ccc; +} + +/* +** Other common styles +*/ +.breadcrumb { + padding-bottom: .5em +} +div.indentation { + width: 20px; + height: 1.7em; + margin: -0.4em 0.2em -0.4em -0.4em; /* LTR */ + padding: 0.42em 0 0.42em 0.6em; /* LTR */ + float: left; /* LTR */ +} +div.tree-child { + background: url(../../misc/tree.png) no-repeat 11px center; /* LTR */ +} +div.tree-child-last { + background: url(../../misc/tree-bottom.png) no-repeat 11px center; /* LTR */ +} +div.tree-child-horizontal { + background: url(../../misc/tree.png) no-repeat -11px center; +} +.error { + color: #e55; +} +div.error { + border: 1px solid #d77; +} +div.error, tr.error { + background: #fcc; + color: #200; + padding: 2px; +} +.warning { + color: #e09010; +} +div.warning { + border: 1px solid #f0c020; +} +div.warning, tr.warning { + background: #ffd; + color: #220; + padding: 2px; +} +.ok { + color: #008000; +} +div.ok { + border: 1px solid #00aa00; +} +div.ok, tr.ok { + background: #dfd; + color: #020; + padding: 2px; +} +.item-list .icon { + color: #555; + float: right; /* LTR */ + padding-left: 0.25em; /* LTR */ + clear: right; /* LTR */ +} +.item-list .title { + font-weight: bold; +} +.item-list ul { + margin: 0 0 0.75em 0; + padding: 0; +} +.item-list ul li { + margin: 0 0 0.25em 1.5em; /* LTR */ + padding: 0; + list-style: disc; +} +ol.task-list li.active { + font-weight: bold; +} +.form-item { + margin-top: 1em; + margin-bottom: 1em; +} +tr.odd .form-item, tr.even .form-item { + margin-top: 0; + margin-bottom: 0; + white-space: nowrap; +} +tr.merge-down, tr.merge-down td, tr.merge-down th { + border-bottom-width: 0 !important; +} +tr.merge-up, tr.merge-up td, tr.merge-up th { + border-top-width: 0 !important; +} +.form-item input.error, .form-item textarea.error, .form-item select.error { + border: 2px solid red; +} +.form-item .description { + font-size: 0.85em; +} +.form-item label { + display: block; + font-weight: bold; +} +.form-item label.option { + display: inline; + font-weight: normal; +} +.form-checkboxes, .form-radios { + margin: 1em 0; +} +.form-checkboxes .form-item, .form-radios .form-item { + margin-top: 0.4em; + margin-bottom: 0.4em; +} +.marker, .form-required { + color: #f00; +} +.more-link { + text-align: right; /* LTR */ +} +.more-help-link { + font-size: 0.85em; + text-align: right; /* LTR */ +} +.nowrap { + white-space: nowrap; +} +.item-list .pager { + clear: both; + text-align: center; +} +.item-list .pager li { + background-image:none; + display:inline; + list-style-type:none; + padding: 0.5em; +} +.pager-current { + font-weight:bold; +} +.tips { + margin-top: 0; + margin-bottom: 0; + padding-top: 0; + padding-bottom: 0; + font-size: 0.9em; +} +dl.multiselect dd.b, dl.multiselect dd.b .form-item, dl.multiselect dd.b select { + font-family: inherit; + font-size: inherit; + width: 14em; +} +dl.multiselect dd.a, dl.multiselect dd.a .form-item { + width: 10em; +} +dl.multiselect dt, dl.multiselect dd { + float: left; /* LTR */ + line-height: 1.75em; + padding: 0; + margin: 0 1em 0 0; /* LTR */ +} +dl.multiselect .form-item { + height: 1.75em; + margin: 0; +} + +/* +** Inline items (need to override above) +*/ +.container-inline div, .container-inline label { + display: inline; +} + +/* +** Tab navigation +*/ +ul.primary { + border-collapse: collapse; + padding: 0 0 0 1em; /* LTR */ + white-space: nowrap; + list-style: none; + margin: 5px; + height: auto; + line-height: normal; + border-bottom: 1px solid #bbb; +} +ul.primary li { + display: inline; +} +ul.primary li a { + background-color: #ddd; + border-color: #bbb; + border-width: 1px; + border-style: solid solid none solid; + height: auto; + margin-right: 0.5em; /* LTR */ + padding: 0 1em; + text-decoration: none; +} +ul.primary li.active a { + background-color: #fff; + border: 1px solid #bbb; + border-bottom: #fff 1px solid; +} +ul.primary li a:hover { + background-color: #eee; + border-color: #ccc; + border-bottom-color: #eee; +} +ul.secondary { + border-bottom: 1px solid #bbb; + padding: 0.5em 1em; + margin: 5px; +} +ul.secondary li { + display: inline; + padding: 0 1em; + border-right: 1px solid #ccc; /* LTR */ +} +ul.secondary a { + padding: 0; + text-decoration: none; +} +ul.secondary a.active { + border-bottom: 4px solid #999; +} + +/* +** Autocomplete styles +*/ +/* Suggestion list */ +#autocomplete { + position: absolute; + border: 1px solid; + overflow: hidden; + z-index: 100; +} +#autocomplete ul { + margin: 0; + padding: 0; + list-style: none; +} +#autocomplete li { + background: #fff; + color: #000; + white-space: pre; + cursor: default; +} +#autocomplete li.selected { + background: #0072b9; + color: #fff; +} +/* Animated throbber */ +html.js input.form-autocomplete { + background-image: url(../../misc/throbber.gif); + background-repeat: no-repeat; + background-position: 100% 2px; /* LTR */ +} +html.js input.throbbing { + background-position: 100% -18px; /* LTR */ +} + +/* +** Collapsing fieldsets +*/ +html.js fieldset.collapsed { + border-bottom-width: 0; + border-left-width: 0; + border-right-width: 0; + margin-bottom: 0; + height: 1em; +} +html.js fieldset.collapsed * { + display: none; +} +html.js fieldset.collapsed legend { + display: block; +} +html.js fieldset.collapsible legend a { + padding-left: 15px; /* LTR */ + background: url(../../misc/menu-expanded.png) 5px 75% no-repeat; /* LTR */ +} +html.js fieldset.collapsed legend a { + background-image: url(../../misc/menu-collapsed.png); /* LTR */ + background-position: 5px 50%; /* LTR */ +} +/* Note: IE-only fix due to '* html' (breaks Konqueror otherwise). */ +* html.js fieldset.collapsed legend, +* html.js fieldset.collapsed legend *, +* html.js fieldset.collapsed table * { + display: inline; +} +/* For Safari 2 to prevent collapsible fieldsets containing tables from dissapearing due to tableheader.js. */ +html.js fieldset.collapsible { + position: relative; +} +html.js fieldset.collapsible legend a { + display: block; +} +/* Avoid jumping around due to margins collapsing into collapsible fieldset border */ +html.js fieldset.collapsible .fieldset-wrapper { + overflow: auto; +} + +/* +** Resizable text areas +*/ +.resizable-textarea { + width: 95%; +} +.resizable-textarea .grippie { + height: 9px; + overflow: hidden; + background: #eee url(../../misc/grippie.png) no-repeat center 2px; + border: 1px solid #ddd; + border-top-width: 0; + cursor: s-resize; +} +html.js .resizable-textarea textarea { + margin-bottom: 0; + width: 100%; + display: block; +} + +/* +** Table drag and drop. +*/ +.draggable a.tabledrag-handle { + cursor: move; + float: left; /* LTR */ + height: 1.7em; + margin: -0.4em 0 -0.4em -0.5em; /* LTR */ + padding: 0.42em 1.5em 0.42em 0.5em; /* LTR */ + text-decoration: none; +} +a.tabledrag-handle:hover { + text-decoration: none; +} +a.tabledrag-handle .handle { + margin-top: 4px; + height: 13px; + width: 13px; + background: url(../../misc/draggable.png) no-repeat 0 0; +} +a.tabledrag-handle-hover .handle { + background-position: 0 -20px; +} + +/* +** Teaser splitter +*/ +.joined + .grippie { + height: 5px; + background-position: center 1px; + margin-bottom: -2px; +} +/* Keeps inner content contained in Opera 9. */ +.teaser-checkbox { + padding-top: 1px; +} +div.teaser-button-wrapper { + float: right; /* LTR */ + padding-right: 5%; /* LTR */ + margin: 0; +} +.teaser-checkbox div.form-item { + float: right; /* LTR */ + margin: 0 5% 0 0; /* LTR */ + padding: 0; +} +textarea.teaser { + display: none; +} +html.js .no-js { + display: none; +} + +/* +** Progressbar styles +*/ +.progress { + font-weight: bold; +} +.progress .bar { + background: #fff url(../../misc/progress.gif); + border: 1px solid #00375a; + height: 1.5em; + margin: 0 0.2em; +} +.progress .filled { + background: #0072b9; + height: 1em; + border-bottom: 0.5em solid #004a73; + width: 0%; +} +.progress .percentage { + float: right; /* LTR */ +} +.progress-disabled { + float: left; /* LTR */ +} +.ahah-progress { + float: left; /* LTR */ +} +.ahah-progress .throbber { + width: 15px; + height: 15px; + margin: 2px; + background: transparent url(../../misc/throbber.gif) no-repeat 0px -18px; + float: left; /* LTR */ +} +tr .ahah-progress .throbber { + margin: 0 2px; +} +.ahah-progress-bar { + width: 16em; +} + +/* +** Formatting for welcome page +*/ +#first-time strong { + display: block; + padding: 1.5em 0 .5em; +} + +/* +** To be used with tableselect.js +*/ +tr.selected td { + background: #ffc; +} + +/* +** Floating header for tableheader.js +*/ +table.sticky-header { + margin-top: 0; + background: #fff; +} + +/* +** Installation clean URLs +*/ +#clean-url.install { + display: none; +} + +/* +** For anything you want to hide on page load when JS is enabled, so +** that you can use the JS to control visibility and avoid flicker. +*/ +html.js .js-hide { + display: none; +} + +/* +** Styles for the system modules page (admin/build/modules) +*/ +#system-modules div.incompatible { + font-weight: bold; +} + +/* +** Styles for the system themes page (admin/build/themes) +*/ +#system-themes-form div.incompatible { + font-weight: bold; +} + +/* +** Password strength indicator +*/ +span.password-strength { + visibility: hidden; +} +input.password-field { + margin-right: 10px; /* LTR */ +} +div.password-description { + padding: 0 2px; + margin: 4px 0 0 0; + font-size: 0.85em; + max-width: 500px; +} +div.password-description ul { + margin-bottom: 0; +} +.password-parent { + margin: 0 0 0 0; +} +/* +** Password confirmation checker +*/ +input.password-confirm { + margin-right: 10px; /* LTR */ +} +.confirm-parent { + margin: 5px 0 0 0; +} +span.password-confirm { + visibility: hidden; +} +span.password-confirm span { + font-weight: normal; +} diff --git a/doc/common/styles/html/coqremote/modules/user/user.css b/doc/common/styles/html/coqremote/modules/user/user.css new file mode 100644 index 000000000..7b2163e3d --- /dev/null +++ b/doc/common/styles/html/coqremote/modules/user/user.css @@ -0,0 +1,58 @@ + +#permissions td.module { + font-weight: bold; +} +#permissions td.permission { + padding-left: 1.5em; /* LTR */ +} +#access-rules .access-type, #access-rules .rule-type { + margin-right: 1em; /* LTR */ + float: left; /* LTR */ +} +#access-rules .access-type .form-item, #access-rules .rule-type .form-item { + margin-top: 0; +} +#access-rules .mask { + clear: both; +} +#user-login-form { + text-align: center; +} +#user-admin-filter ul { + list-style-type: none; + padding: 0; + margin: 0; + width: 100%; +} +#user-admin-buttons { + float: left; /* LTR */ + margin-left: 0.5em; /* LTR */ + clear: right; /* LTR */ +} +#user-admin-settings fieldset .description { + font-size: 0.85em; + padding-bottom: .5em; +} + +/* Generated by user.module but used by profile.module: */ +.profile { + clear: both; + margin: 1em 0; +} +.profile .picture { + float: right; /* LTR */ + margin: 0 1em 1em 0; /* LTR */ +} +.profile h3 { + border-bottom: 1px solid #ccc; +} +.profile dl { + margin: 0 0 1.5em 0; +} +.profile dt { + margin: 0 0 0.2em 0; + font-weight: bold; +} +.profile dd { + margin: 0 0 1em 0; +} diff --git a/doc/common/styles/html/coqremote/sites/all/themes/coq/coqdoc.css b/doc/common/styles/html/coqremote/sites/all/themes/coq/coqdoc.css new file mode 100644 index 000000000..d23ea8f36 --- /dev/null +++ b/doc/common/styles/html/coqremote/sites/all/themes/coq/coqdoc.css @@ -0,0 +1,329 @@ +body { padding: 0px 0px; + margin: 0px 0px; + background-color: white } + +#page { display: block; + padding: 0px; + margin: 0px; + padding-bottom: 10px; } + +#header { display: block; + position: relative; + padding: 0; + margin: 0; + vertical-align: middle; + border-bottom-style: solid; + border-width: thin } + +#header h1 { padding: 0; + margin: 0;} + + +/* Contents */ + +#main{ display: block; + padding: 10px; + font-family: sans-serif; + font-size: 100%; + line-height: 100% } + +#main h1 { line-height: 95% } /* allow for multi-line headers */ + +#main a.idref:visited {color : #416DFF; text-decoration : none; } +#main a.idref:link {color : #416DFF; text-decoration : none; } +#main a.idref:hover {text-decoration : none; } +#main a.idref:active {text-decoration : none; } + +#main a.modref:visited {color : #416DFF; text-decoration : none; } +#main a.modref:link {color : #416DFF; text-decoration : none; } +#main a.modref:hover {text-decoration : none; } +#main a.modref:active {text-decoration : none; } + +#main .keyword { color : #cf1d1d } +#main { color: black } + +.section { background-color: rgb(60%,60%,100%); + padding-top: 13px; + padding-bottom: 13px; + padding-left: 3px; + margin-top: 5px; + margin-bottom: 5px; + font-size : 175% } + +h2.section { background-color: rgb(80%,80%,100%); + padding-left: 3px; + padding-top: 12px; + padding-bottom: 10px; + font-size : 130% } + +h3.section { background-color: rgb(90%,90%,100%); + padding-left: 3px; + padding-top: 7px; + padding-bottom: 7px; + font-size : 115% } + +h4.section { +/* + background-color: rgb(80%,80%,80%); + max-width: 20em; + padding-left: 5px; + padding-top: 5px; + padding-bottom: 5px; +*/ + background-color: white; + padding-left: 0px; + padding-top: 0px; + padding-bottom: 0px; + font-size : 100%; + font-weight : bold; + text-decoration : underline; + } + +#main .doc { margin: 0px; + font-family: sans-serif; + font-size: 100%; + line-height: 125%; + max-width: 40em; + color: black; + padding: 10px; + background-color: #90bdff} + +.inlinecode { + display: inline; +/* font-size: 125%; */ + color: #666666; + font-family: monospace } + +.doc .inlinecode { + display: inline; + font-size: 120%; + color: rgb(30%,30%,70%); + font-family: monospace } + +.doc .inlinecode .id { + color: rgb(30%,30%,70%); +} + +.inlinecodenm { + display: inline; + color: #444444; +} + +.doc .code { + display: inline; + font-size: 120%; + color: rgb(30%,30%,70%); + font-family: monospace } + +.comment { + display: inline; + font-family: monospace; + color: rgb(50%,50%,80%); +} + +.code { + display: block; +/* padding-left: 15px; */ + font-size: 110%; + font-family: monospace; + } + +table.infrule { + border: 0px; + margin-left: 50px; + margin-top: 10px; + margin-bottom: 10px; +} + +td.infrule { + font-family: monospace; + text-align: center; +/* color: rgb(35%,35%,70%); */ + padding: 0px; + line-height: 100%; +} + +tr.infrulemiddle hr { + margin: 1px 0 1px 0; +} + +.infrulenamecol { + color: rgb(60%,60%,60%); + font-size: 80%; + padding-left: 1em; + padding-bottom: 0.1em +} + +/* Pied de page */ + +#footer { font-size: 65%; + font-family: sans-serif; } + +/* Identifiers: <span class="id" title="...">) */ + +.id { display: inline; } + +.id[title="constructor"] { + color: rgb(60%,0%,0%); +} + +.id[title="var"] { + color: rgb(40%,0%,40%); +} + +.id[title="variable"] { + color: rgb(40%,0%,40%); +} + +.id[title="definition"] { + color: rgb(0%,40%,0%); +} + +.id[title="abbreviation"] { + color: rgb(0%,40%,0%); +} + +.id[title="lemma"] { + color: rgb(0%,40%,0%); +} + +.id[title="instance"] { + color: rgb(0%,40%,0%); +} + +.id[title="projection"] { + color: rgb(0%,40%,0%); +} + +.id[title="method"] { + color: rgb(0%,40%,0%); +} + +.id[title="inductive"] { + color: rgb(0%,0%,80%); +} + +.id[title="record"] { + color: rgb(0%,0%,80%); +} + +.id[title="class"] { + color: rgb(0%,0%,80%); +} + +.id[title="keyword"] { + color : #cf1d1d; +/* color: black; */ +} + +/* Deprecated rules using the 'type' attribute of <span> (not xhtml valid) */ + +.id[type="constructor"] { + color: rgb(60%,0%,0%); +} + +.id[type="var"] { + color: rgb(40%,0%,40%); +} + +.id[type="variable"] { + color: rgb(40%,0%,40%); +} + +.id[type="definition"] { + color: rgb(0%,40%,0%); +} + +.id[type="abbreviation"] { + color: rgb(0%,40%,0%); +} + +.id[type="lemma"] { + color: rgb(0%,40%,0%); +} + +.id[type="instance"] { + color: rgb(0%,40%,0%); +} + +.id[type="projection"] { + color: rgb(0%,40%,0%); +} + +.id[type="method"] { + color: rgb(0%,40%,0%); +} + +.id[type="inductive"] { + color: rgb(0%,0%,80%); +} + +.id[type="record"] { + color: rgb(0%,0%,80%); +} + +.id[type="class"] { + color: rgb(0%,0%,80%); +} + +.id[type="keyword"] { + color : #cf1d1d; +/* color: black; */ +} + +.inlinecode .id { + color: rgb(0%,0%,0%); +} + + +/* TOC */ + +#toc h2 { + padding: 10px; + background-color: rgb(60%,60%,100%); +} + +#toc li { + padding-bottom: 8px; +} + +/* Index */ + +#index { + margin: 0; + padding: 0; + width: 100%; +} + +#index #frontispiece { + margin: 1em auto; + padding: 1em; + width: 60%; +} + +.booktitle { font-size : 140% } +.authors { font-size : 90%; + line-height: 115%; } +.moreauthors { font-size : 60% } + +#index #entrance { + text-align: center; +} + +#index #entrance .spacer { + margin: 0 30px 0 30px; +} + +#index #footer { + position: absolute; + bottom: 0; +} + +.paragraph { + height: 0.75em; +} + +ul.doclist { + margin-top: 0em; + margin-bottom: 0em; +} diff --git a/doc/common/styles/html/coqremote/sites/all/themes/coq/style.css b/doc/common/styles/html/coqremote/sites/all/themes/coq/style.css new file mode 100644 index 000000000..32c0b3316 --- /dev/null +++ b/doc/common/styles/html/coqremote/sites/all/themes/coq/style.css @@ -0,0 +1,801 @@ +body +{ + background: white; + color:#444; + font:normal normal normal small/1.5em "Lucida Grande", Verdana, sans-serif; + margin:0; + padding:0; +} + +h2 +{ + font-size:150%; + font-weight:normal; + margin:20px 0 0; +} + +h3 +{ + font-size:130%; + font-weight:normal; +} + +a:link,a:visited +{ + color:#660403; + font-weight:normal; + text-decoration:none; +} + +a:hover +{ + color: red; + text-decoration:none; +} + +#container +{ + margin: 0; + padding: 0; + } + + /*----------header, logo and site name styles----------*/ + #headertop + { + display: block; + /* position:absolute; */ + min-width: 700px; + top: 0; + width: 100%; + height:30px; + z-index: 1; + background: transparent url('images/header_top.png') repeat-x; + } + + #header + { + min-width: 700px; + width: 100%; height:70px; + position: relative; + left: 0; top: 0; + background: transparent url('images/header_bot.png') repeat-x; + } + + #logo + { + float:left; + z-index: 2; + position: absolute; + top: -15px; + left: 0px; + } + + #logo img + { + border:0; + float:left; + } + + #logoWrapper + { + line-height:4em; + } + + #siteName + { + position: relative; + top: 10px; left: 80px; + color:#fff; + float:left; + font-size:350%; + } + + #siteName a + { + color:#fff; + text-decoration:none; + } + + #siteName a:hover + { + color:#ddd; + text-decoration:none; + } + + #siteSlogan + { + color:#eee; + float:left; + font-size:170%; + margin:50px 0 0 10px; + text-transform:lowercase; + white-space:nowrap; + } + + /*----------nav styles -- primary links in header----------*/ + + #nav +{ + position:absolute; right:0; + margin: 0; + padding: 5px; + } + +#nav ul + { + list-style:none outside none; + list-style-image:none; + margin:0; + padding:0; + } + + #nav li + { + display: inline; + margin: 0; padding: 4px; + } + + #nav li a + { + border:medium none; + color:#ccc; + font-weight:normal; + padding-left:10px; + padding-right:10px; + text-decoration:none; + } + + #nav li a:hover + { + background:#7B0505 none repeat; + border:medium none; + border-left:1px solid #ddd; + border-right:1px solid #ddd; + color:#fff; + padding: 6px 9px 5px 9px; + } + + +/************** FOOTER *******************/ + + +#footer +{ + background:transparent url('images/footer.png') repeat-x; + width:100%; + clear:both; + font-size:85%; + text-align:center; + /* position:fixed; */ + margin: 0; + padding: 0; +} + + +#nav-footer +{ + display: inline; + color:#444; + margin: 0; + padding: 0; + text-align:right; + } + +#nav-footer ul + { + list-style:none outside none; + list-style-image:none; + margin:0; + padding:0px; padding-right: 5px; + } + +#nav-footer li +{ + display:inline; padding: 4px; +} + + #nav-footer li a + { + border:medium none; + color:#ccc; + font-size: 11px; + font-weight:normal; + padding-left: 10px; + padding-right: 10px; + text-decoration:none; + } + + #nav-footer li a:hover + { + background:#7B0505 none repeat; + border:medium none; + border-left:1px solid #ddd; + border-right:1px solid #ddd; + color:#fff; + margin:0; + padding: 3px 9px 0px 9px; + } + + + /*----------main content----------*/ + #content + { + display: block; + position: static; + +/* min-width: 640px; */ + max-width: 800px; + + margin-left:40px; + margin-right:300px; + padding: 2ex 2ex; + + z-index:1; + } + +.content { + display: block; + position: relative; + + margin: 0; + padding: 0; +} + + /*----------sidebar styles----------*/ + #sidebarWrapper + { + /* background:transparent url('images/sidebar_bottom.jpg') no-repeat scroll left bottom;*/ + display:block; + position:fixed; + /* avant : top: 100px; right:0px*/ + top: 15px; /* 180 */ + right:0px; + left: auto; + + margin-right: 0px; + + /* avant + width: 12%; + min-width:80px; */ + + /* width: 18%; */ + /* min-*/ + width:270px; + + z-index:0; + overflow:hidden; + +/* ajout precedent:*/ +/* min-height:320px; + padding:10px; + background-image:url('http://www.lix.polytechnique.fr/Labo/Denis.Cousineau/data/coq/rttr340bis.png'); + background-repeat : repeat-x ;*/ + +/* last ajout */ + /* min-height:510px; */ /* 360 */ + padding-left:0px; + padding-right:0px; + padding-top:105px; /* 40 */ + padding-bottom:/*105px*/115px; + /* background:transparent url('http://www.lix.polytechnique.fr/Labo/Denis.Cousineau/data/coq/trig6b.png') no-repeat scroll left top; */ + background:transparent url('images/sidebarbot.png') no-repeat scroll right bottom; + + } + +#sidebar { + padding-left: 40px; + padding-top: 105px; + overflow: visible; + background:transparent url('images/sidebartop.png') no-repeat scroll right top; +} + +#sidebar .title +{ + /* avant :border-bottom:1px solid #eee;*/ + /* avant : color:#660403;*/ + color:#2D0102; + font-size:120%; + font-weight:bold; + line-height:19px; + margin:10px 0; +} + +/*----------page styles----------*/ +.pageTitle +{ + color:#2D0102; + font-size:220%; + margin:10px 0 20px; +} + +.mission +{ + background-color:#efefef; + border:solid 1px #ccc; + margin:0 0 10px 0; + padding:10px; +} + +.messages +{ + color:#C80000; + font-size:110%; + margin:10px 0; +} + +/*----------node styles----------*/ +.nodeTitle +{ + background: url('images/nodeTitle.gif') no-repeat 0 100%; + color:#9a0000; + font-size: 100%; + margin:0; +} + +.nodeTitle a +{ + color:#660403; + text-decoration:none; +} + +.nodeTitle a:hover +{ + color:#d00000; + text-decoration:none; +} + +.node +{ + margin:0 0 20px; +} + +.content p +{ + margin:10px 0; +} + +.submitted +{ + color:#a3a3a3; + font-size:70%; +} + +.nodeLinks +{ + font-size:95%; + margin:0; + padding:0; +} + +.taxonomy +{ + background:url('icons/tag_red.png') no-repeat 0 7px; + font-size:80%; + padding:0 0 5px 16px; +} + +/*----------comment styles----------*/ +.commentTitle +{ + Border-bottom:1px solid #ddd; + color:#9a0000; + font-size:130%; + margin:20px 0 0; +} + +.commentTitle a +{ + color:#660403; + text-decoration:none; +} + +.commentTitle a:hover +{ + color:#d00000; + text-decoration:none; +} + +.commentLinks +{ + background:#f7f7f7; + border:1px solid #e1e1e1; + color:#444; + font-size:95%; + margin:20px 0 30px; + padding:4px 0 4px 4px; +} + + +/*----------img styles----------*/ +img +{ + padding:3px; +} + +/*----------icons for links----------*/ +.comment_comments a +{ + background:url('icons/comment.png') no-repeat 0 2px; + padding-bottom:5px; + padding-left:20px; +} + +.node_read_more a +{ + background:url('icons/page_white_go.png') no-repeat; + padding-bottom:5px; + padding-left:20px; +} + +.comment_add a,.comment_reply a +{ + background:url('icons/comment_add.png') no-repeat; + padding-bottom:5px; + padding-left:20px; +} +.comment_delete a +{ + background:url('icons/comment_delete.png') no-repeat; + padding-bottom:5px; + padding-left:20px; +} + +.comment_edit a +{ + background:url('icons/comment_edit.png') no-repeat; + padding-bottom:5px; + padding-left:20px; +} + +/*----------TinyMCE editor----------*/ +body.mceContentBody +{ + background:#fff; + color:#000; + font-size:12px; +} + +body.mceContentBody a:link +{ + color:#ff0000; +} + +/*----------table styles----------*/ +table +{ + margin:1em 0; + width:100%; +} + +thead th +{ + border-bottom:2px solid #AAA; + color:#494949; + font-weight:bold; +} + +td,th +{ + padding:.3em 0 .5em; +} + +tr.even,tr.odd,tbody th +{ + border:solid #D5D6D7; + border-width:1px 0; +} + +tr.even +{ + background:#fff; +} + +td.region,td.module,td.container +{ + background:#D5D6D7; + border-bottom:1px solid #AAA; + border-top:1.5em solid #fff; + color:#455067; + font-weight:bold; +} + +tr:first-child td.region,tr:first-child td.module,tr:first-child td.container +{ + border-top-width:0; +} + +td.menu-disabled,td.menu-disabled a +{ + background-color:#D5C2C2; + color:#000; +} + +/*----------other styles----------*/ + +.block +{ + margin:5px 0 20px; +} + +.thumbnail,.preview +{ + border:1px solid #ccc; +} + +.lstlisting { + display: block; + font-family: monospace; + white-space: pre; + margin: 1em 0; +} +.center { + text-align: center; +} +.centered { + display: block-inline; +} + +/*----------download table------------*/ + +table.downloadtable +{ + width:90%; + margin-left:auto; + margin-right:auto; +} + +table.downloadtable td.downloadheader +{ +padding: 2px 1em; +font-weight: bold; +font-size: 120%; +color: white; +background: transparent url('images/header_bot.png') repeat-x; +/*background-color: #660403; */ +border: solid 2px white; +border-left: none; +} + +table.downloadtable td.downloadcategory +{ +padding: 2px 1em; +background-color: #dfbfbe; +text-indent: 0; +} + +table.downloadtable td.downloadsize +{ +text-indent: 0; +white-space: nowrap; +height: 52px; +} + +table.downloadtable td +{ +padding: 2px 1em; +background-color: #dfbfbe; +border-right: solid white 2px; +} + + +table.downloadtable td.downloadtopline +{ +border-top: solid white 2px; +} + +table.downloadtable td.downloadtoprightline +{ +border-top: solid 2px white; +border-right: solid 2px white; +} + +table.downloadtable td.downloadbottomline +{ +border-bottom: solid 2px white; +border-right: solid 2px white; +} + +table.downloadtable td.downloadbottomrightline +{ +border-bottom: solid 2px white; +border-right: solid 2px white; +} + +table.downloadtable td.downloadrightline +{ +border-right: solid 2px white; +} + +table.downloadtable td.downloadback +{ +background-color: #efe4e4; +} + +table.downloadtable td.downloadbottomback +{ +border-bottom: solid 2px white; +background-color: #efe4e4; +} + + +/*********** Normal text style ************/ + +p { + text-indent:3em; +} + +ul { + margin: 0px; + margin-left:4em; + padding: 0px; + list-style-type:square; +} + +li +{ + text-indent: 0px; + margin: 0px; + padding: 0px; +} + +tt { font-size: 1em; } + +pre { font-size: 1em; } + +/*********** Framework ***********/ +.framework +{ + display: block; + position:relative; + border:solid 1px #660033; + margin: 8ex 1em; /* 8ex 8ex 1em 1em; */ + padding: 0; +} + +.frameworkcontent +{ + position:relative; + left:0px; + + + margin: 0; + padding: .5ex 2em; + + text-indent: 2em; + text-align: justify; +} + + +.frameworklabel +{ + display: inline; + position:relative; + top:-1.3ex; + + margin-left:2ex; + padding-top:.4ex; + padding-bottom:.4ex; + padding-right:1ex; + padding-left:1ex; + + border: none; + background: white; + color: black; + + font-weight: bold; + font-size:115%; +} + +.frameworklinks { + display:block; + position:relative; + top:1.4ex; + + margin-right:2ex; + + text-align:right; + font-size:100% + } + +.frameworklinks ul +{ + display: inline; + padding: 0px 1ex; + + border: none; + background: white; +} + + +.frameworklinks li + { + display:inline; + padding: 1ex 0px; + } + + .frameworklinks li a +{ + border:medium none; + + margin: 0px 1ex; + padding-left:2px; + padding-right:3px; + + font-weight:normal; + text-decoration:none; + + color: #660003; +} + + .frameworklinks li a:hover + { + color: red; + + border: none; + } + +/* General flat lists */ +.flatlist li {display: inline} + +/* For sections in bycat.html */ +.bycatsection dt { + text-indent: 3em +} + +.bycatsection dt a +{ + font-weight: bold; + color:#444; +} + +/* footnote is used in the new contribution form */ +.footnote { + text-indent: 0pt; + font-size: 80%; + color: silver; + text-align: justify +} + +/****************** CoqIDE Screenshots *****************/ + + +.SCpager { + position:relative; + top:5px; + width:630px; + background: transparent url('images/header_bot.png') repeat-x; + padding:4px; +} + +.SCpagercontent { + width:390px; + position:relative; + margin-left:auto; + margin-right:auto; +} + +.SCthumb { + height:45px; + margin-left:2px; + margin-right:2px; +} + +.SCthumbselected { + height:55px; + margin-left:2px; + margin-right:2px; +} + +.SCcontent { + position:relative; + top:5px; + width:638px; + background-color: #dfbfbe; +} + +.SCscreenshot { + position:relative; + height:400px; + width:auto; + margin:15px auto 15px 19px; +} diff --git a/doc/common/title.tex b/doc/common/title.tex index 0e072b6b6..76e50f65d 100644 --- a/doc/common/title.tex +++ b/doc/common/title.tex @@ -45,7 +45,7 @@ V\coqversion, \today %END LATEX \copyright INRIA 1999-2004 ({\Coq} versions 7.x) -\copyright INRIA 2004-2016 ({\Coq} versions 8.x) +\copyright INRIA 2004-2017 ({\Coq} versions 8.x) #3 \end{flushleft} diff --git a/doc/refman/Extraction.tex b/doc/refman/Extraction.tex index 8cb049d50..499239b6f 100644 --- a/doc/refman/Extraction.tex +++ b/doc/refman/Extraction.tex @@ -381,6 +381,9 @@ some specific {\tt Extract Constant} when primitive counterparts exist. \Example Typical examples are the following: +\begin{coq_eval} +Require Extraction. +\end{coq_eval} \begin{coq_example} Extract Inductive unit => "unit" [ "()" ]. Extract Inductive bool => "bool" [ "true" "false" ]. diff --git a/doc/refman/RefMan-cic.tex b/doc/refman/RefMan-cic.tex index 96fb1eb75..ad795d406 100644 --- a/doc/refman/RefMan-cic.tex +++ b/doc/refman/RefMan-cic.tex @@ -558,7 +558,7 @@ $\Sort$ is called the sort of the inductive type $t$. \paragraph{Examples} \newcommand\ind[3]{$\mathsf{Ind}~[#1]\left(\hskip-.4em - \begin{array}{r @{\mathrm{~:=~}} l} + \begin{array}{r@{\mathrm{~:=~}}l} #2 & #3 \\ \end{array} \hskip-.4em @@ -569,7 +569,7 @@ The declaration for parameterized lists is: \begin{latexonly} \vskip.5em -\ind{1}{[\List:\Set\ra\Set]}{\left[\begin{array}{r \colon l} + \ind{1}{[\List:\Set\ra\Set]}{\left[\begin{array}{r@{:}l} \Nil & \forall A:\Set,\List~A \\ \cons & \forall A:\Set, A \ra \List~A \ra \List~A \end{array} @@ -613,8 +613,8 @@ Inductive list (A:Set) : Set := \noindent The declaration for a mutual inductive definition of {\tree} and {\forest} is: \begin{latexonly} \vskip.5em -\ind{~}{\left[\begin{array}{r \colon l}\tree&\Set\\\forest&\Set\end{array}\right]} - {\left[\begin{array}{r \colon l} +\ind{~}{\left[\begin{array}{r@{:}l}\tree&\Set\\\forest&\Set\end{array}\right]} + {\left[\begin{array}{r@{:}l} \node & \forest \ra \tree\\ \emptyf & \forest\\ \consf & \tree \ra \forest \ra \forest\\ @@ -680,15 +680,15 @@ with forest : Set := \noindent The declaration for a mutual inductive definition of {\even} and {\odd} is: \begin{latexonly} - \newcommand\GammaI{\left[\begin{array}{r \colon l} - \even & \nat\ra\Prop \\ - \odd & \nat\ra\Prop + \newcommand\GammaI{\left[\begin{array}{r@{:}l} + \even & \nat\ra\Prop \\ + \odd & \nat\ra\Prop \end{array} \right]} - \newcommand\GammaC{\left[\begin{array}{r \colon l} - \evenO & \even~\nO \\ - \evenS & \forall n : \nat, \odd~n \ra \even~(\nS~n)\\ - \oddS & \forall n : \nat, \even~n \ra \odd~(\nS~n) + \newcommand\GammaC{\left[\begin{array}{r@{:}l} + \evenO & \even~\nO \\ + \evenS & \forall n : \nat, \odd~n \ra \even~(\nS~n)\\ + \oddS & \forall n : \nat, \even~n \ra \odd~(\nS~n) \end{array} \right]} \vskip.5em @@ -769,7 +769,7 @@ Provided that our environment $E$ contains inductive definitions we showed befor these two inference rules above enable us to conclude that: \vskip.5em \newcommand\prefix{E[\Gamma]\vdash\hskip.25em} -$\begin{array}{@{} l} +$\begin{array}{@{}l} \prefix\even : \nat\ra\Prop\\ \prefix\odd : \nat\ra\Prop\\ \prefix\evenO : \even~\nO\\ @@ -1425,6 +1425,9 @@ If there is an hypothesis $h:a=b$ in the local context, it can be used for rewriting not only in logical propositions but also in any type. % In that case, the term \verb!eq_rec! which was defined as an axiom, is % now a term of the calculus. +\begin{coq_eval} +Require Extraction. +\end{coq_eval} \begin{coq_example} Print eq_rec. Extraction eq_rec. diff --git a/doc/refman/RefMan-gal.tex b/doc/refman/RefMan-gal.tex index 71977d3e9..ef12fe416 100644 --- a/doc/refman/RefMan-gal.tex +++ b/doc/refman/RefMan-gal.tex @@ -37,7 +37,7 @@ Similarly, the notation ``\nelist{\entry}{}'' stands for a non empty sequence of expressions parsed by the ``{\entry}'' entry, without any separator between. -At the end, the notation ``\sequence{\entry}{\tt sep}'' stands for a +Finally, the notation ``\sequence{\entry}{\tt sep}'' stands for a possibly empty sequence of expressions parsed by the ``{\entry}'' entry, separated by the literal ``{\tt sep}''. diff --git a/doc/refman/RefMan-int.tex b/doc/refman/RefMan-int.tex index eca3efcdd..2b9e4e605 100644 --- a/doc/refman/RefMan-int.tex +++ b/doc/refman/RefMan-int.tex @@ -58,7 +58,7 @@ Chapter~\ref{Addoc-coqide}. \section*{How to read this book} -This is a Reference Manual, not a User Manual, then it is not made for a +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. diff --git a/doc/refman/RefMan-oth.tex b/doc/refman/RefMan-oth.tex index bf48057cd..8f43ebcfb 100644 --- a/doc/refman/RefMan-oth.tex +++ b/doc/refman/RefMan-oth.tex @@ -974,7 +974,20 @@ line provided it does not exceed the printing width (See {\tt Set Printing Width} above). \subsection[\tt Test Printing Compact Contexts.]{\tt Test Printing Compact Contexts.\optindex{Printing Compact Contexts}} -This command displays the current state of compaction of goal d'isolat. +This command displays the current state of compaction of goal. + + +\subsection[\tt Unset Printing Unfocused.]{\tt Unset Printing Unfocused.\optindex{Printing Unfocused}} +This command resets the displaying of goals to focused goals only +(default). Unfocused goals are created by focusing other goals with +bullets(see~\ref{bullets}) or curly braces (see~\ref{curlybacket}). + +\subsection[\tt Set Printing Unfocused.]{\tt Set Printing Unfocused.\optindex{Printing Unfocused}} +This command enables the displaying of unfocused goals. The goals are +displayed after the focused ones and are distinguished by a separator. + +\subsection[\tt Test Printing Unfocused.]{\tt Test Printing Unfocused.\optindex{Printing Unfocused}} +This command displays the current state of unfocused goals display. \subsection[\tt Set Printing Dependent Evars Line.]{\tt Set Printing Dependent Evars Line.\optindex{Printing Dependent Evars Line}} This command enables the printing of the ``{\tt (dependent evars: \ldots)}'' diff --git a/doc/refman/RefMan-pre.tex b/doc/refman/RefMan-pre.tex index 0441f952d..0c2a18eb2 100644 --- a/doc/refman/RefMan-pre.tex +++ b/doc/refman/RefMan-pre.tex @@ -1220,6 +1220,120 @@ Paris, November 2016,\\ Matthieu Sozeau and the {\Coq} development team\\ \end{flushright} +\section*{Credits: version 8.7} + +{\Coq} version 8.7 contains the result of refinements, stabilization of +features and cleanups of the internals of the system along with a few +new features. The main user visible changes are: +\begin{itemize} +\item New tactics: variants of tactics supporting existential variables + \texttt{eassert}, \texttt{eenough}, etc... by Hugo Herbelin. Tactics + \texttt{extensionality in H} and \texttt{inversion\_sigma} by Jason + Gross, \texttt{specialize with ...} accepting partial bindings by + Pierre Courtieu. +\item Cumulative Polymorphic Inductive Types, allowing cumulativity of + universes to go through applied inductive types, by Amin Timany and + Matthieu Sozeau. +\item Integration of the \texttt{SSReflect} plugin and its documentation in the + reference manual, by Enrico Tassi, Assia Mahboubi and Maxime Dénès. +\item The \texttt{coq\_makefile} tool was completely redesigned to improve its + maintainability and the extensibility of generated Makefiles, and to + make \texttt{\_CoqProject} files more palatable to IDEs by Enrico Tassi. +\end{itemize} + +{\Coq} 8.7 involved a large amount of work on cleaning and speeding up +the code base, notably the work of Pierre-Marie Pédrot on making the +tactic-level system insensitive to existential variable expansion, +providing a safer API to plugin writers and making the code more +robust. The \texttt{dev/doc/changes.txt} file documents the numerous +changes to the implementation and improvements of interfaces. An effort +to provide an official, streamlined API to plugin writers is in +progress, thanks to the work of Matej KoÅ¡Ãk. + +Version 8.7 also comes with a bunch of smaller-scale changes and improvements +regarding the different components of the system. We shall only list a +few of them. + +The efficiency of the whole system has been significantly improved +thanks to contributions from Pierre-Marie Pédrot, Maxime Dénès and +Matthieu Sozeau and performance issue tracking by Jason Gross and Paul +Steckler. + +Thomas Sibut-Pinote and Hugo Herbelin added support for side effects +hooks in \texttt{cbv}, \texttt{cbn} and \texttt{simpl}. The side +effects are provided via a plugin available at +\url{https://github.com/herbelin/reduction-effects/}. + +The \texttt{BigN}, \texttt{BigZ}, \texttt{BigQ} libraries are no longer +part of the {\Coq} standard library, they are now provided by a separate +repository \url{https://github.com/coq/bignums}, maintained by Pierre +Letouzey. + +In the \texttt{Reals} library, \texttt{IZR} has been changed to produce +a compact representation of integers and real constants are now +represented using \texttt{IZR} (work by Guillaume Melquiond). + +Standard library additions and improvements by Jason Gross, Pierre +Letouzey and others, documented in the CHANGES file. + +The mathematical proof language/declarative mode plugin was removed from +the archive. + +The OPAM repository for {\Coq} packages has been maintained by Guillaume +Melquiond, Matthieu Sozeau, Enrico Tassi with contributions from many +users. A list of packages is available at +\url{https://coq.inria.fr/opam/www/}. + +Packaging tools and software development kits were prepared by Michael +Soegtrop with the help of Maxime Dénès and Enrico Tassi for Windows, and +Maxime Dénès for MacOS X. Packages are regularly built on the +Travis continuous integration server. + +The contributors for this version are Abhishek Anand, C.J. Bell, Yves +Bertot, Frédéric Besson, Tej Chajed, Pierre Courtieu, Maxime Dénès, +Julien Forest, Gaëtan Gilbert, Jason Gross, Hugo Herbelin, Emilio Jesús +Gallego Arias, Ralf Jung, Matej KoÅ¡Ãk, Xavier Leroy, Pierre Letouzey, +Assia Mahboubi, Cyprien Mangin, Erik Martin-Dorel, Olivier Marty, +Guillaume Melquiond, Sam Pablo Kuper, Benjamin Pierce, Pierre-Marie +Pédrot, Lars Rasmusson, Lionel Rieg, Valentin Robert, Yann Régis-Gianas, +Thomas Sibut-Pinote, Michael Soegtrop, Matthieu Sozeau, Arnaud Spiwack, +Paul Steckler, George Stelle, Pierre-Yves Strub, Enrico Tassi, Hendrik +Tews, Amin Timany, Laurent Théry, Vadim Zaliva and Théo Zimmermann. + +The development process was coordinated by Matthieu Sozeau with the help +of Maxime Dénès, who was also in charge of the release process. Théo +Zimmermann is the maintainer of this release. + +Many power users helped to improve the design of the new features via +the bug tracker, the pull request system, the {\Coq} development mailing +list or the coq-club mailing list. Special thanks to the users who +contributed patches and intensive brain-storming and code reviews, +starting with Jason Gross, Ralf Jung, Robbert Krebbers, Xavier Leroy, +Clément Pit--Claudel and Gabriel Scherer. It would however be impossible +to mention exhaustively the names of everybody who to some extent +influenced the development. + +Version 8.7 is the second release of {\Coq} developed on a time-based +development cycle. Its development spanned 9 months from the release of +{\Coq} 8.6 and was based on a public road-map. It attracted many external +contributions. Code reviews and continuous integration testing were +systematically used before integration of new features, with an +important focus given to compatibility and performance issues, resulting +in a hopefully more robust release than {\Coq} 8.6 while maintaining +compatibility. + +Coq Enhancement Proposals (CEPs for short) and open pull-requests +discussions were used to discuss publicly the new features. + +The {\Coq} consortium, an organization directed towards users and +supporters of the system, is now upcoming and will rely on Inria's +newly created Foundation. + +\begin{flushright} +Paris, August 2017,\\ +Matthieu Sozeau and the {\Coq} development team\\ +\end{flushright} + %new Makefile diff --git a/doc/refman/RefMan-pro.tex b/doc/refman/RefMan-pro.tex index 95fee3241..eb59ca584 100644 --- a/doc/refman/RefMan-pro.tex +++ b/doc/refman/RefMan-pro.tex @@ -308,7 +308,7 @@ last {\tt Focus} command. Succeeds in the proof is fully unfocused, fails is there are some goals out of focus. -\subsection[\tt \{ \textrm{and} \}]{\tt \{ \textrm{and} \}\comindex{\{}\comindex{\}}} +\subsection[\tt \{ \textrm{and} \}]{\tt \{ \textrm{and} \}\comindex{\{}\comindex{\}}}\label{curlybacket} The command {\tt \{} (without a terminating period) focuses on the first goal, much like {\tt Focus.} does, however, the subproof can only be unfocused when it has been fully solved (\emph{i.e.} when @@ -327,7 +327,7 @@ unfocus it or focus the next one. \end{ErrMsgs} \subsection[Bullets]{Bullets\comindex{+ (command)} - \comindex{- (command)}\comindex{* (command)}\index{Bullets}} + \comindex{- (command)}\comindex{* (command)}\index{Bullets}}\label{bullets} Alternatively to {\tt \{} and {\tt \}}, proofs can be structured with bullets. The use of a bullet $b$ for the first time focuses on the first goal $g$, the same bullet cannot be used again until the proof diff --git a/doc/refman/RefMan-sch.tex b/doc/refman/RefMan-sch.tex index d3719bed4..23a1c9b02 100644 --- a/doc/refman/RefMan-sch.tex +++ b/doc/refman/RefMan-sch.tex @@ -227,6 +227,7 @@ We define the function \texttt{div2} as follows: \begin{coq_eval} Reset Initial. +Require Import FunInd. \end{coq_eval} \begin{coq_example*} diff --git a/doc/refman/RefMan-ssr.tex b/doc/refman/RefMan-ssr.tex new file mode 100644 index 000000000..61f7421c4 --- /dev/null +++ b/doc/refman/RefMan-ssr.tex @@ -0,0 +1,4932 @@ +\achapter{The SSReflect proof language} +\aauthor{Georges Gonthier, Assia Mahboubi, Enrico Tassi} + +\newcommand{\ssr}{{\sc SSReflect}} + +% listing +\ifhevea\newcommand{\ssrC}[1]{\texttt{#1}}\else\newcommand{\ssrC}[1]{\text{\lstinline!#1!}}\fi +\ifhevea\renewenvironment{center}{\@open{div}{class="center"}\@open{div}{class="centered"}}{\@close{div}\@close{div}}\fi +% non-terminal +%\newcommand\ssrN[2][]{\ensuremath{\langle\mbox{\itshape\rmfamily\small #2}\rangle_{#1}}} +\newcommand\ssrN[2][]{{\textsl {#2}}\ensuremath{_{#1}}} +\ifhevea\newcommand{\underbar}[1]{\underline{#1}}\fi + +% TODO: only use \ssrC +\let\ssrL=\lstinline + +\newcommand{\iitem}{{\it i-item}} +\newcommand{\ditem}{{\it d-item}} +\newcommand{\optional}[1]{{\it[}#1{\it]}} +\newcommand{\optsep}{{\it|}} +\newcommand{\idx}[1]{\tacindex{#1 (ssreflect)}} +\newcommand{\idxC}[1]{\comindex{#1 (ssreflect)}} + +\newenvironment{new}% + {\begin{Sbox}\begin{minipage}{0.97\textwidth}% + \begin{flushright}\textcolor{red}{\fbox{Version 1.3}}% + \end{flushright}\noindent}% + {\end{minipage}\end{Sbox}\noindent\doublebox{\TheSbox}} +\section{Introduction}\label{sec:intro} + +This chapter describes a set of tactics known as \ssr{} +originally designed to provide support for the so-called \emph{small scale +reflection} proof methodology. Despite the original purpose this set of tactic +is of general interest and is available in Coq starting from version 8.7. + +\ssr{} was developed independently of the tactics described in +Chapter~\ref{Tactics}. Indeed the scope of the tactics part of +\ssr{} largely overlaps with the standard set of tactics. Eventually +the overlap will be reduced in future releases of Coq. + +Proofs written in \ssr{} typically look quite different from the +ones written using only tactics as per Chapter~\ref{Tactics}. +We try to summarise here the most ``visible'' ones in order to +help the reader already accustomed to the tactics described in +Chapter~\ref{Tactics}to read this chapter. + +The first difference between the tactics described in this +chapter and the tactics described in Chapter~\ref{Tactics} is the way +hypotheses are managed (we call this \emph{bookkeeping}). +In Chapter~\ref{Tactics} the most common +approach is to avoid moving explicitly hypotheses back and forth +between the context and the conclusion of the goal. On the contrary +in \ssr{} +all bookkeeping is performed on the conclusion of the goal, using for +that purpose a couple of syntactic constructions behaving similar to +tacticals (and often named as such in this chapter). +The \ssrC{:} tactical moves hypotheses from the context to the +conclusion, while \ssrC{=>} moves hypotheses from the +conclusion to the context, and \ssrC{in} moves back +and forth an hypothesis from the context to the conclusion for the +time of applying an action to it. + +While naming hypotheses is commonly done by means of an \ssrC{as} +clause in the basic model of Chapter~\ref{Tactics}, it is here to +\ssrC{=>} that this task is devoted. As tactics leave +new assumptions in the conclusion, and are often followed by +\ssrC{=>} to explicitly name them. +While generalizing the goal is normally +not explicitly needed in Chapter~\ref{Tactics}, it is an explicit +operation performed by \ssrC{:}. + +Beside the difference of bookkeeping model, this chapter includes +specific tactics which have no explicit counterpart in +Chapter~\ref{Tactics} such as tactics to mix forward steps and +generalizations as \ssrC{generally have} or \ssrC{without loss}. + +\ssr{} adopts the point of view that rewriting, definition +expansion and partial evaluation participate all to a same concept of +rewriting a goal in a larger sense. As such, all these functionalities are +provided by the \ssrC{rewrite} tactic. + +\ssrC{} includes a little language of patterns to select subterms in tactics +or tacticals where it matters. Its most notable application +is in the \ssrC{rewrite} tactic, where patterns are used to specify +where the rewriting step has to take place. + +Finally, \ssr{} supports the so-called reflection steps, typically +allowing to switch back and forth between the computational view and +logical view of a concept. + +To conclude it is worth mentioning that \ssr{} tactics +can be mixed with non \ssr{} tactics in the same proof, +or in the same LTac expression. The few exceptions +to this statement are described in section~\label{sec:compat}. + +\iffalse +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\subsection*{How to read this documentation} + +The syntax of the tactics is presented as follows: +\begin{itemize} +\item \ssrC{terminals} are in typewriter font and \ssrN{non terminals} are + between angle brackets. +\item Optional parts of the grammar are surrounded by \optional{ } + brackets. These should not be confused with verbatim brackets + \ssrC{[ ]}, which are delimiters in the \ssr{} syntax. +\item A vertical rule {\optsep} indicates an alternative in the syntax, and + should not be confused with a + verbatim vertical rule between verbatim brackets \ssrC{[ | ]}. +\item A non empty list of non terminals (at least one item should be + present) is represented by \ssrN{non terminals}$^+$. A possibly empty + one is represented by \ssrN{non terminals}$^*$. +\item In a non empty list of non terminals, items are separated by blanks. +\end{itemize} +\fi + +% Hevea has no colors +\ifhevea \else +\noindent We follow the default color scheme of the \ssr{} mode for +ProofGeneral provided in the distribution: + +\centerline{ +\textcolor{dkblue}{\texttt{tactic}} or \textcolor{dkviolet}{\tt + Command} or \textcolor{dkgreen}{\tt keyword} or +\textcolor{dkpink}{\tt tactical}} + +\noindent Closing tactics/tacticals like \ssrC{exact} or \ssrC{by} (see section +\ref{ssec:termin}) are in red. +\fi + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\subsection*{Acknowledgments} +The authors would like to thank Fr\'ed\'eric Blanqui, Fran\,cois Pottier +and Laurence Rideau for their comments and suggestions. + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\newpage\section{Usage} + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\subsection{Getting started}\label{sec:files} +To be available, the tactics presented in this manual need the +following minimal set of libraries to loaded: {\tt ssreflect.v}, {\tt +ssrfun.v} and {\tt ssrbool.v}. Moreover, these tactics come with a +methodology specific to the authors of Ssreflect and which requires a +few options to be set in a different way than in their default +way. All in all, this corresponds to working in the following context: + +\begin{lstlisting} + From Coq Require Import ssreflect ssrfun ssrbool. + Set Implicit Arguments. + Unset Strict Implicit. + Unset Printing Implicit Defensive. +\end{lstlisting} + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\subsection{Compatibility issues}\label{sec:compat} +Requiring the above modules creates an environment which +is mostly compatible with the rest of \Coq{}, up to a few discrepancies: +\begin{itemize} +\item New keywords (\ssrC{is}) might clash with variable, constant, +tactic or tactical names, or with quasi-keywords in tactic or +vernacular notations. +\item New tactic(al)s names (\ssrC{last}, \ssrC{done}, \ssrC{have}, + \ssrC{suffices}, \ssrC{suff}, + \ssrC{without loss}, \ssrC{wlog}, \ssrC{congr}, \ssrC{unlock}) might clash + with user tactic names. +\item Identifiers with both leading and trailing \ssrC{_}, such as \ssrC{_x_}, +are reserved by \ssr{} and cannot appear in scripts. +\item The extensions to the \ssrC{rewrite} tactic are partly +incompatible with those available in current versions of \Coq{}; +in particular: +\ssrC{rewrite .. in (type of k)} or \\ \ssrC{rewrite .. in *} or any other +variant of \ssrC{rewrite} will not work, and the \ssr{} syntax and semantics for occurrence selection and +rule chaining is different. + +Use an explicit rewrite direction (\ssrC{rewrite <-} $\dots$ or \ssrC{rewrite ->} $\dots$) +to access the \Coq{} \ssrC{rewrite} tactic. +\item New symbols (\ssrC{//, /=, //=}) might clash with adjacent existing + symbols (e.g., '\ssrC{//}') instead of '\ssrC{/}''\ssrC{/}'). This can be avoided + by inserting white spaces. +\item New constant and theorem names might clash with the user +theory. This can be avoided by not importing all of \ssr{}: +\begin{lstlisting} + From Coq Require ssreflect. + Import ssreflect.SsrSyntax. +\end{lstlisting} +Note that the full syntax of \ssr{}'s {\tt rewrite} and reserved identifiers are +enabled only if the \ssrC{ssreflect} module has been required and if +\ssrC{SsrSyntax} has been imported. Thus a file that requires (without importing) + \ssrC{ssreflect} and imports \ssrC{SsrSyntax}, can be +required and imported without automatically enabling \ssr{}'s +extended rewrite syntax and reserved identifiers. +\item Some user notations (in particular, defining an infix ';') might +interfere with the "open term", parenthesis free, syntax of tactics +such as \ssrC{have}, \ssrC{set} and \ssrC{pose}. +\item The generalization of \ssrC{if} statements to non-Boolean +conditions is turned off by \ssr{}, because it is mostly subsumed by +\ssrC{Coercion} to \ssrC{bool} of the \ssrC{sum}XXX types (declared in +\ssrC{ssrfun.v}) +and the \ssrC{if} {\term} \ssrC{is} \ssrN{pattern} \ssrC{then} {\term} \ssrC{else} {\term} construct (see +\ref{ssec:patcond}). To use the generalized form, turn off the \ssr{} +Boolean \ssrC{if} notation using the command: +\begin{lstlisting} + Close Scope boolean_if_scope. +\end{lstlisting} +\item The following two options can be unset to disable the + incompatible \ssrC{rewrite} syntax and allow + reserved identifiers to appear in scripts. +\begin{lstlisting} + Unset SsrRewrite. + Unset SsrIdents. +\end{lstlisting} +\end{itemize} + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\section{Gallina extensions} + +Small-scale reflection makes an extensive use of the programming +subset of Gallina, \Coq{}'s logical specification language. This subset +is quite suited to the description of functions on representations, +because it closely follows the well-established design of the ML +programming language. The \ssr{} extension provides three additions +to Gallina, for pattern assignment, pattern testing, and polymorphism; +these mitigate minor but annoying discrepancies between Gallina and ML. + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\subsection{Pattern assignment}\label{ssec:patass} +The \ssr{} extension provides the following construct for +irrefutable pattern matching, that is, destructuring assignment: + +\ssrC{let: } \ssrN{pattern} \ssrC{:=} \ssrN[1]{term} \ssrC{in} \ssrN[2]{term} + +Note the colon `\ssrC{:}' after the \ssrC{let} keyword, which avoids any +ambiguity with a function +definition or \Coq{}'s basic destructuring \ssrC{let}. The \ssrC{let:} +construct differs from the latter in that +\begin{itemize} +\item The pattern can be nested (deep pattern matching), in + particular, this allows expression of the form: +\begin{lstlisting} + let: exist (x, y) p_xy := Hp in ... +\end{lstlisting} +\item The destructured constructor is explicitly given in the + pattern, and is used for type inference, e.g., +\begin{lstlisting} + Let f u := let: (m, n) := u in m + n. +\end{lstlisting} +using a colon \ssrC{let:}, infers \ssrC{f : nat * nat -> nat}, whereas +\begin{lstlisting} + Let f u := let (m, n) := u in m + n. +\end{lstlisting} +with a usual \ssrC{let}, requires an extra type annotation. +\end{itemize} +The \ssrC{let:} construct is just (more legible) notation for the primitive Gallina expression + +\begin{center} +\ssrC{match} \ssrN[1]{term} \ssrC{with} \ssrN{pattern} \ssrC{=>} \ssrN[2]{term} \ssrC{end} +\end{center} + +The \ssr{} destructuring assignment supports all the dependent match +annotations; the full syntax is + +\begin{center} +\ssrC{let:} \ssrN[1]{pattern} \ssrC{as} \ssrN{ident} \ssrC{in} \ssrN[2]{pattern} \ssrC{:=} \ssrN[1]{term} \ssrC{return} \ssrN[2]{term} \ssrC{in} \ssrN[3]{term} +\end{center} + +where \ssrN[2]{pattern} is a \emph{type} pattern and \ssrN[1]{term} and +\ssrN[2]{term} are types. + +When the \ssrC{as} and \ssrC{return} are both present, then \ssrN{ident} is bound +in both the type \ssrN[2]{term} and the expression \ssrN[3]{term}; +variables in the optional type pattern \ssrN[2]{pattern} are +bound only in the type \ssrN[2]{term}, and other variables in \ssrN[1]{pattern} are +bound only in the expression \ssrN[3]{term}, however. + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\subsection{Pattern conditional}\label{ssec:patcond} +The following construct can be used for a refutable pattern matching, +that is, pattern testing: + +\begin{center} +\ssrC{if}\ \ssrN[1]{term} \ssrC{is} \ssrN[1]{pattern} \ssrC{then} \ssrN[2]{term} \ssrC{else} \ssrN[3]{term} +\end{center} + +Although this construct is not strictly ML (it does exits in variants +such as the pattern calculus or the $\rho$-calculus), it turns out to be +very convenient for writing functions on representations, +because most such functions manipulate simple datatypes such as Peano +integers, options, +lists, or binary trees, and the pattern conditional above is almost +always the right construct +for analyzing such simple types. For example, the \ssrC{null} and +\ssrC{all} list function(al)s can be defined as follows: +\begin{lstlisting} + Variable d: Set. + Fixpoint |*null*| (s : list d) := if s is nil then true else false. + Variable a : d -> bool. + Fixpoint |*all*| (s : list d) : bool := + if s is cons x s' then a x && all s' else true. +\end{lstlisting} + +The pattern conditional also provides a notation for destructuring +assignment with a refutable pattern, adapted to the pure functional +setting of Gallina, which lacks a \\\texttt{Match\_Failure} exception. + +Like \ssrC{let:} above, the \ssrC{if}$\dots$\ssrC{is} construct is just (more legible) +notation for the primitive Gallina expression: + +\begin{center} +\ssrC{match} \ssrN[1]{term} \ssrC{with} \ssrN{pattern} \ssrC{=>} \ssrN[2]{term} \ssrC{| _ =>} \ssrN[2]{term} \ssrC{end} +\end{center} + +Similarly, it will always be displayed as the expansion of this form +in terms of primitive \ssrC{match} expressions (where the default +expression $\ssrN[3]{term}$ may be replicated). + + +Explicit pattern testing also largely subsumes the generalization of +the \ssrC{if} construct to all binary datatypes; compare: + +\begin{center} +\ssrC{if} {\term} \ssrC{is inl _ then} \ssrN[l]{term} \ssrC{else} \ssrN[r]{term} +\end{center} + +and: + +\begin{center} +\ssrC{if} {\term} \ssrC{then} \ssrN[l]{term} \ssrC{else} \ssrN[r]{term} +\end{center} + +The latter appears to be marginally shorter, but it is quite +ambiguous, and indeed often +requires an explicit annotation term : \ssrC{\{_\}+\{_\}} to type-check, +which evens the character count. + +Therefore, \ssr{} restricts by default the condition of a plain \ssrC{if} +construct to the standard \ssrC{bool} type; this avoids spurious type +annotations, e.g., in: +\begin{lstlisting} + Definition |*orb*| b1 b2 := if b1 then true else b2. +\end{lstlisting} +As pointed out in section~\ref{sec:compat}, this restriction can be removed with +the command: +\begin{lstlisting} + Close Scope boolean_if_scope. +\end{lstlisting} +Like \ssrC{let:} above, the \ssrC{if} {\term} \ssrC{is} \ssrN{pattern} +\ssrC{else} {\term} construct +supports the dependent \ssrC{match} annotations: + +\begin{center} +\ssrC{if} \ssrN[1]{term} \ssrC{is} \ssrN[1]{pattern} \ssrC{as} \ssrN{ident} \ssrC{in} \ssrN[2]{pattern} \ssrC{return} \ssrN[2]{term} \ssrC{then} \ssrN[3]{term} \ssrC{else} \ssrN[4]{term} +\end{center} + +As in \ssrC{let:} the variable \ssrN{ident} (and those in +the type pattern \ssrN[2]{pattern}) are bound in \ssrN[2]{term}; \ssrN{ident} is +also bound in \ssrN[3]{term} (but not in \ssrN[4]{term}), while the +variables in \ssrN[1]{pattern} are bound only in \ssrN[3]{term}. + +\noindent +Another variant allows to treat the else case first: + +\begin{center} +\ssrC{if} \ssrN[1]{term} \ssrC{isn't} \ssrN[1]{pattern} \ssrC{then} \ssrN[2]{term} \ssrC{else} \ssrN[3]{term} +\end{center} + +Note that \ssrN[1]{pattern} eventually binds variables in \ssrN[3]{term} +and not \ssrN[2]{term}. + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\subsection{Parametric polymorphism}\label{ssec:parampoly} + +Unlike ML, polymorphism in core Gallina is explicit: the type +parameters of polymorphic functions must be declared explicitly, and +supplied at each point of use. However, \Coq{} provides two features +to suppress redundant parameters: +\begin{itemize} +\item Sections are used to provide (possibly implicit) parameters for + a set of definitions. +\item Implicit arguments declarations are used to tell \Coq{} to use + type inference to deduce some parameters from the context at each + point of call. +\end{itemize} +The combination of these features provides a fairly good emulation of ML-style +polymorphism, but unfortunately this emulation breaks down for +higher-order programming. Implicit arguments are indeed not inferred +at all points of use, but only at +points of call, leading to expressions such as +\begin{lstlisting} + Definition |*all_null*| (s : list T) := all (@null T) s. +\end{lstlisting} +Unfortunately, such higher-order expressions are quite frequent in +representation functions, especially those which use \Coq{}'s +\ssrC{Structure}s to emulate Haskell type classes. + +Therefore, \ssr{} provides a variant of \Coq{}'s implicit argument +declaration, which causes \Coq{} to fill in some implicit parameters +at each point of use, e.g., the above definition can be written: +\begin{lstlisting} + Definition |*all_null*| (s : list d) := all null s. +\end{lstlisting} +Better yet, it can be omitted entirely, since \ssrC{all_null s} isn't +much of an improvement over \ssrC{all null s}. + +The syntax of the new declaration is + +\begin{center} +\ssrC{Prenex Implicits} \ssrN{ident}$^+$. +\end{center} + +Let us denote $_1 \dots c_n$ the list of identifiers given to a +\ssrC{Prenex Implicits} command. +The command checks that each $c_i$ is the name of a functional +constant, whose implicit arguments are prenex, i.e., the first $n_i > +0$ arguments of $c_i$ are implicit; then it assigns +\ssrC{Maximal Implicit} status to these arguments. + +As these prenex implicit arguments are ubiquitous and have often large +display strings, it is strongly recommended to change the default +display settings of \Coq{} so that they are not printed (except after a +\ssrC{Set Printing All} command). +All \ssr{} library files thus start with the incantation +\begin{lstlisting} + Set Implicit Arguments. + Unset Strict Implicit. + Unset Printing Implicit Defensive. +\end{lstlisting} + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\subsection{Anonymous arguments} + +When in a definition, the type of a certain argument is mandatory, but +not its name, one usually use ``arrow'' abstractions for prenex +arguments, or the \ssrC{(_ : }{\term}\ssrC{)} syntax for inner arguments. +In \ssr{}, the latter can be replaced by the open syntax `\ssrC{of\ }{\term}' +or (equivalently) `\ssrC{& }{\term}', which are both syntactically +equivalent to a \ssrC{(_ : }{\term}\ssrC{)} expression. + +For instance, the usual two-contrsuctor polymorphic type \ssrC{list}, +i.e. the one of the +standard {\tt List} library, can be defined by the following +declaration: +\begin{lstlisting} + Inductive list (A : Type) : Type := nil | cons of A & list A. +\end{lstlisting} + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\subsection{Wildcards}\label{ssec:wild} + +The terms passed as arguments +to \ssr{} tactics can contain \emph{holes}, materialized by wildcards +\ssrC{_}. +Since \ssr{} allows a more powerful form of type inference for these +arguments, it enhances the possibilities of using such wildcards. +These holes are in particular used as a convenient shorthand for +abstractions, especially in local definitions or type expressions. + +Wildcards may be interpreted as abstractions (see for example sections +\ref{ssec:pose} and \ref{ssec:struct}), or their content can be +inferred from the whole +context of the goal (see for example section \ref{ssec:set}). +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\section{Definitions} + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\subsection{Definitions}\label{ssec:pose} +\idx{pose \dots{} := \dots{}} +\idx{pose fix \dots{} := \dots{}} +\idx{pose cofix \dots{} := \dots{}} + +The \ssrC{pose} tactic allows to add a defined constant to a +proof context. \ssr{} generalizes this tactic in several ways. +In particular, the \ssr{} \ssrC{pose} tactic supports \emph{open syntax}: +the body of +the definition does not need surrounding parentheses. For instance: +\begin{lstlisting} + pose t := x + y. +\end{lstlisting} +is a valid tactic expression. + +The \ssrC{pose} tactic is also improved for the +local definition of higher order terms. +Local definitions of functions can use the same syntax as +global ones. The tactic: +\begin{lstlisting} + pose f x y := x + y. +\end{lstlisting} +adds to the context the defined constant: +\begin{lstlisting} + f := fun x y : nat => x + y : nat -> nat -> nat +\end{lstlisting} + +The \ssr{} \ssrC{pose} tactic also supports (co)fixpoints, +by providing the local counterpart of the +\ssrC{Fixpoint f := $\dots$ } and \ssrC{CoFixpoint f := $\dots$ } constructs. +For instance, the following tactic: +\begin{lstlisting} + pose fix f (x y : nat) {struct x} : nat := + if x is S p then S (f p y) else 0. +\end{lstlisting} +defines a local fixpoint \ssrC{f}, which mimics the standard \ssrC{plus} +operation on natural numbers. + +Similarly, local cofixpoints can be defined by a tactic of the form: +\begin{lstlisting} + pose cofix f (arg : T) ... +\end{lstlisting} + +The possibility to include wildcards in the body of the definitions + offers a smooth +way of defining local abstractions. The type of ``holes'' is +guessed by type inference, and the holes are abstracted. +For instance the tactic: +\begin{lstlisting} + pose f := _ + 1. +\end{lstlisting} +is shorthand for: +\begin{lstlisting} + pose f n := n + 1. +\end{lstlisting} + +When the local definition of a function involves both arguments and +holes, hole abstractions appear first. For instance, the +tactic: +\begin{lstlisting} + pose f x := x + _. +\end{lstlisting} +is shorthand for: +\begin{lstlisting} + pose f n x := x + n. +\end{lstlisting} + + +The interaction of the \ssrC{pose} tactic with the interpretation of +implicit arguments results in a powerful and concise syntax for local +definitions involving dependent types. +For instance, the tactic: +\begin{lstlisting} + pose f x y := (x, y). +\end{lstlisting} +adds to the context the local definition: +\begin{lstlisting} + pose f (Tx Ty : Type) (x : Tx) (y : Ty) := (x, y). +\end{lstlisting} +The generalization of wildcards makes the use of the \ssrC{pose} tactic +resemble ML-like definitions of polymorphic functions. + +% The use of \ssrC{Prenex Implicits} declarations (see section +% \ref{ssec:parampoly}), makes this feature specially convenient. +% Note that this combines with the interpretation of wildcards, and that +% it is possible to define: +% \begin{lstlisting} +% pose g x y : prod _ nat := (x, y). +% \end{lstlisting} +% which is equivalent to: +% \begin{lstlisting} +% pose g x (y : nat) := (x, y). +% \end{lstlisting} + + + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\subsection{Abbreviations}\label{ssec:set} +\idx{set \dots{} := \dots{}} + + +The \ssr{} \ssrC{set} tactic performs abbreviations: it introduces a +defined constant for a subterm appearing in the goal and/or in the +context. + +\ssr{} extends the \ssrC{set} tactic by supplying: +\begin{itemize} +\item an open syntax, similarly to the \ssrC{pose} tactic; +\item a more aggressive matching algorithm; +\item an improved interpretation of wildcards, taking advantage of the + matching algorithm; +\item an improved occurrence selection mechanism allowing to abstract only + selected occurrences of a term. +\end{itemize} + +The general syntax of this tactic is +\begin{center} +\ssrC{set} \ssrN{ident} \optional{\ssrC{:} \ssrN[1]{term}} \ssrC{:=} \optional{\ssrN{occ-switch}} \ssrN[2]{term} +\end{center} +\begin{center} +\ssrN{occ-switch} ::= \ssrC{\{}[\ssrC{+}|\ssrC{-}] {\naturalnumber}$^*$ \ssrC{\}} +\end{center} + + +where: + +\begin{itemize} +\item \ssrN{ident} is a fresh identifier chosen by the user. +\item \ssrN[1]{term} is +an optional type annotation. The type annotation \ssrN[1]{term} can be +given in open syntax (no surrounding parentheses). If no \ssrN{occ-switch} +(described hereafter) is present, it is also +the case for \ssrN[2]{term}. +On the other hand, in presence of \ssrN{occ-switch}, parentheses +surrounding \ssrN[2]{term} are mandatory. +\item In the occurrence switch \ssrN{occ-switch}, if the first element + of the list is a {\naturalnumber}, this element should be a number, and not + an Ltac variable. The empty list \ssrC{\{\}} is not interpreted as a + valid occurrence switch. +\end{itemize} +% For example, the script: +% \begin{lstlisting} +% Goal forall (f : nat -> nat)(x y : nat), f x + f x = f x. +% move=> f x y. +% \end{lstlisting} + +The tactic: +\begin{lstlisting} + set t := f _. +\end{lstlisting} +transforms the goal \ssrC{f x + f x = f x} into \ssrC{t + t = t}, adding +\ssrC{t := f x} to the context, and the tactic: +\begin{lstlisting} + set t := {2}(f _). +\end{lstlisting} +transforms it into \ssrC{f x + t = f x}, adding \ssrC{t := f x} to the context. + +The type annotation \ssrN[1]{term} may +contain wildcards, which will be filled with the appropriate value by +the matching process. + +The tactic first tries to find a subterm of the goal matching +\ssrN[2]{term} (and its type \ssrN[1]{term}), +and stops at the first subterm it finds. Then the occurrences +of this subterm selected by the optional \ssrN{occ-switch} are replaced +by \ssrN{ident} and a definition \ssrN{ident} \ssrC{:=} {\term} is added to +the context. If no \ssrN{occ-switch} is present, then all the +occurrences are abstracted. + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\subsubsection*{Matching} + +The matching algorithm compares a pattern \textit{term} + with a subterm of the goal by comparing their heads +and then pairwise unifying their arguments (modulo conversion). Head +symbols match under the following conditions: + +\begin{itemize} +\item If the head of \textit{term} is a constant, then it + should be syntactically equal to the head symbol of the subterm. +\item If this head is a projection of a canonical structure, + then canonical structure equations are used for the matching. +\item If the head of \textit{term} is \emph{not} a constant, the + subterm should have the same structure ($\lambda$ abstraction, + \ssrC{let}$\dots$\ssrC{in} structure \dots). +\item If the head of \textit{term} is a hole, the subterm should have + at least as many arguments as \textit{term}. For instance the tactic: +\begin{lstlisting} + set t := _ x. +\end{lstlisting} +transforms the goal \ssrL-x + y = z- into \ssrC{t y = z} and adds +\ssrC{t := plus x : nat -> nat} to the context. + +\item In the special case where \textit{term} is of the form + \ssrC{(let f := }$t_0$ \ssrC{in f) }$t_1\dots t_n$, + then the pattern \textit{term} is treated +as \ssrC{(_ }$t_1\dots t_n$\ssrC{)}. For each subterm in +the goal having the form $(A\ u_1\dots u_{n'})$ with $n' \geq n$, the +matching algorithm successively tries to find the largest +partial application $(A\ u_1\dots u_{i'})$ convertible to the head +$t_0$ of \textit{term}. For instance the following tactic: +\begin{lstlisting} + set t := (let g y z := y.+1 + z in g) 2. +\end{lstlisting} +transforms the goal +\begin{lstlisting} + (let f x y z := x + y + z in f 1) 2 3 = 6. +\end{lstlisting} +into \ssrC{t 3 = 6} and adds the local definition of \ssrC{t} to the +context. +\end{itemize} + +Moreover: +\begin{itemize} +\item Multiple holes in \textit{term} are treated as independent + placeholders. For instance, the tactic: +\begin{lstlisting} + set t := _ + _. +\end{lstlisting} +transforms the goal \ssrC{x + y = z} into \ssrC{t = z} and pushes +\ssrC{t := x + y : nat} in the context. +\item The type of the subterm matched should fit the type + (possibly casted by some type annotations) of the pattern + \textit{term}. +\item The replacement of the subterm found by the instantiated pattern + should not capture variables, hence the following script: +\begin{lstlisting} + Goal forall x : nat, x + 1 = 0. + set u := _ + 1. +\end{lstlisting} +raises an error message, since \ssrC{x} is bound in the goal. +\item Typeclass inference should fill in any residual hole, but +matching should never assign a value to a global existential variable. + +\end{itemize} + + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\subsubsection*{Occurrence selection}\label{sssec:occselect} + +\ssr{} provides a generic syntax for the selection of occurrences by +their position indexes. These \emph{occurrence switches} are shared by +all +\ssr{} tactics which require control on subterm selection like rewriting, +generalization, \dots + +An \emph{occurrence switch} can be: +\begin{itemize} +\item A list \ssrC{\{} {\naturalnumber}$^*$ \ssrC{\}} of occurrences affected by the + tactic. +For instance, the tactic: +\begin{lstlisting} + set x := {1 3}(f 2). +\end{lstlisting} +transforms the goal \ssrC{f 2 + f 8 = f 2 + f 2} into +\ssrC{x + f 8 = f 2 + x}, and adds the abbreviation +\ssrC{x := f 2} in the +context. Notice that some occurrences of a +given term may be hidden to the user, for example because of a +notation. The vernacular \ssrC{$\texttt{\textcolor{dkviolet}{Set }}$ + Printing All} command displays all +these hidden occurrences and should be used to find the correct +coding of the occurrences to be selected\footnote{Unfortunately, +even after a call to the Set Printing All command, some occurrences are +still not displayed to the user, essentially the ones possibly hidden +in the predicate of a dependent match structure.}. For instance, the +following script: +\begin{lstlisting} + Notation "a < b":= (le (S a) b). + Goal forall x y, x < y -> S x < S y. + intros x y; set t := S x. +\end{lstlisting} +generates the goal +\ssrC{t <= y -> t < S y} since \ssrC{x < y} is now a notation for +\ssrC{S x <= y}. +\item A list \ssrC{\{}{\naturalnumber}$^+$\ssrC{\}}. This is equivalent to + \ssrC{\{} {\naturalnumber}$^+$ \ssrC{\}} but the list should start with a number, and + not with an Ltac variable. +\item A list \ssrC{\{}{\naturalnumber}$^*$\ssrC{\}} of occurrences \emph{not} to be + affected by the tactic. For instance, the tactic: +\begin{lstlisting} + set x := {-2}(f 2). +\end{lstlisting} +behaves like +\begin{lstlisting} + set x := {1 3}(f 2). +\end{lstlisting} +on the goal \ssrL-f 2 + f 8 = f 2 + f 2- which has three occurrences of +the the term \ssrC{f 2} +\item In particular, the switch \ssrC{\{+\}} selects \emph{all} the + occurrences. This switch is useful to turn + off the default behavior of a tactic which automatically clears + some assumptions (see section \ref{ssec:discharge} for instance). +\item The switch \ssrC{\{-\}} imposes that \emph{no} occurrences of the + term should be affected by the tactic. The tactic: +\begin{lstlisting} + set x := {-}(f 2). +\end{lstlisting} +leaves the goal unchanged and adds the definition \ssrC{x := f 2} to the +context. This kind of tactic may be used to take advantage of the +power of the matching algorithm in a local definition, instead of +copying large terms by hand. +\end{itemize} + + +It is important to remember that matching \emph{precedes} occurrence +selection, hence the tactic: +\begin{lstlisting} + set a := {2}(_ + _). +\end{lstlisting} +transforms the goal \ssrC{x + y = x + y + z} into \ssrC{x + y = a + z} +and fails on the goal \\ +\ssrC{(x + y) + (z + z) = z + z} with the error message: +\begin{lstlisting} + User error: only 1 < 2 occurrence of (x + y + (z + z)) +\end{lstlisting} + + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\subsection{Localization}\label{ssec:loc} + + +It is possible to define an abbreviation for a term appearing in the +context of a goal thanks to the \ssrC{in} tactical. + +A tactic of the form: + +\begin{center} + \ssrC{set x :=} {\term} \ssrC{in} \ssrN[1]{fact}\ssrC{...}\ssrN[n]{fact}. +\end{center} + +introduces a defined constant called \ssrC{x} in the context, and folds +it in the facts \textit{fact$_1 \dots$ fact$_n$} +The body of \ssrC{x} is the first subterm matching \textit{term} in +\textit{fact$_1 \dots$ fact$_n$}. + +A tactic of the form: + +\begin{center} + \ssrC{set x :=} {\term} \ssrC{in} \ssrN[1]{fact}\ssrC{...}\ssrN[n]{fact} \ssrC{*.} +\end{center} + +matches {\term} and then folds \ssrC{x} similarly in +\textit{fact$_1 \dots$ fact$_n$}, but also folds \ssrC{x} in the goal. + +A goal \ssrL-x + t = 4-, whose context contains \ssrC{Hx : x = 3}, is left +unchanged by the tactic: +\begin{lstlisting} + set z := 3 in Hx. +\end{lstlisting} +but the context is extended with the definition \ssrC{z := 3} and \ssrC{Hx} becomes +\ssrC{Hx : x = z}. +On the same goal and context, the tactic: +\begin{lstlisting} + set z := 3 in Hx *. +\end{lstlisting} +will moreover change the goal into \ssrL-x + t = S z-. Indeed, remember +that \ssrC{4} is just a notation for \ssrC{(S 3)}. + +The use of the \ssrC{in} tactical is not limited to the localization of +abbreviations: for a complete description of the \ssrC{in} tactical, see +section \ref{ssec:profstack}. +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\section{Basic tactics}\label{sec:book} + + + +A sizable fraction of proof scripts consists of steps that do not +"prove" anything new, but instead perform menial bookkeeping tasks +such as selecting the names of constants and assumptions or splitting +conjuncts. Although they are logically trivial, bookkeeping steps are +extremely important because they define the structure of the data-flow +of a proof script. This is especially true for reflection-based +proofs, which often involve large numbers of constants and +assumptions. Good bookkeeping consists in always explicitly declaring +(i.e., naming) all new constants and assumptions in the script, and +systematically pruning irrelevant constants and assumptions in the +context. This is essential in the context of an interactive +development environment (IDE), because it facilitates navigating the +proof, allowing to instantly "jump back" to the point at which a +questionable assumption was added, and to find relevant assumptions by +browsing the pruned context. While novice or casual \Coq{} users may +find the automatic name selection feature convenient, the usage of +such a feature severely undermines the readability and maintainability +of proof scripts, much like automatic variable declaration in programming +languages. The \ssr{} tactics are therefore designed to support +precise bookkeeping and to eliminate name generation heuristics. +The bookkeeping features of \ssr{} are implemented as tacticals (or +pseudo-tacticals), shared across most \ssr{} tactics, and thus form +the foundation of the \ssr{} proof language. + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\subsection{Bookkeeping}\label{ssec:profstack} +\idx{move: \dots{}} +\idx{move=> \dots{}} +\idx{move: \dots{} => \dots{}} +\idx{\dots{} in \dots{}} + +During the course of a proof \Coq{} always present the user with +a \emph{sequent} whose general form is +\begin{displaymath}\begin{array}{l} +%\arrayrulecolor{dkviolet} +c_i\ \ssrC{:}\ T_i \\ +\dots\\ +d_j\ \ssrC{:=}\ e_j\ \ssrC{:}\ T_j \\ +\dots\\ +F_k\ \ssrC{:}\ P_k \\ +\dots \\[3pt] +\hline\hline\\[-8pt] +\ssrC{forall}\ \ssrC{(}x_\ell\ \ssrC{:}\ T_\ell\ssrC{)}\ \dots,\\ +\ssrC{let}\ y_m\ \ssrC{:=}\ b_m\ \ssrC{in}\ \dots\ \ssrC{in}\\ +P_n\ \ssrC{->}\ \dots\ \ssrC{->}\ C +\end{array}\end{displaymath} +The \emph{goal} to be proved appears below the double line; above the line is +the \emph{context} of the sequent, a set of declarations of +\emph{constants}~$c_i$, \emph{defined constants}~$d_i$, and +\emph{facts}~$F_k$ that can be used to prove the goal (usually, $T_i, +T_j\;:\;\ssrC{Type}$ and $P_k\;:\;\ssrC{Prop}$). The various kinds of +declarations can come in any order. The top part of the context +consists of declarations produced by the \ssrC{Section} commands +\ssrC{Variable}, \ssrC{Let}, and \ssrC{Hypothesis}. This \emph{section context} +is never affected by the \ssr{} tactics: they only operate on +the lower part --- the \emph{proof context}. +As in the figure above, the goal often decomposes into a series of +(universally) quantified \emph{variables} +$\ssrC{(}x_\ell\;\ssrC{:}\;T_\ell\ssrC{)}$, local \emph{definitions} +$\ssrC{let}\;y_m\:\ssrC{:=}\;b_m\;\ssrC{in}$, and \emph{assumptions} +$P_n\;\ssrC{->}$, and a \emph{conclusion}~$C$ (as in the context, variables, +definitions, and assumptions can appear in any order). The conclusion +is what actually needs to be proved --- the rest of the goal can be +seen as a part of the proof context that happens to be ``below the line''. + +However, although they are logically equivalent, there are fundamental +differences between constants and facts on the one hand, and variables +and assumptions on the others. Constants and facts are +\emph{unordered}, but \emph{named} explicitly in the proof text; +variables and assumptions are \emph{ordered}, but \emph{unnamed}: the +display names of variables may change at any time because of +$\alpha$-conversion. + +Similarly, basic deductive steps such as \ssrC{apply} can only operate on +the goal because the Gallina terms that control their action (e.g., +the type of the lemma used by \ssrC{apply}) only provide unnamed bound +variables.\footnote{Thus scripts that depend on bound variable names, e.g., +via \ssrC{intros} or \ssrC{with}, are inherently fragile.} Since the proof +script can only refer directly to the context, it must constantly +shift declarations from the goal to the context and conversely in +between deductive steps. + +In \ssr{} these moves are performed by two \emph{tacticals} `\ssrC{=>}' +and `\ssrC{:}', so that the bookkeeping required by a deductive step can +be directly associated to that step, and that tactics in an \ssr{} +script correspond to actual logical steps in the proof rather than +merely shuffle facts. Still, some isolated bookkeeping is unavoidable, +such as naming variables and assumptions at the beginning of a proof. +\ssr{} provides a specific \ssrC{move} tactic for this purpose. + +Now \ssrC{move} does essentially nothing: it is mostly a placeholder for +`\ssrC{=>}' and `\ssrC{:}'. The `\ssrC{=>}' tactical moves variables, local +definitions, and assumptions to the context, while the `\ssrC{:}' +tactical moves facts and constants to the goal. For example, the proof +of\footnote{The name \ssrC{subnK} reads as +``right cancellation rule for \ssrC{nat} subtraction''.} +\begin{lstlisting} + Lemma |*subnK*| : forall m n, n <= m -> m - n + n = m. +\end{lstlisting}\noindent +might start with +\begin{lstlisting} + move=> m n le_n_m. +\end{lstlisting} +where \ssrC{move} does nothing, but \ssrL|=> m n le_m_n| changes the +variables and assumption of the goal in the constants \ssrC{m n : nat} +and the fact \ssrL|le_n_m : n <= m|, thus exposing the conclusion\\ + \ssrC{m - n + n = m}. + +The `\ssrC{:}' tactical is the converse of `\ssrC{=>}': it removes facts +and constants from the context by turning them into variables and assumptions. +Thus +\begin{lstlisting} + move: m le_n_m. +\end{lstlisting} +turns back \ssrC{m} and \ssrL|le_m_n| into a variable and an assumption, removing +them from the proof context, and changing the goal to +\begin{lstlisting} + forall m, n <= m -> m - n + n = m. +\end{lstlisting} +which can be proved by induction on \ssrC{n} using \ssrC{elim: n}. + +\noindent +Because they are tacticals, `\ssrC{:}' and `\ssrC{=>}' can be combined, as in +\begin{lstlisting} + move: m le_n_m => p le_n_p. +\end{lstlisting} +simultaneously renames \ssrL|m| and \ssrL|le_m_n| into \ssrL|p| and \ssrL|le_n_p|, +respectively, by first turning them into unnamed variables, then +turning these variables back into constants and facts. + +Furthermore, \ssr{} redefines the basic \Coq{} tactics \ssrC{case}, +\ssrC{elim}, and \ssrC{apply} so that they can take better advantage of +'\ssrC{:}' and `\ssrC{=>}'. In there \ssr{} variants, these tactic operate +on the first variable or constant of the goal and they do not use or +change the proof context. The `\ssrC{:}' tactical is used to operate on +an element in the context. For instance the proof of \ssrC{subnK} could +continue with +\begin{lstlisting} + elim: n. +\end{lstlisting} +instead of \ssrC{elim n}; this has the advantage of +removing \ssrC{n} from the context. Better yet, this \ssrC{elim} can be combined +with previous \ssrC{move} and with the branching version of the \ssrC{=>} tactical +(described in~\ref{ssec:intro}), +to encapsulate the inductive step in a single command: +\begin{lstlisting} + elim: n m le_n_m => [|n IHn] m => [_ | lt_n_m]. +\end{lstlisting} +which breaks down the proof into two subgoals, +\begin{lstlisting} + m - 0 + 0 = m +\end{lstlisting} +given \ssrC{m : nat}, and +\begin{lstlisting} + m - S n + S n = m +\end{lstlisting} +given \ssrC{m n : nat}, \ssrL|lt_n_m : S n <= m|, and +\begin{lstlisting} + IHn : forall m, n <= m -> m - n + n = m. +\end{lstlisting} +The '\ssrC{:}' and `\ssrC{=>}' tacticals can be explained very simply +if one views the goal as a stack of variables and assumptions piled +on a conclusion: +\begin{itemize} +\item {\tac} \ssrC{:} $a$ $b$ $c$ pushes the context constants $a$, $b$, $c$ +as goal variables \emph{before} performing {\tac}. +\item {\tac} \ssrC{=>} $a$ $b$ $c$ pops the top three goal variables as +context constants $a$, $b$, $c$, \emph{after} {\tac} +has been performed. +\end{itemize} +These pushes and pops do not need to balance out as in the examples above, +so +\begin{lstlisting} + move: m le_n_m => p. +\end{lstlisting} +would rename \ssrC{m} into \ssrC{p}, but leave an extra assumption \ssrC{n <= p} +in the goal. + +Basic tactics like \ssrC{apply} and \ssrC{elim} can also be used without the +'\ssrC{:}' tactical: for example we can directly start a proof of \ssrC{subnK} +by induction on the top variable \ssrC{m} with +\begin{lstlisting} + elim=> [|m IHm] n le_n. +\end{lstlisting} + +\noindent +The general form of the localization tactical \ssrC{in} is also best +explained in terms of the goal stack: + +\begin{center} + {\tac} \ssrC{in a H1 H2 *.} +\end{center} + +is basically equivalent to + +\begin{center} + \ssrC{move: a H1 H2;} {\tac} \ssrC{=> a H1 H2.} +\end{center} + +with two differences: the \ssrC{in} tactical will preserve the body of \ssrC{a} if +\ssrC{a} is a defined constant, and if the `\ssrC{*}' is omitted it +will use a temporary abbreviation to hide the statement of the goal +from \ssrC{/*tactic*/}. + +The general form of the \ssrC{in} tactical can be used directly with +the \ssrC{move}, \ssrC{case} and \ssrC{elim} tactics, so that one can write +\begin{lstlisting} + elim: n => [|n IHn] in m le_n_m *. +\end{lstlisting} +instead of +\begin{lstlisting} + elim: n m le_n_m => [|n IHn] m le_n_m. +\end{lstlisting} +This is quite useful for inductive proofs that involve many facts. + +\noindent See section \ref{ssec:gloc} for the general syntax and presentation +of the \ssrC{in} tactical. + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\subsection{The defective tactics}\label{ssec:basictac} + +In this section we briefly present the three basic tactics performing +context manipulations and the main backward chaining tool. + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\subsubsection*{The \ssrC{move} tactic.}\label{sssec:move} +\idx{move} + +The \ssrC{move} tactic, in its +defective form, behaves like the primitive \ssrC{hnf} \Coq{} tactic. For +example, such a defective: +\begin{lstlisting} + move. +\end{lstlisting} +exposes the first assumption in the goal, i.e. its changes the goal +\ssrC{\~ False} into \ssrC{False -> False}. + +More precisely, the \ssrC{move} tactic inspects the goal and does nothing +(\ssrC{idtac}) if an introduction step is possible, i.e. if the +goal is a product or a \ssrC{let}$\dots$\ssrC{in}, and performs \ssrC{hnf} +otherwise. + +Of course this tactic is most often used in combination with the +bookkeeping tacticals (see section \ref{ssec:intro} and +\ref{ssec:discharge}). These combinations mostly subsume the \ssrC{intros}, +\ssrC{generalize}, \ssrC{revert}, \ssrC{rename}, \ssrC{clear} and +\textcolor{dkblue}{\texttt{pattern}} tactics. + + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\subsubsection*{The \ssrC{case} tactic.} +\idx{case: \dots{}} + +The \ssrC{case} tactic performs +\emph{primitive case analysis} on (co)inductive types; specifically, +it destructs the top variable or assumption of the goal, +exposing its constructor(s) and its arguments, as well as setting the value +of its type family indices if it belongs to a type family +(see section \ref{ssec:typefam}). + +The \ssr{} \ssrC{case} tactic has a special behavior on +equalities. +If the top assumption of the goal is an equality, the \ssrC{case} tactic +``destructs'' it as a set of equalities between the constructor +arguments of its left and right hand sides, as per the +tactic \ssrC{injection}. +For example, \ssrC{case} changes the goal +\begin{lstlisting} + (x, y) = (1, 2) -> G. +\end{lstlisting} +into +\begin{lstlisting} + x = 1 -> y = 2 -> G. +\end{lstlisting} + +Note also that the case of \ssr{} performs \ssrC{False} +elimination, even if no branch is generated by this case operation. +Hence the command: +\begin{lstlisting} + case. +\end{lstlisting} +on a goal of the form \ssrC{False -> G} will succeed and prove the goal. + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\subsubsection*{The \ssrC{elim} tactic.} +\idx{elim: \dots{}} + +The \ssrC{elim} tactic performs +inductive elimination on inductive types. +The defective: +\begin{lstlisting} + elim. +\end{lstlisting} +tactic performs inductive elimination on a goal whose top assumption +has an inductive type. For example on goal of the form: +\begin{lstlisting} + forall n : nat, m <= n +\end{lstlisting} + in a context containing \ssrC{m : nat}, the +\begin{lstlisting} + elim. +\end{lstlisting} +tactic produces two goals, +\begin{lstlisting} + m <= 0 +\end{lstlisting} +on one hand and +\begin{lstlisting} + forall n : nat, m <= n -> m <= S n +\end{lstlisting} +on the other hand. + + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\subsubsection*{The \ssrC{apply} tactic.}\label{sssec:apply} +\idx{apply: \dots{}} + +The \ssrC{apply} tactic is the main +backward chaining tactic of the proof system. It takes as argument any +\ssrC{/*term*/} and applies it to the goal. +Assumptions in the type of \ssrC{/*term*/} that don't directly match the +goal may generate one or more subgoals. + +In fact the \ssr{} tactic: +\begin{lstlisting} + apply. +\end{lstlisting} +is a synonym for: +\begin{lstlisting} + intro top; first [refine top | refine (top _) | refine (top _ _) | ...]; clear top. +\end{lstlisting} +where \ssrC{top} is fresh name, and the sequence of \ssrC{refine} tactics +tries to catch the appropriate number of wildcards to be inserted. +Note that this use of the \ssrC{refine} tactic implies that the tactic +tries to match the goal up to expansion of +constants and evaluation of subterms. + +\ssr{}'s \ssrC{apply} has a special behaviour on goals containing +existential metavariables of sort \ssrC{Prop}. Consider the +following example: +\begin{lstlisting} +Goal (forall y, 1 < y -> y < 2 -> exists x : { n | n < 3 }, proj1_sig x > 0). +move=> y y_gt1 y_lt2; apply: (ex_intro _ (exist _ y _)). + by apply: gt_trans _ y_lt2. +by move=> y_lt3; apply: lt_trans y_gt1. +\end{lstlisting} +Note that the last \ssrC{_} of the tactic \ssrC{apply: (ex_intro _ (exist _ y _))} +represents a proof that \ssrC{y < 3}. Instead of generating the following +goal +\begin{lstlisting} + 0 < (n:=3) (m:=y) ?54 +\end{lstlisting} +\noindent the system tries to prove \ssrC{y < 3} calling the \ssrC{trivial} +tactic. If it succeeds, let's say because the context contains +\ssrC{H : y < 3}, then the system generates the following goal: +\begin{lstlisting} + 0 < proj1_sig (exist (fun n => n < 3) y H +\end{lstlisting} +\noindent Otherwise the missing proof is considered to be irrelevant, and +is thus discharged generating the following goals: +\begin{lstlisting} + y < 3 + forall H : y < 3, proj1_sig (exist (fun n => n < 3) y H) +\end{lstlisting} +Last, the user can replace the \ssrC{trivial} tactic by defining +an Ltac expression named \ssrC{ssrautoprop}. + + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\subsection{Discharge}\label{ssec:discharge} +\idx{\dots{} : \dots{}} + +The general syntax of the discharging tactical `\ssrC{:}' is: +\begin{center} + {\tac} \optional{\ssrN{ident}} \ssrC{:} \ssrN[1]{d-item} $\dots$ \ssrN[n]{d-item} \optional{\ssrN{clear-switch}} +\end{center} +where $n > 0$, and \ssrN{d-item} and \ssrN{clear-switch} are defined as +\begin{longtable}{rcl} +\ssrN{d-item} & ::= & \optional{\ssrN{occ-switch} {\optsep} \ssrN{clear-switch}} {\term} \\ +\ssrN{clear-switch}& ::=& \ssrC{\{} \ssrN[1]{ident}\, \ldots\, \ssrN[m]{ident} \ssrC{\}} +\end{longtable} +with the following requirements: +\begin{itemize} +\item {\tac} must be one of the four basic tactics described + in~\ref{ssec:basictac}, i.e., \ssrC{move}, \ssrC{case}, \ssrC{elim} or \ssrC{apply}, + the \ssrC{exact} tactic (section \ref{ssec:termin}), + the \ssrC{congr} tactic (section \ref{ssec:congr}), or the application + of the \emph{view} tactical `\ssrC{/}' (section \ref{ssec:assumpinterp}) + to one of \ssrC{move}, \ssrC{case}, or \ssrC{elim}. +\item The optional \ssrN{ident} specifies \emph{equation generation} + (section \ref{ssec:equations}), and is only allowed if {\tac} + is \ssrC{move}, \ssrC{case} or \ssrC{elim}, or the application of the + view tactical `\ssrC{/}' (section \ref{ssec:assumpinterp}) + to \ssrC{case} or \ssrC{elim}. +\item An \ssrN{occ-switch} selects occurrences of {\term}, + as in \ref{sssec:occselect}; \ssrN{occ-switch} is not allowed if + {\tac} is \ssrC{apply} or \ssrC{exact}. +\item A clear item \ssrN{clear-switch} specifies facts and constants to be + deleted from the proof context (as per the \ssrC{clear} tactic). +\end{itemize} +The `\ssrC{:}' tactical first \emph{discharges} all the \ssrN{d-item}s, +right to left, and then performs {\tac}, i.e., for each \ssrN{d-item}, +starting with $\ssrN[n]{d-item}$: +\begin{enumerate} +\item The \ssr{} matching algorithm described in section~\ref{ssec:set} + is used to find occurrences of {\term} in the goal, + after filling any holes `\ssrC{_}' in {\term}; however if {\tac} + is \ssrC{apply} or \ssrC{exact} a different matching algorithm, + described below, is used + \footnote{Also, a slightly different variant may be used for the first + \ssrN{d-item} of \ssrC{case} and \ssrC{elim}; see section~\ref{ssec:typefam}.}. +\item~\label{enum:gen} These occurrences are replaced by a new + variable; in particular, + if {\term} is a fact, this adds an assumption to the goal. +\item~\label{enum:clr} If {\term} is \emph{exactly} the name of a constant + or fact in the proof context, it is deleted from the context, + unless there is an \ssrN{occ-switch}. +\end{enumerate} +Finally, {\tac} is performed just after $\ssrN[1]{d-item}$ has been +generalized --- +that is, between steps \ref{enum:gen} and \ref{enum:clr} for $\ssrN[1]{d-item}$. +The names listed in the final \ssrN{clear-switch} (if it is present) +are cleared first, before $\ssrN[n]{d-item}$ is discharged. + +\noindent +Switches affect the discharging of a \ssrN{d-item} as follows: +\begin{itemize} +\item An \ssrN{occ-switch} restricts generalization (step~\ref{enum:gen}) + to a specific subset of the occurrences of {\term}, as per + \ref{sssec:occselect}, and prevents clearing (step~\ref{enum:clr}). +\item All the names specified by a \ssrN{clear-switch} are deleted from the + context in step~\ref{enum:clr}, possibly in addition to {\term}. +\end{itemize} +For example, the tactic: +\begin{lstlisting} + move: n {2}n (refl_equal n). +\end{lstlisting} +\begin{itemize} +\item first generalizes \ssrC{(refl_equal n : n = n)}; +\item then generalizes the second occurrence of \ssrC{n}. +\item finally generalizes all the other occurrences of \ssrC{n}, + and clears \ssrC{n} from the proof context + (assuming \ssrC{n} is a proof constant). +\end{itemize} +Therefore this tactic changes any goal \ssrC{G} into +\begin{lstlisting} + forall n n0 : nat, n = n0 -> G. +\end{lstlisting} +where the name \ssrC{n0} is picked by the \Coq{} display function, +and assuming \ssrC{n} appeared only in~\ssrC{G}. + +Finally, note that a discharge operation generalizes defined constants +as variables, and not as local definitions. To override this behavior, +prefix the name of the local definition with a \ssrC{@}, +like in \ssrC{move: @n}. + +This is in contrast with the behavior of the \ssrC{in} tactical (see section +\ref{ssec:gloc}), which preserves local definitions by default. + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\subsubsection*{Clear rules} + +The clear step will fail if {\term} is a proof constant that +appears in other facts; in that case either the facts should be +cleared explicitly with a \ssrN{clear-switch}, or the clear step should be +disabled. The latter can be done by adding an \ssrN{occ-switch} or simply by +putting parentheses around {\term}: both +\begin{lstlisting} + move: (n). +\end{lstlisting} +and +\begin{lstlisting} + move: {+}n. +\end{lstlisting} +generalize \ssrC{n} without clearing \ssrC{n} from the proof context. + +The clear step will also fail if the \ssrN{clear-switch} contains a +\ssrN{ident} that is not in the \emph{proof} context. +Note that \ssr{} never clears a section constant. + +If {\tac} is \ssrC{move} or \ssrC{case} and an equation \ssrN{ident} is given, +then clear (step~\ref{enum:clr}) for $\ssrN[1]{d-item}$ is suppressed +(see section \ref{ssec:equations}). + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\subsubsection*{Matching for \ssrC{apply} and \ssrC{exact}}\label{sss:strongapply} + +The matching algorithm for \ssrN{d-item}s of the \ssr{} \ssrC{apply} and +\ssrC{exact} tactics +exploits the type of $\ssrN[1]{d-item}$ to interpret +wildcards in the other \ssrN{d-item} and to determine which occurrences of +these should be generalized. +Therefore, \ssrN{occur switch}es are not needed for \ssrC{apply} and \ssrC{exact}. + +Indeed, the \ssr{} tactic \ssrC{apply: H x} is equivalent to +\begin{lstlisting} + refine (@H _ ... _ x); clear H x +\end{lstlisting} +with an appropriate number of wildcards between \ssrC{H} and~\ssrC{x}. + +Note that this means that matching for \ssrC{apply} and \ssrC{exact} has +much more context to interpret wildcards; in particular it can accommodate +the `\ssrC{_}' \ssrN{d-item}, which would always be rejected after `\ssrC{move:}'. +For example, the tactic +\begin{lstlisting} + apply: trans_equal (Hfg _) _. +\end{lstlisting} +transforms the goal \ssrC{f a = g b}, whose context contains +\ssrC{(Hfg : forall x, f x = g x)}, into \ssrC{g a = g b}. +This tactic is equivalent (see section \ref{ssec:profstack}) to: +\begin{lstlisting} + refine (trans_equal (Hfg _) _). +\end{lstlisting} +and this is a common idiom for applying transitivity on the left hand side +of an equation. + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\subsubsection*{The \ssrC{abstract} tactic}\label{ssec:abstract} +\idx{abstract: \dots{}} + +The \ssrC{abstract} tactic assigns an abstract constant previously introduced with +the \ssrC{[: name ]} intro pattern (see section~\ref{ssec:intro}, +page~\pageref{ssec:introabstract}). +In a goal like the following: +\begin{lstlisting} + m : nat + abs : <hidden> + n : nat + ============= + m < 5 + n +\end{lstlisting} +The tactic \ssrC{abstract: abs n} first generalizes the goal with respect to +\ssrC{n} (that is not visible to the abstract constant \ssrC{abs}) and then +assigns \ssrC{abs}. The resulting goal is: +\begin{lstlisting} + m : nat + n : nat + ============= + m < 5 + n +\end{lstlisting} +Once this subgoal is closed, all other goals having \ssrC{abs} in their context +see the type assigned to \ssrC{abs}. In this case: +\begin{lstlisting} + m : nat + abs : forall n, m < 5 + n +\end{lstlisting} + +For a more detailed example the user should refer to section~\ref{sssec:have}, +page~\pageref{sec:havetransparent}. + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\subsection{Introduction}\label{ssec:intro} +\idx{\dots{} => \dots{}} + +The application of a tactic to a given goal can generate +(quantified) variables, assumptions, or definitions, which the user may want to +\emph{introduce} as new facts, constants or defined constants, respectively. +If the tactic splits the goal into several subgoals, +each of them may require the introduction of different constants and facts. +Furthermore it is very common to immediately decompose +or rewrite with an assumption instead of adding it to the context, +as the goal can often be simplified and even +proved after this. + +All these operations are performed by the introduction tactical +`\ssrC{=>}', whose general syntax is +\begin{center} + {\tac} \ssrC{=>} \ssrN[1]{i-item} $\dots$ \ssrN[n]{i-item} +\end{center} +where {\tac} can be any tactic, $n > 0$ and +\begin{longtable}{rcl} + \ssrN{i-item}& ::=& \ssrN{i-pattern} {\optsep} \ssrN{s-item} {\optsep} \ssrN{clear-switch} {\optsep} \ssrC{/}{\term} \\ + \ssrN{s-item}& ::=& \ssrC{/=} {\optsep} \ssrC{//} {\optsep} \ssrC{//=} \\ + \ssrN{i-pattern}& ::=& \ssrN{ident} {\optsep} \ssrC{_} {\optsep} \ssrC{?} {\optsep} \ssrC{*} {\optsep} \optional{\ssrN{occ-switch}}\ssrC{->} {\optsep} \optional{\ssrN{occ-switch}}\ssrC{<-} {\optsep} \\ + && \ssrC{[} \ssrN[1]{i-item}$^*$ \ssrC{|} $\dots$ \ssrC{|} \ssrN[m]{i-item}$^*$ \ssrC{]} {\optsep} \ssrC{-} {\optsep} \ssrC{[:} \ssrN{ident}$^+$ \ssrC{]} +\end{longtable} + +The `\ssrC{=>}' tactical first executes {\tac}, then the +\ssrN{i-item}s, left to right, i.e., starting from $\ssrN[1]{i-item}$. An +\ssrN{s-item} specifies a simplification operation; a $\ssrN{clear +switch}$ specifies context pruning as in~\ref{ssec:discharge}. The +\ssrN{i-pattern}s can be seen as a variant of \emph{intro patterns}~\ref{intros-pattern}: +each performs an introduction operation, i.e., pops some variables or +assumptions from the goal. + +An \ssrN{s-item} can simplify the set of subgoals or the subgoal themselves: +\begin{itemize} +\item \ssrC{//} removes all the ``trivial'' subgoals that can be resolved by + the \ssr{} tactic \ssrC{done} described in~\ref{ssec:termin}, i.e., it + executes \ssrC{try done}. +\item \ssrC{/=} simplifies the goal by performing partial evaluation, as + per the tactic \ssrC{simpl}.\footnote{Except \ssrC{/=} does not + expand the local definitions created by the \ssr{} \ssrC{in} tactical.} +\item \ssrC{//=} combines both kinds of simplification; it is equivalent + to \ssrC{/= //}, i.e., \ssrC{simpl; try done}. +\end{itemize} +When an \ssrN{s-item} bears a \ssrN{clear-switch}, then the \ssrN{clear-switch} is +executed \emph{after} the \ssrN{s-item}, e.g., \ssrL|{IHn}//| will solve +some subgoals, possibly using the fact \ssrL|IHn|, and will erase \ssrL|IHn| +from the context of the remaining subgoals. + +The last entry in the \ssrN{i-item} grammar rule, \ssrC{/}{\term}, +represents a view (see section~\ref{sec:views}). If $\ssrN[k+1]{i-item}$ +is a view \ssrN{i-item}, the view is applied to the assumption in top +position once $\ssrN[1]{i-item} \dots \ssrN[k]{i-item}$ have been performed. + +The view is applied to the top assumption. + +\ssr{} supports the following \ssrN{i-pattern}s: +\begin{itemize} +\item \ssrN{ident} pops the top variable, assumption, or local definition into + a new constant, fact, or defined constant \ssrN{ident}, respectively. + Note that defined constants cannot be introduced when + $\delta$-expansion is required to expose the top variable or assumption. +\item \ssrC{?} pops the top variable into an anonymous constant or fact, + whose name is picked by the tactic interpreter. + \ssr{} only generates names that + cannot appear later in the user script.\footnote{\ssr{} reserves + all identifiers of the form ``\ssrC{_x_}'', which is used for such + generated names.} +\item \ssrC{_} pops the top variable into an anonymous constant that will be + deleted from + the proof context of all the subgoals produced by the \ssrC{=>} tactical. + They should thus never be displayed, except in an error message + if the constant is still actually used in the goal or context after + the last \ssrN{i-item} has been executed (\ssrN{s-item}s can erase goals + or terms where the constant appears). +\item \ssrC{*} pops all the remaining apparent variables/assumptions + as anonymous constants/facts. Unlike \ssrC{?} and \ssrC{move} the \ssrC{*} + \ssrN{i-item} does not expand definitions in the goal to expose + quantifiers, so it may be useful to repeat a \ssrC{move=> *} tactic, + e.g., on the goal +\begin{lstlisting} + forall a b : bool, a <> b +\end{lstlisting} +a first \ssrC{move=> *} adds only \ssrC{_a_ : bool} and \ssrC{_b_ : bool} to +the context; it takes a second \ssrC{move=> *} to add +\ssrC{_Hyp_ : _a_ = _b_}. +\item $[\ssrN{occ-switch}]$\ssrC{->} (resp. $[\ssrN{occ-switch}]$\ssrC{<-}) + pops the top assumption + (which should be a rewritable proposition) into an anonymous fact, + rewrites (resp. rewrites right to left) the goal with this fact + (using the \ssr{} \ssrC{rewrite} tactic described in section~\ref{sec:rw}, + and honoring the optional occurrence selector), + and finally deletes the anonymous fact from the context. +\item\ssrC{[ $\ssrN[1]{i-item}^*$ | $\dots$ | $\ssrN[m]{i-item}^*$ ]}, + when it is the very \emph{first} \ssrN{i-pattern} after ${\tac}\;\ssrC{=>}$ + tactical \emph{and} {\tac} is not a \ssrC{move}, is a \emph{branching} + \ssrN{i-pattern}. It executes + the sequence $\ssrN[i]{i-item}^*$ on the $i^{\rm th}$ + subgoal produced by {\tac}. The execution of {\tac} + should thus generate exactly $m$ + subgoals, unless the \ssrC{[$\dots$]} \ssrN{i-pattern} comes after an initial + \ssrC{//} or \ssrC{//=} \ssrN{s-item} that closes some of the goals produced by + {\tac}, in which case exactly $m$ subgoals should remain after the + \ssrN{s-item}, or we have the trivial branching \ssrN{i-pattern} \ssrC{[]}, + which always does nothing, regardless of the number of remaining subgoals. +\item\ssrC{[ $\ssrN[1]{i-item}^*$ | $\dots$ | $\ssrN[m]{i-item}^*$ ]}, when it is + \emph{not} the first \ssrN{i-pattern} or when {\tac} is a + \ssrC{move}, is a \emph{destructing} \ssrN{i-pattern}. It starts by + destructing the top variable, using the \ssr{} \ssrC{case} tactic + described in~\ref{ssec:basictac}. It then behaves as the + corresponding branching \ssrN{i-pattern}, executing the sequence + $\ssrN[i]{i-item}^*$ in the $i^{\rm th}$ subgoal generated by the case + analysis; unless we have the trivial destructing \ssrN{i-pattern} + \ssrC{[]}, the latter should generate exactly $m$ subgoals, i.e., the + top variable should have an inductive type with exactly $m$ + constructors.\footnote{More precisely, it should have a quantified + inductive type with $a$ assumptions and $m - a$ constructors.} + While it is good style to use the $\ssrN[i]{i-item}^*$ + to pop the variables and assumptions corresponding to each constructor, + this is not enforced by \ssr{}. +\item\ssrC{-} does nothing, but counts as an intro pattern. It can also + be used to force the interpretation of + \ssrC{[ $\ssrN[1]{i-item}^*$ | $\dots$ | $\ssrN[m]{i-item}^*$ ]} + as a case analysis like in \ssrC{move=> -[H1 H2]}. It can also be used + to indicate explicitly the link between a view and a name like in + \ssrC{move=> /eqP-H1}. Last, it can serve as a separator between + views. Section~\ref{ssec:multiview} explains in which respect + the tactic \ssrC{move=> /v1/v2} differs from the tactic + \ssrC{move=> /v1-/v2}. +\item\ssrC{[: $\ssrN{ident}^+$ ]} introduces in the context an abstract constant + for each \ssrN{ident}. Its type has to be fixed later on by using + the \ssrC{abstract} tactic (see page~\pageref{ssec:abstract}). Before then + the type displayed is \ssrC{<hidden>}.\label{ssec:introabstract} +\end{itemize} +Note that \ssr{} does not support the syntax +$\ssrC{(}\ssrN{ipat}\ssrC{,}\dots\ssrC{,}\ssrN{ipat}\ssrC{)}$ for destructing +intro-patterns. + +Clears are deferred until the end of the intro pattern. For +example, given the goal: +\begin{lstlisting} +x, y : nat +================== +0 < x = true -> (0 < x) && (y < 2) = true +\end{lstlisting} +the tactic \ssrC{move=> \{x\} ->} successfully rewrites the goal and +deletes \ssrC{x} and the anonymous equation. The goal is thus turned into: +\begin{lstlisting} +y : nat +================== +true && (y < 2) = true +\end{lstlisting} +If the cleared names are reused in the same intro pattern, a renaming +is performed behind the scenes. + +Facts mentioned in a clear switch must be valid +names in the proof context (excluding the section context). + +The rules for interpreting branching and destructing \ssrN{i-pattern} +are motivated by the fact that it would be pointless to have a branching +pattern if {\tac} is a \ssrC{move}, and in most of the remaining cases +{\tac} is \ssrC{case} or \ssrC{elim}, which implies destruction. +The rules above imply that +\begin{lstlisting} + move=> [a b]. + case=> [a b]. + case=> a b. +\end{lstlisting} +are all equivalent, so which one to use is a matter of style; +\ssrC{move} should be used for casual decomposition, +such as splitting a pair, and \ssrC{case} should be used for actual decompositions, +in particular for type families (see~\ref{ssec:typefam}) +and proof by contradiction. + +The trivial branching \ssrN{i-pattern} can be used to force the branching +interpretation, e.g., +\begin{lstlisting} + case=> [] [a b] c. + move=> [[a b] c]. + case; case=> a b c. +\end{lstlisting} +are all equivalent. + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\subsection{Generation of equations}\label{ssec:equations} +\idx{move eq : \dots{}} + +The generation of named equations option stores the definition of a +new constant as an equation. The tactic: +\begin{lstlisting} + move En: (size l) => n. +\end{lstlisting} +where \ssrC{l} is a list, replaces \ssrC{size l} by \ssrC{n} in the goal and +adds the fact \ssrC{En : size l = n} to the context. + This is quite different from: +\begin{lstlisting} + pose n := (size l). +\end{lstlisting} +which generates a definition \ssrC{n := (size l)}. It is not possible to +generalize or +rewrite such a definition; on the other hand, it is automatically +expanded during +computation, whereas expanding the equation \ssrC{En} requires explicit +rewriting. + +The use of this equation name generation option with a \ssrC{case} or an +\ssrC{elim} tactic changes the status of the first \iitem{}, in order to +deal with the possible parameters of the constants introduced. + +On the +goal \ssrC{a <> b} where \ssrC{a, b} are natural numbers, the tactic: +\begin{lstlisting} + case E : a => [|n]. +\end{lstlisting} +generates two subgoals. The equation \ssrC{E : a = 0} (resp. \ssrC{E : a = + S n}, and the constant \ssrC{n : nat}) has been added to +the context of the goal \ssrC{0 <> b} (resp. \ssrC{S n <> b}). + +If the user does not provide a branching \iitem{} as first \iitem{}, +or if the \iitem{} does not provide enough names for the arguments of +a constructor, +then the constants generated are introduced under fresh \ssr{} names. +For instance, on the goal \ssrC{a <> b}, the tactic: +\begin{lstlisting} + case E : a => H. +\end{lstlisting} +also generates two subgoals, both requiring a proof of \ssrC{False}. + The hypotheses \ssrC{E : a = 0} and +\ssrC{H : 0 = b} (resp. \ssrC{E : a = S _n_} and +\ssrC{H : S _n_ = b}) have been added to the context of the first +subgoal (resp. the second subgoal). + +Combining the generation of named equations mechanism with the +\ssrC{case} tactic strengthens the power of a case analysis. On the other +hand, when combined with the \ssrC{elim} tactic, this feature is mostly +useful for +debug purposes, to trace the values of decomposed parameters and +pinpoint failing branches. + +% This feature is also useful +% to analyse and debug generate-and-test style scripts that prove program +% properties by generating a large set of input patterns and uniformly +% solving the corresponding subgoals by computation and rewriting, e.g, + +% \begin{lstlisting} +% case: et => [|e' et]; first by case: s. +% case: e => //; case: b; case: w. +% \end{lstlisting} +% If the above sequence fails, then it's easy enough to replace the line +% above with +% \begin{lstlisting} +% case: et => [|e' et]. +% case Ds: s; case De: e => //; case Db: b; case Dw: w=> [|s' w'] //=. +% \end{lstlisting} +% Then the first subgoal that appears will be the failing one, and the +% equations \ssrC{Ds}, \ssrC{De}, \ssrC{Db} +% and \ssrC{Dw} will pinpoint its branch. When the constructors of +% the decomposed type have arguments (like \ssrC{w : (seq nat)} +% above) these need to be +% introduced in order to generate the equation, so there should +% always be an explicit \iitem{} (\ssrC{\[|s' w'\]} above) that +% assigns names to these arguments. If this \iitem{} +% is omitted the arguments are introduced with default +% name; this +% feature should be +% avoided except for quick debugging runs (it has some uses in complex tactic +% sequences, however). + + + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\subsection{Type families}\label{ssec:typefam} +\idx{case: \dots{} / \dots{}} + +When the top assumption of a goal has an inductive type, two +specific operations are possible: the case analysis performed by the +\ssrC{case} tactic, and the application of an induction principle, +performed by the \ssrC{elim} tactic. When this top assumption has an +inductive type, which is moreover an instance of a type family, \Coq{} +may need help from the user to specify which occurrences of the parameters +of the type should be substituted. + +A specific \ssrC{/} switch indicates the type family parameters of the +type of a \ditem{} immediately following this \ssrC{/} switch, using the +syntax: + +\begin{center} + \ssrC{[} \ssrC{case} {\optsep} \ssrC{elim} \ssrC{]:} \ssrN{d-item}$^+$ \ssrC{/} \ssrN{d-item}$^*$ +\end{center} + +The \ssrN{d-item}s on the right side of the \ssrC{/} switch are discharged +as described in section \ref{ssec:discharge}. The case analysis or +elimination will be done on the type of the top assumption after these +discharge operations. + +Every \ssrN{d-item} preceding the \ssrC{/} is interpreted as arguments of this +type, which should be an instance of an inductive type family. These terms are +not actually generalized, but rather selected for substitution. Occurrence +switches can be used to restrict the substitution. If a {\term} is left +completely implicit (e.g. writing just $\ssrC{\_}$), then a pattern is inferred +looking at the type of the top assumption. This allows for the compact syntax +\ssrC{case: \{2\}\_ / eqP}, were \ssrC{\_} is interpreted as \ssrC{(\_ == \_)}. Moreover +if the \ssrN{d-item}s list is too short, it is padded with an initial +sequence of $\ssrC{\_}$ of the right length. + +Here is a small example on lists. We define first a function which +adds an element at the end of a given list. +\begin{lstlisting} + Require Import List. + + Section LastCases. + Variable A : Type. + + Fixpoint |*add_last*|(a : A)(l : list A): list A := + match l with + |nil => a :: nil + |hd :: tl => hd :: (add_last a tl) + end. +\end{lstlisting} +Then we define an inductive predicate for +case analysis on lists according to their last element: +\begin{lstlisting} + Inductive |*last_spec*| : list A -> Type := + | LastSeq0 : last_spec nil + | LastAdd s x : last_spec (add_last x s). + + Theorem |*lastP*| : forall l : list A, last_spec l. +\end{lstlisting} +Applied to the goal: +\begin{lstlisting} + Goal forall l : list A, (length l) * 2 = length (app l l). +\end{lstlisting} +the command: +\begin{lstlisting} + move=> l; case: (lastP l). +\end{lstlisting} +generates two subgoals: +\begin{lstlisting} + length nil * 2 = length (nil ++ nil) +\end{lstlisting} +and +\begin{lstlisting} + forall (s : list A) (x : A), + length (add_last x s) * 2 = length (add_last x s ++ add_last x s) +\end{lstlisting} +both having \ssrC{l : list A} in their context. + +Applied to the same goal, the command: +\begin{lstlisting} + move=> l; case: l / (lastP l). +\end{lstlisting} +generates the same subgoals but \ssrC{l} has been cleared from both +contexts. + +Again applied to the same goal, the command: +\begin{lstlisting} + move=> l; case: {1 3}l / (lastP l). +\end{lstlisting} +generates the subgoals \ssrL-length l * 2 = length (nil ++ l)- and +\ssrL-forall (s : list A) (x : A), length l * 2 = length (add_last x s++l)- +where the selected occurrences on the left of the \ssrC{/} switch have +been substituted with \ssrC{l} instead of being affected by the case +analysis. + +The equation name generation feature combined with a type family \ssrC{/} + switch generates an equation for the \emph{first} dependent d-item +specified by the user. +Again starting with the above goal, the command: +\begin{lstlisting} + move=> l; case E: {1 3}l / (lastP l)=>[|s x]. +\end{lstlisting} +adds \ssrC{E : l = nil} and \ssrC{E : l = add_last x s}, +respectively, to the context of the two subgoals it generates. + +There must be at least one \emph{d-item} to the left of the \ssrC{/} +switch; this prevents any +confusion with the view feature. However, the \ditem{}s to the right of +the \ssrC{/} are optional, and if they are omitted the first assumption +provides the instance of the type family. + +The equation always refers to the first \emph{d-item} in the actual +tactic call, before any padding with initial $\ssrC{\_}$s. Thus, if an +inductive type has two family parameters, it is possible to have +\ssr{} generate an equation for the second one by omitting the pattern +for the first; note however that this will fail if the type of the +second parameter depends on the value of the first parameter. +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\section{Control flow} +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\subsection{Indentation and bullets}\label{ssec:indent} + +A linear development of \Coq{} scripts gives little information on +the structure of the proof. In addition, replaying a proof after some +changes in the statement to be proved will usually not display information to +distinguish between the various branches of case analysis for instance. + +To help the user in this organization of the proof script at +development time, \ssr{} provides some bullets to highlight the +structure of branching proofs. The available bullets are \ssrC{-}, +\ssrC{+} and \ssrC{*}. Combined with tabulation, this lets us highlight four +nested levels of branching; the most we have ever +needed is three. Indeed, the use of ``simpl and closing'' switches, of +terminators (see above section \ref{ssec:termin}) and selectors (see + section \ref{ssec:select}) is powerful enough +to avoid most of the time more than two levels of indentation. + +Here is a fragment of such a structured script: + +\begin{lstlisting} +case E1: (abezoutn _ _) => [[| k1] [| k2]]. +- rewrite !muln0 !gexpn0 mulg1 => H1. + move/eqP: (sym_equal F0); rewrite -H1 orderg1 eqn_mul1. + by case/andP; move/eqP. +- rewrite muln0 gexpn0 mulg1 => H1. + have F1: t %| t * S k2.+1 - 1. + apply: (@dvdn_trans (orderg x)); first by rewrite F0; exact: dvdn_mull. + rewrite orderg_dvd; apply/eqP; apply: (mulgI x). + rewrite -{1}(gexpn1 x) mulg1 gexpn_add leq_add_sub //. + by move: P1; case t. + rewrite dvdn_subr in F1; last by exact: dvdn_mulr. + + rewrite H1 F0 -{2}(muln1 (p ^ l)); congr (_ * _). + by apply/eqP; rewrite -dvdn1. + + by move: P1; case: (t) => [| [| s1]]. +- rewrite muln0 gexpn0 mul1g => H1. +... +\end{lstlisting} + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\subsection{Terminators}\label{ssec:termin} +\idx{by \dots{}} + +To further structure scripts, \ssr{} +supplies \emph{terminating} tacticals to explicitly close off tactics. +When replaying scripts, we then have the nice property that +an error immediately occurs when a closed tactic fails to prove its +subgoal. + +It is hence recommended practice that the proof of any subgoal should +end with a tactic which \emph{fails if it does not solve the current + goal}, like \ssrC{discriminate}, \ssrC{contradiction} or \ssrC{assumption}. + +In fact, \ssr{} provides a generic tactical which turns any tactic into +a closing one (similar to \ssrC{now}). Its general syntax is: + +\begin{center} + \ssrC{by} {\tac}\ssrC{.} +\end{center} + +The Ltac expression: + +\begin{center} + \ssrC{by [}\ssrN[1]{tactic} \ssrC{| [}\ssrN[2]{tactic} \ssrC{| ...].} +\end{center} + +is equivalent to: + +\begin{center} + \ssrC{[by} \ssrN[1]{tactic} \ssrC{| by} \ssrN[2]{tactic} \ssrC{| ...].} +\end{center} + +and this form should be preferred to the former. + +In the script provided as example in section \ref{ssec:indent}, the +paragraph corresponding to each sub-case ends with a tactic line prefixed +with a \ssrC{by}, like in: + +\begin{center} + \ssrC{by apply/eqP; rewrite -dvdn1.} +\end{center} + + +The \ssrC{by} tactical is implemented using the user-defined, +and extensible \ssrC{done} tactic. This \ssrC{done} tactic tries to solve +the current goal by some trivial means and fails if it doesn't succeed. +Indeed, the tactic expression: + +\begin{center} + \ssrC{by} {\tac}\ssrC{.} +\end{center} + +is equivalent to: + +\begin{center} + {\tac}\ssrC{; done.} +\end{center} + +Conversely, the tactic + +\begin{center} + \ssrC{by [ ].} +\end{center} + +is equivalent to: + +\begin{center} + \ssrC{done.} +\end{center} + +The default implementation of the \ssrC{done} tactic, in the {\tt + ssreflect.v} file, is: + +\begin{lstlisting} +Ltac done := + trivial; hnf; intros; solve + [ do ![solve [trivial | apply: sym_equal; trivial] + | discriminate | contradiction | split] + | case not_locked_false_eq_true; assumption + | match goal with H : ~ _ |- _ => solve [case H; trivial] end ]. +\end{lstlisting} + +The lemma \ssrC{|*not_locked_false_eq_true*|} is needed to discriminate +\emph{locked} boolean predicates (see section \ref{ssec:lock}). +The iterator tactical \ssrC{do} is presented in section +\ref{ssec:iter}. +This tactic can be customized by the user, for instance to include an +\ssrC{auto} tactic. + +A natural and common way of closing a goal is to apply a lemma which +is the \ssrC{exact} one needed for the goal to be solved. The defective +form of the tactic: +\begin{lstlisting} + exact. +\end{lstlisting} +is equivalent to: +\begin{lstlisting} + do [done | by move=> top; apply top]. +\end{lstlisting} +where \ssrC{top} is a fresh name affected to the top assumption of the goal. +This applied form is supported by the \ssrC{:} discharge tactical, and +the tactic: +\begin{lstlisting} + exact: MyLemma. +\end{lstlisting} +is equivalent to: +\begin{lstlisting} + by apply: MyLemma. +\end{lstlisting} +(see section \ref{sss:strongapply} for the documentation of the \ssrC{apply:} +combination). + +\textit{Warning} The list of tactics, possibly chained by +semi-columns, that follows a \ssrC{by} keyword is considered as a +parenthesized block +applied to the current goal. Hence for example if the tactic: +\begin{lstlisting} + by rewrite my_lemma1. +\end{lstlisting} +succeeds, then the tactic: +\begin{lstlisting} + by rewrite my_lemma1; apply my_lemma2. +\end{lstlisting} +usually fails since it is equivalent to: +\begin{lstlisting} + by (rewrite my_lemma1; apply my_lemma2). +\end{lstlisting} + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\subsection{Selectors}\label{ssec:select} +\idx{last \dots{} first} +\idx{first \dots{} last} + +When composing tactics, the two tacticals \ssrC{first} and +\ssrC{last} let the user restrict the application of a tactic to only one +of the subgoals generated by the previous tactic. This +covers the frequent cases where a tactic generates two subgoals one of +which can be easily disposed of. + +This is an other powerful way of linearization of scripts, since it +happens very often that a trivial subgoal can be solved in a less than +one line tactic. For instance, the tactic: + +\begin{center} + \ssrN[1]{tactic}\ssrC{; last by} \ssrN[2]{tactic}\ssrC{.} +\end{center} + +tries to solve the last subgoal generated by \ssrN[1]{tactic} using the +\ssrN[2]{tactic}, and fails if it does not succeeds. Its analogous + +\begin{center} + \ssrN[1]{tactic}\ssrC{; first by} \ssrN[2]{tactic}. +\end{center} + +tries to solve the first subgoal generated by \ssrN[1]{tactic} using the +tactic \ssrN[2]{tactic}, and fails if it does not succeeds. + + +\ssr{} also offers an extension of this facility, by supplying +tactics to \emph{permute} the subgoals generated by a tactic. +The tactic: + +\begin{center} + {\tac}\ssrC{; last first.} +\end{center} + +inverts the order of the subgoals generated by {\tac}. It is +equivalent to: + +\begin{center} + {\tac}\ssrC{; first last.} +\end{center} + + +More generally, the tactic: + +\begin{center} + {\tac}\ssrC{; last }${\naturalnumber}$ \ssrC{first.} +\end{center} + +where ${\naturalnumber}$ is +a \Coq{} numeral, or and Ltac variable denoting +a \Coq{} numeral, having the value $k$. It +rotates the $n$ subgoals $G_1, +\dots, G_n$ generated by {\tac}. The first subgoal becomes +$G_{n + 1 - k}$ and the circular order of subgoals remains unchanged. + +Conversely, the tactic: + + {\tac}\ssrC{; first }${\naturalnumber}$ \ssrC{last.} + +rotates the $n$ subgoals $G_1, +\dots, G_n$ generated by \ssrC{tactic} in order that the first subgoal +becomes $G_{k}$. + +Finally, the tactics \ssrC{last} and \ssrC{first} combine with the +branching syntax of Ltac: +if the tactic $\ssrN[0]{tactic}$ generates $n$ +subgoals on a given goal, then the tactic + + $tactic_0$\ssrC{; last }${\naturalnumber}$ \ssrC{[}$tactic_1$\ssrC{|}$\dots$\ssrC{|}$tactic_m$\ssrC{] || }$tactic_{m+1}$\ssrC{.} + +where ${\naturalnumber}$ denotes the integer $k$ as above, applies $tactic_1$ to the +$n -k + 1$-th goal, $\dots tactic_m$ to the $n -k + 2 - m$-th +goal and $tactic_{m+1}$ to the others. + +For instance, the script: +\begin{lstlisting} + Inductive test : nat -> Prop := + C1 : forall n, test n | C2 : forall n, test n | + C3 : forall n, test n | C4 : forall n, test n. + + Goal forall n, test n -> True. + move=> n t; case: t; last 2 [move=> k| move=> l]; idtac. +\end{lstlisting} + +creates a goal with four subgoals, the first and the last being +\ssrC{nat -> True}, the second and the third being \ssrC{True} with +respectively \ssrC{k : nat} and \ssrC{l : nat} in their context. + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\subsection{Iteration}\label{ssec:iter} +\idx{do \dots{} [ \dots{} ]} + +\ssr{} offers an accurate control on the repetition of +tactics, thanks to the \ssrC{do} tactical, whose general syntax is: + +\begin{center} + \ssrC{do} \optional{\ssrN{mult}} \ssrC{[} \ssrN[1]{tactic} \ssrC{|} $\dots$ \ssrC{|} \ssrN[n]{tactic} \ssrC{]} +\end{center} +where \ssrN{mult} is a \emph{multiplier}. + +Brackets can only be omitted if a single tactic is given \emph{and} a +multiplier is present. + +A tactic of the form: + +\begin{center} + \ssrC{do [} \tac$_1$ \ssrC{|} $\dots$ \ssrC{|} \tac$_n$\ssrC{].} +\end{center} + +is equivalent to the standard Ltac expression: + +\begin{center} + \ssrC{first [} \tac$_1$ \ssrC{|} $\dots$ \ssrC{|} \tac$_n$\ssrC{].} +\end{center} + + +The optional multiplier \ssrN{mult} specifies how many times +the action of {\tac} should be repeated on the current subgoal. + +There are four kinds of multipliers: + \begin{itemize} + \item \ssrC{n!}: the step {\tac} is repeated exactly $n$ times + (where $n$ is a positive integer argument). + \item \ssrC{!}: the step {\tac} is repeated as many times as possible, + and done at least once. + \item \ssrC{?}: the step {\tac} is repeated as many times as possible, + optionally. + \item \ssrC{n?}: the step {\tac} is repeated up to $n$ times, + optionally. + \end{itemize} + +For instance, the tactic: + +\begin{center} + {\tac} \ssrL+; do 1?rewrite mult_comm.+ +\end{center} + +rewrites at most one time the lemma \ssrC{mult_com} in all the subgoals +generated by {\tac} , whereas the tactic: + +\begin{center} + {\tac} \ssrL+; do 2!rewrite mult_comm.+ +\end{center} + +rewrites exactly two times the lemma \ssrC{mult_com} in all the subgoals +generated by {\tac}, and fails if this rewrite is not possible +in some subgoal. + +Note that the combination of multipliers and \ssrC{rewrite} is so often +used that multipliers are in fact integrated to the syntax of the \ssr{} +\ssrC{rewrite} tactic, see section \ref{sec:rw}. + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\subsection{Localization}\label{ssec:gloc} +\idx{\dots{} in \dots{}} + +In sections \ref{ssec:loc} and \ref{ssec:profstack}, we have already +presented the \emph{localization} tactical \ssrC{in}, whose general +syntax is: +\begin{center} + {\tac} \ssrC{in} \ssrN{ident}$^+$ \optional{\ssrC{*}} +\end{center} + +where \ssrN{ident}$^+$ is a non empty list of fact +names in the context. On the left side of \ssrC{in}, {\tac} can be +\ssrC{move}, \ssrC{case}, \ssrC{elim}, \ssrC{rewrite}, \ssrC{set}, + or any tactic formed with the general iteration tactical \ssrC{do} (see + section \ref{ssec:iter}). + +The operation described by {\tac} is performed in the facts +listed in \ssrN{ident}$^+$ and in the goal if a \ssrC{*} ends +the list. + +The \ssrC{in} tactical successively: +\begin{itemize} +\item generalizes the selected hypotheses, possibly ``protecting'' the + goal if \ssrC{*} is not present, +\item performs {\tac}, on the obtained goal, +\item reintroduces the generalized facts, under the same names. +\end{itemize} + +This defective form of the \ssrC{do} tactical is useful to avoid clashes +between standard Ltac \ssrC{in} and the \ssr{} tactical \ssrC{in}. +For example, in the following script: +\begin{lstlisting} + Ltac |*mytac*| H := rewrite H. + + Goal forall x y, x = y -> y = 3 -> x + y = 6. + move=> x y H1 H2. + do [mytac H2] in H1 *. +\end{lstlisting} +the last tactic rewrites the hypothesis \ssrC{H2 : y = 3} both in +\ssrC{H1 : x = y} and in the goal \ssrC{x + y = 6}. + +By default \ssrC{in} keeps the body of local definitions. To erase +the body of a local definition during the generalization phase, +the name of the local definition must be written between parentheses, +like in \ssrC{rewrite H in H1 (def_n) $\;\;$H2}. + +From \ssr{} 1.5 the grammar for the \ssrC{in} tactical has been extended +to the following one: + +\begin{center} + {\tac} \ssrC{in} \optional{ + \ssrN{clear-switch} {\optsep} + \optional{\ssrC{@}}\ssrN{ident} {\optsep} + \ssrC{(}\ssrN{ident}\ssrC{)} {\optsep} + \ssrC{(}\optional{\ssrC{@}}\ssrN{ident} \ssrC{:=} \ssrN{c-pattern}\ssrC{)} + }$^+$ \optional{\ssrC{*}} +\end{center} + +In its simplest form the last option lets one rename hypotheses that can't be +cleared (like section variables). For example \ssrC{(y := x)} generalizes +over \ssrC{x} and reintroduces the generalized +variable under the name \ssrC{y} (and does not clear \ssrC{x}).\\ +For a more precise description the $\ssrC{(}[\ssrC{@}]\ssrN{ident}\ \ssrC{:=}\ \ssrN{c-pattern}\ssrC{)}$ +item refer to the ``Advanced generalization'' paragraph at page~\pageref{par:advancedgen}. + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\subsection{Structure}\label{ssec:struct} + +Forward reasoning structures the script by explicitly specifying some +assumptions to be added to the proof context. It is closely associated +with the declarative style of proof, since an extensive use of these +highlighted statements +make the script closer to a (very detailed) text book proof. + +Forward chaining tactics allow to state an intermediate lemma and start a +piece of script dedicated to the proof of this statement. The use of +closing tactics (see section \ref{ssec:termin}) and of +indentation makes syntactically explicit the portion of the script +building the proof of the intermediate statement. + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\subsubsection*{The \ssrC{have} tactic.} +\label{sssec:have} +\idx{have: \dots{}} +\idx{have: \dots{} := \dots{}} + +The main \ssr{} forward reasoning tactic is the \ssrC{have} tactic. It +can be use in two modes: one starts a new (sub)proof for an +intermediate result in the main proof, and the other +provides explicitly a proof term for this intermediate step. + +In the first mode, the syntax of \ssrC{have} in its defective form is: + + \ssrC{have: }{\term}\ssrC{.} + +This tactic supports open syntax for {\term}. +Applied to a goal \ssrC{G}, it generates a first subgoal requiring a +proof of {\term} in the context of \ssrC{G}. The second generated +subgoal is of the form {\term} \ssrC{-> G}, where {\term} becomes +the new top assumption, instead of being introduced with a fresh +name. At the proof-term level, the \ssrC{have} tactic creates a $\beta$ +redex, and introduces the lemma under a fresh name, automatically +chosen. + + +Like in the case of the \ssrC{pose} tactic (see section \ref{ssec:pose}), +the types of the holes are abstracted in {\term}. +For instance, the tactic: +\begin{lstlisting} + have: _ * 0 = 0. +\end{lstlisting} +is equivalent to: +\begin{lstlisting} + have: forall n : nat, n * 0 = 0. +\end{lstlisting} +The \ssrC{have} tactic also enjoys the same abstraction mechanism as the +\ssrC{pose} tactic for the non-inferred implicit arguments. For instance, +the tactic: +\begin{lstlisting} + have: forall x y, (x, y) = (x, y + 0). +\end{lstlisting} +opens a new subgoal to prove that: + +\noindent\ssrC{forall (T : Type) (x : T) (y : nat), (x, y) = (x, y + 0)} + + +The behavior of the defective \ssrC{have} tactic makes it possible to +generalize it in the +following general construction: +\begin{center} + \ssrC{have} \ssrN{i-item}$^*$ \optional{\ssrN{i-pattern}} + \optional{\ssrN{s-item} {\optsep} \ssrN{binder}$^+$} + \optional{\ssrC{:} \ssrN[1]{term}} + \optional{\ssrC{:=} \ssrN[2]{term} {\optsep} \ssrC{by} {\tac}} +\end{center} + +Open syntax is supported for $\ssrN[1]{term}$ and $\ssrN[2]{term}$. For the +description of +\iitem{}s and clear switches see section \ref{ssec:intro}. +The first mode of the \ssrC{have} tactic, which opens a sub-proof for an +intermediate result, uses tactics of the form: + +\begin{center} + \ssrC{have} \ssrN{clear-switch} \ssrN{i-item} \ssrC{:} {\term} \ssrC{by} {\tac}. +\end{center} + +which behave like:\\ + +\begin{center} + \ssrC{have:} {\term} \ssrC{; first by } {\tac}. +\end{center} +\begin{center} + \ssrC{ move=>} \ssrN{clear-switch} \ssrN{i-item}. +\end{center} + + +Note that the \ssrN{clear-switch} \emph{precedes} the +\ssrN{i-item}, which allows to reuse a name of the context, possibly used +by the proof of the assumption, to introduce the new assumption +itself. + +The \ssrC{by} feature is especially convenient when the proof script of the +statement is very short, basically when it fits in one line like in: +\begin{lstlisting} + have H : forall x y, x + y = y + x by move=> x y; rewrite addnC. +\end{lstlisting} + +The possibility of using \iitem{}s supplies a very concise +syntax for the further use of the intermediate step. For instance, +\begin{lstlisting} + have -> : forall x, x * a = a. +\end{lstlisting} +on a goal \ssrC{G}, opens a new subgoal asking for a proof of +\ssrC{forall x, x * a = a}, and a second subgoal in which the lemma + \ssrC{forall x, x * a = a} has been rewritten in the goal \ssrC{G}. Note + that in this last subgoal, the intermediate result does not appear in + the context. +Note that, thanks to the deferred execution of clears, the following +idiom is supported (assuming \ssrC{x} occurs in the goal only): +\begin{lstlisting} + have {x} -> : x = y +\end{lstlisting} + +An other frequent use of the intro patterns combined with \ssrC{have} is the +destruction of existential assumptions like in the tactic: +\begin{lstlisting} + have [x Px]: exists x : nat, x > 0. +\end{lstlisting} +which opens a new subgoal asking for a proof of \ssrC{exists x : nat, x > + 0} and a second subgoal in which the witness is introduced under +the name \ssrC{x : nat}, and its property under the name \ssrC{Px : x > 0}. + +An alternative use of the \ssrC{have} tactic is to provide the explicit proof +term for the intermediate lemma, using tactics of the form: + +\begin{center} + \ssrC{have} \optional{\ssrN{ident}} \ssrC{:=} {\term}. +\end{center} + +This tactic creates a new assumption of type the type of +{\term}. If the +optional \ssrN{ident} is present, this assumption is introduced under +the name \ssrN{ident}. Note that the body of the constant is lost for +the user. + +Again, non inferred implicit arguments and explicit holes are abstracted. For +instance, the tactic: +\begin{lstlisting} + have H := forall x, (x, x) = (x, x). +\end{lstlisting} +adds to the context \ssrC{H : Type -> Prop}. This is a schematic example but +the feature is specially useful when the proof term to give involves +for instance a lemma with some hidden implicit arguments. + +After the \ssrN{i-pattern}, a list of binders is allowed. +For example, if \ssrC{Pos_to_P} is a lemma that proves that +\ssrC{P} holds for any positive, the following command: +\begin{lstlisting} + have H x (y : nat) : 2 * x + y = x + x + y by auto. +\end{lstlisting} +will put in the context \ssrC{H : forall x, 2 * x = x + x}. A proof term +provided after \ssrC{:=} can mention these bound variables (that are +automatically introduced with the given names). +Since the \ssrN{i-pattern} can be omitted, to avoid ambiguity, bound variables +can be surrounded with parentheses even if no type is specified: +\begin{lstlisting} + have (x) : 2 * x = x + x by auto. +\end{lstlisting} + +The \ssrN{i-item}s and \ssrN{s-item} can be used to interpret the +asserted hypothesis with views (see section~\ref{sec:views}) or +simplify the resulting goals. + +The \ssrC{have} tactic also supports a \ssrC{suff} modifier which allows for +asserting that a given statement implies the current goal without +copying the goal itself. For example, given a goal \ssrC{G} the tactic +\ssrC{have suff H : P} results in the following two goals: +\begin{lstlisting} + |- P -> G + H : P -> G |- G +\end{lstlisting} +Note that \ssrC{H} is introduced in the second goal. The \ssrC{suff} +modifier is not compatible with the presence of a list of binders. + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\subsubsection*{Generating \ssrC{let in} context entries with \ssrC{have}} +\label{sec:havetransparent} + +Since \ssr{} 1.5 the \ssrC{have} tactic supports a ``transparent'' modifier to +generate \ssrC{let in} context entries: the \ssrC{@} symbol in front of the context +entry name. For example: + +\begin{lstlisting} +have @i : 'I_n by apply: (Sub m); auto. +\end{lstlisting} +generates the following two context entry: +\begin{lstlisting} +i := Sub m proof_produced_by_auto : 'I_n +\end{lstlisting} + +Note that the sub-term produced by \ssrC{auto} is in general huge and +uninteresting, and hence one may want to hide it. + +For this purpose the \ssrC{[: name ]} intro pattern and the tactic +\ssrC{abstract} (see page~\pageref{ssec:abstract}) are provided. +Example: +\begin{lstlisting} +have [:blurb] @i : 'I_n by apply: (Sub m); abstract: blurb; auto. +\end{lstlisting} +generates the following two context entries: +\begin{lstlisting} +blurb : (m < n) (*1*) +i := Sub m blurb : 'I_n +\end{lstlisting} +The type of \ssrC{blurb} can be cleaned up by its annotations by just simplifying +it. The annotations are there for technical reasons only. + +When intro patterns for abstract constants are used in conjunction +with \ssrC{have} and an explicit term, they must be used as follows: + +\begin{lstlisting} +have [:blurb] @i : 'I_n := Sub m blurb. + by auto. +\end{lstlisting} + +In this case the abstract constant \ssrC{blurb} is assigned by using it +in the term that follows \ssrC{:=} and its corresponding goal is left to +be solved. Goals corresponding to intro patterns for abstract constants +are opened in the order in which the abstract constants are declared (not +in the ``order'' in which they are used in the term). + +Note that abstract constants do respect scopes. Hence, if a variable +is declared after their introduction, it has to be properly generalized (i.e. +explicitly passed to the abstract constant when one makes use of it). +For example any of the following two lines: +\begin{lstlisting} +have [:blurb] @i k : 'I_(n+k) by apply: (Sub m); abstract: blurb k; auto. +have [:blurb] @i k : 'I_(n+k) := apply: Sub m (blurb k); first by auto. +\end{lstlisting} +generates the following context: +\begin{lstlisting} +blurb : (forall k, m < n+k) (*1*) +i := fun k => Sub m (blurb k) : forall k, 'I_(n+k) +\end{lstlisting} + +Last, notice that the use of intro patterns for abstract constants is +orthogonal to the transparent flag \ssrC{@} for \ssrC{have}. + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\subsubsection*{The \ssrC{have} tactic and type classes resolution} +\label{ssec:havetcresolution} + +Since \ssr{} 1.5 the \ssrC{have} tactic behaves as follows with respect to type +classes inference. + +\begin{itemize} +\item \ssrC{have foo : ty.} + Full inference for \ssrC{ty}. + The first subgoal demands a proof of such instantiated statement. +\item \ssrC{have foo : ty := .} + No inference for \ssrC{ty}. Unresolved instances are quantified in + \ssrC{ty}. The first subgoal demands a proof of such quantified + statement. Note that no proof term follows \ssrC{:=}, hence two + subgoals are generated. +\item \ssrC{have foo : ty := t.} + No inference for \ssrC{ty} and \ssrC{t}. +\item \ssrC{have foo := t.} + No inference for \ssrC{t}. Unresolved instances are quantified in the + (inferred) type of \ssrC{t} and abstracted in \ssrC{t}. +\end{itemize} + +The behavior of \ssr{} 1.4 and below (never resolve type classes) +can be restored with the option \ssrC{Set SsrHave NoTCResolution}. + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\subsubsection*{Variants: the \ssrC{suff} and \ssrC{wlog} tactics.} +\label{ssec:wlog} +\idx{suff: \dots{}} +\idx{suffices: \dots{}} +\idx{wlog: \dots{} / \dots{}} +\idx{without loss: \dots{} / \dots{}} + +As it is often the case in mathematical textbooks, forward +reasoning may be used in slightly different variants. +One of these variants is to show that the intermediate step $L$ +easily implies the initial goal $G$. By easily we mean here that +the proof of $L \Rightarrow G$ is shorter than the one of $L$ +itself. This kind of reasoning step usually starts with: +``It suffices to show that \dots''. + +This is such a frequent way of reasoning that \ssr{} has a variant of the +\ssrC{have} tactic called \ssrC{suffices} (whose abridged name is +\ssrC{suff}). The \ssrC{have} and \ssrC{suff} tactics are equivalent and +have the same syntax but: +\begin{itemize} +\item the order of the generated subgoals is inversed +\item but the optional clear item is still performed in the + \emph{second} branch. This means that the tactic: +\begin{lstlisting} + suff {H} H : forall x : nat, x >= 0. +\end{lstlisting} +fails if the context of the current goal indeed contains an +assumption named \ssrC{H}. +\end{itemize} +The rationale of this clearing policy is to make possible ``trivial'' +refinements of an assumption, without changing its name in the main +branch of the reasoning. + +The \ssrC{have} modifier can follow the \ssrC{suff} tactic. +For example, given a goal \ssrC{G} the tactic +\ssrC{suff have H : P} results in the following two goals: +\begin{lstlisting} + H : P |- G + |- (P -> G) -> G +\end{lstlisting} +Note that, in contrast with \ssrC{have suff}, the name \ssrC{H} has been introduced +in the first goal. + +Another useful construct is reduction, +showing that a particular case is in fact general enough to prove +a general property. This kind of reasoning step usually starts with: +``Without loss of generality, we can suppose that \dots''. +Formally, this corresponds to the proof of a goal \ssrC{G} by introducing +a cut \ssrN{wlog\_statement} \ssrC{-> G}. Hence the user shall provide a +proof for both \ssrC{(}\ssrN{wlog\_statement} \ssrC{-> G) -> G} and +\ssrN{wlog\_statement} \ssrC{-> G}. However, such cuts are usually rather +painful to perform by hand, because the statement +\ssrN{wlog\_statement} is tedious to write by hand, and somtimes even +to read. + +\ssr{} implements this kind of reasoning step through the \ssrC{without loss} +tactic, whose short name is \ssrC{wlog}. It offers support to describe +the shape of the cut statements, by providing the simplifying +hypothesis and by pointing at the elements of the initial goals which +should be generalized. The general syntax of \ssrC{without loss} is: + +\begin{center} + \ssrC{wlog} \optional{\ssrC{suff}} \optional{\ssrN{clear-switch}} \optional{\ssrN{i-item}} \ssrC{:} \optional{\ssrN[1]{ident} $\dots$ \ssrN[n]{ident}} \ssrC{/} {\term} +\end{center} + +where \ssrN[1]{ident} $\dots$ \ssrN[n]{ident} are identifiers for constants +in the context of the goal. Open syntax is supported for {\term}. + +In its defective form: + +\begin{center} + \ssrC{wlog: /} {\term}. +\end{center} + +on a goal \ssrC{G}, it creates two subgoals: a first one to prove the formula +\ssrC{(}{\term} \ssrC{-> G) -> G} and a second one to prove the formula +{\term} \ssrC{-> G}. + +:browse confirm wa +If the optional list \ssrN[1]{ident} $\dots$ \ssrN[n]{ident} is present on the left +side of \ssrC{/}, these constants are generalized in the premise +\ssrC{(}{\term} \ssrC{-> G)} of the first subgoal. By default the body of +local definitions is erased. This behavior can be inhibited +prefixing the name of the local definition with the \ssrC{@} character. + +In the second subgoal, the tactic: + +\begin{center} + \ssrC{move=>} \ssrN{clear-switch}\ssrC{} \ssrN{i-item}\ssrC{.} +\end{center} + +is performed if at least one of these optional switches is present in +the \ssrC{wlog} tactic. + +The \ssrC{wlog} tactic is specially useful when a symmetry argument +simplifies a proof. Here is an example showing the beginning of the +proof that quotient and reminder of natural number euclidean division +are unique. +\begin{lstlisting} + Lemma quo_rem_unicity: forall d q1 q2 r1 r2, + q1*d + r1 = q2*d + r2 -> r1 < d -> r2 < d -> (q1, r1) = (q2, r2). + move=> d q1 q2 r1 r2. + wlog: q1 q2 r1 r2 / q1 <= q2. + by case (le_gt_dec q1 q2)=> H; last symmetry; eauto with arith. +\end{lstlisting} + +The \ssrC{wlog suff} variant is simpler, since it cuts +\ssrN{wlog\_statement} instead of \ssrN{wlog\_statement} \ssrC{-> G}. It thus +opens the goals \ssrN{wlog\_statement} \ssrC{-> G} and \ssrN{wlog\_statement}. + +In its simplest form +the \ssrC{generally have :...} tactic +is equivalent to \ssrC{wlog suff :...} followed by \ssrC{last first}. +When the \ssrC{have} tactic +is used with the \ssrC{generally} (or \ssrC{gen}) modifier it accepts an +extra identifier followed by a comma before the usual intro pattern. +The identifier will name the new hypothesis in its more general form, +while the intro pattern will be used to process its instance. For example: +\begin{lstlisting} + Lemma simple n (ngt0 : 0 < n ) : P n. + gen have ltnV, /andP[nge0 neq0] : n ngt0 / (0 <= n) && (n != 0). +\end{lstlisting} +The first subgoal will be +\begin{lstlisting} + n : nat + ngt0 : 0 < n + ==================== + (0 <= n) && (n != 0) +\end{lstlisting} +while the second one will be +\begin{lstlisting} + n : nat + ltnV : forall n, 0 < n -> (0 <= n) && (n != 0) + nge0 : 0 <= n + neqn0 : n != 0 + ==================== + P n +\end{lstlisting} + +\paragraph{Advanced generalization}\label{par:advancedgen} +The complete syntax for the items on the left hand side of the \ssrC{/} +separator is the following one: +\begin{center} +\ssrN{clear-switch} {\optsep} \optional{\ssrC{@}} \ssrN{ident} {\optsep} \ssrC{(}\optional{\ssrC{@}}\ssrN{ident} \ssrC{:=} \ssrN{c-pattern}\ssrC{)} +\end{center} +Clear operations are intertwined with generalization operations. This +helps in particular avoiding dependency issues while generalizing some facts. + +\noindent +If an \ssrN{ident} is prefixed with the \ssrC{@} prefix mark, then a +let-in redex is created, which keeps track if its body (if any). The +syntax \ssrC{(}\ssrN{ident}\ssrC{:=}\ssrN{c-pattern}\ssrC{)} allows to +generalize an arbitrary term using a given name. Note that its simplest +form \ssrC{(x := y)} is just a renaming of \ssrC{y} into \ssrC{x}. In +particular, this can be useful in order to simulate the generalization +of a section variable, otherwise not allowed. Indeed renaming does not +require the original variable to be cleared. + + +\noindent +The syntax \ssrC{(@x := y)} generates a let-in abstraction but with the following +caveat: \ssrC{x} will not bind \ssrC{y}, but its body, whenever \ssrC{y} can be +unfolded. This cover the case of both local and global definitions, as +illustrated in the following example: + +\begin{lstlisting} +Section Test. +Variable x : nat. +Definition addx z := z + x. +Lemma test : x <= addx x. +wlog H : (y := x) (@twoy := addx x) / twoy = 2 * y. +\end{lstlisting} +\noindent +The first subgoal is: +\begin{lstlisting} + (forall y : nat, let twoy := y + y in twoy = 2 * y -> y <= twoy) -> + x <= addx x +\end{lstlisting} +\noindent +To avoid unfolding the term captured by the pattern \ssrC{add x} one +can use the pattern \ssrC{id (addx x)}, that would produce the following first +subgoal: +\begin{lstlisting} + (forall y : nat, let twoy := addx y in twoy = 2 * y -> y <= twoy) -> + x <= addx x +\end{lstlisting} +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\section{Rewriting}\label{sec:rw} +\idx{rewrite \dots{}} + +The generalized use of reflection implies that most of the +intermediate results handled are properties of effectively computable +functions. The most efficient mean of establishing such results are +computation and simplification of expressions involving such +functions, i.e., rewriting. \ssr{} therefore includes an extended +\ssrC{rewrite} tactic, that unifies and combines most of the rewriting +functionalities. +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\subsection{An extended \ssrC{rewrite} tactic}\label{ssec:extrw} +The main features of the \ssrC{rewrite} tactic are: +\begin{itemize} +\item It can perform an entire series of such operations in any + subset of the goal and/or context; +\item It allows to perform rewriting, + simplifications, folding/unfolding of definitions, closing of goals; +\item Several rewriting operations can be chained in a single tactic; +\item Control over the occurrence at which rewriting is to be performed is + significantly enhanced. +\end{itemize} + + +The general form of an \ssr{} rewrite tactic is: + +\begin{center} + \ssrC{rewrite} \ssrN{rstep}$^+$\ssrC{.} +\end{center} + +The combination of a rewrite tactic with the \ssrC{in} tactical (see +section \ref{ssec:loc}) performs rewriting in both the context and the +goal. + +A rewrite step \ssrN{rstep} has the general form: + +\begin{center} + \optional{\ssrN{r-prefix}}\ssrN{r-item} +\end{center} + +where: + +\begin{longtable}{rcl} +\ssrN{r-prefix} & ::= & + \optional{\ssrC{-}} \optional{\ssrN{mult}} \optional{\ssrN{occ-switch} {\optsep} \ssrN{clear-switch}} \optional{\ssrC{[}\ssrN{r-pattern}\ssrC{]}}\\ +\ssrN{r-pattern} & ::= & +{\term} {\optsep} \ssrC{in} \optional{\ssrN{ident} \ssrC{in}} {\term} {\optsep} \optional{{\term} \ssrC{in} {\optsep} {\term} \ssrC{as} } \ssrN{ident} \ssrC{in} {\term}\\ +\ssrN{r-item} & ::= & +\optional{\ssrC{/}}{\term} {\optsep} \ssrN{s-item} \\ +\end{longtable} + + +% \begin{eqnarray*} +% \ssrN{r-prefix} & ::= & +% [\ssrC{-}]\ [\ssrN{mult}][\ssrN{occ-switch} | \ssrN{cl-item}][{\term}]\\ +% \ssrN{r-item} & ::= & +% [\ssrC{-}]{\term}\ |\ [\ssrC{-}]\ssrC{[}\ssrN[1]{term}\ssrC{]}\ssrC{/(}\ssrN[2]{term}\ssrC{)} \ |\ +% \ssrN{simpl switch} \ |\ \\ +% && \ssrN{eq-term} \ |\ \ssrC{(} \ssrN[1]{eq-term}\ssrC{,}\dots +% \ssrC{,}\ssrN[n]{eq-term} \ssrC{)} \ |\ \ssrC{(_ :}\ssrN{eq-term} \ssrC{)} +% \end{eqnarray*} + + +An \ssrN{r-prefix} contains annotations to qualify where and how the +rewrite operation should be performed: +\begin{itemize} +\item The optional initial \ssrC{-} indicates the direction of the rewriting + of \ssrN{r-item}: if present the direction is right-to-left and it is + left-to-right otherwise. +\item The multiplier \ssrN{mult} (see section \ref{ssec:iter}) + specifies if and how the rewrite operation should be repeated. +\item A rewrite operation matches the occurrences of a \emph{rewrite + pattern}, and replaces these occurrences by an other term, according + to the given \ssrN{r-item}. + The optional \emph{redex switch} $\ssrC{[}\ssrN{r-pattern}\ssrC{]}$, which + should always be surrounded by brackets, gives explicitly this + rewrite pattern. In its simplest form, it is a regular term. + If no explicit redex switch + is present the rewrite pattern to be matched is inferred from the + \ssrN{r-item}. +\item This optional {\term}, or + the \ssrN{r-item}, may be preceded by an + occurrence switch (see section \ref{ssec:select}) or a clear item + (see section \ref{ssec:discharge}), these two possibilities being + exclusive. An occurrence switch selects the occurrences of the + rewrite pattern which should be affected by the rewrite operation. +\end{itemize} + + +An \ssrN{r-item} can be: + + +\begin{itemize} +\item A \emph{simplification r-item}, represented by a + \ssrN{s-item} (see section \ref{ssec:intro}). +% In some cases, \ssrN{r-prefix}es are not supported. + Simplification operations are + intertwined with the possible other rewrite operations specified by + the list of r-items. +\item A \emph{folding/unfolding r-item}. The tactic: + + \ssrC{rewrite /}{\term} + +unfolds the head constant of \textit{term} in every occurrence of the +first matching of \textit{term} in the goal. In particular, if +\ssrC{my_def} is a (local or global) defined constant, the tactic: +\begin{lstlisting} + rewrite /my_def. +\end{lstlisting} +is analogous to: +\begin{lstlisting} + unfold my_def. +\end{lstlisting} +Conversely: +\begin{lstlisting} + rewrite -/my_def. +\end{lstlisting} +is equivalent to: +\begin{lstlisting} + fold my_def. +\end{lstlisting} +%\emph{Warning} The combination of redex switch with unfold +%\ssrN{r-item} is not yet implemented. + +When an unfold r-item is combined with a redex pattern, a conversion +operation is performed. A tactic of the form: + +\begin{center} + \ssrC{rewrite -[}\ssrN[1]{term}\ssrC{]/}\ssrN[2]{term}\ssrC{.} +\end{center} + +is equivalent to: + + +\begin{center} + \ssrC{change} \ssrN[1]{term} \ssrC{with} \ssrN[2]{term}\ssrC{.} +\end{center} + + +If \ssrN[2]{term} is a single constant and \ssrN[1]{term} head symbol +is not \ssrN[2]{term}, then the head symbol of \ssrN[1]{term} is +repeatedly unfolded until \ssrN[2]{term} appears. + +\begin{lstlisting} + Definition double x := x + x. + Definition ddouble x := double (double x). + Lemma ex1 x : ddouble x = 4 * x. + rewrite [ddouble _]/double. +\end{lstlisting} + +The resulting goal is: + +\begin{lstlisting} + double x + double x = 4 * x +\end{lstlisting} + +\emph{Warning} The \ssr{} terms containing holes are \emph{not} +typed as abstractions in this context. Hence the following script: +\begin{lstlisting} + Definition f := fun x y => x + y. + Goal forall x y, x + y = f y x. + move=> x y. + rewrite -[f y]/(y + _). +\end{lstlisting} +raises the error message +\begin{verbatim} + User error: fold pattern (y + _) does not match redex (f y) +\end{verbatim} +but the script obtained by replacing the last line with: +\begin{lstlisting} + rewrite -[f y x]/(y + _). +\end{lstlisting} +is valid. + + +\item A term, which can be: + \begin{itemize} + \item A term whose type has the form: + $$\ssrC{forall}\ (x_1\ :\ A_1)\dots(x_n\ :\ A_n),\ eq\ term_1\ term_2$$ + where $eq$ is the Leibniz equality or a registered setoid + equality. %In the case of setoid relations, the only supported + %r-prefix is the directional \ssrC{-}. + \item A list of terms $(t_1,\dots,t_n)$, each $t_i$ having a type of the + form: $$\ssrC{forall}\ (x_1\ :\ A_1)\dots(x_n\ :\ A_n),\ eq\ term_1\ term_2$$ where + $eq$ is the Leibniz equality or a registered setoid + equality. The tactic: + + \centerline{\ssrC{rewrite} \ssrN{r-prefix}\ssrC{(}$t_1$\ssrC{,}$\dots$\ssrC{,}$t_n$\ssrC{).}} + + is equivalent to: + + \centerline{\ssrC{do [rewrite} \ssrN{r-prefix} $t_1$ \ssrC{|} $\dots$ \ssrC| rewrite} \ssrN{r-prefix} $t_n$\ssrC{].} + + \item An anonymous rewrite lemma + \ssrC{(_ :} {\term}), where \textit{term} has again the form: + $$\ssrC{forall}\ (x_1\ :\ A_1)\dots(x_n\ :\ A_n),\ eq\ term_1\ term_2$$ + The tactic: + + \centerline{\ssrC{rewrite (_ :} {\term}\ssrC{)}} + + is in fact synonym of: + + \centerline{\ssrC{cutrewrite (}{\term}\ssrC{).}} + + + \end{itemize} + +\end{itemize} + + + + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\subsection{Remarks and examples}\label{ssec:rwex} + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\subsubsection*{Rewrite redex selection} +The general strategy of \ssr{} +is to grasp as many redexes as possible and to let the user select the +ones to be rewritten thanks to the improved syntax for the control of +rewriting. + +This may be a source of incompatibilities between the two \ssrC{rewrite} +tactics. + +In a rewrite tactic of the form: + + \ssrC{rewrite} \ssrN{occ-switch}\ssrC{[}\ssrN[1]{term}\ssrC{]}\ssrN[2]{term}. + +\ssrN[1]{term} is the explicit rewrite redex and +\ssrN[2]{term} is the +rewrite rule. This execution of this tactic unfolds as follows: + +\begin{itemize} +\item First \ssrN[1]{term} and \ssrN[2]{term} are $\beta\iota$ normalized. Then + \ssrN[2]{term} is put in head normal form if the Leibniz equality + constructor \ssrC{eq} is not the head symbol. This may involve $\zeta$ + reductions. +\item Then, the matching algorithm (see section \ref{ssec:set}) + determines the first subterm of the goal matching the rewrite pattern. + The rewrite pattern is + given by \ssrN[1]{term}, if an explicit redex pattern switch is provided, or by + the type of \ssrN[2]{term} otherwise. However, matching skips over + matches that would lead to trivial rewrites. All the + occurrences of this subterm in the goal are candidates for rewriting. +\item Then only the occurrences coded by \ssrN{occ-switch} (see again + section \ref{ssec:set}) are finally selected for rewriting. +\item The left hand side of $\ssrN[2]{term}$ is unified with the subterm found + by the matching algorithm, and if this succeeds, all the selected + occurrences in the goal are replaced by the right hand side of + $\ssrN[2]{term}$. +\item Finally the goal is $\beta\iota$ normalized. +\end{itemize} + +In the case $\ssrN[2]{term}$ is a list of terms, the first top-down (in +the goal) left-to-right (in the list) matching rule gets selected. + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\subsubsection*{Chained rewrite steps} + + +The possibility to chain rewrite operations in a single tactic makes +scripts more compact and gathers in a single command line a bunch +of surgical +operations which would be described by a one sentence in a pen and +paper proof. + +Performing rewrite and simplification operations in a single tactic +enhances significantly the concision of scripts. For instance the +tactic: +\begin{lstlisting} + rewrite /my_def {2}[f _]/= my_eq //=. +\end{lstlisting} +unfolds \ssrC{my_def} in the goal, simplifies the second occurrence of the +first subterm matching pattern \ssrC{[f _]}, rewrites \ssrC{my_eq}, +simplifies the whole goal and closes trivial goals. + +Here are some concrete examples of chained rewrite operations, in the +proof of basic results on natural numbers arithmetic: + +\begin{lstlisting} + Lemma |*addnS*| : forall m n, m + n.+1 = (m + n).+1. + Proof. by move=> m n; elim: m. Qed. + + Lemma |*addSnnS*| : forall m n, m.+1 + n = m + n.+1. + Proof. move=> *; rewrite addnS; apply addSn. Qed. + + Lemma |*addnCA*| : forall m n p, m + (n + p) = n + (m + p). + Proof. by move=> m n; elim: m => [|m Hrec] p; rewrite ?addSnnS -?addnS. Qed. + + Lemma |*addnC*| : forall m n, m + n = n + m. + Proof. by move=> m n; rewrite -{1}[n]addn0 addnCA addn0. Qed. +\end{lstlisting} + +Note the use of the \ssrC{?} switch for parallel rewrite operations in +the proof of \ssrC{|*addnCA*|}. + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\subsubsection*{Explicit redex switches are matched first} +If an \ssrN{r-prefix} involves a \emph{redex switch}, the first step is to +find a subterm matching this redex pattern, independently from the left hand +side \ssrC{t1} of the equality the user wants to rewrite. + +For instance, if \ssrL-H : forall t u, t + u = u + t- is in the context of a +goal \ssrL-x + y = y + x-, the tactic: +\begin{lstlisting} + rewrite [y + _]H. +\end{lstlisting} +transforms the goal into \ssrL-x + y = x + y-. + +Note that if this first pattern matching is not compatible with the +\emph{r-item}, the rewrite fails, even if the goal contains a correct +redex matching both the redex switch and the left hand side of the +equality. For instance, if \ssrL-H : forall t u, t + u * 0 = t- is +in the context of a goal \ssrL-x + y * 4 + 2 * 0 = x + 2 * 0-, then tactic: +\begin{lstlisting} + rewrite [x + _]H. +\end{lstlisting} +raises the error message: +\begin{verbatim} + User error: rewrite rule H doesn't match redex (x + y * 4) +\end{verbatim} +while the tactic: +\begin{lstlisting} + rewrite (H _ 2). +\end{lstlisting} +transforms the goal into \ssrL-x + y * 4 = x + 2 * 0-. + + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\subsubsection*{Occurrence switches and redex switches} +The tactic: +\begin{lstlisting} + rewrite {2}[_ + y + 0](_: forall z, z + 0 = z). +\end{lstlisting} +transforms the goal: +\begin{lstlisting} + x + y + 0 = x + y + y + 0 + 0 + (x + y + 0) +\end{lstlisting} +into: +\begin{lstlisting} + x + y + 0 = x + y + y + 0 + 0 + (x + y) +\end{lstlisting} +and generates a second subgoal: +\begin{lstlisting} + forall z : nat, z + 0 = z +\end{lstlisting} +The second subgoal is generated by the use of an anonymous lemma in +the rewrite tactic. The effect of the tactic on the initial goal is to +rewrite this lemma at the second occurrence of the first matching +\ssrL-x + y + 0- of the explicit rewrite redex \ssrL-_ + y + 0-. + + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\subsubsection*{Occurrence selection and repetition} +Occurrence selection has priority over repetition switches. This means +the repetition of a rewrite tactic specified by a multiplier +will perform matching each time an elementary rewrite operation is +performed. Repeated rewrite tactics apply to every subgoal generated +by the previous tactic, including the previous instances of the +repetition. For example: +\begin{lstlisting} + Goal forall x y z : nat, x + 1 = x + y + 1. + move=> x y z. +\end{lstlisting} +creates a goal \ssrC{ x + 1 = x + y + 1}, which is turned into \ssrC{z = z} +by the additional tactic: +\begin{lstlisting} + rewrite 2!(_ : _ + 1 = z). +\end{lstlisting} +In fact, this last tactic generates \emph{three} subgoals, +respectively +\ssrC{ x + y + 1 = z}, \ssrC{ z = z} and \ssrC{x + 1 = z}. Indeed, the second +rewrite operation specified with the \ssrC{2!} multiplier applies to +the two subgoals generated by the first rewrite. + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\subsubsection*{Multi-rule rewriting} +The \ssrC{rewrite} tactic can be provided a \emph{tuple} of rewrite rules, +or more generally a tree of such rules, since this tuple can feature +arbitrary inner parentheses. We call \emph{multirule} such a +generalized rewrite rule. This feature is of special interest when it +is combined with multiplier switches, which makes the \ssrC{rewrite} +tactic iterates the rewrite operations prescribed by the rules on the +current goal. For instance, let us define two triples \ssrC{multi1} and +\ssrC{multi2} as: +\begin{lstlisting} + Variables (a b c : nat). + + Hypothesis eqab : a = b. + + Hypothesis eqac : a = c. +\end{lstlisting} + +Executing the tactic: +\begin{lstlisting} + rewrite (eqab, eqac) +\end{lstlisting} +on the goal: +\begin{lstlisting} + ========= + a = a +\end{lstlisting} +turns it into \ssrC{b = b}, as rule \ssrC{eqab} is the first to apply among +the ones gathered in the tuple passed to the \ssrC{rewrite} +tactic. This multirule \ssrC{(eqab, eqac)} is actually a \Coq{} term and we +can name it with a definition: +\begin{lstlisting} +Definition |*multi1*| := (eqab, eqac). +\end{lstlisting} +In this case, the tactic \ssrC{rewrite multi1} is a synonym for +\ssrC{(eqab, eqac)}. More precisely, a multirule rewrites +the first subterm to which one of the rules applies in a left-to-right +traversal of the goal, with the first rule from the multirule tree in +left-to-right order. Matching is performed according to the algorithm +described in Section~\ref{ssec:set}, but literal matches have +priority. For instance if we add a definition and a new multirule to +our context: + +\begin{lstlisting} + Definition |*d*| := a. + + Hypotheses eqd0 : d = 0. + + Definition |*multi2*| := (eqab, eqd0). +\end{lstlisting} +then executing the tactic: +\begin{lstlisting} + rewrite multi2. +\end{lstlisting} +on the goal: +\begin{lstlisting} + ========= + d = b +\end{lstlisting} +turns it into \ssrC{0 = b}, as rule \ssrC{eqd0} applies without unfolding +the definition of \ssrC{d}. For repeated rewrites the selection process +is repeated anew. For instance, if we define: + +\begin{lstlisting} + Hypothesis eq_adda_b : forall x, x + a = b. + + Hypothesis eq_adda_c : forall x, x + a = c. + + Hypothesis eqb0 : b = 0. + + Definition |*multi3*| := (eq_adda_b, eq_adda_c, eqb0). +\end{lstlisting} +then executing the tactic: +\begin{lstlisting} + rewrite 2!multi3. +\end{lstlisting} +on the goal: +\begin{lstlisting} + ========= + 1 + a = 12 + a +\end{lstlisting} +turns it into \ssrC{0 = 12 + a}: it uses \ssrC{eq_adda_b} then \ssrC{eqb0} on the +left-hand side only. Now executing the tactic \ssrC{rewrite !multi3} +turns the same goal into \ssrC{0 = 0}. + +The grouping of rules inside a multirule does not affect the selection +strategy but can make it easier to include one rule set in another or +to (universally) quantify over the parameters of a subset of rules (as +there is special code that will omit unnecessary quantifiers for rules that +can be syntactically extracted). It is also possible to +reverse the direction of a rule subset, using a special dedicated syntax: +the tactic \ssrC{rewrite (=~ multi1)} is equivalent to +\ssrC{rewrite multi1_rev} with: +\begin{lstlisting} + Hypothesis eqba : b = a. + + Hypothesis eqca : c = a. + + Definition |*multi1_rev*| := (eqba, eqca). +\end{lstlisting} +except that the constants \ssrC{eqba, eqab, mult1_rev} have not been created. + +Rewriting with multirules +is useful to implement simplification or transformation +procedures, to be applied on terms of small to medium size. For +instance the library \ssrL{ssrnat} provides two implementations for +arithmetic operations on natural numbers: an elementary one and a tail +recursive version, less inefficient but also less convenient for +reasoning purposes. The library also provides one lemma per such +operation, stating that both versions return the same values when +applied to the same arguments: + +\begin{lstlisting} + Lemma |*addE*| : add =2 addn. + Lemma |*doubleE*| : double =1 doublen. + Lemma |*add_mulE*| n m s : add_mul n m s = addn (muln n m) s. + Lemma |*mulE*| : mul =2 muln. + Lemma |*mul_expE*| m n p : mul_exp m n p = muln (expn m n) p. + Lemma |*expE*| : exp =2 expn. + Lemma |*oddE*| : odd =1 oddn. +\end{lstlisting} + +The operation on the left hand side of each lemma is the efficient +version, and the corresponding naive implementation is on the right +hand side. In order to reason conveniently on expressions involving +the efficient operations, we gather all these rules in the +definition \ssrC{|*trecE*|}: +\begin{lstlisting} + Definition |*trecE*| := (addE, (doubleE, oddE), (mulE, add_mulE, (expE, mul_expE))). +\end{lstlisting} +The tactic: +\begin{lstlisting} + rewrite !trecE. +\end{lstlisting} +restores the naive versions of each operation in a goal involving the +efficient ones, e.g. for the purpose of a correctness proof. + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\subsubsection*{Wildcards vs abstractions} + The \ssrC{rewrite} tactic supports r-items containing holes. For example + in the tactic $(1)$: +\begin{lstlisting} + rewrite (_ : _ * 0 = 0). +\end{lstlisting} + the term \ssrC{_ * 0 = 0} is interpreted as \ssrC{forall n : nat, n * 0 = 0}. + Anyway this tactic is \emph{not} equivalent to the tactic $(2)$: +\begin{lstlisting} + rewrite (_ : forall x, x * 0 = 0). +\end{lstlisting} + The tactic $(1)$ transforms the goal + \ssrL-(y * 0) + y * (z * 0) = 0- into \ssrC{y * (z * 0) = 0} + and generates a new subgoal to prove the statement \ssrC{y * 0 = 0}, + which is the \emph{instance} of the\\ \ssrC{forall x, x * 0 = 0} + rewrite rule that + has been used to perform the rewriting. On the other hand, tactic + $(2)$ performs the same rewriting on the current goal but generates a + subgoal to prove \ssrC{forall x, x * 0 = 0}. + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\subsubsection*{When \ssr{} \ssrC{rewrite} fails on standard \Coq{} licit rewrite} +In a few cases, the \ssr{} \ssrC{rewrite} tactic fails +rewriting some redexes which standard \Coq{} successfully rewrites. +There are two main cases: + +\begin{itemize} +\item \ssr{} never accepts to rewrite indeterminate patterns like: +\begin{lstlisting} + Lemma |*foo*| : forall x : unit, x = tt. +\end{lstlisting} +\ssr{} will however accept the $\eta\zeta$ expansion of this rule: +\begin{lstlisting} + Lemma |*fubar*| : forall x : unit, (let u := x in u) = tt. +\end{lstlisting} +\item In standard \Coq{}, suppose that we work in the following context: +\begin{lstlisting} + Variable g : nat -> nat. + Definition |*f*| := g. +\end{lstlisting} +then rewriting \ssrC{H : forall x, f x = 0} in the goal +\ssrC{g 3 + g 3 = g 6} succeeds +and transforms the goal into \ssrC{0 + 0 = g 6}. + +This rewriting is not possible in \ssr{} because there is no +occurrence of the head symbol \ssrC{f} of the rewrite rule in the +goal. Rewriting with \ssrC{H} first requires unfolding the occurrences of +\ssrC{f} where the substitution is to be performed (here there is a single +such occurrence), using tactic \ssrC{rewrite /f} (for a global +replacement of \ssrC{f} by \ssrC{g}) or \ssrC{rewrite $\ \ssrN{pattern}$/f}, for a +finer selection. +\end{itemize} + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\subsubsection*{Existential metavariables and rewriting} +\label{ssec:rewcaveats} +The \ssrC{rewrite} tactic will not instantiate existing existential +metavariables when matching a redex pattern. + +If a rewrite rule generates a goal +with new existential metavariables, these will be generalized as for \ssrC{apply} +(see page~\pageref{sssec:apply}) and corresponding new goals will be generated. +For example, consider the following script: + +\begin{lstlisting} + Lemma |*ex3*| (x : 'I_2) y (le_1 : y < 1) (E : val x = y) : Some x = insub y. + rewrite insubT ?(leq_trans le_1)// => le_2. +\end{lstlisting} + +Since \ssrC{insubT} has the following type: + +\begin{lstlisting} + forall T P (sT : subType P) (x : T) (Px : P x), insub x = Some (Sub x Px) +\end{lstlisting} + +and since the implicit argument corresponding to the \ssrC{Px} abstraction is not +supplied by the user, the resulting goal should be \ssrC{Some x = Some (Sub y +$\;\;?_{Px}$)}. Instead, \ssr{} \ssrC{rewrite} tactic generates the two following +goals: +\begin{lstlisting} + y < 2 + forall Hyp0 : y < 2, Some x = Some (Sub y Hyp0) +\end{lstlisting} +The script closes the former with \ssrC{?(leq_trans le_1)//}, then it introduces +the new generalization naming it \ssrC{le_2}. + +\begin{lstlisting} + x : 'I_2 + y : nat + le_1 : y < 1 + E : val x = y + le_2 : y < 2 + ============================ + Some x = Some (Sub y le_2) +\end{lstlisting} + +As a temporary limitation, this behavior is available only if the rewriting +rule is stated using Leibniz equality (as opposed to setoid relations). +It will be extended to other rewriting relations in the future. + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\subsection{Locking, unlocking} \label{ssec:lock} + +As program proofs tend to generate large goals, it is important to be +able to control the partial evaluation performed by the simplification +operations that are performed by the tactics. These evaluations can +for example come from a \ssrC{/=} simplification switch, or from rewrite steps +which may expand large terms while performing conversion. We definitely +want to avoid repeating large subterms of the goal in +the proof script. We do this by +``clamping down'' selected function symbols in the goal, which +prevents them from +being considered in simplification or rewriting steps. This clamping +is accomplished by using the occurrence switches (see section +\ref{sssec:occselect}) together with ``term tagging'' operations. + +\ssr{} provides two levels of tagging. + +The first one uses auxiliary definitions to introduce a provably equal +copy of any term \ssrC{t}. However this copy is (on purpose) +\emph{not convertible} to \ssrC{t} in the \Coq{} system\footnote{This is + an implementation feature: there is not such obstruction in the + metatheory}. The job is done by the following construction: + +\begin{lstlisting} + Lemma |*master_key*| : unit. Proof. exact tt. Qed. + Definition |*locked*| A := let: tt := master_key in fun x : A => x. + Lemma |*lock*| : forall A x, x = locked x :> A. +\end{lstlisting} +Note that the definition of \ssrC{|*master_key*|} is explicitly opaque. +The equation \ssrC{t = locked t} given by the \ssrC{lock} lemma can be used +for selective rewriting, blocking on the fly the reduction in the +term \ssrC{t}. +For example the script: +\begin{lstlisting} + Require Import List. + Variable A : Type. + + Fixpoint |*my_has*| (p : A -> bool)(l : list A){struct l} : bool:= + match l with + |nil => false + |cons x l => p x || (my_has p l) + end. + + Goal forall a x y l, a x = true -> my_has a ( x :: y :: l) = true. + move=> a x y l Hax. +\end{lstlisting} +where \ssrL{||} denotes the boolean disjunction, results in a goal +\ssrC{my_has a ( x :: y :: l) = true}. The tactic: +\begin{lstlisting} + rewrite {2}[cons]lock /= -lock. +\end{lstlisting} +turns it into \ssrC{a x || my_has a (y :: l) = true}. +Let us now start by reducing the initial goal without blocking reduction. +The script: +\begin{lstlisting} + Goal forall a x y l, a x = true -> my_has a ( x :: y :: l) = true. + move=> a x y l Hax /=. +\end{lstlisting} +creates a goal \ssrC{(a x) || (a y) || (my_has a l) = true}. Now the +tactic: +\begin{lstlisting} + rewrite {1}[orb]lock orbC -lock. +\end{lstlisting} +where \ssrC{orbC} states the commutativity of \ssrC{orb}, changes the +goal into\\ \ssrC{(a x) || (my_has a l) || (a y) = true}: only the +arguments of the second disjunction where permuted. + + +It is sometimes desirable to globally prevent a definition from being +expanded by simplification; this is done by adding \ssrC{locked} in the +definition. + +For instance, the function \ssrC{|*fgraph_of_fun*|} maps a function whose +domain and codomain are finite types to a concrete representation of +its (finite) graph. Whatever implementation of this transformation we +may use, we want it to be hidden to simplifications and tactics, to +avoid the collapse of the graph object: +\begin{lstlisting} + Definition |*fgraph_of_fun*| := + locked + (fun (d1 :finType) (d2 :eqType) (f : d1 -> d2) => Fgraph (size_maps f _)). +\end{lstlisting} + +We provide a special tactic \ssrC{unlock} for unfolding such definitions +while removing ``locks'', e.g., the tactic: + + \ssrC{unlock} \ssrN{occ-switch}\ssrC{fgraph_of_fun}. + +replaces the occurrence(s) of \ssrC{fgraph_of_fun} coded by the \ssrN{occ-switch} +with \ssrC{(Fgraph (size_maps _ _))} in the goal. + +We found that it was usually preferable to prevent the expansion of +some functions by the partial evaluation switch ``/='', unless +this allowed the evaluation of a condition. This is possible thanks to +an other mechanism of term tagging, resting on the following +\emph{Notation}: +\begin{lstlisting} + Notation "'nosimpl' t" := (let: tt := tt in t). +\end{lstlisting} + +The term \ssrC{(nosimpl t)} simplifies to t \emph{except} in a +definition. More precisely, +given: +\begin{lstlisting} + Definition |*foo*| := (nosimpl bar). +\end{lstlisting} +the term \ssrC{foo (or (foo t'))} will \emph{not} be expanded by the +\emph{simpl} tactic unless it is in a forcing context (e.g., in +\ssrC{match foo t' with $\dots$ end}, \ssrC{foo t'} will be reduced if this allows +\ssrC{match} to be reduced). Note that \ssrC{nosimpl bar} is simply notation +for a term that reduces to \ssrC{bar}; hence \ssrC{unfold foo} will replace + \ssrC{foo} by \ssrC{bar}, and \ssrC{fold foo} will replace \ssrC{bar} by + \ssrC{foo}. + +\emph{Warning} The \ssrC{nosimpl} trick only works if no reduction is +apparent in \ssrC{t}; in particular, the declaration: +\begin{lstlisting} + Definition |*foo*| x := nosimpl (bar x). +\end{lstlisting} +will usually not work. Anyway, the common practice is to tag only the +function, and to use the following definition, which blocks the +reduction as expected: +\begin{lstlisting} + Definition |*foo*| x := nosimpl bar x. +\end{lstlisting} + + +A standard example making this technique shine is the case of +arithmetic operations. We define for instance: +\begin{lstlisting} + Definition |*addn*| := nosimpl plus. +\end{lstlisting} +The operation \ssrC{addn} behaves exactly like plus, except that +\ssrC{(addn (S n) m)} will not +simplify spontaneously to \ssrC{(S (addn n m))} (the two terms, however, are +inter-convertible). In addition, the unfolding step: +\begin{lstlisting} +rewrite /addn +\end{lstlisting} +will replace \ssrC{addn} directly with \ssrC{plus}, so the \ssrC{nosimpl} form +is essentially invisible. + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\subsection{Congruence}\label{ssec:congr} + +Because of the way matching interferes with type families parameters, +the tactic: +\begin{lstlisting} + apply: my_congr_property. +\end{lstlisting} +will generally fail to perform congruence simplification, even on +rather simple cases. We therefore provide a +more robust alternative in which the function is supplied: +$$\ssrC{congr}\ [\ssrN{int}]\ {\term}$$ + +This tactic: +\begin{itemize} +\item checks that the goal is a Leibniz equality +\item matches both sides of this equality with ``{\term} applied to + some arguments'', inferring the right number of arguments from the goal + and the type of {\term}. This may + expand some definitions or fixpoints. +\item generates the subgoals corresponding to pairwise equalities of + the arguments present in the goal. +\end{itemize} + +The goal can be a non dependent product \ssrC{P -> Q}. +In that case, the system asserts the equation \ssrC{P = Q}, uses it to solve +the goal, and calls the \ssrC{congr} tactic on the remaining goal +\ssrC{P = Q}. This can be useful for instance to perform a transitivity +step, like in the following situation: +\begin{lstlisting} + x, y, z : nat + =============== + x = y -> x = z +\end{lstlisting} +the tactic \ssrC{congr (_ = _)} turns this goal into: + +\begin{lstlisting} + x, y, z : nat + =============== + y = z +\end{lstlisting} +which can also be obtained starting from: +\begin{lstlisting} + x, y, z : nat + h : x = y + =============== + x = z +\end{lstlisting} +and using the tactic \ssrC{congr (_ = _): h}. + +The optional \ssrN{int} forces the number of arguments for which the +tactic should generate equality proof obligations. + +This tactic supports equalities between applications with dependent +arguments. Yet dependent arguments should have exactly the same +parameters on both sides, and these parameters should appear as first +arguments. + +The following script: +\begin{lstlisting} + Definition f n := match n with 0 => plus | S _ => mult end. + Definition g (n m : nat) := plus. + + Goal forall x y, f 0 x y = g 1 1 x y. + by move=> x y; congr plus. + Qed. +\end{lstlisting} +shows that the \ssrC{congr} tactic matches \ssrC{plus} with \ssrC{f 0} on the +left hand side and \ssrC{g 1 1} on the right hand side, and solves the goal. + +The script: +\begin{lstlisting} + Goal forall n m, m <= n -> S m + (S n - S m) = S n. + move=> n m Hnm; congr S; rewrite -/plus. +\end{lstlisting} +generates the subgoal \ssrC{m + (S n - S m) = n}. The tactic +\ssrC{rewrite -/plus} folds back the expansion of \ssrC{plus} which was +necessary for matching both sides of the equality with an application +of \ssrC{S}. + +Like most \ssr{} arguments, {\term} can contain wildcards. +The script: +\begin{lstlisting} + Goal forall x y, x + (y * (y + x - x)) = x * 1 + (y + 0) * y. + move=> x y; congr ( _ + (_ * _)). +\end{lstlisting} +generates three subgoals, respectively \ssrC{x = x * 1}, \ssrC{y = y + 0} +and \ssrC{ y + x - x = y}. +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\section{Contextual patterns} +\label{ssec:rewp} + +The simple form of patterns used so far, ${\term}s$ possibly containing +wild cards, often require an additional \ssrN{occ-switch} to be specified. +While this may work pretty fine for small goals, the use of polymorphic +functions and dependent types may lead to an invisible duplication of functions +arguments. These copies usually end up in types hidden by the implicit +arguments machinery or by user defined notations. In these situations +computing the right occurrence numbers is very tedious because they must be +counted on the goal as printed after setting the \ssrC{Printing All} flag. +Moreover the resulting script is not really informative for the reader, since +it refers to occurrence numbers he cannot easily see. + +Contextual patterns mitigate these issues allowing to specify occurrences +according to the context they occur in. + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\subsection{Syntax} + +The following table summarizes the full syntax of +\ssrN{c-pattern} and the corresponding subterm(s) identified +by the pattern. +In the third column we use s.m.r. for +``the subterms matching the redex'' specified in the second column. + +\begin{center} +%\begin{tabularx}{\textwidth}{>{\arraybackslash}m{0.30\textwidth}|>{\arraybackslash}m{0.21\textwidth}|>{\arraybackslash}m{0.39\textwidth}} +\begin{tabular}{llp{10em}} +\ssrN{c-pattern} & redex & subterms affected \\ +\hline +{\term} & {\term} & all occurrences of {\term}\\ +\hline +$\ssrN{ident}\ \ssrC{in}\ {\term}$ & + subterm of {\term} selected by \ssrN{ident} & + all the subterms identified by \ssrN{ident} in all + the occurrences of {\term} \\ +\hline +$\ssrN[1]{term}\ \ssrC{in}\ \ssrN{ident}\ \ssrC{in}\ \ssrN[2]{term}$ & $\ssrN[1]{term}$ & + in all s.m.r. in all the subterms identified by \ssrN{ident} in all + the occurrences of $\ssrN[2]{term}$ \\ +\hline +$\ssrN[1]{term}\ \ssrC{as}\ \ssrN{ident}\ \ssrC{in}\ \ssrN[2]{term}$ & $\ssrN[1]{term}$ & + in all the subterms identified by \ssrN{ident} in all + the occurrences of $\ssrN[2]{term}[\ssrN[1]{term}/\ssrN{ident}]$\\ +\hline +%\end{tabularx} +\end{tabular} +\end{center} + +The \ssrC{rewrite} tactic supports two more patterns obtained +prefixing the first two with \ssrC{in}. The intended meaning is that the +pattern identifies all subterms of the specified context. The +\ssrC{rewrite} tactic will infer a pattern for the redex looking at the +rule used for rewriting. + +\begin{center} +\begin{tabularx}{\textwidth}{>{\arraybackslash}m{0.30\textwidth}|>{\arraybackslash}m{0.21\textwidth}|>{\arraybackslash}m{0.39\textwidth}} +\ssrN{r-pattern} & redex & subterms affected \\ +\hline +$\ssrC{in}\ {\term}$ & inferred from rule & + in all s.m.r. in all occurrences of {\term}\\ +\hline +$\ssrC{in}\ \ssrN{ident}\ \ssrC{in}\ {\term}$ & inferred from rule & + in all s.m.r. in all the subterms identified by \ssrN{ident} in all + the occurrences of {\term} \\ +\hline +\end{tabularx} +\end{center} + +The first \ssrN{c-pattern} is the simplest form matching any +context but selecting a specific redex and has been described in the +previous sections. We have seen so far that the possibility of +selecting a redex using a term with holes is already a powerful mean of redex +selection. Similarly, any {\term}s provided by the +user in the more complex forms of \ssrN{c-pattern}s presented in the +tables above can contain holes. + +For a quick glance at what can be expressed with the last +\ssrN{r-pattern} consider the goal \ssrC{a = b} and the tactic +\begin{lstlisting} + rewrite [in X in _ = X]rule. +\end{lstlisting} +It rewrites all occurrences of the left hand side of \ssrC{rule} inside +\ssrC{b} only (\ssrC{a}, and the hidden type of the equality, are ignored). +Note that the variant \ssrC{rewrite [X in _ = X]rule} would have +rewritten \ssrC{b} exactly (i.e., it would only work if \ssrC{b} and the +left hand side of \ssrC{rule} can be unified). + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\subsection{Matching contextual patterns} + +The \ssrN{c-pattern}s and \ssrN{r-pattern}s involving +{\term}s with holes are matched +against the goal in order to find a closed instantiation. This +matching proceeds as follows: + +\begin{center} +\begin{tabularx}{\textwidth}{>{\arraybackslash}m{0.30\textwidth}|>{\arraybackslash}m{0.65\textwidth}} +\ssrN{c-pattern} & instantiation order and place for $\ssrN[i]{term}$ and redex\\ +\hline +{\term} & {\term} is matched against the goal, redex is unified with + the instantiation of {\term}\\ +\hline +$\ssrN{ident}\ \ssrC{in}\ {\term}$ & + {\term} is matched against the goal, redex is + unified with the subterm of the + instantiation of {\term} identified by \ssrN{ident}\\ +\hline +$\ssrN[1]{term}\ \ssrC{in}\ \ssrN{ident}\ \ssrC{in}\ \ssrN[2]{term}$ & + $\ssrN[2]{term}$ is matched against the goal, $\ssrN[1]{term}$ is + matched against the subterm of the + instantiation of $\ssrN[1]{term}$ identified by \ssrN{ident}, + redex is unified with the instantiation of $\ssrN[1]{term}$\\ +\hline +$\ssrN[1]{term}\ \ssrC{as}\ \ssrN{ident}\ \ssrC{in}\ \ssrN[2]{term}$ & + $\ssrN[2]{term}[\ssrN[1]{term}/\ssrN{ident}]$ + is matched against the goal, + redex is unified with the instantiation of $\ssrN[1]{term}$\\ +\hline +\end{tabularx} +\end{center} + +In the following patterns, the redex is intended to be inferred from the +rewrite rule. + +\begin{center} +\begin{tabularx}{\textwidth}{>{\arraybackslash}m{0.30\textwidth}|>{\arraybackslash}m{0.65\textwidth}} +\ssrN{r-pattern} & instantiation order and place for $\ssrN[i]{term}$ and redex\\ +\hline +$\ssrC{in}\ \ssrN{ident}\ \ssrC{in}\ {\term}$ & + {\term} is matched against the goal, the redex is + matched against the subterm of the + instantiation of {\term} identified by \ssrN{ident}\\ +\hline +$\ssrC{in}\ {\term}$ & {\term} is matched against the goal, redex is + matched against the instantiation of {\term}\\ +\hline +\end{tabularx} +\end{center} + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\subsection{Examples} + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\subsubsection{Contextual pattern in \ssrC{set} and the \ssrC{:} tactical} + +As already mentioned in section~\ref{ssec:set} the \ssrC{set} tactic +takes as an argument a term in open syntax. This term is interpreted +as the simplest for of \ssrN{c-pattern}. To void confusion in the grammar, +open syntax is supported only for the simplest form of patterns, while + parentheses are required around more complex patterns. + +\begin{lstlisting} +set t := (X in _ = X). +set t := (a + _ in X in _ = X). +\end{lstlisting} + +Given the goal \ssrC{a + b + 1 = b + (a + 1)} the first tactic +captures \ssrC{b + (a + 1)}, while the latter \ssrC{a + 1}. + +Since the user may define an infix notation for \ssrC{in} the former +tactic may result ambiguous. The disambiguation rule implemented is +to prefer patterns over simple terms, but to interpret a pattern with +double parentheses as a simple term. For example +the following tactic would capture any occurrence of the term `\ssrC{a in A}'. + +\begin{lstlisting} +set t := ((a in A)). +\end{lstlisting} + +Contextual pattern can also be used as arguments of the \ssrC{:} tactical. +For example: +\begin{lstlisting} +elim: n (n in _ = n) (refl_equal n). +\end{lstlisting} + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\subsubsection{Contextual patterns in \ssrC{rewrite}} +As a more comprehensive example consider the following goal: +\begin{lstlisting} + (x.+1 + y) + f (x.+1 + y) (z + (x + y).+1) = 0 +\end{lstlisting} +The tactic \ssrC{rewrite [in f _ _]addSn} turns it into: +\begin{lstlisting} + (x.+1 + y) + f (x + y).+1 (z + (x + y).+1) = 0 +\end{lstlisting} +since the simplification rule \ssrC{addSn} is applied only under the \ssrC{f} symbol. +Then we simplify also the first addition and expand \ssrC{0} into \ssrC{0+0}. +\begin{lstlisting} + rewrite addSn -[X in _ = X]addn0. +\end{lstlisting} +obtaining: +\begin{lstlisting} + (x + y).+1 + f (x + y).+1 (z + (x + y).+1) = 0 + 0 +\end{lstlisting} +Note that the right hand side of \ssrC{addn0} is undetermined, but the +rewrite pattern specifies the redex explicitly. The right hand side of +\ssrC{addn0} is unified with the term identified by \ssrC{X}, \ssrC{0} here. + +The following pattern does not specify a redex, since it +identifies an entire region, hence the rewrite rule has to be instantiated +explicitly. Thus the tactic: +\begin{lstlisting} + rewrite -{2}[in X in _ = X](addn0 0). +\end{lstlisting} +changes the goal as follows: +\begin{lstlisting} + (x + y).+1 + f (x + y).+1 (z + (x + y).+1) = 0 + (0 + 0) +\end{lstlisting} +The following tactic is quite tricky: +\begin{lstlisting} + rewrite [_.+1 in X in f _ X](addnC x.+1). +\end{lstlisting} +and the resulting goals is: +\begin{lstlisting} + (x + y).+1 + f (x + y).+1 (z + (y + x.+1)) = 0 + (0 + 0) +\end{lstlisting} +The explicit redex \ssrC{_.+1} is important since its head +constant \ssrC{S} differs from the head constant inferred from +\ssrC{(addnC x.+1)} (that is \ssrC{addn}, denoted \ssrC{+} here). +Moreover, the pattern \ssrC{f _ X} is important to rule out the first occurrence +of \ssrC{(x + y).+1}. Last, only the subterms of \ssrC{f _ X} identified by \ssrC{X} are +rewritten, thus the first argument of \ssrC{f} is skipped too. +Also note the pattern \ssrC{_.+1} is interpreted in the context +identified by \ssrC{X}, thus it gets instantiated to \ssrC{(y + x).+1} and +not \ssrC{(x + y).+1}. + +The last rewrite pattern allows to specify exactly the shape of the term +identified by \ssrC{X}, that is thus unified with the left hand side of the +rewrite rule. +\begin{lstlisting} + rewrite [x.+1 + y as X in f X _]addnC. +\end{lstlisting} +The resulting goal is: +\begin{lstlisting} + (x + y).+1 + f (y + x.+1) (z + (y + x.+1)) = 0 + (0 + 0) +\end{lstlisting} + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\subsection{Patterns for recurrent contexts} + +The user can define shortcuts for recurrent contexts corresponding to the +\ssrN{ident} \ssrC{in} {\term} part. The notation scope identified +with \ssrC{\%pattern} provides a special notation `\ssrC{(X in t)}' the user +must adopt to define context shortcuts. + +The following example is taken from \ssrC{ssreflect.v} where the +\ssrC{LHS} and \ssrC{RHS} shortcuts are defined. + +\begin{lstlisting} +Notation RHS := (X in _ = X)%pattern. +Notation LHS := (X in X = _)%pattern. +\end{lstlisting} + +Shortcuts defined this way can be freely used in place of the +trailing \ssrN{ident} \ssrC{in} {\term} part of any contextual +pattern. +Some examples follow: + +\begin{lstlisting} +set rhs := RHS. +rewrite [in RHS]rule. +case: (a + _ in RHS). +\end{lstlisting} +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\section{Views and reflection}\label{sec:views} + +The bookkeeping facilities presented in section \ref{sec:book} are +crafted to ease simultaneous introductions and generalizations of facts and +casing, +naming $\dots$ operations. It also a common practice to make a stack +operation immediately followed by an \emph{interpretation} of the fact +being pushed, +that is, to apply a lemma to this fact before passing it +to a tactic for decomposition, application and so on. + + +% possibly + +% Small scale reflection consists in using a two levels +% approach locally when developing formal proofs. This means that a +% fact, which may be an assumption, or the goal itself, will often be +% \emph{interpreted} before being passed to a tactic +% for decomposition, application and so on. + +\ssr{} provides a convenient, unified syntax to combine these +interpretation operations with the proof stack operations. This +\emph{view mechanism} relies on the combination of the \ssrC{/} view +switch with bookkeeping tactics and tacticals. + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\subsection{Interpreting eliminations} +\idx{elim/\dots{}} + +The view syntax combined with the \ssrC{elim} tactic specifies an +elimination scheme to +be used instead of the default, generated, one. Hence the \ssr{} tactic: +\begin{lstlisting} + elim/V. +\end{lstlisting} +is a synonym for: +\begin{lstlisting} + intro top; elim top using V; clear top. +\end{lstlisting} +where \ssrC{top} is a fresh name and \ssrC{V} any second-order lemma. + +Since an elimination view supports the two bookkeeping tacticals of +discharge and introduction (see section \ref{sec:book}), the \ssr{} tactic: +\begin{lstlisting} + elim/V: x => y. +\end{lstlisting} +is a synonym for: +\begin{lstlisting} + elim x using V; clear x; intro y. +\end{lstlisting} +where \ssrC{x} is a variable in the context, \ssrC{y} a fresh name and \ssrC{V} +any second order lemma; \ssr{} relaxes the syntactic restrictions of +the \Coq{} \ssrC{elim}. The first pattern following \ssrC{:} can be a \ssrC{_} +wildcard if the conclusion of the view \ssrC{V} specifies a pattern for +its last argument (e.g., if \ssrC{V} is a functional induction lemma +generated by the \ssrC{Function} command). + +The elimination view mechanism is compatible with the equation name +generation (see section \ref{ssec:equations}). + +The following script illustrate a toy example of this feature. Let us +define a function adding an element at the end of a list: +\begin{lstlisting} + Require Import List. + + Variable d : Type. + + Fixpoint |*add_last*|(s : list d) (z : d) {struct s} : list d := + match s with + | nil => z :: nil + | cons x s' => cons x (add_last s' z) + end. +\end{lstlisting} + +One can define an alternative, reversed, induction principle on inductively +defined \ssrC{list}s, by proving the following lemma: + +\begin{lstlisting} + Lemma |*last_ind_list*| : forall (P : list d -> Type), + P nil -> + (forall (s : list d) (x : d), P s -> P (add_last s x)) -> forall s : list d, P s. +\end{lstlisting} + +Then the combination of elimination views with equation names result +in a concise syntax for reasoning inductively using the user +defined elimination scheme. The script: +\begin{lstlisting} + Goal forall (x : d)(l : list d), l = l. + move=> x l. + elim/last_ind_list E : l=> [| u v]; last first. +\end{lstlisting} +generates two subgoals: the first one to prove \ssrC{nil = nil} in a +context featuring \ssrC{E : l = nil} and the second to prove +\ssrC{add_last u v = add_last u v}, in a context containing +\ssrC{E : l = add_last u v}. + +User provided eliminators (potentially generated with the +\ssrC{Function} \Coq{}'s command) can be combined with the type family switches +described in section~\ref{ssec:typefam}. Consider an eliminator +\ssrC{foo_ind} of type: + + \ssrC{foo_ind : forall $\dots$, forall x : T, P p$_1$ $\dots$ p$_m$} + +and consider the tactic + + \ssrC{elim/foo_ind: e$_1$ $\dots$ / e$_n$} + +The \ssrC{elim/} tactic distinguishes two cases: +\begin{description} +\item[truncated eliminator] when \ssrC{x} does not occur in \ssrC{P p$_1 \dots$ p$_m$} + and the type of \ssrC{e$_n$} unifies with \ssrC{T} and \ssrC{e$_n$} is not \ssrC{_}. + In that case, \ssrC{e$_n$} is passed to the eliminator as the last argument + (\ssrC{x} in \ssrC{foo_ind}) and \ssrC{e$_{n-1} \dots$ e$_1$} are used as patterns + to select in the goal the occurrences that will be bound by the + predicate \ssrC{P}, thus it must be possible to unify the sub-term of + the goal matched by \ssrC{e$_{n-1}$} with \ssrC{p$_m$}, the one matched by + \ssrC{e$_{n-2}$} with \ssrC{p$_{m-1}$} and so on. +\item[regular eliminator] in all the other cases. Here it must be + possible to unify the term matched by + \ssrC{e$_n$} with \ssrC{p$_m$}, the one matched by + \ssrC{e$_{n-1}$} with \ssrC{p$_{m-1}$} and so on. Note that + standard eliminators have the shape \ssrC{$\dots$forall x, P $\dots$ x}, thus + \ssrC{e$_n$} is the pattern identifying the eliminated term, as expected. +\end{description} +As explained in section~\ref{ssec:typefam}, the initial prefix of +\ssrC{e$_i$} can be omitted. + +Here an example of a regular, but non trivial, eliminator: +\begin{lstlisting} + Function |*plus*| (m n : nat) {struct n} : nat := + match n with 0 => m | S p => S (plus m p) end. +\end{lstlisting} +The type of \ssrC{plus_ind} is +\begin{lstlisting} +plus_ind : forall (m : nat) (P : nat -> nat -> Prop), + (forall n : nat, n = 0 -> P 0 m) -> + (forall n p : nat, n = p.+1 -> P p (plus m p) -> P p.+1 (plus m p).+1) -> + forall n : nat, P n (plus m n) +\end{lstlisting} +Consider the following goal +\begin{lstlisting} + Lemma |*exF*| x y z: plus (plus x y) z = plus x (plus y z). +\end{lstlisting} +The following tactics are all valid and perform the same elimination +on that goal. +\begin{lstlisting} + elim/plus_ind: z / (plus _ z). + elim/plus_ind: {z}(plus _ z). + elim/plus_ind: {z}_. + elim/plus_ind: z / _. +\end{lstlisting} +In the two latter examples, being the user provided pattern a wildcard, the +pattern inferred from the type of the eliminator is used instead. For both +cases it is \ssrC{(plus _ _)} and matches the subterm \ssrC{plus (plus x y)$\;$z} thus +instantiating the latter \ssrC{_} with \ssrC{z}. Note that the tactic +\ssrC{elim/plus_ind: y / _} would have resulted in an error, since \ssrC{y} and \ssrC{z} +do no unify but the type of the eliminator requires the second argument of +\ssrC{P} to be the same as the second argument of \ssrC{plus} in the second +argument of \ssrC{P}. + +Here an example of a truncated eliminator. Consider the goal +\begin{lstlisting} + p : nat_eqType + n : nat + n_gt0 : 0 < n + pr_p : prime p + ================= + p %| \prod_(i <- prime_decomp n | i \in prime_decomp n) i.1 ^ i.2 -> + exists2 x : nat * nat, x \in prime_decomp n & p = x.1 +\end{lstlisting} +and the tactic +\begin{lstlisting} +elim/big_prop: _ => [| u v IHu IHv | [q e] /=]. +\end{lstlisting} +where the type of the eliminator is +\begin{lstlisting} +big_prop: forall (R : Type) (Pb : R -> Type) (idx : R) (op1 : R -> R -> R), + Pb idx -> + (forall x y : R, Pb x -> Pb y -> Pb (op1 x y)) -> + forall (I : Type) (r : seq I) (P : pred I) (F : I -> R), + (forall i : I, P i -> Pb (F i)) -> + Pb (\big[op1/idx]_(i <- r | P i) F i) +\end{lstlisting} +Since the pattern for the argument of \ssrC{Pb} is not specified, the inferred one +is used instead: \ssrC{(\\big[_/_]_(i <- _ | _ i) _ i)}, and after the +introductions, the following goals are generated. +\begin{lstlisting} +subgoal 1 is: + p %| 1 -> exists2 x : nat * nat, x \in prime_decomp n & p = x.1 +subgoal 2 is: + p %| u * v -> exists2 x : nat * nat, x \in prime_decomp n & p = x.1 +subgoal 3 is: + (q, e) \in prime_decomp n -> p %| q ^ e -> + exists2 x : nat * nat, x \in prime_decomp n & p = x.1 +\end{lstlisting} +Note that the pattern matching algorithm instantiated all the variables +occurring in the pattern. + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\subsection{Interpreting assumptions}\label{ssec:assumpinterp} +\idx{move/\dots{}} + +Interpreting an assumption in the context of a proof is applying it a +correspondence lemma before generalizing, and/or decomposing it. +For instance, with the extensive use of boolean reflection (see +section \ref{ssec:boolrefl}), it is +quite frequent to need to decompose the logical interpretation of (the +boolean expression of) a +fact, rather than the fact itself. +This can be achieved by a combination of \ssrC{move : _ => _} +switches, like in the following script, where \ssrC{||} is a notation for +the boolean disjunction: +\begin{lstlisting} + Variables P Q : bool -> Prop. + Hypothesis |*P2Q*| : forall a b, P (a || b) -> Q a. + + Goal forall a, P (a || a) -> True. + move=> a HPa; move: {HPa}(P2Q _ _ HPa) => HQa. +\end{lstlisting} +which transforms the hypothesis \ssrC{HPn : P n} which has been +introduced from the initial statement into \ssrC{HQn : Q n}. +This operation is so common that the tactic shell has +specific syntax for it. +The following scripts: +\begin{lstlisting} + Goal forall a, P (a || a) -> True. + move=> a HPa; move/P2Q: HPa => HQa. +\end{lstlisting} +or more directly: +\begin{lstlisting} + Goal forall a, P (a || a) -> True. + move=> a; move/P2Q=> HQa. +\end{lstlisting} +are equivalent to the former one. The former script shows how to +interpret a fact (already in the context), thanks to the discharge +tactical (see section \ref{ssec:discharge}) and the latter, how to +interpret the top assumption of a goal. Note +that the number of wildcards to be inserted to find the correct +application of the view lemma to the hypothesis has been automatically +inferred. + +The view mechanism is compatible with the \ssrC{case} tactic and with the +equation name generation mechanism (see section \ref{ssec:equations}): +\begin{lstlisting} + Variables P Q: bool -> Prop. + Hypothesis |*Q2P*| : forall a b, Q (a || b) -> P a \/ P b. + + Goal forall a b, Q (a || b) -> True. + move=> a b; case/Q2P=> [HPa | HPb]. +\end{lstlisting} +creates two new subgoals whose contexts no more contain +\ssrC{HQ : Q (a || b)} but respectively \ssrC{HPa : P a} and +\ssrC{HPb : P b}. This view tactic +performs: +\begin{lstlisting} + move=> a b HQ; case: {HQ}(Q2P _ _ HQ) => [HPa | HPb]. +\end{lstlisting} + +The term on the right of the \ssrC{/} view switch is called a \emph{view + lemma}. Any \ssr{} term coercing to a product type can be used as a +view lemma. + + +The examples we have given so far explicitly provide the direction of the +translation to be performed. In fact, view lemmas need not to be +oriented. The view mechanism is able to detect which +application is relevant for the current goal. For instance, the +script: +\begin{lstlisting} + Variables P Q: bool -> Prop. + Hypothesis |*PQequiv*| : forall a b, P (a || b) <-> Q a. + + Goal forall a b, P (a || b) -> True. + move=> a b; move/PQequiv=> HQab. +\end{lstlisting} +has the same behavior as the first example above. + +The view mechanism can insert automatically a \emph{view hint} to +transform the double implication into the expected simple implication. +The last script is in fact equivalent to: +\begin{lstlisting} + Goal forall a b, P (a || b) -> True. + move=> a b; move/(iffLR (PQequiv _ _)). +\end{lstlisting} +where: +\begin{lstlisting} + Lemma |*iffLR*| : forall P Q, (P <-> Q) -> P -> Q. +\end{lstlisting} + + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\subsubsection*{Specializing assumptions} +\idx{move/\dots{}} + +The special case when the \emph{head symbol} of the view lemma is a +wildcard is used to interpret an assumption by \emph{specializing} +it. The view mechanism hence offers the possibility to +apply a higher-order assumption to some given arguments. + +For example, the script: +\begin{lstlisting} + Goal forall z, (forall x y, x + y = z -> z = x) -> z = 0. + move=> z; move/(_ 0 z). +\end{lstlisting} +changes the goal into: +\begin{lstlisting} + (0 + z = z -> z = 0) -> z = 0 +\end{lstlisting} + + + + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\subsection{Interpreting goals}\label{ssec:goalinterp} + +In a similar way, it is also often convenient to interpret a goal by changing +it into an equivalent proposition. The view mechanism of \ssr{} has a +special syntax \ssrC{apply/} for combining simultaneous goal +interpretation operations and +bookkeeping steps in a single tactic. + +With the hypotheses of section \ref{ssec:assumpinterp}, the following +script, where \ssrL+~~+ denotes the boolean negation: +\begin{lstlisting} + Goal forall a, P ((~~ a) || a). + move=> a; apply/PQequiv. +\end{lstlisting} +transforms the goal into \ssrC{Q (~~ a)}, and is equivalent to: +\begin{lstlisting} + Goal forall a, P ((~~ a) || a). + move=> a; apply: (iffRL (PQequiv _ _)). +\end{lstlisting} +where \ssrC{iffLR} is the analogous of \ssrC{iffRL} for the converse +implication. + +Any \ssr{} term whose type coerces to a double implication can be used +as a view for goal interpretation. + +Note that the goal interpretation view mechanism supports both +\ssrC{apply} and \ssrC{exact} tactics. As expected, a goal interpretation +view command \ssrC{exact/$term$} should solve the current goal or it will +fail. + + +\emph{Warning} Goal interpretation view tactics are \emph{not} compatible +with the bookkeeping tactical \ssrC{=>} since this would be redundant with +the \ssrC{apply:} {\term} \ssrC{=> _} construction. + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\subsection{Boolean reflection}\label{ssec:boolrefl} +In the Calculus of Inductive Construction, there is +an obvious distinction between logical propositions and boolean values. +On the one hand, logical propositions are objects +of \emph{sort} \ssrC{Prop} which is the carrier of intuitionistic +reasoning. Logical connectives in \ssrC{Prop} are \emph{types}, which give precise +information on the structure of their proofs; this information is +automatically exploited by \Coq{} tactics. For example, \Coq{} knows that a +proof of \ssrL+A \/ B+ is either a proof of \ssrC{A} or a proof of \ssrC{B}. +The tactics \ssrC{left} and \ssrC{right} change the goal \ssrL+A \/ B+ +to \ssrC{A} and \ssrC{B}, respectively; dualy, the tactic \ssrC{case} reduces the goal +\ssrL+A \/ B => G+ to two subgoals \ssrC{A => G} and \ssrC{B => G}. + +On the other hand, \ssrC{bool} is an inductive \emph{datatype} +with two constructors \ssrC{true} and \ssrC{false}. +Logical connectives on \ssrC{bool} are \emph{computable functions}, defined by +their truth tables, using case analysis: +\begin{lstlisting} + Definition (b1 || b2) := if b1 then true else b2. +\end{lstlisting} +Properties of such connectives are also established using case +analysis: the tactic \ssrC{by case: b} solves the goal +\begin{lstlisting} + b || ~~ b = true +\end{lstlisting} +by replacing \ssrC{b} first by \ssrC{true} and then by \ssrC{false}; in either case, +the resulting subgoal reduces by computation to the trivial +\ssrC{true = true}. + +Thus, \ssrC{Prop} and \ssrC{bool} are truly complementary: the former +supports robust natural deduction, the latter allows brute-force +evaluation. +\ssr{} supplies +a generic mechanism to have the best of the two worlds and move freely +from a propositional version of a +decidable predicate to its boolean version. + +First, booleans are injected into propositions +using the coercion mechanism: +\begin{lstlisting} + Coercion |*is_true*| (b : bool) := b = true. +\end{lstlisting} +This allows any boolean formula~\ssrC{b} to be used in a context +where \Coq{} would expect a proposition, e.g., after \ssrC{Lemma $\dots$ : }. +It is then interpreted as \ssrC{(is_true b)}, i.e., +the proposition \ssrC{b = true}. Coercions are elided by the pretty-printer, +so they are essentially transparent to the user. + + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\subsection{The \ssrC{reflect} predicate}\label{ssec:reflpred} + +To get all the benefits of the boolean reflection, it is in fact +convenient to introduce the following inductive predicate +\ssrC{reflect} to relate propositions and booleans: + +\begin{lstlisting} + Inductive |*reflect*| (P: Prop): bool -> Type := + | Reflect_true: P => reflect P true + | Reflect_false: ~P => reflect P false. +\end{lstlisting} + +The statement \ssrC{(reflect P b)} asserts that \ssrC{(is_true b)} +and \ssrC{P} are logically equivalent propositions. + +For instance, the following lemma: +\begin{lstlisting} + Lemma |*andP*|: forall b1 b2, reflect (b1 /\ b2) (b1 && b2). +\end{lstlisting} +relates the boolean conjunction \ssrC{&&} to +the logical one \ssrL+/\+. +Note that in \ssrC{andP}, \ssrC{b1} and \ssrC{b2} are two boolean variables and +the proposition \ssrL+b1 /\ b2+ hides two coercions. +The conjunction of \ssrC{b1} and \ssrC{b2} can then be viewed +as \ssrL+b1 /\ b2+ or as \ssrC{b1 && b2}. + + +Expressing logical equivalences through this family of inductive types +makes possible to take benefit from \emph{rewritable equations} +associated to the case analysis of \Coq{}'s inductive types. + +Since the equivalence predicate is defined in \Coq{} as: +\begin{lstlisting} + Definition |*iff*| (A B:Prop) := (A -> B) /\ (B -> A). +\end{lstlisting} +where \ssrC{/\\} is a notation for \ssrC{and}: +\begin{lstlisting} + Inductive |*and*| (A B:Prop) : Prop := + conj : A -> B -> and A B +\end{lstlisting} + +This make case analysis very different according to the way an +equivalence property has been defined. + + +For instance, if we have proved the lemma: +\begin{lstlisting} + Lemma |*andE*|: forall b1 b2, (b1 /\ b2) <-> (b1 && b2). +\end{lstlisting} +let us compare the respective behaviours of \ssrC{andE} and \ssrC{andP} on a +goal: +\begin{lstlisting} + Goal forall b1 b2, if (b1 && b2) then b1 else ~~(b1||b2). +\end{lstlisting} + +The command: +\begin{lstlisting} + move=> b1 b2; case (@andE b1 b2). +\end{lstlisting} +generates a single subgoal: +\begin{lstlisting} + (b1 && b2 -> b1 /\ b2) -> (b1 /\ b2 -> b1 && b2) -> + if b1 && b2 then b1 else ~~ (b1 || b2) +\end{lstlisting} + +while the command: +\begin{lstlisting} + move=> b1 b2; case (@andP b1 b2). +\end{lstlisting} +generates two subgoals, respectively \ssrL+b1 /\ b2 -> b1+ and +\ssrL+~ (b1 /\ b2) -> ~~ (b1 || b2)+. + + + +Expressing reflection relation through the \ssrC{reflect} predicate +is hence a very convenient way to deal with classical reasoning, by +case analysis. Using the \ssrC{reflect} predicate allows moreover to +program rich specifications inside +its two constructors, which will be automatically taken into account +during destruction. This formalisation style gives far more +efficient specifications than quantified (double) implications. + + +A naming convention in \ssr{} is to postfix the name of view lemmas with \ssrC{P}. +For example, \ssrC{orP} relates \ssrC{||} and \ssrL+\/+, \ssrC{negP} relates +\ssrL+~~+ and \ssrL+~+. + +The view mechanism is compatible with \ssrC{reflect} predicates. + +For example, the script +\begin{lstlisting} + Goal forall a b : bool, a -> b -> a /\\ b. + move=> a b Ha Hb; apply/andP. +\end{lstlisting} +changes the goal \ssrL+a /\ b+ to \ssrC{a && b} (see section \ref{ssec:goalinterp}). + +Conversely, the script +\begin{lstlisting} + Goal forall a b : bool, a /\ b -> a. + move=> a b; move/andP. +\end{lstlisting} +changes the goal \ssrL+a /\ b -> a+ into \ssrC{a && b -> a} (see section +\ref{ssec:assumpinterp}). + + +The same tactics can also be used to perform the converse +operation, changing a boolean conjunction into a logical one. The view +mechanism guesses the direction of the +transformation to be used i.e., the constructor of the \ssrC{reflect} +predicate which should be chosen. + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\subsection{General mechanism for interpreting goals and assumptions} + + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\subsubsection*{Specializing assumptions} +\idx{move/\dots{}} + +The \ssr{} +tactic: + + \ssrC{move/(_} \ssrN[1]{term} $\dots$ \ssrN[n]{term}\ssrC{)} + +\noindent +is equivalent to the tactic: + + \ssrC{intro top; generalize (top} \ssrN[1]{term} $\dots$ \ssrN[n]{term}\ssrC{); clear top.} + +\noindent +where \ssrC{top} is a fresh name for introducing the top assumption of +the current goal. + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\subsubsection*{Interpreting assumptions} +\label{sssec:hypview} +The general form of an assumption view tactic is: + +\begin{center} + \optional{\ssrC{move} {\optsep} \ssrC{case}} \ssrC{/} \ssrN[0]{term} +\end{center} + +The term \ssrN[0]{term}, called the \emph{view lemma} can be: +\begin{itemize} +\item a (term coercible to a) function; +\item a (possibly quantified) implication; +\item a (possibly quantified) double implication; +\item a (possibly quantified) instance of the \ssrC{reflect} predicate + (see section \ref{ssec:reflpred}). +\end{itemize} + +Let \ssrC{top} be the top assumption in the goal. + +There are three steps in the behaviour of an assumption view tactic: +\begin{itemize} +\item It first introduces \ssrL+top+. +\item If the type of \ssrN[0]{term} is neither a double implication nor + an instance of the \ssrC{reflect} predicate, then the tactic + automatically generalises a term of the form: + +\begin{center} + \ssrC{(}\ssrN[0]{term} \ssrN[1]{term} $\dots$ \ssrN[n]{term}\ssrC{)} +\end{center} + + where the terms \ssrN[1]{term} $\dots$ \ssrN[n]{term} instantiate the + possible quantified variables of \ssrN[0]{term}, in order for + \ssrC{(}\ssrN[0]{term} \ssrN[1]{term} $\dots$ \ssrN[n]{term} \ssrC{top)} to be well typed. +\item If the type of $\ssrN[0]{term}$ is an equivalence, or + an instance of the \ssrC{reflect} predicate, it generalises a term of + the form: + \begin{center} + (\ssrN[vh]{term} (\ssrN[0]{term} \ssrN[1]{term} $\dots$ \ssrN[n]{term})) + \end{center} + where the term \ssrN[vh]{term} inserted is called an + \emph{assumption interpretation view hint}. +\item It finally clears \ssrC{top}. +\end{itemize} +For a \ssrC{case/}\ssrN[0]{term} tactic, the generalisation step is +replaced by a case analysis step. + +\emph{View hints} are declared by the user (see section +\ref{ssec:vhints}) and are stored in the \ssrC{Hint View} database. +The proof engine automatically +detects from the shape of the top assumption \ssrC{top} and of the view +lemma $\ssrN[0]{term}$ provided to the tactic the appropriate view hint in +the database to be inserted. + +If $\ssrN[0]{term}$ is a double implication, then the view hint \ssrC{A} will +be one of the defined view hints for implication. These hints are by +default the ones present in the file {\tt ssreflect.v}: +\begin{lstlisting} + Lemma |*iffLR*| : forall P Q, (P <-> Q) -> P -> Q. +\end{lstlisting} +which transforms a double implication into the left-to-right one, or: +\begin{lstlisting} + Lemma |*iffRL*| : forall P Q, (P <-> Q) -> Q -> P. +\end{lstlisting} +which produces the converse implication. In both cases, the two first +\ssrC{Prop} arguments are implicit. + +If $\ssrN[0]{term}$ is an instance of the \ssrC{reflect} predicate, then \ssrC{A} +will be one of the defined view hints for the \ssrC{reflect} +predicate, which are by +default the ones present in the file {\tt ssrbool.v}. +These hints are not only used for choosing the appropriate direction of +the translation, but they also allow complex transformation, involving +negations. + For instance the hint: +\begin{lstlisting} + Lemma |*introN*| : forall (P : Prop) (b : bool), reflect P b -> ~ P -> ~~ b. +\end{lstlisting} +makes the following script: +\begin{lstlisting} + Goal forall a b : bool, a -> b -> ~~ (a && b). + move=> a b Ha Hb. apply/andP. +\end{lstlisting} +transforms the goal into \ssrC{ \~ (a /\ b)}. +In fact\footnote{The current state of the proof shall be displayed by + the \ssrC{Show Proof} command of \Coq{} proof mode.} +this last script does not exactly use the hint \ssrC{introN}, but the +more general hint: +\begin{lstlisting} + Lemma |*introNTF*| : forall (P : Prop) (b c : bool), + reflect P b -> (if c then ~ P else P) -> ~~ b = c +\end{lstlisting} +The lemma \ssrL+|*introN*|+ is an instantiation of \ssrC{introNF} using + \ssrC{c := true}. + +Note that views, being part of \ssrN{i-pattern}, can be used to interpret +assertions too. For example the following script asserts \ssrC{a \&\& b} +but actually used its propositional interpretation. +\begin{lstlisting} + Lemma |*test*| (a b : bool) (pab : b && a) : b. + have /andP [pa ->] : (a && b) by rewrite andbC. +\end{lstlisting} + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\subsubsection*{Interpreting goals} +\idx{apply/\dots{}} + +A goal interpretation view tactic of the form: + +\begin{center} + \ssrC{apply/} \ssrN[0]{term} +\end{center} +applied to a goal \ssrC{top} is interpreted in the following way: +\begin{itemize} +\item If the type of $\ssrN[0]{term}$ is not an instance of the + \ssrC{reflect} predicate, nor an equivalence, + then the term $\ssrN[0]{term}$ is applied to the current goal \ssrC{top}, + possibly inserting implicit arguments. +\item If the type of $\ssrN[0]{term}$ is an instance of the \ssrC{reflect} + predicate or an equivalence, then +a \emph{goal interpretation view hint} can possibly be inserted, which +corresponds to the application of a term +\ssrC{($\ssrN[vh]{term}$ ($\ssrN[0]{term}$ _ $\dots$ _))} to the current +goal, possibly inserting implicit arguments. +\end{itemize} + +Like assumption interpretation view hints, goal interpretation ones +are user defined lemmas stored (see section \ref{ssec:vhints}) in the +\ssrC{Hint View} database bridging +the possible gap between the type of $\ssrN[0]{term}$ and the type of the +goal. + + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\subsection{Interpreting equivalences} +\idx{apply/\dots{}/\dots{}} + +Equivalent boolean propositions are simply \emph{equal} boolean terms. +A special construction helps the user to prove boolean equalities by +considering them as logical double implications (between their coerced +versions), while +performing at the same time logical operations on both sides. + +The syntax of double views is: +\begin{center} + \ssrC{apply/} \ssrN[l]{term} \ssrC{/} \ssrN[r]{term} +\end{center} + +The term \ssrN[l]{term} is the view lemma applied to the left hand side of the +equality, \ssrN[r]{term} is the one applied to the right hand side. + +In this context, the identity view: +\begin{lstlisting} +Lemma |*idP*| : reflect b1 b1. +\end{lstlisting} +is useful, for example the tactic: +\begin{lstlisting} + apply/idP/idP. +\end{lstlisting} +transforms the goal +\ssrL+~~ (b1 || b2)= b3+ + into two subgoals, respectively + \ssrL+~~ (b1 || b2) -> b3+ and \\ +\ssrL+b3 -> ~~ (b1 || b2).+ + +The same goal can be decomposed in several ways, and the user may +choose the most convenient interpretation. For instance, the tactic: +\begin{lstlisting} + apply/norP/idP. +\end{lstlisting} +applied on the same goal \ssrL+~~ (b1 || b2) = b3+ generates the subgoals +\ssrL+~~ b1 /\ ~~ b2 -> b3+ and\\ +\ssrL+b3 -> ~~ b1 /\ ~~ b2+. + + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\subsection{Declaring new \ssrC{Hint View}s}\label{ssec:vhints} +\idxC{Hint View} + +The database of hints for the view mechanism is extensible via a +dedicated vernacular command. As library {\tt ssrbool.v} already +declares a corpus of hints, this feature is probably useful only for +users who define their own logical connectives. Users can declare +their own hints following the syntax used in {\tt ssrbool.v}: + +\begin{center} + \ssrC{Hint View for} {\tac} \ssrC{/} \ssrN{ident} \optional{\ssrC{|}{\naturalnumber}} +\end{center} + + where {\tac}$\in \{$\ssrC{move, apply}$\}$, \ssrN{ident} is the +name of the lemma to be declared as a hint, and ${\naturalnumber}$ a natural +number. If \ssrL+move+ is used as {\tac}, the hint is declared for +assumption interpretation tactics, \ssrL+apply+ declares hints for goal +interpretations. +Goal interpretation view hints are declared for both simple views and +left hand side views. The optional natural number ${\naturalnumber}$ is the +number of implicit arguments to be considered for the declared hint +view lemma \ssrC{name_of_the_lemma}. + +The command: + +\begin{center} + \ssrC{Hint View for apply//} \ssrN{ident}\optional{\ssrC{|}{\naturalnumber}}. +\end{center} + +with a double slash \ssrL+//+, declares hint views for right hand sides of +double views. + + +\noindent See the files {\tt ssreflect.v} and {\tt ssrbool.v} for examples. + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\subsection{Multiple views}\label{ssec:multiview} + +The hypotheses and the goal can be interpreted applying multiple views in +sequence. Both \ssrC{move} and \ssrC{apply} can be followed by an arbitrary number +of \ssrC{/}$\ssrN[i]{term}$. The main difference between the following two tactics +\begin{lstlisting} + apply/v1/v2/v3. + apply/v1; apply/v2; apply/v3. +\end{lstlisting} +is that the former applies all the views to the principal goal. +Applying a view with hypotheses generates new goals, and the second line +would apply the view \ssrC{v2} to all the goals generated by \ssrC{apply/v1}. +Note that the NO-OP intro pattern \ssrC{-} can be used to separate two +views, making the two following examples equivalent: +\begin{lstlisting} + move=> /v1; move=> /v2. + move=> /v1-/v2. +\end{lstlisting} + +The tactic \ssrC{move} can be used together with the \ssrC{in} +tactical to pass a given hypothesis to a lemma. For example, if +\ssrC{P2Q : P -> Q } and \ssrC{Q2R : Q -> R}, the following +tactic turns the hypothesis \ssrC{p : P} into \ssrC{P : R}. +\begin{lstlisting} + move/P2Q/Q2R in p. +\end{lstlisting} + +If the list of views is of length two, \ssrC{Hint View}s for interpreting +equivalences are indeed taken into account, otherwise only single +\ssrC{Hint View}s are used. +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\section{\ssr{} searching tool} +\idxC{Search \dots{}} + +\ssr{} proposes an extension of the \ssrC{Search} command. Its syntax is: + +\begin{center} + \ssrC{Search} \optional{\ssrN{pattern}} \optional{\optional{\ssrC{\-}} \optional{\ssrN{string}\optional{\ssrC{\%}\ssrN{key}} {\optsep} \ssrN{pattern}}}$^*$ \optional{\ssrC{in} \optional{\optional{\ssrC{\-}} \ssrN{name} }$^+$} +\end{center} + +% \begin{lstlisting} +% Search [[\~]\ssrN{string}]$^*$ [\ssrN{pattern}] [[$\ssrN[1]{pattern} \dots $ $\ssrN[n]{pattern}$]] $[[$inside$|$outside$]$ $M_1 \dots M_n$]. +% \end{lstlisting} + +% This tactic returns the list of defined constants matching the +% given criteria: +% \begin{itemize} +% \item \ssrL+[[-]\ssrN{string}]$^*$+ is an open sequence of strings, which sould +% all appear in the name of the returned constants. The optional \ssrL+-+ +% prefixes strings that are required \emph{not} to appear. +% % \item \ssrN{pattern} should be a subterm of the +% % \emph{conclusion} of the lemmas found by the command. If a lemma features +% % an occurrence +% % of this pattern only in one or several of its assumptions, it will not be +% % selected by the searching tool. +% \item +% \ssrL=[$\ssrN{pattern}^+$]= +% is a list of \ssr{} terms, which may +% include types, that are required to appear in the returned constants. +% Terms with holes should be surrounded by parentheses. +% \item $\ssrC{in}\ [[\ssrC{\-}]M]^+$ limits the search to the signature +% of open modules given in the list, but the ones preceeded by the +% $\ssrC{\-}$ flag. The +% command: +% \begin{lstlisting} +% Search in M. +% \end{lstlisting} +% is hence a way of obtaining the complete signature of the module \ssrL{M}. +% \end{itemize} +where \ssrN{name} is the name of an open module. +This command search returns the list of lemmas: +\begin{itemize} +\item whose \emph{conclusion} contains a subterm matching the optional + first \ssrN{pattern}. A $\ssrC{-}$ reverses the test, producing the list + of lemmas whose conclusion does not contain any subterm matching + the pattern; +\item whose name contains the given string. A $\ssrC{-}$ prefix reverses + the test, producing the list of lemmas whose name does not contain the + string. A string that contains symbols or +is followed by a scope \ssrN{key}, is interpreted as the constant whose +notation involves that string (e.g., \ssrL=+= for \ssrL+addn+), if this is +unambiguous; otherwise the diagnostic includes the output of the +\ssrC{Locate} vernacular command. + +\item whose statement, including assumptions and types, contains a + subterm matching the next patterns. If a pattern is prefixed by + $\ssrC{-}$, the test is reversed; +\item contained in the given list of modules, except the ones in the + modules prefixed by a $\ssrC{-}$. +\end{itemize} + +Note that: +\begin{itemize} +\item As for regular terms, patterns can feature scope + indications. For instance, the command: +\begin{lstlisting} + Search _ (_ + _)%N. +\end{lstlisting} +lists all the lemmas whose statement (conclusion or hypotheses) +involve an application of the binary operation denoted by the infix +\ssrC{+} symbol in the \ssrC{N} scope (which is \ssr{} scope for natural numbers). +\item Patterns with holes should be surrounded by parentheses. +\item Search always volunteers the expansion of the notation, avoiding the + need to execute Locate independently. Moreover, a string fragment + looks for any notation that contains fragment as + a substring. If the \ssrL+ssrbool+ library is imported, the command: +\begin{lstlisting} + Search "~~". +\end{lstlisting} +answers : +\begin{lstlisting} +"~~" is part of notation (~~ _) +In bool_scope, (~~ b) denotes negb b +negbT forall b : bool, b = false -> ~~ b +contra forall c b : bool, (c -> b) -> ~~ b -> ~~ c +introN forall (P : Prop) (b : bool), reflect P b -> ~ P -> ~~ b +\end{lstlisting} + \item A diagnostic is issued if there are different matching notations; + it is an error if all matches are partial. +\item Similarly, a diagnostic warns about multiple interpretations, and + signals an error if there is no default one. +\item The command \ssrC{Search in M.} +is a way of obtaining the complete signature of the module \ssrL{M}. +\item Strings and pattern indications can be interleaved, but the + first indication has a special status if it is a pattern, and only + filters the conclusion of lemmas: +\begin{itemize} + \item The command : + \begin{lstlisting} + Search (_ =1 _) "bij". + \end{lstlisting} +lists all the lemmas whose conclusion features a '$\ssrC{=1}$' and whose +name contains the string \verb+bij+. +\item The command : + \begin{lstlisting} + Search "bij" (_ =1 _). + \end{lstlisting} +lists all the lemmas whose statement, including hypotheses, features a +'$\ssrC{=1}$' and whose name contains the string \verb+bij+. + +\end{itemize} + +\end{itemize} +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\section{Synopsis and Index} + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\subsection*{Parameters} + +\begin{minipage}[c]{\textwidth}\renewcommand{\footnoterule}{} +\begin{longtable}{lcl} +\ssrN{d-tactic} && one of the + \ssrC{elim}, \ssrC{case}, \ssrC{congr}, \ssrC{apply}, \ssrC{exact} + and \ssrC{move} \ssr{} tactics \\ +\ssrN{fix-body} && standard \Coq{} \textit{fix\_body}\\ +\ssrN{ident} && standard \Coq{} identifier\\ +\ssrN{int} && integer literal \\ +\ssrN{key} && notation scope\\ +\ssrN{name} && module name\\ +${\naturalnumber}$ && \ssrN{int} or Ltac variable denoting a standard \Coq{} numeral\footnote{The name of this Ltac variable should not be the name of a tactic which can be followed by a bracket + \ssrL+[+, like \ssrL+do+, \ssrL+ have+,\dots}\\ +\ssrN{pattern} && synonym for {\term}\\ +\ssrN{string} && standard \Coq{} string\\ +{\tac} && standard \Coq{} tactic or \ssr{} tactic\\ +{\term} & \hspace{1cm} & Gallina term, possibly containing wildcards\\ +%\ssrN{view} && global constant\\ +\end{longtable} +\end{minipage} + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\subsection*{Items and switches} + +\begin{longtable}{lclr} +\ssrN{binder} & {\ident} {\optsep} \ssrC{(} {\ident} \optional{\ssrC{:} {\term} } \ssrC{)} & binder& p. \pageref{ssec:pose}\\ +\\ +\ssrN{clear-switch} & \ssrC{\{} {\ident}$^+$ \ssrC{\}} & clear switch & p. \pageref{ssec:discharge}\\ +\\ +\ssrN{c-pattern} & \optional{{\term} \ssrC{in} {\optsep} {\term} \ssrC{as}} {\ident} \ssrC{in} {\term} & context pattern & p. \pageref{ssec:rewp} \\ +\\ +\ssrN{d-item} & \optional{\ssrN{occ-switch} {\optsep} \ssrN{clear-switch}} \optional{{\term} {\optsep} \ssrC{(}\ssrN{c-pattern}\ssrC{)}} & discharge item & p. \pageref{ssec:discharge}\\ +\\ +\ssrN{gen-item} & \optional{\ssrC{@}}{\ident} {\optsep} \ssrC{(}{\ident}\ssrC{)} {\optsep} \ssrC{(}\optional{\ssrC{@}}{\ident} \ssrC{:=} \ssrN{c-pattern}\ssrC{)} & generalization item & p. \pageref{ssec:struct}\\ +\\ +\ssrN{i-pattern} & {\ident} {\optsep} \ssrC{_} {\optsep} \ssrC{?} {\optsep} \ssrC{*} {\optsep} \optional{\ssrN{occ-switch}}\ssrC{->} {\optsep} \optional{\ssrN{occ-switch}}\ssrC{<-} {\optsep} & intro pattern & p. \pageref{ssec:intro}\\ +& \ssrC{[} \ssrN{i-item}$^*$ \ssrC{|} $\dots$ \ssrC{|} \ssrN{i-item}$^*$ \ssrC{]} {\optsep} \ssrC{-} {\optsep} \ssrC{[:} {\ident}$^+$\ssrC{]} &\\ +\\ +\ssrN{i-item} & \ssrN{clear-switch} {\optsep} \ssrN{s-item} {\optsep} \ssrN{i-pattern} {\optsep} \ssrC{/}{\term} & intro item & p. \pageref{ssec:intro}\\ +\\ +\ssrN{int-mult} & \optional{{\naturalnumber}} \ssrN{mult-mark} & multiplier & p. \pageref{ssec:iter}\\ +\\ +\ssrN{occ-switch} & \ssrC{\{} \optional{\ssrC{+} {\optsep} \ssrC{-}} {\naturalnumber}$^*$\ssrC{\}} & occur. switch & p. \pageref{sssec:occselect}\\ +\\ +\ssrN{mult} & \optional{{\naturalnumber}} \ssrN{mult-mark} & multiplier & p. \pageref{ssec:iter}\\ +\\ +\ssrN{mult-mark} & \ssrC{?} {\optsep} \ssrC{!} & multiplier mark & p. \pageref{ssec:iter}\\ +\\ +\ssrN{r-item} & \optional{\ssrC{/}} {\term} {\optsep} \ssrN{s-item} & rewrite item & p. \pageref{ssec:extrw}\\ +\\ +\ssrN{r-prefix} & \optional{\ssrC{-}} \optional{\ssrN{int-mult}} \optional{\ssrN{occ-switch} {\optsep} \ssrN{clear-switch}} \optional{\ssrC{[}\ssrN{r-pattern}\ssrC{]}} & rewrite prefix & p. \pageref{ssec:extrw}\\ +\\ +\ssrN{r-pattern} & {\term} {\optsep} \ssrN{c-pattern} {\optsep} \ssrC{in} \optional{{\ident} \ssrC{in}} {\term} & rewrite pattern & p. \pageref{ssec:extrw}\\ +\\ +\ssrN{r-step} & \optional{\ssrN{r-prefix}}\ssrN{r-item} & rewrite step & p. \pageref{ssec:extrw}\\ +\\ +\ssrN{s-item} & \ssrC{/=} {\optsep} \ssrC{//} {\optsep} \ssrC{//=} & simplify switch & p. \pageref{ssec:intro}\\ +\\ +\end{longtable} + + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\subsection*{Tactics} +\emph{Note}: \ssrC{without loss} and \ssrC{suffices} are synonyms for \ssrC{wlog} and +\ssrC{suff} respectively. + +\begin{longtable}{llr} +\ssrC{move} & \textcolor{dkblue}{\texttt{idtac}} or \ssrC{hnf}& p. \pageref{ssec:profstack} \\ +\ssrC{apply} & application & p. \pageref{ssec:basictac}\\ +\ssrC{exact} &&\\ +\ssrC{abstract} && p. \pageref{ssec:abstract}, \pageref{sec:havetransparent}\\ +\\ +\ssrC{elim} & induction & p. \pageref{ssec:basictac}\\ +\ssrC{case} & case analysis & p. \pageref{ssec:basictac}\\ +\\ +\ssrC{rewrite} \ssrN{rstep}$^+$ & rewrite& p. \pageref{ssec:extrw}\\ +\\ +\ssrC{have} \ssrN{i-item}$^*$ \optional{\ssrN{i-pattern}} \optional{\ssrN{s-item} {\optsep} \ssrN{binder}$^+$} \optional{\ssrC{:} {\term}} \ssrC{:=} {\term} & forward & p. \pageref{ssec:struct}\\ +\ssrC{have} \ssrN{i-item}$^*$ \optional{\ssrN{i-pattern}} \optional{\ssrN{s-item}{\optsep} \ssrN{binder}$^+$} \ssrC{:} {\term} \optional{\ssrC{by} {\tac}} & chaining & \\ +\ssrC{have suff} \optional{\ssrN{clear-switch}} \optional{\ssrN{i-pattern}} \optional{\ssrC{:} {\term}} \ssrC{:=} {\term} & & \\ +\ssrC{have suff} \optional{\ssrN{clear-switch}} \optional{\ssrN{i-pattern}} \ssrC{:} {\term} \optional{\ssrC{by} {\tac}} & & \\ +\ssrC{gen have} \optional{{\ident}\ssrC{,}} \optional{\ssrN{i-pattern}} \ssrC{:} \ssrN{gen-item}$^+$ \ssrC{/} {\term} \optional{\ssrC{by} {\tac}} & & \\ +\\ +\ssrC{wlog} \optional{\ssrC{suff}} \optional{\ssrN{i-item}} \ssrC{:} \optional{\ssrN{gen-item}{\optsep} \ssrN{clear-switch}}$^*$ \ssrC{/} {\term} & specializing & p. \pageref{ssec:struct} \\ +\\ +\ssrC{suff} \ssrN{i-item}$^*$ \optional{\ssrN{i-pattern}} \optional{\ssrN{binder}$^+$} \ssrC{:} {\term} \optional{\ssrC{by} {\tac}} & backchaining & p. \pageref{ssec:struct}\\ +\ssrC{suff} \optional{\ssrC{have}} \optional{\ssrN{clear-switch}} \optional{\ssrN{i-pattern}} \ssrC{:} {\term} \optional{\ssrC{by} {\tac}} & & \\ +\\ +\ssrC{pose} {\ident} \ssrC{:=} {\term} & local definition& p. \pageref{ssec:pose}\\ +\ssrC{pose} {\ident} \ssrN{binder}$^+$ \ssrC{:=} {\term} & \rlap{local function definition}& \\ +\ssrC{pose fix} \ssrN{fix-body} & \rlap{local fix definition} & \\ +\ssrC{pose cofix} \ssrN{fix-body} & \rlap{local cofix definition} & \\ +\\ +\ssrC{set} {\ident} \optional{\ssrC{:} {\term}} \ssrC{:=} \optional{\ssrN{occ-switch}} \optional{{\term}{\optsep} \ssrC{(}\ssrN{c-pattern}\ssrC{)}} & abbreviation&p. \pageref{ssec:set}\\ +\\ +\ssrC{unlock} \optional{\ssrN{r-prefix}]{\ident}}$^*$ & unlock & p. \pageref{ssec:lock}\\ +\\ +\ssrC{congr} \optional{\naturalnumber} {\term} & congruence& p. \pageref{ssec:congr}\\ +\end{longtable} + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\subsection*{Tacticals} + +\begin{longtable}{lclr} +\ssrN{d-tactic} \optional{\ident} \ssrC{:} \ssrN{d-item}$^{+}$ \optional{\ssrN{clear-switch}} & & discharge & p. \pageref{ssec:discharge}\\ +\\ +{\tac} \ssrC{=>} \ssrN{i-item}$^+$ && introduction & p. \pageref{ssec:intro}\\ +\\ +{\tac} \ssrC{in} \optional{\ssrN{gen-item} {\optsep} \ssrN{clear-switch}}$^+$ \optional{\ssrC{*}} && localization & p. \pageref{ssec:gloc}\\ +\\ +\ssrC{do} \optional{\ssrN{mult}} \ssrC{[} \nelist{\tac}{|} \ssrC{]}&& iteration & p. \pageref{ssec:iter}\\ +\ssrC{do} \ssrN{mult} {\tac} &&& \\ +\\ +{\tac} \ssrC{ ; first} \optional{\naturalnumber} \ssrC{[}\nelist{\tac}{|}\ssrC{]} && selector & p. \pageref{ssec:select}\\ +{\tac} \ssrC{ ; last} \optional{\naturalnumber} \ssrC{[}\nelist{\tac}{|}\ssrC{]} \\ +{\tac} \ssrC{ ; first} \optional{\naturalnumber} \ssrC{last} && subgoals & p. \pageref{ssec:select}\\ +{\tac} \ssrC{; last} \optional{\naturalnumber} \ssrC{first} && rotation & \\ +\\ +\ssrC{by [} \nelist{\tac}{|} \ssrC{]} && closing & p. \pageref{ssec:termin}\\ +\ssrC{by []} \\ +\ssrC{by} {\tac} \\ +\end{longtable} + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\subsection*{Commands} +\begin{longtable}{lclr} +\ssrL+Hint View for+ \optional{\ssrL+move+ {\it |} \ssrL+apply+} {\tt /} {\ident} \optional{{\tt|} {\naturalnumber}} && view hint +declaration & p. \pageref{ssec:vhints}\\ +\\ +\ssrL+Hint View for apply//+ {\ident} \optional{{\tt|}{\naturalnumber}} && right hand side double + & p. \pageref{ssec:vhints}\\ +&& view hint declaration &\\ +\\ +%\ssrL+Import Prenex Implicits+ && enable prenex implicits & +%p. \pageref{ssec:parampoly}\\ +%\\ +\ssrL+Prenex Implicits+ {\ident}$^+$ & \hspace{.6cm} & prenex implicits decl. + & p. \pageref{ssec:parampoly}\\ + +\end{longtable} + +\iffalse + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\section{Changes} + +\subsection{\ssr{} version 1.3} +All changes are retrocompatible extensions but for: +\begin{itemize} +\item Occurrences in the type family switch now refer only to the goal, while + before they used to refer also to the types in the abstractions of the + predicate used by the eliminator. This bug used to affect lemmas like + \ssrC{boolP}. See the relative comments in \ssrC{ssrbool.v}. +\item Clear switches can only mention existing hypothesis and + otherwise fail. This can in particular affect intro patterns + simultaneously applied to several goals. + % commit: 2686 +\item A bug in the \ssrC{rewrite} tactic allowed to + instantiate existential metavariables occurring in the goal. + This is not the case any longer (see section~\ref{ssec:rewcaveats}). +\item The \ssrC{fold} and \ssrC{unfold} \ssrN{r-items} for \ssrC{rewrite} used to + fail silently when used in combination with a \ssrN{r-pattern} matching no + goal subterm. They now fail. The old behavior can be obtained using + the \ssrC{?} multiplier (see section~\ref{ssec:extrw}). +\item \Coq{} 8.2 users with a statically linked toplevel must comment out the\\ + \ssrC{Declare ML Module "ssreflect".}\\ + line at the beginning of \ssrC{ssreflect.v} to compile the 1.3 library. +\end{itemize} +New features: +\begin{itemize} +\item Contextual \ssrC{rewrite} patterns. + The context surrounding the redex can now be used to specify which + redex occurrences should be rewritten (see section~\ref{ssec:rewp}).\\ + \ssrC{rewrite [in X in _ = X]addnC.} + % commit: 2690, 2689, 2718, 2733 +\item Proof irrelevant interpretation of goals with existential metavariables. + Goals containing an existential metavariable of sort \ssrC{Prop} are + generalized over it, and a new goal for the missing subproof is + generated (see page~\pageref{sssec:apply} and + section~\ref{ssec:rewcaveats}).\\ + \ssrC{apply: (ex_intro _ (@Ordinal _ y _)).}\\ + \ssrC{rewrite insubT.} + % commit: 2553, 2544, 2543, 2733 +\item Views are now part of \ssrN{i-pattern} and can thus be used + inside intro patterns (see section~\ref{ssec:intro}).\\ + \ssrC{move=> a b /andP [Ha Hb].} + % commit: 2720 +\item Multiple views for \ssrC{move}, \ssrC{move $\dots$ in} and \ssrC{apply} + (see section~\ref{ssec:multiview}).\\ + \ssrC{move/v1/v2/v3.}\\ + \ssrC{move/v1/v2/v3 in H.}\\ + \ssrC{apply/v1/v2/v3.} + % commit: 2720 +\item \ssrC{have} and \ssrC{suff} idiom with view (see section~\ref{sssec:hypview}). +\begin{lstlisting} + Lemma |*test*| (a b : bool) (pab : a && b) : b. + have {pab} /= /andP [pa ->] // : true && (a && b) := pab. +\end{lstlisting} + % commit: 2726 +\item \ssrC{have suff}, \ssrC{suff have} and \ssrC{wlog suff} forward reasoning + tactics (see section~\ref{ssec:struct}).\\ + \ssrC{have suff H : P.} + % commit: 2633 +\item Binders support in \ssrC{have} (see section~\ref{sssec:have}).\\ + \ssrC{have H x y (r : R x y) : P x -> Q y.} + % commit: 2633 +\item Deferred clear switches. Clears are deferred to the end of the + intro pattern. In the meanwhile, cleared variables are still + part of the context, thus the goal can mention them, but are + renamed to non accessible dummy names (see section~\ref{ssec:intro}).\\ + \ssrC{suff: G \\x H = K; first case/dprodP=> \{G H\} [[G H -> -> defK]].} + % commit: 2660 +\item Relaxed alternation condition in intro patterns. The + \ssrN{i-item} grammar rule is simplified (see section~\ref{ssec:intro}).\\ + \ssrC{move=> a \{H\} /= \{H1\} // b c /= \{H2\}.} + % commit: 2713 +\item Occurrence selection for \ssrC{->} and \ssrC{<-} intro pattern + (see section~\ref{ssec:intro}).\\ + \ssrC{move=> a b H \{2\}->.} + % commit: 2714 +\item Modifiers for the discharging '\ssrC{:}' and \ssrC{in} tactical to override + the default behavior when dealing with local definitions (let-in): + \ssrC{@f} forces the body of \ssrC{f} to be kept, \ssrC{(f)} forces the body of + \ssrC{f} to be dropped (see sections~\ref{ssec:discharge} + and~\ref{ssec:gloc}).\\ + \ssrC{move: x y @f z.}\\ + \ssrC{rewrite rule in (f) $\;\;$H.} + %commit: 2659, 2710 +\item Type family switch in \ssrC{elim} and \ssrC{case} + can contain patterns with occurrence switch + (see section~\ref{ssec:typefam}).\\ + \ssrC{case: \{2\}(_ == x) / eqP.} + % commit: 2593, 2598, 2539, 2538, 2527, 2529 +\item Generic second order predicate support for \ssrC{elim} + (see section~\ref{sec:views}).\\ + \ssrC{elim/big\_prop: _} + % commit: 2767 +\item The \ssrC{congr} tactic now also works on products (see + section~\ref{ssec:congr}). +\begin{lstlisting} + Lemma |*test*| x (H : P x) : P y. + congr (P _): H. +\end{lstlisting} + % commit: 2608 +\item Selectors now support Ltac variables + (see section~\ref{ssec:select}).\\ + \ssrC{let n := 3 in tac; first n last.} + % commit: 2725 +\item Deprecated use of \ssrC{Import Prenex Implicits} directive. + It must be replaced with the \Coq{} \ssrC{Unset Printing + Implicit Defensive} vernacular command. +\item New synonym \ssrC{Canonical} for \ssrC{Canonical Structure}. +\end{itemize} +\subsection{\ssr{} version 1.4} +New features: +\begin{itemize} +\item User definable recurrent contexts (see section~\ref{ssec:rewp}).\\ + \ssrC{Notation RHS := (X in _ = X)\%pattern} +\item Contextual patterns in + \ssrC{set} and `\ssrC{:}' (see section~\ref{ssec:rewp}).\\ + \ssrC{set t := (a + _ in RHS)} +\item NO-OP intro pattern (see section~\ref{ssec:intro}).\\ + \ssrC{move=> /eqP-H /fooP-/barP} +\item \ssrC{if $\ {\term}\ $ isn't $\ \ssrN{pattern}\ $ then $\ {\term}\ $ + else $\ {\term}\ $} notation (see section~\ref{ssec:patcond}).\\ + \ssrC{if x isn't Some y then simple else complex y} +\end{itemize} +\subsection{\ssr{} version 1.5} +Incompatibilities: +\begin{itemize} +\item The \ssrC{have} tactic now performs type classes resolution. The old + behavior can be restored with \ssrC{Set SsrHave NoTCResolution} +\end{itemize} +Fixes: +\begin{itemize} +\item The \ssrC{let foo := type of t in} syntax of standard \ssrC{Ltac} has + been made compatible with \ssr{} and can be freely used even if + the \ssr{} plugin is loaded +\end{itemize} +New features: +\begin{itemize} +\item Generalizations supported in have (see section~\ref{ssec:struct}).\\ + \ssrC{generally have hx2px, pa : a ha / P a.} +\item Renaming and patterns in wlog (see section~\ref{ssec:struct} and + page \pageref{par:advancedgen}).\\ + \ssrC{wlog H : (n := m)$\;$ (x := m + _)$\;$ / T x}.\\ + \ssrC{wlog H : (n := m)$\;$ (@ldef := secdef m)$\;$ / T x}. +\item Renaming, patterns and clear switches in \ssrC{in} + tactical (see section~\ref{ssec:gloc}).\\ + \ssrC{$\dots$ in H1 \{H2\} (n := m).} +\item Handling of type classes in \ssrC{have} + (see page~\pageref{ssec:havetcresolution}).\\ + \ssrC{have foo : ty. (* TC inference for ty *)}\\ + \ssrC{have foo : ty := . (* no TC inference for ty *)}\\ + \ssrC{have foo : ty := t. (* no TC inference for ty and t *)}\\ + \ssrC{have foo := t. (* no TC inference for t *)} +\item Transparent flag for \ssrC{have} to generate a \ssrC{let in} context entry + (see page~\pageref{sec:havetransparent}).\\ + \ssrC{have @i : 'I\_n by apply: (Sub m); auto.} +\item Intro pattern \ssrC{[: foo bar ]} to create abstract variables + (see page~\pageref{ssec:introabstract}). +\item Tactic \ssrC{abstract:} to assign an abstract variable + (see page~\pageref{ssec:abstract}).\\ + \ssrC{have [: blurb ] @i : 'I\_n by apply: (Sub m); abstract: blurb; auto.}\\ + \ssrC{have [: blurb ] i : 'I\_n := Sub m blurb; first by auto.} + +\end{itemize} + +\fi diff --git a/doc/refman/RefMan-syn.tex b/doc/refman/RefMan-syn.tex index 084317776..d8a353300 100644 --- a/doc/refman/RefMan-syn.tex +++ b/doc/refman/RefMan-syn.tex @@ -980,7 +980,7 @@ delimited by key {\tt nat}, and bound to the type {\tt nat} (see \ref{bindscope} This scope includes the standard arithmetical operators and relations on type {\tt N} (binary natural numbers). It is delimited by key {\tt N} -and comes with an interpretation for numerals as closed term of type {\tt Z}. +and comes with an interpretation for numerals as closed term of type {\tt N}. \subsubsection{\tt Z\_scope} @@ -1014,16 +1014,8 @@ fractions of an integer and a strictly positive integer. This scope includes the standard arithmetical operators and relations on type {\tt R} (axiomatic real numbers). It is delimited by key {\tt R} -and comes with an interpretation for numerals as term of type {\tt -R}. The interpretation is based on the binary decomposition. The -numeral 2 is represented by $1+1$. The interpretation $\phi(n)$ of an -odd positive numerals greater $n$ than 3 is {\tt 1+(1+1)*$\phi((n-1)/2)$}. -The interpretation $\phi(n)$ of an even positive numerals greater $n$ -than 4 is {\tt (1+1)*$\phi(n/2)$}. Negative numerals are represented as the -opposite of the interpretation of their absolute value. E.g. the -syntactic object {\tt -11} is interpreted as {\tt --(1+(1+1)*((1+1)*(1+(1+1))))} where the unit $1$ and all the operations are -those of {\tt R}. +and comes with an interpretation for numerals using the {\tt IZR} +morphism from binary integer numbers to {\tt R}. \subsubsection{\tt bool\_scope} diff --git a/doc/refman/RefMan-tac.tex b/doc/refman/RefMan-tac.tex index b13ae9b7b..6e2735700 100644 --- a/doc/refman/RefMan-tac.tex +++ b/doc/refman/RefMan-tac.tex @@ -3269,7 +3269,7 @@ The call-by-value strategy is the one used in ML languages: the arguments of a function call are systematically weakly evaluated first. Despite the lazy strategy always performs fewer reductions than the call-by-value strategy, the latter is generally more efficient for -evaluating purely computational expressions (i.e. with few dead code). +evaluating purely computational expressions (i.e. with little dead code). \begin{Variants} \item {\tt compute} \tacindex{compute}\\ @@ -3317,6 +3317,20 @@ evaluating purely computational expressions (i.e. with few dead code). compilation cost is higher, so it is worth using only for intensive computations. + On Linux, if you have the {\tt perf} profiler installed, you can profile {\tt native\_compute} evaluations. + The command + \begin{quote} + {\tt Set Native Compute Profiling} + \end{quote} + enables profiling. Use the command + \begin{quote} + {\tt Set NativeCompute Profile Filename \str} + \end{quote} + to specify the profile output; the default is {\tt native\_compute\_profile.data}. The actual filename used + will contain extra characters to avoid overwriting an existing file; that filename is reported to the user. That means + you can individually profile multiple uses of {\tt native\_compute} in a script. From the Linux command line, run {\tt perf report} on + the profile file to see the results. Consult the {\tt perf} documentation for more details. + \end{Variants} % Obsolete? Anyway not very important message @@ -4671,50 +4685,15 @@ congruence. \end{ErrMsgs} +\section{Checking properties of terms} - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -\section{Everything after this point has yet to be sorted} - +Each of the following tactics acts as the identity if the check succeeds, and results in an error otherwise. \subsection{\tt constr\_eq \term$_1$ \term$_2$} \tacindex{constr\_eq} \label{constreq} -This tactic applies to any goal. It checks whether its arguments are -equal modulo alpha conversion and casts. +This tactic checks whether its arguments are equal modulo alpha conversion and casts. \ErrMsg \errindex{Not equal} @@ -4722,8 +4701,8 @@ equal modulo alpha conversion and casts. \tacindex{unify} \label{unify} -This tactic applies to any goal. It checks whether its arguments are -unifiable, potentially instantiating existential variables. +This tactic checks whether its arguments are unifiable, potentially +instantiating existential variables. \ErrMsg \errindex{Not unifiable} @@ -4738,9 +4717,9 @@ unifiable, potentially instantiating existential variables. \tacindex{is\_evar} \label{isevar} -This tactic applies to any goal. It checks whether its argument is an -existential variable. Existential variables are uninstantiated -variables generated by e.g. {\tt eapply} (see Section~\ref{apply}). +This tactic checks whether its argument is a current existential +variable. Existential variables are uninstantiated variables generated +by {\tt eapply} (see Section~\ref{apply}) and some other tactics. \ErrMsg \errindex{Not an evar} @@ -4748,10 +4727,9 @@ variables generated by e.g. {\tt eapply} (see Section~\ref{apply}). \tacindex{has\_evar} \label{hasevar} -This tactic applies to any goal. It checks whether its argument has an -existential variable as a subterm. Unlike {\tt context} patterns -combined with {\tt is\_evar}, this tactic scans all subterms, -including those under binders. +This tactic checks whether its argument has an existential variable as +a subterm. Unlike {\tt context} patterns combined with {\tt is\_evar}, +this tactic scans all subterms, including those under binders. \ErrMsg \errindex{No evars} @@ -4759,8 +4737,8 @@ including those under binders. \tacindex{is\_var} \label{isvar} -This tactic applies to any goal. It checks whether its argument is a -variable or hypothesis in the current goal context or in the opened sections. +This tactic checks whether its argument is a variable or hypothesis in the +current goal context or in the opened sections. \ErrMsg \errindex{Not a variable or hypothesis} diff --git a/doc/refman/RefMan-tacex.tex b/doc/refman/RefMan-tacex.tex index 9f4ddc804..cb8f916f1 100644 --- a/doc/refman/RefMan-tacex.tex +++ b/doc/refman/RefMan-tacex.tex @@ -849,7 +849,7 @@ Ltac DSimplif trm := Ltac Length trm := match trm with | (_ * ?B) => let succ := Length B in constr:(S succ) - | _ => constr:1 + | _ => constr:(1) end. Ltac assoc := repeat rewrite <- Ass. \end{coq_example} diff --git a/doc/refman/RefMan-uti.tex b/doc/refman/RefMan-uti.tex index 768d0df76..f6371f8e5 100644 --- a/doc/refman/RefMan-uti.tex +++ b/doc/refman/RefMan-uti.tex @@ -51,6 +51,8 @@ arguments. In other cases, the debugger is simply called without additional arguments. Such a wrapper can be found in the \texttt{dev/} subdirectory of the sources. +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + \section[Building a \Coq\ project with {\tt coq\_makefile}] {Building a \Coq\ project with {\tt coq\_makefile} \label{Makefile} @@ -95,7 +97,7 @@ Such command generates the following files: \item[{\tt CoqMakefile.conf}] contains make variables assignments that reflect the contents of the {\tt \_CoqProject} file as well as the path relevant to \Coq{}. \end{description} -An optional file {\bf {\tt CoqMakefile.local}} can be provided by the user in order to extend {\tt CoqMakefile}. In particular one can declare custom actions to be performed before or after the build process. Similarly one can customize the install target or even provide new targets. Extension points are documented in the {\tt CoqMakefile} file. +An optional file {\bf {\tt CoqMakefile.local}} can be provided by the user in order to extend {\tt CoqMakefile}. In particular one can declare custom actions to be performed before or after the build process. Similarly one can customize the install target or even provide new targets. Extension points are documented in paragraph \ref{coqmakefile:local}. The extensions of the files listed in {\tt \_CoqProject} is used in order to decide how to build them. In particular: @@ -114,7 +116,52 @@ the plugin's ``name space'' ({\tt Qux\_plugin}). This reduces the chances of begin unable to load two distinct plugins because of a clash in their auxiliary module names. -\paragraph{Timing targets and performance testing} +\paragraph{CoqMakefile.local} %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\label{coqmakefile:local} + +The optional file {\tt CoqMakefile.local} is included by the generated file +{\tt CoqMakefile}. Such can contain two kinds of directives. + +\begin{description} + \item[Variable assignment] to the variables listed in the {\tt Parameters} + section of the generated makefile. Here we describe only few of them. + \begin{description} + \item[CAMLPKGS] can be used to specify third party findlib packages, and is + passed to the OCaml compiler on building or linking of modules. + Eg: {\tt -package yojson}. + \item[CAMLFLAGS] can be used to specify additional flags to the OCaml + compiler, like {\tt -bin-annot} or {\tt -w...}. + \item[COQC, COQDEP, COQDOC] can be set in order to use alternative + binaries (e.g. wrappers) + \end{description} +\item[Rule extension] + The following makefile rules can be extended. For example +\begin{verbatim} +pre-all:: + echo "This line is print before making the all target" +install-extra:: + cp ThisExtraFile /there/it/goes +\end{verbatim} + \begin{description} + \item[pre-all::] run before the {\tt all} target. One can use this + to configure the project, or initialize sub modules or check + dependencies are met. + \item[post-all::] run after the {\tt all} target. One can use this + to run a test suite, or compile extracted code. + \item[install-extra::] run after {\tt install}. One can use this + to install extra files. + \item[install-doc::] One can use this to install extra doc. + \item[uninstall::] + \item[uninstall-doc::] + \item[clean::] + \item[cleanall::] + \item[archclean::] + \item[merlin-hook::] One can append lines to the generated {\tt .merlin} + file extending this target. + \end{description} +\end{description} + +\paragraph{Timing targets and performance testing} %%%%%%%%%%%%%%%%%%%%%%%%%%% The generated \texttt{Makefile} supports the generation of two kinds of timing data: per-file build-times, and per-line times for an individual file. @@ -273,9 +320,10 @@ After | Code | Before || C \texttt{Note}: This target requires \texttt{python} to build the table. \end{itemize} -\paragraph{Notes about including the generated Makefile} +\paragraph{Reusing/extending the generated Makefile} %%%%%%%%%%%%%%%%%%%%%%%%% -This practice is discouraged. The contents of this file, including variable names +Including the generated makefile with an {\tt include} directive is discouraged. +The contents of this file, including variable names and status of rules shall change in the future. Users are advised to include {\tt Makefile.conf} or call a target of the generated Makefile as in {\tt make -f Makefile target} from another Makefile. @@ -303,21 +351,23 @@ invoke-coqmakefile: CoqMakefile .PHONY: invoke-coqmakefile $(KNOWNFILES) #################################################################### -#################################################################### -#################################################################### -#################################################################### ## Your targets here ## #################################################################### -#################################################################### -#################################################################### -#################################################################### # This should be the last rule, to handle any targets not declared above %: invoke-coqmakefile @true \end{verbatim} -\paragraph{Notes for users of {\tt coq\_makefile} with version $<$ 8.7} +\paragraph{Building a subset of the targets with -j} %%%%%%%%%%%%%%%%%%%%%%%%% + +To build, say, two targets \texttt{foo.vo} and \texttt{bar.vo} +in parallel one can use \texttt{make only TGTS="foo.vo bar.vo" -j}. + +Note that \texttt{make foo.vo bar.vo -j} has a different meaning for +the make utility, in particular it may build a shared prerequisite twice. + +\paragraph{Notes for users of {\tt coq\_makefile} with version $<$ 8.7} %%%%%% \begin{itemize} \item Support for ``sub-directory'' is deprecated. To perform actions before @@ -328,13 +378,7 @@ invoke-coqmakefile: CoqMakefile {\tt CoqMakefile.local} \end{itemize} -\paragraph{Note: building a subset of the targets with -j} - -To build, say, two targets \texttt{foo.vo} and \texttt{bar.vo} -in parallel one can use \texttt{make only TGTS="foo.vo bar.vo" -j}. - -Note that \texttt{make foo.vo bar.vo -j} has a different meaning for -the make utility, in particular it may build a shared prerequisite twice. +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section[Modules dependencies]{Modules dependencies\label{Dependencies}\index{Dependencies} \ttindex{coqdep}} diff --git a/doc/refman/Reference-Manual.tex b/doc/refman/Reference-Manual.tex index 291c07de4..fc1c01cf2 100644 --- a/doc/refman/Reference-Manual.tex +++ b/doc/refman/Reference-Manual.tex @@ -22,6 +22,17 @@ \usepackage{xspace} \usepackage{pmboxdraw} \usepackage{float} +\usepackage{color} + \definecolor{dkblue}{rgb}{0,0.1,0.5} + \definecolor{lightblue}{rgb}{0,0.5,0.5} + \definecolor{dkgreen}{rgb}{0,0.4,0} + \definecolor{dk2green}{rgb}{0.4,0,0} + \definecolor{dkviolet}{rgb}{0.6,0,0.8} + \definecolor{dkpink}{rgb}{0.2,0,0.6} +\usepackage{listings} + \def\lstlanguagefiles{coq-listing.tex} +\usepackage{tabularx} +\usepackage{array,longtable} \floatstyle{boxed} \restylefloat{figure} @@ -99,6 +110,11 @@ Options A and B of the licence are {\em not} elected.} \include{RefMan-ltac.v}% Writing tactics \include{RefMan-tacex.v}% Detailed Examples of tactics +\lstset{language=SSR} +\lstset{moredelim=[is][]{|*}{*|}} +\lstset{moredelim=*[is][\itshape\rmfamily]{/*}{*/}} +\include{RefMan-ssr} + \part{User extensions} \include{RefMan-syn.v}% The Syntax and the Grammar commands %%SUPPRIME \include{RefMan-tus.v}% Writing tactics diff --git a/doc/refman/Setoid.tex b/doc/refman/Setoid.tex index 2c9602a22..6c7928438 100644 --- a/doc/refman/Setoid.tex +++ b/doc/refman/Setoid.tex @@ -156,9 +156,9 @@ compatibility constraints. \begin{cscexample}[Rewriting] Continuing the previous examples, suppose that the user must prove \texttt{set\_eq int (union int (union int S1 S2) S2) (f S1 S2)} under the -hypothesis \texttt{H: set\_eq int S2 (nil int)}. It is possible to +hypothesis \texttt{H: set\_eq int S2 (@nil int)}. It is possible to use the \texttt{rewrite} tactic to replace the first two occurrences of -\texttt{S2} with \texttt{nil int} in the goal since the context +\texttt{S2} with \texttt{@nil int} in the goal since the context \texttt{set\_eq int (union int (union int S1 nil) nil) (f S1 S2)}, being a composition of morphisms instances, is a morphism. However the tactic will fail replacing the third occurrence of \texttt{S2} unless \texttt{f} diff --git a/doc/refman/Universes.tex b/doc/refman/Universes.tex index 2bb1301c7..6ea253739 100644 --- a/doc/refman/Universes.tex +++ b/doc/refman/Universes.tex @@ -134,12 +134,14 @@ producing global universe constraints, one can use the \asection{{\tt Cumulative, NonCumulative}} \comindex{Cumulative} \comindex{NonCumulative} -\optindex{Inductive Cumulativity} +\optindex{Polymorphic Inductive Cumulativity} -Inductive types, coinductive types, variants and records can be +Polymorphic inductive types, coinductive types, variants and records can be declared cumulative using the \texttt{Cumulative}. Alternatively, -there is an option \texttt{Set Inductive Cumulativity} which when set, -makes all subsequent inductive definitions cumulative. Consider the examples below. +there is an option \texttt{Set Polymorphic Inductive Cumulativity} which when set, +makes all subsequent \emph{polymorphic} inductive definitions cumulative. When set, +inductive types and the like can be enforced to be +\emph{non-cumulative} using the \texttt{NonCumulative} prefix. Consider the examples below. \begin{coq_example*} Polymorphic Cumulative Inductive list {A : Type} := | nil : list @@ -158,24 +160,61 @@ This also means that any two instances of \texttt{list} are convertible: $\WTEGCONV{\mathtt{list@\{i\}} A}{\mathtt{list@\{j\}} B}$ whenever $\WTEGCONV{A}{B}$ and furthermore their corresponding (when fully applied to convertible arguments) constructors. See Chapter~\ref{Cic} for more details on convertibility and subtyping. -Also notice the subtyping constraints for the \emph{non-cumulative} version of list: +The following is an example of a record with non-trivial subtyping relation: \begin{coq_example*} -Polymorphic NonCumulative Inductive list' {A : Type} := -| nil' : list' -| cons' : A -> list' -> list'. +Polymorphic Cumulative Record packType := {pk : Type}. \end{coq_example*} \begin{coq_example} -Print list'. +Print packType. +\end{coq_example} +Notice that as expected, \texttt{packType@\{i\}} and \texttt{packType@\{j\}} are +convertible if and only if \texttt{i $=$ j}. + +Cumulative inductive types, coninductive types, variants and records +only make sense when they are universe polymorphic. Therefore, an +error is issued whenever the user uses the \texttt{Cumulative} or +\texttt{NonCumulative} prefix in a monomorphic context. +Notice that this is not the case for the option \texttt{Set Polymorphic Inductive Cumulativity}. +That is, this option, when set, makes all subsequent \emph{polymorphic} +inductive declarations cumulative (unless, of course the \texttt{NonCumulative} prefix is used) +but has no effect on \emph{monomorphic} inductive declarations. +Consider the following examples. +\begin{coq_example} +Monomorphic Cumulative Inductive Unit := unit. +\end{coq_example} +\begin{coq_example} +Monomorphic NonCumulative Inductive Unit := unit. \end{coq_example} -The following is an example of a record with non-trivial subtyping relation: \begin{coq_example*} -Polymorphic Cumulative Record packType := {pk : Type}. +Set Polymorphic Inductive Cumulativity. +Inductive Unit := unit. \end{coq_example*} \begin{coq_example} -Print packType. +Print Unit. \end{coq_example} -Notice that as expected, \texttt{packType@\{i\}} and \texttt{packType@\{j\}} are convertible if and only if \texttt{i $=$ j}. +\subsection*{An example of a proof using cumulativity} + +\begin{coq_example} +Set Universe Polymorphism. +Set Polymorphic Inductive Cumulativity. + +Inductive eq@{i} {A : Type@{i}} (x : A) : A -> Type@{i} := eq_refl : eq x x. + +Definition funext_type@{a b e} (A : Type@{a}) (B : A -> Type@{b}) + := forall f g : (forall a, B a), + (forall x, eq@{e} (f x) (g x)) + -> eq@{e} f g. + +Section down. + Universes a b e e'. + Constraint e' < e. + Lemma funext_down {A B} + (H : @funext_type@{a b e} A B) : @funext_type@{a b e'} A B. + Proof. + exact H. + Defined. +\end{coq_example} \asection{Global and local universes} @@ -293,8 +332,18 @@ Universes k l. Check (le@{k l}). \end{coq_example} -User-named universes are considered rigid for unification and are never -minimized. +User-named universes and the anonymous universe implicitly attached to +an explicit $Type$ are considered rigid for unification and are never +minimized. Flexible anonymous universes can be produced with an +underscore or by omitting the annotation to a polymorphic definition. + +\begin{coq_example} + Check (fun x => x) : Type -> Type. + Check (fun x => x) : Type -> Type@{_}. + + Check le@{k _}. + Check le. +\end{coq_example} \subsection{\tt Unset Strict Universe Declaration. \optindex{Strict Universe Declaration} diff --git a/doc/refman/coq-listing.tex b/doc/refman/coq-listing.tex new file mode 100644 index 000000000..c69c3b1b8 --- /dev/null +++ b/doc/refman/coq-listing.tex @@ -0,0 +1,152 @@ +%======================================================================= +% Listings LaTeX package style for Gallina + SSReflect (Assia Mahboubi 2007) + +\lstdefinelanguage{SSR} { + +% Anything betweeen $ becomes LaTeX math mode +mathescape=true, +% Comments may or not include Latex commands +texcl=false, + + +% Vernacular commands +morekeywords=[1]{ +From, Section, Module, End, Require, Import, Export, Defensive, Function, +Variable, Variables, Parameter, Parameters, Axiom, Hypothesis, Hypotheses, +Notation, Local, Tactic, Reserved, Scope, Open, Close, Bind, Delimit, +Definition, Let, Ltac, Fixpoint, CoFixpoint, Add, Morphism, Relation, +Implicit, Arguments, Set, Unset, Contextual, Strict, Prenex, Implicits, +Inductive, CoInductive, Record, Structure, Canonical, Coercion, +Theorem, Lemma, Corollary, Proposition, Fact, Remark, Example, +Proof, Goal, Save, Qed, Defined, Hint, Resolve, Rewrite, View, +Search, Show, Print, Printing, All, Graph, Projections, inside, +outside, Locate, Maximal}, + +% Gallina +morekeywords=[2]{forall, exists, exists2, fun, fix, cofix, struct, + match, with, end, as, in, return, let, if, is, then, else, + for, of, nosimpl}, + +% Sorts +morekeywords=[3]{Type, Prop}, + +% Various tactics, some are std Coq subsumed by ssr, for the manual purpose +morekeywords=[4]{ + pose, set, move, case, elim, apply, clear, + hnf, intro, intros, generalize, rename, pattern, after, + destruct, induction, using, refine, inversion, injection, + rewrite, congr, unlock, compute, ring, field, + replace, fold, unfold, change, cutrewrite, simpl, + have, gen, generally, suff, wlog, suffices, without, loss, nat_norm, + assert, cut, trivial, revert, bool_congr, nat_congr, abstract, + symmetry, transitivity, auto, split, left, right, autorewrite}, + +% Terminators +morekeywords=[5]{ + by, done, exact, reflexivity, tauto, romega, omega, + assumption, solve, contradiction, discriminate}, + + +% Control +morekeywords=[6]{do, last, first, try, idtac, repeat}, + +% Various symbols +% For the ssr manual we turn off the prettyprint of formulas +% literate= +% {->}{{$\rightarrow\,$}}2 +% {->}{{\tt ->}}3 +% {<-}{{$\leftarrow\,$}}2 +% {<-}{{\tt <-}}2 +% {>->}{{$\mapsto$}}3 +% {<=}{{$\leq$}}1 +% {>=}{{$\geq$}}1 +% {<>}{{$\neq$}}1 +% {/\\}{{$\wedge$}}2 +% {\\/}{{$\vee$}}2 +% {<->}{{$\leftrightarrow\;$}}3 +% {<=>}{{$\Leftrightarrow\;$}}3 +% {:nat}{{$~\in\mathbb{N}$}}3 +% {fforall\ }{{$\forall_f\,$}}1 +% {forall\ }{{$\forall\,$}}1 +% {exists\ }{{$\exists\,$}}1 +% {negb}{{$\neg$}}1 +% {spp}{{:*:\,}}1 +% {~}{{$\sim$}}1 +% {\\in}{{$\in\;$}}1 +% {/\\}{$\land\,$}1 +% {:*:}{{$*$}}2 +% {=>}{{$\,\Rightarrow\ $}}1 +% {=>}{{\tt =>}}2 +% {:=}{{{\tt:=}\,\,}}2 +% {==}{{$\equiv$}\,}2 +% {!=}{{$\neq$}\,}2 +% {^-1}{{$^{-1}$}}1 +% {elt'}{elt'}1 +% {=}{{\tt=}\,\,}2 +% {+}{{\tt+}\,\,}2, +literate= + {isn't }{{{\ttfamily\color{dkgreen} isn't }}}1, + +% Comments delimiters, we do turn this off for the manual +%comment=[s]{(*}{*)}, + +% Spaces are not displayed as a special character +showstringspaces=false, + +% String delimiters +morestring=[b]", +morestring=[d]", + +% Size of tabulations +tabsize=3, + +% Enables ASCII chars 128 to 255 +extendedchars=true, + +% Case sensitivity +sensitive=true, + +% Automatic breaking of long lines +breaklines=true, + +% Default style fors listings +basicstyle=\ttfamily, + +% Position of captions is bottom +captionpos=b, + +% Full flexible columns +columns=[l]fullflexible, + +% Style for (listings') identifiers +identifierstyle={\ttfamily\color{black}}, +% Note : highlighting of Coq identifiers is done through a new +% delimiter definition through an lstset at the begining of the +% document. Don't know how to do better. + +% Style for declaration keywords +keywordstyle=[1]{\ttfamily\color{dkviolet}}, + +% Style for gallina keywords +keywordstyle=[2]{\ttfamily\color{dkgreen}}, + +% Style for sorts keywords +keywordstyle=[3]{\ttfamily\color{lightblue}}, + +% Style for tactics keywords +keywordstyle=[4]{\ttfamily\color{dkblue}}, + +% Style for terminators keywords +keywordstyle=[5]{\ttfamily\color{red}}, + + +%Style for iterators +keywordstyle=[6]{\ttfamily\color{dkpink}}, + +% Style for strings +stringstyle=\ttfamily, + +% Style for comments +commentstyle=\rmfamily, + +} diff --git a/doc/rt/RefMan-cover.tex b/doc/rt/RefMan-cover.tex deleted file mode 100644 index ac1686c25..000000000 --- a/doc/rt/RefMan-cover.tex +++ /dev/null @@ -1,45 +0,0 @@ -\documentstyle[RRcover]{book} - % The use of the style `french' forces the french abstract to appear first. - -\RRtitle{Manuel de r\'ef\'erence du syst\`eme Coq \\ version V7.1} -\RRetitle{The Coq Proof Assistant \\ Reference Manual \\ Version 7.1 -\thanks -{This research was partly supported by ESPRIT Basic Research -Action ``Types'' and by the GDR ``Programmation'' co-financed by MRE-PRC and CNRS.} -} -\RRauthor{Bruno Barras, Samuel Boutin, Cristina Cornes, -Judica\"el Courant, Jean-Christophe Filli\^atre, Eduardo Gim\'enez, -Hugo Herbelin, G\'erard Huet, C\'esar Mu\~noz, Chetan Murthy, -Catherine Parent, Christine Paulin-Mohring, -Amokrane Sa{\"\i}bi, Benjamin Werner} -\authorhead{} -\titlehead{Coq V7.1 Reference Manual} -\RRtheme{2} -\RRprojet{Coq} -\RRNo{0123456789} -\RRdate{May 1997} -%\RRpages{} -\URRocq - -\RRresume{Coq est un syst\`eme permettant le d\'eveloppement et la -v\'erification de preuves formelles dans une logique d'ordre -sup\'erieure incluant un riche langage de d\'efinitions de fonctions. -Ce document constitue le manuel de r\'ef\'erence de la version V7.1 -qui est distribu\'ee par ftp anonyme \`a l'adresse -\url{ftp://ftp.inria.fr/INRIA/coq/}} - -\RRmotcle{Coq, Syst\`eme d'aide \`a la preuve, Preuves formelles, -Calcul des Constructions Inductives} - - -\RRabstract{Coq is a proof assistant based on a higher-order logic -allowing powerful definitions of functions. -Coq V7.1 is available by anonymous -ftp at \url{ftp://ftp.inria.fr/INRIA/coq/}} - -\RRkeyword{Coq, Proof Assistant, Formal Proofs, Calculus of Inductives -Constructions} - -\begin{document} -\makeRT -\end{document} diff --git a/doc/rt/Tutorial-cover.tex b/doc/rt/Tutorial-cover.tex deleted file mode 100644 index aefea8d42..000000000 --- a/doc/rt/Tutorial-cover.tex +++ /dev/null @@ -1,47 +0,0 @@ -\documentstyle[RRcover]{book} - % The use of the style `french' forces the french abstract to appear first. -\RRetitle{ -The Coq Proof Assistant \\ A Tutorial \\ Version 7.1 -\thanks{This research was partly supported by ESPRIT Basic Research -Action ``Types'' and by the GDR ``Programmation'' co-financed by MRE-PRC and CNRS.} -} -\RRtitle{Coq \\ Une introduction \\ V7.1 } -\RRauthor{G\'erard Huet, Gilles Kahn and Christine Paulin-Mohring} -\RRtheme{2} -\RRprojet{{Coq -\\[15pt] -{INRIA Rocquencourt} -{\hskip -5.25pt} -~~{\bf ---}~~ - \def\thefootnote{\arabic{footnote}\hss} -{CNRS - ENS Lyon} -\footnote[1]{LIP URA 1398 du CNRS, -46 All\'ee d'Italie, 69364 Lyon CEDEX 07, France.} -{\hskip -14pt}}} - -%\RRNo{0123456789} -\RRNo{0204} -\RRdate{Ao\^ut 1997} - -\URRocq -\RRresume{Coq est un syst\`eme permettant le d\'eveloppement et la -v\'erification de preuves formelles dans une logique d'ordre -sup\'erieure incluant un riche langage de d\'efinitions de fonctions. -Ce document constitue une introduction pratique \`a l'utilisation de -la version V7.1 qui est distribu\'ee par ftp anonyme \`a l'adresse -\url{ftp://ftp.inria.fr/INRIA/coq/}} - -\RRmotcle{Coq, Syst\`eme d'aide \`a la preuve, Preuves formelles, Calcul -des Constructions Inductives} - -\RRabstract{Coq is a proof assistant based on a higher-order logic -allowing powerful definitions of functions. This document is a -tutorial for the version V7.1 of Coq. This version is available by -anonymous ftp at \url{ftp://ftp.inria.fr/INRIA/coq/}} - -\RRkeyword{Coq, Proof Assistant, Formal Proofs, Calculus of Inductives -Constructions} - -\begin{document} -\makeRT -\end{document} diff --git a/doc/tools/Translator.tex b/doc/tools/Translator.tex index ed1d336d9..3ee65d6f2 100644 --- a/doc/tools/Translator.tex +++ b/doc/tools/Translator.tex @@ -614,7 +614,7 @@ is compiled by a Makefile with the following constraints: \begin{itemize} \item compilation is achieved by invoking make without specifying a target \item options are passed to Coq with make variable COQFLAGS that - includes variables OPT, COQLIBS, OTHERFLAGS and COQ_XML. + includes variables OPT, COQLIBS, and OTHERFLAGS. \end{itemize} These constraints are met by the makefiles produced by {\tt coq\_makefile} diff --git a/doc/tutorial/Tutorial.tex b/doc/tutorial/Tutorial.tex index 8337b1c48..77ce8574f 100644 --- a/doc/tutorial/Tutorial.tex +++ b/doc/tutorial/Tutorial.tex @@ -241,7 +241,7 @@ Variables A B C : Prop. \end{coq_example} We shall consider simple implications, such as $A\ra B$, read as -``$A$ implies $B$''. Remark that we overload the arrow symbol, which +``$A$ implies $B$''. Note that we overload the arrow symbol, which has been used above as the functionality type constructor, and which may be used as well as propositional connective: \begin{coq_example} @@ -289,7 +289,7 @@ apply H. We are now in the situation where we have two judgments as conjectures that remain to be proved. Only the first is listed in full, for the others the system displays only the corresponding subgoal, without its -local hypotheses list. Remark that \verb:apply: has kept the local +local hypotheses list. Note that \verb:apply: has kept the local hypotheses of its father judgment, which are still available for the judgments it generated. @@ -654,7 +654,7 @@ Hypothesis R_transitive : forall x y z : D, R x y -> R y z -> R x z. \end{coq_example} -Remark the syntax \verb+forall x : D,+ which stands for universal quantification +Note the syntax \verb+forall x : D,+ which stands for universal quantification $\forall x : D$. \subsection{Existential quantification} @@ -664,10 +664,10 @@ We now state our lemma, and enter proof mode. Lemma refl_if : forall x : D, (exists y, R x y) -> R x x. \end{coq_example} -Remark that the hypotheses which are local to the currently opened sections +The hypotheses that are local to the currently opened sections are listed as local hypotheses to the current goals. -The rationale is that these hypotheses are going to be discharged, as we -shall see, when we shall close the corresponding sections. +That is because these hypotheses are going to be discharged, as +we shall see, when we shall close the corresponding sections. Note the functional syntax for existential quantification. The existential quantifier is built from the operator \verb:ex:, which expects a @@ -687,7 +687,7 @@ verifies \verb:P:. Let us see how this works on this simple example. intros x x_Rlinked. \end{coq_example} -Remark that \verb:intros: treats universal quantification in the same way +Note that \verb:intros: treats universal quantification in the same way as the premises of implications. Renaming of bound variables occurs when it is needed; for instance, had we started with \verb:intro y:, we would have obtained the goal: @@ -859,7 +859,7 @@ Check weird. Check drinker. \end{coq_example} -Remark how the three theorems are completely generic in the most general +Note how the three theorems are completely generic in the most general fashion; the domain \verb:D: is discharged in all of them, \verb:R: is discharged in \verb:refl_if: only, \verb:P: is discharged only in \verb:weird: and @@ -867,7 +867,7 @@ the domain \verb:D: is discharged in all of them, \verb:R: is discharged in Finally, the excluded middle hypothesis is discharged only in \verb:drinker:. -Note that the name \verb:d: has vanished as well from +Note, too, that the name \verb:d: has vanished from the statements of \verb:weird: and \verb:drinker:, since \Coq's pretty-printer replaces systematically a quantification such as \texttt{forall d : D, E}, diff --git a/engine/evarutil.ml b/engine/evarutil.ml index 2afc12cd3..339c6a248 100644 --- a/engine/evarutil.ml +++ b/engine/evarutil.ml @@ -412,6 +412,14 @@ let new_evar_instance sign evd typ ?src ?filter ?candidates ?store ?naming ?prin let (evd, newevk) = new_pure_evar sign evd ?src ?filter ?candidates ?store ?naming ?principal typ in evd, mkEvar (newevk,Array.of_list instance) +let new_evar_from_context sign evd ?src ?filter ?candidates ?store ?naming ?principal typ = + let instance = List.map (NamedDecl.get_id %> EConstr.mkVar) (named_context_of_val sign) in + let instance = + match filter with + | None -> instance + | Some filter -> Filter.filter_list filter instance in + new_evar_instance sign evd typ ?src ?filter ?candidates ?store ?naming ?principal instance + (* [new_evar] declares a new existential in an env env with type typ *) (* Converting the env into the sign of the evar to define *) let new_evar env evd ?src ?filter ?candidates ?store ?naming ?principal typ = diff --git a/engine/evarutil.mli b/engine/evarutil.mli index a8b6b5861..14173e774 100644 --- a/engine/evarutil.mli +++ b/engine/evarutil.mli @@ -21,6 +21,13 @@ val new_meta : unit -> metavariable val mk_new_meta : unit -> constr (** {6 Creating a fresh evar given their type and context} *) + +val new_evar_from_context : + named_context_val -> evar_map -> ?src:Evar_kinds.t Loc.located -> ?filter:Filter.t -> + ?candidates:constr list -> ?store:Store.t -> + ?naming:Misctypes.intro_pattern_naming_expr -> + ?principal:bool -> types -> evar_map * EConstr.t + val new_evar : env -> evar_map -> ?src:Evar_kinds.t Loc.located -> ?filter:Filter.t -> ?candidates:constr list -> ?store:Store.t -> diff --git a/ide/coq.ml b/ide/coq.ml index 0fe831ab3..42ab86dd6 100644 --- a/ide/coq.ml +++ b/ide/coq.ml @@ -410,8 +410,19 @@ let clear_handle h = let mkready coqtop = fun () -> coqtop.status <- Ready; Void +let save_all = ref (fun () -> assert false) + let rec respawn_coqtop ?(why=Unexpected) coqtop = - if why = Unexpected then warning "Coqtop died badly. Resetting."; + let () = match why with + | Unexpected -> + let title = "Warning" in + let icon = (warn_image ())#coerce in + let buttons = ["Reset"; "Save all and quit"; "Quit without saving"] in + let ans = GToolbox.question_box ~title ~buttons ~icon "Coqtop died badly." in + if ans = 2 then (!save_all (); GtkMain.Main.quit ()) + else if ans = 3 then GtkMain.Main.quit () + | Planned -> () + in clear_handle coqtop.handle; ignore_error (fun () -> coqtop.handle <- diff --git a/ide/coq.mli b/ide/coq.mli index 5d9648603..463dd134a 100644 --- a/ide/coq.mli +++ b/ide/coq.mli @@ -170,3 +170,4 @@ val check_connection : string list -> unit may terminate coqide in case of trouble *) val interrupter : (int -> unit) ref +val save_all : (unit -> unit) ref diff --git a/ide/coqide.ml b/ide/coqide.ml index feb45a7be..7b65c9fec 100644 --- a/ide/coqide.ml +++ b/ide/coqide.ml @@ -284,6 +284,8 @@ let saveall _ = | Some f -> ignore (sn.fileops#save f)) notebook#pages +let () = Coq.save_all := saveall + let revert_all _ = List.iter (fun sn -> if sn.fileops#changed_on_disk then sn.fileops#revert) diff --git a/ide/wg_Detachable.ml b/ide/wg_Detachable.ml index e5b436427..3d3a5ccb2 100644 --- a/ide/wg_Detachable.ml +++ b/ide/wg_Detachable.ml @@ -19,7 +19,7 @@ class detachable (obj : ([> Gtk.box] as 'a) Gobject.obj) = inherit GPack.box_skel (obj :> Gtk.box Gobject.obj) as super val but = GButton.button () - val win = GWindow.window () + val win = GWindow.window ~type_hint:`DIALOG () val frame = GBin.frame ~shadow_type:`NONE () val mutable detached = false val mutable detached_cb = (fun _ -> ()) diff --git a/interp/constrextern.ml b/interp/constrextern.ml index fcaee5c93..f5eff693f 100644 --- a/interp/constrextern.ml +++ b/interp/constrextern.ml @@ -298,7 +298,7 @@ let add_patt_for_params ind l = let add_cpatt_for_params ind l = if !Flags.in_debugger then l else - Util.List.addn (Inductiveops.inductive_nparamdecls ind) (CAst.make @@ PatVar Anonymous) l + Util.List.addn (Inductiveops.inductive_nparamdecls ind) (DAst.make @@ PatVar Anonymous) l let drop_implicits_in_patt cst nb_expl args = let impl_st = (implicits_of_global cst) in @@ -320,38 +320,6 @@ let drop_implicits_in_patt cst nb_expl args = let imps = List.skipn_at_least nb_expl (select_stronger_impargs impl_st) in impls_fit [] (imps,args) -let has_curly_brackets ntn = - String.length ntn >= 6 && (String.is_sub "{ _ } " ntn 0 || - String.is_sub " { _ }" ntn (String.length ntn - 6) || - String.string_contains ~where:ntn ~what:" { _ } ") - -let rec wildcards ntn n = - if Int.equal n (String.length ntn) then [] - else let l = spaces ntn (n+1) in if ntn.[n] == '_' then n::l else l -and spaces ntn n = - if Int.equal n (String.length ntn) then [] - else if ntn.[n] == ' ' then wildcards ntn (n+1) else spaces ntn (n+1) - -let expand_curly_brackets loc mknot ntn l = - let ntn' = ref ntn in - let rec expand_ntn i = - function - | [] -> [] - | a::l -> - let a' = - let p = List.nth (wildcards !ntn' 0) i - 2 in - if p>=0 && p+5 <= String.length !ntn' && String.is_sub "{ _ }" !ntn' p - then begin - ntn' := - String.sub !ntn' 0 p ^ "_" ^ - String.sub !ntn' (p+5) (String.length !ntn' -p-5); - mknot (loc,"{ _ }",[a]) end - else a in - a' :: expand_ntn (i+1) l in - let l = expand_ntn 0 l in - (* side effect *) - mknot (loc,!ntn',l) - let destPrim = function { CAst.v = CPrim t } -> Some t | _ -> None let destPatPrim = function { CAst.v = CPatPrim t } -> Some t | _ -> None @@ -367,9 +335,7 @@ let is_zero s = in aux 0 let make_notation_gen loc ntn mknot mkprim destprim l = - if has_curly_brackets ntn - then expand_curly_brackets loc mknot ntn l - else match ntn,List.map destprim l with + match ntn,List.map destprim l with (* Special case to avoid writing "- 3" for e.g. (Z.opp 3) *) | "- _", [Some (Numeral (p,true))] when not (is_zero p) -> mknot (loc,ntn,([mknot (loc,"( _ )",l)])) @@ -410,6 +376,10 @@ let pattern_printable_in_both_syntax (ind,_ as c) = (List.for_all is_status_implicit params)&&(List.for_all (fun x -> not (is_status_implicit x)) args) ) impl_st +let lift f c = + let loc = c.CAst.loc in + CAst.make ?loc (f ?loc (DAst.get c)) + (* Better to use extern_glob_constr composed with injection/retraction ?? *) let rec extern_cases_pattern_in_scope (scopes:local_scopes) vars pat = try @@ -426,7 +396,7 @@ let rec extern_cases_pattern_in_scope (scopes:local_scopes) vars pat = extern_notation_pattern scopes vars pat (uninterp_cases_pattern_notations pat) with No_match -> - CAst.map_with_loc (fun ?loc -> function + lift (fun ?loc -> function | PatVar (Name id) -> CPatAtom (Some (Ident (loc,id))) | PatVar (Anonymous) -> CPatAtom None | PatCstr(cstrsp,args,na) -> @@ -516,7 +486,7 @@ and extern_notation_pattern (tmp_scope,scopes as allscopes) vars t = function try if is_inactive_rule keyrule then raise No_match; let loc = t.loc in - match t.v with + match DAst.get t with | PatCstr (cstr,_,na) -> let p = apply_notation_to_pattern ?loc (ConstructRef cstr) (match_notation_constr_cases_pattern t pat) allscopes vars keyrule in @@ -679,8 +649,12 @@ let extern_args extern env args = let map (arg, argscopes) = lazy (extern argscopes env arg) in List.map map args -let match_coercion_app = function - | {loc; v = GApp ({ v = GRef (r,_) },args)} -> Some (loc, r, 0, args) +let match_coercion_app c = match DAst.get c with + | GApp (r, args) -> + begin match DAst.get r with + | GRef (r,_) -> Some (c.CAst.loc, r, 0, args) + | _ -> None + end | _ -> None let rec remove_coercions inctx c = @@ -702,14 +676,20 @@ let rec remove_coercions inctx c = been confused with ordinary application or would have need a surrounding context and the coercion to funclass would have been made explicit to match *) - if List.is_empty l then a' else CAst.make ?loc @@ GApp (a',l) + if List.is_empty l then a' else DAst.make ?loc @@ GApp (a',l) | _ -> c with Not_found -> c) | _ -> c -let rec flatten_application = function - | {loc; v = GApp ({ v = GApp(a,l')},l)} -> flatten_application (CAst.make ?loc @@ GApp (a,l'@l)) - | a -> a +let rec flatten_application c = match DAst.get c with + | GApp (f, l) -> + begin match DAst.get f with + | GApp(a,l') -> + let loc = c.CAst.loc in + flatten_application (DAst.make ?loc @@ GApp (a,l'@l)) + | _ -> c + end + | a -> c (**********************************************************************) (* mapping glob_constr to numerals (in presence of coercions, choose the *) @@ -736,10 +716,12 @@ let extern_optimal_prim_token scopes r r' = let extended_glob_local_binder_of_decl loc = function | (p,bk,None,t) -> GLocalAssum (p,bk,t) - | (p,bk,Some x, { v = GHole ( _, Misctypes.IntroAnonymous, None) } ) -> GLocalDef (p,bk,x,None) - | (p,bk,Some x,t) -> GLocalDef (p,bk,x,Some t) + | (p,bk,Some x, t) -> + match DAst.get t with + | GHole (_, Misctypes.IntroAnonymous, None) -> GLocalDef (p,bk,x,None) + | _ -> GLocalDef (p,bk,x,Some t) -let extended_glob_local_binder_of_decl ?loc u = CAst.make ?loc (extended_glob_local_binder_of_decl loc u) +let extended_glob_local_binder_of_decl ?loc u = DAst.make ?loc (extended_glob_local_binder_of_decl loc u) (**********************************************************************) (* mapping glob_constr to constr_expr *) @@ -764,7 +746,7 @@ let rec extern inctx scopes vars r = let r'' = flatten_application r' in if !Flags.raw_print || !print_no_symbol then raise No_match; extern_notation scopes vars r'' (uninterp_notations r'') - with No_match -> CAst.map_with_loc (fun ?loc -> function + 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) @@ -783,8 +765,9 @@ let rec extern inctx scopes vars r = | Evar_kinds.FirstOrderPatVar n -> CEvar (n,[])) | GApp (f,args) -> - (match f with - | {loc = rloc; v = GRef (ref,us) } -> + (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 @@ -859,8 +842,8 @@ let rec extern inctx scopes vars r = (cases_predicate_names tml) vars in let rtntypopt' = Option.map (extern_typ scopes vars') rtntypopt in let tml = List.map (fun (tm,(na,x)) -> - let na' = match na,tm with - | Anonymous, { v = GVar id } -> + let na' = match na, DAst.get tm with + | Anonymous, GVar id -> begin match rtntypopt with | None -> None | Some ntn -> @@ -869,12 +852,12 @@ let rec extern inctx scopes vars r = else None end | Anonymous, _ -> None - | Name id, { v = GVar id' } when Id.equal id id' -> None + | Name id, GVar id' when Id.equal id id' -> None | Name _, _ -> Some (Loc.tag na) in (sub_extern false scopes vars tm, na', Option.map (fun (loc,(ind,nal)) -> - let args = List.map (fun x -> CAst.make @@ PatVar x) nal in + 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 ) x)) @@ -965,14 +948,16 @@ and factorize_lambda inctx scopes vars na bk aty c = and extern_local_binder scopes vars = function [] -> ([],[],[]) - | { v = GLocalDef (na,bk,bd,ty)}::l -> + | b :: l -> + match DAst.get b with + | GLocalDef (na,bk,bd,ty) -> let (assums,ids,l) = extern_local_binder scopes (Name.fold_right Id.Set.add na vars) l in (assums,na::ids, CLocalDef((Loc.tag na), extern false scopes vars bd, Option.map (extern false scopes vars) ty) :: l) - | { v = GLocalAssum (na,bk,ty)}::l -> + | GLocalAssum (na,bk,ty) -> let ty = extern_typ scopes vars ty in (match extern_local_binder scopes (Name.fold_right Id.Set.add na vars) l with (assums,ids,CLocalAssum(nal,k,ty')::l) @@ -985,7 +970,7 @@ and extern_local_binder scopes vars = function (na::assums,na::ids, CLocalAssum([(Loc.tag na)],Default bk,ty) :: l)) - | { v = GLocalPattern ((p,_),_,bk,ty)}::l -> + | GLocalPattern ((p,_),_,bk,ty) -> let ty = if !Flags.raw_print then Some (extern_typ scopes vars ty) else None in let p = extern_cases_pattern vars p in @@ -1003,12 +988,12 @@ and extern_notation (tmp_scope,scopes as allscopes) vars t = function try if is_inactive_rule keyrule then raise No_match; (* Adjusts to the number of arguments expected by the notation *) - let (t,args,argsscopes,argsimpls) = match t.v ,n with + let (t,args,argsscopes,argsimpls) = match DAst.get t ,n with | GApp (f,args), Some n when List.length args >= n -> let args1, args2 = List.chop n args in let subscopes, impls = - match f.v with + match DAst.get f with | GRef (ref,us) -> let subscopes = try List.skipn n (find_arguments_scope ref) @@ -1021,15 +1006,19 @@ and extern_notation (tmp_scope,scopes as allscopes) vars t = function subscopes,impls | _ -> [], [] in - (if Int.equal n 0 then f else CAst.make @@ GApp (f,args1)), + (if Int.equal n 0 then f else DAst.make @@ GApp (f,args1)), args2, subscopes, impls - | GApp ({ v = GRef (ref,us) } as f, args), None -> + | GApp (f, args), None -> + begin match DAst.get f with + | GRef (ref,us) -> let subscopes = find_arguments_scope ref in let impls = select_impargs_size (List.length args) (implicits_of_global ref) in f, args, subscopes, impls - | GRef (ref,us), Some 0 -> CAst.make @@ GApp (t,[]), [], [], [] + | _ -> t, [], [], [] + end + | GRef (ref,us), Some 0 -> DAst.make @@ GApp (t,[]), [], [], [] | _, None -> t, [], [], [] | _ -> raise No_match in (* Try matching ... *) @@ -1098,9 +1087,8 @@ let extern_constr_gen lax goal_concl_style scopt env sigma t = (* Not "goal_concl_style" means do alpha-conversion avoiding only *) (* those goal/section/rel variables that occurs in the subterm under *) (* consideration; see namegen.ml for further details *) - let t = EConstr.of_constr t in let avoid = if goal_concl_style then ids_of_context env else [] in - let r = Detyping.detype ~lax:lax goal_concl_style avoid env sigma t in + let r = Detyping.detype Detyping.Later ~lax:lax goal_concl_style avoid env sigma t in let vars = vars_of_env env in extern false (scopt,[]) vars r @@ -1111,9 +1099,8 @@ let extern_constr ?(lax=false) goal_concl_style env sigma t = extern_constr_gen lax goal_concl_style None env sigma t let extern_type goal_concl_style env sigma t = - let t = EConstr.of_constr t in let avoid = if goal_concl_style then ids_of_context env else [] in - let r = Detyping.detype goal_concl_style avoid env sigma t in + let r = Detyping.detype Detyping.Later goal_concl_style avoid env sigma t in extern_glob_type (vars_of_env env) r let extern_sort sigma s = extern_glob_sort (detype_sort sigma s) @@ -1131,9 +1118,9 @@ let extern_closed_glob ?lax goal_concl_style env sigma t = let any_any_branch = (* | _ => _ *) - Loc.tag ([],[CAst.make @@ PatVar Anonymous], CAst.make @@ GHole (Evar_kinds.InternalHole,Misctypes.IntroAnonymous,None)) + Loc.tag ([],[DAst.make @@ PatVar Anonymous], DAst.make @@ GHole (Evar_kinds.InternalHole,Misctypes.IntroAnonymous,None)) -let rec glob_of_pat env sigma pat = CAst.make @@ match pat with +let rec glob_of_pat env sigma pat = DAst.make @@ match pat with | PRef ref -> GRef (ref,None) | PVar id -> GVar id | PEvar (evk,l) -> @@ -1153,12 +1140,12 @@ let rec glob_of_pat env sigma pat = CAst.make @@ match pat with GVar id | PMeta None -> GHole (Evar_kinds.InternalHole, Misctypes.IntroAnonymous,None) | PMeta (Some n) -> GPatVar (Evar_kinds.FirstOrderPatVar n) - | PProj (p,c) -> GApp (CAst.make @@ GRef (ConstRef (Projection.constant p),None), + | PProj (p,c) -> GApp (DAst.make @@ GRef (ConstRef (Projection.constant p),None), [glob_of_pat env sigma c]) | PApp (f,args) -> GApp (glob_of_pat env sigma f,Array.map_to_list (glob_of_pat env sigma) args) | PSoApp (n,args) -> - GApp (CAst.make @@ GPatVar (Evar_kinds.SecondOrderPatVar n), + GApp (DAst.make @@ GPatVar (Evar_kinds.SecondOrderPatVar n), List.map (glob_of_pat env sigma) args) | PProd (na,t,c) -> GProd (na,Explicit,glob_of_pat env sigma t,glob_of_pat (na::env) sigma c) @@ -1190,17 +1177,15 @@ let rec glob_of_pat env sigma pat = CAst.make @@ match pat with | _ -> anomaly (Pp.str "PCase with non-trivial predicate but unknown inductive.") in GCases (RegularStyle,rtn,[glob_of_pat env sigma tm,indnames],mat) - | PFix f -> (Detyping.detype_names false [] env (Global.env()) sigma (EConstr.of_constr (mkFix f))).v (** FIXME bad env *) - | PCoFix c -> (Detyping.detype_names false [] env (Global.env()) sigma (EConstr.of_constr (mkCoFix c))).v + | PFix f -> DAst.get (Detyping.detype_names false [] env (Global.env()) sigma (EConstr.of_constr (mkFix f))) (** FIXME bad env *) + | PCoFix c -> DAst.get (Detyping.detype_names false [] env (Global.env()) sigma (EConstr.of_constr (mkCoFix c))) | PSort s -> GSort s let extern_constr_pattern env sigma pat = extern true (None,[]) Id.Set.empty (glob_of_pat env sigma pat) let extern_rel_context where env sigma sign = - let sign = List.map (fun d -> Termops.map_rel_decl EConstr.of_constr d) sign in - let where = Option.map EConstr.of_constr where in - let a = detype_rel_context where [] (names_of_rel_context env,env) sigma sign in + let a = detype_rel_context Detyping.Later where [] (names_of_rel_context env,env) sigma sign in let vars = vars_of_env env in let a = List.map (extended_glob_local_binder_of_decl) a in pi3 (extern_local_binder (None,[]) vars a) diff --git a/interp/constrextern.mli b/interp/constrextern.mli index b5242b347..593580fb7 100644 --- a/interp/constrextern.mli +++ b/interp/constrextern.mli @@ -9,6 +9,7 @@ open Names open Term open Termops +open EConstr open Environ open Libnames open Globnames @@ -22,9 +23,9 @@ open Misctypes (** Translation of pattern, cases pattern, glob_constr and term into syntax trees for printing *) -val extern_cases_pattern : Id.Set.t -> cases_pattern -> cases_pattern_expr -val extern_glob_constr : Id.Set.t -> glob_constr -> constr_expr -val extern_glob_type : Id.Set.t -> glob_constr -> constr_expr +val extern_cases_pattern : Id.Set.t -> 'a cases_pattern_g -> cases_pattern_expr +val extern_glob_constr : Id.Set.t -> 'a glob_constr_g -> constr_expr +val extern_glob_type : Id.Set.t -> 'a glob_constr_g -> constr_expr val extern_constr_pattern : names_context -> Evd.evar_map -> constr_pattern -> constr_expr val extern_closed_glob : ?lax:bool -> bool -> env -> Evd.evar_map -> closed_glob_constr -> constr_expr @@ -41,7 +42,7 @@ val extern_reference : ?loc:Loc.t -> Id.Set.t -> global_reference -> reference val extern_type : bool -> env -> Evd.evar_map -> types -> constr_expr val extern_sort : Evd.evar_map -> sorts -> glob_sort val extern_rel_context : constr option -> env -> Evd.evar_map -> - Context.Rel.t -> local_binder_expr list + rel_context -> local_binder_expr list (** Printing options *) val print_implicits : bool ref diff --git a/interp/constrintern.ml b/interp/constrintern.ml index c9fc3aa4f..6f7c6c827 100644 --- a/interp/constrintern.ml +++ b/interp/constrintern.ml @@ -15,7 +15,6 @@ open Namegen open Libnames open Globnames open Impargs -open CAst open Glob_term open Glob_ops open Patternops @@ -306,12 +305,12 @@ let reset_tmp_scope env = {env with tmp_scope = None} let rec it_mkGProd ?loc env body = match env with - (loc2, (na, bk, t)) :: tl -> it_mkGProd ?loc:loc2 tl (CAst.make ?loc:(Loc.merge_opt loc loc2) @@ GProd (na, bk, t, body)) + (loc2, (na, bk, t)) :: tl -> it_mkGProd ?loc:loc2 tl (DAst.make ?loc:(Loc.merge_opt loc loc2) @@ GProd (na, bk, t, body)) | [] -> body let rec it_mkGLambda ?loc env body = match env with - (loc2, (na, bk, t)) :: tl -> it_mkGLambda ?loc:loc2 tl (CAst.make ?loc:(Loc.merge_opt loc loc2) @@ GLambda (na, bk, t, body)) + (loc2, (na, bk, t)) :: tl -> it_mkGLambda ?loc:loc2 tl (DAst.make ?loc:(Loc.merge_opt loc loc2) @@ GLambda (na, bk, t, body)) | [] -> body (**********************************************************************) @@ -323,15 +322,15 @@ let build_impls = function |Explicit -> fun _ -> None let impls_type_list ?(args = []) = - let rec aux acc = function - | { v = GProd (na,bk,_,c) } -> aux ((build_impls bk na)::acc) c + let rec aux acc c = match DAst.get c with + | GProd (na,bk,_,c) -> aux ((build_impls bk na)::acc) c | _ -> (Variable,[],List.append args (List.rev acc),[]) in aux [] let impls_term_list ?(args = []) = - let rec aux acc = function - | { v = GLambda (na,bk,_,c) } -> aux ((build_impls bk na)::acc) c - | { v = GRec (fix_kind, nas, args, tys, bds) } -> + let rec aux acc c = match DAst.get c with + | GLambda (na,bk,_,c) -> aux ((build_impls bk na)::acc) c + | GRec (fix_kind, nas, args, tys, bds) -> let nb = match fix_kind with |GFix (_, n) -> n | GCoFix n -> n in let acc' = List.fold_left (fun a (na, bk, _, _) -> (build_impls bk na)::a) acc args.(nb) in aux acc' bds.(nb) @@ -347,14 +346,14 @@ let rec check_capture ty = function | [] -> () -let locate_if_hole ?loc na = function - | { v = GHole (_,naming,arg) } -> +let locate_if_hole ?loc na c = match DAst.get c with + | GHole (_,naming,arg) -> (try match na with | Name id -> glob_constr_of_notation_constr ?loc (Reserve.find_reserved_type id) | Anonymous -> raise Not_found - with Not_found -> CAst.make ?loc @@ GHole (Evar_kinds.BinderType na, naming, arg)) - | x -> x + with Not_found -> DAst.make ?loc @@ GHole (Evar_kinds.BinderType na, naming, arg)) + | _ -> c let reset_hidden_inductive_implicit_test env = { env with impls = Id.Map.map (function @@ -400,7 +399,7 @@ let intern_generalized_binder ?(global_level=false) intern_type lvar env fvs in let bl = List.map (fun (loc, id) -> - (loc, (Name id, b, CAst.make ?loc @@ GHole (Evar_kinds.BinderType (Name id), Misctypes.IntroAnonymous, None)))) + (loc, (Name id, b, DAst.make ?loc @@ GHole (Evar_kinds.BinderType (Name id), Misctypes.IntroAnonymous, None)))) fvs in let na = match na with @@ -433,11 +432,11 @@ let intern_assumption intern lvar env nal bk ty = let env, b = intern_generalized_binder intern_type lvar env (List.hd nal) b b' t ty in env, b -let glob_local_binder_of_extended = CAst.with_loc_val (fun ?loc -> function +let glob_local_binder_of_extended = DAst.with_loc_val (fun ?loc -> function | GLocalAssum (na,bk,t) -> (na,bk,None,t) | GLocalDef (na,bk,c,Some t) -> (na,bk,Some c,t) | GLocalDef (na,bk,c,None) -> - let t = CAst.make ?loc @@ GHole(Evar_kinds.BinderType na,Misctypes.IntroAnonymous,None) in + let t = DAst.make ?loc @@ GHole(Evar_kinds.BinderType na,Misctypes.IntroAnonymous,None) in (na,bk,Some c,t) | GLocalPattern (_,_,_,_) -> Loc.raise ?loc (Stream.Error "pattern with quote not allowed here.") @@ -448,13 +447,13 @@ let intern_cases_pattern_fwd = ref (fun _ -> failwith "intern_cases_pattern_fwd" let intern_local_binder_aux ?(global_level=false) intern lvar (env,bl) = function | CLocalAssum(nal,bk,ty) -> let env, bl' = intern_assumption intern lvar env nal bk ty in - let bl' = List.map (fun (loc,(na,c,t)) -> CAst.make ?loc @@ GLocalAssum (na,c,t)) bl' in + let bl' = List.map (fun (loc,(na,c,t)) -> DAst.make ?loc @@ GLocalAssum (na,c,t)) bl' in env, bl' @ bl | CLocalDef((loc,na as locna),def,ty) -> let term = intern env def in let ty = Option.map (intern env) ty in (push_name_env lvar (impls_term_list term) env locna, - (CAst.make ?loc @@ GLocalDef (na,Explicit,term,ty)) :: bl) + (DAst.make ?loc @@ GLocalDef (na,Explicit,term,ty)) :: bl) | CLocalPattern (loc,(p,ty)) -> let tyc = match ty with @@ -476,7 +475,7 @@ let intern_local_binder_aux ?(global_level=false) intern lvar (env,bl) = functio let bk = Default Explicit in let _, bl' = intern_assumption intern lvar env [na] bk tyc in let _,(_,bk,t) = List.hd bl' in - (env, (CAst.make ?loc @@ GLocalPattern((cp,il),id,bk,t)) :: bl) + (env, (DAst.make ?loc @@ GLocalPattern((cp,il),id,bk,t)) :: bl) let intern_generalization intern env lvar loc bk ak c = let c = intern {env with unb = true} c in @@ -499,12 +498,12 @@ let intern_generalization intern env lvar loc bk ak c = in if pi then (fun (loc', id) acc -> - CAst.make ?loc:(Loc.merge_opt loc' loc) @@ - GProd (Name id, bk, CAst.make ?loc:loc' @@ GHole (Evar_kinds.BinderType (Name id), Misctypes.IntroAnonymous, None), acc)) + DAst.make ?loc:(Loc.merge_opt loc' loc) @@ + GProd (Name id, bk, DAst.make ?loc:loc' @@ GHole (Evar_kinds.BinderType (Name id), Misctypes.IntroAnonymous, None), acc)) else (fun (loc', id) acc -> - CAst.make ?loc:(Loc.merge_opt loc' loc) @@ - GLambda (Name id, bk, CAst.make ?loc:loc' @@ GHole (Evar_kinds.BinderType (Name id), Misctypes.IntroAnonymous, None), acc)) + DAst.make ?loc:(Loc.merge_opt loc' loc) @@ + GLambda (Name id, bk, DAst.make ?loc:loc' @@ GHole (Evar_kinds.BinderType (Name id), Misctypes.IntroAnonymous, None), acc)) in List.fold_right (fun (loc, id as lid) (env, acc) -> let env' = push_name_env lvar (Variable,[],[],[]) env (loc, Name id) in @@ -558,27 +557,34 @@ let make_letins = (fun a c -> match a with | loc, LPLetIn (na,b,t) -> - CAst.make ?loc @@ GLetIn(na,b,t,c) + DAst.make ?loc @@ GLetIn(na,b,t,c) | loc, LPCases ((cp,il),id) -> - let tt = (CAst.make ?loc @@ GVar id, (Name id,None)) in - CAst.make ?loc @@ GCases(Misctypes.LetPatternStyle,None,[tt],[(loc,(il,[cp],c))])) + let tt = (DAst.make ?loc @@ GVar id, (Name id,None)) in + DAst.make ?loc @@ GCases(Misctypes.LetPatternStyle,None,[tt],[(loc,(il,[cp],c))])) -let rec subordinate_letins letins = function +let rec subordinate_letins letins l = match l with + | bnd :: l -> + let loc = bnd.CAst.loc in + begin match DAst.get bnd with (* binders come in reverse order; the non-let are returned in reverse order together *) (* with the subordinated let-in in writing order *) - | { loc; v = GLocalDef (na,_,b,t) }::l -> + | GLocalDef (na,_,b,t) -> subordinate_letins ((Loc.tag ?loc @@ LPLetIn (na,b,t))::letins) l - | { loc; v = GLocalAssum (na,bk,t)}::l -> + | GLocalAssum (na,bk,t) -> let letins',rest = subordinate_letins [] l in letins',((loc,(na,bk,t)),letins)::rest - | { loc; v = GLocalPattern (u,id,bk,t)} :: l -> + | GLocalPattern (u,id,bk,t) -> subordinate_letins ((Loc.tag ?loc @@ LPCases (u,id))::letins) - ([CAst.make ?loc @@ GLocalAssum (Name id,bk,t)] @ l) + ([DAst.make ?loc @@ GLocalAssum (Name id,bk,t)] @ l) + end | [] -> letins,[] +let dmap_with_loc f n = + CAst.map_with_loc (fun ?loc c -> f ?loc (DAst.get_thunk c)) n + let terms_of_binders bl = - let rec term_of_pat pt = CAst.map_with_loc (fun ?loc -> function + let rec term_of_pat pt = dmap_with_loc (fun ?loc -> function | PatVar (Name id) -> CRef (Ident (loc,id), None) | PatVar (Anonymous) -> user_err Pp.(str "Cannot turn \"_\" into a term.") | PatCstr (c,l,_) -> @@ -586,12 +592,16 @@ let terms_of_binders bl = 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 = function - | {loc; v = GLocalAssum (Name id,_,_)}::l -> (CAst.make ?loc @@ CRef (Ident (loc,id), None)) :: extract_variables l - | {loc; v = GLocalDef (Name id,_,_,_)}::l -> extract_variables l - | {loc; v = GLocalDef (Anonymous,_,_,_)}::l - | {loc; v = GLocalAssum (Anonymous,_,_)}::l -> user_err Pp.(str "Cannot turn \"_\" into a term.") - | {loc; v = GLocalPattern ((u,_),_,_,_)}::l -> term_of_pat u :: extract_variables l + let rec extract_variables l = match l with + | bnd :: l -> + let loc = bnd.CAst.loc in + begin match DAst.get bnd with + | GLocalAssum (Name id,_,_) -> (CAst.make ?loc @@ CRef (Ident (loc,id), None)) :: extract_variables l + | GLocalDef (Name id,_,_,_) -> extract_variables l + | GLocalDef (Anonymous,_,_,_) + | GLocalAssum (Anonymous,_,_) -> user_err Pp.(str "Cannot turn \"_\" into a term.") + | GLocalPattern ((u,_),_,_,_) -> term_of_pat u :: extract_variables l + end | [] -> [] in extract_variables bl @@ -647,7 +657,7 @@ let instantiate_notation_constr loc intern ntnvars subst infos c = let bindings = Id.Map.map mk_env terms in Some (Genintern.generic_substitute_notation bindings arg) in - CAst.make ?loc @@ GHole (knd, naming, arg) + DAst.make ?loc @@ GHole (knd, naming, arg) | NBinderList (x,y,iter,terminator) -> (try (* All elements of the list are in scopes (scopt,subscopes) *) @@ -665,22 +675,22 @@ let instantiate_notation_constr loc intern ntnvars subst infos c = let a,letins = snd (Option.get binderopt) in let e = make_letins letins (aux subst' infos c') in let (_loc,(na,bk,t)) = a in - CAst.make ?loc @@ GProd (na,bk,t,e) + DAst.make ?loc @@ GProd (na,bk,t,e) | NLambda (Name id,NHole _,c') when option_mem_assoc id binderopt -> let a,letins = snd (Option.get binderopt) in let (_loc,(na,bk,t)) = a in - CAst.make ?loc @@ GLambda (na,bk,t,make_letins letins (aux subst' infos c')) + DAst.make ?loc @@ GLambda (na,bk,t,make_letins letins (aux subst' infos c')) (* Two special cases to keep binder name synchronous with BinderType *) | NProd (na,NHole(Evar_kinds.BinderType na',naming,arg),c') when Name.equal na na' -> let subinfos,na = traverse_binder subst avoid subinfos na in - let ty = CAst.make ?loc @@ GHole (Evar_kinds.BinderType na,naming,arg) in - CAst.make ?loc @@ GProd (na,Explicit,ty,aux subst' subinfos c') + let ty = DAst.make ?loc @@ GHole (Evar_kinds.BinderType na,naming,arg) in + DAst.make ?loc @@ GProd (na,Explicit,ty,aux subst' subinfos c') | NLambda (na,NHole(Evar_kinds.BinderType na',naming,arg),c') when Name.equal na na' -> let subinfos,na = traverse_binder subst avoid subinfos na in - let ty = CAst.make ?loc @@ GHole (Evar_kinds.BinderType na,naming,arg) in - CAst.make ?loc @@ GLambda (na,Explicit,ty,aux subst' subinfos c') + let ty = DAst.make ?loc @@ GHole (Evar_kinds.BinderType na,naming,arg) in + DAst.make ?loc @@ GLambda (na,Explicit,ty,aux subst' subinfos c') | t -> glob_constr_of_notation_constr_with_binders ?loc (traverse_binder subst avoid) (aux subst') subinfos t @@ -692,7 +702,7 @@ let instantiate_notation_constr loc intern ntnvars subst infos c = intern {env with tmp_scope = scopt; scopes = subscopes @ env.scopes} a with Not_found -> - CAst.make ?loc ( + DAst.make ?loc ( try GVar (Id.Map.find id renaming) with Not_found -> @@ -732,7 +742,7 @@ let string_of_ty = function | Variable -> "var" let gvar (loc, id) us = match us with -| None -> CAst.make ?loc @@ GVar id +| None -> DAst.make ?loc @@ GVar id | Some _ -> user_err ?loc (str "Variable " ++ pr_id id ++ str " cannot have a universe instance") @@ -774,24 +784,27 @@ let intern_var genv (ltacvars,ntnvars) namedctx loc id us = let impls = implicits_of_global ref in let scopes = find_arguments_scope ref in Dumpglob.dump_reference ?loc "<>" (string_of_qualid (Decls.variable_secpath id)) "var"; - CAst.make ?loc @@ GRef (ref, us), impls, scopes, [] + DAst.make ?loc @@ GRef (ref, us), impls, scopes, [] with e when CErrors.noncritical e -> (* [id] a goal variable *) gvar (loc,id) us, [], [], [] let find_appl_head_data c = - match c.v with + match DAst.get c with | GRef (ref,_) -> let impls = implicits_of_global ref in let scopes = find_arguments_scope ref in c, impls, scopes, [] - | GApp ({ v = GRef (ref,_) },l) - when l != [] -> + | GApp (r, l) -> + begin match DAst.get r with + | GRef (ref,_) when l != [] -> let n = List.length l in let impls = implicits_of_global ref in let scopes = find_arguments_scope ref in c, List.map (drop_first_implicits n) impls, List.skipn_at_least n scopes,[] + | _ -> c,[],[],[] + end | _ -> c,[],[],[] let error_not_enough_arguments ?loc = @@ -824,7 +837,7 @@ let intern_reference ref = (* Is it a global reference or a syntactic definition? *) let intern_qualid loc qid intern env lvar us args = match intern_extended_global_of_qualid (loc,qid) with - | TrueGlobal ref -> (CAst.make ?loc @@ GRef (ref, us)), true, args + | TrueGlobal ref -> (DAst.make ?loc @@ GRef (ref, us)), true, args | SynDef sp -> let (ids,c) = Syntax_def.search_syntactic_definition sp in let nids = List.length ids in @@ -836,23 +849,32 @@ let intern_qualid loc qid intern env lvar 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 lvar subst infos c in - let c = match us, c with - | None, _ -> c - | Some _, { loc; v = GRef (ref, None) } -> CAst.make ?loc @@ GRef (ref, us) - | Some _, { loc; v = GApp ({ loc = loc' ; v = GRef (ref, None) }, arg) } -> - CAst.make ?loc @@ GApp (CAst.make ?loc:loc' @@ GRef (ref, us), arg) - | Some _, _ -> + let loc = c.CAst.loc in + let err () = user_err ?loc (str "Notation " ++ pr_qualid qid - ++ str " cannot have a universe instance," - ++ str " its expanded head does not start with a reference") + ++ str " cannot have a universe instance," + ++ str " its expanded head does not start with a reference") + in + let c = match us, DAst.get c with + | None, _ -> c + | Some _, GRef (ref, None) -> DAst.make ?loc @@ GRef (ref, us) + | Some _, GApp (r, arg) -> + let loc' = r.CAst.loc in + begin match DAst.get r with + | GRef (ref, None) -> + DAst.make ?loc @@ GApp (DAst.make ?loc:loc' @@ GRef (ref, us), arg) + | _ -> err () + end + | 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 lvar us args = - match intern_qualid loc qid intern env lvar us args with - | { v = GRef (VarRef _, _) },_,_ -> raise Not_found - | r -> r + let c, _, _ as r = intern_qualid loc qid intern env lvar 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) -> @@ -888,14 +910,14 @@ let interp_reference vars r = (** {5 Cases } *) (** Private internalization patterns *) -type raw_cases_pattern_expr_r = - | RCPatAlias of raw_cases_pattern_expr * Id.t +type 'a raw_cases_pattern_expr_r = + | RCPatAlias of 'a raw_cases_pattern_expr * Id.t | RCPatCstr of Globnames.global_reference - * raw_cases_pattern_expr list * raw_cases_pattern_expr list + * 'a raw_cases_pattern_expr list * 'a raw_cases_pattern_expr list (** [RCPatCstr (loc, c, l1, l2)] represents ((@c l1) l2) *) | RCPatAtom of Id.t option - | RCPatOr of raw_cases_pattern_expr list -and raw_cases_pattern_expr = raw_cases_pattern_expr_r CAst.t + | RCPatOr of 'a raw_cases_pattern_expr list +and 'a raw_cases_pattern_expr = ('a raw_cases_pattern_expr_r, 'a) DAst.t (** {6 Elementary bricks } *) let apply_scope_env env = function @@ -977,7 +999,7 @@ let insert_local_defs_in_pattern (ind,j) l = let (decls,_) = decompose_prod_assum typi in let rec aux decls args = match decls, args with - | Context.Rel.Declaration.LocalDef _ :: decls, args -> (CAst.make @@ RCPatAtom None) :: aux decls args + | Context.Rel.Declaration.LocalDef _ :: decls, args -> (DAst.make @@ RCPatAtom None) :: aux decls args | _, [] -> [] (* In particular, if there were trailing local defs, they have been inserted *) | Context.Rel.Declaration.LocalAssum _ :: decls, a :: args -> a :: aux decls args | _ -> assert false in @@ -1013,10 +1035,10 @@ let add_implicits_check_length fail nargs nargs_with_letin impls_st len_pl1 pl2 else Int.equal args_len nargs_with_letin || (fst (fail (nargs - List.length impl_list + i)))) ,l) |imp::q as il,[] -> if is_status_implicit imp && maximal_insertion_of imp - then let (b,out) = aux i (q,[]) in (b,(CAst.make @@ RCPatAtom None)::out) + then let (b,out) = aux i (q,[]) in (b,(DAst.make @@ RCPatAtom None)::out) else fail (remaining_args (len_pl1+i) il) |imp::q,(hh::tt as l) -> if is_status_implicit imp - then let (b,out) = aux i (q,l) in (b,(CAst.make @@ RCPatAtom(None))::out) + then let (b,out) = aux i (q,l) in (b,(DAst.make @@ RCPatAtom(None))::out) else let (b,out) = aux (succ i) (q,tt) in (b,hh::out) in aux 0 (impl_list,pl2) @@ -1041,8 +1063,9 @@ let chop_params_pattern loc ind args with_letin = else Inductiveops.inductive_nparams ind in assert (nparams <= List.length args); let params,args = List.chop nparams args in - List.iter (function { v = PatVar Anonymous } -> () - | { loc; v = PatVar _ } | { loc; v = PatCstr(_,_,_) } -> error_parameter_not_implicit ?loc) params; + List.iter (fun c -> match DAst.get c with + | PatVar Anonymous -> () + | PatVar _ | PatCstr(_,_,_) -> error_parameter_not_implicit ?loc:c.CAst.loc) params; args let find_constructor loc add_params ref = @@ -1062,7 +1085,7 @@ let find_constructor loc add_params ref = then Inductiveops.inductive_nparamdecls ind else Inductiveops.inductive_nparams ind in - List.make nb ([], [(Id.Map.empty, CAst.make @@ PatVar Anonymous)]) + List.make nb ([], [(Id.Map.empty, DAst.make @@ PatVar Anonymous)]) | None -> [] let find_pattern_variable = function @@ -1235,15 +1258,23 @@ let product_of_cases_patterns aliases idspl = List.map (fun (subst',ptail) -> (merge_subst subst subst',p::ptail)) ptaill) pl))) idspl (aliases.alias_ids,[aliases.alias_map,[]]) -let rec subst_pat_iterator y t = CAst.(map (function +let rec subst_pat_iterator y t = DAst.(map (function | RCPatAtom id as p -> - begin match id with Some x when Id.equal x y -> t.v | _ -> p end + begin match id with Some x when Id.equal x y -> DAst.get t | _ -> p end | RCPatCstr (id,l1,l2) -> RCPatCstr (id,List.map (subst_pat_iterator y t) l1, List.map (subst_pat_iterator y t) l2) | RCPatAlias (p,a) -> RCPatAlias (subst_pat_iterator y t p,a) | RCPatOr pl -> RCPatOr (List.map (subst_pat_iterator y t) pl))) +let is_non_zero c = match c with +| { CAst.v = CPrim (Numeral (p, true)) } -> not (is_zero p) +| _ -> false + +let is_non_zero_pat c = match c with +| { CAst.v = CPatPrim (Numeral (p, true)) } -> not (is_zero p) +| _ -> false + let drop_notations_pattern looked_for genv = (* At toplevel, Constructors and Inductives are accepted, in recursive calls only constructor are allowed *) @@ -1258,11 +1289,16 @@ let drop_notations_pattern looked_for genv = if top then looked_for else function ConstructRef _ -> () | _ -> raise Not_found in (** [rcp_of_glob] : from [glob_constr] to [raw_cases_pattern_expr] *) - let rec rcp_of_glob x = CAst.(map (function + let rec rcp_of_glob x = DAst.(map (function | GVar id -> RCPatAtom (Some id) | GHole (_,_,_) -> RCPatAtom (None) | GRef (g,_) -> RCPatCstr (g,[],[]) - | GApp ({ v = GRef (g,_) }, l) -> RCPatCstr (g, List.map rcp_of_glob l,[]) + | GApp (r, l) -> + begin match DAst.get r with + | GRef (g,_) -> RCPatCstr (g, List.map rcp_of_glob l,[]) + | _ -> + CErrors.anomaly Pp.(str "Invalid return pattern from Notation.interp_prim_token_cases_pattern_expr.") + end | _ -> 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 = @@ -1303,25 +1339,25 @@ let drop_notations_pattern looked_for genv = let open CAst in let loc = pt.loc in match pt.v with - | CPatAlias (p, id) -> CAst.make ?loc @@ RCPatAlias (in_pat top scopes p, id) + | CPatAlias (p, id) -> DAst.make ?loc @@ RCPatAlias (in_pat top scopes p, id) | CPatRecord l -> let sorted_fields = sort_fields ~complete:false loc l (fun _idx -> CAst.make ?loc @@ CPatAtom None) in begin match sorted_fields with - | None -> CAst.make ?loc @@ RCPatAtom None + | None -> DAst.make ?loc @@ RCPatAtom None | Some (n, head, pl) -> let pl = if !asymmetric_patterns then pl else let pars = List.make n (CAst.make ?loc @@ CPatAtom None) in List.rev_append pars pl in match drop_syndef top scopes head pl with - | Some (a,b,c) -> CAst.make ?loc @@ RCPatCstr(a, b, c) + | Some (a,b,c) -> DAst.make ?loc @@ RCPatCstr(a, b, c) | None -> raise (InternalizationError (loc,NotAConstructor head)) end | CPatCstr (head, None, pl) -> begin match drop_syndef top scopes head pl with - | Some (a,b,c) -> CAst.make ?loc @@ RCPatCstr(a, b, c) + | Some (a,b,c) -> DAst.make ?loc @@ RCPatCstr(a, b, c) | None -> raise (InternalizationError (loc,NotAConstructor head)) end | CPatCstr (r, Some expl_pl, pl) -> @@ -1330,14 +1366,14 @@ let drop_notations_pattern looked_for genv = raise (InternalizationError (loc,NotAConstructor r)) in if expl_pl == [] then (* Convention: (@r) deactivates all further implicit arguments and scopes *) - CAst.make ?loc @@ RCPatCstr (g, List.map (in_pat false scopes) pl, []) + DAst.make ?loc @@ RCPatCstr (g, List.map (in_pat false scopes) pl, []) else (* Convention: (@r expl_pl) deactivates implicit arguments in expl_pl and in pl *) (* but not scopes in expl_pl *) let (argscs1,_) = find_remaining_scopes expl_pl pl g in - CAst.make ?loc @@ RCPatCstr (g, List.map2 (in_pat_sc scopes) argscs1 expl_pl @ List.map (in_pat false scopes) pl, []) - | CPatNotation ("- _",([{ CAst.v = CPatPrim(Numeral (p,true)) }],[]),[]) - when not (is_zero p) -> + DAst.make ?loc @@ RCPatCstr (g, List.map2 (in_pat_sc scopes) argscs1 expl_pl @ List.map (in_pat false scopes) pl, []) + | CPatNotation ("- _",([a],[]),[]) when is_non_zero_pat a -> + let p = match a.CAst.v with CPatPrim (Numeral (p, _)) -> p | _ -> assert false in let pat, _df = Notation.interp_prim_token_cases_pattern_expr ?loc (ensure_kind false loc) (Numeral (p,false)) scopes in rcp_of_glob pat | CPatNotation ("( _ )",([a],[]),[]) -> @@ -1358,11 +1394,11 @@ let drop_notations_pattern looked_for genv = | CPatAtom Some id -> begin match drop_syndef top scopes id [] with - | Some (a,b,c) -> CAst.make ?loc @@ RCPatCstr (a, b, c) - | None -> CAst.make ?loc @@ RCPatAtom (Some (find_pattern_variable id)) + | Some (a,b,c) -> DAst.make ?loc @@ RCPatCstr (a, b, c) + | None -> DAst.make ?loc @@ RCPatAtom (Some (find_pattern_variable id)) end - | CPatAtom None -> CAst.make ?loc @@ RCPatAtom None - | CPatOr pl -> CAst.make ?loc @@ RCPatOr (List.map (in_pat top scopes) pl) + | CPatAtom None -> DAst.make ?loc @@ RCPatAtom None + | CPatOr pl -> DAst.make ?loc @@ RCPatOr (List.map (in_pat top scopes) pl) | CPatCast (_,_) -> (* We raise an error if the pattern contains a cast, due to current restrictions on casts in patterns. Cast in patterns @@ -1389,19 +1425,19 @@ let drop_notations_pattern looked_for genv = let (a,(scopt,subscopes)) = Id.Map.find id subst in in_pat top (scopt,subscopes@snd scopes) a with Not_found -> - if Id.equal id ldots_var then CAst.make ?loc @@ RCPatAtom (Some id) else + if Id.equal id ldots_var then DAst.make ?loc @@ RCPatAtom (Some id) else anomaly (str "Unbound pattern notation variable: " ++ Id.print id ++ str ".") end | NRef g -> ensure_kind top loc g; let (_,argscs) = find_remaining_scopes [] args g in - CAst.make ?loc @@ RCPatCstr (g, [], List.map2 (in_pat_sc scopes) argscs args) + DAst.make ?loc @@ RCPatCstr (g, [], List.map2 (in_pat_sc scopes) argscs args) | NApp (NRef g,pl) -> ensure_kind top loc g; let (argscs1,argscs2) = find_remaining_scopes pl args g in let pl = List.map2 (fun x -> in_not false loc (x,snd scopes) fullsubst []) argscs1 pl in let pl = add_local_defs_and_check_length loc genv g pl args in - CAst.make ?loc @@ RCPatCstr (g, pl @ List.map (in_pat false scopes) args, []) + DAst.make ?loc @@ RCPatCstr (g, pl @ List.map (in_pat false scopes) args, []) | NList (x,y,iter,terminator,lassoc) -> if not (List.is_empty args) then user_err ?loc (strbrk "Application of arguments to a recursive notation not supported in patterns."); @@ -1418,7 +1454,7 @@ let drop_notations_pattern looked_for genv = anomaly (Pp.str "Inconsistent substitution of recursive notation.")) | NHole _ -> let () = assert (List.is_empty args) in - CAst.make ?loc @@ RCPatAtom None + DAst.make ?loc @@ RCPatAtom None | t -> error_invalid_pattern_notation ?loc () in in_pat true @@ -1427,10 +1463,10 @@ let rec intern_pat genv aliases pat = let idslpl2 = List.map (intern_pat genv empty_alias) pl2 in let (ids',pll) = product_of_cases_patterns aliases (idslpl1@idslpl2) in let pl' = List.map (fun (asubst,pl) -> - (asubst, CAst.make ?loc @@ PatCstr (c,chop_params_pattern loc (fst c) pl with_letin,alias_of aliases))) pll in + (asubst, DAst.make ?loc @@ PatCstr (c,chop_params_pattern loc (fst c) pl with_letin,alias_of aliases))) pll in ids',pl' in let loc = CAst.(pat.loc) in - match CAst.(pat.v) with + match DAst.get pat with | RCPatAlias (p, id) -> let aliases' = merge_aliases aliases id in intern_pat genv aliases' p @@ -1448,10 +1484,10 @@ let rec intern_pat genv aliases pat = intern_cstr_with_all_args loc c with_letin idslpl1 (expl_pl@pl2) | RCPatAtom (Some id) -> let aliases = merge_aliases aliases id in - (aliases.alias_ids,[aliases.alias_map, CAst.make ?loc @@ PatVar (alias_of aliases)]) + (aliases.alias_ids,[aliases.alias_map, DAst.make ?loc @@ PatVar (alias_of aliases)]) | RCPatAtom (None) -> let { alias_ids = ids; alias_map = asubst; } = aliases in - (ids, [asubst, CAst.make ?loc @@ PatVar (alias_of aliases)]) + (ids, [asubst, DAst.make ?loc @@ PatVar (alias_of aliases)]) | RCPatOr pl -> assert (not (List.is_empty pl)); let pl' = List.map (intern_pat genv aliases) pl in @@ -1475,7 +1511,7 @@ let intern_ind_pattern genv scopes pat = with InternalizationError(loc,NotAConstructor _) -> error_bad_inductive_type ?loc in let loc = no_not.CAst.loc in - match no_not.CAst.v with + match DAst.get no_not with | RCPatCstr (head, expl_pl, pl) -> let c = (function IndRef ind -> ind | _ -> error_bad_inductive_type ?loc) head in let with_letin, pl2 = add_implicits_check_ind_length genv loc c @@ -1506,9 +1542,18 @@ let merge_impargs l args = let get_implicit_name n imps = Some (Impargs.name_of_implicit (List.nth imps (n-1))) -let set_hole_implicit i b = function - | {loc; v = GRef (r,_) } | { v = GApp ({loc; v = GRef (r,_)},_) } -> Loc.tag ?loc (Evar_kinds.ImplicitArg (r,i,b),Misctypes.IntroAnonymous,None) - | {loc; v = GVar id } -> Loc.tag ?loc (Evar_kinds.ImplicitArg (VarRef id,i,b),Misctypes.IntroAnonymous,None) +let set_hole_implicit i b c = + let loc = c.CAst.loc in + match DAst.get c with + | GRef (r, _) -> Loc.tag ?loc (Evar_kinds.ImplicitArg (r,i,b),Misctypes.IntroAnonymous,None) + | GApp (r, _) -> + let loc = r.CAst.loc in + begin match DAst.get r with + | GRef (r, _) -> + Loc.tag ?loc (Evar_kinds.ImplicitArg (r,i,b),Misctypes.IntroAnonymous,None) + | _ -> anomaly (Pp.str "Only refs have implicits.") + end + | GVar id -> Loc.tag ?loc (Evar_kinds.ImplicitArg (VarRef id,i,b),Misctypes.IntroAnonymous,None) | _ -> anomaly (Pp.str "Only refs have implicits.") let exists_implicit_name id = @@ -1574,7 +1619,8 @@ let internalize globalenv env pattern_mode (_, ntnvars as lvar) c = let before, after = split_at_annot bl n in let (env',rbefore) = List.fold_left intern_local_binder (env,[]) before in let ro = f (intern env') in - let n' = Option.map (fun _ -> List.count (function | { v = GLocalAssum _ } -> true + let n' = Option.map (fun _ -> List.count (fun c -> match DAst.get c with + | GLocalAssum _ -> true | _ -> false (* remove let-ins *)) rbefore) n in n', ro, List.fold_left intern_local_binder (env',rbefore) after @@ -1597,7 +1643,7 @@ let internalize globalenv env pattern_mode (_, ntnvars as lvar) c = push_name_env ntnvars (impls_type_list ~args:fix_args tyi) en (Loc.tag @@ Name name)) 0 env' lf in (a,b,c,intern {env'' with tmp_scope = None} bd)) dl idl_temp in - CAst.make ?loc @@ + DAst.make ?loc @@ GRec (GFix (Array.map (fun (ro,_,_,_) -> ro) idl,n), Array.of_list lf, @@ -1624,7 +1670,7 @@ let internalize globalenv env pattern_mode (_, ntnvars as lvar) c = push_name_env ntnvars (impls_type_list ~args:cofix_args tyi) en (Loc.tag @@ Name name)) 0 env' lf in (b,c,intern {env'' with tmp_scope = None} bd)) dl idl_tmp in - CAst.make ?loc @@ + DAst.make ?loc @@ GRec (GCoFix n, Array.of_list lf, Array.map (fun (bl,_,_) -> bl) idl, @@ -1641,11 +1687,11 @@ let internalize globalenv env pattern_mode (_, ntnvars as lvar) c = | CLetIn (na,c1,t,c2) -> let inc1 = intern (reset_tmp_scope env) c1 in let int = Option.map (intern_type env) t in - CAst.make ?loc @@ + DAst.make ?loc @@ GLetIn (snd na, inc1, int, intern (push_name_env ntnvars (impls_term_list inc1) env na) c2) - | CNotation ("- _",([{ CAst.v = CPrim (Numeral (p,true)) }],[],[])) - when not (is_zero p) -> + | CNotation ("- _", ([a],[],[])) when is_non_zero a -> + let p = match a.CAst.v with CPrim (Numeral (p, _)) -> p | _ -> assert false in intern env (CAst.make ?loc @@ CPrim (Numeral (p,false))) | CNotation ("( _ )",([a],[],[])) -> intern env a | CNotation (ntn,args) -> @@ -1664,13 +1710,13 @@ let internalize globalenv env pattern_mode (_, ntnvars as lvar) c = lvar us args ref in (* Rem: GApp(_,f,[]) stands for @f *) - CAst.make ?loc @@ + DAst.make ?loc @@ GApp (f, intern_args env args_scopes (List.map fst args)) | CApp ((isproj,f), args) -> - let f,args = match f with + let f,args = match f.CAst.v with (* Compact notations like "t.(f args') args" *) - | { CAst.v = CApp ((Some _,f), args') } when not (Option.has_some isproj) -> + | CApp ((Some _,f), args') when not (Option.has_some isproj) -> f,args'@args (* Don't compact "(f args') args" to resolve implicits separately *) | _ -> f,args in @@ -1719,9 +1765,13 @@ let internalize globalenv env pattern_mode (_, ntnvars as lvar) c = (Id.Set.union ex_ids as_in_vars) (reset_hidden_inductive_implicit_test env) in (* PatVars before a real pattern do not need to be matched *) let stripped_match_from_in = + let is_patvar c = match DAst.get c with + | PatVar _ -> true + | _ -> false + in let rec aux = function | [] -> [] - | (_, { v = PatVar _}) :: q -> aux q + | (_, c) :: q when is_patvar c -> aux q | l -> l in aux match_from_in in let rtnpo = match stripped_match_from_in with @@ -1730,20 +1780,20 @@ let internalize globalenv env pattern_mode (_, ntnvars as lvar) c = (* Build a return predicate by expansion of the patterns of the "in" clause *) 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 -> (CAst.make @@ GVar id),(Name id,None)) thevars (* "match v1,..,vn" *) 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 @@ ([],thepats, (* "|p1,..,pn" *) Option.cata (intern_type env') - (CAst.make ?loc @@ GHole(Evar_kinds.CasesType false,Misctypes.IntroAnonymous,None)) + (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) (CAst.make @@ PatVar Anonymous), (* "|_,..,_" *) - CAst.make @@ GHole(Evar_kinds.ImpossibleCase,Misctypes.IntroAnonymous,None))] (* "=> _" *) in - Some (CAst.make @@ GCases(Term.RegularStyle,sub_rtn,sub_tms,main_sub_eqn::catch_all_sub_eqn)) + [Loc.tag @@ ([],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 let eqns' = List.map (intern_eqn (List.length tms) env) eqns in - CAst.make ?loc @@ + DAst.make ?loc @@ GCases (sty, rtnpo, tms, List.flatten eqns') | CLetTuple (nal, (na,po), b, c) -> let env' = reset_tmp_scope env in @@ -1753,7 +1803,7 @@ let internalize globalenv env pattern_mode (_, ntnvars as lvar) c = let env'' = push_name_env ntnvars (Variable,[],[],[]) (reset_hidden_inductive_implicit_test env') (Loc.tag na') in intern_type env'' u) po in - CAst.make ?loc @@ + DAst.make ?loc @@ GLetTuple (List.map snd nal, (na', p'), b', intern (List.fold_left (push_name_env ntnvars (Variable,[],[],[])) (reset_hidden_inductive_implicit_test env) nal) c) | CIf (c, (na,po), b1, b2) -> @@ -1763,7 +1813,7 @@ let internalize globalenv env pattern_mode (_, ntnvars as lvar) c = let env'' = push_name_env ntnvars (Variable,[],[],[]) (reset_hidden_inductive_implicit_test env) (Loc.tag na') in intern_type env'' p) po in - CAst.make ?loc @@ + DAst.make ?loc @@ GIf (c', (na', p'), intern env b1, intern env b2) | CHole (k, naming, solve) -> let k = match k with @@ -1791,28 +1841,28 @@ let internalize globalenv env pattern_mode (_, ntnvars as lvar) c = let (_, glb) = Genintern.generic_intern ist gen in Some glb in - CAst.make ?loc @@ + DAst.make ?loc @@ GHole (k, naming, solve) (* Parsing pattern variables *) | CPatVar n when pattern_mode -> - CAst.make ?loc @@ + DAst.make ?loc @@ GPatVar (Evar_kinds.SecondOrderPatVar n) | CEvar (n, []) when pattern_mode -> - CAst.make ?loc @@ + DAst.make ?loc @@ GPatVar (Evar_kinds.FirstOrderPatVar n) (* end *) (* Parsing existential variables *) | CEvar (n, l) -> - CAst.make ?loc @@ + DAst.make ?loc @@ GEvar (n, List.map (on_snd (intern env)) l) | CPatVar _ -> raise (InternalizationError (loc,IllegalMetavariable)) (* end *) | CSort s -> - CAst.make ?loc @@ + DAst.make ?loc @@ GSort s | CCast (c1, c2) -> - CAst.make ?loc @@ + DAst.make ?loc @@ GCast (intern env c1, Miscops.map_cast_type (intern_type env) c2) ) and intern_type env = intern (set_type_scope env) @@ -1850,9 +1900,11 @@ let internalize globalenv env pattern_mode (_, ntnvars as lvar) c = (* the "match" part *) let tm' = intern env tm in (* the "as" part *) - let extra_id,na = match tm', na with - | {loc; v = GVar id}, None when not (Id.Map.mem id (snd lvar)) -> Some id,(loc,Name id) - | {loc; v = GRef (VarRef id, _)}, None -> Some id,(loc,Name id) + let extra_id,na = + let loc = tm'.CAst.loc in + match DAst.get tm', na with + | GVar id, None when not (Id.Map.mem id (snd lvar)) -> Some id,(loc,Name id) + | GRef (VarRef id, _), None -> Some id,(loc,Name id) | _, None -> None,(Loc.tag Anonymous) | _, Some (loc,na) -> None,(loc,na) in (* the "in" part *) @@ -1871,21 +1923,25 @@ let internalize globalenv env pattern_mode (_, ntnvars as lvar) c = let rec canonize_args case_rel_ctxt arg_pats forbidden_names match_acc var_acc = let add_name l = function | _,Anonymous -> l - | loc,(Name y as x) -> (y, CAst.make ?loc @@ PatVar x) :: l in + | loc,(Name y as x) -> (y, DAst.make ?loc @@ PatVar x) :: l in 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) | [],[] -> (add_name match_acc na, var_acc) - | _::t, { loc; v = PatVar x}::tt -> - canonize_args t tt forbidden_names - (add_name match_acc (loc,x)) ((loc,x)::var_acc) | (LocalAssum (cano_name,ty) | LocalDef (cano_name,_,ty)) :: t, c::tt -> - let fresh = - Namegen.next_name_away_with_default_using_types "iV" cano_name forbidden_names (EConstr.of_constr ty) in - canonize_args t tt (fresh::forbidden_names) - ((fresh,c)::match_acc) ((cases_pattern_loc c,Name fresh)::var_acc) + begin match DAst.get c with + | PatVar x -> + let loc = c.CAst.loc in + canonize_args t tt forbidden_names + (add_name match_acc (loc,x)) ((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 (fresh::forbidden_names) + ((fresh,c)::match_acc) ((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 @@ -1924,7 +1980,7 @@ let internalize globalenv env pattern_mode (_, ntnvars as lvar) c = (* with implicit arguments if maximal insertion is set *) [] else - (CAst.map_from_loc (fun ?loc (a,b,c) -> GHole(a,b,c)) + (DAst.map_from_loc (fun ?loc (a,b,c) -> GHole(a,b,c)) (set_hole_implicit (n,get_implicit_name n l) (force_inference_of imp) c) ) :: aux (n+1) impl' subscopes' eargs rargs end @@ -1950,9 +2006,11 @@ let internalize globalenv env pattern_mode (_, ntnvars as lvar) c = and smart_gapp f loc = function | [] -> f - | l -> match f with - | { loc = loc'; v = GApp (g, args) } -> CAst.make ?loc:(Loc.merge_opt loc' loc) @@ GApp (g, args@l) - | _ -> CAst.make ?loc:(Loc.merge_opt (loc_of_glob_constr f) loc) @@ GApp (f, l) + | l -> + let loc' = f.CAst.loc in + match DAst.get f with + | GApp (g, args) -> DAst.make ?loc:(Loc.merge_opt loc' loc) @@ GApp (g, args@l) + | _ -> DAst.make ?loc:(Loc.merge_opt (loc_of_glob_constr f) loc) @@ GApp (f, l) and intern_args env subscopes = function | [] -> [] @@ -2038,7 +2096,9 @@ let interp_constr_evars_gen_impls env evdref ?(impls=empty_internalization_env) expected_type c = let c = intern_gen expected_type ~impls env c in let imps = Implicit_quantifiers.implicits_of_glob_constr ~with_products:(expected_type == IsType) c in - understand_tcc_evars env evdref ~expected_type c, imps + let evd, c = understand_tcc env !evdref ~expected_type c in + evdref := evd; + c, imps let interp_constr_evars_impls env evdref ?(impls=empty_internalization_env) c = interp_constr_evars_gen_impls env evdref ~impls WithoutTypeConstraint c @@ -2053,7 +2113,9 @@ let interp_type_evars_impls env evdref ?(impls=empty_internalization_env) c = let interp_constr_evars_gen env evdref ?(impls=empty_internalization_env) expected_type c = let c = intern_gen expected_type ~impls env c in - understand_tcc_evars env evdref ~expected_type c + let evd, c = understand_tcc env !evdref ~expected_type c in + evdref := evd; + c let interp_constr_evars env evdref ?(impls=empty_internalization_env) c = interp_constr_evars_gen env evdref WithoutTypeConstraint ~impls c @@ -2098,7 +2160,9 @@ let interp_binder env sigma na t = let interp_binder_evars env evdref na t = let t = intern_gen IsType env t in let t' = locate_if_hole ?loc:(loc_of_glob_constr t) na t in - understand_tcc_evars env evdref ~expected_type:IsType t' + let evd, c = understand_tcc env !evdref ~expected_type:IsType t' in + evdref := evd; + c let my_intern_constr env lvar acc c = internalize env acc false lvar c @@ -2125,7 +2189,8 @@ let interp_glob_context_evars env evdref k bl = if Option.is_empty b then locate_if_hole ?loc:(loc_of_glob_constr t) na t else t in - let t = understand_tcc_evars env evdref ~expected_type:IsType t' in + let (evd,t) = understand_tcc env !evdref ~expected_type:IsType t' in + evdref := evd; match b with None -> let d = LocalAssum (na,t) in @@ -2137,7 +2202,8 @@ let interp_glob_context_evars env evdref k bl = in (push_rel d env, d::params, succ n, impls) | Some b -> - let c = understand_tcc_evars env evdref ~expected_type:(OfType t) b in + let (evd,c) = understand_tcc env !evdref ~expected_type:(OfType t) b in + evdref := evd; let d = LocalDef (na, c, t) in (push_rel d env, d::params, n, impls)) (env,[],k+1,[]) (List.rev bl) diff --git a/interp/declare.ml b/interp/declare.ml index 70f422b51..7fcb38296 100644 --- a/interp/declare.ml +++ b/interp/declare.ml @@ -32,14 +32,6 @@ type internal_flag = | InternalTacticRequest (* kernel action, no message is displayed *) | UserIndividualRequest (* user action, a message is displayed *) -(** XML output hooks *) - -let (f_xml_declare_variable, xml_declare_variable) = Hook.make ~default:ignore () -let (f_xml_declare_constant, xml_declare_constant) = Hook.make ~default:ignore () -let (f_xml_declare_inductive, xml_declare_inductive) = Hook.make ~default:ignore () - -let if_xml f x = if !Flags.xml_export then f x else () - (** Declaration of section variables and local definitions *) type section_variable_entry = @@ -95,7 +87,6 @@ let declare_variable id obj = declare_var_implicits id; Notation.declare_ref_arguments_scope (VarRef id); Heads.declare_head (EvalVarRef id); - if_xml (Hook.get f_xml_declare_variable) oname; oname @@ -256,7 +247,6 @@ let declare_constant ?(internal = UserIndividualRequest) ?(local = false) id ?(e let id = Label.to_id (pi3 (Constant.repr3 c)) in ignore(add_leaf id o); update_tables c; - let () = if_xml (Hook.get f_xml_declare_constant) (InternalTacticRequest, c) in match role with | Safe_typing.Subproof -> () | Safe_typing.Schema (ind, kind) -> !declare_scheme kind [|ind,c|] @@ -268,9 +258,7 @@ let declare_constant ?(internal = UserIndividualRequest) ?(local = false) id ?(e cst_kind = kind; cst_locl = local; } in - let kn = declare_constant_common id cst in - let () = if_xml (Hook.get f_xml_declare_constant) (internal, kn) in - kn + declare_constant_common id cst let declare_definition ?(internal=UserIndividualRequest) ?(opaque=false) ?(kind=Decl_kinds.Definition) ?(local = false) @@ -410,7 +398,6 @@ let declare_mind mie = let isrecord,isprim = declare_projections mind in declare_mib_implicits mind; declare_inductive_argument_scopes mind mie; - if_xml (Hook.get f_xml_declare_inductive) (isrecord,oname); oname, isprim (* Declaration messages *) diff --git a/interp/declare.mli b/interp/declare.mli index 6a0943464..ccd7d28bb 100644 --- a/interp/declare.mli +++ b/interp/declare.mli @@ -69,11 +69,6 @@ val set_declare_scheme : the whole block and a boolean indicating if it is a primitive record. *) val declare_mind : mutual_inductive_entry -> object_name * bool -(** Hooks for XML output *) -val xml_declare_variable : (object_name -> unit) Hook.t -val xml_declare_constant : (internal_flag * constant -> unit) Hook.t -val xml_declare_inductive : (bool * object_name -> unit) Hook.t - (** Declaration messages *) val definition_message : Id.t -> unit diff --git a/interp/implicit_quantifiers.ml b/interp/implicit_quantifiers.ml index e498d979d..cae67c3e7 100644 --- a/interp/implicit_quantifiers.ml +++ b/interp/implicit_quantifiers.ml @@ -119,13 +119,14 @@ let free_vars_of_binders ?(bound=Id.Set.empty) l (binders : local_binder_expr li in aux bound l binders let generalizable_vars_of_glob_constr ?(bound=Id.Set.empty) ?(allowed=Id.Set.empty) = - let rec vars bound vs t = match t with - | { loc; CAst.v = GVar id } -> + let rec vars bound vs c = match DAst.get c with + | GVar id -> + let loc = c.CAst.loc in if is_freevar bound (Global.env ()) id then if Id.List.mem_assoc_sym id vs then vs else (Loc.tag ?loc id) :: vs else vs - | c -> Glob_ops.fold_glob_constr_with_binders Id.Set.add vars bound vs c + | _ -> Glob_ops.fold_glob_constr_with_binders Id.Set.add vars bound vs c in fun rt -> let vars = List.rev (vars bound [] rt) in List.iter (fun (loc, id) -> @@ -253,11 +254,11 @@ let implicits_of_glob_constr ?(with_products=true) l = (ExplByPos (i, name), (true, true, true)) :: l | _ -> l in - let rec aux i { loc; CAst.v = c } = + let rec aux i c = let abs na bk b = add_impl i na bk (aux (succ i) b) in - match c with + match DAst.get c with | GProd (na, bk, t, b) -> if with_products then abs na bk b else diff --git a/interp/notation.ml b/interp/notation.ml index c07a00943..176ac3bf6 100644 --- a/interp/notation.ml +++ b/interp/notation.ml @@ -41,7 +41,6 @@ open Context.Named.Declaration (**********************************************************************) (* Scope of symbols *) -type level = precedence * tolerability list type delimiters = string type notation_location = (DirPath.t * DirPath.t) * string @@ -83,11 +82,18 @@ let parenRelation_eq t1 t2 = match t1, t2 with | Prec l1, Prec l2 -> Int.equal l1 l2 | _ -> false -let level_eq (l1, t1) (l2, t2) = +let notation_var_internalization_type_eq v1 v2 = match v1, v2 with +| NtnInternTypeConstr, NtnInternTypeConstr -> true +| NtnInternTypeBinder, NtnInternTypeBinder -> true +| NtnInternTypeIdent, NtnInternTypeIdent -> true +| (NtnInternTypeConstr | NtnInternTypeBinder | NtnInternTypeIdent), _ -> false + +let level_eq (l1, t1, u1) (l2, t2, u2) = let tolerability_eq (i1, r1) (i2, r2) = Int.equal i1 i2 && parenRelation_eq r1 r2 in Int.equal l1 l2 && List.equal tolerability_eq t1 t2 + && List.equal notation_var_internalization_type_eq u1 u2 let declare_scope scope = try let _ = String.Map.find scope !scope_map in () @@ -259,19 +265,28 @@ let keymap_find key map = (* Scopes table : interpretation -> scope_name *) let notations_key_table = ref (KeyMap.empty : notation_rule list KeyMap.t) -let prim_token_key_table = ref KeyMap.empty +let prim_token_key_table = ref (KeyMap.empty : (string * (any_glob_constr -> prim_token option) * bool) KeyMap.t) -let glob_prim_constr_key = function - | { CAst.v = GApp ({ CAst.v = GRef (ref,_) } ,_) } | { CAst.v = GRef (ref,_) } -> RefKey (canonical_gr ref) +let glob_prim_constr_key c = match DAst.get c with + | GRef (ref, _) -> RefKey (canonical_gr ref) + | GApp (c, _) -> + begin match DAst.get c with + | GRef (ref, _) -> RefKey (canonical_gr ref) + | _ -> Oth + end | _ -> Oth -let glob_constr_keys = function - | { CAst.v = GApp ({ CAst.v = GRef (ref,_) },_) } -> [RefKey (canonical_gr ref); Oth] - | { CAst.v = GRef (ref,_) } -> [RefKey (canonical_gr ref)] +let glob_constr_keys c = match DAst.get c with + | GApp (c, _) -> + begin match DAst.get c with + | GRef (ref, _) -> [RefKey (canonical_gr ref); Oth] + | _ -> [Oth] + end + | GRef (ref,_) -> [RefKey (canonical_gr ref)] | _ -> [Oth] -let cases_pattern_key = function - | { CAst.v = PatCstr (ref,_,_) } -> RefKey (canonical_gr (ConstructRef ref)) +let cases_pattern_key c = match DAst.get c with + | PatCstr (ref,_,_) -> RefKey (canonical_gr (ConstructRef ref)) | _ -> Oth let notation_constr_key = function (* Rem: NApp(NRef ref,[]) stands for @ref *) @@ -294,7 +309,7 @@ type 'a prim_token_interpreter = type cases_pattern_status = bool (* true = use prim token in patterns *) type 'a prim_token_uninterpreter = - glob_constr list * (glob_constr -> 'a option) * cases_pattern_status + glob_constr list * (any_glob_constr -> 'a option) * cases_pattern_status type internal_prim_token_interpreter = ?loc:Loc.t -> prim_token -> required_module * (unit -> glob_constr) @@ -490,11 +505,15 @@ let interp_prim_token_gen ?loc g p local_scopes = let interp_prim_token ?loc = interp_prim_token_gen ?loc (fun _ -> ()) -let rec check_allowed_ref_in_pat looked_for = CAst.(with_val (function +let rec check_allowed_ref_in_pat looked_for = DAst.(with_val (function | GVar _ | GHole _ -> () | GRef (g,_) -> looked_for g - | GApp ({ v = GRef (g,_) },l) -> - looked_for g; List.iter (check_allowed_ref_in_pat looked_for) l + | GApp (f, l) -> + begin match DAst.get f with + | GRef (g, _) -> + looked_for g; List.iter (check_allowed_ref_in_pat looked_for) l + | _ -> raise Not_found + end | _ -> raise Not_found)) let interp_prim_token_cases_pattern_expr ?loc looked_for p = @@ -526,7 +545,7 @@ let uninterp_prim_token c = try let (sc,numpr,_) = KeyMap.find (glob_prim_constr_key c) !prim_token_key_table in - match numpr c with + match numpr (AnyGlobConstr c) with | None -> raise Notation_ops.No_match | Some n -> (sc,n) with Not_found -> raise Notation_ops.No_match @@ -539,8 +558,8 @@ let uninterp_prim_token_ind_pattern ind args = if not b then raise Notation_ops.No_match; let args' = List.map (fun x -> snd (glob_constr_of_closed_cases_pattern x)) args in - let ref = CAst.make @@ GRef (ref,None) in - match numpr (CAst.make @@ GApp (ref,args')) with + let ref = DAst.make @@ GRef (ref,None) in + match numpr (AnyGlobConstr (DAst.make @@ GApp (ref,args'))) with | None -> raise Notation_ops.No_match | Some n -> (sc,n) with Not_found -> raise Notation_ops.No_match @@ -551,7 +570,7 @@ let uninterp_prim_token_cases_pattern c = let (sc,numpr,b) = KeyMap.find k !prim_token_key_table in if not b then raise Notation_ops.No_match; let na,c = glob_constr_of_closed_cases_pattern c in - match numpr c with + match numpr (AnyGlobConstr c) with | None -> raise Notation_ops.No_match | Some n -> (na,sc,n) with Not_found -> raise Notation_ops.No_match diff --git a/interp/notation.mli b/interp/notation.mli index e63ad10cd..75c8d5aa5 100644 --- a/interp/notation.mli +++ b/interp/notation.mli @@ -21,7 +21,6 @@ open Ppextend (** A scope is a set of interpreters for symbols + optional interpreter and printers for integers + optional delimiters *) -type level = precedence * tolerability list type delimiters = string type scope type scopes (** = [scope_name list] *) @@ -71,7 +70,7 @@ type 'a prim_token_interpreter = ?loc:Loc.t -> 'a -> glob_constr type 'a prim_token_uninterpreter = - glob_constr list * (glob_constr -> 'a option) * cases_pattern_status + glob_constr list * (any_glob_constr -> 'a option) * cases_pattern_status type rawnum = Constrexpr.raw_natural_number * Constrexpr.sign @@ -97,9 +96,9 @@ val interp_prim_token_cases_pattern_expr : ?loc:Loc.t -> (global_reference -> un raise [No_match] if no such token *) val uninterp_prim_token : - glob_constr -> scope_name * prim_token + 'a glob_constr_g -> scope_name * prim_token val uninterp_prim_token_cases_pattern : - cases_pattern -> Name.t * scope_name * prim_token + 'a cases_pattern_g -> Name.t * scope_name * prim_token val uninterp_prim_token_ind_pattern : inductive -> cases_pattern list -> scope_name * prim_token @@ -125,8 +124,8 @@ val interp_notation : ?loc:Loc.t -> notation -> local_scopes -> type notation_rule = interp_rule * interpretation * int option (** Return the possible notations for a given term *) -val uninterp_notations : glob_constr -> notation_rule list -val uninterp_cases_pattern_notations : cases_pattern -> notation_rule list +val uninterp_notations : 'a glob_constr_g -> notation_rule list +val uninterp_cases_pattern_notations : 'a cases_pattern_g -> notation_rule list val uninterp_ind_pattern_notations : inductive -> notation_rule list (** Test if a notation is available in the scopes diff --git a/interp/notation_ops.ml b/interp/notation_ops.ml index 5d703011d..034116731 100644 --- a/interp/notation_ops.ml +++ b/interp/notation_ops.ml @@ -99,43 +99,43 @@ let name_to_ident = function let to_id g e id = let e,na = g e (Name id) in e,name_to_ident na -let rec cases_pattern_fold_map ?loc g e = CAst.with_val (function +let rec cases_pattern_fold_map ?loc g e = DAst.with_val (function | PatVar na -> - let e',na' = g e na in e', CAst.make ?loc @@ PatVar na' + let e',na' = g e na in e', DAst.make ?loc @@ PatVar na' | PatCstr (cstr,patl,na) -> let e',na' = g e na in - let e',patl' = List.fold_map (cases_pattern_fold_map ?loc g) e patl in - e', CAst.make ?loc @@ PatCstr (cstr,patl',na') + let e',patl' = List.fold_left_map (cases_pattern_fold_map ?loc g) e patl in + e', DAst.make ?loc @@ PatCstr (cstr,patl',na') ) let subst_binder_type_vars l = function | Evar_kinds.BinderType (Name id) -> let id = - try match Id.List.assoc id l with { CAst.v = GVar id' } -> id' | _ -> id + try match DAst.get (Id.List.assoc id l) with GVar id' -> id' | _ -> id with Not_found -> id in Evar_kinds.BinderType (Name id) | e -> e -let rec subst_glob_vars l gc = CAst.map (function - | GVar id as r -> (try (Id.List.assoc id l).CAst.v with Not_found -> r) +let rec subst_glob_vars l gc = DAst.map (function + | GVar id as r -> (try DAst.get (Id.List.assoc id l) with Not_found -> r) | GProd (Name id,bk,t,c) -> let id = - try match Id.List.assoc id l with { CAst.v = GVar id' } -> id' | _ -> id + try match DAst.get (Id.List.assoc id l) with GVar id' -> id' | _ -> id with Not_found -> id in GProd (Name id,bk,subst_glob_vars l t,subst_glob_vars l c) | GLambda (Name id,bk,t,c) -> let id = - try match Id.List.assoc id l with { CAst.v = GVar id' } -> id' | _ -> id + try match DAst.get (Id.List.assoc id l) with GVar id' -> id' | _ -> id with Not_found -> id in GLambda (Name id,bk,subst_glob_vars l t,subst_glob_vars l c) | GHole (x,naming,arg) -> GHole (subst_binder_type_vars l x,naming,arg) - | _ -> (map_glob_constr (subst_glob_vars l) gc).CAst.v (* assume: id is not binding *) + | _ -> DAst.get (map_glob_constr (subst_glob_vars l) gc) (* assume: id is not binding *) ) gc let ldots_var = Id.of_string ".." let glob_constr_of_notation_constr_with_binders ?loc g f e nc = - let lt x = CAst.make ?loc x in lt @@ match nc with + let lt x = DAst.make ?loc x in lt @@ match nc with | NVar id -> GVar id | NApp (a,args) -> GApp (f e a, List.map (f e) args) | NList (x,y,iter,tail,swap) -> @@ -143,13 +143,13 @@ let glob_constr_of_notation_constr_with_binders ?loc g f e nc = let innerl = (ldots_var,t)::(if swap then [] else [x, lt @@ GVar y]) in let inner = lt @@ GApp (lt @@ GVar (ldots_var),[subst_glob_vars innerl it]) in let outerl = (ldots_var,inner)::(if swap then [x, lt @@ GVar y] else []) in - (subst_glob_vars outerl it).CAst.v + DAst.get (subst_glob_vars outerl it) | NBinderList (x,y,iter,tail) -> let t = f e tail in let it = f e iter in let innerl = [(ldots_var,t);(x, lt @@ GVar y)] in let inner = lt @@ GApp (lt @@ GVar ldots_var,[subst_glob_vars innerl it]) in let outerl = [(ldots_var,inner)] in - (subst_glob_vars outerl it).CAst.v + DAst.get (subst_glob_vars outerl it) | NLambda (na,ty,c) -> let e',na = g e na in GLambda (na,Explicit,f e ty,f e' c) | NProd (na,ty,c) -> @@ -169,21 +169,21 @@ let glob_constr_of_notation_constr_with_binders ?loc g f e nc = let fold (idl,e) na = let (e,na) = g e na in ((Name.cons na idl,e),na) in let eqnl' = List.map (fun (patl,rhs) -> let ((idl,e),patl) = - List.fold_map (cases_pattern_fold_map ?loc fold) ([],e) patl in + List.fold_left_map (cases_pattern_fold_map ?loc fold) ([],e) patl in Loc.tag (idl,patl,f e rhs)) eqnl in GCases (sty,Option.map (f e') rtntypopt,tml',eqnl') | NLetTuple (nal,(na,po),b,c) -> - let e',nal = List.fold_map g e nal in + let e',nal = List.fold_left_map g e nal in let e'',na = g e na in GLetTuple (nal,(na,Option.map (f e'') po),f e b,f e' c) | NIf (c,(na,po),b1,b2) -> let e',na = g e na in GIf (f e c,(na,Option.map (f e') po),f e b1,f e b2) | NRec (fk,idl,dll,tl,bl) -> - let e,dll = Array.fold_map (List.fold_map (fun e (na,oc,b) -> + let e,dll = Array.fold_left_map (List.fold_left_map (fun e (na,oc,b) -> let e,na = g e na in (e,(na,Explicit,Option.map (f e) oc,f e b)))) e dll in - let e',idl = Array.fold_map (to_id g) e idl in + let e',idl = Array.fold_left_map (to_id g) e idl in GRec (fk,idl,dll,Array.map (f e) tl,Array.map (f e') bl) | NCast (c,k) -> GCast (f e c,Miscops.map_cast_type (f e) k) | NSort x -> GSort x @@ -201,28 +201,34 @@ let glob_constr_of_notation_constr ?loc x = let add_id r id = r := (id :: pi1 !r, pi2 !r, pi3 !r) let add_name r = function Anonymous -> () | Name id -> add_id r id +let is_gvar id c = match DAst.get c with +| GVar id' -> Id.equal id id' +| _ -> false + let split_at_recursive_part c = let sub = ref None in - let open CAst in - let rec aux = function - | { loc = loc0; v = GApp ({ loc; v = GVar v },c::l) } when Id.equal v ldots_var -> (* *) + let rec aux c = + let loc0 = c.CAst.loc in + match DAst.get c with + | GApp (f, c::l) when is_gvar ldots_var f -> (* *) + let loc = f.CAst.loc in begin match !sub with | None -> let () = sub := Some c in begin match l with - | [] -> CAst.make ?loc @@ GVar ldots_var - | _ :: _ -> CAst.make ?loc:loc0 @@ GApp (CAst.make ?loc @@ GVar ldots_var, l) + | [] -> DAst.make ?loc @@ GVar ldots_var + | _ :: _ -> DAst.make ?loc:loc0 @@ GApp (DAst.make ?loc @@ GVar ldots_var, l) end | Some _ -> (* Not narrowed enough to find only one recursive part *) raise Not_found end - | c -> map_glob_constr aux c in + | _ -> map_glob_constr aux c in let outer_iterator = aux c in match !sub with | None -> (* No recursive pattern found *) raise Not_found | Some c -> - match outer_iterator.v with + match DAst.get outer_iterator with | GVar v when Id.equal v ldots_var -> (* Not enough context *) raise Not_found | _ -> outer_iterator, c @@ -231,7 +237,7 @@ let subtract_loc loc1 loc2 = let l2 = fst (Option.cata Loc.unloc (0,0) loc2) in Some (Loc.make_loc (l1,l2-1)) -let check_is_hole id = function { CAst.v = GHole _ } -> () | t -> +let check_is_hole id t = match DAst.get t with GHole _ -> () | _ -> user_err ?loc:(loc_of_glob_constr t) (strbrk "In recursive notation with binders, " ++ pr_id id ++ strbrk " is expected to come without type.") @@ -243,21 +249,24 @@ type recursive_pattern_kind = | RecursiveBinders of glob_constr * glob_constr let compare_recursive_parts found f f' (iterator,subc) = - let open CAst in let diff = ref None in let terminator = ref None in - let rec aux c1 c2 = match c1.v, c2.v with + let rec aux c1 c2 = match DAst.get c1, DAst.get c2 with | GVar v, term when Id.equal v ldots_var -> (* We found the pattern *) assert (match !terminator with None -> true | Some _ -> false); terminator := Some c2; true - | GApp ({ v = GVar v },l1), GApp (term, l2) when Id.equal v ldots_var -> + | GApp (f,l1), GApp (term, l2) -> + begin match DAst.get f with + | GVar v when Id.equal v ldots_var -> (* We found the pattern, but there are extra arguments *) (* (this allows e.g. alternative (recursive) notation of application) *) assert (match !terminator with None -> true | Some _ -> false); terminator := Some term; List.for_all2eq aux l1 l2 + | _ -> mk_glob_constr_eq aux c1 c2 + end | GVar x, GVar y when not (Id.equal x y) -> (* We found the position where it differs *) let lassoc = match !terminator with None -> false | Some _ -> true in @@ -301,13 +310,13 @@ let compare_recursive_parts found f f' (iterator,subc) = (pi1 !found, (x,y) :: pi2 !found, pi3 !found),x,y,lassoc in let iterator = f' (if lassoc then iterator - else subst_glob_vars [x, CAst.make @@ GVar y] iterator) in + else subst_glob_vars [x, DAst.make @@ GVar y] iterator) in (* found have been collected by compare_constr *) found := newfound; NList (x,y,iterator,f (Option.get !terminator),lassoc) | Some (x,y,RecursiveBinders (t_x,t_y)) -> let newfound = (pi1 !found, pi2 !found, (x,y) :: pi3 !found) in - let iterator = f' (subst_glob_vars [x, CAst.make @@ GVar y] iterator) in + let iterator = f' (subst_glob_vars [x, DAst.make @@ GVar y] iterator) in (* found have been collected by compare_constr *) found := newfound; check_is_hole x t_x; @@ -325,15 +334,20 @@ let notation_constr_and_vars_of_glob_constr a = try compare_recursive_parts found aux aux' (split_at_recursive_part c) with Not_found -> found := keepfound; - match c.CAst.v with - | GApp ({ CAst.v = GVar f; loc},[c]) when Id.equal f ldots_var -> + match DAst.get c with + | GApp (t, [_]) -> + begin match DAst.get t with + | GVar f when Id.equal f ldots_var -> (* Fall on the second part of the recursive pattern w/o having found the first part *) + let loc = t.CAst.loc in user_err ?loc (str "Cannot find where the recursive pattern starts.") + | _ -> aux' c + end | _c -> aux' c - and aux' x = CAst.with_val (function + and aux' x = DAst.with_val (function | GVar id -> add_id found id; NVar id | GApp (g,args) -> NApp (aux g, List.map aux args) | GLambda (na,bk,ty,c) -> add_name found na; NLambda (na,aux ty,aux c) @@ -433,7 +447,7 @@ let notation_constr_of_glob_constr nenv a = let notation_constr_of_constr avoiding t = let t = EConstr.of_constr t in - let t = Detyping.detype false avoiding (Global.env()) Evd.empty t in + let t = Detyping.detype Detyping.Now false avoiding (Global.env()) Evd.empty t in let nenv = { ninterp_var_type = Id.Map.empty; ninterp_rec_vars = Id.Map.empty; @@ -441,13 +455,13 @@ let notation_constr_of_constr avoiding t = notation_constr_of_glob_constr nenv t let rec subst_pat subst pat = - match pat.CAst.v with + match DAst.get pat with | PatVar _ -> pat | PatCstr (((kn,i),j),cpl,n) -> let kn' = subst_mind subst kn and cpl' = List.smartmap (subst_pat subst) cpl in if kn' == kn && cpl' == cpl then pat else - CAst.make ?loc:pat.CAst.loc @@ PatCstr (((kn',i),j),cpl',n) + DAst.make ?loc:pat.CAst.loc @@ PatCstr (((kn',i),j),cpl',n) let rec subst_notation_constr subst bound raw = match raw with @@ -576,14 +590,14 @@ let abstract_return_type_context pi mklam tml rtno = List.fold_right mklam nal rtn) rtno -let abstract_return_type_context_glob_constr = +let abstract_return_type_context_glob_constr tml rtn = abstract_return_type_context (fun (_,(_,nal)) -> nal) - (fun na c -> CAst.make @@ - GLambda(na,Explicit,CAst.make @@ GHole(Evar_kinds.InternalHole,Misctypes.IntroAnonymous,None),c)) + (fun na c -> DAst.make @@ + GLambda(na,Explicit,DAst.make @@ GHole(Evar_kinds.InternalHole,Misctypes.IntroAnonymous,None),c)) tml rtn -let abstract_return_type_context_notation_constr = +let abstract_return_type_context_notation_constr tml rtn = abstract_return_type_context snd - (fun na c -> NLambda(na,NHole (Evar_kinds.InternalHole, Misctypes.IntroAnonymous, None),c)) + (fun na c -> NLambda(na,NHole (Evar_kinds.InternalHole, Misctypes.IntroAnonymous, None),c)) tml rtn let is_term_meta id metas = try match Id.List.assoc id metas with _,(NtnTypeConstr | NtnTypeConstrList) -> true | _ -> false @@ -651,19 +665,23 @@ let add_binding_env alp (terms,onlybinders,termlists,binderlists) var v = let add_bindinglist_env (terms,onlybinders,termlists,binderlists) x bl = (terms,onlybinders,termlists,(x,bl)::binderlists) -let rec pat_binder_of_term t = CAst.map (function +let rec pat_binder_of_term t = DAst.map (function | GVar id -> PatVar (Name id) - | GApp ({ CAst.v = GRef (ConstructRef cstr,_)}, l) -> + | GApp (t, l) -> + begin match DAst.get t with + | GRef (ConstructRef cstr,_) -> let nparams = Inductiveops.inductive_nparams (fst cstr) in let _,l = List.chop nparams l in PatCstr (cstr, List.map pat_binder_of_term l, Anonymous) + | _ -> raise No_match + end | _ -> raise No_match ) t let bind_term_env alp (terms,onlybinders,termlists,binderlists as sigma) var v = try let v' = Id.List.assoc var terms in - match CAst.(v.v, v'.v) with + match DAst.get v, DAst.get v' with | GHole _, _ -> sigma | _, GHole _ -> let sigma = Id.List.remove_assoc var terms,onlybinders,termlists,binderlists in @@ -677,7 +695,7 @@ let bind_termlist_env alp (terms,onlybinders,termlists,binderlists as sigma) var try let vl' = Id.List.assoc var termlists in let unify_term v v' = - match CAst.(v.v, v'.v) with + match DAst.get v, DAst.get v' with | GHole _, _ -> v' | _, GHole _ -> v | _, _ -> if glob_constr_eq (alpha_rename (snd alp) v) v' then v' else raise No_match in @@ -693,8 +711,8 @@ let bind_termlist_env alp (terms,onlybinders,termlists,binderlists as sigma) var let bind_term_as_binding_env alp (terms,onlybinders,termlists,binderlists as sigma) var id = try - match Id.List.assoc var terms with - | { CAst.v = GVar id' } -> + match DAst.get (Id.List.assoc var terms) with + | GVar id' -> (if not (Id.equal id id') then (fst alp,(id,id')::snd alp) else alp), sigma | _ -> anomaly (str "A term which can be a binder has to be a variable.") @@ -702,7 +720,7 @@ let bind_term_as_binding_env alp (terms,onlybinders,termlists,binderlists as sig (* The matching against a term allowing to find the instance has not been found yet *) (* If it will be a different name, we shall unfortunately fail *) (* TODO: look at the consequences for alp *) - alp, add_env alp sigma var (CAst.make @@ GVar id) + alp, add_env alp sigma var (DAst.make @@ GVar id) let bind_binding_as_term_env alp (terms,onlybinders,termlists,binderlists as sigma) var id = try @@ -729,17 +747,19 @@ let bind_binding_env alp (terms,onlybinders,termlists,binderlists as sigma) var else (fst alp,(id1,id2)::snd alp),sigma with Not_found -> alp, add_binding_env alp sigma var v -let rec map_cases_pattern_name_left f = CAst.map (function +let rec map_cases_pattern_name_left f = DAst.map (function | PatVar na -> PatVar (f na) | PatCstr (c,l,na) -> PatCstr (c,List.map_left (map_cases_pattern_name_left f) l,f na) ) -let rec fold_cases_pattern_eq f x p p' = let open CAst in match p, p' with - | { loc; v = PatVar na}, { v = PatVar na' } -> let x,na = f x na na' in x, CAst.make ?loc @@ PatVar na - | { loc; v = PatCstr (c,l,na)}, { v = PatCstr (c',l',na') } when eq_constructor c c' -> +let rec fold_cases_pattern_eq f x p p' = + let loc = p.CAst.loc in + match DAst.get p, DAst.get p' with + | PatVar na, PatVar na' -> let x,na = f x na na' in x, DAst.make ?loc @@ PatVar na + | PatCstr (c,l,na), PatCstr (c',l',na') when eq_constructor c c' -> let x,l = fold_cases_pattern_list_eq f x l l' in let x,na = f x na na' in - x, CAst.make ?loc @@ PatCstr (c,l,na) + x, DAst.make ?loc @@ PatCstr (c,l,na) | _ -> failwith "Not equal" and fold_cases_pattern_list_eq f x pl pl' = match pl, pl' with @@ -750,7 +770,7 @@ and fold_cases_pattern_list_eq f x pl pl' = match pl, pl' with x, p :: pl | _ -> assert false -let rec cases_pattern_eq p1 p2 = match CAst.(p1.v, p2.v) with +let rec cases_pattern_eq p1 p2 = match DAst.get p1, DAst.get p2 with | PatVar na1, PatVar na2 -> Name.equal na1 na2 | PatCstr (c1, pl1, na1), PatCstr (c2, pl2, na2) -> eq_constructor c1 c2 && List.equal cases_pattern_eq pl1 pl2 && @@ -771,7 +791,7 @@ let bind_bindinglist_env alp (terms,onlybinders,termlists,binderlists as sigma) let unify_pat alp p p' = try fold_cases_pattern_eq unify_name alp p p' with Failure _ -> raise No_match in let unify_term alp v v' = - match CAst.(v.v, v'.v) with + match DAst.get v, DAst.get v' with | GHole _, _ -> v' | _, GHole _ -> v | _, _ -> if glob_constr_eq (alpha_rename (snd alp) v) v' then v else raise No_match in @@ -783,16 +803,16 @@ let bind_bindinglist_env alp (terms,onlybinders,termlists,binderlists as sigma) let unify_binding_kind bk bk' = if bk == bk' then bk' else raise No_match in let unify_binder alp b b' = let loc, loc' = CAst.(b.loc, b'.loc) in - match CAst.(b.v, b'.v) with + match DAst.get b, DAst.get b' with | GLocalAssum (na,bk,t), GLocalAssum (na',bk',t') -> let alp, na = unify_name alp na na' in - alp, CAst.make ?loc @@ GLocalAssum (na, unify_binding_kind bk bk', unify_term alp t t') + alp, DAst.make ?loc @@ GLocalAssum (na, unify_binding_kind bk bk', unify_term alp t t') | GLocalDef (na,bk,c,t), GLocalDef (na',bk',c',t') -> let alp, na = unify_name alp na na' in - alp, CAst.make ?loc @@ GLocalDef (na, unify_binding_kind bk bk', unify_term alp c c', unify_opt_term alp t t') + alp, DAst.make ?loc @@ GLocalDef (na, unify_binding_kind bk bk', unify_term alp c c', unify_opt_term alp t t') | GLocalPattern ((p,ids),id,bk,t), GLocalPattern ((p',_),_,bk',t') -> let alp, p = unify_pat alp p p' in - alp, CAst.make ?loc @@ GLocalPattern ((p,ids), id, unify_binding_kind bk bk', unify_term alp t t') + alp, DAst.make ?loc @@ GLocalPattern ((p,ids), id, unify_binding_kind bk bk', unify_term alp t t') | _ -> raise No_match in let rec unify alp bl bl' = match bl, bl' with @@ -819,19 +839,22 @@ let bind_bindinglist_as_term_env alp (terms,onlybinders,termlists,binderlists) v let unify_pat p p' = if cases_pattern_eq (map_cases_pattern_name_left (name_app (rename_var (snd alp))) p) p' then p' else raise No_match in - let unify_term_binder c = CAst.(map (fun b' -> - match c, b' with - | { v = GVar id}, GLocalAssum (na', bk', t') -> + let unify_term_binder c = DAst.(map (fun b' -> + match DAst.get c, b' with + | GVar id, GLocalAssum (na', bk', t') -> GLocalAssum (unify_id id na', bk', t') - | c, GLocalPattern ((p',ids), id, bk', t') -> + | _, GLocalPattern ((p',ids), id, bk', t') -> let p = pat_binder_of_term c in GLocalPattern ((unify_pat p p',ids), id, bk', t') | _ -> raise No_match )) in let rec unify cl bl' = match cl, bl' with | [], [] -> [] - | c :: cl, { CAst.v = GLocalDef ( _, _, _, t) } :: bl' -> unify cl bl' - | c :: cl, b' :: bl' -> unify_term_binder c b' :: unify cl bl' + | c :: cl, b' :: bl' -> + begin match DAst.get b' with + | GLocalDef ( _, _, _, t) -> unify cl bl' + | _ -> unify_term_binder c b' :: unify cl bl' + end | _ -> raise No_match in let bl = unify cl bl' in let sigma = (terms,onlybinders,termlists,Id.List.remove_assoc var binderlists) in @@ -872,7 +895,7 @@ let match_names metas (alp,sigma) na1 na2 = match (na1,na2) with | _ -> raise No_match let rec match_cases_pattern_binders metas acc pat1 pat2 = - match CAst.(pat1.v, pat2.v) with + match DAst.get pat1, DAst.get pat2 with | PatVar na1, PatVar na2 -> match_names metas acc na1 na2 | PatCstr (c1,patl1,na1), PatCstr (c2,patl2,na2) when eq_constructor c1 c2 && Int.equal (List.length patl1) (List.length patl2) -> @@ -882,21 +905,29 @@ let rec match_cases_pattern_binders metas acc pat1 pat2 = let glue_letin_with_decls = true -let rec match_iterated_binders islambda decls bi = CAst.(with_loc_val (fun ?loc -> function - | GLambda (Name p,bk,t, { v = GCases (LetPatternStyle,None,[({ v = GVar e },_)],[(_,(ids,[cp],b))])}) - when islambda && Id.equal p e -> - match_iterated_binders islambda ((CAst.make ?loc @@ GLocalPattern((cp,ids),p,bk,t))::decls) b - | GLambda (na,bk,t,b) when islambda -> - match_iterated_binders islambda ((CAst.make ?loc @@ GLocalAssum(na,bk,t))::decls) b - | GProd (Name p,bk,t, { v = GCases (LetPatternStyle,None,[({ v = GVar e },_)],[(_,(ids,[cp],b))]) } ) - when not islambda && Id.equal p e -> - match_iterated_binders islambda ((CAst.make ?loc @@ GLocalPattern((cp,ids),p,bk,t))::decls) b - | GProd ((Name _ as na),bk,t,b) when not islambda -> - match_iterated_binders islambda ((CAst.make ?loc @@ GLocalAssum(na,bk,t))::decls) b +let rec match_iterated_binders islambda decls bi = DAst.(with_loc_val (fun ?loc -> function + | GLambda (na,bk,t,b) as b0 -> + begin match na, DAst.get b with + | Name p, GCases (LetPatternStyle,None,[(e,_)],[(_,(ids,[cp],b))]) + when islambda && is_gvar p e -> + match_iterated_binders islambda ((DAst.make ?loc @@ GLocalPattern((cp,ids),p,bk,t))::decls) b + | _, _ when islambda -> + match_iterated_binders islambda ((DAst.make ?loc @@ GLocalAssum(na,bk,t))::decls) b + | _ -> (decls, DAst.make ?loc b0) + end + | GProd (na,bk,t,b) as b0 -> + begin match na, DAst.get b with + | Name p, GCases (LetPatternStyle,None,[(e,_)],[(_,(ids,[cp],b))]) + when not islambda && is_gvar p e -> + match_iterated_binders islambda ((DAst.make ?loc @@ GLocalPattern((cp,ids),p,bk,t))::decls) b + | Name _, _ when not islambda -> + match_iterated_binders islambda ((DAst.make ?loc @@ GLocalAssum(na,bk,t))::decls) b + | _ -> (decls, DAst.make ?loc b0) + end | GLetIn (na,c,t,b) when glue_letin_with_decls -> match_iterated_binders islambda - ((CAst.make ?loc @@ GLocalDef (na,Explicit (*?*), c,t))::decls) b - | b -> (decls, CAst.make ?loc b) + ((DAst.make ?loc @@ GLocalDef (na,Explicit (*?*), c,t))::decls) b + | b -> (decls, DAst.make ?loc b) )) bi let remove_sigma x (terms,onlybinders,termlists,binderlists) = @@ -948,7 +979,7 @@ let match_termlist match_fun alp metas sigma rest x y iter termin lassoc = else bind_termlist_env alp sigma x l -let does_not_come_from_already_eta_expanded_var = +let does_not_come_from_already_eta_expanded_var glob = (* This is hack to avoid looping on a rule with rhs of the form *) (* "?f (fun ?x => ?g)" since otherwise, matching "F H" expands in *) (* "F (fun x => H x)" and "H x" is recursively matched against the same *) @@ -958,12 +989,14 @@ let does_not_come_from_already_eta_expanded_var = (* The following test is then an approximation of what can be done *) (* optimally (whether other looping situations can occur remains to be *) (* checked). *) - function { CAst.v = GVar _ } -> false | _ -> true + match DAst.get glob with GVar _ -> false | _ -> true + +let is_var c = match DAst.get c with GVar _ -> true | _ -> false let rec match_ inner u alp metas sigma a1 a2 = let open CAst in let loc = a1.loc in - match a1.v, a2 with + match DAst.get a1, a2 with (* Matching notation variable *) | r1, NVar id2 when is_term_meta id2 metas -> bind_term_env alp sigma id2 a1 | GVar id1, NVar id2 when is_onlybinding_meta id2 metas -> bind_binding_as_term_env alp sigma id2 id1 @@ -973,50 +1006,62 @@ let rec match_ inner u alp metas sigma a1 a2 = | r1, NList (x,y,iter,termin,lassoc) -> match_termlist (match_hd u alp) alp metas sigma a1 x y iter termin lassoc - (* "λ p, let 'cp = p in t" -> "λ 'cp, t" *) - | GLambda (Name p,bk,t1, { v = GCases (LetPatternStyle,None,[({ v = GVar e},_)],[(_,(ids,[cp],b1))])}), - NBinderList (x,_,NLambda (Name _id2,_,b2),termin) when Id.equal p e -> - let (decls,b) = match_iterated_binders true [CAst.make ?loc @@ GLocalPattern((cp,ids),p,bk,t1)] b1 in + | GLambda (na1, bk, t1, b1), NBinderList (x,y,iter,termin) -> + begin match na1, DAst.get b1, iter with + (* "λ p, let 'cp = p in t" -> "λ 'cp, t" *) + | Name p, GCases (LetPatternStyle,None,[(e,_)],[(_,(ids,[cp],b1))]), NLambda (Name _, _, _) when is_gvar p e -> + let (decls,b) = match_iterated_binders true [DAst.make ?loc @@ GLocalPattern((cp,ids),p,bk,t1)] b1 in let alp,sigma = bind_bindinglist_env alp sigma x decls in match_in u alp metas sigma b termin - - (* Matching recursive notations for binders: ad hoc cases supporting let-in *) - | GLambda (na1,bk,t1,b1), NBinderList (x,_,NLambda (Name _id2,_,b2),termin)-> - let (decls,b) = match_iterated_binders true [CAst.make ?loc @@ GLocalAssum (na1,bk,t1)] b1 in + (* Matching recursive notations for binders: ad hoc cases supporting let-in *) + | _, _, NLambda (Name _,_,_) -> + let (decls,b) = match_iterated_binders true [DAst.make ?loc @@ GLocalAssum (na1,bk,t1)] b1 in (* TODO: address the possibility that termin is a Lambda itself *) let alp,sigma = bind_bindinglist_env alp sigma x decls in match_in u alp metas sigma b termin + (* Matching recursive notations for binders: general case *) + | _, _, _ -> + match_binderlist_with_app (match_hd u) alp metas sigma a1 x y iter termin + end - (* "∀ p, let 'cp = p in t" -> "∀ 'cp, t" *) - | GProd (Name p,bk,t1, { v = GCases (LetPatternStyle,None,[({ v = GVar e },_)],[(_,(ids,[cp],b1))]) } ), - NBinderList (x,_,NProd (Name _id2,_,b2),(NVar v as termin)) when Id.equal p e -> - let (decls,b) = match_iterated_binders true [CAst.make ?loc @@ GLocalPattern ((cp,ids),p,bk,t1)] b1 in + | GProd (na1, bk, t1, b1), NBinderList (x,y,iter,termin) -> + (* "∀ p, let 'cp = p in t" -> "∀ 'cp, t" *) + begin match na1, DAst.get b1, iter, termin with + | Name p, GCases (LetPatternStyle,None,[(e, _)],[(_,(ids,[cp],b1))]), NProd (Name _,_,_), NVar _ when is_gvar p e -> + let (decls,b) = match_iterated_binders true [DAst.make ?loc @@ GLocalPattern ((cp,ids),p,bk,t1)] b1 in let alp,sigma = bind_bindinglist_env alp sigma x decls in match_in u alp metas sigma b termin - - | GProd (na1,bk,t1,b1), NBinderList (x,_,NProd (Name _id2,_,b2),termin) - when na1 != Anonymous -> - let (decls,b) = match_iterated_binders false [CAst.make ?loc @@ GLocalAssum (na1,bk,t1)] b1 in + | _, _, NProd (Name _,_,_), _ when na1 != Anonymous -> + let (decls,b) = match_iterated_binders false [DAst.make ?loc @@ GLocalAssum (na1,bk,t1)] b1 in (* TODO: address the possibility that termin is a Prod itself *) let alp,sigma = bind_bindinglist_env alp sigma x decls in match_in u alp metas sigma b termin + (* Matching recursive notations for binders: general case *) + | _, _, _, _ -> + match_binderlist_with_app (match_hd u) alp metas sigma a1 x y iter termin + end + (* Matching recursive notations for binders: general case *) | _r, NBinderList (x,y,iter,termin) -> - match_binderlist_with_app (match_hd u) alp metas sigma a1 x y iter termin + match_binderlist_with_app (match_hd u) alp metas sigma a1 x y iter termin (* Matching individual binders as part of a recursive pattern *) - | GLambda (Name p,bk,t, { v = GCases (LetPatternStyle,None,[({ v = GVar e },_)],[(_,(ids,[cp],b1))])}), - NLambda (Name id,_,b2) - when is_bindinglist_meta id metas -> - let alp,sigma = bind_bindinglist_env alp sigma id [CAst.make ?loc @@ GLocalPattern ((cp,ids),p,bk,t)] in + | GLambda (na1, bk, t1, b1), NLambda (na2, t2, b2) -> + begin match na1, DAst.get b1, na2 with + | Name p, GCases (LetPatternStyle,None,[(e,_)],[(_,(ids,[cp],b1))]), Name id + when is_var e && is_bindinglist_meta id metas -> + let alp,sigma = bind_bindinglist_env alp sigma id [DAst.make ?loc @@ GLocalPattern ((cp,ids),p,bk,t1)] in match_in u alp metas sigma b1 b2 - | GLambda (na,bk,t,b1), NLambda (Name id,_,b2) - when is_bindinglist_meta id metas -> - let alp,sigma = bind_bindinglist_env alp sigma id [CAst.make ?loc @@ GLocalAssum (na,bk,t)] in + | _, _, Name id when is_bindinglist_meta id metas -> + let alp,sigma = bind_bindinglist_env alp sigma id [DAst.make ?loc @@ GLocalAssum (na1,bk,t1)] in match_in u alp metas sigma b1 b2 + | _ -> + match_binders u alp metas na1 na2 (match_in u alp metas sigma t1 t2) b1 b2 + end + | GProd (na,bk,t,b1), NProd (Name id,_,b2) when is_bindinglist_meta id metas && na != Anonymous -> - let alp,sigma = bind_bindinglist_env alp sigma id [CAst.make ?loc @@ GLocalAssum (na,bk,t)] in + let alp,sigma = bind_bindinglist_env alp sigma id [DAst.make ?loc @@ GLocalAssum (na,bk,t)] in match_in u alp metas sigma b1 b2 (* Matching compositionally *) @@ -1028,13 +1073,11 @@ let rec match_ inner u alp metas sigma a1 a2 = if n1 < n2 then let l21,l22 = List.chop (n2-n1) l2 in f1,l1, NApp (f2,l21), l22 else if n1 > n2 then - let l11,l12 = List.chop (n1-n2) l1 in CAst.make ?loc @@ GApp (f1,l11),l12, f2,l2 + let l11,l12 = List.chop (n1-n2) l1 in DAst.make ?loc @@ GApp (f1,l11),l12, f2,l2 else f1,l1, f2, l2 in let may_use_eta = does_not_come_from_already_eta_expanded_var f1 in List.fold_left2 (match_ may_use_eta u alp metas) (match_in u alp metas sigma f1 f2) l1 l2 - | GLambda (na1,_,t1,b1), NLambda (na2,t2,b2) -> - match_binders u alp metas na1 na2 (match_in u alp metas sigma t1 t2) b1 b2 | GProd (na1,_,t1,b1), NProd (na2,t2,b2) -> match_binders u alp metas na1 na2 (match_in u alp metas sigma t1 t2) b1 b2 | GLetIn (na1,b1,_,c1), NLetIn (na2,b2,None,c2) @@ -1101,17 +1144,17 @@ let rec match_ inner u alp metas sigma a1 a2 = let avoid = free_glob_vars a1 @ (* as in Namegen: *) glob_visible_short_qualid a1 in let id' = Namegen.next_ident_away id avoid in - let t1 = CAst.make @@ GHole(Evar_kinds.BinderType (Name id'),Misctypes.IntroAnonymous,None) in + let t1 = DAst.make @@ GHole(Evar_kinds.BinderType (Name id'),Misctypes.IntroAnonymous,None) in let sigma = match t2 with | NHole _ -> sigma | NVar id2 -> bind_term_env alp sigma id2 t1 | _ -> assert false in let (alp,sigma) = if is_bindinglist_meta id metas then - bind_bindinglist_env alp sigma id [CAst.make @@ GLocalAssum (Name id',Explicit,t1)] + bind_bindinglist_env alp sigma id [DAst.make @@ GLocalAssum (Name id',Explicit,t1)] else match_names metas (alp,sigma) (Name id') na in - match_in u alp metas sigma (mkGApp a1 (CAst.make @@ GVar id')) b2 + match_in u alp metas sigma (mkGApp a1 (DAst.make @@ GVar id')) b2 | (GRec _ | GEvar _), _ | _,_ -> raise No_match @@ -1132,7 +1175,7 @@ and match_equations u alp metas sigma (_,(_,patl1,rhs1)) (patl2,rhs2) = (alp,sigma) patl1 patl2 in match_in u alp metas sigma rhs1 rhs2 -let term_of_binder bi = CAst.make @@ match bi with +let term_of_binder bi = DAst.make @@ match bi with | Name id -> GVar id | Anonymous -> GHole (Evar_kinds.InternalHole,Misctypes.IntroAnonymous,None) @@ -1145,7 +1188,7 @@ let match_notation_constr u c (metas,pat) = with Not_found -> (* Happens for binders bound to Anonymous *) (* Find a better way to propagate Anonymous... *) - CAst.make @@GVar x in + DAst.make @@GVar x in List.fold_right (fun (x,(scl,typ)) (terms',termlists',binders') -> match typ with | NtnTypeConstr -> @@ -1185,8 +1228,7 @@ let match_cases_pattern_list match_fun metas sigma rest x y iter termin lassoc = (terms,onlybinders,(x,if lassoc then l else List.rev l)::termlists, binderlists) let rec match_cases_pattern metas (terms,(),termlists,() as sigma) a1 a2 = - let open CAst in - match a1.v, a2 with + match DAst.get a1, a2 with | r1, NVar id2 when Id.List.mem_assoc id2 metas -> (bind_env_cases_pattern sigma id2 a1),(0,[]) | PatVar Anonymous, NHole _ -> sigma,(0,[]) | PatCstr ((ind,_ as r1),largs,_), NRef (ConstructRef r2) when eq_constructor r1 r2 -> diff --git a/interp/notation_ops.mli b/interp/notation_ops.mli index 3154fd7ad..0904a4ea3 100644 --- a/interp/notation_ops.mli +++ b/interp/notation_ops.mli @@ -47,19 +47,19 @@ val glob_constr_of_notation_constr : ?loc:Loc.t -> notation_constr -> glob_const exception No_match -val match_notation_constr : bool -> glob_constr -> interpretation -> - (glob_constr * subscopes) list * (glob_constr list * subscopes) list * - (extended_glob_local_binder list * subscopes) list +val match_notation_constr : bool -> 'a glob_constr_g -> interpretation -> + ('a glob_constr_g * subscopes) list * ('a glob_constr_g list * subscopes) list * + ('a extended_glob_local_binder_g list * subscopes) list val match_notation_constr_cases_pattern : - cases_pattern -> interpretation -> - ((cases_pattern * subscopes) list * (cases_pattern list * subscopes) list) * - (int * cases_pattern list) + 'a cases_pattern_g -> interpretation -> + (('a cases_pattern_g * subscopes) list * ('a cases_pattern_g list * subscopes) list) * + (int * 'a cases_pattern_g list) val match_notation_constr_ind_pattern : - inductive -> cases_pattern list -> interpretation -> - ((cases_pattern * subscopes) list * (cases_pattern list * subscopes) list) * - (int * cases_pattern list) + inductive -> 'a cases_pattern_g list -> interpretation -> + (('a cases_pattern_g * subscopes) list * ('a cases_pattern_g list * subscopes) list) * + (int * 'a cases_pattern_g list) (** {5 Matching a notation pattern against a [glob_constr]} *) diff --git a/interp/ppextend.ml b/interp/ppextend.ml index 2bbe87bbc..3ebc9b71d 100644 --- a/interp/ppextend.ml +++ b/interp/ppextend.ml @@ -7,17 +7,10 @@ (************************************************************************) open Pp +open Notation_term (*s Pretty-print. *) -(* Dealing with precedences *) - -type precedence = int - -type parenRelation = L | E | Any | Prec of precedence - -type tolerability = precedence * parenRelation - type ppbox = | PpHB of int | PpHOVB of int diff --git a/interp/ppextend.mli b/interp/ppextend.mli index a347a5c7b..6ff5a4272 100644 --- a/interp/ppextend.mli +++ b/interp/ppextend.mli @@ -6,15 +6,9 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(** {6 Pretty-print. } *) - -(** Dealing with precedences *) - -type precedence = int +open Notation_term -type parenRelation = L | E | Any | Prec of precedence - -type tolerability = precedence * parenRelation +(** {6 Pretty-print. } *) type ppbox = | PpHB of int diff --git a/interp/reserve.ml b/interp/reserve.ml index b05f05283..a1e5bd0ea 100644 --- a/interp/reserve.ml +++ b/interp/reserve.ml @@ -110,7 +110,7 @@ let revert_reserved_type t = let t = EConstr.Unsafe.to_constr t in let reserved = KeyMap.find (constr_key t) !reserve_revtable in let t = EConstr.of_constr t in - let t = Detyping.detype false [] (Global.env()) Evd.empty t in + let t = Detyping.detype Detyping.Now false [] (Global.env()) Evd.empty t in (* pedrot: if [Notation_ops.match_notation_constr] may raise [Failure _] then I've introduced a bug... *) let filter _ pat = diff --git a/intf/glob_term.ml b/intf/glob_term.ml index dd122b972..757ba5786 100644 --- a/intf/glob_term.ml +++ b/intf/glob_term.ml @@ -24,66 +24,82 @@ type existential_name = Id.t (** The kind of patterns that occurs in "match ... with ... end" locs here refers to the ident's location, not whole pat *) -type cases_pattern_r = +type 'a cases_pattern_r = | PatVar of Name.t - | PatCstr of constructor * cases_pattern list * Name.t + | PatCstr of constructor * 'a cases_pattern_g list * Name.t (** [PatCstr(p,C,l,x)] = "|'C' 'l' as 'x'" *) -and cases_pattern = cases_pattern_r CAst.t +and 'a cases_pattern_g = ('a cases_pattern_r, 'a) DAst.t + +type cases_pattern = [ `any ] cases_pattern_g (** Representation of an internalized (or in other words globalized) term. *) -type glob_constr_r = +type 'a glob_constr_r = | GRef of global_reference * glob_level list option (** An identifier that represents a reference to an object defined either in the (global) environment or in the (local) context. *) | GVar of Id.t (** An identifier that cannot be regarded as "GRef". Bound variables are typically represented this way. *) - | GEvar of existential_name * (Id.t * glob_constr) list + | GEvar of existential_name * (Id.t * 'a glob_constr_g) list | GPatVar of Evar_kinds.matching_var_kind (** Used for patterns only *) - | GApp of glob_constr * glob_constr list - | GLambda of Name.t * binding_kind * glob_constr * glob_constr - | GProd of Name.t * binding_kind * glob_constr * glob_constr - | GLetIn of Name.t * glob_constr * glob_constr option * glob_constr - | GCases of case_style * glob_constr option * tomatch_tuples * cases_clauses + | GApp of 'a glob_constr_g * 'a glob_constr_g list + | GLambda of Name.t * binding_kind * 'a glob_constr_g * 'a glob_constr_g + | GProd of Name.t * binding_kind * 'a glob_constr_g * 'a glob_constr_g + | GLetIn of Name.t * 'a glob_constr_g * 'a glob_constr_g option * 'a glob_constr_g + | GCases of case_style * 'a glob_constr_g option * 'a tomatch_tuples_g * 'a cases_clauses_g (** [GCases(style,r,tur,cc)] = "match 'tur' return 'r' with 'cc'" (in [MatchStyle]) *) - | GLetTuple of Name.t list * (Name.t * glob_constr option) * glob_constr * glob_constr - | GIf of glob_constr * (Name.t * glob_constr option) * glob_constr * glob_constr - | GRec of fix_kind * Id.t array * glob_decl list array * - glob_constr array * glob_constr array + | GLetTuple of Name.t list * (Name.t * 'a glob_constr_g option) * 'a glob_constr_g * 'a glob_constr_g + | GIf of 'a glob_constr_g * (Name.t * 'a glob_constr_g option) * 'a glob_constr_g * 'a glob_constr_g + | GRec of 'a fix_kind_g * Id.t array * 'a glob_decl_g list array * + 'a glob_constr_g array * 'a glob_constr_g array | GSort of glob_sort | GHole of Evar_kinds.t * intro_pattern_naming_expr * Genarg.glob_generic_argument option - | GCast of glob_constr * glob_constr cast_type -and glob_constr = glob_constr_r CAst.t + | GCast of 'a glob_constr_g * 'a glob_constr_g cast_type +and 'a glob_constr_g = ('a glob_constr_r, 'a) DAst.t -and glob_decl = Name.t * binding_kind * glob_constr option * glob_constr +and 'a glob_decl_g = Name.t * binding_kind * 'a glob_constr_g option * 'a glob_constr_g -and fix_recursion_order = +and 'a fix_recursion_order_g = | GStructRec - | GWfRec of glob_constr - | GMeasureRec of glob_constr * glob_constr option + | GWfRec of 'a glob_constr_g + | GMeasureRec of 'a glob_constr_g * 'a glob_constr_g option -and fix_kind = - | GFix of ((int option * fix_recursion_order) array * int) +and 'a fix_kind_g = + | GFix of ((int option * 'a fix_recursion_order_g) array * int) | GCoFix of int -and predicate_pattern = +and 'a predicate_pattern_g = Name.t * (inductive * Name.t list) Loc.located option (** [(na,id)] = "as 'na' in 'id'" where if [id] is [Some(l,I,k,args)]. *) -and tomatch_tuple = (glob_constr * predicate_pattern) +and 'a tomatch_tuple_g = ('a glob_constr_g * 'a predicate_pattern_g) -and tomatch_tuples = tomatch_tuple list +and 'a tomatch_tuples_g = 'a tomatch_tuple_g list -and cases_clause = (Id.t list * cases_pattern list * glob_constr) Loc.located +and 'a cases_clause_g = (Id.t list * 'a cases_pattern_g list * 'a glob_constr_g) Loc.located (** [(p,il,cl,t)] = "|'cl' => 't'". Precondition: the free variables of [t] are members of [il]. *) -and cases_clauses = cases_clause list - -type extended_glob_local_binder_r = - | GLocalAssum of Name.t * binding_kind * glob_constr - | GLocalDef of Name.t * binding_kind * glob_constr * glob_constr option - | GLocalPattern of (cases_pattern * Id.t list) * Id.t * binding_kind * glob_constr -and extended_glob_local_binder = extended_glob_local_binder_r CAst.t +and 'a cases_clauses_g = 'a cases_clause_g list + +type glob_constr = [ `any ] glob_constr_g +type tomatch_tuple = [ `any ] tomatch_tuple_g +type tomatch_tuples = [ `any ] tomatch_tuples_g +type cases_clause = [ `any ] cases_clause_g +type cases_clauses = [ `any ] cases_clauses_g +type glob_decl = [ `any ] glob_decl_g +type fix_kind = [ `any ] fix_kind_g +type predicate_pattern = [ `any ] predicate_pattern_g +type fix_recursion_order = [ `any ] fix_recursion_order_g + +type any_glob_constr = AnyGlobConstr : 'r glob_constr_g -> any_glob_constr + +type 'a extended_glob_local_binder_r = + | GLocalAssum of Name.t * binding_kind * 'a glob_constr_g + | GLocalDef of Name.t * binding_kind * 'a glob_constr_g * 'a glob_constr_g option + | GLocalPattern of ('a cases_pattern_g * Id.t list) * Id.t * binding_kind * 'a glob_constr_g +and 'a extended_glob_local_binder_g = ('a extended_glob_local_binder_r, 'a) DAst.t + +type extended_glob_local_binder = [ `any ] extended_glob_local_binder_g (** A globalised term together with a closure representing the value of its free variables. Intended for use when these variables are taken diff --git a/intf/notation_term.ml b/intf/notation_term.ml index cee96040b..c342da3dc 100644 --- a/intf/notation_term.ml +++ b/intf/notation_term.ml @@ -88,11 +88,24 @@ type grammar_constr_prod_item = concat with last parsed list when true; additionally release the p last items as if they were parsed autonomously *) -type notation_grammar = { - notgram_level : int; +(** Dealing with precedences *) + +type precedence = int +type parenRelation = L | E | Any | Prec of precedence +type tolerability = precedence * parenRelation + +type level = precedence * tolerability list * notation_var_internalization_type list + +(** Grammar rules for a notation *) + +type one_notation_grammar = { + notgram_level : level; notgram_assoc : Extend.gram_assoc option; notgram_notation : Constrexpr.notation; notgram_prods : grammar_constr_prod_item list list; - notgram_typs : notation_var_internalization_type list; +} + +type notation_grammar = { notgram_onlyprinting : bool; + notgram_rules : one_notation_grammar list } diff --git a/intf/vernacexpr.ml b/intf/vernacexpr.ml index 6ef9532ad..2adf522b7 100644 --- a/intf/vernacexpr.ml +++ b/intf/vernacexpr.ml @@ -305,6 +305,14 @@ type inline = type module_ast_inl = module_ast * inline type module_binder = bool option * lident list * module_ast_inl +(** Cumulativity can be set globally, locally or unset locally and it + can not enabled at all. *) +type cumulative_inductive_parsing_flag = + | GlobalCumulativity + | GlobalNonCumulativity + | LocalCumulativity + | LocalNonCumulativity + (** {6 The type of vernacular expressions} *) type vernac_expr = @@ -336,7 +344,7 @@ type vernac_expr = | VernacExactProof of constr_expr | VernacAssumption of (locality option * assumption_object_kind) * inline * (plident list * constr_expr) with_coercion list - | VernacInductive of cumulative_inductive_flag * private_flag * inductive_flag * (inductive_expr * decl_notation list) list + | VernacInductive of cumulative_inductive_parsing_flag * private_flag * inductive_flag * (inductive_expr * decl_notation list) list | VernacFixpoint of locality option * (fixpoint_expr * decl_notation list) list | VernacCoFixpoint of diff --git a/kernel/primitives.ml b/kernel/cPrimitives.ml index 14c11bf10..14c11bf10 100644 --- a/kernel/primitives.ml +++ b/kernel/cPrimitives.ml diff --git a/kernel/primitives.mli b/kernel/cPrimitives.mli index 8cdffb670..8cdffb670 100644 --- a/kernel/primitives.mli +++ b/kernel/cPrimitives.mli diff --git a/kernel/declarations.ml b/kernel/declarations.ml index 9697b0b8b..e17fb1c38 100644 --- a/kernel/declarations.ml +++ b/kernel/declarations.ml @@ -250,16 +250,16 @@ and module_implementation = | Struct of module_signature (** interactive body *) | FullStruct (** special case of [Struct] : the body is exactly [mod_type] *) -and module_body = +and 'a generic_module_body = { mod_mp : module_path; (** absolute path of the module *) - mod_expr : module_implementation; (** implementation *) + mod_expr : 'a; (** implementation *) mod_type : module_signature; (** expanded type *) mod_type_alg : module_expression option; (** algebraic type *) mod_constraints : Univ.ContextSet.t; (** set of all universes constraints in the module *) mod_delta : Mod_subst.delta_resolver; (** quotiented set of equivalent constants and inductive names *) - mod_retroknowledge : Retroknowledge.action list } + mod_retroknowledge : 'a module_retroknowledge } (** For a module, there are five possible situations: - [Declare Module M : T] then [mod_expr = Abstract; mod_type_alg = Some T] @@ -269,13 +269,19 @@ and module_body = - [Module M : T. ... End M] then [mod_expr = Struct; mod_type_alg = Some T] And of course, all these situations may be functors or not. *) -(** A [module_type_body] is just a [module_body] with no - implementation ([mod_expr] always [Abstract]) and also - an empty [mod_retroknowledge]. Its [mod_type_alg] contains +and module_body = module_implementation generic_module_body + +(** A [module_type_body] is just a [module_body] with no implementation and + also an empty [mod_retroknowledge]. Its [mod_type_alg] contains the algebraic definition of this module type, or [None] if it has been built interactively. *) -and module_type_body = module_body +and module_type_body = unit generic_module_body + +and _ module_retroknowledge = +| ModBodyRK : + Retroknowledge.action list -> module_implementation module_retroknowledge +| ModTypeRK : unit module_retroknowledge (** Extra invariants : diff --git a/kernel/declareops.ml b/kernel/declareops.ml index 85dd1e66d..66d66c7d0 100644 --- a/kernel/declareops.ml +++ b/kernel/declareops.ml @@ -318,7 +318,7 @@ let rec hcons_structure_field_body sb = match sb with let mb' = hcons_module_body mb in if mb == mb' then sb else SFBmodule mb' | SFBmodtype mb -> - let mb' = hcons_module_body mb in + let mb' = hcons_module_type mb in if mb == mb' then sb else SFBmodtype mb' and hcons_structure_body sb = @@ -331,10 +331,10 @@ and hcons_structure_body sb = List.smartmap map sb and hcons_module_signature ms = - hcons_functorize hcons_module_body hcons_structure_body hcons_module_signature ms + hcons_functorize hcons_module_type hcons_structure_body hcons_module_signature ms and hcons_module_expression me = - hcons_functorize hcons_module_body hcons_module_alg_expr hcons_module_expression me + hcons_functorize hcons_module_type hcons_module_alg_expr hcons_module_expression me and hcons_module_implementation mip = match mip with | Abstract -> Abstract @@ -346,9 +346,11 @@ and hcons_module_implementation mip = match mip with if ms == ms' then mip else Struct ms | FullStruct -> FullStruct -and hcons_module_body mb = +and hcons_generic_module_body : + 'a. ('a -> 'a) -> 'a generic_module_body -> 'a generic_module_body = + fun hcons_impl mb -> let mp' = mb.mod_mp in - let expr' = hcons_module_implementation mb.mod_expr in + let expr' = hcons_impl mb.mod_expr in let type' = hcons_module_signature mb.mod_type in let type_alg' = mb.mod_type_alg in let constraints' = Univ.hcons_universe_context_set mb.mod_constraints in @@ -373,3 +375,9 @@ and hcons_module_body mb = mod_delta = delta'; mod_retroknowledge = retroknowledge'; } + +and hcons_module_body mb = + hcons_generic_module_body hcons_module_implementation mb + +and hcons_module_type mb = + hcons_generic_module_body (fun () -> ()) mb diff --git a/kernel/declareops.mli b/kernel/declareops.mli index a8ba5fa39..b2d29759d 100644 --- a/kernel/declareops.mli +++ b/kernel/declareops.mli @@ -78,3 +78,4 @@ val safe_flags : typing_flags val hcons_const_body : constant_body -> constant_body val hcons_mind : mutual_inductive_body -> mutual_inductive_body val hcons_module_body : module_body -> module_body +val hcons_module_type : module_type_body -> module_type_body diff --git a/kernel/environ.ml b/kernel/environ.ml index d2c737ab0..621a9931d 100644 --- a/kernel/environ.ml +++ b/kernel/environ.ml @@ -624,39 +624,39 @@ fun rk value field -> native_constant_dynamic = Some Nativelambda.compile_dynamic_int31; } | KInt31 (_, Int31Plus) -> int31_binop_from_const Cbytecodes.Kaddint31 - Primitives.Int31add + CPrimitives.Int31add | KInt31 (_, Int31PlusC) -> int31_binop_from_const Cbytecodes.Kaddcint31 - Primitives.Int31addc + CPrimitives.Int31addc | KInt31 (_, Int31PlusCarryC) -> int31_binop_from_const Cbytecodes.Kaddcarrycint31 - Primitives.Int31addcarryc + CPrimitives.Int31addcarryc | KInt31 (_, Int31Minus) -> int31_binop_from_const Cbytecodes.Ksubint31 - Primitives.Int31sub + CPrimitives.Int31sub | KInt31 (_, Int31MinusC) -> int31_binop_from_const Cbytecodes.Ksubcint31 - Primitives.Int31subc + CPrimitives.Int31subc | KInt31 (_, Int31MinusCarryC) -> int31_binop_from_const - Cbytecodes.Ksubcarrycint31 Primitives.Int31subcarryc + Cbytecodes.Ksubcarrycint31 CPrimitives.Int31subcarryc | KInt31 (_, Int31Times) -> int31_binop_from_const Cbytecodes.Kmulint31 - Primitives.Int31mul + CPrimitives.Int31mul | KInt31 (_, Int31TimesC) -> int31_binop_from_const Cbytecodes.Kmulcint31 - Primitives.Int31mulc + CPrimitives.Int31mulc | KInt31 (_, Int31Div21) -> int31_op_from_const 3 Cbytecodes.Kdiv21int31 - Primitives.Int31div21 + CPrimitives.Int31div21 | KInt31 (_, Int31Diveucl) -> int31_binop_from_const Cbytecodes.Kdivint31 - Primitives.Int31diveucl + CPrimitives.Int31diveucl | KInt31 (_, Int31AddMulDiv) -> int31_op_from_const 3 Cbytecodes.Kaddmuldivint31 - Primitives.Int31addmuldiv + CPrimitives.Int31addmuldiv | KInt31 (_, Int31Compare) -> int31_binop_from_const Cbytecodes.Kcompareint31 - Primitives.Int31compare + CPrimitives.Int31compare | KInt31 (_, Int31Head0) -> int31_unop_from_const Cbytecodes.Khead0int31 - Primitives.Int31head0 + CPrimitives.Int31head0 | KInt31 (_, Int31Tail0) -> int31_unop_from_const Cbytecodes.Ktail0int31 - Primitives.Int31tail0 + CPrimitives.Int31tail0 | KInt31 (_, Int31Lor) -> int31_binop_from_const Cbytecodes.Klorint31 - Primitives.Int31lor + CPrimitives.Int31lor | KInt31 (_, Int31Land) -> int31_binop_from_const Cbytecodes.Klandint31 - Primitives.Int31land + CPrimitives.Int31land | KInt31 (_, Int31Lxor) -> int31_binop_from_const Cbytecodes.Klxorint31 - Primitives.Int31lxor + CPrimitives.Int31lxor | _ -> empty_reactive_info let _ = Hook.set Retroknowledge.dispatch_hook dispatch diff --git a/kernel/kernel.mllib b/kernel/kernel.mllib index 994634854..917e4f6f1 100644 --- a/kernel/kernel.mllib +++ b/kernel/kernel.mllib @@ -17,7 +17,7 @@ Opaqueproof Declarations Entries Nativevalues -Primitives +CPrimitives Declareops Retroknowledge Conv_oracle diff --git a/kernel/mod_typing.ml b/kernel/mod_typing.ml index 0888ccc10..d2b41aae9 100644 --- a/kernel/mod_typing.ml +++ b/kernel/mod_typing.ml @@ -264,7 +264,9 @@ let rec translate_mse env mpo inl = function |MEident mp1 as me -> let mb = match mpo with |Some mp -> strengthen_and_subst_mb (lookup_module mp1 env) mp false - |None -> lookup_modtype mp1 env + |None -> + let mt = lookup_modtype mp1 env in + module_body_of_type mt.mod_mp mt in mb.mod_type, me, mb.mod_delta, Univ.ContextSet.empty |MEapply (fe,mp1) -> @@ -281,9 +283,11 @@ let mk_mod mp e ty cst reso = mod_type_alg = None; mod_constraints = cst; mod_delta = reso; - mod_retroknowledge = [] } + mod_retroknowledge = ModBodyRK []; } -let mk_modtype mp ty cst reso = mk_mod mp Abstract ty cst reso +let mk_modtype mp ty cst reso = + let mb = mk_mod mp Abstract ty cst reso in + { mb with mod_expr = (); mod_retroknowledge = ModTypeRK } let rec translate_mse_funct env mpo inl mse = function |[] -> @@ -319,6 +323,7 @@ let finalize_module env mp (sign,alg,reso,cst) restype = match restype with { res_mtb with mod_mp = mp; mod_expr = impl; + mod_retroknowledge = ModBodyRK []; (** cst from module body typing, cst' from subtyping, constraints from module type. *) diff --git a/kernel/modops.ml b/kernel/modops.ml index a079bc893..76915e917 100644 --- a/kernel/modops.ml +++ b/kernel/modops.ml @@ -143,11 +143,12 @@ let rec functor_iter fty f0 = function (** {6 Misc operations } *) let module_type_of_module mb = - { mb with mod_expr = Abstract; mod_type_alg = None } + { mb with mod_expr = (); mod_type_alg = None; + mod_retroknowledge = ModTypeRK; } let module_body_of_type mp mtb = - assert (mtb.mod_expr == Abstract); - { mtb with mod_mp = mp } + { mtb with mod_expr = Abstract; mod_mp = mp; + mod_retroknowledge = ModBodyRK []; } let check_modpath_equiv env mp1 mp2 = if ModPath.equal mp1 mp2 then () @@ -196,7 +197,8 @@ let rec subst_structure sub do_delta sign = in List.smartmap subst_body sign -and subst_body is_mod sub do_delta mb = +and subst_body : 'a. _ -> _ -> (_ -> 'a -> 'a) -> _ -> 'a generic_module_body -> 'a generic_module_body = + fun is_mod sub subst_impl do_delta mb -> let { mod_mp=mp; mod_expr=me; mod_type=ty; mod_type_alg=aty } = mb in let mp' = subst_mp sub mp in let sub = @@ -205,10 +207,7 @@ and subst_body is_mod sub do_delta mb = else add_mp mp mp' empty_delta_resolver sub in let ty' = subst_signature sub do_delta ty in - let me' = - implem_smartmap - (subst_signature sub id_delta) (subst_expression sub id_delta) me - in + let me' = subst_impl sub me in let aty' = Option.smartmap (subst_expression sub id_delta) aty in let delta' = do_delta mb.mod_delta sub in if mp==mp' && me==me' && ty==ty' && aty==aty' && delta'==mb.mod_delta @@ -221,9 +220,14 @@ and subst_body is_mod sub do_delta mb = mod_type_alg = aty'; mod_delta = delta' } -and subst_module sub do_delta mb = subst_body true sub do_delta mb +and subst_module sub do_delta mb = + subst_body true sub subst_impl do_delta mb + +and subst_impl sub me = + implem_smartmap + (subst_signature sub id_delta) (subst_expression sub id_delta) me -and subst_modtype sub do_delta mtb = subst_body false sub do_delta mtb +and subst_modtype sub do_delta mtb = subst_body false sub (fun _ () -> ()) do_delta mtb and subst_expr sub do_delta seb = match seb with |MEident mp -> @@ -268,7 +272,7 @@ let add_retroknowledge mp = CErrors.anomaly ~label:"Modops.add_retroknowledge" (Pp.str "had to import an unsupported kind of term.") in - fun lclrk env -> + fun (ModBodyRK lclrk) env -> (* The order of the declaration matters, for instance (and it's at the time this comment is being written, the only relevent instance) the int31 type registration absolutely needs int31 bits to be registered. @@ -567,7 +571,7 @@ let rec is_bounded_expr l = function is_bounded_expr l (MEident mp) || is_bounded_expr l fexpr | _ -> false -let rec clean_module l mb = +let rec clean_module_body l mb = let impl, typ = mb.mod_expr, mb.mod_type in let typ' = clean_signature l typ in let impl' = match impl with @@ -577,19 +581,25 @@ let rec clean_module l mb = if typ==typ' && impl==impl' then mb else { mb with mod_type=typ'; mod_expr=impl' } +and clean_module_type l mb = + let (), typ = mb.mod_expr, mb.mod_type in + let typ' = clean_signature l typ in + if typ==typ' then mb + else { mb with mod_type=typ' } + and clean_field l field = match field with |(lab,SFBmodule mb) -> - let mb' = clean_module l mb in + let mb' = clean_module_body l mb in if mb==mb' then field else (lab,SFBmodule mb') |_ -> field and clean_structure l = List.smartmap (clean_field l) and clean_signature l = - functor_smartmap (clean_module l) (clean_structure l) + functor_smartmap (clean_module_type l) (clean_structure l) and clean_expression l = - functor_smartmap (clean_module l) (fun me -> me) + functor_smartmap (clean_module_type l) (fun me -> me) let rec collect_mbid l sign = match sign with |MoreFunctor (mbid,ty,m) -> @@ -613,14 +623,16 @@ let join_constant_body except otab cb = | _ -> () let join_structure except otab s = - let rec join_module mb = - implem_iter join_signature join_expression mb.mod_expr; + let rec join_module : 'a. 'a generic_module_body -> unit = fun mb -> Option.iter join_expression mb.mod_type_alg; join_signature mb.mod_type and join_field (l,body) = match body with |SFBconst sb -> join_constant_body except otab sb |SFBmind _ -> () - |SFBmodule m |SFBmodtype m -> join_module m + |SFBmodule m -> + implem_iter join_signature join_expression m.mod_expr; + join_module m + |SFBmodtype m -> join_module m and join_structure struc = List.iter join_field struc and join_signature sign = functor_iter join_module join_structure sign diff --git a/kernel/nativecode.ml b/kernel/nativecode.ml index da7fcd6f2..e08d913bc 100644 --- a/kernel/nativecode.ml +++ b/kernel/nativecode.ml @@ -296,7 +296,7 @@ type primitive = | MLmagic | MLarrayget | Mk_empty_instance - | Coq_primitive of Primitives.t * (prefix * constant) option + | Coq_primitive of CPrimitives.t * (prefix * constant) option let eq_primitive p1 p2 = match p1, p2 with @@ -361,9 +361,9 @@ let primitive_hash = function | MLsub -> 33 | MLmul -> 34 | MLmagic -> 35 - | Coq_primitive (prim, None) -> combinesmall 36 (Primitives.hash prim) + | Coq_primitive (prim, None) -> combinesmall 36 (CPrimitives.hash prim) | Coq_primitive (prim, Some (prefix,kn)) -> - combinesmall 37 (combine3 (String.hash prefix) (Constant.hash kn) (Primitives.hash prim)) + combinesmall 37 (combine3 (String.hash prefix) (Constant.hash kn) (CPrimitives.hash prim)) | Mk_proj -> 38 | MLarrayget -> 39 | Mk_empty_instance -> 40 @@ -921,7 +921,7 @@ let merge_branches t = type prim_aux = - | PAprim of string * constant * Primitives.t * prim_aux array + | PAprim of string * constant * CPrimitives.t * prim_aux array | PAml of mllambda let add_check cond args = @@ -988,11 +988,11 @@ let compile_prim decl cond paux = | Int31lt -> if Sys.word_size = 64 then app_prim Mk_bool [|(app_prim MLlt (args_to_int args))|] - else app_prim (Coq_primitive (Primitives.Int31lt,None)) args + else app_prim (Coq_primitive (CPrimitives.Int31lt,None)) args | Int31le -> if Sys.word_size = 64 then app_prim Mk_bool [|(app_prim MLle (args_to_int args))|] - else app_prim (Coq_primitive (Primitives.Int31le, None)) args + else app_prim (Coq_primitive (CPrimitives.Int31le, None)) args | Int31lsl -> of_int (mk_lsl (args_to_int args)) | Int31lsr -> of_int (mk_lsr (args_to_int args)) | Int31land -> of_int (mk_land (args_to_int args)) @@ -1752,9 +1752,9 @@ let pp_mllam fmt l = | MLarrayget -> Format.fprintf fmt "Array.get" | Mk_empty_instance -> Format.fprintf fmt "Univ.Instance.empty" | Coq_primitive (op,None) -> - Format.fprintf fmt "no_check_%s" (Primitives.to_string op) + Format.fprintf fmt "no_check_%s" (CPrimitives.to_string op) | Coq_primitive (op, Some (prefix,kn)) -> - Format.fprintf fmt "%s %a" (Primitives.to_string op) + Format.fprintf fmt "%s %a" (CPrimitives.to_string op) pp_mllam (MLglobal (Gconstant (prefix, kn))) in Format.fprintf fmt "@[%a@]" pp_mllam l diff --git a/kernel/nativeconv.ml b/kernel/nativeconv.ml index d2f050d3b..a62a079da 100644 --- a/kernel/nativeconv.ml +++ b/kernel/nativeconv.ml @@ -132,7 +132,7 @@ let native_conv_gen pb sigma env univs t1 t2 = let penv = Environ.pre_env env in let ml_filename, prefix = get_ml_filename () in let code, upds = mk_conv_code penv sigma prefix t1 t2 in - match compile ml_filename code with + match compile ml_filename code ~profile:false with | (true, fn) -> begin if !Flags.debug then Feedback.msg_debug (Pp.str "Running test..."); diff --git a/kernel/nativeinstr.mli b/kernel/nativeinstr.mli index cb79877e8..2353470f0 100644 --- a/kernel/nativeinstr.mli +++ b/kernel/nativeinstr.mli @@ -30,7 +30,7 @@ and lambda = | Lapp of lambda * lambda array | Lconst of prefix * pconstant | Lproj of prefix * constant (* prefix, projection name *) - | Lprim of prefix * constant * Primitives.t * lambda array + | Lprim of prefix * constant * CPrimitives.t * lambda array | Lcase of annot_sw * lambda * lambda * lam_branches (* annotations, term being matched, accu, branches *) | Lif of lambda * lambda * lambda diff --git a/kernel/nativelambda.mli b/kernel/nativelambda.mli index bfa3bf941..156e4f834 100644 --- a/kernel/nativelambda.mli +++ b/kernel/nativelambda.mli @@ -38,5 +38,5 @@ val compile_dynamic_int31 : bool -> prefix -> constructor -> lambda array -> val before_match_int31 : inductive -> bool -> prefix -> constructor -> lambda -> lambda -val compile_prim : Primitives.t -> constant -> bool -> prefix -> lambda array -> +val compile_prim : CPrimitives.t -> constant -> bool -> prefix -> lambda array -> lambda diff --git a/kernel/nativelib.ml b/kernel/nativelib.ml index 02e02b031..665ddf7a6 100644 --- a/kernel/nativelib.ml +++ b/kernel/nativelib.ml @@ -64,7 +64,7 @@ let warn_native_compiler_failed = in CWarnings.create ~name:"native-compiler-failed" ~category:"native-compiler" print -let call_compiler ml_filename = +let call_compiler ?profile:(profile=false) ml_filename = let load_path = !get_load_paths () in let load_path = List.map (fun dn -> dn / output_dir) load_path in let include_dirs = List.flatten (List.map (fun x -> ["-I"; x]) (include_dirs () @ load_path)) in @@ -74,14 +74,26 @@ let call_compiler ml_filename = let remove f = if Sys.file_exists f then Sys.remove f in remove link_filename; remove (f ^ ".cmi"); + let initial_args = + if Dynlink.is_native then + ["opt"; "-shared"] + else + ["ocamlc"; "-c"] + in + let profile_args = + if profile then + ["-g"] + else + [] + in let args = - (if Dynlink.is_native then "opt" else "ocamlc") - ::(if Dynlink.is_native then "-shared" else "-c") - ::"-o"::link_filename - ::"-rectypes" - ::"-w"::"a" - ::include_dirs - @ ["-impl"; ml_filename] in + initial_args @ + profile_args @ + ("-o"::link_filename + ::"-rectypes" + ::"-w"::"a" + ::include_dirs) @ + ["-impl"; ml_filename] in if !Flags.debug then Feedback.msg_debug (Pp.str (ocamlfind () ^ " " ^ (String.concat " " args))); try let res = CUnix.sys_command (ocamlfind ()) args in @@ -95,9 +107,9 @@ let call_compiler ml_filename = warn_native_compiler_failed (Inr e); false, link_filename -let compile fn code = +let compile fn code ~profile:profile = write_ml_code fn code; - let r = call_compiler fn in + let r = call_compiler ~profile fn in if (not !Flags.debug) && Sys.file_exists fn then Sys.remove fn; r diff --git a/kernel/nativelib.mli b/kernel/nativelib.mli index e8b51dc36..a262a9f58 100644 --- a/kernel/nativelib.mli +++ b/kernel/nativelib.mli @@ -19,7 +19,7 @@ val load_obj : (string -> unit) ref val get_ml_filename : unit -> string * string -val compile : string -> global list -> bool * string +val compile : string -> global list -> profile:bool -> bool * string val compile_library : Names.dir_path -> global list -> string -> bool diff --git a/kernel/pre_env.ml b/kernel/pre_env.ml index 7b4fb4e86..94738d618 100644 --- a/kernel/pre_env.ml +++ b/kernel/pre_env.ml @@ -156,7 +156,7 @@ let map_named_val f ctxt = in (accu, d') in - let map, ctx = List.fold_map fold ctxt.env_named_map ctxt.env_named_ctx in + let map, ctx = List.fold_left_map fold ctxt.env_named_map ctxt.env_named_ctx in if map == ctxt.env_named_map then ctxt else { env_named_ctx = ctx; env_named_map = map } diff --git a/kernel/safe_typing.ml b/kernel/safe_typing.ml index 04051f2e2..ad622b07d 100644 --- a/kernel/safe_typing.ml +++ b/kernel/safe_typing.ml @@ -574,7 +574,7 @@ let add_mind dir l mie senv = let add_modtype l params_mte inl senv = let mp = MPdot(senv.modpath, l) in let mtb = Mod_typing.translate_modtype senv.env mp inl params_mte in - let mtb = Declareops.hcons_module_body mtb in + let mtb = Declareops.hcons_module_type mtb in let senv' = add_field (l,SFBmodtype mtb) MT senv in mp, senv' @@ -677,7 +677,7 @@ let build_module_body params restype senv = (struc,None,senv.modresolver,senv.univ) restype' in let mb' = functorize_module params mb in - { mb' with mod_retroknowledge = senv.local_retroknowledge } + { mb' with mod_retroknowledge = ModBodyRK senv.local_retroknowledge } (** Returning back to the old pre-interactive-module environment, with one extra component and some updated fields @@ -732,12 +732,12 @@ let end_module l restype senv = let build_mtb mp sign cst delta = { mod_mp = mp; - mod_expr = Abstract; + mod_expr = (); mod_type = sign; mod_type_alg = None; mod_constraints = cst; mod_delta = delta; - mod_retroknowledge = [] } + mod_retroknowledge = ModTypeRK } let end_modtype l senv = let mp = senv.modpath in @@ -853,7 +853,7 @@ let export ?except senv dir = mod_type_alg = None; mod_constraints = senv.univ; mod_delta = senv.modresolver; - mod_retroknowledge = senv.local_retroknowledge + mod_retroknowledge = ModBodyRK senv.local_retroknowledge } in let ast, symbols = diff --git a/kernel/subtyping.ml b/kernel/subtyping.ml index b311165f1..b564b2a8c 100644 --- a/kernel/subtyping.ml +++ b/kernel/subtyping.ml @@ -416,7 +416,7 @@ and check_modtypes cst env mtb1 mtb2 subst1 subst2 equiv = mod_type = subst_signature subst1 body_t1; mod_type_alg = None; mod_constraints = mtb1.mod_constraints; - mod_retroknowledge = []; + mod_retroknowledge = ModBodyRK []; mod_delta = mtb1.mod_delta} env in check_structure cst env body_t1 body_t2 equiv subst1 subst2 diff --git a/lib/cArray.ml b/lib/cArray.ml index bb1e33546..d08f24d49 100644 --- a/lib/cArray.ml +++ b/lib/cArray.ml @@ -53,8 +53,12 @@ sig ('a -> 'b -> 'c -> 'd) -> 'a array -> 'b array -> 'c array -> 'd array val map_left : ('a -> 'b) -> 'a array -> 'b array val iter2 : ('a -> 'b -> unit) -> 'a array -> 'b array -> unit - val fold_map' : ('a -> 'c -> 'b * 'c) -> 'a array -> 'c -> 'b array * 'c + val fold_left_map : ('a -> 'b -> 'a * 'c) -> 'a -> 'b array -> 'a * 'c array + val fold_right_map : ('a -> 'c -> 'b * 'c) -> 'a array -> 'c -> 'b array * 'c + val fold_left2_map : ('a -> 'b -> 'c -> 'a * 'd) -> 'a -> 'b array -> 'c array -> 'a * 'd array + val fold_right2_map : ('a -> 'b -> 'c -> 'd * 'c) -> 'a array -> 'b array -> 'c -> 'd array * 'c val fold_map : ('a -> 'b -> 'a * 'c) -> 'a -> 'b array -> 'a * 'c array + val fold_map' : ('a -> 'c -> 'b * 'c) -> 'a array -> 'c -> 'b array * 'c val fold_map2' : ('a -> 'b -> 'c -> 'd * 'c) -> 'a array -> 'b array -> 'c -> 'd array * 'c val distinct : 'a array -> bool @@ -283,8 +287,7 @@ let rev_of_list = function let () = set (len - 1) l in ans -let map_to_list f v = - List.map f (Array.to_list v) +let map_to_list = CList.map_of_array let map_of_list f l = let len = List.length l in @@ -434,7 +437,7 @@ let iter2 f v1 v2 = let pure_functional = false -let fold_map' f v e = +let fold_right_map f v e = if pure_functional then let (l,e) = Array.fold_right @@ -446,18 +449,28 @@ else let v' = Array.map (fun x -> let (y,e) = f x !e' in e' := e; y) v in (v',!e') -let fold_map f e v = +let fold_map' = fold_right_map + +let fold_left_map f e v = let e' = ref e in let v' = Array.map (fun x -> let (e,y) = f !e' x in e' := e; y) v in (!e',v') -let fold_map2' f v1 v2 e = +let fold_map = fold_left_map + +let fold_right2_map f v1 v2 e = let e' = ref e in let v' = map2 (fun x1 x2 -> let (y,e) = f x1 x2 !e' in e' := e; y) v1 v2 in (v',!e') +let fold_map2' = fold_right2_map + +let fold_left2_map f e v1 v2 = + let e' = ref e in + let v' = map2 (fun x1 x2 -> let (e,y) = f !e' x1 x2 in e' := e; y) v1 v2 in + (!e',v') let distinct v = let visited = Hashtbl.create 23 in diff --git a/lib/cArray.mli b/lib/cArray.mli index 7e5c93b5d..325ff8edc 100644 --- a/lib/cArray.mli +++ b/lib/cArray.mli @@ -96,10 +96,28 @@ sig val iter2 : ('a -> 'b -> unit) -> 'a array -> 'b array -> unit (** Iter on two arrays. Raise [Invalid_argument "Array.iter2"] if sizes differ. *) - val fold_map' : ('a -> 'c -> 'b * 'c) -> 'a array -> 'c -> 'b array * 'c + val fold_left_map : ('a -> 'b -> 'a * 'c) -> 'a -> 'b array -> 'a * 'c array + (** [fold_left_map f e_0 [|l_1...l_n|] = e_n,[|k_1...k_n|]] + where [(e_i,k_i)=f e_{i-1} l_i] *) + + val fold_right_map : ('a -> 'c -> 'b * 'c) -> 'a array -> 'c -> 'b array * 'c + (** Same, folding on the right *) + + val fold_left2_map : ('a -> 'b -> 'c -> 'a * 'd) -> 'a -> 'b array -> 'c array -> 'a * 'd array + (** Same with two arrays, folding on the left *) + + val fold_right2_map : ('a -> 'b -> 'c -> 'd * 'c) -> 'a array -> 'b array -> 'c -> 'd array * 'c + (** Same with two arrays, folding on the left *) + val fold_map : ('a -> 'b -> 'a * 'c) -> 'a -> 'b array -> 'a * 'c array + (** @deprecated Same as [fold_left_map] *) + + val fold_map' : ('a -> 'c -> 'b * 'c) -> 'a array -> 'c -> 'b array * 'c + (** @deprecated Same as [fold_right_map] *) + val fold_map2' : ('a -> 'b -> 'c -> 'd * 'c) -> 'a array -> 'b array -> 'c -> 'd array * 'c + (** @deprecated Same as [fold_right2_map] *) val distinct : 'a array -> bool (** Return [true] if every element of the array is unique (for default diff --git a/lib/cList.ml b/lib/cList.ml index c8283e3c7..ca69628af 100644 --- a/lib/cList.ml +++ b/lib/cList.ml @@ -49,6 +49,7 @@ sig (int -> 'a -> bool) -> 'a list -> 'a list val partitioni : (int -> 'a -> bool) -> 'a list -> 'a list * 'a list + val map_of_array : ('a -> 'b) -> 'a array -> 'b list val smartfilter : ('a -> bool) -> 'a list -> 'a list val extend : bool list -> 'a -> 'a list -> 'a list val count : ('a -> bool) -> 'a list -> int @@ -91,6 +92,10 @@ sig val map_append : ('a -> 'b list) -> 'a list -> 'b list val map_append2 : ('a -> 'b -> 'c list) -> 'a list -> 'b list -> 'c list val share_tails : 'a list -> 'a list -> 'a list * 'a list * 'a list + val fold_left_map : ('a -> 'b -> 'a * 'c) -> 'a -> 'b list -> 'a * 'c list + val fold_right_map : ('b -> 'a -> 'c * 'a) -> 'b list -> 'a -> 'c list * 'a + val fold_left2_map : ('a -> 'b -> 'c -> 'a * 'd) -> 'a -> 'b list -> 'c list -> 'a * 'd list + val fold_right2_map : ('b -> 'c -> 'a -> 'd * 'a) -> 'b list -> 'c list -> 'a -> 'd list * 'a val fold_map : ('a -> 'b -> 'a * 'c) -> 'a -> 'b list -> 'a * 'c list val fold_map' : ('b -> 'a -> 'c * 'a) -> 'b list -> 'a -> 'c list * 'a val map_assoc : ('a -> 'b) -> ('c * 'a) list -> ('c * 'b) list @@ -159,6 +164,21 @@ let map2 f l1 l2 = match l1, l2 with cast c | _ -> invalid_arg "List.map2" +let rec map_of_array_loop f p a i l = + if Int.equal i l then () + else + let c = { head = f (Array.unsafe_get a i); tail = [] } in + p.tail <- cast c; + map_of_array_loop f c a (i + 1) l + +let map_of_array f a = + let l = Array.length a in + if Int.equal l 0 then [] + else + let c = { head = f (Array.unsafe_get a 0); tail = [] } in + map_of_array_loop f c a 1 l; + cast c + let rec append_loop p tl = function | [] -> p.tail <- tl | x :: l -> @@ -745,13 +765,15 @@ let share_tails l1 l2 = in shr_rev [] (List.rev l1, List.rev l2) -let rec fold_map f e = function +let rec fold_left_map f e = function | [] -> (e,[]) | h::t -> let e',h' = f e h in - let e'',t' = fold_map f e' t in + let e'',t' = fold_left_map f e' t in e'',h'::t' +let fold_map = fold_left_map + (* (* tail-recursive version of the above function *) let fold_map f e l = let g (e,b') h = @@ -763,9 +785,17 @@ let fold_map f e l = *) (* The same, based on fold_right, with the effect accumulated on the right *) -let fold_map' f l e = +let fold_right_map f l e = List.fold_right (fun x (l,e) -> let (y,e) = f x e in (y::l,e)) l ([],e) +let fold_map' = fold_right_map + +let fold_left2_map f e l l' = + List.fold_left2 (fun (e,l) x x' -> let (e,y) = f e x x' in (e,y::l)) (e,[]) l l' + +let fold_right2_map f l l' e = + List.fold_right2 (fun x x' (l,e) -> let (y,e) = f x x' e in (y::l,e)) l l' ([],e) + let map_assoc f = List.map (fun (x,a) -> (x,f a)) let rec assoc_f f a = function diff --git a/lib/cList.mli b/lib/cList.mli index bc8749b4f..8cb07da79 100644 --- a/lib/cList.mli +++ b/lib/cList.mli @@ -53,7 +53,7 @@ sig [Invalid_argument "List.make"] if [n] is negative. *) val assign : 'a list -> int -> 'a -> 'a list - (** [assign l i x] set the [i]-th element of [l] to [x], starting from [0]. *) + (** [assign l i x] sets the [i]-th element of [l] to [x], starting from [0]. *) val distinct : 'a list -> bool (** Return [true] if all elements of the list are distinct. *) @@ -91,6 +91,9 @@ sig val filteri : (int -> 'a -> bool) -> 'a list -> 'a list val partitioni : (int -> 'a -> bool) -> 'a list -> 'a list * 'a list + val map_of_array : ('a -> 'b) -> 'a array -> 'b list + (** [map_of_array f a] behaves as [List.map f (Array.to_list a)] *) + val smartfilter : ('a -> bool) -> 'a list -> 'a list (** [smartfilter f [a1...an] = List.filter f [a1...an]] but if for all i [f ai = true], then [smartfilter f l == l] *) @@ -195,11 +198,25 @@ sig val share_tails : 'a list -> 'a list -> 'a list * 'a list * 'a list - val fold_map : ('a -> 'b -> 'a * 'c) -> 'a -> 'b list -> 'a * 'c list - (** [fold_map f e_0 [l_1...l_n] = e_n,[k_1...k_n]] + val fold_left_map : ('a -> 'b -> 'a * 'c) -> 'a -> 'b list -> 'a * 'c list + (** [fold_left_map f e_0 [l_1...l_n] = e_n,[k_1...k_n]] where [(e_i,k_i)=f e_{i-1} l_i] *) + val fold_right_map : ('b -> 'a -> 'c * 'a) -> 'b list -> 'a -> 'c list * 'a + (** Same, folding on the right *) + + val fold_left2_map : ('a -> 'b -> 'c -> 'a * 'd) -> 'a -> 'b list -> 'c list -> 'a * 'd list + (** Same with two lists, folding on the left *) + + val fold_right2_map : ('b -> 'c -> 'a -> 'd * 'a) -> 'b list -> 'c list -> 'a -> 'd list * 'a + (** Same with two lists, folding on the right *) + + val fold_map : ('a -> 'b -> 'a * 'c) -> 'a -> 'b list -> 'a * 'c list + (** @deprecated Same as [fold_left_map] *) + val fold_map' : ('b -> 'a -> 'c * 'a) -> 'b list -> 'a -> 'c list * 'a + (** @deprecated Same as [fold_right_map] *) + val map_assoc : ('a -> 'b) -> ('c * 'a) list -> ('c * 'b) list val assoc_f : 'a eq -> 'a -> ('a * 'b) list -> 'b val remove_assoc_f : 'a eq -> 'a -> ('a * 'b) list -> ('a * 'b) list diff --git a/lib/clib.mllib b/lib/clib.mllib index d5c938fe5..5c1f7d9af 100644 --- a/lib/clib.mllib +++ b/lib/clib.mllib @@ -19,6 +19,7 @@ Flags Control Loc CAst +DAst CList CString Deque diff --git a/lib/dAst.ml b/lib/dAst.ml new file mode 100644 index 000000000..0fe323d01 --- /dev/null +++ b/lib/dAst.ml @@ -0,0 +1,41 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2017 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +open CAst + +type ('a, _) thunk = +| Value : 'a -> ('a, 'b) thunk +| Thunk : 'a Lazy.t -> ('a, [ `thunk ]) thunk + +type ('a, 'b) t = ('a, 'b) thunk CAst.t + +let map_thunk (type s) f : (_, s) thunk -> (_, s) thunk = function +| Value x -> Value (f x) +| Thunk k -> Thunk (lazy (f (Lazy.force k))) + +let get_thunk (type s) : ('a, s) thunk -> 'a = function +| Value x -> x +| Thunk k -> Lazy.force k + +let get x = get_thunk x.v + +let make ?loc v = CAst.make ?loc (Value v) + +let delay ?loc v = CAst.make ?loc (Thunk (Lazy.from_fun v)) + +let map f n = CAst.map (fun x -> map_thunk f x) n + +let map_with_loc f n = + CAst.map_with_loc (fun ?loc x -> map_thunk (fun x -> f ?loc x) x) n + +let map_from_loc f (loc, x) = + make ?loc (f ?loc x) + +let with_val f n = f (get n) + +let with_loc_val f n = f ?loc:n.CAst.loc (get n) diff --git a/lib/dAst.mli b/lib/dAst.mli new file mode 100644 index 000000000..5b51677fc --- /dev/null +++ b/lib/dAst.mli @@ -0,0 +1,28 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2017 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(** Lazy AST node wrapper. Only used for [glob_constr] as of today. *) + +type ('a, _) thunk = +| Value : 'a -> ('a, 'b) thunk +| Thunk : 'a Lazy.t -> ('a, [ `thunk ]) thunk + +type ('a, 'b) t = ('a, 'b) thunk CAst.t + +val get : ('a, 'b) t -> 'a +val get_thunk : ('a, 'b) thunk -> 'a + +val make : ?loc:Loc.t -> 'a -> ('a, 'b) t +val delay : ?loc:Loc.t -> (unit -> 'a) -> ('a, [ `thunk ]) t + +val map : ('a -> 'b) -> ('a, 'c) t -> ('b, 'c) t +val map_with_loc : (?loc:Loc.t -> 'a -> 'b) -> ('a, 'c) t -> ('b, 'c) t +val map_from_loc : (?loc:Loc.t -> 'a -> 'b) -> 'a Loc.located -> ('b, 'c) t + +val with_val : ('a -> 'b) -> ('a, 'c) t -> 'b +val with_loc_val : (?loc:Loc.t -> 'a -> 'b) -> ('a, 'c) t -> 'b diff --git a/lib/flags.ml b/lib/flags.ml index 0bce22f58..d4be81c61 100644 --- a/lib/flags.ml +++ b/lib/flags.ml @@ -87,8 +87,6 @@ let in_toplevel = ref false let profile = false -let xml_export = ref false - let ide_slave = ref false let ideslave_coqtop_flags = ref None @@ -96,7 +94,6 @@ let time = ref false let raw_print = ref false - let univ_print = ref false let we_are_parsing = ref false @@ -167,9 +164,9 @@ let use_polymorphic_flag () = let make_polymorphic_flag b = local_polymorphic_flag := Some b -let inductive_cumulativity = ref false -let make_inductive_cumulativity b = inductive_cumulativity := b -let is_inductive_cumulativity () = !inductive_cumulativity +let polymorphic_inductive_cumulativity = ref false +let make_polymorphic_inductive_cumulativity b = polymorphic_inductive_cumulativity := b +let is_polymorphic_inductive_cumulativity () = !polymorphic_inductive_cumulativity (** [program_mode] tells that Program mode has been activated, either globally via [Set Program] or locally via the Program command prefix. *) diff --git a/lib/flags.mli b/lib/flags.mli index eb4c37a54..3024c6039 100644 --- a/lib/flags.mli +++ b/lib/flags.mli @@ -56,11 +56,6 @@ val stm_debug : bool ref val profile : bool -(* Legacy flags *) - -(* -xml option: xml hooks will be called *) -val xml_export : bool ref - (* -ide_slave: printing will be more verbose, will affect stm caching *) val ide_slave : bool ref val ideslave_coqtop_flags : string option ref @@ -119,9 +114,9 @@ val is_universe_polymorphism : unit -> bool val make_polymorphic_flag : bool -> unit val use_polymorphic_flag : unit -> bool -(** Global inductive cumulativity flag. *) -val make_inductive_cumulativity : bool -> unit -val is_inductive_cumulativity : unit -> bool +(** Global polymorphic inductive cumulativity flag. *) +val make_polymorphic_inductive_cumulativity : bool -> unit +val is_polymorphic_inductive_cumulativity : unit -> bool val warn : bool ref val make_warn : bool -> unit diff --git a/lib/minisys.ml b/lib/minisys.ml index 1ed017e48..706f0430c 100644 --- a/lib/minisys.ml +++ b/lib/minisys.ml @@ -44,11 +44,13 @@ let ok_dirname f = (* Check directory can be opened *) let exists_dir dir = + (* See BZ#5391 on windows failing on a trailing (back)slash *) let rec strip_trailing_slash dir = let len = String.length dir in if len > 0 && (dir.[len-1] = '/' || dir.[len-1] = '\\') then strip_trailing_slash (String.sub dir 0 (len-1)) else dir in - try Sys.is_directory (strip_trailing_slash dir) with Sys_error _ -> false + let dir = if Sys.os_type = "Win32" then strip_trailing_slash dir else dir in + try Sys.is_directory dir with Sys_error _ -> false let apply_subdir f path name = (* we avoid all files and subdirs starting by '.' (e.g. .svn) *) diff --git a/lib/option.ml b/lib/option.ml index 7cedffef0..98b168035 100644 --- a/lib/option.ml +++ b/lib/option.ml @@ -121,12 +121,19 @@ let fold_right f x a = | Some y -> f y a | _ -> a -(** [fold_map f a x] is [a, f y] if [x] is [Some y], and [a] otherwise. *) -let fold_map f a x = +(** [fold_left_map f a x] is [a, f y] if [x] is [Some y], and [a] otherwise. *) +let fold_left_map f a x = match x with | Some y -> let a, z = f a y in a, Some z | _ -> a, None +let fold_right_map f x a = + match x with + | Some y -> let z, a = f y a in Some z, a + | _ -> None, a + +let fold_map = fold_left_map + (** [cata f a x] is [a] if [x] is [None] and [f y] if [x] is [Some y]. *) let cata f a = function | Some c -> f c diff --git a/lib/option.mli b/lib/option.mli index c4d1ebc3a..66f05023f 100644 --- a/lib/option.mli +++ b/lib/option.mli @@ -85,7 +85,13 @@ val fold_left2 : ('a -> 'b -> 'c -> 'a) -> 'a -> 'b option -> 'c option -> 'a (** [fold_right f x a] is [f y a] if [x] is [Some y], and [a] otherwise. *) val fold_right : ('a -> 'b -> 'b) -> 'a option -> 'b -> 'b -(** [fold_map f a x] is [a, f y] if [x] is [Some y], and [a] otherwise. *) +(** [fold_left_map f a x] is [a, f y] if [x] is [Some y], and [a] otherwise. *) +val fold_left_map : ('a -> 'b -> 'a * 'c) -> 'a -> 'b option -> 'a * 'c option + +(** Same as [fold_left_map] on the right *) +val fold_right_map : ('b -> 'a -> 'c * 'a) -> 'b option -> 'a -> 'c option * 'a + +(** @deprecated Same as [fold_left_map] *) val fold_map : ('a -> 'b -> 'a * 'c) -> 'a -> 'b option -> 'a * 'c option (** [cata f e x] is [e] if [x] is [None] and [f a] if [x] is [Some a] *) diff --git a/library/declaremods.ml b/library/declaremods.ml index e7aa5bd0d..6d9295bde 100644 --- a/library/declaremods.ml +++ b/library/declaremods.ml @@ -557,17 +557,6 @@ let openmodtype_info = Summary.ref ([] : module_type_body list) ~name:"MODTYPE-INFO" -(** XML output hooks *) - -let (f_xml_declare_module, xml_declare_module) = Hook.make ~default:ignore () -let (f_xml_start_module, xml_start_module) = Hook.make ~default:ignore () -let (f_xml_end_module, xml_end_module) = Hook.make ~default:ignore () -let (f_xml_declare_module_type, xml_declare_module_type) = Hook.make ~default:ignore () -let (f_xml_start_module_type, xml_start_module_type) = Hook.make ~default:ignore () -let (f_xml_end_module_type, xml_end_module_type) = Hook.make ~default:ignore () - -let if_xml f x = if !Flags.xml_export then f x else () - (** {6 Modules : start, end, declare} *) module RawModOps = struct @@ -589,7 +578,6 @@ let start_module interp_modast export id args res fs = openmod_info := { cur_typ = res_entry_o; cur_typs = subtyps }; let prefix = Lib.start_module export id mp fs in Nametab.push_dir (Nametab.Until 1) (fst prefix) (DirOpenModule prefix); - if_xml (Hook.get f_xml_start_module) mp; mp let end_module () = @@ -628,7 +616,6 @@ let end_module () = assert (eq_full_path (fst newoname) (fst oldoname)); assert (ModPath.equal (mp_of_kn (snd newoname)) mp); - if_xml (Hook.get f_xml_end_module) mp; mp let declare_module interp_modast id args res mexpr_o fs = @@ -682,7 +669,6 @@ let declare_module interp_modast id args res mexpr_o fs = let sobjs = subst_sobjs (map_mp mp0 mp resolver) sobjs in ignore (Lib.add_leaf id (in_module sobjs)); - if_xml (Hook.get f_xml_declare_module) mp; mp end @@ -699,7 +685,6 @@ let start_modtype interp_modast id args mtys fs = openmodtype_info := sub_mty_l; let prefix = Lib.start_modtype id mp fs in Nametab.push_dir (Nametab.Until 1) (fst prefix) (DirOpenModtype prefix); - if_xml (Hook.get f_xml_start_module_type) mp; mp let end_modtype () = @@ -716,7 +701,6 @@ let end_modtype () = assert (eq_full_path (fst oname) (fst oldoname)); assert (ModPath.equal (mp_of_kn (snd oname)) mp); - if_xml (Hook.get f_xml_end_module_type) mp; mp let declare_modtype interp_modast id args mtys (mty,ann) fs = @@ -750,7 +734,6 @@ let declare_modtype interp_modast id args mtys (mty,ann) fs = check_subtypes_mt mp sub_mty_l; ignore (Lib.add_leaf id (in_modtype sobjs)); - if_xml (Hook.get f_xml_declare_module_type) mp; mp end diff --git a/library/declaremods.mli b/library/declaremods.mli index 005594b8d..9d750b616 100644 --- a/library/declaremods.mli +++ b/library/declaremods.mli @@ -63,14 +63,6 @@ val start_modtype : val end_modtype : unit -> module_path -(** Hooks for XML output *) -val xml_declare_module : (module_path -> unit) Hook.t -val xml_start_module : (module_path -> unit) Hook.t -val xml_end_module : (module_path -> unit) Hook.t -val xml_declare_module_type : (module_path -> unit) Hook.t -val xml_start_module_type : (module_path -> unit) Hook.t -val xml_end_module_type : (module_path -> unit) Hook.t - (** {6 Libraries i.e. modules on disk } *) type library_name = DirPath.t diff --git a/library/lib.ml b/library/lib.ml index a24d20c68..5418003eb 100644 --- a/library/lib.ml +++ b/library/lib.ml @@ -162,6 +162,13 @@ let find_entry_p p = in find !lib_state.lib_stk +let find_entries_p p = + let rec find = function + | [] -> [] + | ent::l -> if p ent then ent::find l else find l + in + find !lib_state.lib_stk + let split_lib_gen test = let rec collect after equal = function | hd::before when test hd -> collect after (hd::equal) before @@ -328,16 +335,18 @@ let start_compilation s mp = lib_state := { !lib_state with comp_name = Some s; path_prefix = prefix } +let open_blocks_message es = + let open_block_name = function + | oname, OpenedSection _ -> str "section " ++ pr_id (basename (fst oname)) + | oname, OpenedModule (ty,_,_,_) -> str (module_kind ty) ++ spc () ++ pr_id (basename (fst oname)) + | _ -> assert false in + str "The " ++ pr_enum open_block_name es ++ spc () ++ + str "need" ++ str (if List.length es == 1 then "s" else "") ++ str " to be closed." + let end_compilation_checks dir = - let _ = - try match snd (find_entry_p is_opening_node) with - | OpenedSection _ -> user_err Pp.(str "There are some open sections.") - | OpenedModule (ty,_,_,_) -> - user_err ~hdr:"Lib.end_compilation_checks" - (str "There are some open " ++ str (module_kind ty) ++ str "s.") - | _ -> assert false - with Not_found -> () - in + let _ = match find_entries_p is_opening_node with + | [] -> () + | es -> user_err ~hdr:"Lib.end_compilation_checks" (open_blocks_message es) in let is_opening_lib = function _,CompilingLibrary _ -> true | _ -> false in let oname = @@ -512,11 +521,6 @@ let is_in_section ref = (*************) (* Sections. *) - -(* XML output hooks *) -let (f_xml_open_section, xml_open_section) = Hook.make ~default:ignore () -let (f_xml_close_section, xml_close_section) = Hook.make ~default:ignore () - let open_section id = let olddir,(mp,oldsec) = !lib_state.path_prefix in let dir = add_dirpath_suffix olddir id in @@ -528,7 +532,6 @@ let open_section id = (*Pushed for the lifetime of the section: removed by unfrozing the summary*) Nametab.push_dir (Nametab.Until 1) dir (DirOpenSection prefix); lib_state := { !lib_state with path_prefix = prefix }; - if !Flags.xml_export then Hook.get f_xml_open_section id; add_section () @@ -556,7 +559,6 @@ let close_section () = let full_olddir = fst !lib_state.path_prefix in pop_path_prefix (); add_entry oname (ClosedSection (List.rev (mark::secdecls))); - if !Flags.xml_export then Hook.get f_xml_close_section (basename (fst oname)); let newdecls = List.map discharge_item secdecls in Summary.unfreeze_summaries fs; List.iter (Option.iter (fun (id,o) -> add_discharged_leaf id o)) newdecls; diff --git a/library/lib.mli b/library/lib.mli index f1c9bfca2..3dcec1d53 100644 --- a/library/lib.mli +++ b/library/lib.mli @@ -150,10 +150,6 @@ val unfreeze : frozen -> unit val init : unit -> unit -(** XML output hooks *) -val xml_open_section : (Names.Id.t -> unit) Hook.t -val xml_close_section : (Names.Id.t -> unit) Hook.t - (** {6 Section management for discharge } *) type variable_info = Context.Named.Declaration.t * Decl_kinds.binding_kind type variable_context = variable_info list @@ -165,7 +161,7 @@ val named_of_variable_context : variable_context -> Context.Named.t val section_segment_of_constant : Names.constant -> abstr_info val section_segment_of_mutual_inductive: Names.mutual_inductive -> abstr_info val variable_section_segment_of_reference : Globnames.global_reference -> variable_context - + val section_instance : Globnames.global_reference -> Univ.universe_instance * Names.Id.t array val is_in_section : Globnames.global_reference -> bool diff --git a/library/library.ml b/library/library.ml index 20ecc2c22..28afa054e 100644 --- a/library/library.ml +++ b/library/library.ml @@ -551,8 +551,6 @@ let in_require : require_obj -> obj = (* Require libraries, import them if [export <> None], mark them for export if [export = Some true] *) -let (f_xml_require, xml_require) = Hook.make ~default:ignore () - let warn_require_in_module = CWarnings.create ~name:"require-in-module" ~category:"deprecated" (fun () -> strbrk "Require inside a module is" ++ @@ -574,7 +572,6 @@ let require_library_from_dirpath modrefl export = end else add_anonymous_leaf (in_require (needed,modrefl,export)); - if !Flags.xml_export then List.iter (Hook.get f_xml_require) modrefl; () (* the function called by Vernacentries.vernac_import *) diff --git a/library/library.mli b/library/library.mli index 604167804..6c624ce52 100644 --- a/library/library.mli +++ b/library/library.mli @@ -67,9 +67,6 @@ val library_full_filename : DirPath.t -> string (** - Overwrite the filename of all libraries (used when restoring a state) *) val overwrite_library_filenames : string -> unit -(** {6 Hook for the xml exportation of libraries } *) -val xml_require : (DirPath.t -> unit) Hook.t - (** {6 Locate a library in the load paths } *) exception LibUnmappedDir exception LibNotFound diff --git a/library/nameops.ml b/library/nameops.ml index adfe6f5a5..d598a63b8 100644 --- a/library/nameops.ml +++ b/library/nameops.ml @@ -130,7 +130,8 @@ sig val fold_right : (Id.t -> 'a -> 'a) -> t -> 'a -> 'a val iter : (Id.t -> unit) -> t -> unit val map : (Id.t -> Id.t) -> t -> t - val fold_map : ('a -> Id.t -> 'a * Id.t) -> 'a -> t -> 'a * t + val fold_left_map : ('a -> Id.t -> 'a * Id.t) -> 'a -> t -> 'a * t + val fold_right_map : (Id.t -> 'a -> Id.t * 'a) -> Name.t -> 'a -> Name.t * 'a val get_id : t -> Id.t val pick : t -> t -> t val cons : t -> Id.t list -> Id.t list @@ -160,10 +161,14 @@ struct | Name id -> Name (f id) | Anonymous -> Anonymous - let fold_map f a = function + let fold_left_map f a = function | Name id -> let (a, id) = f a id in (a, Name id) | Anonymous -> a, Anonymous + let fold_right_map f na a = match na with + | Name id -> let (id, a) = f id a in (Name id, a) + | Anonymous -> Anonymous, a + let get_id = function | Name id -> id | Anonymous -> raise IsAnonymous @@ -191,7 +196,7 @@ let out_name = get_id let name_fold = fold_right let name_iter = iter let name_app = map -let name_fold_map = fold_map +let name_fold_map = fold_left_map let name_cons = cons let name_max = pick let pr_name = print diff --git a/library/nameops.mli b/library/nameops.mli index 89aba2447..58cd6ed4e 100644 --- a/library/nameops.mli +++ b/library/nameops.mli @@ -66,10 +66,14 @@ module Name : sig val map : (Id.t -> Id.t) -> Name.t -> t (** [map f na] is [Anonymous] if [na] is [Anonymous] and [Name (f id)] if [na] is [Name id]. *) - val fold_map : ('a -> Id.t -> 'a * Id.t) -> 'a -> Name.t -> 'a * Name.t - (** [fold_map f na a] is [a',Name id'] when [na] is [Name id] and [f a id] is [(a',id')]. + val fold_left_map : ('a -> Id.t -> 'a * Id.t) -> 'a -> Name.t -> 'a * Name.t + (** [fold_left_map f a na] is [a',Name id'] when [na] is [Name id] and [f a id] is [(a',id')]. It is [a,Anonymous] otherwise. *) + val fold_right_map : (Id.t -> 'a -> Id.t * 'a) -> Name.t -> 'a -> Name.t * 'a + (** [fold_right_map f na a] is [Name id',a'] when [na] is [Name id] and [f id a] is [(id',a')]. + It is [Anonymous,a] otherwise. *) + val get_id : Name.t -> Id.t (** [get_id] associates [id] to [Name id]. @raise IsAnonymous otherwise. *) @@ -98,7 +102,7 @@ val name_app : (Id.t -> Id.t) -> Name.t -> Name.t (** @deprecated Same as [Name.map] *) val name_fold_map : ('a -> Id.t -> 'a * Id.t) -> 'a -> Name.t -> 'a * Name.t -(** @deprecated Same as [Name.fold_map] *) +(** @deprecated Same as [Name.fold_left_map] *) val name_max : Name.t -> Name.t -> Name.t (** @deprecated Same as [Name.pick] *) diff --git a/man/coqide.1 b/man/coqide.1 index f82bf2ad4..3592f6e4e 100644 --- a/man/coqide.1 +++ b/man/coqide.1 @@ -123,13 +123,6 @@ Set sort Set impredicative. .TP .B \-dont\-load\-proofs Don't load opaque proofs in memory. -.TP -.B \-xml -Export XML files either to the hierarchy rooted in -the directory -.B COQ_XML_LIBRARY_ROOT -(if set) or to stdout (if unset). - .SH SEE ALSO diff --git a/man/coqtop.1 b/man/coqtop.1 index feee7fd8b..62d17aa67 100644 --- a/man/coqtop.1 +++ b/man/coqtop.1 @@ -153,12 +153,6 @@ set sort Set impredicative .B \-dont\-load\-proofs don't load opaque proofs in memory -.TP -.B \-xml -export XML files either to the hierarchy rooted in -the directory $COQ_XML_LIBRARY_ROOT (if set) or to -stdout (if unset) - .SH SEE ALSO .BR coqc (1), diff --git a/parsing/cLexer.ml4 b/parsing/cLexer.ml4 index 5fcbb43b6..636027f9b 100644 --- a/parsing/cLexer.ml4 +++ b/parsing/cLexer.ml4 @@ -368,9 +368,6 @@ let rec string loc ~comm_level bp len = parser let loc = set_loc_pos loc bp ep in err loc Unterminated_string -(* Hook for exporting comment into xml theory files *) -let (f_xml_output_comment, xml_output_comment) = Hook.make ~default:ignore () - (* To associate locations to a file name *) let current_file = ref None @@ -432,9 +429,6 @@ let null_comment s = let comment_stop ep = let current_s = Buffer.contents current_comment in - if !Flags.xml_export && Buffer.length current_comment > 0 && - (!between_commands || not(null_comment current_s)) then - Hook.get f_xml_output_comment current_s; (if !Flags.beautify && Buffer.length current_comment > 0 && (!between_commands || not(null_comment current_s)) then let bp = match !comment_begin with diff --git a/parsing/cLexer.mli b/parsing/cLexer.mli index 09c9d8ee4..77d652b18 100644 --- a/parsing/cLexer.mli +++ b/parsing/cLexer.mli @@ -19,9 +19,6 @@ val get_keyword_state : unit -> keyword_state val check_ident : string -> unit val is_ident : string -> bool val check_keyword : string -> unit - -val xml_output_comment : (string -> unit) Hook.t - val terminal : string -> Tok.t (** The lexer of Coq: *) diff --git a/parsing/egramcoq.ml b/parsing/egramcoq.ml index ec422c58d..870137ca1 100644 --- a/parsing/egramcoq.ml +++ b/parsing/egramcoq.ml @@ -443,7 +443,7 @@ let make_act : type r. r target -> _ -> r gen_eval = function CAst.make ~loc @@ CPatNotation (notation, env, []) let extend_constr state forpat ng = - let n = ng.notgram_level in + let n,_,_ = ng.notgram_level in let assoc = ng.notgram_assoc in let (entry, level) = interp_constr_entry_key forpat n in let fold (accu, state) pt = @@ -464,7 +464,7 @@ let extend_constr state forpat ng = let constr_levels = GramState.field () -let extend_constr_notation (_, ng) state = +let extend_constr_notation ng state = let levels = match GramState.get state constr_levels with | None -> default_constr_levels | Some lev -> lev @@ -476,7 +476,7 @@ let extend_constr_notation (_, ng) state = let state = GramState.set state constr_levels levels in (r @ r', state) -let constr_grammar : (Notation.level * notation_grammar) grammar_command = +let constr_grammar : one_notation_grammar grammar_command = create_grammar_command "Notation" extend_constr_notation -let extend_constr_grammar pr ntn = extend_grammar_command constr_grammar (pr, ntn) +let extend_constr_grammar ntn = extend_grammar_command constr_grammar ntn diff --git a/parsing/egramcoq.mli b/parsing/egramcoq.mli index 248de3348..8e0469275 100644 --- a/parsing/egramcoq.mli +++ b/parsing/egramcoq.mli @@ -13,5 +13,5 @@ (** {5 Adding notations} *) -val extend_constr_grammar : Notation.level -> Notation_term.notation_grammar -> unit +val extend_constr_grammar : Notation_term.one_notation_grammar -> unit (** Add a term notation rule to the parsing system. *) diff --git a/parsing/g_vernac.ml4 b/parsing/g_vernac.ml4 index 3d29fca77..560a9a757 100644 --- a/parsing/g_vernac.ml4 +++ b/parsing/g_vernac.ml4 @@ -51,6 +51,19 @@ let make_bullet s = | '*' -> Star n | _ -> assert false +let parse_compat_version ?(allow_old = true) = let open Flags in function + | "8.8" -> Current + | "8.7" -> V8_7 + | "8.6" -> V8_6 + | "8.5" -> V8_5 + | ("8.4" | "8.3" | "8.2" | "8.1" | "8.0") as s -> + if allow_old then VOld else + CErrors.user_err ~hdr:"get_compat_version" + Pp.(str "Compatibility with version " ++ str s ++ str " not supported.") + | s -> + CErrors.user_err ~hdr:"get_compat_version" + Pp.(str "Unknown compatibility version \"" ++ str s ++ str "\".") + let extraction_err ~loc = if not (Mltop.module_is_known "extraction_plugin") then CErrors.user_err ~loc (str "Please do first a Require Extraction.") @@ -168,8 +181,13 @@ GEXTEND Gram let indl=List.map (fun ((a,b,c,d),e) -> ((a,b,c,k,d),e)) indl in let cum = match cum with - Some b -> b - | None -> Flags.is_inductive_cumulativity () + Some true -> LocalCumulativity + | Some false -> LocalNonCumulativity + | None -> + if Flags.is_polymorphic_inductive_cumulativity () then + GlobalCumulativity + else + GlobalNonCumulativity in VernacInductive (cum, priv,f,indl) | "Fixpoint"; recs = LIST1 rec_definition SEP "with" -> @@ -1163,7 +1181,7 @@ GEXTEND Gram [ [ "("; IDENT "only"; IDENT "parsing"; ")" -> Some Flags.Current | "("; IDENT "compat"; s = STRING; ")" -> - Some (Coqinit.get_compat_version s) + Some (parse_compat_version s) | -> None ] ] ; obsolete_locality: @@ -1181,7 +1199,7 @@ GEXTEND Gram | IDENT "only"; IDENT "printing" -> SetOnlyPrinting | IDENT "only"; IDENT "parsing" -> SetOnlyParsing | IDENT "compat"; s = STRING -> - SetCompatVersion (Coqinit.get_compat_version s) + SetCompatVersion (parse_compat_version s) | IDENT "format"; s1 = [s = STRING -> Loc.tag ~loc:!@loc s]; s2 = OPT [s = STRING -> Loc.tag ~loc:!@loc s] -> begin match s1, s2 with diff --git a/plugins/cc/cctac.ml b/plugins/cc/cctac.ml index 4934b0750..fca7d9851 100644 --- a/plugins/cc/cctac.ml +++ b/plugins/cc/cctac.ml @@ -84,7 +84,8 @@ let rec decompose_term env sigma t= | Proj (p, c) -> let canon_const kn = Constant.make1 (Constant.canonical kn) in let p' = Projection.map canon_const p in - (Appli (Symb (Term.mkConst (Projection.constant p')), decompose_term env sigma c)) + let c = Retyping.expand_projection env sigma p' c [] in + decompose_term env sigma c | _ -> let t = Termops.strip_outer_cast sigma t in if closed0 sigma t then Symb (EConstr.to_constr sigma t) else raise Not_found @@ -231,7 +232,8 @@ let make_prb gls depth additionnal_terms = let build_projection intype (cstr:pconstructor) special default gls= let open Tacmach.New in let ci= (snd(fst cstr)) in - let sigma, body=Equality.build_selector (pf_env gls) (project gls) ci (mkRel 1) intype special default in + let sigma = project gls in + let body=Equality.build_selector (pf_env gls) sigma ci (mkRel 1) intype special default in let id=pf_get_new_id (Id.of_string "t") gls in sigma, mkLambda(Name id,intype,body) @@ -440,11 +442,11 @@ let cc_tactic depth additionnal_terms = let open Glob_term in let env = Proofview.Goal.env gl in let terms_to_complete = List.map (build_term_to_complete uf) (epsilons uf) in - let hole = CAst.make @@ GHole (Evar_kinds.InternalHole, Misctypes.IntroAnonymous, None) in + let hole = DAst.make @@ GHole (Evar_kinds.InternalHole, Misctypes.IntroAnonymous, None) in let pr_missing (c, missing) = - let c = Detyping.detype ~lax:true false [] env sigma c in + let c = Detyping.detype Detyping.Now ~lax:true false [] env sigma c in let holes = List.init missing (fun _ -> hole) in - Printer.pr_glob_constr_env env (CAst.make @@ GApp (c, holes)) + Printer.pr_glob_constr_env env (DAst.make @@ GApp (c, holes)) in Feedback.msg_info (Pp.str "Goal is solvable by congruence but some arguments are missing."); diff --git a/plugins/extraction/extract_env.ml b/plugins/extraction/extract_env.ml index 89c2a0ae3..f503c572d 100644 --- a/plugins/extraction/extract_env.ml +++ b/plugins/extraction/extract_env.ml @@ -281,7 +281,8 @@ and extract_msignature_spec env mp1 reso = function MTfunsig (mbid, extract_mbody_spec env mp mtb, extract_msignature_spec env' mp1 reso me) -and extract_mbody_spec env mp mb = match mb.mod_type_alg with +and extract_mbody_spec : 'a. _ -> _ -> 'a generic_module_body -> _ = + fun env mp mb -> match mb.mod_type_alg with | Some ty -> extract_mexpression_spec env mp (mb.mod_type,ty) | None -> extract_msignature_spec env mp mb.mod_delta mb.mod_type diff --git a/plugins/firstorder/sequent.ml b/plugins/firstorder/sequent.ml index 5ba98fb58..05194164b 100644 --- a/plugins/firstorder/sequent.ml +++ b/plugins/firstorder/sequent.ml @@ -233,7 +233,7 @@ let extend_with_auto_hints env sigma l seq = let print_cmap map= let print_entry c l s= - let xc=Constrextern.extern_constr false (Global.env ()) Evd.empty c in + let xc=Constrextern.extern_constr false (Global.env ()) Evd.empty (EConstr.of_constr c) in str "| " ++ prlist Printer.pr_global l ++ str " : " ++ diff --git a/plugins/funind/glob_term_to_relation.ml b/plugins/funind/glob_term_to_relation.ml index 8555a0b22..7087a195e 100644 --- a/plugins/funind/glob_term_to_relation.ml +++ b/plugins/funind/glob_term_to_relation.ml @@ -34,10 +34,10 @@ type glob_context = (binder_type*glob_constr) list let rec solve_trivial_holes pat_as_term e = - match pat_as_term.CAst.v,e.CAst.v with + match DAst.get pat_as_term, DAst.get e with | GHole _,_ -> e | GApp(fp,argsp),GApp(fe,argse) when glob_constr_eq fp fe -> - CAst.make (GApp((solve_trivial_holes fp fe),List.map2 solve_trivial_holes argsp argse)) + DAst.make (GApp((solve_trivial_holes fp fe),List.map2 solve_trivial_holes argsp argse)) | _,_ -> pat_as_term (* @@ -361,7 +361,7 @@ let add_pat_variables pat typ env : Environ.env = let rec add_pat_variables env pat typ : Environ.env = observe (str "new rel env := " ++ Printer.pr_rel_context_of env (Evd.from_env env)); - match pat.CAst.v with + match DAst.get pat with | PatVar na -> Environ.push_rel (RelDecl.LocalAssum (na,typ)) env | PatCstr(c,patl,na) -> let Inductiveops.IndType(indf,indargs) = @@ -411,7 +411,7 @@ let add_pat_variables pat typ env : Environ.env = -let rec pattern_to_term_and_type env typ = CAst.with_val (function +let rec pattern_to_term_and_type env typ = DAst.with_val (function | PatVar Anonymous -> assert false | PatVar (Name id) -> mkGVar id @@ -434,7 +434,7 @@ let rec pattern_to_term_and_type env typ = CAst.with_val (function Array.to_list (Array.init (cst_narg - List.length patternl) - (fun i -> Detyping.detype false [] env (Evd.from_env env) (EConstr.of_constr csta.(i))) + (fun i -> Detyping.detype Detyping.Now false [] env (Evd.from_env env) (EConstr.of_constr csta.(i))) ) in let patl_as_term = @@ -480,7 +480,7 @@ let rec pattern_to_term_and_type env typ = CAst.with_val (function let rec build_entry_lc env funnames avoid rt : glob_constr build_entry_return = observe (str " Entering : " ++ Printer.pr_glob_constr rt); let open CAst in - match rt.v with + match DAst.get rt with | GRef _ | GVar _ | GEvar _ | GPatVar _ | GSort _ | GHole _ -> (* do nothing (except changing type of course) *) mk_result [] rt avoid @@ -496,13 +496,13 @@ let rec build_entry_lc env funnames avoid rt : glob_constr build_entry_return = (mk_result [] [] avoid) in begin - match f.v with + match DAst.get f with | GLambda _ -> let rec aux t l = match l with | [] -> t - | u::l -> CAst.make @@ - match t.v with + | u::l -> DAst.make @@ + match DAst.get t with | GLambda(na,_,nat,b) -> GLetIn(na,u,None,aux b l) | _ -> @@ -519,7 +519,7 @@ let rec build_entry_lc env funnames avoid rt : glob_constr build_entry_return = *) let rt_as_constr,ctx = Pretyping.understand env (Evd.from_env env) rt in let rt_typ = Typing.unsafe_type_of env (Evd.from_env env) (EConstr.of_constr rt_as_constr) in - let res_raw_type = Detyping.detype false [] env (Evd.from_env env) rt_typ in + let res_raw_type = Detyping.detype Detyping.Now false [] env (Evd.from_env env) rt_typ in let res = fresh_id args_res.to_avoid "_res" in let new_avoid = res::args_res.to_avoid in let res_rt = mkGVar res in @@ -564,7 +564,7 @@ let rec build_entry_lc env funnames avoid rt : glob_constr build_entry_return = let new_b = replace_var_by_term id - (CAst.make @@ GVar id) + (DAst.make @@ GVar id) b in (Name new_id,new_b,new_avoid) @@ -626,7 +626,7 @@ let rec build_entry_lc env funnames avoid rt : glob_constr build_entry_return = then the one corresponding to the value [t] and combine the two result *) - let v = match typ with None -> v | Some t -> CAst.make ?loc:rt.loc @@ GCast (v,CastConv t) in + let v = match typ with None -> v | Some t -> DAst.make ?loc:rt.loc @@ GCast (v,CastConv t) in let v_res = build_entry_lc env funnames avoid v in let v_as_constr,ctx = Pretyping.understand env (Evd.from_env env) v in let v_type = Typing.unsafe_type_of env (Evd.from_env env) (EConstr.of_constr v_as_constr) in @@ -773,7 +773,7 @@ and build_entry_lc_from_case_term env types funname make_discr patterns_to_preve Typing.unsafe_type_of env_with_pat_ids (Evd.from_env env) (EConstr.mkVar id) in let raw_typ_of_id = - Detyping.detype false [] + Detyping.detype Detyping.Now false [] env_with_pat_ids (Evd.from_env env) typ_of_id in mkGProd (Name id,raw_typ_of_id,acc)) @@ -819,7 +819,7 @@ and build_entry_lc_from_case_term env types funname make_discr patterns_to_preve (fun pat e typ_as_constr -> let this_pat_ids = ids_of_pat pat in let typ_as_constr = EConstr.of_constr typ_as_constr in - let typ = Detyping.detype false [] new_env (Evd.from_env env) typ_as_constr in + let typ = Detyping.detype Detyping.Now false [] new_env (Evd.from_env env) typ_as_constr in let pat_as_term = pattern_to_term pat in (* removing trivial holes *) let pat_as_term = solve_trivial_holes pat_as_term e in @@ -833,7 +833,7 @@ and build_entry_lc_from_case_term env types funname make_discr patterns_to_preve then (Prod (Name id), let typ_of_id = Typing.unsafe_type_of new_env (Evd.from_env env) (EConstr.mkVar id) in let raw_typ_of_id = - Detyping.detype false [] new_env (Evd.from_env env) typ_of_id + Detyping.detype Detyping.Now false [] new_env (Evd.from_env env) typ_of_id in raw_typ_of_id )::acc @@ -875,15 +875,23 @@ and build_entry_lc_from_case_term env types funname make_discr patterns_to_preve { brl'_res with result = this_branch_res@brl'_res.result } -let is_res id = - try +let is_res r = match DAst.get r with +| GVar id -> + begin try String.equal (String.sub (Id.to_string id) 0 4) "_res" - with Invalid_argument _ -> false + with Invalid_argument _ -> false end +| _ -> false +let is_gr c gr = match DAst.get c with +| GRef (r, _) -> Globnames.eq_gr r gr +| _ -> false +let is_gvar c = match DAst.get c with +| GVar id -> true +| _ -> false let same_raw_term rt1 rt2 = - match CAst.(rt1.v, rt2.v) with + match DAst.get rt1, DAst.get rt2 with | GRef(r1,_), GRef (r2,_) -> Globnames.eq_gr r1 r2 | GHole _, GHole _ -> true | _ -> false @@ -917,23 +925,24 @@ let rec rebuild_cons env nb_args relname args crossed_types depth rt = observe (str "rebuilding : " ++ pr_glob_constr rt); let open Context.Rel.Declaration in let open CAst in - match rt.v with + match DAst.get rt with | GProd(n,k,t,b) -> let not_free_in_t id = not (is_free_in id t) in let new_crossed_types = t::crossed_types in begin - match t with - | { v = GApp(({ v = GVar res_id } as res_rt),args') } when is_res res_id -> + match DAst.get t with + | GApp(res_rt ,args') when is_res res_rt -> begin - match args' with - | { v = GVar this_relname }::args' -> + let arg = List.hd args' in + match DAst.get arg with + | GVar this_relname -> (*i The next call to mk_rel_id is valid since we are constructing the graph Ensures by: obvious i*) let new_t = - mkGApp(mkGVar(mk_rel_id this_relname),args'@[res_rt]) + mkGApp(mkGVar(mk_rel_id this_relname),List.tl args'@[res_rt]) in let t',ctx = Pretyping.understand env (Evd.from_env env) new_t in let new_env = Environ.push_rel (LocalAssum (n,t')) env in @@ -948,9 +957,13 @@ let rec rebuild_cons env nb_args relname args crossed_types depth rt = | _ -> (* the first args is the name of the function! *) assert false end - | { loc = loc1; v = GApp({ loc = loc2; v = GRef(eq_as_ref,_) },[ty; { loc = loc3; v = GVar id};rt]) } - when Globnames.eq_gr eq_as_ref (Lazy.force Coqlib.coq_eq_ref) && n == Anonymous + | GApp(eq_as_ref,[ty; id ;rt]) + when is_gvar id && is_gr eq_as_ref (Lazy.force Coqlib.coq_eq_ref) && n == Anonymous -> + let loc1 = rt.CAst.loc in + let loc2 = eq_as_ref.CAst.loc in + let loc3 = id.CAst.loc in + let id = match DAst.get id with GVar id -> id | _ -> assert false in begin try observe (str "computing new type for eq : " ++ pr_glob_constr rt); @@ -985,10 +998,10 @@ let rec rebuild_cons env nb_args relname args crossed_types depth rt = let params,arg' = ((Util.List.chop nparam args')) in - let rt_typ = CAst.make @@ - GApp(CAst.make @@ GRef (Globnames.IndRef (fst ind),None), + let rt_typ = DAst.make @@ + GApp(DAst.make @@ GRef (Globnames.IndRef (fst ind),None), (List.map - (fun p -> Detyping.detype false [] + (fun p -> Detyping.detype Detyping.Now false [] env (Evd.from_env env) (EConstr.of_constr p)) params)@(Array.to_list (Array.make @@ -996,7 +1009,7 @@ let rec rebuild_cons env nb_args relname args crossed_types depth rt = (mkGHole ())))) in let eq' = - CAst.make ?loc:loc1 @@ GApp(CAst.make ?loc:loc2 @@GRef(jmeq,None),[ty;CAst.make ?loc:loc3 @@ GVar id;rt_typ;rt]) + DAst.make ?loc:loc1 @@ GApp(DAst.make ?loc:loc2 @@GRef(jmeq,None),[ty;DAst.make ?loc:loc3 @@ GVar id;rt_typ;rt]) in observe (str "computing new type for jmeq : " ++ pr_glob_constr eq'); let eq'_as_constr,ctx = Pretyping.understand env (Evd.from_env env) eq' in @@ -1015,12 +1028,12 @@ let rec rebuild_cons env nb_args relname args crossed_types depth rt = match na with | Anonymous -> acc | Name id' -> - (id',Detyping.detype false [] + (id',Detyping.detype Detyping.Now false [] env (Evd.from_env env) arg)::acc else if isVar var_as_constr - then (destVar var_as_constr,Detyping.detype false [] + then (destVar var_as_constr,Detyping.detype Detyping.Now false [] env (Evd.from_env env) arg)::acc @@ -1065,8 +1078,8 @@ let rec rebuild_cons env nb_args relname args crossed_types depth rt = mkGProd(n,t,new_b),id_to_exclude else new_b, Id.Set.add id id_to_exclude *) - | { loc = loc1; v = GApp({ loc = loc2; v = GRef(eq_as_ref,_) },[ty;rt1;rt2]) } - when Globnames.eq_gr eq_as_ref (Lazy.force Coqlib.coq_eq_ref) && n == Anonymous + | GApp(eq_as_ref,[ty;rt1;rt2]) + when is_gr eq_as_ref (Lazy.force Coqlib.coq_eq_ref) && n == Anonymous -> begin try @@ -1077,7 +1090,7 @@ let rec rebuild_cons env nb_args relname args crossed_types depth rt = List.fold_left (fun acc (lhs,rhs) -> mkGProd(Anonymous, - mkGApp(mkGRef(eq_as_ref),[mkGHole ();lhs;rhs]),acc) + mkGApp(mkGRef(Lazy.force Coqlib.coq_eq_ref),[mkGHole ();lhs;rhs]),acc) ) b l @@ -1135,14 +1148,14 @@ let rec rebuild_cons env nb_args relname args crossed_types depth rt = then new_b, Id.Set.remove id (Id.Set.filter not_free_in_t id_to_exclude) else - CAst.make @@ GProd(n,k,t,new_b),Id.Set.filter not_free_in_t id_to_exclude + DAst.make @@ GProd(n,k,t,new_b),Id.Set.filter not_free_in_t id_to_exclude | _ -> anomaly (Pp.str "Should not have an anonymous function here.") (* We have renamed all the anonymous functions during alpha_renaming phase *) end | GLetIn(n,v,t,b) -> begin - let t = match t with None -> v | Some t -> CAst.make ?loc:rt.loc @@ GCast (v,CastConv t) in + let t = match t with None -> v | Some t -> DAst.make ?loc:rt.loc @@ GCast (v,CastConv t) in let not_free_in_t id = not (is_free_in id t) in let evd = (Evd.from_env env) in let t',ctx = Pretyping.understand env evd t in @@ -1158,7 +1171,7 @@ let rec rebuild_cons env nb_args relname args crossed_types depth rt = match n with | Name id when Id.Set.mem id id_to_exclude && depth >= nb_args -> new_b,Id.Set.remove id (Id.Set.filter not_free_in_t id_to_exclude) - | _ -> CAst.make @@ GLetIn(n,t,None,new_b), (* HOPING IT WOULD WORK *) + | _ -> DAst.make @@ GLetIn(n,t,None,new_b), (* HOPING IT WOULD WORK *) Id.Set.filter not_free_in_t id_to_exclude end | GLetTuple(nal,(na,rto),t,b) -> @@ -1184,7 +1197,7 @@ let rec rebuild_cons env nb_args relname args crossed_types depth rt = (* | Name id when Id.Set.mem id id_to_exclude -> *) (* new_b,Id.Set.remove id (Id.Set.filter not_free_in_t id_to_exclude) *) (* | _ -> *) - CAst.make @@ GLetTuple(nal,(na,None),t,new_b), + DAst.make @@ GLetTuple(nal,(na,None),t,new_b), Id.Set.filter not_free_in_t (Id.Set.union id_to_exclude id_to_exclude') end @@ -1210,12 +1223,15 @@ let rebuild_cons env nb_args relname args crossed_types rt = TODO: Find a valid way to deal with implicit arguments here! *) -let rec compute_cst_params relnames params gt = CAst.with_val (function +let rec compute_cst_params relnames params gt = DAst.with_val (function | GRef _ | GVar _ | GEvar _ | GPatVar _ -> params - | GApp({ CAst.v = GVar relname' },rtl) when Id.Set.mem relname' relnames -> - compute_cst_params_from_app [] (params,rtl) | GApp(f,args) -> + begin match DAst.get f with + | GVar relname' when Id.Set.mem relname' relnames -> + compute_cst_params_from_app [] (params,args) + | _ -> List.fold_left (compute_cst_params relnames) params (f::args) + end | GLambda(_,_,t,b) | GProd(_,_,t,b) | GLetTuple(_,_,t,b) -> let t_params = compute_cst_params relnames params t in compute_cst_params relnames t_params b @@ -1232,10 +1248,10 @@ let rec compute_cst_params relnames params gt = CAst.with_val (function raise (UserError(Some "compute_cst_params", str "Not handled case")) ) gt and compute_cst_params_from_app acc (params,rtl) = + let is_gid id c = match DAst.get c with GVar id' -> Id.equal id id' | _ -> false in match params,rtl with | _::_,[] -> assert false (* the rel has at least nargs + 1 arguments ! *) - | ((Name id,_,None) as param)::params', { CAst.v = GVar id' }::rtl' - when Id.compare id id' == 0 -> + | ((Name id,_,None) as param)::params', c::rtl' when is_gid id c -> compute_cst_params_from_app (param::acc) (params',rtl') | _ -> List.rev acc @@ -1492,7 +1508,7 @@ let do_build_inductive in let msg = str "while trying to define"++ spc () ++ - Ppvernac.pr_vernac (Vernacexpr.VernacInductive(false,false,Decl_kinds.Finite,repacked_rel_inds)) + Ppvernac.pr_vernac (Vernacexpr.VernacInductive(Vernacexpr.GlobalNonCumulativity,false,Decl_kinds.Finite,repacked_rel_inds)) ++ fnl () ++ msg in @@ -1507,7 +1523,7 @@ let do_build_inductive in let msg = str "while trying to define"++ spc () ++ - Ppvernac.pr_vernac (Vernacexpr.VernacInductive(false,false,Decl_kinds.Finite,repacked_rel_inds)) + Ppvernac.pr_vernac (Vernacexpr.VernacInductive(Vernacexpr.GlobalNonCumulativity,false,Decl_kinds.Finite,repacked_rel_inds)) ++ fnl () ++ CErrors.print reraise in diff --git a/plugins/funind/glob_termops.ml b/plugins/funind/glob_termops.ml index 003bb4e30..02ee56ac5 100644 --- a/plugins/funind/glob_termops.ml +++ b/plugins/funind/glob_termops.ml @@ -10,36 +10,36 @@ open Misctypes Some basic functions to rebuild glob_constr In each of them the location is Loc.ghost *) -let mkGRef ref = CAst.make @@ GRef(ref,None) -let mkGVar id = CAst.make @@ GVar(id) -let mkGApp(rt,rtl) = CAst.make @@ GApp(rt,rtl) -let mkGLambda(n,t,b) = CAst.make @@ GLambda(n,Explicit,t,b) -let mkGProd(n,t,b) = CAst.make @@ GProd(n,Explicit,t,b) -let mkGLetIn(n,b,t,c) = CAst.make @@ GLetIn(n,b,t,c) -let mkGCases(rto,l,brl) = CAst.make @@ GCases(Term.RegularStyle,rto,l,brl) -let mkGSort s = CAst.make @@ GSort(s) -let mkGHole () = CAst.make @@ GHole(Evar_kinds.BinderType Anonymous,Misctypes.IntroAnonymous,None) -let mkGCast(b,t) = CAst.make @@ GCast(b,CastConv t) +let mkGRef ref = DAst.make @@ GRef(ref,None) +let mkGVar id = DAst.make @@ GVar(id) +let mkGApp(rt,rtl) = DAst.make @@ GApp(rt,rtl) +let mkGLambda(n,t,b) = DAst.make @@ GLambda(n,Explicit,t,b) +let mkGProd(n,t,b) = DAst.make @@ GProd(n,Explicit,t,b) +let mkGLetIn(n,b,t,c) = DAst.make @@ GLetIn(n,b,t,c) +let mkGCases(rto,l,brl) = DAst.make @@ GCases(Term.RegularStyle,rto,l,brl) +let mkGSort s = DAst.make @@ GSort(s) +let mkGHole () = DAst.make @@ GHole(Evar_kinds.BinderType Anonymous,Misctypes.IntroAnonymous,None) +let mkGCast(b,t) = DAst.make @@ GCast(b,CastConv t) (* Some basic functions to decompose glob_constrs These are analogous to the ones constrs *) let glob_decompose_prod = - let rec glob_decompose_prod args = function - | { CAst.v = GProd(n,k,t,b) } -> + let rec glob_decompose_prod args c = match DAst.get c with + | GProd(n,k,t,b) -> glob_decompose_prod ((n,t)::args) b - | rt -> args,rt + | _ -> args,c in glob_decompose_prod [] let glob_decompose_prod_or_letin = - let rec glob_decompose_prod args = function - | { CAst.v = GProd(n,k,t,b) } -> + let rec glob_decompose_prod args rt = match DAst.get rt with + | GProd(n,k,t,b) -> glob_decompose_prod ((n,None,Some t)::args) b - | { CAst.v = GLetIn(n,b,t,c) } -> + | GLetIn(n,b,t,c) -> glob_decompose_prod ((n,Some b,t)::args) c - | rt -> args,rt + | _ -> args,rt in glob_decompose_prod [] @@ -58,10 +58,10 @@ let glob_decompose_prod_n n = let rec glob_decompose_prod i args c = if i<=0 then args,c else - match c with - | { CAst.v = GProd(n,_,t,b) } -> + match DAst.get c with + | GProd(n,_,t,b) -> glob_decompose_prod (i-1) ((n,t)::args) b - | rt -> args,rt + | _ -> args,c in glob_decompose_prod n [] @@ -70,12 +70,12 @@ let glob_decompose_prod_or_letin_n n = let rec glob_decompose_prod i args c = if i<=0 then args,c else - match c with - | { CAst.v = GProd(n,_,t,b) } -> + match DAst.get c with + | GProd(n,_,t,b) -> glob_decompose_prod (i-1) ((n,None,Some t)::args) b - | { CAst.v = GLetIn(n,b,t,c) } -> + | GLetIn(n,b,t,c) -> glob_decompose_prod (i-1) ((n,Some b,t)::args) c - | rt -> args,rt + | _ -> args,c in glob_decompose_prod n [] @@ -83,10 +83,10 @@ let glob_decompose_prod_or_letin_n n = let glob_decompose_app = let rec decompose_rapp acc rt = (* msgnl (str "glob_decompose_app on : "++ Printer.pr_glob_constr rt); *) - match rt with - | { CAst.v = GApp(rt,rtl) } -> + match DAst.get rt with + | GApp(rt,rtl) -> decompose_rapp (List.fold_left (fun y x -> x::y) acc rtl) rt - | rt -> rt,List.rev acc + | _ -> rt,List.rev acc in decompose_rapp [] @@ -120,7 +120,7 @@ let remove_name_from_mapping mapping na = let change_vars = let rec change_vars mapping rt = - CAst.map_with_loc (fun ?loc -> function + DAst.map_with_loc (fun ?loc -> function | GRef _ as x -> x | GVar id -> let new_id = @@ -191,15 +191,15 @@ let change_vars = let rec alpha_pat excluded pat = let loc = pat.CAst.loc in - match pat.CAst.v with + match DAst.get pat with | PatVar Anonymous -> let new_id = Indfun_common.fresh_id excluded "_x" in - (CAst.make ?loc @@ PatVar(Name new_id)),(new_id::excluded),Id.Map.empty + (DAst.make ?loc @@ PatVar(Name new_id)),(new_id::excluded),Id.Map.empty | PatVar(Name id) -> if Id.List.mem id excluded then let new_id = Namegen.next_ident_away id excluded in - (CAst.make ?loc @@ PatVar(Name new_id)),(new_id::excluded), + (DAst.make ?loc @@ PatVar(Name new_id)),(new_id::excluded), (Id.Map.add id new_id Id.Map.empty) else pat, excluded,Id.Map.empty | PatCstr(constr,patl,na) -> @@ -219,7 +219,7 @@ let rec alpha_pat excluded pat = ([],new_excluded,map) patl in - (CAst.make ?loc @@ PatCstr(constr,List.rev new_patl,new_na)),new_excluded,new_map + (DAst.make ?loc @@ PatCstr(constr,List.rev new_patl,new_na)),new_excluded,new_map let alpha_patl excluded patl = let patl,new_excluded,map = @@ -238,7 +238,7 @@ let alpha_patl excluded patl = let raw_get_pattern_id pat acc = let rec get_pattern_id pat = - match pat.CAst.v with + match DAst.get pat with | PatVar(Anonymous) -> assert false | PatVar(Name id) -> [id] @@ -257,8 +257,8 @@ let get_pattern_id pat = raw_get_pattern_id pat [] let rec alpha_rt excluded rt = let loc = rt.CAst.loc in - let new_rt = CAst.make ?loc @@ - match rt.CAst.v with + let new_rt = DAst.make ?loc @@ + match DAst.get rt with | GRef _ | GVar _ | GEvar _ | GPatVar _ as rt -> rt | GLambda(Anonymous,k,t,b) -> let new_id = Namegen.next_ident_away (Id.of_string "_x") excluded in @@ -377,7 +377,7 @@ and alpha_br excluded (loc,(ids,patl,res)) = [is_free_in id rt] checks if [id] is a free variable in [rt] *) let is_free_in id = - let rec is_free_in x = CAst.with_loc_val (fun ?loc -> function + let rec is_free_in x = DAst.with_loc_val (fun ?loc -> function | GRef _ -> false | GVar id' -> Id.compare id' id == 0 | GEvar _ -> false @@ -421,7 +421,7 @@ let is_free_in id = -let rec pattern_to_term pt = CAst.with_val (function +let rec pattern_to_term pt = DAst.with_val (function | PatVar Anonymous -> assert false | PatVar(Name id) -> mkGVar id @@ -448,8 +448,8 @@ let rec pattern_to_term pt = CAst.with_val (function let replace_var_by_term x_id term = - let rec replace_var_by_pattern x = CAst.map (function - | GVar id when Id.compare id x_id == 0 -> term.CAst.v + let rec replace_var_by_pattern x = DAst.map (function + | GVar id when Id.compare id x_id == 0 -> DAst.get term | GRef _ | GVar _ | GEvar _ @@ -522,11 +522,10 @@ exception NotUnifiable let rec are_unifiable_aux = function | [] -> () - | eq::eqs -> - let open CAst in - match eq with - | { v = PatVar _ },_ | _, { v = PatVar _ } -> are_unifiable_aux eqs - | { v = PatCstr(constructor1,cpl1,_) }, { v = PatCstr(constructor2,cpl2,_) } -> + | (l, r) ::eqs -> + match DAst.get l, DAst.get r with + | PatVar _ ,_ | _, PatVar _-> are_unifiable_aux eqs + | PatCstr(constructor1,cpl1,_), PatCstr(constructor2,cpl2,_) -> if not (eq_constructor constructor2 constructor1) then raise NotUnifiable else @@ -545,11 +544,10 @@ let are_unifiable pat1 pat2 = let rec eq_cases_pattern_aux = function | [] -> () - | eq::eqs -> - let open CAst in - match eq with - | { v = PatVar _ }, { v = PatVar _ } -> eq_cases_pattern_aux eqs - | { v = PatCstr(constructor1,cpl1,_) }, { v = PatCstr(constructor2,cpl2,_) } -> + | (l, r) ::eqs -> + match DAst.get l, DAst.get r with + | PatVar _, PatVar _ -> eq_cases_pattern_aux eqs + | PatCstr(constructor1,cpl1,_), PatCstr(constructor2,cpl2,_) -> if not (eq_constructor constructor2 constructor1) then raise NotUnifiable else @@ -569,7 +567,7 @@ let eq_cases_pattern pat1 pat2 = let ids_of_pat = - let rec ids_of_pat ids = CAst.with_val (function + let rec ids_of_pat ids = DAst.with_val (function | PatVar Anonymous -> ids | PatVar(Name id) -> Id.Set.add id ids | PatCstr(_,patl,_) -> List.fold_left ids_of_pat ids patl @@ -583,9 +581,9 @@ let id_of_name = function (* TODO: finish Rec caes *) let ids_of_glob_constr c = - let rec ids_of_glob_constr acc {loc; CAst.v = c} = + let rec ids_of_glob_constr acc c = let idof = id_of_name in - match c with + match DAst.get c with | GVar id -> id::acc | GApp (g,args) -> ids_of_glob_constr [] g @ List.flatten (List.map (ids_of_glob_constr []) args) @ acc @@ -610,7 +608,7 @@ let ids_of_glob_constr c = let zeta_normalize = - let rec zeta_normalize_term x = CAst.map (function + let rec zeta_normalize_term x = DAst.map (function | GRef _ | GVar _ | GEvar _ @@ -632,9 +630,9 @@ let zeta_normalize = zeta_normalize_term b ) | GLetIn(Name id,def,typ,b) -> - (zeta_normalize_term (replace_var_by_term id def b)).CAst.v + DAst.get (zeta_normalize_term (replace_var_by_term id def b)) | GLetIn(Anonymous,def,typ,b) -> - (zeta_normalize_term b).CAst.v + DAst.get (zeta_normalize_term b) | GLetTuple(nal,(na,rto),def,b) -> GLetTuple(nal, (na,Option.map zeta_normalize_term rto), @@ -670,19 +668,19 @@ let zeta_normalize = let expand_as = - let rec add_as map ({loc; CAst.v = pat } as rt) = - match pat with + let rec add_as map rt = + match DAst.get rt with | PatVar _ -> map | PatCstr(_,patl,Name id) -> Id.Map.add id (pattern_to_term rt) (List.fold_left add_as map patl) | PatCstr(_,patl,_) -> List.fold_left add_as map patl in - let rec expand_as map = CAst.map (function + let rec expand_as map = DAst.map (function | GRef _ | GEvar _ | GPatVar _ | GSort _ | GHole _ as rt -> rt | GVar id as rt -> begin try - (Id.Map.find id map).CAst.v + DAst.get (Id.Map.find id map) with Not_found -> rt end | GApp(f,args) -> GApp(expand_as map f,List.map (expand_as map) args) @@ -723,7 +721,7 @@ If someone knows how to prevent solved existantial removal in understand, pleas (* then we map [rt] to replace the implicit holes by their values *) let rec change rt = - match rt.CAst.v with + match DAst.get rt with | GHole(ImplicitArg(grk,pk,bk),_,_) -> (* we only want to deal with implicit arguments *) ( try (* we scan the new evar map to find the evar corresponding to this hole (by looking the source *) @@ -743,7 +741,7 @@ If someone knows how to prevent solved existantial removal in understand, pleas match evi.evar_body with | Evar_defined c -> (* we just have to lift the solution in glob_term *) - Detyping.detype false [] env ctx (EConstr.of_constr (f c)) + Detyping.detype Detyping.Now false [] env ctx (EConstr.of_constr (f c)) | Evar_empty -> rt (* the hole was not solved : we do nothing *) ) | (GHole(BinderType na,_,_)) -> (* we only want to deal with implicit arguments *) @@ -765,7 +763,7 @@ If someone knows how to prevent solved existantial removal in understand, pleas match evi.evar_body with | Evar_defined c -> (* we just have to lift the solution in glob_term *) - Detyping.detype false [] env ctx (EConstr.of_constr (f c)) + Detyping.detype Detyping.Now false [] env ctx (EConstr.of_constr (f c)) | Evar_empty -> rt (* the hole was not solved : we d when falseo nothing *) in res diff --git a/plugins/funind/indfun.ml b/plugins/funind/indfun.ml index 89537ad3f..dab094f91 100644 --- a/plugins/funind/indfun.ml +++ b/plugins/funind/indfun.ml @@ -191,7 +191,7 @@ let error msg = user_err Pp.(str msg) let is_rec names = let names = List.fold_right Id.Set.add names Id.Set.empty in let check_id id names = Id.Set.mem id names in - let rec lookup names gt = match gt.CAst.v with + let rec lookup names gt = match DAst.get gt with | GVar(id) -> check_id id names | GRef _ | GEvar _ | GPatVar _ | GSort _ | GHole _ -> false | GCast(b,_) -> lookup names b @@ -618,7 +618,7 @@ let recompute_binder_list (fixpoint_exprl : (Vernacexpr.fixpoint_expr * Vernacex let fixl,ntns = Command.extract_fixpoint_components false fixpoint_exprl in let ((_,_,typel),_,ctx,_) = Command.interp_fixpoint fixl ntns in let constr_expr_typel = - with_full_print (List.map (Constrextern.extern_constr false (Global.env ()) (Evd.from_ctx ctx))) typel in + with_full_print (List.map (fun c -> Constrextern.extern_constr false (Global.env ()) (Evd.from_ctx ctx) (EConstr.of_constr c))) typel in let fixpoint_exprl_with_new_bl = List.map2 (fun ((lna,(rec_arg_opt,rec_order),bl,ret_typ,opt_body),notation_list) fix_typ -> @@ -855,9 +855,9 @@ let make_graph (f_ref:global_reference) = let sigma = Evd.from_env env in let extern_body,extern_type = with_full_print (fun () -> - (Constrextern.extern_constr false env sigma body, + (Constrextern.extern_constr false env sigma (EConstr.of_constr body), Constrextern.extern_type false env sigma - ((*FIXME*) c_body.const_type) + (EConstr.of_constr (*FIXME*) c_body.const_type) ) ) () diff --git a/plugins/funind/indfun_common.ml b/plugins/funind/indfun_common.ml index f4f9ba2bb..5f4d514f3 100644 --- a/plugins/funind/indfun_common.ml +++ b/plugins/funind/indfun_common.ml @@ -66,7 +66,7 @@ let chop_rlambda_n = if n == 0 then List.rev acc,rt else - match rt.CAst.v with + match DAst.get rt with | Glob_term.GLambda(name,k,t,b) -> chop_lambda_n ((name,t,None)::acc) (n-1) b | Glob_term.GLetIn(name,v,t,b) -> chop_lambda_n ((name,v,t)::acc) (n-1) b | _ -> @@ -80,7 +80,7 @@ let chop_rprod_n = if n == 0 then List.rev acc,rt else - match rt.CAst.v with + match DAst.get rt with | Glob_term.GProd(name,k,t,b) -> chop_prod_n ((name,t)::acc) (n-1) b | _ -> raise (CErrors.UserError(Some "chop_rprod_n",str "chop_rprod_n: Not enough products")) in diff --git a/plugins/funind/merge.ml b/plugins/funind/merge.ml index 52a82b0e5..96200a98a 100644 --- a/plugins/funind/merge.ml +++ b/plugins/funind/merge.ml @@ -64,8 +64,8 @@ let string_of_name = id_of_name %> Id.to_string (** [isVarf f x] returns [true] if term [x] is of the form [(Var f)]. *) let isVarf f x = - match x with - | { CAst.v = GVar x } -> Id.equal x f + match DAst.get x with + | GVar x -> Id.equal x f | _ -> false (** [ident_global_exist id] returns true if identifier [id] is linked @@ -491,38 +491,38 @@ exception NoMerge let rec merge_app c1 c2 id1 id2 shift filter_shift_stable = let lnk = Array.append shift.lnk1 shift.lnk2 in - match CAst.(c1.v, c2.v) with + match DAst.get c1, DAst.get c2 with | GApp(f1, arr1), GApp(f2,arr2) when isVarf id1 f1 && isVarf id2 f2 -> let _ = prstr "\nICI1!\n" in let args = filter_shift_stable lnk (arr1 @ arr2) in - CAst.make @@ GApp ((CAst.make @@ GVar shift.ident) , args) + DAst.make @@ GApp ((DAst.make @@ GVar shift.ident) , args) | GApp(f1, arr1), GApp(f2,arr2) -> raise NoMerge | GLetIn(nme,bdy,typ,trm) , _ -> let _ = prstr "\nICI2!\n" in let newtrm = merge_app trm c2 id1 id2 shift filter_shift_stable in - CAst.make @@ GLetIn(nme,bdy,typ,newtrm) + DAst.make @@ GLetIn(nme,bdy,typ,newtrm) | _, GLetIn(nme,bdy,typ,trm) -> let _ = prstr "\nICI3!\n" in let newtrm = merge_app c1 trm id1 id2 shift filter_shift_stable in - CAst.make @@ GLetIn(nme,bdy,typ,newtrm) + DAst.make @@ GLetIn(nme,bdy,typ,newtrm) | _ -> let _ = prstr "\nICI4!\n" in raise NoMerge let rec merge_app_unsafe c1 c2 shift filter_shift_stable = let lnk = Array.append shift.lnk1 shift.lnk2 in - match CAst.(c1.v, c2.v) with + match DAst.get c1, DAst.get c2 with | GApp(f1, arr1), GApp(f2,arr2) -> let args = filter_shift_stable lnk (arr1 @ arr2) in - CAst.make @@ GApp (CAst.make @@ GVar shift.ident, args) + DAst.make @@ GApp (DAst.make @@ GVar shift.ident, args) (* FIXME: what if the function appears in the body of the let? *) | GLetIn(nme,bdy,typ,trm) , _ -> let _ = prstr "\nICI2 '!\n" in let newtrm = merge_app_unsafe trm c2 shift filter_shift_stable in - CAst.make @@ GLetIn(nme,bdy,typ,newtrm) + DAst.make @@ GLetIn(nme,bdy,typ,newtrm) | _, GLetIn(nme,bdy,typ,trm) -> let _ = prstr "\nICI3 '!\n" in let newtrm = merge_app_unsafe c1 trm shift filter_shift_stable in - CAst.make @@ GLetIn(nme,bdy,typ,newtrm) + DAst.make @@ GLetIn(nme,bdy,typ,newtrm) | _ -> let _ = prstr "\nICI4 '!\n" in raise NoMerge @@ -533,16 +533,18 @@ let rec merge_app_unsafe c1 c2 shift filter_shift_stable = let rec merge_rec_hyps shift accrec (ltyp:(Name.t * glob_constr option * glob_constr option) list) filter_shift_stable : (Name.t * glob_constr option * glob_constr option) list = + let is_app c = match DAst.get c with GApp _ -> true | _ -> false in let mergeonehyp t reldecl = match reldecl with - | (nme,x,Some ({ CAst.v = GApp(i,args)} as ind)) + | (nme,x,Some ind) when is_app ind -> nme,x, Some (merge_app_unsafe ind t shift filter_shift_stable) | (nme,Some _,None) -> error "letins with recursive calls not treated yet" | (nme,None,Some _) -> assert false | (nme,None,None) | (nme,Some _,Some _) -> assert false in + let is_app c = match DAst.get c with GApp (f, _) -> isVarf ind2name f | _ -> false in match ltyp with | [] -> [] - | (nme,None,Some ({ CAst. v = GApp(f, largs) } as t)) :: lt when isVarf ind2name f -> + | (nme,None,Some t) :: lt when is_app t -> let rechyps = List.map (mergeonehyp t) accrec in rechyps @ merge_rec_hyps shift accrec lt filter_shift_stable | e::lt -> e :: merge_rec_hyps shift accrec lt filter_shift_stable @@ -553,12 +555,13 @@ let build_suppl_reccall (accrec:(Name.t * glob_constr) list) concl2 shift = let find_app (nme:Id.t) ltyp = + let is_app c = match DAst.get c with GApp (f, _) -> isVarf nme f | _ -> false in try ignore (List.map (fun x -> match x with - | _,None,Some { CAst.v = GApp(f,_)} when isVarf nme f -> raise (Found 0) + | _,None,Some c when is_app c -> raise (Found 0) | _ -> ()) ltyp); false @@ -617,7 +620,7 @@ let rec merge_types shift accrec1 rechyps , concl | (nme,None, Some t1)as e ::lt1 -> - (match t1.CAst.v with + (match DAst.get t1 with | GApp(f,carr) when isVarf ind1name f -> merge_types shift (e::accrec1) lt1 concl1 ltyp2 concl2 | _ -> @@ -764,7 +767,7 @@ let merge_inductive_body (shift:merge_infos) avoid (oib1:one_inductive_body) (* first replace rel 1 by a varname *) let substindtyp = substitterm 0 (mkRel 1) (mkVar nme) typ in let substindtyp = EConstr.of_constr substindtyp in - Detyping.detype false (Id.Set.elements avoid) (Global.env()) Evd.empty substindtyp in + Detyping.detype Detyping.Now false (Id.Set.elements avoid) (Global.env()) Evd.empty substindtyp in let lcstr1: glob_constr list = Array.to_list (Array.map (mkrawcor ind1name avoid) oib1.mind_user_lc) in (* add to avoid all indentifiers of lcstr1 *) @@ -812,13 +815,13 @@ let merge_rec_params_and_arity prms1 prms2 shift (concl:constr) = let typ = glob_constr_to_constr_expr tp in CLocalAssum ([(Loc.tag nme)], Constrexpr_ops.default_binder_kind, typ) :: acc) [] params in - let concl = Constrextern.extern_constr false (Global.env()) Evd.empty concl in + let concl = Constrextern.extern_constr false (Global.env()) Evd.empty (EConstr.of_constr concl) in let arity,_ = List.fold_left (fun (acc,env) decl -> let nm = Context.Rel.Declaration.get_name decl in let c = RelDecl.get_type decl in - let typ = Constrextern.extern_constr false env Evd.empty c in + let typ = Constrextern.extern_constr false env Evd.empty (EConstr.of_constr c) in let newenv = Environ.push_rel (LocalAssum (nm,c)) env in CAst.make @@ CProdN ([[(Loc.tag nm)],Constrexpr_ops.default_binder_kind,typ] , acc) , newenv) (concl,Global.env()) @@ -848,8 +851,8 @@ let mkProd_reldecl (rdecl:Context.Rel.Declaration.t) (t2:glob_constr) = match rdecl with | LocalAssum (nme,t) -> let t = EConstr.of_constr t in - let traw = Detyping.detype false [] (Global.env()) Evd.empty t in - CAst.make @@ GProd (nme,Explicit,traw,t2) + let traw = Detyping.detype Detyping.Now false [] (Global.env()) Evd.empty t in + DAst.make @@ GProd (nme,Explicit,traw,t2) | LocalDef _ -> assert false diff --git a/plugins/funind/recdef.ml b/plugins/funind/recdef.ml index d3eccb58d..41a10cba3 100644 --- a/plugins/funind/recdef.ml +++ b/plugins/funind/recdef.ml @@ -190,15 +190,15 @@ let (value_f:Term.constr list -> global_reference -> Term.constr) = in let env = Environ.push_rel_context context (Global.env ()) in let glob_body = - CAst.make @@ + DAst.make @@ GCases (RegularStyle,None, - [CAst.make @@ GApp(CAst.make @@ GRef(fterm,None), List.rev_map (fun x_id -> CAst.make @@ GVar x_id) rev_x_id_l), + [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], [CAst.make @@ PatCstr ((destIndRef (delayed_force coq_sig_ref),1), - [CAst.make @@ PatVar(Name v_id); CAst.make @@ PatVar Anonymous], + [Loc.tag ([v_id], [DAst.make @@ PatCstr ((destIndRef (delayed_force coq_sig_ref),1), + [DAst.make @@ PatVar(Name v_id); DAst.make @@ PatVar Anonymous], Anonymous)], - CAst.make @@ GVar v_id)]) + DAst.make @@ GVar v_id)]) in let body = fst (understand env (Evd.from_env env) glob_body)(*FIXME*) in it_mkLambda_or_LetIn body context diff --git a/plugins/ltac/extraargs.ml4 b/plugins/ltac/extraargs.ml4 index 609795133..89feea8dc 100644 --- a/plugins/ltac/extraargs.ml4 +++ b/plugins/ltac/extraargs.ml4 @@ -249,7 +249,7 @@ END let pr_by_arg_tac _prc _prlc prtac opt_c = match opt_c with | None -> mt () - | Some t -> hov 2 (str "by" ++ spc () ++ prtac (3,Ppextend.E) t) + | Some t -> hov 2 (str "by" ++ spc () ++ prtac (3,Notation_term.E) t) ARGUMENT EXTEND by_arg_tac TYPED AS tactic_opt diff --git a/plugins/ltac/extraargs.mli b/plugins/ltac/extraargs.mli index b06f35ddc..00668ddc7 100644 --- a/plugins/ltac/extraargs.mli +++ b/plugins/ltac/extraargs.mli @@ -64,7 +64,7 @@ val wit_by_arg_tac : Geninterp.Val.t option) Genarg.genarg_type val pr_by_arg_tac : - (int * Ppextend.parenRelation -> raw_tactic_expr -> Pp.t) -> + (int * Notation_term.parenRelation -> raw_tactic_expr -> Pp.t) -> raw_tactic_expr option -> Pp.t val test_lpar_id_colon : unit Pcoq.Gram.entry diff --git a/plugins/ltac/extratactics.ml4 b/plugins/ltac/extratactics.ml4 index f3f2f27e9..99e444010 100644 --- a/plugins/ltac/extratactics.ml4 +++ b/plugins/ltac/extratactics.ml4 @@ -40,7 +40,7 @@ let with_delayed_uconstr ist c tac = fail_evar = false; expand_evars = true } in - let c = Pretyping.type_uconstr ~flags ist c in + let c = Tacinterp.type_uconstr ~flags ist c in Tacticals.New.tclDELAYEDWITHHOLES false c tac let replace_in_clause_maybe_by ist c1 c2 cl tac = @@ -359,7 +359,7 @@ let refine_tac ist simple with_classes c = let flags = { constr_flags () with Pretyping.use_typeclasses = with_classes } in let expected_type = Pretyping.OfType concl in - let c = Pretyping.type_uconstr ~flags ~expected_type ist c in + let c = Tacinterp.type_uconstr ~flags ~expected_type ist c in let update = begin fun sigma -> c env sigma end in @@ -626,19 +626,19 @@ END let subst_var_with_hole occ tid t = let occref = if occ > 0 then ref occ else Find_subterm.error_invalid_occurrence [occ] in let locref = ref 0 in - let rec substrec = function - | { CAst.v = GVar id } as x -> + let rec substrec x = match DAst.get x with + | GVar id -> if Id.equal id tid then (decr occref; if Int.equal !occref 0 then x else (incr locref; - CAst.make ~loc:(Loc.make_loc (!locref,0)) @@ + DAst.make ~loc:(Loc.make_loc (!locref,0)) @@ GHole (Evar_kinds.QuestionMark(Evar_kinds.Define true,Anonymous), Misctypes.IntroAnonymous, None))) else x - | c -> map_glob_constr_left_to_right substrec c in + | _ -> map_glob_constr_left_to_right substrec x in let t' = substrec t in if !occref > 0 then Find_subterm.error_invalid_occurrence [occ] else t' @@ -646,15 +646,15 @@ let subst_var_with_hole occ tid t = let subst_hole_with_term occ tc t = let locref = ref 0 in let occref = ref occ in - let rec substrec = function - | { CAst.v = GHole (Evar_kinds.QuestionMark(Evar_kinds.Define true,Anonymous),Misctypes.IntroAnonymous,s) } -> + let rec substrec c = match DAst.get c with + | GHole (Evar_kinds.QuestionMark(Evar_kinds.Define true,Anonymous),Misctypes.IntroAnonymous,s) -> decr occref; if Int.equal !occref 0 then tc else (incr locref; - CAst.make ~loc:(Loc.make_loc (!locref,0)) @@ + DAst.make ~loc:(Loc.make_loc (!locref,0)) @@ GHole (Evar_kinds.QuestionMark(Evar_kinds.Define true,Anonymous),Misctypes.IntroAnonymous,s)) - | c -> map_glob_constr_left_to_right substrec c + | _ -> map_glob_constr_left_to_right substrec c in substrec t @@ -666,8 +666,8 @@ let hResolve id c occ t = let env = Termops.clear_named_body id (Proofview.Goal.env gl) in let concl = Proofview.Goal.concl gl in let env_ids = Termops.ids_of_context env in - let c_raw = Detyping.detype true env_ids env sigma c in - let t_raw = Detyping.detype true env_ids env sigma t in + let c_raw = Detyping.detype Detyping.Now true env_ids env sigma c in + let t_raw = Detyping.detype Detyping.Now true env_ids env sigma t in let rec resolve_hole t_hole = try Pretyping.understand env sigma t_hole diff --git a/plugins/ltac/g_auto.ml4 b/plugins/ltac/g_auto.ml4 index 301943a50..5baa0d5c1 100644 --- a/plugins/ltac/g_auto.ml4 +++ b/plugins/ltac/g_auto.ml4 @@ -48,7 +48,7 @@ let eval_uconstrs ist cs = expand_evars = true } in let map c env sigma = c env sigma in - List.map (fun c -> map (Pretyping.type_uconstr ~flags ist c)) cs + List.map (fun c -> map (Tacinterp.type_uconstr ~flags ist c)) cs let pr_auto_using_raw _ _ _ = Pptactic.pr_auto_using Ppconstr.pr_constr_expr let pr_auto_using_glob _ _ _ = Pptactic.pr_auto_using (fun (c,_) -> Printer.pr_glob_constr c) diff --git a/plugins/ltac/g_class.ml4 b/plugins/ltac/g_class.ml4 index dd24aa3db..104977aef 100644 --- a/plugins/ltac/g_class.ml4 +++ b/plugins/ltac/g_class.ml4 @@ -20,7 +20,7 @@ let set_transparency cl b = List.iter (fun r -> let gr = Smartlocate.global_with_alias r in let ev = Tacred.evaluable_of_global_reference (Global.env ()) gr in - Classes.set_typeclass_transparency ev false b) cl + Classes.set_typeclass_transparency ev (Locality.make_section_locality None) b) cl VERNAC COMMAND EXTEND Typeclasses_Unfold_Settings CLASSIFIED AS SIDEFF | [ "Typeclasses" "Transparent" reference_list(cl) ] -> [ diff --git a/plugins/ltac/g_rewrite.ml4 b/plugins/ltac/g_rewrite.ml4 index c874f8d5a..c22e68323 100644 --- a/plugins/ltac/g_rewrite.ml4 +++ b/plugins/ltac/g_rewrite.ml4 @@ -123,7 +123,7 @@ END let clsubstitute o c = Proofview.Goal.enter begin fun gl -> - let is_tac id = match fst (fst (snd c)) with { CAst.v = GVar id' } when Id.equal id' id -> true | _ -> false in + let is_tac id = match DAst.get (fst (fst (snd c))) with GVar id' when Id.equal id' id -> true | _ -> false in let hyps = Tacmach.New.pf_ids_of_hyps gl in Tacticals.New.tclMAP (fun cl -> diff --git a/plugins/ltac/pptactic.ml b/plugins/ltac/pptactic.ml index 140cc3344..f4e3ba633 100644 --- a/plugins/ltac/pptactic.ml +++ b/plugins/ltac/pptactic.ml @@ -18,7 +18,7 @@ open Geninterp open Stdarg open Tacarg open Libnames -open Ppextend +open Notation_term open Misctypes open Locus open Decl_kinds @@ -1040,7 +1040,7 @@ type 'a extra_genarg_printer = let strip_prod_binders_glob_constr n (ty,_) = let rec strip_ty acc n ty = if Int.equal n 0 then (List.rev acc, (ty,None)) else - match ty.CAst.v with + match DAst.get ty with Glob_term.GProd(na,Explicit,a,b) -> strip_ty (([Loc.tag na],(a,None))::acc) (n-1) b | _ -> user_err Pp.(str "Cannot translate fix tactic: not enough products") in diff --git a/plugins/ltac/pptactic.mli b/plugins/ltac/pptactic.mli index 0bf9bc7f6..1f6ebaf44 100644 --- a/plugins/ltac/pptactic.mli +++ b/plugins/ltac/pptactic.mli @@ -16,7 +16,7 @@ open Misctypes open Environ open Constrexpr open Tacexpr -open Ppextend +open Notation_term type 'a grammar_tactic_prod_item_expr = | TacTerm of string diff --git a/plugins/ltac/tacintern.ml b/plugins/ltac/tacintern.ml index 0554d4364..fc6ee6aab 100644 --- a/plugins/ltac/tacintern.ml +++ b/plugins/ltac/tacintern.ml @@ -106,12 +106,12 @@ let intern_ltac_variable ist = function let intern_constr_reference strict ist = function | Ident (_,id) as r when not strict && find_hyp id ist -> - (CAst.make @@ GVar id), Some (CAst.make @@ CRef (r,None)) + (DAst.make @@ GVar id), Some (CAst.make @@ CRef (r,None)) | Ident (_,id) as r when find_var id ist -> - (CAst.make @@ GVar id), if strict then None else Some (CAst.make @@ CRef (r,None)) + (DAst.make @@ GVar id), if strict then None else Some (CAst.make @@ CRef (r,None)) | r -> let loc,_ as lqid = qualid_of_reference r in - CAst.make @@ GRef (locate_global_with_alias lqid,None), + DAst.make @@ GRef (locate_global_with_alias lqid,None), if strict then None else Some (CAst.make @@ CRef (r,None)) (* Internalize an isolated reference in position of tactic *) @@ -264,9 +264,10 @@ let intern_destruction_arg ist = function | clear,ElimOnIdent (loc,id) -> if !strict_check then (* If in a defined tactic, no intros-until *) - match intern_constr ist (CAst.make @@ CRef (Ident (Loc.tag id), None)) with - | {loc; CAst.v = GVar id}, _ -> clear,ElimOnIdent (loc,id) - | c -> clear,ElimOnConstr (c,NoBindings) + let c, p = intern_constr ist (CAst.make @@ CRef (Ident (Loc.tag id), None)) in + match DAst.get c with + | GVar id -> clear,ElimOnIdent (c.CAst.loc,id) + | _ -> clear,ElimOnConstr ((c, p), NoBindings) else clear,ElimOnIdent (loc,id) @@ -348,7 +349,7 @@ let intern_typed_pattern_or_ref_with_occurrences ist (l,p) = ltac_extra = ist.extra; } in let c = Constrintern.interp_reference sign r in - match c.CAst.v with + match DAst.get c with | GRef (r,None) -> Inl (ArgArg (evaluable_of_global_reference ist.genv r,None)) | GVar id -> diff --git a/plugins/ltac/tacinterp.ml b/plugins/ltac/tacinterp.ml index d3e625e73..8fa95ffb0 100644 --- a/plugins/ltac/tacinterp.ml +++ b/plugins/ltac/tacinterp.ml @@ -679,8 +679,8 @@ let interp_typed_pattern ist env sigma (_,c,_) = (* Interprets a constr expression *) let interp_constr_in_compound_list inj_fun dest_fun interp_fun ist env sigma l = let try_expand_ltac_var sigma x = - try match dest_fun x with - | { CAst.v = GVar id }, _ -> + try match DAst.get (fst (dest_fun x)) with + | GVar id -> let v = Id.Map.find id ist.lfun in sigma, List.map inj_fun (coerce_to_constr_list env v) | _ -> @@ -689,7 +689,7 @@ let interp_constr_in_compound_list inj_fun dest_fun interp_fun ist env sigma l = (* dest_fun, List.assoc may raise Not_found *) let sigma, c = interp_fun ist env sigma x in sigma, [c] in - let sigma, l = List.fold_map try_expand_ltac_var sigma l in + let sigma, l = List.fold_left_map try_expand_ltac_var sigma l in sigma, List.flatten l let interp_constr_list ist env sigma c = @@ -908,18 +908,18 @@ and interp_intro_pattern_action ist env sigma = function and interp_or_and_intro_pattern ist env sigma = function | IntroAndPattern l -> - let sigma, l = List.fold_map (interp_intro_pattern ist env) sigma l in + let sigma, l = List.fold_left_map (interp_intro_pattern ist env) sigma l in sigma, IntroAndPattern l | IntroOrPattern ll -> - let sigma, ll = List.fold_map (interp_intro_pattern_list_as_list ist env) sigma ll in + let sigma, ll = List.fold_left_map (interp_intro_pattern_list_as_list ist env) sigma ll in sigma, IntroOrPattern ll and interp_intro_pattern_list_as_list ist env sigma = function | [loc,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_map (interp_intro_pattern ist env) sigma l) - | l -> List.fold_map (interp_intro_pattern ist env) sigma l + List.fold_left_map (interp_intro_pattern ist env) sigma l) + | l -> List.fold_left_map (interp_intro_pattern ist env) sigma l let interp_intro_pattern_naming_option ist env sigma = function | None -> None @@ -973,7 +973,7 @@ let interp_bindings ist env sigma = function let sigma, l = interp_open_constr_list ist env sigma l in sigma, ImplicitBindings l | ExplicitBindings l -> - let sigma, l = List.fold_map (interp_binding ist env) sigma l in + let sigma, l = List.fold_left_map (interp_binding ist env) sigma l in sigma, ExplicitBindings l let interp_constr_with_bindings ist env sigma (c,bl) = @@ -1043,7 +1043,7 @@ let interp_destruction_arg ist gl arg = if Tactics.is_quantified_hypothesis id gl then keep,ElimOnIdent (loc,id) else - let c = (CAst.make ?loc @@ GVar id,Some (CAst.make @@ CRef (Ident (loc,id),None))) in + let c = (DAst.make ?loc @@ GVar id,Some (CAst.make @@ CRef (Ident (loc,id),None))) in let f env sigma = let (sigma,c) = interp_open_constr ist env sigma c in (sigma, (c,NoBindings)) @@ -1108,6 +1108,20 @@ let rec read_match_rule lfun ist env sigma = function :: read_match_rule lfun ist env sigma tl | [] -> [] +(* Fully evaluate an untyped constr *) +let type_uconstr ?(flags = {(constr_flags ()) with use_hook = None }) + ?(expected_type = WithoutTypeConstraint) ist c = + begin fun env sigma -> + let { closure; term } = c in + let vars = { + ltac_constrs = closure.typed; + ltac_uconstrs = closure.untyped; + ltac_idents = closure.idents; + ltac_genargs = Id.Map.empty; + } in + understand_ltac flags env sigma vars expected_type term + end + let warn_deprecated_info = CWarnings.create ~name:"deprecated-info-tactical" ~category:"deprecated" (fun () -> @@ -1657,7 +1671,7 @@ and interp_atomic ist tac : unit Proofview.tactic = let env = Proofview.Goal.env gl in let sigma = project gl in let sigma, cb = interp_open_constr_with_bindings ist env sigma cb in - let sigma, cbo = Option.fold_map (interp_open_constr_with_bindings ist env) sigma cbo in + let sigma, cbo = Option.fold_left_map (interp_open_constr_with_bindings ist env) sigma cbo in let named_tac = let tac = Tactics.elim ev keep cb cbo in name_atomic ~env (TacElim (ev,(keep,cb),cbo)) tac @@ -1775,7 +1789,7 @@ and interp_atomic ist tac : unit Proofview.tactic = let env = Proofview.Goal.env gl in let sigma = project gl in let sigma,l = - List.fold_map begin fun sigma (c,(ipato,ipats),cls) -> + List.fold_left_map begin fun sigma (c,(ipato,ipats),cls) -> (* TODO: move sigma as a side-effect *) (* spiwack: the [*p] variants are for printing *) let cp = c in @@ -1789,7 +1803,7 @@ and interp_atomic ist tac : unit Proofview.tactic = in let l,lp = List.split l in let sigma,el = - Option.fold_map (interp_open_constr_with_bindings ist env) sigma el in + Option.fold_left_map (interp_open_constr_with_bindings ist env) sigma el in Tacticals.New.tclTHEN (Proofview.Unsafe.tclEVARS sigma) (name_atomic ~env (TacInductionDestruct(isrec,ev,(lp,el))) diff --git a/plugins/ltac/tacinterp.mli b/plugins/ltac/tacinterp.mli index 73e4f3d6a..c1ab2b4c4 100644 --- a/plugins/ltac/tacinterp.mli +++ b/plugins/ltac/tacinterp.mli @@ -54,6 +54,11 @@ val set_debug : debug_info -> unit (** Gives the state of debug *) val get_debug : unit -> debug_info +val type_uconstr : + ?flags:Pretyping.inference_flags -> + ?expected_type:Pretyping.typing_constraint -> + Geninterp.interp_sign -> Glob_term.closed_glob_constr -> constr Tactypes.delayed_open + (** Adds an interpretation function for extra generic arguments *) val interp_genarg : interp_sign -> glob_generic_argument -> Value.t Ftactic.t diff --git a/plugins/setoid_ring/Ring_tac.v b/plugins/setoid_ring/Ring_tac.v index fc02cef10..329fa0ee8 100644 --- a/plugins/setoid_ring/Ring_tac.v +++ b/plugins/setoid_ring/Ring_tac.v @@ -427,19 +427,37 @@ Tactic Notation "ring_simplify" constr_list(rl) "in" hyp(H):= let t := type of H in let g := fresh "goal" in set (g:= G); - generalize H;clear H; + generalize H; ring_lookup (PackRing Ring_simplify) [] rl t; - intro H; + (* + Correction of bug 1859: + we want to leave H at its initial position + this is obtained by adding a copy of H (H'), + move it just after H, remove H and finally + rename H into H' + *) + let H' := fresh "H" in + intro H'; + move H' after H; + clear H;rename H' into H; unfold g;clear g. -Tactic Notation - "ring_simplify" "["constr_list(lH)"]" constr_list(rl) "in" hyp(H):= +Tactic Notation "ring_simplify" "["constr_list(lH)"]" constr_list(rl) "in" hyp(H):= let G := Get_goal in let t := type of H in let g := fresh "goal" in set (g:= G); - generalize H;clear H; + generalize H; ring_lookup (PackRing Ring_simplify) [lH] rl t; - intro H; - unfold g;clear g. - + (* + Correction of bug 1859: + we want to leave H at its initial position + this is obtained by adding a copy of H (H'), + move it just after H, remove H and finally + rename H into H' + *) + let H' := fresh "H" in + intro H'; + move H' after H; + clear H;rename H' into H; + unfold g;clear g.
\ No newline at end of file diff --git a/plugins/setoid_ring/newring.ml b/plugins/setoid_ring/newring.ml index 0f996c65a..d0fe1f957 100644 --- a/plugins/setoid_ring/newring.ml +++ b/plugins/setoid_ring/newring.ml @@ -131,7 +131,7 @@ let closed_term_ast l = let l = List.map (fun gr -> ArgArg(Loc.tag gr)) l in TacFun([Name(Id.of_string"t")], TacML(Loc.tag (tacname, - [TacGeneric (Genarg.in_gen (Genarg.glbwit Stdarg.wit_constr) (CAst.make @@ GVar(Id.of_string"t"),None)); + [TacGeneric (Genarg.in_gen (Genarg.glbwit Stdarg.wit_constr) (DAst.make @@ GVar(Id.of_string"t"),None)); TacGeneric (Genarg.in_gen (Genarg.glbwit (Genarg.wit_list Stdarg.wit_ref)) l)]))) (* let _ = add_tacdef false ((Loc.ghost,Id.of_string"ring_closed_term" diff --git a/plugins/ssr/ssrbwd.ml b/plugins/ssr/ssrbwd.ml index cc0e86684..c29a1fe7c 100644 --- a/plugins/ssr/ssrbwd.ml +++ b/plugins/ssr/ssrbwd.ml @@ -42,10 +42,10 @@ let interp_agen ist gl ((goclr, _), (k, gc as c)) (clr, rcs) = | Some ghyps -> let clr' = snd (interp_hyps ist gl ghyps) @ clr in if k <> xNoFlag then clr', rcs' else - let open CAst in - match rc with - | { loc; v = GVar id } when not_section_id id -> SsrHyp (Loc.tag ?loc id) :: clr', rcs' - | { loc; v = GRef (VarRef id, _) } when not_section_id id -> + let loc = rc.CAst.loc in + match DAst.get rc with + | GVar id when not_section_id id -> SsrHyp (Loc.tag ?loc id) :: clr', rcs' + | GRef (VarRef id, _) when not_section_id id -> SsrHyp (Loc.tag ?loc id) :: clr', rcs' | _ -> clr', rcs' @@ -68,9 +68,8 @@ let pf_match = pf_apply (fun e s c t -> understand_tcc e s ~expected_type:t c) let apply_rconstr ?ist t gl = (* ppdebug(lazy(str"sigma@apply_rconstr=" ++ pr_evar_map None (project gl))); *) - let open CAst in - let n = match ist, t with - | None, { v = GVar id | GRef (VarRef id,_) } -> pf_nbargs gl (EConstr.mkVar id) + let n = match ist, DAst.get t with + | None, (GVar id | GRef (VarRef id,_)) -> pf_nbargs gl (EConstr.mkVar id) | Some ist, _ -> interp_nbargs ist gl t | _ -> anomaly "apply_rconstr without ist and not RVar" in let mkRlemma i = mkRApp t (mkRHoles i) in diff --git a/plugins/ssr/ssrcommon.ml b/plugins/ssr/ssrcommon.ml index 799e969ae..cf5fdf318 100644 --- a/plugins/ssr/ssrcommon.ml +++ b/plugins/ssr/ssrcommon.ml @@ -176,24 +176,26 @@ open Globnames open Misctypes open Decl_kinds -let mkRHole = CAst.make @@ GHole (Evar_kinds.InternalHole, IntroAnonymous, None) +let mkRHole = DAst.make @@ GHole (Evar_kinds.InternalHole, IntroAnonymous, None) let rec mkRHoles n = if n > 0 then mkRHole :: mkRHoles (n - 1) else [] -let rec isRHoles = function { CAst.v = GHole _ } :: cl -> isRHoles cl | cl -> cl = [] -let mkRApp f args = if args = [] then f else CAst.make @@ GApp (f, args) -let mkRVar id = CAst.make @@ GRef (VarRef id,None) -let mkRltacVar id = CAst.make @@ GVar (id) -let mkRCast rc rt = CAst.make @@ GCast (rc, CastConv rt) -let mkRType = CAst.make @@ GSort (GType []) -let mkRProp = CAst.make @@ GSort (GProp) -let mkRArrow rt1 rt2 = CAst.make @@ GProd (Anonymous, Explicit, rt1, rt2) -let mkRConstruct c = CAst.make @@ GRef (ConstructRef c,None) -let mkRInd mind = CAst.make @@ GRef (IndRef mind,None) -let mkRLambda n s t = CAst.make @@ GLambda (n, Explicit, s, t) +let rec isRHoles cl = match cl with +| [] -> true +| c :: l -> match DAst.get c with GHole _ -> isRHoles l | _ -> false +let mkRApp f args = if args = [] then f else DAst.make @@ GApp (f, args) +let mkRVar id = DAst.make @@ GRef (VarRef id,None) +let mkRltacVar id = DAst.make @@ GVar (id) +let mkRCast rc rt = DAst.make @@ GCast (rc, CastConv rt) +let mkRType = DAst.make @@ GSort (GType []) +let mkRProp = DAst.make @@ GSort (GProp) +let mkRArrow rt1 rt2 = DAst.make @@ GProd (Anonymous, Explicit, rt1, rt2) +let mkRConstruct c = DAst.make @@ GRef (ConstructRef c,None) +let mkRInd mind = DAst.make @@ GRef (IndRef mind,None) +let mkRLambda n s t = DAst.make @@ GLambda (n, Explicit, s, t) let rec mkRnat n = - if n <= 0 then CAst.make @@ GRef (Coqlib.glob_O, None) else - mkRApp (CAst.make @@ GRef (Coqlib.glob_S, None)) [mkRnat (n - 1)] + if n <= 0 then DAst.make @@ GRef (Coqlib.glob_O, None) else + mkRApp (DAst.make @@ GRef (Coqlib.glob_S, None)) [mkRnat (n - 1)] let glob_constr ist genv = function | _, Some ce -> @@ -710,7 +712,7 @@ let mkSsrRef name = try locate_reference (ssrqid name) with Not_found -> try locate_reference (ssrtopqid name) with Not_found -> CErrors.user_err (Pp.str "Small scale reflection library not loaded") -let mkSsrRRef name = (CAst.make @@ GRef (mkSsrRef name,None)), None +let mkSsrRRef name = (DAst.make @@ GRef (mkSsrRef name,None)), None let mkSsrConst name env sigma = EConstr.fresh_global env sigma (mkSsrRef name) let pf_mkSsrConst name gl = @@ -845,10 +847,10 @@ let pf_interp_ty ?(resolve_typeclasses=false) ist gl ty = let n_binders = ref 0 in let ty = match ty with | a, (t, None) -> - let rec force_type ty = CAst.(map (function + let rec force_type ty = DAst.(map (function | GProd (x, k, s, t) -> incr n_binders; GProd (x, k, s, force_type t) | GLetIn (x, v, oty, t) -> incr n_binders; GLetIn (x, v, oty, force_type t) - | _ -> (mkRCast ty mkRType).v)) ty in + | _ -> DAst.get (mkRCast ty mkRType))) ty in a, (force_type t, None) | _, (_, Some ty) -> let rec force_type ty = CAst.(map (function diff --git a/plugins/ssr/ssrequality.ml b/plugins/ssr/ssrequality.ml index ab6a60f4e..8b69c3435 100644 --- a/plugins/ssr/ssrequality.ml +++ b/plugins/ssr/ssrequality.ml @@ -129,7 +129,7 @@ let newssrcongrtac arg ist gl = let eq, gl = pf_fresh_global (Coqlib.build_coq_eq ()) gl in pf_saturate gl (EConstr.of_constr eq) 3 in tclMATCH_GOAL (equality, gl') (fun gl' -> fs gl' (List.assoc 0 eq_args)) - (fun ty -> congrtac (arg, Detyping.detype false [] (pf_env gl) (project gl) ty) ist) + (fun ty -> congrtac (arg, Detyping.detype Detyping.Now false [] (pf_env gl) (project gl) ty) ist) (fun () -> let lhs, gl' = mk_evar gl EConstr.mkProp in let rhs, gl' = mk_evar gl' EConstr.mkProp in let arrow = EConstr.mkArrow lhs (EConstr.Vars.lift 1 rhs) in diff --git a/plugins/ssr/ssrfwd.ml b/plugins/ssr/ssrfwd.ml index 8e6329a15..d01bdc1b9 100644 --- a/plugins/ssr/ssrfwd.ml +++ b/plugins/ssr/ssrfwd.ml @@ -184,9 +184,13 @@ let havetac ist mkt ct, mkt cty, mkt (mkCHole None), loc | _, (_, Some ct) -> mkt ct, mkt (mkCHole None), mkt (mkCHole None), None - | _, ({ loc; v = GCast (ct, CastConv cty) }, None) -> - mkl ct, mkl cty, mkl mkRHole, loc - | _, (t, None) -> mkl t, mkl mkRHole, mkl mkRHole, None in + | _, (t, None) -> + begin match DAst.get t with + | GCast (ct, CastConv cty) -> + mkl ct, mkl cty, mkl mkRHole, t.CAst.loc + | _ -> mkl t, mkl mkRHole, mkl mkRHole, None + end + in let gl, cut, sol, itac1, itac2 = match fk, namefst, suff with | FwdHave, true, true -> @@ -323,11 +327,18 @@ let wlogtac ist (((clr0, pats),_),_) (gens, ((_, ct))) hint suff ghave gl = let mkpats = function | _, Some ((x, _), _) -> fun pats -> IPatId (hoi_id x) :: pats | _ -> fun x -> x in - let open CAst in let ct = match ct with - | (a, (b, Some { v = CCast (_, CastConv cty)})) -> a, (b, Some cty) - | (a, ({ v = GCast (_, CastConv cty) }, None)) -> a, (cty, None) - | _ -> anomaly "wlog: ssr cast hole deleted by typecheck" in + | (a, (b, Some ct)) -> + begin match ct.CAst.v with + | CCast (_, CastConv cty) -> a, (b, Some cty) + | _ -> anomaly "wlog: ssr cast hole deleted by typecheck" + end + | (a, (t, None)) -> + begin match DAst.get t with + | GCast (_, CastConv cty) -> a, (cty, None) + | _ -> anomaly "wlog: ssr cast hole deleted by typecheck" + end + in let cut_implies_goal = not (suff || ghave <> `NoGen) in let c, args, ct, gl = let gens = List.filter (function _, Some _ -> true | _ -> false) gens in @@ -398,11 +409,18 @@ let wlogtac ist (((clr0, pats),_),_) (gens, ((_, ct))) hint suff ghave gl = let sufftac ist ((((clr, pats),binders),simpl), ((_, c), hint)) = let htac = Tacticals.tclTHEN (introstac ~ist pats) (hinttac ist true hint) in - let open CAst in let c = match c with - | (a, (b, Some { v = CCast (_, CastConv cty)})) -> a, (b, Some cty) - | (a, ({ v = GCast (_, CastConv cty) }, None)) -> a, (cty, None) - | _ -> anomaly "suff: ssr cast hole deleted by typecheck" in + | (a, (b, Some ct)) -> + begin match ct.CAst.v with + | CCast (_, CastConv cty) -> a, (b, Some cty) + | _ -> anomaly "suff: ssr cast hole deleted by typecheck" + end + | (a, (t, None)) -> + begin match DAst.get t with + | GCast (_, CastConv cty) -> a, (cty, None) + | _ -> anomaly "suff: ssr cast hole deleted by typecheck" + end + in let ctac gl = let _,ty,_,uc = pf_interp_ty ist gl c in let gl = pf_merge_uc uc gl in basecuttac "ssr_suff" ty gl in diff --git a/plugins/ssr/ssrparser.ml4 b/plugins/ssr/ssrparser.ml4 index ce23bb2b3..060225dab 100644 --- a/plugins/ssr/ssrparser.ml4 +++ b/plugins/ssr/ssrparser.ml4 @@ -62,7 +62,7 @@ DECLARE PLUGIN "ssreflect_plugin" * we thus save the lexer to restore it at the end of the file *) let frozen_lexer = CLexer.get_keyword_state () ;; -let tacltop = (5,Ppextend.E) +let tacltop = (5,Notation_term.E) let pr_ssrtacarg _ _ prt = prt tacltop ARGUMENT EXTEND ssrtacarg TYPED AS tactic PRINTED BY pr_ssrtacarg @@ -342,7 +342,7 @@ let interp_index ist gl idx = | None -> begin match Tacinterp.Value.to_constr v with | Some c -> - let rc = Detyping.detype false [] (pf_env gl) (project gl) c in + let rc = Detyping.detype Detyping.Now false [] (pf_env gl) (project gl) c in begin match Notation.uninterp_prim_token rc with | _, Constrexpr.Numeral (s,b) -> let n = int_of_string s in if b then n else -n @@ -1062,32 +1062,32 @@ let rec format_glob_decl h0 d0 = match h0, d0 with Bdef (x, None, v) :: format_glob_decl [] d | _, [] -> [] -let rec format_glob_constr h0 c0 = let open CAst in match h0, c0 with - | BFvar :: h, { v = GLambda (x, _, _, c) } -> +let rec format_glob_constr h0 c0 = match h0, DAst.get c0 with + | BFvar :: h, GLambda (x, _, _, c) -> let bs, c' = format_glob_constr h c in Bvar x :: bs, c' - | BFdecl 1 :: h, { v = GLambda (x, _, t, c) } -> + | BFdecl 1 :: h, GLambda (x, _, t, c) -> let bs, c' = format_glob_constr h c in Bdecl ([x], t) :: bs, c' - | BFdecl n :: h, { v = GLambda (x, _, t, c) } when n > 1 -> + | BFdecl n :: h, GLambda (x, _, t, c) when n > 1 -> begin match format_glob_constr (BFdecl (n - 1) :: h) c with | Bdecl (xs, _) :: bs, c' -> Bdecl (x :: xs, t) :: bs, c' | _ -> [Bdecl ([x], t)], c end - | BFdef :: h, { v = GLetIn(x, v, oty, c) } -> + | BFdef :: h, GLetIn(x, v, oty, c) -> let bs, c' = format_glob_constr h c in Bdef (x, oty, v) :: bs, c' - | [BFcast], { v = GCast (c, CastConv t) } -> + | [BFcast], GCast (c, CastConv t) -> [Bcast t], c - | BFrec (has_str, has_cast) :: h, { v = GRec (f, _, bl, t, c) } + | BFrec (has_str, has_cast) :: h, GRec (f, _, bl, t, c) when Array.length c = 1 -> let bs = format_glob_decl h bl.(0) in let bstr = match has_str, f with | true, GFix ([|Some i, GStructRec|], _) -> mkBstruct i bs | _ -> [] in bs @ bstr @ (if has_cast then [Bcast t.(0)] else []), c.(0) - | _, c -> - [], c + | _, _ -> + [], c0 (** Forward chaining argument *) diff --git a/plugins/ssr/ssrparser.mli b/plugins/ssr/ssrparser.mli index 88beeaa71..f9dc345e1 100644 --- a/plugins/ssr/ssrparser.mli +++ b/plugins/ssr/ssrparser.mli @@ -10,11 +10,11 @@ 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 -> (int * Ppextend.parenRelation -> 'c) -> 'c +val pr_ssrtacarg : 'a -> 'b -> (Notation_term.tolerability -> 'c) -> 'c val ssrtclarg : Tacexpr.raw_tactic_expr Pcoq.Gram.entry val wit_ssrtclarg : (Tacexpr.raw_tactic_expr, Tacexpr.glob_tactic_expr, Geninterp.Val.t) Genarg.genarg_type -val pr_ssrtclarg : 'a -> 'b -> (int * Ppextend.parenRelation -> 'c -> 'd) -> 'c -> 'd +val pr_ssrtclarg : 'a -> 'b -> (Notation_term.tolerability -> 'c -> 'd) -> 'c -> 'd val add_genarg : string -> ('a -> Pp.t) -> 'a Genarg.uniform_genarg_type diff --git a/plugins/ssr/ssrvernac.ml4 b/plugins/ssr/ssrvernac.ml4 index 9c59d83d4..507b4631b 100644 --- a/plugins/ssr/ssrvernac.ml4 +++ b/plugins/ssr/ssrvernac.ml4 @@ -292,7 +292,7 @@ let interp_search_notation ?loc tag okey = err (pr_ntn ntn ++ str " is an n-ary notation"); let nvars = List.filter (fun (_,(_,typ)) -> typ = NtnTypeConstr) nvars in let rec sub () = function - | NVar x when List.mem_assoc x nvars -> CAst.make ?loc @@ GPatVar (FirstOrderPatVar x) + | NVar x when List.mem_assoc x nvars -> DAst.make ?loc @@ GPatVar (FirstOrderPatVar x) | c -> glob_constr_of_notation_constr_with_binders ?loc (fun _ x -> (), x) sub () c in let _, npat = Patternops.pattern_of_glob_constr (sub () body) in @@ -467,10 +467,10 @@ let pr_raw_ssrhintref prc _ _ = let open CAst in function prc c ++ str "|" ++ int (List.length args) | c -> prc c -let pr_rawhintref = let open CAst in function - | { v = GApp (f, args) } when isRHoles args -> +let pr_rawhintref c = match DAst.get c with + | GApp (f, args) when isRHoles args -> pr_glob_constr f ++ str "|" ++ int (List.length args) - | c -> pr_glob_constr c + | _ -> pr_glob_constr c let pr_glob_ssrhintref _ _ _ (c, _) = pr_rawhintref c diff --git a/plugins/ssr/ssrview.ml b/plugins/ssr/ssrview.ml index 338ecccc2..61b65e347 100644 --- a/plugins/ssr/ssrview.ml +++ b/plugins/ssr/ssrview.ml @@ -59,13 +59,13 @@ let glob_view_hints lvh = let add_view_hints lvh i = Lib.add_anonymous_leaf (in_viewhint (i, lvh)) -let interp_view ist si env sigma gv v rid = - let open CAst in - match v with - | { v = GApp ( { v = GHole _ } , rargs); loc } -> - let rv = make ?loc @@ GApp (rid, rargs) in +let interp_view ist si env sigma gv rv rid = + match DAst.get rv with + | GApp (h, rargs) when (match DAst.get h with GHole _ -> true | _ -> false) -> + let loc = rv.CAst.loc in + let rv = DAst.make ?loc @@ GApp (rid, rargs) in snd (interp_open_constr ist (re_sig si sigma) (rv, None)) - | rv -> + | _ -> let interp rc rargs = interp_open_constr ist (re_sig si sigma) (mkRApp rc rargs, None) in let rec simple_view rargs n = diff --git a/plugins/ssrmatching/ssrmatching.ml4 b/plugins/ssrmatching/ssrmatching.ml4 index f6300ab7e..2e5522b83 100644 --- a/plugins/ssrmatching/ssrmatching.ml4 +++ b/plugins/ssrmatching/ssrmatching.ml4 @@ -134,6 +134,10 @@ let dC t = CastConv t let isCVar = function { CAst.v = CRef (Ident _, _) } -> true | _ -> false let destCVar = function { CAst.v = CRef (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) + | _ -> CErrors.anomaly (str "not a GLambda") +let isGHole c = match DAst.get c with GHole _ -> true | _ -> false let mkCHole ~loc = CAst.make ?loc @@ CHole (None, IntroAnonymous, None) let mkCLambda ?loc name ty t = CAst.make ?loc @@ CLambdaN ([[Loc.tag ?loc name], Default Explicit, ty], t) @@ -141,10 +145,10 @@ let mkCLetIn ?loc name bo t = CAst.make ?loc @@ CLetIn ((Loc.tag ?loc name), bo, None, t) let mkCCast ?loc t ty = CAst.make ?loc @@ CCast (t, dC ty) (** Constructors for rawconstr *) -let mkRHole = CAst.make @@ GHole (InternalHole, IntroAnonymous, None) -let mkRApp f args = if args = [] then f else CAst.make @@ GApp (f, args) -let mkRCast rc rt = CAst.make @@ GCast (rc, dC rt) -let mkRLambda n s t = CAst.make @@ GLambda (n, Explicit, s, t) +let mkRHole = DAst.make @@ GHole (InternalHole, IntroAnonymous, None) +let mkRApp f args = if args = [] then f else DAst.make @@ GApp (f, args) +let mkRCast rc rt = DAst.make @@ GCast (rc, dC rt) +let mkRLambda n s t = DAst.make @@ GLambda (n, Explicit, s, t) (* ssrterm conbinators *) let combineCG t1 t2 f g = match t1, t2 with @@ -980,11 +984,10 @@ let pr_rpattern = pr_pattern type pattern = Evd.evar_map * (constr, constr) ssrpattern - -let id_of_cpattern = let open CAst in function - | _,(_,Some { v = CRef (Ident (_, x), _) } ) -> Some x - | _,(_,Some { v = CAppExpl ((_, Ident (_, x), _), []) } ) -> Some x - | _,({ v = GRef (VarRef x, _)} ,None) -> Some x +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 + | GRef (VarRef x, _), None -> Some x | _ -> None let id_of_Cterm t = match id_of_cpattern t with | Some x -> x @@ -1082,10 +1085,11 @@ let interp_pattern ?wit_ssrpatternarg ist gl red redty = let eAsXInT e x t = E_As_X_In_T(e,x,t) in let mkG ?(k=' ') x = k,(x,None) in let decode ist t ?reccall f g = - let open CAst in - try match (pf_intern_term ist gl t) with - | { v = GCast({ v = GHole _},CastConv({ v = GLambda(Name x,_,_,c)})) } -> f x (' ',(c,None)) - | { v = GVar id } + try match DAst.get (pf_intern_term ist gl t) with + | GCast(t,CastConv c) when isGHole t && isGLambda c-> + let (x, c) = destGLambda c in + f x (' ',(c,None)) + | GVar id when Id.Map.mem id ist.lfun && not(Option.is_empty reccall) && not(Option.is_empty wit_ssrpatternarg) -> @@ -1126,19 +1130,27 @@ let interp_pattern ?wit_ssrpatternarg ist gl red redty = thin name sigma e) sigma new_evars in sigma in - let red = let rec decode_red (ist,red) = let open CAst in match red with - | T(k,({ v = GCast ({ v = GHole _ },CastConv({ v = GLambda (Name id,_,_,t)}))},None)) - when let id = Id.to_string id in let len = String.length id in + let red = let rec decode_red (ist,red) = match red with + | T(k,(t,None)) -> + begin match DAst.get t with + | GCast (c,CastConv t) + when isGHole c && + let (id, t) = destGLambda t in + let id = Id.to_string id in let len = String.length id in (len > 8 && String.sub id 0 8 = "_ssrpat_") -> + let (id, t) = destGLambda t in let id = Id.to_string id in let len = String.length id in - (match String.sub id 8 (len - 8), t with - | "In", { v = GApp( _, [t]) } -> decodeG t xInT (fun x -> T x) - | "In", { v = GApp( _, [e; t]) } -> decodeG t (eInXInT (mkG e)) (bad_enc id) - | "In", { v = GApp( _, [e; t; e_in_t]) } -> + (match String.sub id 8 (len - 8), DAst.get t with + | "In", GApp( _, [t]) -> decodeG t xInT (fun x -> T x) + | "In", GApp( _, [e; t]) -> decodeG t (eInXInT (mkG e)) (bad_enc id) + | "In", GApp( _, [e; t; e_in_t]) -> decodeG t (eInXInT (mkG e)) (fun _ -> decodeG e_in_t xInT (fun _ -> assert false)) - | "As", { v = GApp(_, [e; t]) } -> decodeG t (eAsXInT (mkG e)) (bad_enc id) + | "As", GApp(_, [e; t]) -> decodeG t (eAsXInT (mkG e)) (bad_enc id) | _ -> bad_enc id ()) + | _ -> + decode ist ~reccall:decode_red (k, (t, None)) xInT (fun x -> T x) + end | T t -> decode ist ~reccall:decode_red t xInT (fun x -> T x) | In_T t -> decode ist t inXInT inT | X_In_T (e,t) -> decode ist t (eInXInT e) (fun x -> xInT (id_of_Cterm e) x) @@ -1163,7 +1175,7 @@ let interp_pattern ?wit_ssrpatternarg ist gl red redty = pp(lazy(str"typed as: " ++ pr_pattern_w_ids red)); let mkXLetIn ?loc x (a,(g,c)) = match c with | Some b -> a,(g,Some (mkCLetIn ?loc x (mkCHole ~loc) b)) - | None -> a,(CAst.make ?loc @@ GLetIn (x, CAst.make ?loc @@ GHole (BinderType x, IntroAnonymous, None), None, g), None) in + | None -> a,(DAst.make ?loc @@ GLetIn (x, DAst.make ?loc @@ GHole (BinderType x, IntroAnonymous, None), None, g), None) in match red with | T t -> let sigma, t = interp_term ist gl t in sigma, T t | In_T t -> let sigma, t = interp_term ist gl t in sigma, In_T t @@ -1336,10 +1348,10 @@ let pf_fill_occ_term gl occ t = let cl,(_,t) = fill_occ_term env concl occ sigma0 t in cl, t -let cpattern_of_id id = ' ', (CAst.make @@ GRef (VarRef id, None), None) +let cpattern_of_id id = ' ', (DAst.make @@ GRef (VarRef id, None), None) -let is_wildcard : cpattern -> bool = function - | _,(_,Some { CAst.v = CHole _ } | { CAst.v = GHole _ } ,None) -> true +let is_wildcard ((_, (l, r)) : cpattern) : bool = match DAst.get l, r with + | _, Some { CAst.v = CHole _ } | GHole _, None -> true | _ -> false (* "ssrpattern" *) diff --git a/plugins/syntax/ascii_syntax.ml b/plugins/syntax/ascii_syntax.ml index c41ec39cb..b299ff853 100644 --- a/plugins/syntax/ascii_syntax.ml +++ b/plugins/syntax/ascii_syntax.ml @@ -25,6 +25,10 @@ let make_dir l = DirPath.make (List.rev_map Id.of_string l) let make_kn dir id = Globnames.encode_mind (make_dir dir) (Id.of_string id) let make_path dir id = Libnames.make_path (make_dir dir) (Id.of_string id) +let is_gr c gr = match DAst.get c with +| GRef (r, _) -> Globnames.eq_gr r gr +| _ -> false + let ascii_module = ["Coq";"Strings";"Ascii"] let ascii_path = make_path ascii_module "ascii" @@ -42,9 +46,9 @@ let interp_ascii ?loc p = let rec aux n p = if Int.equal n 0 then [] else let mp = p mod 2 in - (CAst.make ?loc @@ GRef ((if Int.equal mp 0 then glob_false else glob_true),None)) + (DAst.make ?loc @@ GRef ((if Int.equal mp 0 then glob_false else glob_true),None)) :: (aux (n-1) (p/2)) in - CAst.make ?loc @@ GApp (CAst.make ?loc @@ GRef(force glob_Ascii,None), aux 8 p) + DAst.make ?loc @@ GApp (DAst.make ?loc @@ GRef(force glob_Ascii,None), aux 8 p) let interp_ascii_string ?loc s = let p = @@ -60,12 +64,12 @@ let interp_ascii_string ?loc s = let uninterp_ascii r = let rec uninterp_bool_list n = function | [] when Int.equal n 0 -> 0 - | { CAst.v = GRef (k,_)}::l when Globnames.eq_gr k glob_true -> 1+2*(uninterp_bool_list (n-1) l) - | { CAst.v = GRef (k,_)}::l when Globnames.eq_gr k glob_false -> 2*(uninterp_bool_list (n-1) l) + | r::l when is_gr r glob_true -> 1+2*(uninterp_bool_list (n-1) l) + | r::l when is_gr r glob_false -> 2*(uninterp_bool_list (n-1) l) | _ -> raise Non_closed_ascii in try - let aux = function - | { CAst.v = GApp ({ CAst.v = GRef (k,_)},l) } when Globnames.eq_gr k (force glob_Ascii) -> uninterp_bool_list 8 l + let aux c = match DAst.get c with + | GApp (r, l) when is_gr r (force glob_Ascii) -> uninterp_bool_list 8 l | _ -> raise Non_closed_ascii in Some (aux r) with @@ -75,10 +79,10 @@ let make_ascii_string n = if n>=32 && n<=126 then String.make 1 (char_of_int n) else Printf.sprintf "%03d" n -let uninterp_ascii_string r = Option.map make_ascii_string (uninterp_ascii r) +let uninterp_ascii_string (AnyGlobConstr r) = Option.map make_ascii_string (uninterp_ascii r) let _ = Notation.declare_string_interpreter "char_scope" (ascii_path,ascii_module) interp_ascii_string - ([CAst.make @@ GRef (static_glob_Ascii,None)], uninterp_ascii_string, true) + ([DAst.make @@ GRef (static_glob_Ascii,None)], uninterp_ascii_string, true) diff --git a/plugins/syntax/int31_syntax.ml b/plugins/syntax/int31_syntax.ml index af64b1479..0dff047a3 100644 --- a/plugins/syntax/int31_syntax.ml +++ b/plugins/syntax/int31_syntax.ml @@ -23,6 +23,10 @@ open Glob_term let make_dir l = DirPath.make (List.rev_map Id.of_string l) let make_path dir id = Libnames.make_path (make_dir dir) (Id.of_string id) +let is_gr c gr = match DAst.get c with +| GRef (r, _) -> Globnames.eq_gr r gr +| _ -> false + let make_mind mp id = Names.MutInd.make2 mp (Label.make id) let make_mind_mpfile dir id = make_mind (ModPath.MPfile (make_dir dir)) id let make_mind_mpdot dir modname id = @@ -49,9 +53,9 @@ exception Non_closed (* parses a *non-negative* integer (from bigint.ml) into an int31 wraps modulo 2^31 *) let int31_of_pos_bigint ?loc n = - let ref_construct = CAst.make ?loc (GRef (int31_construct, None)) in - let ref_0 = CAst.make ?loc (GRef (int31_0, None)) in - let ref_1 = CAst.make ?loc (GRef (int31_1, None)) in + let ref_construct = DAst.make ?loc (GRef (int31_construct, None)) in + let ref_0 = DAst.make ?loc (GRef (int31_0, None)) in + let ref_1 = DAst.make ?loc (GRef (int31_1, None)) in let rec args counter n = if counter <= 0 then [] @@ -59,7 +63,7 @@ let int31_of_pos_bigint ?loc n = let (q,r) = div2_with_rest n in (if r then ref_1 else ref_0)::(args (counter-1) q) in - CAst.make ?loc (GApp (ref_construct, List.rev (args 31 n))) + DAst.make ?loc (GApp (ref_construct, List.rev (args 31 n))) let error_negative ?loc = CErrors.user_err ?loc ~hdr:"interp_int31" (Pp.str "int31 are only non-negative numbers.") @@ -76,15 +80,15 @@ let bigint_of_int31 = let rec args_parsing args cur = match args with | [] -> cur - | { CAst.v = GRef (b,_) }::l when eq_gr b int31_0 -> args_parsing l (mult_2 cur) - | { CAst.v = GRef (b,_) }::l when eq_gr b int31_1 -> args_parsing l (add_1 (mult_2 cur)) + | r::l when is_gr r int31_0 -> args_parsing l (mult_2 cur) + | r::l when is_gr r int31_1 -> args_parsing l (add_1 (mult_2 cur)) | _ -> raise Non_closed in - function - | { CAst.v = GApp ({ CAst.v = GRef (c, _) }, args) } when eq_gr c int31_construct -> args_parsing args zero + fun c -> match DAst.get c with + | GApp (r, args) when is_gr r int31_construct -> args_parsing args zero | _ -> raise Non_closed -let uninterp_int31 i = +let uninterp_int31 (AnyGlobConstr i) = try Some (bigint_of_int31 i) with Non_closed -> @@ -94,6 +98,6 @@ let uninterp_int31 i = let _ = Notation.declare_numeral_interpreter int31_scope (int31_path, int31_module) interp_int31 - ([CAst.make (GRef (int31_construct, None))], + ([DAst.make (GRef (int31_construct, None))], uninterp_int31, true) diff --git a/plugins/syntax/nat_syntax.ml b/plugins/syntax/nat_syntax.ml index 524a5c522..2f9870cf9 100644 --- a/plugins/syntax/nat_syntax.ml +++ b/plugins/syntax/nat_syntax.ml @@ -37,11 +37,11 @@ let warn_large_nat = let nat_of_int ?loc n = if is_pos_or_zero n then begin if less_than threshold n then warn_large_nat (); - let ref_O = CAst.make ?loc @@ GRef (glob_O, None) in - let ref_S = CAst.make ?loc @@ GRef (glob_S, None) in + let ref_O = DAst.make ?loc @@ GRef (glob_O, None) in + let ref_S = DAst.make ?loc @@ GRef (glob_S, None) in let rec mk_nat acc n = if n <> zero then - mk_nat (CAst.make ?loc @@ GApp (ref_S, [acc])) (sub_1 n) + mk_nat (DAst.make ?loc @@ GApp (ref_S, [acc])) (sub_1 n) else acc in @@ -56,13 +56,17 @@ let nat_of_int ?loc n = exception Non_closed_number -let rec int_of_nat x = CAst.with_val (function - | GApp ({ CAst.v = GRef (s,_) } ,[a]) when Globnames.eq_gr s glob_S -> add_1 (int_of_nat a) +let rec int_of_nat x = DAst.with_val (function + | GApp (r, [a]) -> + begin match DAst.get r with + | GRef (s,_) when Globnames.eq_gr s glob_S -> add_1 (int_of_nat a) + | _ -> raise Non_closed_number + end | GRef (z,_) when Globnames.eq_gr z glob_O -> zero | _ -> raise Non_closed_number ) x -let uninterp_nat p = +let uninterp_nat (AnyGlobConstr p) = try Some (int_of_nat p) with @@ -75,4 +79,4 @@ let _ = Notation.declare_numeral_interpreter "nat_scope" (nat_path,datatypes_module_name) nat_of_int - ([CAst.make @@ GRef (glob_S,None); CAst.make @@ GRef (glob_O,None)], uninterp_nat, true) + ([DAst.make @@ GRef (glob_S,None); DAst.make @@ GRef (glob_O,None)], uninterp_nat, true) diff --git a/plugins/syntax/r_syntax.ml b/plugins/syntax/r_syntax.ml index 06117de79..88ff38c6d 100644 --- a/plugins/syntax/r_syntax.ml +++ b/plugins/syntax/r_syntax.ml @@ -27,6 +27,10 @@ let binnums = ["Coq";"Numbers";"BinNums"] let make_dir l = DirPath.make (List.rev_map Id.of_string l) let make_path dir id = Libnames.make_path (make_dir dir) (Id.of_string id) +let is_gr c gr = match DAst.get c with +| GRef (r, _) -> Globnames.eq_gr r gr +| _ -> false + let positive_path = make_path binnums "positive" (* TODO: temporary hack *) @@ -42,13 +46,13 @@ let glob_xO = ConstructRef path_of_xO let glob_xH = ConstructRef path_of_xH let pos_of_bignat ?loc x = - let ref_xI = CAst.make @@ GRef (glob_xI, None) in - let ref_xH = CAst.make @@ GRef (glob_xH, None) in - let ref_xO = CAst.make @@ GRef (glob_xO, None) in + let ref_xI = DAst.make @@ GRef (glob_xI, None) in + let ref_xH = DAst.make @@ GRef (glob_xH, None) in + let ref_xO = DAst.make @@ GRef (glob_xO, None) in let rec pos_of x = match div2_with_rest x with - | (q,false) -> CAst.make @@ GApp (ref_xO,[pos_of q]) - | (q,true) when not (Bigint.equal q zero) -> CAst.make @@ GApp (ref_xI,[pos_of q]) + | (q,false) -> DAst.make @@ GApp (ref_xO,[pos_of q]) + | (q,true) when not (Bigint.equal q zero) -> DAst.make @@ GApp (ref_xI,[pos_of q]) | (q,true) -> ref_xH in pos_of x @@ -57,10 +61,10 @@ let pos_of_bignat ?loc x = (* Printing positive via scopes *) (**********************************************************************) -let rec bignat_of_pos = function - | { CAst.v = GApp ({ CAst.v = GRef (b,_)},[a]) } when Globnames.eq_gr b glob_xO -> mult_2(bignat_of_pos a) - | { CAst.v = GApp ({ CAst.v = GRef (b,_)},[a]) } when Globnames.eq_gr b glob_xI -> add_1(mult_2(bignat_of_pos a)) - | { CAst.v = GRef (a, _) } when Globnames.eq_gr a glob_xH -> Bigint.one +let rec bignat_of_pos c = match DAst.get c with + | GApp (r, [a]) when is_gr r glob_xO -> mult_2(bignat_of_pos a) + | GApp (r, [a]) when is_gr r glob_xI -> add_1(mult_2(bignat_of_pos a)) + | GRef (a, _) when Globnames.eq_gr a glob_xH -> Bigint.one | _ -> raise Non_closed_number (**********************************************************************) @@ -81,18 +85,18 @@ let z_of_int ?loc n = if not (Bigint.equal n zero) then let sgn, n = if is_pos_or_zero n then glob_POS, n else glob_NEG, Bigint.neg n in - CAst.make @@ GApp(CAst.make @@ GRef (sgn,None), [pos_of_bignat ?loc n]) + DAst.make @@ GApp(DAst.make @@ GRef (sgn,None), [pos_of_bignat ?loc n]) else - CAst.make @@ GRef (glob_ZERO, None) + DAst.make @@ GRef (glob_ZERO, None) (**********************************************************************) (* Printing Z via scopes *) (**********************************************************************) -let bigint_of_z = function - | { CAst.v = GApp ({ CAst.v = GRef (b,_)},[a]) } when Globnames.eq_gr b glob_POS -> bignat_of_pos a - | { CAst.v = GApp ({ CAst.v = GRef (b,_)},[a]) } when Globnames.eq_gr b glob_NEG -> Bigint.neg (bignat_of_pos a) - | { CAst.v = GRef (a, _) } when Globnames.eq_gr a glob_ZERO -> Bigint.zero +let bigint_of_z c = match DAst.get c with + | GApp (r,[a]) when is_gr r glob_POS -> bignat_of_pos a + | GApp (r,[a]) when is_gr r glob_NEG -> Bigint.neg (bignat_of_pos a) + | GRef (a, _) when Globnames.eq_gr a glob_ZERO -> Bigint.zero | _ -> raise Non_closed_number (**********************************************************************) @@ -108,18 +112,18 @@ let make_path dir id = Globnames.encode_con dir (Id.of_string id) let glob_IZR = ConstRef (make_path (make_dir rdefinitions) "IZR") let r_of_int ?loc z = - CAst.make @@ GApp (CAst.make @@ GRef(glob_IZR,None), [z_of_int ?loc z]) + DAst.make @@ GApp (DAst.make @@ GRef(glob_IZR,None), [z_of_int ?loc z]) (**********************************************************************) (* Printing R via scopes *) (**********************************************************************) -let bigint_of_r = function - | { CAst.v = GApp ({ CAst.v = GRef (o,_) }, [a]) } when Globnames.eq_gr o glob_IZR -> +let bigint_of_r c = match DAst.get c with + | GApp (r, [a]) when is_gr r glob_IZR -> bigint_of_z a | _ -> raise Non_closed_number -let uninterp_r p = +let uninterp_r (AnyGlobConstr p) = try Some (bigint_of_r p) with Non_closed_number -> @@ -128,6 +132,6 @@ let uninterp_r p = let _ = Notation.declare_numeral_interpreter "R_scope" (r_path,["Coq";"Reals";"Rdefinitions"]) r_of_int - ([CAst.make @@ GRef (glob_IZR, None)], + ([DAst.make @@ GRef (glob_IZR, None)], uninterp_r, false) diff --git a/plugins/syntax/string_syntax.ml b/plugins/syntax/string_syntax.ml index b7f13b040..cc82fc94c 100644 --- a/plugins/syntax/string_syntax.ml +++ b/plugins/syntax/string_syntax.ml @@ -31,25 +31,29 @@ let make_reference id = find_reference "String interpretation" string_module id let glob_String = lazy (make_reference "String") let glob_EmptyString = lazy (make_reference "EmptyString") +let is_gr c gr = match DAst.get c with +| GRef (r, _) -> Globnames.eq_gr r gr +| _ -> false + open Lazy let interp_string ?loc s = let le = String.length s in let rec aux n = - if n = le then CAst.make ?loc @@ GRef (force glob_EmptyString, None) else - CAst.make ?loc @@ GApp (CAst.make ?loc @@ GRef (force glob_String, None), + if n = le then DAst.make ?loc @@ GRef (force glob_EmptyString, None) else + DAst.make ?loc @@ GApp (DAst.make ?loc @@ GRef (force glob_String, None), [interp_ascii ?loc (int_of_char s.[n]); aux (n+1)]) in aux 0 -let uninterp_string r = +let uninterp_string (AnyGlobConstr r) = try let b = Buffer.create 16 in - let rec aux = function - | { CAst.v = GApp ({ CAst.v = GRef (k,_) },[a;s]) } when eq_gr k (force glob_String) -> + let rec aux c = match DAst.get c with + | GApp (k,[a;s]) when is_gr k (force glob_String) -> (match uninterp_ascii a with | Some c -> Buffer.add_char b (Char.chr c); aux s | _ -> raise Non_closed_string) - | { CAst.v = GRef (z,_) } when eq_gr z (force glob_EmptyString) -> + | GRef (z,_) when eq_gr z (force glob_EmptyString) -> Some (Buffer.contents b) | _ -> raise Non_closed_string @@ -61,6 +65,6 @@ let _ = Notation.declare_string_interpreter "string_scope" (string_path,["Coq";"Strings";"String"]) interp_string - ([CAst.make @@ GRef (static_glob_String,None); - CAst.make @@ GRef (static_glob_EmptyString,None)], + ([DAst.make @@ GRef (static_glob_String,None); + DAst.make @@ GRef (static_glob_EmptyString,None)], uninterp_string, true) diff --git a/plugins/syntax/z_syntax.ml b/plugins/syntax/z_syntax.ml index af3df2889..0d743a2b5 100644 --- a/plugins/syntax/z_syntax.ml +++ b/plugins/syntax/z_syntax.ml @@ -45,13 +45,13 @@ let glob_xO = ConstructRef path_of_xO let glob_xH = ConstructRef path_of_xH let pos_of_bignat ?loc x = - let ref_xI = CAst.make ?loc @@ GRef (glob_xI, None) in - let ref_xH = CAst.make ?loc @@ GRef (glob_xH, None) in - let ref_xO = CAst.make ?loc @@ GRef (glob_xO, None) in + let ref_xI = DAst.make ?loc @@ GRef (glob_xI, None) in + let ref_xH = DAst.make ?loc @@ GRef (glob_xH, None) in + let ref_xO = DAst.make ?loc @@ GRef (glob_xO, None) in let rec pos_of x = match div2_with_rest x with - | (q,false) -> CAst.make ?loc @@ GApp (ref_xO,[pos_of q]) - | (q,true) when not (Bigint.equal q zero) -> CAst.make ?loc @@ GApp (ref_xI,[pos_of q]) + | (q,false) -> DAst.make ?loc @@ GApp (ref_xO,[pos_of q]) + | (q,true) when not (Bigint.equal q zero) -> DAst.make ?loc @@ GApp (ref_xI,[pos_of q]) | (q,true) -> ref_xH in pos_of x @@ -68,14 +68,18 @@ let interp_positive ?loc n = (* Printing positive via scopes *) (**********************************************************************) -let rec bignat_of_pos x = CAst.with_val (function - | GApp ({ CAst.v = GRef (b,_) },[a]) when Globnames.eq_gr b glob_xO -> mult_2(bignat_of_pos a) - | GApp ({ CAst.v = GRef (b,_) },[a]) when Globnames.eq_gr b glob_xI -> add_1(mult_2(bignat_of_pos a)) +let is_gr c gr = match DAst.get c with +| GRef (r, _) -> Globnames.eq_gr r gr +| _ -> false + +let rec bignat_of_pos x = DAst.with_val (function + | GApp (r ,[a]) when is_gr r glob_xO -> mult_2(bignat_of_pos a) + | GApp (r ,[a]) when is_gr r glob_xI -> add_1(mult_2(bignat_of_pos a)) | GRef (a, _) when Globnames.eq_gr a glob_xH -> Bigint.one | _ -> raise Non_closed_number ) x -let uninterp_positive p = +let uninterp_positive (AnyGlobConstr p) = try Some (bignat_of_pos p) with Non_closed_number -> @@ -88,9 +92,9 @@ let uninterp_positive p = let _ = Notation.declare_numeral_interpreter "positive_scope" (positive_path,binnums) interp_positive - ([CAst.make @@ GRef (glob_xI, None); - CAst.make @@ GRef (glob_xO, None); - CAst.make @@ GRef (glob_xH, None)], + ([DAst.make @@ GRef (glob_xI, None); + DAst.make @@ GRef (glob_xO, None); + DAst.make @@ GRef (glob_xH, None)], uninterp_positive, true) @@ -107,9 +111,9 @@ let glob_Npos = ConstructRef path_of_Npos let n_path = make_path binnums "N" -let n_of_binnat ?loc pos_or_neg n = CAst.make ?loc @@ +let n_of_binnat ?loc pos_or_neg n = DAst.make ?loc @@ if not (Bigint.equal n zero) then - GApp(CAst.make @@ GRef (glob_Npos,None), [pos_of_bignat ?loc n]) + GApp(DAst.make @@ GRef (glob_Npos,None), [pos_of_bignat ?loc n]) else GRef(glob_N0, None) @@ -124,13 +128,13 @@ let n_of_int ?loc n = (* Printing N via scopes *) (**********************************************************************) -let bignat_of_n = CAst.with_val (function - | GApp ({ CAst.v = GRef (b,_)},[a]) when Globnames.eq_gr b glob_Npos -> bignat_of_pos a +let bignat_of_n n = DAst.with_val (function + | GApp (r, [a]) when is_gr r glob_Npos -> bignat_of_pos a | GRef (a,_) when Globnames.eq_gr a glob_N0 -> Bigint.zero | _ -> raise Non_closed_number - ) + ) n -let uninterp_n p = +let uninterp_n (AnyGlobConstr p) = try Some (bignat_of_n p) with Non_closed_number -> None @@ -140,8 +144,8 @@ let uninterp_n p = let _ = Notation.declare_numeral_interpreter "N_scope" (n_path,binnums) n_of_int - ([CAst.make @@ GRef (glob_N0, None); - CAst.make @@ GRef (glob_Npos, None)], + ([DAst.make @@ GRef (glob_N0, None); + DAst.make @@ GRef (glob_Npos, None)], uninterp_n, true) @@ -163,22 +167,22 @@ let z_of_int ?loc n = if not (Bigint.equal n zero) then let sgn, n = if is_pos_or_zero n then glob_POS, n else glob_NEG, Bigint.neg n in - CAst.make ?loc @@ GApp(CAst.make ?loc @@ GRef(sgn,None), [pos_of_bignat ?loc n]) + DAst.make ?loc @@ GApp(DAst.make ?loc @@ GRef(sgn,None), [pos_of_bignat ?loc n]) else - CAst.make ?loc @@ GRef(glob_ZERO, None) + DAst.make ?loc @@ GRef(glob_ZERO, None) (**********************************************************************) (* Printing Z via scopes *) (**********************************************************************) -let bigint_of_z = CAst.with_val (function - | GApp ({ CAst.v = GRef (b,_)},[a]) when Globnames.eq_gr b glob_POS -> bignat_of_pos a - | GApp ({ CAst.v = GRef (b,_)},[a]) when Globnames.eq_gr b glob_NEG -> Bigint.neg (bignat_of_pos a) +let bigint_of_z z = DAst.with_val (function + | GApp (r, [a]) when is_gr r glob_POS -> bignat_of_pos a + | GApp (r, [a]) when is_gr r glob_NEG -> Bigint.neg (bignat_of_pos a) | GRef (a, _) when Globnames.eq_gr a glob_ZERO -> Bigint.zero | _ -> raise Non_closed_number - ) + ) z -let uninterp_z p = +let uninterp_z (AnyGlobConstr p) = try Some (bigint_of_z p) with Non_closed_number -> None @@ -189,8 +193,8 @@ let uninterp_z p = let _ = Notation.declare_numeral_interpreter "Z_scope" (z_path,binnums) z_of_int - ([CAst.make @@ GRef (glob_ZERO, None); - CAst.make @@ GRef (glob_POS, None); - CAst.make @@ GRef (glob_NEG, None)], + ([DAst.make @@ GRef (glob_ZERO, None); + DAst.make @@ GRef (glob_POS, None); + DAst.make @@ GRef (glob_NEG, None)], uninterp_z, true) diff --git a/pretyping/cases.ml b/pretyping/cases.ml index 49f073d66..7455587c0 100644 --- a/pretyping/cases.ml +++ b/pretyping/cases.ml @@ -94,7 +94,7 @@ let msg_may_need_inversion () = (* Utils *) let make_anonymous_patvars n = - List.make n (CAst.make @@ PatVar Anonymous) + List.make n (DAst.make @@ PatVar Anonymous) (* We have x1:t1...xn:tn,xi':ti,y1..yk |- c and re-generalize over xi:ti to get x1:t1...xn:tn,xi':ti,y1..yk |- c[xi:=xi'] *) @@ -177,7 +177,7 @@ and build_glob_pattern args = function | Top -> args | MakeConstructor (pci, rh) -> glob_pattern_of_partial_history - [CAst.make @@ PatCstr (pci, args, Anonymous)] rh + [DAst.make @@ PatCstr (pci, args, Anonymous)] rh let complete_history = glob_pattern_of_partial_history [] @@ -187,12 +187,12 @@ let pop_history_pattern = function | Continuation (0, l, Top) -> Result (List.rev l) | Continuation (0, l, MakeConstructor (pci, rh)) -> - feed_history (CAst.make @@ PatCstr (pci,List.rev l,Anonymous)) rh + feed_history (DAst.make @@ PatCstr (pci,List.rev l,Anonymous)) rh | _ -> anomaly (Pp.str "Constructor not yet filled with its arguments.") let pop_history h = - feed_history (CAst.make @@ PatVar Anonymous) h + feed_history (DAst.make @@ PatVar Anonymous) h (* Builds a continuation expecting [n] arguments and building [ci] applied to this [n] arguments *) @@ -273,8 +273,10 @@ type 'a pattern_matching_problem = let rec find_row_ind = function [] -> None - | { CAst.v = PatVar _ } :: l -> find_row_ind l - | { CAst.v = PatCstr(c,_,_) ; loc } :: _ -> Some (loc,c) + | p :: l -> + match DAst.get p with + | PatVar _ -> find_row_ind l + | PatCstr(c,_,_) -> Some (p.CAst.loc,c) let inductive_template evdref env tmloc ind = let indu = evd_comb1 (Evd.fresh_inductive_instance env) evdref ind in @@ -348,7 +350,7 @@ let find_tomatch_tycon evdref env loc = function empty_tycon,None let make_return_predicate_ltac_lvar sigma na tm c lvar = - match na, tm.CAst.v with + match na, DAst.get tm with | Name id, (GVar id' | GRef (Globnames.VarRef id', _)) when Id.equal id id' -> if Id.Map.mem id lvar.ltac_genargs then let ltac_genargs = Id.Map.remove id lvar.ltac_genargs in @@ -447,7 +449,7 @@ let current_pattern eqn = | pat::_ -> pat | [] -> anomaly (Pp.str "Empty list of patterns.") -let alias_of_pat = CAst.with_val (function +let alias_of_pat = DAst.with_val (function | PatVar name -> name | PatCstr(_,_,name) -> name ) @@ -493,13 +495,14 @@ let rec adjust_local_defs ?loc = function | (pat :: pats, LocalAssum _ :: decls) -> pat :: adjust_local_defs ?loc (pats,decls) | (pats, LocalDef _ :: decls) -> - (CAst.make ?loc @@ PatVar Anonymous) :: adjust_local_defs ?loc (pats,decls) + (DAst.make ?loc @@ PatVar Anonymous) :: adjust_local_defs ?loc (pats,decls) | [], [] -> [] | _ -> raise NotAdjustable -let check_and_adjust_constructor env ind cstrs = function - | { CAst.v = PatVar _ } as pat -> pat - | { CAst.v = PatCstr (((_,i) as cstr),args,alias) ; loc } as pat -> +let check_and_adjust_constructor env ind cstrs pat = match DAst.get pat with + | PatVar _ -> pat + | PatCstr (((_,i) as cstr),args,alias) -> + let loc = pat.CAst.loc in (* Check it is constructor of the right type *) let ind' = inductive_of_constructor cstr in if eq_ind ind' ind then @@ -510,7 +513,7 @@ let check_and_adjust_constructor env ind cstrs = function else try let args' = adjust_local_defs ?loc (args, List.rev ci.cs_args) - in CAst.make ?loc @@ PatCstr (cstr, args', alias) + in DAst.make ?loc @@ PatCstr (cstr, args', alias) with NotAdjustable -> error_wrong_numarg_constructor ?loc env cstr nb_args_constr else @@ -522,9 +525,12 @@ let check_and_adjust_constructor env ind cstrs = function let check_all_variables env sigma typ mat = List.iter - (fun eqn -> match current_pattern eqn with - | { CAst.v = PatVar id } -> () - | { CAst.v = PatCstr (cstr_sp,_,_); loc } -> + (fun eqn -> + let pat = current_pattern eqn in + match DAst.get pat with + | PatVar id -> () + | PatCstr (cstr_sp,_,_) -> + let loc = pat.CAst.loc in error_bad_pattern ?loc env sigma cstr_sp typ) mat @@ -549,9 +555,9 @@ let occur_in_rhs na rhs = | Anonymous -> false | Name id -> Id.List.mem id rhs.rhs_vars -let is_dep_patt_in eqn = function - | { CAst.v = PatVar name } -> Flags.is_program_mode () || occur_in_rhs name eqn.rhs - | { CAst.v = PatCstr _ } -> true +let is_dep_patt_in eqn pat = match DAst.get pat with + | PatVar name -> Flags.is_program_mode () || occur_in_rhs name eqn.rhs + | PatCstr _ -> true let mk_dep_patt_row (pats,_,eqn) = List.map (is_dep_patt_in eqn) pats @@ -771,7 +777,7 @@ let recover_and_adjust_alias_names names sign = | x::names, LocalAssum (_,t)::sign -> (x, LocalAssum (alias_of_pat x,t)) :: aux (names,sign) | names, (LocalDef (na,_,_) as decl)::sign -> - (CAst.make @@ PatVar na, decl) :: aux (names,sign) + (DAst.make @@ PatVar na, decl) :: aux (names,sign) | _ -> assert false in List.split (aux (names,sign)) @@ -987,7 +993,7 @@ let use_unit_judge evd = evd', j let add_assert_false_case pb tomatch = - let pats = List.map (fun _ -> CAst.make @@ PatVar Anonymous) tomatch in + let pats = List.map (fun _ -> DAst.make @@ PatVar Anonymous) tomatch in let aliasnames = List.map_filter (function Alias _ | NonDepAlias -> Some Anonymous | _ -> None) tomatch in @@ -1184,9 +1190,9 @@ let postprocess_dependencies evd tocheck brs tomatch pred deps cs = (************************************************************************) (* Sorting equations by constructor *) -let rec irrefutable env = function - | { CAst.v = PatVar name } -> true - | { CAst.v = PatCstr (cstr,args,_) } -> +let rec irrefutable env pat = match DAst.get pat with + | PatVar name -> true + | PatCstr (cstr,args,_) -> let ind = inductive_of_constructor cstr in let (_,mip) = Inductive.lookup_mind_specif env ind in let one_constr = Int.equal (Array.length mip.mind_user_lc) 1 in @@ -1206,15 +1212,15 @@ let group_equations pb ind current cstrs mat = (fun eqn () -> let rest = remove_current_pattern eqn in let pat = current_pattern eqn in - match check_and_adjust_constructor pb.env ind cstrs pat with - | { CAst.v = PatVar name } -> + match DAst.get (check_and_adjust_constructor pb.env ind cstrs pat) with + | PatVar name -> (* This is a default clause that we expand *) for i=1 to Array.length cstrs do let args = make_anonymous_patvars cstrs.(i-1).cs_nargs in brs.(i-1) <- (args, name, rest) :: brs.(i-1) done; if !only_default == None then only_default := Some true - | { CAst.v = PatCstr (((_,i)),args,name) ; loc } -> + | PatCstr (((_,i)),args,name) -> (* This is a regular clause *) only_default := Some false; brs.(i-1) <- (args, name, rest) :: brs.(i-1)) mat () in @@ -1745,22 +1751,22 @@ let build_tycon ?loc env tycon_env s subst tycon extenv evdref t = let build_inversion_problem loc env sigma tms t = let make_patvar t (subst,avoid) = let id = next_name_away (named_hd env sigma t Anonymous) avoid in - CAst.make @@ PatVar (Name id), ((id,t)::subst, id::avoid) in + DAst.make @@ PatVar (Name id), ((id,t)::subst, id::avoid) in let rec reveal_pattern t (subst,avoid as acc) = match EConstr.kind sigma (whd_all env sigma t) with - | Construct (cstr,u) -> CAst.make (PatCstr (cstr,[],Anonymous)), acc + | Construct (cstr,u) -> DAst.make (PatCstr (cstr,[],Anonymous)), acc | App (f,v) when isConstruct sigma f -> let cstr,u = destConstruct sigma f in let n = constructor_nrealargs_env env cstr in let l = List.lastn n (Array.to_list v) in - let l,acc = List.fold_map' reveal_pattern l acc in - CAst.make (PatCstr (cstr,l,Anonymous)), acc + let l,acc = List.fold_right_map reveal_pattern l acc in + DAst.make (PatCstr (cstr,l,Anonymous)), acc | _ -> make_patvar t acc in let rec aux n env acc_sign tms acc = match tms with | [] -> [], acc_sign, acc | (t, IsInd (_,IndType(indf,realargs),_)) :: tms -> - let patl,acc = List.fold_map' reveal_pattern realargs acc in + let patl,acc = List.fold_right_map reveal_pattern realargs acc in let pat,acc = make_patvar t acc in let indf' = lift_inductive_family n indf in let sign = make_arity_signature env sigma true indf' in @@ -1830,7 +1836,7 @@ let build_inversion_problem loc env sigma tms t = (* No need for a catch all clause *) [] else - [ { patterns = List.map (fun _ -> CAst.make @@ PatVar Anonymous) patl; + [ { patterns = List.map (fun _ -> DAst.make @@ PatVar Anonymous) patl; alias_stack = []; eqn_loc = None; used = ref false; @@ -2094,14 +2100,14 @@ let mk_JMeq evdref typ x typ' y = let mk_JMeq_refl evdref typ x = papp evdref coq_JMeq_refl [| typ; x |] -let hole na = CAst.make @@ +let hole na = DAst.make @@ GHole (Evar_kinds.QuestionMark (Evar_kinds.Define false,na), Misctypes.IntroAnonymous, None) let constr_of_pat env evdref arsign pat avoid = let rec typ env (ty, realargs) pat avoid = let loc = pat.CAst.loc in - match pat.CAst.v with + match DAst.get pat with | PatVar name -> let name, avoid = match name with Name n -> name, avoid @@ -2109,7 +2115,7 @@ let constr_of_pat env evdref arsign pat avoid = let previd, id = prime avoid (Name (Id.of_string "wildcard")) in Name id, id :: avoid in - ((CAst.make ?loc @@ PatVar name), [LocalAssum (name, ty)] @ realargs, mkRel 1, ty, + ((DAst.make ?loc @@ PatVar name), [LocalAssum (name, ty)] @ realargs, mkRel 1, ty, (List.map (fun x -> mkRel 1) realargs), 1, avoid) | PatCstr (((_, i) as cstr),args,alias) -> let cind = inductive_of_constructor cstr in @@ -2140,7 +2146,7 @@ let constr_of_pat env evdref arsign pat avoid = in let args = List.rev args in let patargs = List.rev patargs in - let pat' = CAst.make ?loc @@ PatCstr (cstr, patargs, alias) in + let pat' = DAst.make ?loc @@ PatCstr (cstr, patargs, alias) in let cstr = mkConstructU (on_snd EInstance.make ci.cs_cstr) in let app = applist (cstr, List.map (lift (List.length sign)) params) in let app = applist (app, args) in @@ -2196,18 +2202,18 @@ let vars_of_ctx sigma ctx = match decl with | LocalDef (na,t',t) when is_topvar sigma t' -> prev, - (CAst.make @@ GApp ( - (CAst.make @@ GRef (delayed_force coq_eq_refl_ref, None)), - [hole na; CAst.make @@ GVar prev])) :: vars + (DAst.make @@ GApp ( + (DAst.make @@ GRef (delayed_force coq_eq_refl_ref, None)), + [hole na; DAst.make @@ GVar prev])) :: vars | _ -> match RelDecl.get_name decl with Anonymous -> invalid_arg "vars_of_ctx" - | Name n -> n, (CAst.make @@ GVar n) :: vars) + | Name n -> n, (DAst.make @@ GVar n) :: vars) ctx (Id.of_string "vars_of_ctx_error", []) in List.rev y let rec is_included x y = - match CAst.(x.v, y.v) with + match DAst.get x, DAst.get y with | PatVar _, _ -> true | _, PatVar _ -> true | PatCstr ((_, i), args, alias), PatCstr ((_, i'), args', alias') -> @@ -2325,13 +2331,13 @@ let constrs_of_pats typing_fun env evdref eqns tomatchs sign neqs arity = let branch_name = Id.of_string ("program_branch_" ^ (string_of_int !i)) in let branch_decl = LocalDef (Name branch_name, lift !i bbody, lift !i btype) in let branch = - let bref = CAst.make @@ GVar branch_name in + let bref = DAst.make @@ GVar branch_name in match vars_of_ctx !evdref rhs_rels with [] -> bref - | l -> CAst.make @@ GApp (bref, l) + | l -> DAst.make @@ GApp (bref, l) in let branch = match ineqs with - Some _ -> CAst.make @@ GApp (branch, [ hole Anonymous ]) + Some _ -> DAst.make @@ GApp (branch, [ hole Anonymous ]) | None -> branch in incr i; @@ -2501,14 +2507,14 @@ let compile_program_cases ?loc style (typing_function, evdref) tycon env lvar in let tycon, arity = + let nar = List.fold_left (fun n sign -> List.length sign + n) 0 sign in match tycon' with - | None -> let ev = mkExistential env evdref in ev, ev + | None -> let ev = mkExistential env evdref in ev, lift nar ev | Some t -> let pred = match prepare_predicate_from_arsign_tycon env !evdref loc tomatchs sign t with | Some (evd, pred) -> evdref := evd; pred | None -> - let nar = List.fold_left (fun n sign -> List.length sign + n) 0 sign in lift nar t in Option.get tycon, pred in diff --git a/pretyping/coercion.ml b/pretyping/coercion.ml index 535a62046..fc0a650bc 100644 --- a/pretyping/coercion.ml +++ b/pretyping/coercion.ml @@ -77,8 +77,8 @@ let apply_pattern_coercion ?loc pat p = List.fold_left (fun pat (co,n) -> let f i = - if i<n then (CAst.make ?loc @@ Glob_term.PatVar Anonymous) else pat in - CAst.make ?loc @@ Glob_term.PatCstr (co, List.init (n+1) f, Anonymous)) + if i<n then (DAst.make ?loc @@ Glob_term.PatVar Anonymous) else pat in + DAst.make ?loc @@ Glob_term.PatCstr (co, List.init (n+1) f, Anonymous)) pat p (* raise Not_found if no coercion found *) diff --git a/pretyping/detyping.ml b/pretyping/detyping.ml index a27debe73..1eb22cdb8 100644 --- a/pretyping/detyping.ml +++ b/pretyping/detyping.ml @@ -28,6 +28,10 @@ open Misctypes open Decl_kinds open Context.Named.Declaration +type _ delay = +| Now : 'a delay +| Later : [ `thunk ] delay + (** Should we keep details of universes during detyping ? *) let print_universes = Flags.univ_print @@ -277,7 +281,7 @@ let rec decomp_branch tags nal b (avoid,env as e) sigma c = (avoid', add_name_opt na' body t env) sigma c let rec build_tree na isgoal e sigma ci cl = - let mkpat n rhs pl = CAst.make @@ PatCstr((ci.ci_ind,n+1),pl,update_name sigma na rhs) in + let mkpat n rhs pl = DAst.make @@ PatCstr((ci.ci_ind,n+1),pl,update_name sigma na rhs) in let cnl = ci.ci_pp_info.cstr_tags in let cna = ci.ci_cstr_nargs in List.flatten @@ -300,7 +304,7 @@ and align_tree nal isgoal (e,c as rhs) sigma = match nal with List.map (fun (hd,rest) -> pat::hd,rest) lines) clauses) | _ -> - let pat = CAst.make @@ PatVar(update_name sigma na rhs) in + let pat = DAst.make @@ PatVar(update_name sigma na rhs) in let mat = align_tree nal isgoal rhs sigma in List.map (fun (hd,rest) -> pat::hd,rest) mat @@ -323,7 +327,7 @@ let is_nondep_branch sigma c l = let extract_nondep_branches test c b l = let rec strip l r = - match r.CAst.v, l with + match DAst.get r, l with | r', [] -> r | GLambda (_,_,_,t), false::l -> strip l t | GLetIn (_,_,_,t), true::l -> strip l t @@ -333,7 +337,7 @@ let extract_nondep_branches test c b l = let it_destRLambda_or_LetIn_names l c = let rec aux l nal c = - match c.CAst.v, l with + match DAst.get c, l with | _, [] -> (List.rev nal,c) | GLambda (na,_,_,c), false::l -> aux l (na::nal) c | GLetIn (na,_,_,c), true::l -> aux l (na::nal) c @@ -347,11 +351,11 @@ let it_destRLambda_or_LetIn_names l c = x in let x = next (free_glob_vars c) in - let a = CAst.make @@ GVar x in + let a = DAst.make @@ GVar x in aux l (Name x :: nal) - (match c with - | { loc; CAst.v = GApp (p,l) } -> CAst.make ?loc @@ GApp (p,l@[a]) - | _ -> CAst.make @@ GApp (c,[a])) + (match DAst.get c with + | GApp (p,l) -> DAst.make ?loc:c.CAst.loc @@ GApp (p,l@[a]) + | _ -> DAst.make @@ GApp (c,[a])) in aux l [] c let detype_case computable detype detype_eqns testdep avoid data p c bl = @@ -367,7 +371,7 @@ let detype_case computable detype detype_eqns testdep avoid data p c bl = | None -> Anonymous, None, None | Some p -> let nl,typ = it_destRLambda_or_LetIn_names k p in - let n,typ = match typ.CAst.v with + let n,typ = match DAst.get typ with | GLambda (x,_,t,c) -> x, c | _ -> Anonymous, typ in let aliastyp = @@ -437,12 +441,20 @@ let detype_instance sigma l = if Univ.Instance.is_empty l then None else Some (List.map (detype_level sigma) (Array.to_list (Univ.Instance.to_array l))) -let rec detype flags avoid env sigma t = CAst.make @@ +let delay (type a) (d : a delay) (f : a delay -> _ -> _ -> _ -> _ -> _ -> a glob_constr_r) flags env avoid sigma t : a glob_constr_g = + match d with + | Now -> DAst.make (f d flags env avoid sigma t) + | Later -> DAst.delay (fun () -> f d flags env avoid sigma t) + +let rec detype d flags avoid env sigma t = + delay d detype_r flags avoid env sigma t + +and detype_r d flags avoid env sigma t = match EConstr.kind sigma (collapse_appl sigma t) with | Rel n -> (try match lookup_name_of_rel n (fst env) with | Name id -> GVar id - | Anonymous -> (!detype_anonymous n).CAst.v + | Anonymous -> GVar (!detype_anonymous n) with Not_found -> let s = "_UNBOUND_REL_"^(string_of_int n) in GVar (Id.of_string s)) @@ -455,44 +467,44 @@ let rec detype flags avoid env sigma t = CAst.make @@ with Not_found -> GVar id) | Sort s -> GSort (detype_sort sigma (ESorts.kind sigma s)) | Cast (c1,REVERTcast,c2) when not !Flags.raw_print -> - (detype flags avoid env sigma c1).CAst.v + DAst.get (detype d flags avoid env sigma c1) | Cast (c1,k,c2) -> - let d1 = detype flags avoid env sigma c1 in - let d2 = detype flags avoid env sigma c2 in + let d1 = detype d flags avoid env sigma c1 in + let d2 = detype d flags avoid env sigma c2 in let cast = match k with | VMcast -> CastVM d2 | NATIVEcast -> CastNative d2 | _ -> CastConv d2 in GCast(d1,cast) - | Prod (na,ty,c) -> detype_binder flags BProd avoid env sigma na None ty c - | Lambda (na,ty,c) -> detype_binder flags BLambda avoid env sigma na None ty c - | LetIn (na,b,ty,c) -> detype_binder flags BLetIn avoid env sigma na (Some b) ty c + | Prod (na,ty,c) -> detype_binder d flags BProd avoid env sigma na None ty c + | Lambda (na,ty,c) -> detype_binder d flags BLambda avoid env sigma na None ty c + | LetIn (na,b,ty,c) -> detype_binder d flags BLetIn avoid env sigma na (Some b) ty c | App (f,args) -> let mkapp f' args' = - match f'.CAst.v with + match DAst.get f' with | GApp (f',args'') -> GApp (f',args''@args') | _ -> GApp (f',args') in - mkapp (detype flags avoid env sigma f) - (detype_array flags avoid env sigma args) + mkapp (detype d flags avoid env sigma f) + (Array.map_to_list (detype d flags avoid env sigma) args) | Const (sp,u) -> GRef (ConstRef sp, detype_instance sigma u) | Proj (p,c) -> let noparams () = let pb = Environ.lookup_projection p (snd env) in let pars = pb.Declarations.proj_npars in - let hole = CAst.make @@ GHole(Evar_kinds.InternalHole,Misctypes.IntroAnonymous,None) in + let hole = DAst.make @@ GHole(Evar_kinds.InternalHole,Misctypes.IntroAnonymous,None) in let args = List.make pars hole in - GApp (CAst.make @@ GRef (ConstRef (Projection.constant p), None), - (args @ [detype flags avoid env sigma c])) + GApp (DAst.make @@ GRef (ConstRef (Projection.constant p), None), + (args @ [detype d flags avoid env sigma c])) in if fst flags || !Flags.in_debugger || !Flags.in_toplevel then try noparams () with _ -> (* lax mode, used by debug printers only *) - GApp (CAst.make @@ GRef (ConstRef (Projection.constant p), None), - [detype flags avoid env sigma c]) + GApp (DAst.make @@ GRef (ConstRef (Projection.constant p), None), + [detype d flags avoid env sigma c]) else if print_primproj_compatibility () && Projection.unfolded p then (** Print the compatibility match version *) @@ -509,12 +521,12 @@ let rec detype flags avoid env sigma t = CAst.make @@ substl (c :: List.rev args) body' with Retyping.RetypeError _ | Not_found -> anomaly (str"Cannot detype an unfolded primitive projection.") - in (detype flags avoid env sigma c').CAst.v + in DAst.get (detype d flags avoid env sigma c') else if print_primproj_params () then try let c = Retyping.expand_projection (snd env) sigma p c [] in - (detype flags avoid env sigma c).CAst.v + DAst.get (detype d flags avoid env sigma c) with Retyping.RetypeError _ -> noparams () else noparams () @@ -542,23 +554,23 @@ let rec detype flags avoid env sigma t = CAst.make @@ (Array.map_to_list (fun c -> (Id.of_string "__",c)) cl) in GEvar (id, - List.map (on_snd (detype flags avoid env sigma)) l) + List.map (on_snd (detype d flags avoid env sigma)) l) | Ind (ind_sp,u) -> GRef (IndRef ind_sp, detype_instance sigma u) | Construct (cstr_sp,u) -> GRef (ConstructRef cstr_sp, detype_instance sigma u) | Case (ci,p,c,bl) -> let comp = computable sigma p (List.length (ci.ci_pp_info.ind_tags)) in - detype_case comp (detype flags avoid env sigma) - (detype_eqns flags avoid env sigma ci comp) + detype_case comp (detype d flags avoid env sigma) + (detype_eqns d flags avoid env sigma ci comp) (is_nondep_branch sigma) avoid (ci.ci_ind,ci.ci_pp_info.style, ci.ci_pp_info.cstr_tags,ci.ci_pp_info.ind_tags) (Some p) c bl - | Fix (nvn,recdef) -> detype_fix flags avoid env sigma nvn recdef - | CoFix (n,recdef) -> detype_cofix flags avoid env sigma n recdef + | Fix (nvn,recdef) -> detype_fix d flags avoid env sigma nvn recdef + | CoFix (n,recdef) -> detype_cofix d flags avoid env sigma n recdef -and detype_fix flags avoid env sigma (vn,_ as nvn) (names,tys,bodies) = +and detype_fix d flags avoid env sigma (vn,_ as nvn) (names,tys,bodies) = let def_avoid, def_env, lfi = Array.fold_left2 (fun (avoid, env, l) na ty -> @@ -567,14 +579,14 @@ and detype_fix flags avoid env sigma (vn,_ as nvn) (names,tys,bodies) = (avoid, env, []) names tys in let n = Array.length tys in let v = Array.map3 - (fun c t i -> share_names flags (i+1) [] def_avoid def_env sigma c (lift n t)) + (fun c t i -> share_names d flags (i+1) [] def_avoid def_env sigma c (lift n t)) bodies tys vn in GRec(GFix (Array.map (fun i -> Some i, GStructRec) (fst nvn), snd nvn),Array.of_list (List.rev lfi), Array.map (fun (bl,_,_) -> bl) v, Array.map (fun (_,_,ty) -> ty) v, Array.map (fun (_,bd,_) -> bd) v) -and detype_cofix flags avoid env sigma n (names,tys,bodies) = +and detype_cofix d flags avoid env sigma n (names,tys,bodies) = let def_avoid, def_env, lfi = Array.fold_left2 (fun (avoid, env, l) na ty -> @@ -583,14 +595,14 @@ and detype_cofix flags avoid env sigma n (names,tys,bodies) = (avoid, env, []) names tys in let ntys = Array.length tys in let v = Array.map2 - (fun c t -> share_names flags 0 [] def_avoid def_env sigma c (lift ntys t)) + (fun c t -> share_names d flags 0 [] def_avoid def_env sigma c (lift ntys t)) bodies tys in GRec(GCoFix n,Array.of_list (List.rev lfi), Array.map (fun (bl,_,_) -> bl) v, Array.map (fun (_,_,ty) -> ty) v, Array.map (fun (_,bd,_) -> bd) v) -and share_names flags n l avoid env sigma c t = +and share_names d flags n l avoid env sigma c t = match EConstr.kind sigma c, EConstr.kind sigma t with (* factorize even when not necessary to have better presentation *) | Lambda (na,t,c), Prod (na',t',c') -> @@ -598,59 +610,59 @@ and share_names flags n l avoid env sigma c t = Name _, _ -> na | _, Name _ -> na' | _ -> na in - let t' = detype flags avoid env sigma t in + let t' = detype d flags avoid env sigma t in let id = next_name_away na avoid in let avoid = id::avoid and env = add_name (Name id) None t env in - share_names flags (n-1) ((Name id,Explicit,None,t')::l) avoid env sigma c c' + share_names d flags (n-1) ((Name id,Explicit,None,t')::l) avoid env sigma c c' (* May occur for fix built interactively *) | LetIn (na,b,t',c), _ when n > 0 -> - let t'' = detype flags avoid env sigma t' in - let b' = detype flags avoid env sigma b in + let t'' = detype d flags avoid env sigma t' in + let b' = detype d flags avoid env sigma b in let id = next_name_away na avoid in let avoid = id::avoid and env = add_name (Name id) (Some b) t' env in - share_names flags n ((Name id,Explicit,Some b',t'')::l) avoid env sigma c (lift 1 t) + share_names d flags n ((Name id,Explicit,Some b',t'')::l) avoid env sigma c (lift 1 t) (* Only if built with the f/n notation or w/o let-expansion in types *) | _, LetIn (_,b,_,t) when n > 0 -> - share_names flags n l avoid env sigma c (subst1 b t) + share_names d flags n l avoid env sigma c (subst1 b t) (* If it is an open proof: we cheat and eta-expand *) | _, Prod (na',t',c') when n > 0 -> - let t'' = detype flags avoid env sigma t' in + let t'' = detype d flags avoid env sigma t' in let id = next_name_away na' avoid in let avoid = id::avoid and env = add_name (Name id) None t' env in let appc = mkApp (lift 1 c,[|mkRel 1|]) in - share_names flags (n-1) ((Name id,Explicit,None,t'')::l) avoid env sigma appc c' + share_names d flags (n-1) ((Name id,Explicit,None,t'')::l) avoid env sigma appc c' (* If built with the f/n notation: we renounce to share names *) | _ -> if n>0 then Feedback.msg_debug (strbrk "Detyping.detype: cannot factorize fix enough"); - let c = detype flags avoid env sigma c in - let t = detype flags avoid env sigma t in + let c = detype d flags avoid env sigma c in + let t = detype d flags avoid env sigma t in (List.rev l,c,t) -and detype_eqns flags avoid env sigma ci computable constructs consnargsl bl = +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 (pat,((avoid,env),c)) -> Loc.tag ([],[pat],detype flags avoid env sigma c)) + List.map (fun (pat,((avoid,env),c)) -> Loc.tag ([],[pat],detype d flags avoid env sigma c)) mat with e when CErrors.noncritical e -> Array.to_list - (Array.map3 (detype_eqn flags avoid env sigma) constructs consnargsl bl) + (Array.map3 (detype_eqn d flags avoid env sigma) constructs consnargsl bl) -and detype_eqn (lax,isgoal as flags) avoid env sigma constr construct_nargs branch = +and detype_eqn d (lax,isgoal as flags) avoid env sigma constr construct_nargs branch = let make_pat x avoid env b body ty ids = if force_wildcard () && noccurn sigma 1 b then - CAst.make @@ PatVar Anonymous,avoid,(add_name Anonymous body ty env),ids + DAst.make @@ PatVar Anonymous,avoid,(add_name Anonymous body ty env),ids else let flag = if isgoal then RenamingForGoal else RenamingForCasesPattern (fst env,b) in let na,avoid' = compute_displayed_name_in sigma flag avoid x b in - CAst.make (PatVar na),avoid',(add_name na body ty env),add_vname ids na + DAst.make (PatVar na),avoid',(add_name na body ty env),add_vname ids na in let rec buildrec ids patlist avoid env l b = match EConstr.kind sigma b, l with | _, [] -> Loc.tag @@ (Id.Set.elements ids, - [CAst.make @@ PatCstr(constr, List.rev patlist,Anonymous)], - detype flags avoid env sigma b) + [DAst.make @@ PatCstr(constr, List.rev patlist,Anonymous)], + detype d flags avoid env sigma b) | Lambda (x,t,b), false::l -> let pat,new_avoid,new_env,new_ids = make_pat x avoid env b None t ids in buildrec new_ids (pat::patlist) new_avoid new_env l b @@ -663,7 +675,7 @@ and detype_eqn (lax,isgoal as flags) avoid env sigma constr construct_nargs bran buildrec ids patlist avoid env l c | _, true::l -> - let pat = CAst.make @@ PatVar Anonymous in + let pat = DAst.make @@ PatVar Anonymous in buildrec ids (pat::patlist) avoid env l b | _, false::l -> @@ -678,32 +690,23 @@ and detype_eqn (lax,isgoal as flags) avoid env sigma constr construct_nargs bran in buildrec Id.Set.empty [] avoid env construct_nargs branch -and detype_binder (lax,isgoal as flags) bk avoid env sigma na body ty c = +and detype_binder d (lax,isgoal as flags) bk avoid env sigma na body ty c = let flag = if isgoal then RenamingForGoal else RenamingElsewhereFor (fst env,c) in let na',avoid' = match bk with | BLetIn -> compute_displayed_let_name_in sigma flag avoid na c | _ -> compute_displayed_name_in sigma flag avoid na c in - let r = detype flags avoid' (add_name na' body ty env) sigma c in + let r = detype d flags avoid' (add_name na' body ty env) sigma c in match bk with - | BProd -> GProd (na',Explicit,detype (lax,false) avoid env sigma ty, r) - | BLambda -> GLambda (na',Explicit,detype (lax,false) avoid env sigma ty, r) + | BProd -> GProd (na',Explicit,detype d (lax,false) avoid env sigma ty, r) + | BLambda -> GLambda (na',Explicit,detype d (lax,false) avoid env sigma ty, r) | BLetIn -> - let c = detype (lax,false) avoid env sigma (Option.get body) in + let c = detype d (lax,false) avoid env sigma (Option.get body) in (* Heuristic: we display the type if in Prop *) let s = try Retyping.get_sort_family_of (snd env) sigma ty with _ when !Flags.in_debugger || !Flags.in_toplevel -> InType (* Can fail because of sigma missing in debugger *) in - let t = if s != InProp && not !Flags.raw_print then None else Some (detype (lax,false) avoid env sigma ty) in + let t = if s != InProp && not !Flags.raw_print then None else Some (detype d (lax,false) avoid env sigma ty) in GLetIn (na', c, t, r) -(** We use a dedicated function here to prevent overallocation from - Array.map_to_list. *) -and detype_array flags avoid env sigma args = - let ans = ref [] in - for i = Array.length args - 1 downto 0 do - ans := detype flags avoid env sigma args.(i) :: !ans; - done; - !ans - -let detype_rel_context ?(lax=false) where avoid env sigma sign = +let detype_rel_context d ?(lax=false) where avoid env sigma sign = let where = Option.map (fun c -> EConstr.it_mkLambda_or_LetIn c sign) where in let rec aux avoid env = function | [] -> [] @@ -725,15 +728,18 @@ let detype_rel_context ?(lax=false) where avoid env sigma sign = | LocalAssum _ -> None | LocalDef (_,b,_) -> Some b in - let b' = Option.map (detype (lax,false) avoid env sigma) b in - let t' = detype (lax,false) avoid env sigma t in + let b' = Option.map (detype d (lax,false) avoid env sigma) b in + let t' = detype d (lax,false) avoid env sigma t in (na',Explicit,b',t') :: aux avoid' (add_name na' b t env) rest in aux avoid env (List.rev sign) let detype_names isgoal avoid nenv env sigma t = - detype (false,isgoal) avoid (nenv,env) sigma t -let detype ?(lax=false) isgoal avoid env sigma t = - detype (lax,isgoal) avoid (names_of_rel_context env, env) sigma t + detype Now (false,isgoal) avoid (nenv,env) sigma t +let detype d ?(lax=false) isgoal avoid env sigma t = + detype d (lax,isgoal) avoid (names_of_rel_context env, env) sigma t + +let detype_rel_context d ?lax where avoid env sigma sign = + detype_rel_context d ?lax where avoid env sigma sign let detype_closed_glob ?lax isgoal avoid env sigma t = let open Context.Rel.Declaration in @@ -745,7 +751,7 @@ let detype_closed_glob ?lax isgoal avoid env sigma t = | Name id -> Name (convert_id cl id) | Anonymous -> Anonymous in - let rec detype_closed_glob cl cg : Glob_term.glob_constr = CAst.map (function + let rec detype_closed_glob cl cg : Glob_term.glob_constr = DAst.map (function | GVar id -> (* if [id] is bound to a name. *) begin try @@ -759,11 +765,11 @@ let detype_closed_glob ?lax isgoal avoid env sigma t = [Printer.pr_constr_under_binders_env] does. *) let assums = List.map (fun id -> LocalAssum (Name id,(* dummy *) mkProp)) b in let env = push_rel_context assums env in - (detype ?lax isgoal avoid env sigma c).CAst.v + DAst.get (detype Now ?lax isgoal avoid env sigma c) (* if [id] is bound to a [closed_glob_constr]. *) with Not_found -> try let {closure;term} = Id.Map.find id cl.untyped in - (detype_closed_glob closure term).CAst.v + DAst.get (detype_closed_glob closure term) (* Otherwise [id] stands for itself *) with Not_found -> GVar id @@ -790,7 +796,7 @@ let detype_closed_glob ?lax isgoal avoid env sigma t = in GCases(sty,po,tml,eqns) | c -> - (Glob_ops.map_glob_constr (detype_closed_glob cl) cg).CAst.v + DAst.get (Glob_ops.map_glob_constr (detype_closed_glob cl) cg) ) cg in detype_closed_glob t.closure t.term @@ -798,7 +804,7 @@ let detype_closed_glob ?lax isgoal avoid env sigma t = (**********************************************************************) (* Module substitution: relies on detyping *) -let rec subst_cases_pattern subst = CAst.map (function +let rec subst_cases_pattern subst = DAst.map (function | PatVar _ as pat -> pat | PatCstr (((kn,i),j),cpl,n) as pat -> let kn' = subst_mind subst kn @@ -809,11 +815,11 @@ let rec subst_cases_pattern subst = CAst.map (function let (f_subst_genarg, subst_genarg_hook) = Hook.make () -let rec subst_glob_constr subst = CAst.map (function +let rec subst_glob_constr subst = DAst.map (function | GRef (ref,u) as raw -> let ref',t = subst_global subst ref in if ref' == ref then raw else - (detype false [] (Global.env()) Evd.empty (EConstr.of_constr t)).CAst.v + DAst.get (detype Now false [] (Global.env()) Evd.empty (EConstr.of_constr t)) | GSort _ | GVar _ @@ -914,8 +920,8 @@ let rec subst_glob_constr subst = CAst.map (function let simple_cases_matrix_of_branches ind brs = List.map (fun (i,n,b) -> let nal,c = it_destRLambda_or_LetIn_names n b in - let mkPatVar na = CAst.make @@ PatVar na in - let p = CAst.make @@ PatCstr ((ind,i+1),List.map mkPatVar nal,Anonymous) in + 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)) brs diff --git a/pretyping/detyping.mli b/pretyping/detyping.mli index 59f3f967d..67c852af3 100644 --- a/pretyping/detyping.mli +++ b/pretyping/detyping.mli @@ -16,6 +16,10 @@ open Mod_subst open Misctypes open Evd +type _ delay = +| Now : 'a delay +| Later : [ `thunk ] delay + (** Should we keep details of universes during detyping ? *) val print_universes : bool ref @@ -33,12 +37,12 @@ val subst_glob_constr : substitution -> glob_constr -> glob_constr val detype_names : bool -> Id.t list -> names_context -> env -> evar_map -> constr -> glob_constr -val detype : ?lax:bool -> bool -> Id.t list -> env -> evar_map -> constr -> glob_constr +val detype : 'a delay -> ?lax:bool -> bool -> Id.t list -> env -> evar_map -> constr -> 'a glob_constr_g val detype_sort : evar_map -> sorts -> glob_sort -val detype_rel_context : ?lax:bool -> constr option -> Id.t list -> (names_context * env) -> - evar_map -> rel_context -> glob_decl list +val detype_rel_context : 'a delay -> ?lax:bool -> constr option -> Id.t list -> (names_context * env) -> + evar_map -> rel_context -> 'a glob_decl_g list val detype_closed_glob : ?lax:bool -> bool -> Id.t list -> env -> evar_map -> closed_glob_constr -> glob_constr @@ -47,7 +51,7 @@ val lookup_name_as_displayed : env -> evar_map -> constr -> Id.t -> int option val lookup_index_as_renamed : env -> evar_map -> constr -> int -> int option (* XXX: This is a hack and should go away *) -val set_detype_anonymous : (?loc:Loc.t -> int -> glob_constr) -> unit +val set_detype_anonymous : (?loc:Loc.t -> int -> Id.t) -> unit val force_wildcard : unit -> bool val synthetize_type : unit -> bool diff --git a/pretyping/glob_ops.ml b/pretyping/glob_ops.ml index b94228e75..c40a24e3b 100644 --- a/pretyping/glob_ops.ml +++ b/pretyping/glob_ops.ml @@ -23,8 +23,8 @@ let cases_predicate_names tml = | (tm,(na,None)) -> [na] | (tm,(na,Some (_,(_,nal)))) -> na::nal) tml) -let mkGApp ?loc p t = CAst.make ?loc @@ - match p.CAst.v with +let mkGApp ?loc p t = DAst.make ?loc @@ + match DAst.get p with | GApp (f,l) -> GApp (f,l@[t]) | _ -> GApp (p,[t]) @@ -46,7 +46,7 @@ let case_style_eq s1 s2 = match s1, s2 with | RegularStyle, RegularStyle -> true | (LetStyle | IfStyle | LetPatternStyle | MatchStyle | RegularStyle), _ -> false -let rec cases_pattern_eq { CAst.v = p1} { CAst.v = p2 } = match p1, p2 with +let rec cases_pattern_eq p1 p2 = match DAst.get p1, DAst.get p2 with | PatVar na1, PatVar na2 -> Name.equal na1 na2 | PatCstr (c1, pl1, na1), PatCstr (c2, pl2, na2) -> eq_constructor c1 c2 && List.equal cases_pattern_eq pl1 pl2 && @@ -98,7 +98,7 @@ let fix_kind_eq f k1 k2 = match k1, k2 with let instance_eq f (x1,c1) (x2,c2) = Id.equal x1 x2 && f c1 c2 -let mk_glob_constr_eq f { CAst.v = c1 } { CAst.v = c2 } = match c1, c2 with +let mk_glob_constr_eq f c1 c2 = match DAst.get c1, DAst.get c2 with | GRef (gr1, _), GRef (gr2, _) -> eq_gr gr1 gr2 | GVar id1, GVar id2 -> Id.equal id1 id2 | GEvar (id1, arg1), GEvar (id2, arg2) -> @@ -137,7 +137,7 @@ let mk_glob_constr_eq f { CAst.v = c1 } { CAst.v = c2 } = match c1, c2 with let rec glob_constr_eq c = mk_glob_constr_eq glob_constr_eq c -let map_glob_constr_left_to_right f = CAst.map (function +let map_glob_constr_left_to_right f = DAst.map (function | GApp (g,args) -> let comp1 = f g in let comp2 = Util.List.map_left f args in @@ -186,7 +186,7 @@ let map_glob_constr = map_glob_constr_left_to_right let fold_return_type f acc (na,tyopt) = Option.fold_left f acc tyopt -let fold_glob_constr f acc = CAst.with_val (function +let fold_glob_constr f acc = DAst.with_val (function | GVar _ -> acc | GApp (c,args) -> List.fold_left f (f acc c) args | GLambda (_,_,b,c) | GProd (_,_,b,c) -> @@ -217,7 +217,7 @@ let fold_glob_constr f acc = CAst.with_val (function let fold_return_type_with_binders f g v acc (na,tyopt) = Option.fold_left (f (Name.fold_right g na v)) acc tyopt -let fold_glob_constr_with_binders g f v acc = CAst.(with_val (function +let fold_glob_constr_with_binders g f v acc = DAst.(with_val (function | GVar _ -> acc | GApp (c,args) -> List.fold_left (f v) (f v acc c) args | GLambda (na,_,b,c) | GProd (na,_,b,c) -> @@ -256,10 +256,9 @@ let fold_glob_constr_with_binders g f v acc = CAst.(with_val (function let iter_glob_constr f = fold_glob_constr (fun () -> f) () let occur_glob_constr id = - let open CAst in - let rec occur barred acc = function - | { loc ; v = GVar id' } -> Id.equal id id' - | c -> + let rec occur barred acc c = match DAst.get c with + | GVar id' -> Id.equal id id' + | _ -> (* [g] looks if [id] appears in a binding position, in which case, we don't have to look in the corresponding subterm *) let g id' barred = barred || Id.equal id id' in @@ -268,21 +267,20 @@ let occur_glob_constr id = occur false false let free_glob_vars = - let open CAst in - let rec vars bound vs = function - | { loc ; v = GVar id' } -> if Id.Set.mem id' bound then vs else Id.Set.add id' vs - | c -> fold_glob_constr_with_binders Id.Set.add vars bound vs c in + let rec vars bound vs c = match DAst.get c with + | GVar id' -> if Id.Set.mem id' bound then vs else Id.Set.add id' vs + | _ -> fold_glob_constr_with_binders Id.Set.add vars bound vs c in fun rt -> let vs = vars Id.Set.empty Id.Set.empty rt in Id.Set.elements vs let glob_visible_short_qualid c = - let rec aux acc = function - | { CAst.v = GRef (c,_) } -> + let rec aux acc c = match DAst.get c with + | GRef (c,_) -> let qualid = Nametab.shortest_qualid_of_global Id.Set.empty c in let dir,id = Libnames.repr_qualid qualid in if DirPath.is_empty dir then id :: acc else acc - | c -> + | _ -> fold_glob_constr aux acc c in aux [] c @@ -326,7 +324,7 @@ let map_tomatch_binders f ((c,(na,inp)) as x) : tomatch_tuple = if r == inp then x else c,(f na, r) -let rec map_case_pattern_binders f = CAst.map (function +let rec map_case_pattern_binders f = DAst.map (function | PatVar na as x -> let r = f na in if r == na then x @@ -396,7 +394,9 @@ let rename_var l id = if List.exists (fun (_,id') -> Id.equal id id') l then raise UnsoundRenaming else id -let rec rename_glob_vars l c = CAst.map_with_loc (fun ?loc -> function +let force c = DAst.make ?loc:c.CAst.loc (DAst.get c) + +let rec rename_glob_vars l c = force @@ DAst.map_with_loc (fun ?loc -> function | GVar id as r -> let id' = rename_var l id in if id == id' then r else GVar id' @@ -436,13 +436,13 @@ let rec rename_glob_vars l c = CAst.map_with_loc (fun ?loc -> function test_na l na; (na,k,Option.map (rename_glob_vars l) bbd,rename_glob_vars l bty))) decls, Array.map (rename_glob_vars l) bs, Array.map (rename_glob_vars l) ts) - | _ -> (map_glob_constr (rename_glob_vars l) c).CAst.v + | _ -> DAst.get (map_glob_constr (rename_glob_vars l) c) ) c (**********************************************************************) (* Conversion from glob_constr to cases pattern, if possible *) -let rec cases_pattern_of_glob_constr na = CAst.map (function +let rec cases_pattern_of_glob_constr na = DAst.map (function | GVar id -> begin match na with | Name _ -> @@ -452,8 +452,12 @@ let rec cases_pattern_of_glob_constr na = CAst.map (function end | GHole (_,_,_) -> PatVar na | GRef (ConstructRef cstr,_) -> PatCstr (cstr,[],na) - | GApp ( { CAst.v = GRef (ConstructRef cstr,_) }, l) -> + | GApp (c, l) -> + begin match DAst.get c with + | GRef (ConstructRef cstr,_) -> PatCstr (cstr,List.map (cases_pattern_of_glob_constr Anonymous) l,na) + | _ -> raise Not_found + end | _ -> raise Not_found ) @@ -469,7 +473,7 @@ let drop_local_defs typi args = | [], [] -> [] | Rel.Declaration.LocalDef _ :: decls, pat :: args -> begin - match pat.CAst.v with + match DAst.get pat with | PatVar Anonymous -> aux decls args | _ -> raise Not_found (* The pattern is used, one cannot drop it *) end @@ -487,21 +491,22 @@ let add_patterns_for_params_remove_local_defs (ind,j) l = let typi = mip.mind_nf_lc.(j-1) in let (_,typi) = decompose_prod_n_assum (Rel.length mib.mind_params_ctxt) typi in drop_local_defs typi l in - Util.List.addn nparams (CAst.make @@ PatVar Anonymous) l + Util.List.addn nparams (DAst.make @@ PatVar Anonymous) l (* Turn a closed cases pattern into a glob_constr *) -let rec glob_constr_of_closed_cases_pattern_aux x = CAst.map_with_loc (fun ?loc -> function +let rec glob_constr_of_closed_cases_pattern_aux x = DAst.map_with_loc (fun ?loc -> function | PatCstr (cstr,[],Anonymous) -> GRef (ConstructRef cstr,None) | PatCstr (cstr,l,Anonymous) -> - let ref = CAst.make ?loc @@ GRef (ConstructRef cstr,None) in + let ref = DAst.make ?loc @@ GRef (ConstructRef cstr,None) in let l = add_patterns_for_params_remove_local_defs cstr l in GApp (ref, List.map glob_constr_of_closed_cases_pattern_aux l) | _ -> raise Not_found ) x -let glob_constr_of_closed_cases_pattern = function - | { CAst.loc ; v = PatCstr (cstr,l,na) } -> - na,glob_constr_of_closed_cases_pattern_aux (CAst.make ?loc @@ PatCstr (cstr,l,Anonymous)) +let glob_constr_of_closed_cases_pattern p = match DAst.get p with + | PatCstr (cstr,l,na) -> + let loc = p.CAst.loc in + na,glob_constr_of_closed_cases_pattern_aux (DAst.make ?loc @@ PatCstr (cstr,l,Anonymous)) | _ -> raise Not_found diff --git a/pretyping/glob_ops.mli b/pretyping/glob_ops.mli index bd9e111f5..bacc8fbe4 100644 --- a/pretyping/glob_ops.mli +++ b/pretyping/glob_ops.mli @@ -11,21 +11,21 @@ open Glob_term (** Equalities *) -val cases_pattern_eq : cases_pattern -> cases_pattern -> bool +val cases_pattern_eq : 'a cases_pattern_g -> 'a cases_pattern_g -> bool val cast_type_eq : ('a -> 'a -> bool) -> 'a Misctypes.cast_type -> 'a Misctypes.cast_type -> bool -val glob_constr_eq : glob_constr -> glob_constr -> bool +val glob_constr_eq : 'a glob_constr_g -> 'a glob_constr_g -> bool (** Operations on [glob_constr] *) -val cases_pattern_loc : cases_pattern -> Loc.t option +val cases_pattern_loc : 'a cases_pattern_g -> Loc.t option -val cases_predicate_names : tomatch_tuples -> Name.t list +val cases_predicate_names : 'a tomatch_tuples_g -> Name.t list (** Apply one argument to a glob_constr *) -val mkGApp : ?loc:Loc.t -> glob_constr -> glob_constr -> glob_constr +val mkGApp : ?loc:Loc.t -> 'a glob_constr_g -> 'a glob_constr_g -> 'a glob_constr_g val map_glob_constr : (glob_constr -> glob_constr) -> glob_constr -> glob_constr @@ -42,12 +42,12 @@ val mk_glob_constr_eq : (glob_constr -> glob_constr -> bool) -> val fold_glob_constr : ('a -> glob_constr -> 'a) -> 'a -> glob_constr -> 'a val fold_glob_constr_with_binders : (Id.t -> 'a -> 'a) -> ('a -> 'b -> glob_constr -> 'b) -> 'a -> 'b -> glob_constr -> 'b val iter_glob_constr : (glob_constr -> unit) -> glob_constr -> unit -val occur_glob_constr : Id.t -> glob_constr -> bool -val free_glob_vars : glob_constr -> Id.t list +val occur_glob_constr : Id.t -> 'a glob_constr_g -> bool +val free_glob_vars : 'a glob_constr_g -> Id.t list val bound_glob_vars : glob_constr -> Id.Set.t (* Obsolete *) -val loc_of_glob_constr : glob_constr -> Loc.t option -val glob_visible_short_qualid : glob_constr -> Id.t list +val loc_of_glob_constr : 'a glob_constr_g -> Loc.t option +val glob_visible_short_qualid : 'a glob_constr_g -> Id.t list (* Renaming free variables using a renaming map; fails with [UnsoundRenaming] if applying the renaming would introduce @@ -57,7 +57,7 @@ val glob_visible_short_qualid : glob_constr -> Id.t list exception UnsoundRenaming val rename_var : (Id.t * Id.t) list -> Id.t -> Id.t -val rename_glob_vars : (Id.t * Id.t) list -> glob_constr -> glob_constr +val rename_glob_vars : (Id.t * Id.t) list -> 'a glob_constr_g -> 'a glob_constr_g (** [map_pattern_binders f m c] applies [f] to all the binding names in a pattern-matching expression ({!Glob_term.GCases}) represented @@ -80,9 +80,9 @@ val map_pattern : (glob_constr -> glob_constr) -> @raise Not_found if translation is impossible *) val cases_pattern_of_glob_constr : Name.t -> glob_constr -> cases_pattern -val glob_constr_of_closed_cases_pattern : cases_pattern -> Name.t * glob_constr +val glob_constr_of_closed_cases_pattern : 'a cases_pattern_g -> Name.t * 'a glob_constr_g -val add_patterns_for_params_remove_local_defs : constructor -> cases_pattern list -> cases_pattern list +val add_patterns_for_params_remove_local_defs : constructor -> 'a cases_pattern_g list -> 'a cases_pattern_g list val ltac_interp_name : Glob_term.ltac_var_map -> Names.name -> Names.name val empty_lvar : Glob_term.ltac_var_map diff --git a/pretyping/nativenorm.ml b/pretyping/nativenorm.ml index 5142af356..39c2ceeba 100644 --- a/pretyping/nativenorm.ml +++ b/pretyping/nativenorm.ml @@ -26,6 +26,59 @@ module RelDecl = Context.Rel.Declaration exception Find_at of int +(* profiling *) + +let profiling_enabled = ref false + +(* for supported platforms, filename for profiler results *) + +let profile_filename = ref "native_compute_profile.data" + +let profiler_platform () = + match [@warning "-8"] Sys.os_type with + | "Unix" -> + let in_ch = Unix.open_process_in "uname" in + let uname = input_line in_ch in + let _ = close_in in_ch in + Format.sprintf "Unix (%s)" uname + | "Win32" -> "Windows (Win32)" + | "Cygwin" -> "Windows (Cygwin)" + +let get_profile_filename () = !profile_filename + +let set_profile_filename fn = + profile_filename := fn + +(* find unused profile filename *) +let get_available_profile_filename () = + let profile_filename = get_profile_filename () in + let dir = Filename.dirname profile_filename in + let base = Filename.basename profile_filename in + (* starting with OCaml 4.04, could use Filename.remove_extension and Filename.extension, which + gets rid of need for exception-handling here + *) + let (name,ext) = + try + let nm = Filename.chop_extension base in + let nm_len = String.length nm in + let ex = String.sub base nm_len (String.length base - nm_len) in + (nm,ex) + with Invalid_argument _ -> (base,"") + in + try + (* unlikely race: fn deleted, another process uses fn *) + Filename.temp_file ~temp_dir:dir (name ^ "_") ext + with Sys_error s -> + let msg = "When trying to find native_compute profile output file: " ^ s in + let _ = Feedback.msg_info (Pp.str msg) in + assert false + +let get_profiling_enabled () = + !profiling_enabled + +let set_profiling_enabled b = + profiling_enabled := b + let invert_tag cst tag reloc_tbl = try for j = 0 to Array.length reloc_tbl - 1 do @@ -379,6 +432,52 @@ let evars_of_evar_map sigma = Nativelambda.evars_typ = Evd.existential_type sigma; Nativelambda.evars_metas = Evd.meta_type sigma } +(* fork perf process, return profiler's process id *) +let start_profiler_linux profile_fn = + let coq_pid = Unix.getpid () in (* pass pid of running coqtop *) + (* we don't want to see perf's console output *) + let dev_null = Unix.descr_of_out_channel (open_out_bin "/dev/null") in + let _ = Feedback.msg_info (Pp.str ("Profiling to file " ^ profile_fn)) in + let perf = "perf" in + let profiler_pid = + Unix.create_process + perf + [|perf; "record"; "-g"; "-o"; profile_fn; "-p"; string_of_int coq_pid |] + Unix.stdin dev_null dev_null + in + (* doesn't seem to be a way to test whether process creation succeeded *) + if !Flags.debug then + Feedback.msg_debug (Pp.str (Format.sprintf "Native compute profiler started, pid = %d, output to: %s" profiler_pid profile_fn)); + Some profiler_pid + +(* kill profiler via SIGINT *) +let stop_profiler_linux m_pid = + match m_pid with + | Some pid -> ( + let _ = if !Flags.debug then Feedback.msg_debug (Pp.str "Stopping native code profiler") in + try + Unix.kill pid Sys.sigint; + let _ = Unix.waitpid [] pid in () + with Unix.Unix_error (Unix.ESRCH,"kill","") -> + Feedback.msg_info (Pp.str "Could not stop native code profiler, no such process") + ) + | None -> () + +let start_profiler () = + let profile_fn = get_available_profile_filename () in + match profiler_platform () with + "Unix (Linux)" -> start_profiler_linux profile_fn + | _ -> + let _ = Feedback.msg_info + (Pp.str (Format.sprintf "Native_compute profiling not supported on the platform: %s" + (profiler_platform ()))) in + None + +let stop_profiler m_pid = + match profiler_platform() with + "Unix (Linux)" -> stop_profiler_linux m_pid + | _ -> () + let native_norm env sigma c ty = let c = EConstr.Unsafe.to_constr c in let ty = EConstr.Unsafe.to_constr ty in @@ -392,12 +491,15 @@ let native_norm env sigma c ty = *) let ml_filename, prefix = Nativelib.get_ml_filename () in let code, upd = mk_norm_code penv (evars_of_evar_map sigma) prefix c in - match Nativelib.compile ml_filename code with + let profile = get_profiling_enabled () in + match Nativelib.compile ml_filename code ~profile:profile with | true, fn -> if !Flags.debug then Feedback.msg_debug (Pp.str "Running norm ..."); + let profiler_pid = if profile then start_profiler () else None in let t0 = Sys.time () in Nativelib.call_linker ~fatal:true prefix fn (Some upd); let t1 = Sys.time () in + if profile then stop_profiler profiler_pid; let time_info = Format.sprintf "Evaluation done in %.5f@." (t1 -. t0) in if !Flags.debug then Feedback.msg_debug (Pp.str time_info); let res = nf_val env sigma !Nativelib.rt1 ty in diff --git a/pretyping/nativenorm.mli b/pretyping/nativenorm.mli index 4e7f2110d..579a7d2ac 100644 --- a/pretyping/nativenorm.mli +++ b/pretyping/nativenorm.mli @@ -12,6 +12,13 @@ open Evd (** This module implements normalization by evaluation to OCaml code *) +val get_profile_filename : unit -> string +val set_profile_filename : string -> unit + +val get_profiling_enabled : unit -> bool +val set_profiling_enabled : bool -> unit + + val native_norm : env -> evar_map -> constr -> types -> constr (** Conversion with inference of universe constraints *) diff --git a/pretyping/patternops.ml b/pretyping/patternops.ml index 5826cc135..3b3ad021e 100644 --- a/pretyping/patternops.ml +++ b/pretyping/patternops.ml @@ -326,7 +326,7 @@ let warn_cast_in_pattern = CWarnings.create ~name:"cast-in-pattern" ~category:"automation" (fun () -> Pp.strbrk "Casts are ignored in patterns") -let rec pat_of_raw metas vars = CAst.with_loc_val (fun ?loc -> function +let rec pat_of_raw metas vars = DAst.with_loc_val (fun ?loc -> function | GVar id -> (try PRel (List.index Name.equal (Name id) vars) with Not_found -> PVar id) @@ -335,11 +335,14 @@ let rec pat_of_raw metas vars = CAst.with_loc_val (fun ?loc -> function | GRef (gr,_) -> PRef (canonical_gr gr) (* Hack to avoid rewriting a complete interpretation of patterns *) - | GApp ({ CAst.v = GPatVar (Evar_kinds.SecondOrderPatVar n) }, cl) -> + | GApp (c, cl) -> + begin match DAst.get c with + | GPatVar (Evar_kinds.SecondOrderPatVar n) -> metas := n::!metas; PSoApp (n, List.map (pat_of_raw metas vars) cl) - | GApp (c,cl) -> + | _ -> PApp (pat_of_raw metas vars c, Array.of_list (List.map (pat_of_raw metas vars) cl)) + end | GLambda (na,bk,c1,c2) -> Name.iter (fun n -> metas := n::!metas) na; PLambda (na, pat_of_raw metas vars c1, @@ -364,8 +367,8 @@ let rec pat_of_raw metas vars = CAst.with_loc_val (fun ?loc -> function PIf (pat_of_raw metas vars c, pat_of_raw metas vars b1,pat_of_raw metas vars b2) | GLetTuple (nal,(_,None),b,c) -> - let mkGLambda na c = CAst.make ?loc @@ - GLambda (na,Explicit, CAst.make @@ GHole (Evar_kinds.InternalHole, IntroAnonymous, None),c) in + let mkGLambda na c = DAst.make ?loc @@ + GLambda (na,Explicit, DAst.make @@ GHole (Evar_kinds.InternalHole, IntroAnonymous, None),c) in let c = List.fold_right mkGLambda nal c in let cip = { cip_style = LetStyle; @@ -377,8 +380,12 @@ let rec pat_of_raw metas vars = CAst.with_loc_val (fun ?loc -> function PCase (cip, PMeta None, pat_of_raw metas vars b, [0,tags,pat_of_raw metas vars c]) | GCases (sty,p,[c,(na,indnames)],brs) -> + let get_ind p = match DAst.get p with + | PatCstr((ind,_),_,_) -> Some ind + | _ -> None + in let get_ind = function - | (_,(_,[{ CAst.v = PatCstr((ind,_),_,_) }],_))::_ -> Some ind + | (_,(_,[p],_))::_ -> get_ind p | _ -> None in let ind_tags,ind = match indnames with @@ -391,8 +398,11 @@ let rec pat_of_raw metas vars = CAst.with_loc_val (fun ?loc -> function | Some p, Some (_,(_,nal)) -> let nvars = na :: List.rev nal @ vars in rev_it_mkPLambda nal (mkPLambda na (pat_of_raw metas nvars p)) - | (None | Some { CAst.v = GHole _}), _ -> PMeta None + | None, _ -> PMeta None | Some p, None -> + match DAst.get p with + | GHole _ -> PMeta None + | _ -> user_err ?loc (strbrk "Clause \"in\" expected in patterns over \"match\" expressions with an explicit \"return\" clause.") in let info = @@ -410,30 +420,36 @@ let rec pat_of_raw metas vars = CAst.with_loc_val (fun ?loc -> function ) and pats_of_glob_branches loc metas vars ind brs = - let get_arg = function - | { CAst.v = PatVar na } -> + let get_arg p = match DAst.get p with + | PatVar na -> Name.iter (fun n -> metas := n::!metas) na; na - | { CAst.v = PatCstr(_,_,_) ; loc } -> err ?loc (Pp.str "Non supported pattern.") + | PatCstr(_,_,_) -> err ?loc:p.CAst.loc (Pp.str "Non supported pattern.") in let rec get_pat indexes = function | [] -> false, [] - | [(_,(_,[{ CAst.v = PatVar Anonymous }], { CAst.v = GHole _}))] -> true, [] (* ends with _ => _ *) - | (_,(_,[{ CAst.v = PatCstr((indsp,j),lv,_) }],br)) :: brs -> - let () = match ind with - | Some sp when eq_ind sp indsp -> () + | (loc',(_,[p], br)) :: brs -> + begin match DAst.get p, DAst.get br, brs with + | PatVar Anonymous, GHole _, [] -> + true, [] (* ends with _ => _ *) + | PatCstr((indsp,j),lv,_), _, _ -> + let () = match ind with + | Some sp when eq_ind sp indsp -> () + | _ -> + err ?loc (Pp.str "All constructors must be in the same inductive type.") + in + if Int.Set.mem (j-1) indexes then + err ?loc + (str "No unique branch for " ++ int j ++ str"-th constructor."); + let lna = List.map get_arg lv in + let vars' = List.rev lna @ vars in + let pat = rev_it_mkPLambda lna (pat_of_raw metas vars' br) in + let ext,pats = get_pat (Int.Set.add (j-1) indexes) brs in + let tags = List.map (fun _ -> false) lv (* approximation, w/o let-in *) in + ext, ((j-1, tags, pat) :: pats) | _ -> - err ?loc (Pp.str "All constructors must be in the same inductive type.") - in - if Int.Set.mem (j-1) indexes then - err ?loc - (str "No unique branch for " ++ int j ++ str"-th constructor."); - let lna = List.map get_arg lv in - let vars' = List.rev lna @ vars in - let pat = rev_it_mkPLambda lna (pat_of_raw metas vars' br) in - let ext,pats = get_pat (Int.Set.add (j-1) indexes) brs in - let tags = List.map (fun _ -> false) lv (* approximation, w/o let-in *) in - ext, ((j-1, tags, pat) :: pats) + err ?loc:loc' (Pp.str "Non supported pattern.") + end | (loc,(_,_,_)) :: _ -> 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 b4d87dfdb..79d2c3333 100644 --- a/pretyping/pretyping.ml +++ b/pretyping/pretyping.ml @@ -47,8 +47,6 @@ open Misctypes module NamedDecl = Context.Named.Declaration type typing_constraint = OfType of types | IsType | WithoutTypeConstraint -type glob_constr_ltac_closure = ltac_var_map * glob_constr -type pure_open_constr = evar_map * EConstr.constr (************************************************************************) (* This concerns Cases *) @@ -385,9 +383,6 @@ let adjust_evar_source evdref na c = end | _, _ -> c -(* Allow references to syntactically nonexistent variables (i.e., if applied on an inductive) *) -let allow_anonymous_refs = ref false - (* coerce to tycon if any *) let inh_conv_coerce_to_tycon ?loc resolve_tc env evdref j = function | None -> j @@ -577,7 +572,7 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) (env : ExtraEnv.t) evdre let pretype = pretype k0 resolve_tc in let open Context.Rel.Declaration in let loc = t.CAst.loc in - match t.CAst.v with + match DAst.get t with | GRef (ref,u) -> inh_conv_coerce_to_tycon ?loc env evdref (pretype_ref ?loc evdref env ref u) @@ -918,9 +913,7 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) (env : ExtraEnv.t) evdre (* Make dependencies from arity signature impossible *) let arsgn = let arsgn,_ = get_arity env.ExtraEnv.env indf in - if not !allow_anonymous_refs then - List.map (set_name Anonymous) arsgn - else arsgn + List.map (set_name Anonymous) arsgn in let indt = build_dependent_inductive env.ExtraEnv.env indf in let psign = LocalAssum (na, indt) :: arsgn in (* For locating names in [po] *) @@ -981,10 +974,8 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) (env : ExtraEnv.t) evdre let arsgn = let arsgn,_ = get_arity env.ExtraEnv.env indf in - if not !allow_anonymous_refs then - (* Make dependencies from arity signature impossible *) - List.map (set_name Anonymous) arsgn - else arsgn + (* Make dependencies from arity signature impossible *) + List.map (set_name Anonymous) arsgn in let nar = List.length arsgn in let indt = build_dependent_inductive env.ExtraEnv.env indf in @@ -1018,13 +1009,8 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) (env : ExtraEnv.t) evdre let pi = beta_applist !evdref (pi, [EConstr.of_constr (build_dependent_constructor cs)]) in let cs_args = List.map (fun d -> map_rel_decl EConstr.of_constr d) cs.cs_args in let csgn = - if not !allow_anonymous_refs then - List.map (set_name Anonymous) cs_args - else - List.map (map_name (function Name _ as n -> n - | Anonymous -> Name Namegen.default_non_dependent_ident)) - cs_args - in + List.map (set_name Anonymous) cs_args + in let env_c = push_rel_context !evdref csgn env in let bj = pretype (mk_tycon pi) env_c evdref lvar b in it_mkLambda_or_LetIn bj.uj_val cs_args in @@ -1114,8 +1100,9 @@ and pretype_instance k0 resolve_tc env evdref lvar loc hyps evk update = Array.map_of_list snd subst (* [pretype_type valcon env evdref lvar c] coerces [c] into a type *) -and pretype_type k0 resolve_tc valcon (env : ExtraEnv.t) evdref lvar = function - | { loc; CAst.v = GHole (knd, naming, None) } -> +and pretype_type k0 resolve_tc valcon (env : ExtraEnv.t) evdref lvar c = match DAst.get c with + | GHole (knd, naming, None) -> + let loc = loc_of_glob_constr c in let rec is_Type c = match EConstr.kind !evdref c with | Sort s -> begin match ESorts.kind !evdref s with @@ -1148,7 +1135,7 @@ and pretype_type k0 resolve_tc valcon (env : ExtraEnv.t) evdref lvar = function let s = evd_comb0 (new_sort_variable univ_flexible_alg) evdref in { utj_val = e_new_evar env evdref ~src:(loc, knd) ~naming (mkSort s); utj_type = s}) - | c -> + | _ -> let j = pretype k0 resolve_tc empty_tycon env evdref lvar c in let loc = loc_of_glob_constr c in let tj = evd_comb1 (Coercion.inh_coerce_to_sort ?loc env.ExtraEnv.env) evdref j in @@ -1191,29 +1178,6 @@ let no_classes_no_fail_inference_flags = { let all_and_fail_flags = default_inference_flags true let all_no_fail_flags = default_inference_flags false -let on_judgment sigma f j = - let c = mkCast(j.uj_val,DEFAULTcast, j.uj_type) in - let (c,_,t) = destCast sigma (f c) in - {uj_val = c; uj_type = t} - -let understand_judgment env sigma c = - let env = make_env env sigma in - let evdref = ref sigma in - let k0 = Context.Rel.length (rel_context env) in - let j = pretype k0 true empty_tycon env evdref empty_lvar c in - let j = on_judgment sigma (fun c -> - let evd, c = process_inference_flags all_and_fail_flags env.ExtraEnv.env sigma (!evdref,c) in - evdref := evd; c) j - in j, Evd.evar_universe_context !evdref - -let understand_judgment_tcc env evdref c = - let env = make_env env !evdref in - let k0 = Context.Rel.length (rel_context env) in - let j = pretype k0 true empty_tycon env evdref empty_lvar c in - on_judgment !evdref (fun c -> - let (evd,c) = process_inference_flags all_no_fail_flags env.ExtraEnv.env Evd.empty (!evdref,c) in - evdref := evd; c) j - let ise_pretype_gen_ctx flags env sigma lvar kind c = let evd, c = ise_pretype_gen flags env sigma lvar kind c in let evd, f = Evarutil.nf_evars_and_universes evd in @@ -1231,36 +1195,10 @@ let understand_tcc ?(flags=all_no_fail_flags) env sigma ?(expected_type=WithoutT let (sigma, c) = ise_pretype_gen flags env sigma empty_lvar expected_type c in (sigma, c) -let understand_tcc_evars ?(flags=all_no_fail_flags) env evdref ?(expected_type=WithoutTypeConstraint) c = - let sigma, c = ise_pretype_gen flags env !evdref empty_lvar expected_type c in - evdref := sigma; - c - let understand_ltac flags env sigma lvar kind c = let (sigma, c) = ise_pretype_gen flags env sigma lvar kind c in (sigma, c) -let constr_flags = { - use_typeclasses = true; - solve_unification_constraints = true; - use_hook = None; - fail_evar = true; - expand_evars = true } - -(* Fully evaluate an untyped constr *) -let type_uconstr ?(flags = constr_flags) - ?(expected_type = WithoutTypeConstraint) ist c = - begin fun env sigma -> - let { closure; term } = c in - let vars = { - ltac_constrs = closure.typed; - ltac_uconstrs = closure.untyped; - ltac_idents = closure.idents; - ltac_genargs = Id.Map.empty; - } in - understand_ltac flags env sigma vars expected_type term - end - let pretype k0 resolve_tc typcon env evdref lvar t = pretype k0 resolve_tc typcon (make_env env !evdref) evdref lvar t diff --git a/pretyping/pretyping.mli b/pretyping/pretyping.mli index 6e533f178..7395e94a0 100644 --- a/pretyping/pretyping.mli +++ b/pretyping/pretyping.mli @@ -27,9 +27,6 @@ val search_guard : type typing_constraint = OfType of types | IsType | WithoutTypeConstraint -type glob_constr_ltac_closure = ltac_var_map * glob_constr -type pure_open_constr = evar_map * constr - type inference_hook = env -> evar_map -> evar -> evar_map * constr type inference_flags = { @@ -48,9 +45,6 @@ val all_no_fail_flags : inference_flags val all_and_fail_flags : inference_flags -(** Allow references to syntactically nonexistent variables (i.e., if applied on an inductive) *) -val allow_anonymous_refs : bool ref - (** Generic calls to the interpreter from glob_constr to open_constr; by default, inference_flags tell to use type classes and heuristics (but no external tactic solver hooks), as well as to @@ -61,9 +55,6 @@ val allow_anonymous_refs : bool ref val understand_tcc : ?flags:inference_flags -> env -> evar_map -> ?expected_type:typing_constraint -> glob_constr -> evar_map * constr -val understand_tcc_evars : ?flags:inference_flags -> env -> evar_map ref -> - ?expected_type:typing_constraint -> glob_constr -> constr - (** More general entry point with evars from ltac *) (** Generic call to the interpreter from glob_constr to constr @@ -78,7 +69,7 @@ val understand_tcc_evars : ?flags:inference_flags -> env -> evar_map ref -> val understand_ltac : inference_flags -> env -> evar_map -> ltac_var_map -> - typing_constraint -> glob_constr -> pure_open_constr + typing_constraint -> glob_constr -> evar_map * EConstr.t (** Standard call to get a constr from a glob_constr, resolving implicit arguments and coercions, and compiling pattern-matching; @@ -90,20 +81,6 @@ val understand_ltac : inference_flags -> val understand : ?flags:inference_flags -> ?expected_type:typing_constraint -> env -> evar_map -> glob_constr -> Constr.constr Evd.in_evar_universe_context -(** Idem but returns the judgment of the understood term *) - -val understand_judgment : env -> evar_map -> - glob_constr -> unsafe_judgment Evd.in_evar_universe_context - -(** Idem but do not fail on unresolved evars (type cl*) -val understand_judgment_tcc : env -> evar_map ref -> - glob_constr -> unsafe_judgment - -val type_uconstr : - ?flags:inference_flags -> - ?expected_type:typing_constraint -> - Geninterp.interp_sign -> Glob_term.closed_glob_constr -> constr Tactypes.delayed_open - (** Trying to solve remaining evars and remaining conversion problems possibly using type classes, heuristics, external tactic solver hook depending on given flags. *) diff --git a/pretyping/tacred.ml b/pretyping/tacred.ml index 76f35f76f..708788ab8 100644 --- a/pretyping/tacred.ml +++ b/pretyping/tacred.ml @@ -557,6 +557,12 @@ let match_eval_ref_value env sigma constr stack = Some (EConstr.of_constr (constant_value_in env (sp, u))) else None + | Proj (p, c) when not (Projection.unfolded p) -> + reduction_effect_hook env sigma (EConstr.to_constr sigma constr) + (lazy (EConstr.to_constr sigma (applist (constr,stack)))); + if is_evaluable env (EvalConstRef (Projection.constant p)) then + Some (mkProj (Projection.unfold p, c)) + else None | Var id when is_evaluable env (EvalVarRef id) -> env |> lookup_named id |> NamedDecl.get_value | Rel n -> diff --git a/pretyping/typeclasses.ml b/pretyping/typeclasses.ml index d4fa266c0..375a8a983 100644 --- a/pretyping/typeclasses.ml +++ b/pretyping/typeclasses.ml @@ -84,8 +84,8 @@ type instance = { is_class: global_reference; is_info: Vernacexpr.hint_info_expr; (* Sections where the instance should be redeclared, - -1 for discard, 0 for none. *) - is_global: int; + None for discard, Some 0 for none. *) + is_global: int option; is_poly: bool; is_impl: global_reference; } @@ -98,9 +98,11 @@ let hint_priority is = is.is_info.Vernacexpr.hint_priority let new_instance cl info glob poly impl = let global = - if glob then Lib.sections_depth () - else -1 + if glob then Some (Lib.sections_depth ()) + else None in + if match global with Some n -> n>0 && isVarRef impl | _ -> false then + CErrors.user_err (Pp.str "Cannot set Global an instance referring to a section variable."); { is_class = cl.cl_impl; is_info = info ; is_global = global ; @@ -350,22 +352,34 @@ let subst_instance (subst, (action, inst)) = action, is_impl = fst (subst_global subst inst.is_impl) } let discharge_instance (_, (action, inst)) = - if inst.is_global <= 0 then None - else Some (action, + match inst.is_global with + | None -> None + | Some n -> + assert (not (isVarRef inst.is_impl)); + Some (action, { inst with - is_global = pred inst.is_global; + is_global = Some (pred n); is_class = Lib.discharge_global inst.is_class; is_impl = Lib.discharge_global inst.is_impl }) -let is_local i = Int.equal i.is_global (-1) +let is_local i = (i.is_global == None) + +let is_local_for_hint i = + match i.is_global with + | None -> true (* i.e. either no Global keyword not in section, or in section *) + | Some n -> n <> 0 (* i.e. in a section, declare the hint as local + since discharge is managed by rebuild_instance which calls again + add_instance_hint; don't ask hints to take discharge into account + itself *) let add_instance check inst = let poly = Global.is_polymorphic inst.is_impl in - add_instance_hint (IsGlobal inst.is_impl) [inst.is_impl] (is_local inst) + let local = is_local_for_hint inst in + add_instance_hint (IsGlobal inst.is_impl) [inst.is_impl] local inst.is_info poly; List.iter (fun (path, pri, c) -> add_instance_hint (IsConstr c) path - (is_local inst) pri poly) + local pri poly) (build_subclasses ~check:(check && not (isVarRef inst.is_impl)) (Global.env ()) (Evd.from_env (Global.env ())) inst.is_impl inst.is_info) @@ -404,6 +418,7 @@ let declare_instance info local glob = let info = Option.default {hint_priority = None; hint_pattern = None} info in match class_of_constr Evd.empty (EConstr.of_constr ty) with | Some (rels, ((tc,_), args) as _cl) -> + assert (not (isVarRef glob) || local); add_instance (new_instance tc info (not local) (Flags.use_polymorphic_flag ()) glob) | None -> () diff --git a/printing/ppconstr.ml b/printing/ppconstr.ml index ee03bc900..4a103cdd2 100644 --- a/printing/ppconstr.ml +++ b/printing/ppconstr.ml @@ -15,6 +15,7 @@ open Nameops open Libnames open Pputils open Ppextend +open Notation_term open Constrexpr open Constrexpr_ops open Decl_kinds @@ -737,7 +738,7 @@ let tag_var = tag Tag.variable pr_lconstr_pattern_expr : constr_pattern_expr -> Pp.t } - type precedence = Ppextend.precedence * Ppextend.parenRelation + type precedence = Notation_term.precedence * Notation_term.parenRelation let modular_constr_pr = pr let rec fix rf x = rf (fix rf) x let pr = fix modular_constr_pr mt diff --git a/printing/ppconstr.mli b/printing/ppconstr.mli index 833503485..7546c748d 100644 --- a/printing/ppconstr.mli +++ b/printing/ppconstr.mli @@ -15,6 +15,7 @@ open Libnames open Constrexpr open Names open Misctypes +open Notation_term val extract_lam_binders : constr_expr -> local_binder_expr list * constr_expr @@ -24,7 +25,7 @@ val split_fix : int -> constr_expr -> constr_expr -> local_binder_expr list * constr_expr * constr_expr -val prec_less : int -> int * Ppextend.parenRelation -> bool +val prec_less : precedence -> tolerability -> bool val pr_tight_coma : unit -> Pp.t diff --git a/printing/ppvernac.ml b/printing/ppvernac.ml index a68b569cb..4c50c2f36 100644 --- a/printing/ppvernac.ml +++ b/printing/ppvernac.ml @@ -760,7 +760,11 @@ open Decl_kinds | Class _ -> "Class" | Variant -> "Variant" in if p then - let cm = if cum then "Cumulative" else "NonCumulative" in + let cm = + match cum with + | GlobalCumulativity | LocalCumulativity -> "Cumulative" + | GlobalNonCumulativity | LocalNonCumulativity -> "NonCumulative" + in cm ^ " " ^ kind else kind in diff --git a/printing/printer.ml b/printing/printer.ml index c6cf2254f..28b10c781 100644 --- a/printing/printer.ml +++ b/printing/printer.ml @@ -79,23 +79,23 @@ let _ = and only names of goal/section variables and rel names that do _not_ occur in the scope of the binder to be printed are avoided. *) -let pr_constr_core goal_concl_style env sigma t = +let pr_econstr_core goal_concl_style env sigma t = pr_constr_expr (extern_constr goal_concl_style env sigma t) -let pr_lconstr_core goal_concl_style env sigma t = +let pr_leconstr_core goal_concl_style env sigma t = pr_lconstr_expr (extern_constr goal_concl_style env sigma t) -let pr_lconstr_env env = pr_lconstr_core false env -let pr_constr_env env = pr_constr_core false env +let pr_lconstr_env env sigma c = pr_leconstr_core false env sigma (EConstr.of_constr c) +let pr_constr_env env sigma c = pr_econstr_core false env sigma (EConstr.of_constr c) let _ = Hook.set Refine.pr_constr pr_constr_env -let pr_lconstr_goal_style_env env = pr_lconstr_core true env -let pr_constr_goal_style_env env = pr_constr_core true env +let pr_lconstr_goal_style_env env sigma c = pr_leconstr_core true env sigma (EConstr.of_constr c) +let pr_constr_goal_style_env env sigma c = pr_econstr_core true env sigma (EConstr.of_constr c) let pr_open_lconstr_env env sigma (_,c) = pr_lconstr_env env sigma c let pr_open_constr_env env sigma (_,c) = pr_constr_env env sigma c -let pr_leconstr_env env sigma c = pr_lconstr_env env sigma (EConstr.to_constr sigma c) -let pr_econstr_env env sigma c = pr_constr_env env sigma (EConstr.to_constr sigma c) +let pr_leconstr_env env sigma c = pr_leconstr_core false env sigma c +let pr_econstr_env env sigma c = pr_econstr_core false env sigma c (* NB do not remove the eta-redexes! Global.env() has side-effects... *) let pr_lconstr t = @@ -128,13 +128,13 @@ let pr_lconstr_under_binders c = let (sigma, env) = get_current_context () in pr_lconstr_under_binders_env env sigma c -let pr_type_core goal_concl_style env sigma t = +let pr_etype_core goal_concl_style env sigma t = pr_constr_expr (extern_type goal_concl_style env sigma t) -let pr_ltype_core goal_concl_style env sigma t = +let pr_letype_core goal_concl_style env sigma t = pr_lconstr_expr (extern_type goal_concl_style env sigma t) -let pr_ltype_env env = pr_ltype_core false env -let pr_type_env env = pr_type_core false env +let pr_ltype_env env sigma c = pr_letype_core false env sigma (EConstr.of_constr c) +let pr_type_env env sigma c = pr_etype_core false env sigma (EConstr.of_constr c) let pr_ltype t = let (sigma, env) = get_current_context () in @@ -143,10 +143,9 @@ let pr_type t = let (sigma, env) = get_current_context () in pr_type_env env sigma t -let pr_etype_env env sigma c = pr_type_env env sigma (EConstr.to_constr sigma c) -let pr_letype_env env sigma c = pr_ltype_env env sigma (EConstr.to_constr sigma c) -let pr_goal_concl_style_env env sigma c = - pr_ltype_core true env sigma (EConstr.to_constr sigma c) +let pr_etype_env env sigma c = pr_etype_core false env sigma c +let pr_letype_env env sigma c = pr_letype_core false env sigma c +let pr_goal_concl_style_env env sigma c = pr_letype_core true env sigma c let pr_ljudge_env env sigma j = (pr_leconstr_env env sigma j.uj_val, pr_leconstr_env env sigma j.uj_type) @@ -191,7 +190,7 @@ let pr_constr_pattern t = let pr_sort sigma s = pr_glob_sort (extern_sort sigma s) let _ = Termops.set_print_constr - (fun env sigma t -> pr_lconstr_expr (extern_constr ~lax:true false env sigma (EConstr.Unsafe.to_constr t))) + (fun env sigma t -> pr_lconstr_expr (extern_constr ~lax:true false env sigma t)) let pr_in_comment pr x = str "(* " ++ pr x ++ str " *)" @@ -364,6 +363,7 @@ let pr_named_context env sigma ne_context = ne_context ~init:(mt ())) let pr_rel_context env sigma rel_context = + let rel_context = List.map (fun d -> Termops.map_rel_decl EConstr.of_constr d) rel_context in pr_binders (extern_rel_context None env sigma rel_context) let pr_rel_context_of env sigma = @@ -479,7 +479,8 @@ let pr_transparent_state (ids, csts) = (* display complete goal *) let default_pr_goal gs = - let (g,sigma) = Goal.V82.nf_evar (project gs) (sig_it gs) in + let g = sig_it gs in + let sigma = project gs in let env = Goal.V82.env sigma g in let concl = Goal.V82.concl sigma g in let goal = @@ -845,15 +846,6 @@ let pr_goal_by_uid uid = (* Elementary tactics *) let pr_prim_rule = function - | Cut (b,replace,id,t) -> - if b then - (* TODO: express "replace" *) - (str"assert " ++ str"(" ++ pr_id id ++ str":" ++ pr_lconstr t ++ str")") - else - let cl = if replace then str"clear " ++ pr_id id ++ str"; " else mt() in - (str"cut " ++ pr_constr t ++ - str ";[" ++ cl ++ str"intro " ++ pr_id id ++ str"|idtac]") - | Refine c -> (** FIXME *) str(if Termops.occur_meta Evd.empty (EConstr.of_constr c) then "refine " else "exact ") ++ diff --git a/proofs/evar_refiner.ml b/proofs/evar_refiner.ml index cc81adb85..48fa2202e 100644 --- a/proofs/evar_refiner.ml +++ b/proofs/evar_refiner.ml @@ -13,11 +13,14 @@ open Evd open Evarutil open Evarsolve open Pp +open Glob_term (******************************************) (* Instantiation of existential variables *) (******************************************) +type glob_constr_ltac_closure = ltac_var_map * glob_constr + let depends_on_evar sigma evk _ (pbty,_,t1,t2) = let t1 = EConstr.of_constr t1 in let t2 = EConstr.of_constr t2 in diff --git a/proofs/evar_refiner.mli b/proofs/evar_refiner.mli index b65ffb1be..5d6971596 100644 --- a/proofs/evar_refiner.mli +++ b/proofs/evar_refiner.mli @@ -7,9 +7,11 @@ (************************************************************************) open Evd -open Pretyping +open Glob_term (** Refinement of existential variables. *) +type glob_constr_ltac_closure = ltac_var_map * glob_constr + val w_refine : evar * evar_info -> glob_constr_ltac_closure -> evar_map -> evar_map diff --git a/proofs/logic.ml b/proofs/logic.ml index 17128b92e..20d075ae1 100644 --- a/proofs/logic.ml +++ b/proofs/logic.ml @@ -22,7 +22,6 @@ open Proof_type open Type_errors open Retyping open Misctypes -open Context.Named.Declaration module NamedDecl = Context.Named.Declaration @@ -93,15 +92,6 @@ let check_typability env sigma c = (* Implementation of the structural rules (moving and deleting hypotheses around) *) -(* The Clear tactic: it scans the context for hypotheses to be removed - (instead of iterating on the list of identifier to be removed, which - forces the user to give them in order). *) - -let clear_hyps2 env sigma ids sign t cl = - let evdref = ref (Evd.clear_metas sigma) in - let (hyps,t,cl) = Evarutil.clear_hyps2_in_evi env evdref sign t cl ids in - (hyps, t, cl, !evdref) - (* The ClearBody tactic *) (* Reordering of the context *) @@ -200,14 +190,6 @@ let move_location_eq m1 m2 = match m1, m2 with | MoveFirst, MoveFirst -> true | _ -> false -let rec get_hyp_after h = function - | [] -> error_no_such_hypothesis h - | d :: right -> - if Id.equal (NamedDecl.get_id d) h then - match right with d' ::_ -> MoveBefore (NamedDecl.get_id d') | [] -> MoveFirst - else - get_hyp_after h right - let split_sign hfrom hto l = let rec splitrec left toleft = function | [] -> error_no_such_hypothesis hfrom @@ -282,6 +264,10 @@ let move_hyp_in_named_context sigma hfrom hto sign = split_sign hfrom hto (named_context_of_val sign) in move_hyp sigma toleft (left,declfrom,right) hto +let insert_decl_in_named_context sigma decl hto sign = + let open EConstr in + move_hyp sigma false ([],decl,named_context_of_val sign) hto + (**********************************************************************) @@ -535,37 +521,9 @@ let convert_hyp check sign sigma d = (* Primitive tactics are handled here *) let prim_refiner r sigma goal = - let env = Goal.V82.env sigma goal in - let sign = Goal.V82.hyps sigma goal in let cl = Goal.V82.concl sigma goal in - let mk_goal hyps concl = - Goal.V82.mk_goal sigma hyps concl (Goal.V82.extra sigma goal) - in - let open EConstr in match r with (* Logical rules *) - | Cut (b,replace,id,t) -> -(* if !check && not (Retyping.get_sort_of env sigma t) then*) - let t = EConstr.of_constr t in - let (sg1,ev1,sigma) = mk_goal sign (nf_betaiota sigma t) in - let sign,t,cl,sigma = - if replace then - let nexthyp = get_hyp_after id (named_context_of_val sign) in - let sign,t,cl,sigma = clear_hyps2 env sigma (Id.Set.singleton id) sign t cl in - move_hyp sigma false ([], LocalAssum (id,t),named_context_of_val sign) - nexthyp, - t,cl,sigma - else - (if !check && mem_named_context_val id sign then - user_err ~hdr:"Logic.prim_refiner" - (str "Variable " ++ pr_id id ++ str " is already declared."); - push_named_context_val (LocalAssum (id,t)) sign,t,cl,sigma) in - let (sg2,ev2,sigma) = - Goal.V82.mk_goal sigma sign cl (Goal.V82.extra sigma goal) in - let oterm = mkLetIn (Name id, ev1, t, EConstr.Vars.subst_var id ev2) in - let sigma = Goal.V82.partial_solution_to sigma goal sg2 oterm in - if b then ([sg1;sg2],sigma) else ([sg2;sg1],sigma) - | Refine c -> let cl = EConstr.Unsafe.to_constr cl in check_meta_variables c; diff --git a/proofs/logic.mli b/proofs/logic.mli index 84a21044b..9d0756b33 100644 --- a/proofs/logic.mli +++ b/proofs/logic.mli @@ -52,6 +52,8 @@ type refiner_error = exception RefinerError of refiner_error +val error_no_such_hypothesis : Id.t -> 'a + val catchable_exception : exn -> bool val convert_hyp : bool -> Environ.named_context_val -> evar_map -> @@ -59,3 +61,7 @@ val convert_hyp : bool -> Environ.named_context_val -> evar_map -> val move_hyp_in_named_context : Evd.evar_map -> Id.t -> Id.t Misctypes.move_location -> Environ.named_context_val -> Environ.named_context_val + +val insert_decl_in_named_context : Evd.evar_map -> + EConstr.named_declaration -> Id.t Misctypes.move_location -> + Environ.named_context_val -> Environ.named_context_val diff --git a/proofs/proof_type.ml b/proofs/proof_type.ml index 11f1a13e6..2ad5f607f 100644 --- a/proofs/proof_type.ml +++ b/proofs/proof_type.ml @@ -9,14 +9,12 @@ (** Legacy proof engine. Do not use in newly written code. *) open Evd -open Names open Term (** This module defines the structure of proof tree and the tactic type. So, it is used by [Proof_tree] and [Refiner] *) type prim_rule = - | Cut of bool * bool * Id.t * types | Refine of constr (** Nowadays, the only rules we'll consider are the primitive rules *) diff --git a/proofs/tacmach.ml b/proofs/tacmach.ml index 2ed9416d1..a4d662e0a 100644 --- a/proofs/tacmach.ml +++ b/proofs/tacmach.ml @@ -115,22 +115,12 @@ let pf_matches gl p c = pf_apply Constr_matching.matches_conv gl p c let refiner = refiner -let internal_cut_no_check replace id t gl = - let t = EConstr.Unsafe.to_constr t in - refiner (Cut (true,replace,id,t)) gl - -let internal_cut_rev_no_check replace id t gl = - let t = EConstr.Unsafe.to_constr t in - refiner (Cut (false,replace,id,t)) gl - let refine_no_check c gl = let c = EConstr.Unsafe.to_constr c in refiner (Refine c) gl (* Versions with consistency checks *) -let internal_cut b d t = with_check (internal_cut_no_check b d t) -let internal_cut_rev b d t = with_check (internal_cut_rev_no_check b d t) let refine c = with_check (refine_no_check c) (* Pretty-printers *) diff --git a/proofs/tacmach.mli b/proofs/tacmach.mli index 40b6573a1..93bf428fd 100644 --- a/proofs/tacmach.mli +++ b/proofs/tacmach.mli @@ -84,13 +84,10 @@ val pf_is_matching : goal sigma -> constr_pattern -> constr -> bool (** {6 The most primitive tactics. } *) val refiner : rule -> tactic -val internal_cut_no_check : bool -> Id.t -> types -> tactic val refine_no_check : constr -> tactic (** {6 The most primitive tactics with consistency and type checking } *) -val internal_cut : bool -> Id.t -> types -> tactic -val internal_cut_rev : bool -> Id.t -> types -> tactic val refine : constr -> tactic (** {6 Pretty-printing functions (debug only). } *) diff --git a/tactics/class_tactics.ml b/tactics/class_tactics.ml index 371debede..b98b10315 100644 --- a/tactics/class_tactics.ml +++ b/tactics/class_tactics.ml @@ -1342,7 +1342,7 @@ module Search = struct | Some i -> str ", with depth limit " ++ int i)); tac - let run_on_evars p evm tac = + let run_on_evars env evm p tac = match evars_to_goals p evm with | None -> None (* This happens only because there's no evar having p *) | Some (goals, evm') -> @@ -1357,7 +1357,7 @@ module Search = struct let pv = Proofview.unshelve goals pv in try let (), pv', (unsafe, shelved, gaveup), _ = - Proofview.apply (Global.env ()) tac pv + Proofview.apply env tac pv in if Proofview.finished pv' then let evm' = Proofview.return pv' in @@ -1374,22 +1374,22 @@ module Search = struct else raise Not_found with Logic_monad.TacticFailure _ -> raise Not_found - let evars_eauto depth only_classes unique dep st hints p evd = + let evars_eauto env evd depth only_classes unique dep st hints p = let eauto_tac = eauto_tac ~st ~unique ~only_classes ~depth ~dep:(unique || dep) hints in - let res = run_on_evars p evd eauto_tac in + let res = run_on_evars env evd p eauto_tac in match res with | None -> evd | Some evd' -> evd' - let typeclasses_eauto ?depth unique st hints p evd = - evars_eauto depth true unique false st hints p evd + let typeclasses_eauto env evd ?depth unique st hints p = + evars_eauto env evd depth true unique false st hints p (** Typeclasses eauto is an eauto which tries to resolve only goals of typeclass type, and assumes that the initially selected evars in evd are independent of the rest of the evars *) - let typeclasses_resolve debug depth unique p evd = + let typeclasses_resolve env evd debug depth unique p = let db = searchtable_map typeclasses_db in - typeclasses_eauto ?depth unique (Hint_db.transparent_state db) [db] p evd + typeclasses_eauto env evd ?depth unique (Hint_db.transparent_state db) [db] p end (** Binding to either V85 or Search implementations. *) @@ -1532,7 +1532,7 @@ let resolve_all_evars debug depth unique env p oevd do_split fail = if get_typeclasses_legacy_resolution () then V85.resolve_all_evars_once debug depth unique p evd else - Search.typeclasses_resolve debug depth unique p evd + Search.typeclasses_resolve env evd debug depth unique p in if has_undefined p oevd evd' then raise Unresolved; docomp evd' comps diff --git a/tactics/eauto.ml b/tactics/eauto.ml index 65864bd47..2b5bbfcd1 100644 --- a/tactics/eauto.ml +++ b/tactics/eauto.ml @@ -86,16 +86,16 @@ let rec prolog l n gl = let prol = (prolog l (n-1)) in (tclFIRST (List.map (fun t -> (tclTHEN t prol)) (one_step l gl))) gl -let out_term = function +let out_term env = function | IsConstr (c, _) -> c - | IsGlobRef gr -> EConstr.of_constr (fst (Universes.fresh_global_instance (Global.env ()) gr)) + | IsGlobRef gr -> EConstr.of_constr (fst (Universes.fresh_global_instance env gr)) let prolog_tac l n = Proofview.V82.tactic begin fun gl -> let map c = let (sigma, c) = c (pf_env gl) (project gl) in let c = pf_apply (prepare_hint false (false,true)) gl (sigma, c) in - out_term c + out_term (pf_env gl) c in let l = List.map map l in try (prolog l n gl) diff --git a/tactics/eqdecide.ml b/tactics/eqdecide.ml index d4cad3fa8..e16fcec7c 100644 --- a/tactics/eqdecide.ml +++ b/tactics/eqdecide.ml @@ -155,9 +155,9 @@ open Proofview.Notations (* spiwack: a PatternMatchingFailure wrapper around [Hipattern]. *) -let match_eqdec sigma c = +let match_eqdec env sigma c = try - let (eqonleft,_,c1,c2,ty) = match_eqdec sigma c in + let (eqonleft,_,c1,c2,ty) = match_eqdec env sigma c in let (op,eq1,noteq,eq2) = match EConstr.kind sigma c with | App (op,[|ty1;ty2|]) -> @@ -202,8 +202,9 @@ let solveEqBranch rectype = begin Proofview.Goal.enter begin fun gl -> let concl = pf_concl gl in + let env = Proofview.Goal.env gl in let sigma = project gl in - match_eqdec sigma concl >>= fun (eqonleft,mk,lhs,rhs,_) -> + match_eqdec env sigma concl >>= fun (eqonleft,mk,lhs,rhs,_) -> let (mib,mip) = Global.lookup_inductive rectype in let nparams = mib.mind_nparams in let getargs l = List.skipn nparams (snd (decompose_app sigma l)) in @@ -229,8 +230,9 @@ let decideGralEquality = begin Proofview.Goal.enter begin fun gl -> let concl = pf_concl gl in + let env = Proofview.Goal.env gl in let sigma = project gl in - match_eqdec sigma concl >>= fun (eqonleft,mk,c1,c2,typ as data) -> + match_eqdec env sigma concl >>= fun (eqonleft,mk,c1,c2,typ as data) -> let headtyp = hd_app sigma (pf_compute gl typ) in begin match EConstr.kind sigma headtyp with | Ind (mi,_) -> Proofview.tclUNIT mi diff --git a/tactics/equality.ml b/tactics/equality.ml index 66345ce43..3ea9538f3 100644 --- a/tactics/equality.ml +++ b/tactics/equality.ml @@ -334,25 +334,27 @@ let (forward_general_setoid_rewrite_clause, general_setoid_rewrite_clause) = Hoo (* Do we have a JMeq instance on twice the same domains ? *) -let jmeq_same_dom gl = function +let jmeq_same_dom env sigma = function | None -> true (* already checked in Hipattern.find_eq_data_decompose *) | Some t -> - let rels, t = decompose_prod_assum (project gl) t in - let env = push_rel_context rels (Proofview.Goal.env gl) in - match decompose_app (project gl) t with - | _, [dom1; _; dom2;_] -> is_conv env (Tacmach.New.project gl) dom1 dom2 + let rels, t = decompose_prod_assum sigma t in + let env = push_rel_context rels env in + match decompose_app sigma t with + | _, [dom1; _; dom2;_] -> is_conv env sigma dom1 dom2 | _ -> false (* find_elim determines which elimination principle is necessary to eliminate lbeq on sort_of_gl. *) -let find_elim hdcncl lft2rgt dep cls ot gl = +let find_elim hdcncl lft2rgt dep cls ot = + Proofview.Goal.enter_one begin fun gl -> let sigma = project gl in let is_global gr c = Termops.is_global sigma gr c in let inccl = Option.is_empty cls in + let env = Proofview.Goal.env gl in if (is_global Coqlib.glob_eq hdcncl || (is_global Coqlib.glob_jmeq hdcncl && - jmeq_same_dom gl ot)) && not dep + jmeq_same_dom env sigma ot)) && not dep then let c = match EConstr.kind sigma hdcncl with @@ -382,9 +384,7 @@ let find_elim hdcncl lft2rgt dep cls ot gl = Logic.eq or Jmeq just before *) assert false in - let (sigma, elim) = fresh_global (Global.env ()) (Proofview.Goal.sigma gl) (ConstRef c) in - let elim = EConstr.of_constr elim in - (sigma, (elim, Safe_typing.empty_private_constants)) + pf_constr_of_global (ConstRef c) else let scheme_name = match dep, lft2rgt, inccl with (* Non dependent case *) @@ -400,14 +400,12 @@ let find_elim hdcncl lft2rgt dep cls ot gl = in match EConstr.kind sigma hdcncl with | Ind (ind,u) -> + let c, eff = find_scheme scheme_name ind in - (* MS: cannot use pf_constr_of_global as the eliminator might be generated by side-effect *) - let (sigma, elim) = - fresh_global (Global.env ()) (Proofview.Goal.sigma gl) (ConstRef c) - in - let elim = EConstr.of_constr elim in - (sigma, (elim, eff)) + Proofview.tclEFFECTS eff <*> + pf_constr_of_global (ConstRef c) | _ -> assert false + end let type_of_clause cls gl = match cls with | None -> Proofview.Goal.concl gl @@ -420,9 +418,7 @@ let leibniz_rewrite_ebindings_clause cls lft2rgt tac c t l with_evars frzevars d let dep_fun = if isatomic then dependent else dependent_no_evar in let type_of_cls = type_of_clause cls gl in let dep = dep_proof_ok && dep_fun evd c type_of_cls in - let (sigma, (elim, effs)) = find_elim hdcncl lft2rgt dep cls (Some t) gl in - Proofview.Unsafe.tclEVARS sigma <*> - Proofview.tclEFFECTS effs <*> + find_elim hdcncl lft2rgt dep cls (Some t) >>= fun elim -> general_elim_clause with_evars frzevars tac cls c t l (match lft2rgt with None -> false | Some b -> b) {elimindex = None; elimbody = (elim,NoBindings); elimrename = None} @@ -536,7 +532,7 @@ let general_rewrite_clause l2r with_evars ?tac c cl = let do_hyps = (* If the term to rewrite uses an hypothesis H, don't rewrite in H *) let ids gl = - let ids_in_c = Termops.global_vars_set (Global.env()) (project gl) (fst c) in + let ids_in_c = Termops.global_vars_set (Proofview.Goal.env gl) (project gl) (fst c) in let ids_of_hyps = pf_ids_of_hyps gl in Id.Set.fold (fun id l -> List.remove Id.equal id l) ids_in_c ids_of_hyps in @@ -858,7 +854,8 @@ let descend_then env sigma head dirn = let IndType (indf,_) = try find_rectype env sigma (get_type_of env sigma head) with Not_found -> - user_err Pp.(str "Cannot project on an inductive type derived from a dependency.") in + user_err Pp.(str "Cannot project on an inductive type derived from a dependency.") + in let indp,_ = (dest_ind_family indf) in let ind, _ = check_privacy env indp in let (mib,mip) = lookup_mind_specif env ind in @@ -880,7 +877,7 @@ let descend_then env sigma head dirn = List.map build_branch (List.interval 1 (Array.length mip.mind_consnames)) in let ci = make_case_info env ind RegularStyle in - sigma, Inductiveops.make_case_or_project env sigma indf ci p head (Array.of_list brl))) + Inductiveops.make_case_or_project env sigma indf ci p head (Array.of_list brl))) (* Now we need to construct the discriminator, given a discriminable position. This boils down to: @@ -925,23 +922,21 @@ let build_selector env sigma dirn c ind special default = let brl = List.map build_branch(List.interval 1 (Array.length mip.mind_consnames)) in let ci = make_case_info env ind RegularStyle in - sigma, mkCase (ci, p, c, Array.of_list brl) + let ans = Inductiveops.make_case_or_project env sigma indf ci p c (Array.of_list brl) in + ans -let build_coq_False sigma = Evarutil.new_global sigma (build_coq_False ()) -let build_coq_True sigma = Evarutil.new_global sigma (build_coq_True ()) -let build_coq_I sigma = Evarutil.new_global sigma (build_coq_I ()) +let build_coq_False () = pf_constr_of_global (build_coq_False ()) +let build_coq_True () = pf_constr_of_global (build_coq_True ()) +let build_coq_I () = pf_constr_of_global (build_coq_I ()) -let rec build_discriminator env sigma dirn c = function +let rec build_discriminator env sigma true_0 false_0 dirn c = function | [] -> let ind = get_type_of env sigma c in - let sigma, true_0 = build_coq_True sigma in - let sigma, false_0 = build_coq_False sigma in build_selector env sigma dirn c ind true_0 false_0 | ((sp,cnum),argnum)::l -> - let sigma, false_0 = build_coq_False sigma in let (cnum_nlams,cnum_env,kont) = descend_then env sigma c cnum in let newc = mkRel(cnum_nlams-argnum) in - let sigma, subval = build_discriminator cnum_env sigma dirn newc l in + let subval = build_discriminator cnum_env sigma true_0 false_0 dirn newc l in kont sigma subval (false_0,mkSort (Prop Null)) (* Note: discrimination could be more clever: if some elimination is @@ -984,14 +979,15 @@ let ind_scheme_of_eq lbeq = ConstRef c, eff -let discrimination_pf env sigma e (t,t1,t2) discriminator lbeq = - let sigma, i = build_coq_I sigma in - let sigma, absurd_term = build_coq_False sigma in +let discrimination_pf e (t,t1,t2) discriminator lbeq = + build_coq_I () >>= fun i -> + build_coq_False () >>= fun absurd_term -> let eq_elim, eff = ind_scheme_of_eq lbeq in - let sigma, eq_elim = Evd.fresh_global (Global.env ()) sigma eq_elim in - let eq_elim = EConstr.of_constr eq_elim in - sigma, (applist (eq_elim, [t;t1;mkNamedLambda e t discriminator;i;t2]), absurd_term), - eff + Proofview.tclEFFECTS eff <*> + pf_constr_of_global eq_elim >>= fun eq_elim -> + Proofview.tclUNIT + (applist (eq_elim, [t;t1;mkNamedLambda e t discriminator;i;t2]), absurd_term) + let eq_baseid = Id.of_string "e" @@ -1005,19 +1001,24 @@ let apply_on_clause (f,t) clause = clenv_fchain ~with_univs:false argmv f_clause clause let discr_positions env sigma (lbeq,eqn,(t,t1,t2)) eq_clause cpath dirn = + build_coq_True () >>= fun true_0 -> + build_coq_False () >>= fun false_0 -> let e = next_ident_away eq_baseid (ids_of_context env) in let e_env = push_named (Context.Named.Declaration.LocalAssum (e,t)) env in - let sigma, discriminator = - build_discriminator e_env sigma dirn (mkVar e) cpath in - let sigma,(pf, absurd_term), eff = - discrimination_pf env sigma e (t,t1,t2) discriminator lbeq in - let pf_ty = mkArrow eqn absurd_term in - let absurd_clause = apply_on_clause (pf,pf_ty) eq_clause in - let pf = Clenvtac.clenv_value_cast_meta absurd_clause in - Proofview.Unsafe.tclEVARS sigma <*> - Proofview.tclEFFECTS eff <*> - tclTHENS (assert_after Anonymous absurd_term) - [onLastHypId gen_absurdity; (Proofview.V82.tactic (Tacmach.refine pf))] + let discriminator = + try + Proofview.tclUNIT + (build_discriminator e_env sigma true_0 false_0 dirn (mkVar e) cpath) + with + UserError _ as ex -> Proofview.tclZERO ex + in + discriminator >>= fun discriminator -> + discrimination_pf e (t,t1,t2) discriminator lbeq >>= fun (pf, absurd_term) -> + let pf_ty = mkArrow eqn absurd_term in + let absurd_clause = apply_on_clause (pf,pf_ty) eq_clause in + let pf = Clenvtac.clenv_value_cast_meta absurd_clause in + tclTHENS (assert_after Anonymous absurd_term) + [onLastHypId gen_absurdity; (Proofview.V82.tactic (Tacmach.refine pf))] let discrEq (lbeq,_,(t,t1,t2) as u) eq_clause = let sigma = eq_clause.evd in @@ -1303,7 +1304,7 @@ let rec build_injrec env sigma dflt c = function let (cnum_nlams,cnum_env,kont) = descend_then env sigma c cnum in let newc = mkRel(cnum_nlams-argnum) in let sigma, (subval,tuplety,dfltval) = build_injrec cnum_env sigma dflt newc l in - let sigma, res = kont sigma subval (dfltval,tuplety) in + let res = kont sigma subval (dfltval,tuplety) in sigma, (res, tuplety,dfltval) with UserError _ -> failwith "caught" @@ -1536,7 +1537,7 @@ let decomp_tuple_term env sigma c t = let rec decomprec inner_code ex exty = let iterated_decomp = try - let ({proj1=p1; proj2=p2}),(i,a,p,car,cdr) = find_sigma_data_decompose sigma ex in + let ({proj1=p1; proj2=p2}),(i,a,p,car,cdr) = find_sigma_data_decompose env sigma ex in let car_code = applist (mkConstU (destConstRef p1,i),[a;p;inner_code]) and cdr_code = applist (mkConstU (destConstRef p2,i),[a;p;inner_code]) in let cdrtyp = beta_applist sigma (p,[car]) in diff --git a/tactics/equality.mli b/tactics/equality.mli index 421f7c7f5..a4d1c0f9b 100644 --- a/tactics/equality.mli +++ b/tactics/equality.mli @@ -126,4 +126,4 @@ val set_eq_dec_scheme_kind : mutual scheme_kind -> unit (* [build_selector env sigma i c t u v] matches on [c] of type [t] and returns [u] in branch [i] and [v] on other branches *) val build_selector : env -> evar_map -> int -> constr -> types -> - constr -> constr -> evar_map * constr + constr -> constr -> constr diff --git a/tactics/hipattern.ml b/tactics/hipattern.ml index 4101004d4..75fae6647 100644 --- a/tactics/hipattern.ml +++ b/tactics/hipattern.ml @@ -252,16 +252,16 @@ open Decl_kinds open Evar_kinds let mkPattern c = snd (Patternops.pattern_of_glob_constr c) -let mkGApp f args = CAst.make @@ GApp (f, args) -let mkGHole = CAst.make @@ +let mkGApp f args = DAst.make @@ GApp (f, args) +let mkGHole = DAst.make @@ GHole (QuestionMark (Define false,Anonymous), Misctypes.IntroAnonymous, None) -let mkGProd id c1 c2 = CAst.make @@ +let mkGProd id c1 c2 = DAst.make @@ GProd (Name (Id.of_string id), Explicit, c1, c2) -let mkGArrow c1 c2 = CAst.make @@ +let mkGArrow c1 c2 = DAst.make @@ GProd (Anonymous, Explicit, c1, c2) -let mkGVar id = CAst.make @@ GVar (Id.of_string id) -let mkGPatVar id = CAst.make @@ GPatVar(Evar_kinds.FirstOrderPatVar (Id.of_string id)) -let mkGRef r = CAst.make @@ GRef (Lazy.force r, None) +let mkGVar id = DAst.make @@ GVar (Id.of_string id) +let mkGPatVar id = DAst.make @@ GPatVar(Evar_kinds.FirstOrderPatVar (Id.of_string id)) +let mkGRef r = DAst.make @@ GRef (Lazy.force r, None) let mkGAppRef r args = mkGApp (mkGRef r) args (** forall x : _, _ x x *) @@ -280,10 +280,7 @@ let coq_refl_jm_pattern = open Globnames -let is_matching sigma x y = is_matching (Global.env ()) sigma x y -let matches sigma x y = matches (Global.env ()) sigma x y - -let match_with_equation sigma t = +let match_with_equation env sigma t = if not (isApp sigma t) then raise NoEquationFound; let (hdapp,args) = destApp sigma t in match EConstr.kind sigma hdapp with @@ -302,11 +299,11 @@ let match_with_equation sigma t = let constr_types = mip.mind_nf_lc in let nconstr = Array.length mip.mind_consnames in if Int.equal nconstr 1 then - if is_matching sigma coq_refl_leibniz1_pattern (EConstr.of_constr constr_types.(0)) then + if is_matching env sigma coq_refl_leibniz1_pattern (EConstr.of_constr constr_types.(0)) then None, hdapp, MonomorphicLeibnizEq(args.(0),args.(1)) - else if is_matching sigma coq_refl_leibniz2_pattern (EConstr.of_constr constr_types.(0)) then + else if is_matching env sigma coq_refl_leibniz2_pattern (EConstr.of_constr constr_types.(0)) then None, hdapp, PolymorphicLeibnizEq(args.(0),args.(1),args.(2)) - else if is_matching sigma coq_refl_jm_pattern (EConstr.of_constr constr_types.(0)) then + else if is_matching env sigma coq_refl_jm_pattern (EConstr.of_constr constr_types.(0)) then None, hdapp, HeterogenousEq(args.(0),args.(1),args.(2),args.(3)) else raise NoEquationFound else raise NoEquationFound @@ -335,8 +332,8 @@ let is_equality_type sigma t = op2bool (match_with_equality_type sigma t) (** X1 -> X2 **) let coq_arrow_pattern = mkPattern (mkGArrow (mkGPatVar "X1") (mkGPatVar "X2")) -let match_arrow_pattern sigma t = - let result = matches sigma coq_arrow_pattern t in +let match_arrow_pattern env sigma t = + let result = matches env sigma coq_arrow_pattern t in match Id.Map.bindings result with | [(m1,arg);(m2,mind)] -> assert (Id.equal m1 meta1 && Id.equal m2 meta2); (arg, mind) @@ -349,13 +346,13 @@ let match_with_imp_term sigma c = let is_imp_term sigma c = op2bool (match_with_imp_term sigma c) -let match_with_nottype sigma t = +let match_with_nottype env sigma t = try - let (arg,mind) = match_arrow_pattern sigma t in + let (arg,mind) = match_arrow_pattern env sigma t in if is_empty_type sigma mind then Some (mind,arg) else None with PatternMatchingFailure -> None -let is_nottype sigma t = op2bool (match_with_nottype sigma t) +let is_nottype env sigma t = op2bool (match_with_nottype env sigma t) (* Forall *) @@ -481,7 +478,7 @@ let dest_nf_eq gls eqn = (*** Sigma-types *) -let match_sigma sigma ex = +let match_sigma env sigma ex = match EConstr.kind sigma ex with | App (f, [| a; p; car; cdr |]) when Termops.is_global sigma (Lazy.force coq_exist_ref) f -> build_sigma (), (snd (destConstruct sigma f), a, p, car, cdr) @@ -489,19 +486,19 @@ let match_sigma sigma ex = build_sigma_type (), (snd (destConstruct sigma f), a, p, car, cdr) | _ -> raise PatternMatchingFailure -let find_sigma_data_decompose ex = (* fails with PatternMatchingFailure *) - match_sigma ex +let find_sigma_data_decompose env ex = (* fails with PatternMatchingFailure *) + match_sigma env ex (* Pattern "(sig ?1 ?2)" *) let coq_sig_pattern = lazy (mkPattern (mkGAppRef coq_sig_ref [mkGPatVar "X1"; mkGPatVar "X2"])) -let match_sigma sigma t = - match Id.Map.bindings (matches sigma (Lazy.force coq_sig_pattern) t) with +let match_sigma env sigma t = + match Id.Map.bindings (matches env sigma (Lazy.force coq_sig_pattern) t) with | [(_,a); (_,p)] -> (a,p) | _ -> anomaly (Pp.str "Unexpected pattern.") -let is_matching_sigma sigma t = is_matching sigma (Lazy.force coq_sig_pattern) t +let is_matching_sigma env sigma t = is_matching env sigma (Lazy.force coq_sig_pattern) t (*** Decidable equalities *) @@ -533,15 +530,15 @@ let coq_eqdec_rev_pattern = coq_eqdec ~sum:coq_or_ref ~rev:true let op_or = coq_or_ref let op_sum = coq_sumbool_ref -let match_eqdec sigma t = +let match_eqdec env sigma t = let eqonleft,op,subst = - try true,op_sum,matches sigma (Lazy.force coq_eqdec_inf_pattern) t + try true,op_sum,matches env sigma (Lazy.force coq_eqdec_inf_pattern) t with PatternMatchingFailure -> - try false,op_sum,matches sigma (Lazy.force coq_eqdec_inf_rev_pattern) t + try false,op_sum,matches env sigma (Lazy.force coq_eqdec_inf_rev_pattern) t with PatternMatchingFailure -> - try true,op_or,matches sigma (Lazy.force coq_eqdec_pattern) t + try true,op_or,matches env sigma (Lazy.force coq_eqdec_pattern) t with PatternMatchingFailure -> - false,op_or,matches sigma (Lazy.force coq_eqdec_rev_pattern) t in + false,op_or,matches env sigma (Lazy.force coq_eqdec_rev_pattern) t in match Id.Map.bindings subst with | [(_,typ);(_,c1);(_,c2)] -> eqonleft, Lazy.force op, c1, c2, typ @@ -551,8 +548,8 @@ let match_eqdec sigma t = let coq_not_pattern = lazy (mkPattern (mkGAppRef coq_not_ref [mkGHole])) let coq_imp_False_pattern = lazy (mkPattern (mkGArrow mkGHole (mkGRef coq_False_ref))) -let is_matching_not sigma t = is_matching sigma (Lazy.force coq_not_pattern) t -let is_matching_imp_False sigma t = is_matching sigma (Lazy.force coq_imp_False_pattern) t +let is_matching_not env sigma t = is_matching env sigma (Lazy.force coq_not_pattern) t +let is_matching_imp_False env sigma t = is_matching env sigma (Lazy.force coq_imp_False_pattern) t (* Remark: patterns that have references to the standard library must be evaluated lazily (i.e. at the time they are used, not a the time diff --git a/tactics/hipattern.mli b/tactics/hipattern.mli index 59406e158..8ff6fe95c 100644 --- a/tactics/hipattern.mli +++ b/tactics/hipattern.mli @@ -81,8 +81,8 @@ val is_inductive_equality : inductive -> bool val match_with_equality_type : (constr * constr list) matching_function val is_equality_type : testing_function -val match_with_nottype : (constr * constr) matching_function -val is_nottype : testing_function +val match_with_nottype : Environ.env -> (constr * constr) matching_function +val is_nottype : Environ.env -> testing_function val match_with_forall_term : (Name.t * constr * constr) matching_function val is_forall_term : testing_function @@ -114,7 +114,7 @@ type equation_kind = exception NoEquationFound val match_with_equation: - evar_map -> constr -> coq_eq_data option * constr * equation_kind + Environ.env -> evar_map -> constr -> coq_eq_data option * constr * equation_kind (***** Destructing patterns bound to some theory *) @@ -132,21 +132,21 @@ val find_eq_data : evar_map -> constr -> coq_eq_data * EInstance.t * equation_ki (** Match a term of the form [(existT A P t p)] Returns associated lemmas and [A,P,t,p] *) -val find_sigma_data_decompose : evar_map -> constr -> +val find_sigma_data_decompose : Environ.env -> evar_map -> constr -> coq_sigma_data * (EInstance.t * constr * constr * constr * constr) (** Match a term of the form [{x:A|P}], returns [A] and [P] *) -val match_sigma : evar_map -> constr -> constr * constr +val match_sigma : Environ.env -> evar_map -> constr -> constr * constr -val is_matching_sigma : evar_map -> constr -> bool +val is_matching_sigma : Environ.env -> evar_map -> constr -> bool (** Match a decidable equality judgement (e.g [{t=u:>T}+{~t=u}]), returns [t,u,T] and a boolean telling if equality is on the left side *) -val match_eqdec : evar_map -> constr -> bool * Globnames.global_reference * constr * constr * constr +val match_eqdec : Environ.env -> evar_map -> constr -> bool * Globnames.global_reference * constr * constr * constr (** Match an equality up to conversion; returns [(eq,t1,t2)] in normal form *) val dest_nf_eq : 'a Proofview.Goal.t -> constr -> (constr * constr * constr) (** Match a negation *) -val is_matching_not : evar_map -> constr -> bool -val is_matching_imp_False : evar_map -> constr -> bool +val is_matching_not : Environ.env -> evar_map -> constr -> bool +val is_matching_imp_False : Environ.env -> evar_map -> constr -> bool diff --git a/tactics/tactics.ml b/tactics/tactics.ml index 82d58074b..67bc55d3f 100644 --- a/tactics/tactics.ml +++ b/tactics/tactics.ml @@ -436,19 +436,85 @@ let find_name mayrepl decl naming gl = match naming with id (**************************************************************) +(* Computing position of hypotheses for replacing *) +(**************************************************************) + +let get_next_hyp_position id = + let rec aux = function + | [] -> error_no_such_hypothesis id + | decl :: right -> + if Id.equal (NamedDecl.get_id decl) id then + match right with decl::_ -> MoveBefore (NamedDecl.get_id decl) | [] -> MoveFirst + else + aux right + in + aux + +let get_previous_hyp_position id = + let rec aux dest = function + | [] -> error_no_such_hypothesis id + | decl :: right -> + let hyp = NamedDecl.get_id decl in + if Id.equal hyp id then dest else aux (MoveAfter hyp) right + in + aux MoveLast + +(**************************************************************) (* Cut rule *) (**************************************************************) +let clear_hyps2 env sigma ids sign t cl = + try + let evdref = ref (Evd.clear_metas sigma) in + let (hyps,t,cl) = Evarutil.clear_hyps2_in_evi env evdref sign t cl ids in + (hyps, t, cl, !evdref) + with Evarutil.ClearDependencyError (id,err) -> + error_replacing_dependency env sigma id err + +let internal_cut_gen ?(check=true) dir replace id t = + Proofview.Goal.enter begin fun gl -> + let env = Proofview.Goal.env gl in + let sigma = Tacmach.New.project gl in + let concl = Proofview.Goal.concl gl in + let store = Proofview.Goal.extra gl in + let sign = named_context_val env in + let sign',t,concl,sigma = + if replace then + let nexthyp = get_next_hyp_position id (named_context_of_val sign) in + let sign',t,concl,sigma = clear_hyps2 env sigma (Id.Set.singleton id) sign t concl in + let sign' = insert_decl_in_named_context sigma (LocalAssum (id,t)) nexthyp sign' in + sign',t,concl,sigma + else + (if check && mem_named_context_val id sign then + user_err (str "Variable " ++ pr_id id ++ str " is already declared."); + push_named_context_val (LocalAssum (id,t)) sign,t,concl,sigma) in + let nf_t = nf_betaiota sigma t in + Proofview.tclTHEN + (Proofview.Unsafe.tclEVARS sigma) + (Refine.refine ~typecheck:false begin fun sigma -> + let (sigma,ev,ev') = + if dir then + let (sigma, ev) = Evarutil.new_evar_from_context sign sigma nf_t in + let (sigma, ev') = Evarutil.new_evar_from_context sign' sigma ~principal:true ~store concl in + (sigma,ev,ev') + else + let (sigma, ev') = Evarutil.new_evar_from_context sign' sigma ~principal:true ~store concl in + let (sigma, ev) = Evarutil.new_evar_from_context sign sigma nf_t in + (sigma,ev,ev') in + let term = mkLetIn (Name id, ev, t, EConstr.Vars.subst_var id ev') in + (sigma, term) + end) + end + +let internal_cut ?(check=true) = internal_cut_gen ~check true +let internal_cut_rev ?(check=true) = internal_cut_gen ~check false + let assert_before_then_gen b naming t tac = let open Context.Rel.Declaration in Proofview.Goal.enter begin fun gl -> let id = find_name b (LocalAssum (Anonymous,t)) naming gl in Tacticals.New.tclTHENLAST - (Proofview.V82.tactic - (fun gl -> - try Tacmach.internal_cut b id t gl - with Evarutil.ClearDependencyError (id,err) -> - error_replacing_dependency (pf_env gl) (project gl) id err)) + (internal_cut b id t) (tac id) end @@ -463,11 +529,7 @@ let assert_after_then_gen b naming t tac = Proofview.Goal.enter begin fun gl -> let id = find_name b (LocalAssum (Anonymous,t)) naming gl in Tacticals.New.tclTHENFIRST - (Proofview.V82.tactic - (fun gl -> - try Tacmach.internal_cut_rev b id t gl - with Evarutil.ClearDependencyError (id,err) -> - error_replacing_dependency (pf_env gl) (project gl) id err)) + (internal_cut_rev b id t) (tac id) end @@ -999,29 +1061,10 @@ let intro_forthcoming_then_gen name_flag move_flag dep_flag n bound tac = in aux n [] -let get_next_hyp_position id gl = - let rec aux = function - | [] -> raise (RefinerError (NoSuchHyp id)) - | decl :: right -> - if Id.equal (NamedDecl.get_id decl) id then - match right with decl::_ -> MoveBefore (NamedDecl.get_id decl) | [] -> MoveLast - else - aux right - in - aux (Proofview.Goal.hyps (Proofview.Goal.assume gl)) - -let get_previous_hyp_position id gl = - let rec aux dest = function - | [] -> raise (RefinerError (NoSuchHyp id)) - | decl :: right -> - let hyp = NamedDecl.get_id decl in - if Id.equal hyp id then dest else aux (MoveAfter hyp) right - in - aux MoveLast (Proofview.Goal.hyps (Proofview.Goal.assume gl)) - let intro_replacing id = Proofview.Goal.enter begin fun gl -> - let next_hyp = get_next_hyp_position id gl in + let hyps = Proofview.Goal.hyps (Proofview.Goal.assume gl) in + let next_hyp = get_next_hyp_position id hyps in Tacticals.New.tclTHENLIST [ clear_for_replacing [id]; introduction id; @@ -1040,7 +1083,8 @@ let intro_replacing id = let intros_possibly_replacing ids = let suboptimal = true in Proofview.Goal.enter begin fun gl -> - let posl = List.map (fun id -> (id, get_next_hyp_position id gl)) ids in + let hyps = Proofview.Goal.hyps (Proofview.Goal.assume gl) in + let posl = List.map (fun id -> (id, get_next_hyp_position id hyps)) ids in Tacticals.New.tclTHEN (Tacticals.New.tclMAP (fun id -> Tacticals.New.tclTRY (clear_for_replacing [id])) @@ -1053,7 +1097,8 @@ let intros_possibly_replacing ids = (* This version assumes that replacement is actually possible *) let intros_replacing ids = Proofview.Goal.enter begin fun gl -> - let posl = List.map (fun id -> (id, get_next_hyp_position id gl)) ids in + let hyps = Proofview.Goal.hyps (Proofview.Goal.assume gl) in + let posl = List.map (fun id -> (id, get_next_hyp_position id hyps)) ids in Tacticals.New.tclTHEN (clear_for_replacing ids) (Tacticals.New.tclMAP (fun (id,pos) -> intro_move (Some id) pos) posl) @@ -2578,7 +2623,8 @@ let general_apply_in sidecond_first with_delta with_destruct with_evars Proofview.Goal.enter begin fun gl -> let destopt = if with_evars then MoveLast (* evars would depend on the whole context *) - else get_previous_hyp_position id gl in + else + get_previous_hyp_position id (Proofview.Goal.hyps (Proofview.Goal.assume gl)) in let naming,ipat_tac = prepare_intros_opt with_evars (IntroIdentifier id) destopt ipat in let lemmas_target, last_lemma_target = @@ -3074,17 +3120,17 @@ let expand_hyp id = Tacticals.New.tclTRY (unfold_body id) <*> clear [id] *) -let warn_unused_intro_pattern = +let warn_unused_intro_pattern env sigma = CWarnings.create ~name:"unused-intro-pattern" ~category:"tactics" (fun names -> strbrk"Unused introduction " ++ str (String.plural (List.length names) "pattern") ++ str": " ++ prlist_with_sep spc (Miscprint.pr_intro_pattern - (fun c -> Printer.pr_econstr (snd (c (Global.env()) Evd.empty)))) names) + (fun c -> Printer.pr_econstr (snd (c env sigma)))) names) -let check_unused_names names = +let check_unused_names env sigma names = if not (List.is_empty names) then - warn_unused_intro_pattern names + warn_unused_intro_pattern env sigma names let intropattern_of_name gl avoid = function | Anonymous -> IntroNaming IntroAnonymous @@ -3204,8 +3250,12 @@ let induct_discharge with_evars dests avoid' tac (avoid,ra) names = peel_tac ra' dests names thin) end | [] -> - check_unused_names names; + Proofview.Goal.enter begin fun gl -> + let env = Proofview.Goal.env gl in + let sigma = Proofview.Goal.sigma gl in + check_unused_names env sigma names; Tacticals.New.tclTHEN (clear_wildcards thin) (tac dests) + end in peel_tac ra dests names [] @@ -3272,7 +3322,7 @@ let atomize_param_of_ind_then (indref,nparams,_) hyp0 tac = | Var id -> id | _ -> let type_of = Tacmach.New.pf_unsafe_type_of gl in - id_of_name_using_hdchar (Global.env()) sigma (type_of c) Anonymous in + id_of_name_using_hdchar env sigma (type_of c) Anonymous in let x = fresh_id_in_env avoid id env in Tacticals.New.tclTHEN (letin_tac None (Name x) c None allHypsAndConcl) @@ -3805,11 +3855,12 @@ let compare_upto_variables sigma x y = in compare x y -let specialize_eqs id gl = +let specialize_eqs id = let open Context.Rel.Declaration in - let env = Tacmach.pf_env gl in - let ty = Tacmach.pf_get_hyp_typ gl id in - let evars = ref (project gl) in + Proofview.Goal.enter begin fun gl -> + let env = Proofview.Goal.env gl in + let ty = Tacmach.New.pf_get_hyp_typ id gl in + let evars = ref (Proofview.Goal.sigma gl) in let unif env evars c1 c2 = compare_upto_variables !evars c1 c2 && Evarconv.e_conv env evars c1 c2 in @@ -3852,16 +3903,18 @@ let specialize_eqs id gl = and acc' = Tacred.whd_simpl env !evars acc' in let ty' = Evarutil.nf_evar !evars ty' in if worked then - tclTHENFIRST (Tacmach.internal_cut true id ty') - (Proofview.V82.of_tactic (exact_no_check ((* refresh_universes_strict *) acc'))) gl - else tclFAIL 0 (str "Nothing to do in hypothesis " ++ pr_id id) gl - + Tacticals.New.tclTHENFIRST + (internal_cut true id ty') + (exact_no_check ((* refresh_universes_strict *) acc')) + else + Tacticals.New.tclFAIL 0 (str "Nothing to do in hypothesis " ++ pr_id id) + end let specialize_eqs id = Proofview.Goal.enter begin fun gl -> let msg = str "Specialization not allowed on dependent hypotheses" in Proofview.tclOR (clear [id]) (fun _ -> Tacticals.New.tclZEROMSG msg) >>= fun () -> - Proofview.V82.tactic (specialize_eqs id) + specialize_eqs id end let occur_rel sigma n c = @@ -4485,7 +4538,7 @@ let induction_gen clear_flag isrec with_evars elim declaring the induction argument as a new local variable *) let id = (* Type not the right one if partially applied but anyway for internal use*) - let x = id_of_name_using_hdchar (Global.env()) evd t Anonymous in + let x = id_of_name_using_hdchar env evd t Anonymous in new_fresh_id [] x gl in let info_arg = (is_arg_pure_hyp, not enough_applied) in pose_induction_arg_then @@ -4521,8 +4574,9 @@ let induction_gen_l isrec with_evars elim names lc = Proofview.Goal.enter begin fun gl -> let type_of = Tacmach.New.pf_unsafe_type_of gl in let sigma = Tacmach.New.project gl in + Proofview.tclENV >>= fun env -> let x = - id_of_name_using_hdchar (Global.env()) sigma (type_of c) Anonymous in + id_of_name_using_hdchar env sigma (type_of c) Anonymous in let id = new_fresh_id [] x gl in let newl' = List.map (fun r -> replace_term sigma c (mkVar id) r) l' in @@ -4741,8 +4795,9 @@ let prove_symmetry hdcncl eq_kind = one_constructor 1 NoBindings ]) let match_with_equation sigma c = + Proofview.tclENV >>= fun env -> try - let res = match_with_equation sigma c in + let res = match_with_equation env sigma c in Proofview.tclUNIT res with NoEquationFound -> Proofview.tclZERO NoEquationFound diff --git a/test-suite/Makefile b/test-suite/Makefile index beb80a3df..ae426f0da 100644 --- a/test-suite/Makefile +++ b/test-suite/Makefile @@ -33,6 +33,7 @@ BIN := $(shell cd ..; pwd)/bin/ coqtop := $(BIN)coqtop -coqlib $(LIB) -boot -q -batch -test-mode -R prerequisite TestSuite coqc := $(BIN)coqc -coqlib $(LIB) -R prerequisite TestSuite coqchk := $(BIN)coqchk -coqlib $(LIB) -R prerequisite TestSuite +coqdoc := $(BIN)coqdoc coqtopbyte := $(BIN)coqtop.byte coqtopload := $(coqtop) -top Top -async-proofs-cache force -load-vernac-source @@ -84,8 +85,11 @@ COMPLEXITY := $(if $(bogomips),complexity) BUGS := bugs/opened bugs/closed +INTERACTIVE := interactive + VSUBSYSTEMS := prerequisite success failure $(BUGS) output \ - output-modulo-time interactive micromega $(COMPLEXITY) modules stm + output-modulo-time $(INTERACTIVE) micromega $(COMPLEXITY) modules stm \ + coqdoc # All subsystems SUBSYSTEMS := $(VSUBSYSTEMS) misc bugs ide vio coqchk coq-makefile @@ -153,6 +157,7 @@ summary: $(call summary_dir, "VI tests", vio); \ $(call summary_dir, "Coqchk tests", coqchk); \ $(call summary_dir, "Coq makefile", coq-makefile); \ + $(call summary_dir, "Coqdoc tests", coqdoc); \ nb_success=`find . -name '*.log' -exec tail -n2 '{}' \; | grep -e $(log_success) | wc -l`; \ nb_failure=`find . -name '*.log' -exec tail -n2 '{}' \; | grep -e $(log_failure) | wc -l`; \ nb_tests=`expr $$nb_success + $$nb_failure`; \ @@ -456,6 +461,8 @@ ide : $(patsubst %.fake,%.fake.log,$(wildcard ide/*.fake)) fi; \ } > "$@" +# vio compilation + vio: $(patsubst %.v,%.vio.log,$(wildcard vio/*.v)) %.vio.log:%.v @@ -473,6 +480,8 @@ vio: $(patsubst %.v,%.vio.log,$(wildcard vio/*.v)) fi; \ } > "$@" +# coqchk + coqchk: $(patsubst %.v,%.chk.log,$(wildcard coqchk/*.v)) %.chk.log:%.v @@ -489,6 +498,8 @@ coqchk: $(patsubst %.v,%.chk.log,$(wildcard coqchk/*.v)) fi; \ } > "$@" +# coq_makefile + coq-makefile: $(patsubst %/run.sh,%.log,$(wildcard coq-makefile/*/run.sh)) coq-makefile/%.log : coq-makefile/%/run.sh @@ -505,3 +516,27 @@ coq-makefile/%.log : coq-makefile/%/run.sh echo " $<...Error!"; \ fi; \ ) > "$@" + +# coqdoc + +coqdoc: $(patsubst %.sh,%.log,$(wildcard coqdoc/*.sh)) + +$(addsuffix .log,$(wildcard coqdoc/*.v)): %.v.log: %.v %.html.out %.tex.out $(PREREQUISITELOG) + @echo "TEST $< $(call get_coq_prog_args_in_parens,"$<")" + $(HIDE){ \ + echo $(call log_intro,$<); \ + $(coqc) -R coqdoc Coqdoc $* 2>&1; \ + cd coqdoc; \ + f=`basename $*`; \ + $(coqdoc) -R . Coqdoc -coqlib http://coq.inria.fr/stdlib --html $$f.v; \ + $(coqdoc) -R . Coqdoc -coqlib http://coq.inria.fr/stdlib --latex $$f.v; \ + diff -u --strip-trailing-cr $$f.html.out Coqdoc.$$f.html 2>&1; R=$$?; times; \ + grep -v "^%%" Coqdoc.$$f.tex | diff -u --strip-trailing-cr $$f.tex.out - 2>&1; S=$$?; times; \ + if [ $$R = 0 -a $$S = 0 ]; then \ + echo $(log_success); \ + echo " $<...Ok"; \ + else \ + echo $(log_failure); \ + echo " $<...Error! (unexpected output)"; \ + fi; \ + } > "$@" diff --git a/test-suite/bugs/closed/1859.v b/test-suite/bugs/closed/1859.v new file mode 100644 index 000000000..43acfe4ba --- /dev/null +++ b/test-suite/bugs/closed/1859.v @@ -0,0 +1,20 @@ +Require Import Ring. +Require Import ArithRing. + +Ltac ring_simplify_neq := + match goal with + | [ H: ?X <> ?Y |- _ ] => progress ring_simplify X Y in H + end. + +Lemma toto : forall x y, x*1 <> y*1 -> y*1 <> x*1 -> x<>y. +Proof. + intros. + ring_simplify_neq. + ring_simplify_neq. + (* make sure ring_simplify has simplified both hypotheses *) + match goal with + | [ H: context[_*1] |- _ ] => fail 1 + | _ => idtac + end. + auto. +Qed. diff --git a/test-suite/bugs/closed/5245.v b/test-suite/bugs/closed/5245.v new file mode 100644 index 000000000..77bf169e1 --- /dev/null +++ b/test-suite/bugs/closed/5245.v @@ -0,0 +1,18 @@ +Set Primitive Projections. + +Record foo := Foo { + foo_car : Type; + foo_rel : foo_car -> foo_car -> Prop +}. +Arguments foo_rel : simpl never. + +Definition foo_fun {A B} := Foo (A -> B) (fun f g => forall x, f x = g x). + +Goal @foo_rel foo_fun (fun x : nat => x) (fun x => x). +Proof. +intros x; exact eq_refl. +Undo. +progress hnf; intros; exact eq_refl. +Undo. +unfold foo_rel. intros x. exact eq_refl. +Qed.
\ No newline at end of file diff --git a/test-suite/bugs/closed/5469.v b/test-suite/bugs/closed/5469.v deleted file mode 100644 index fce671c75..000000000 --- a/test-suite/bugs/closed/5469.v +++ /dev/null @@ -1,3 +0,0 @@ -(* Some problems with the special treatment of curly braces *) - -Reserved Notation "'a' { x }" (at level 0, format "'a' { x }"). diff --git a/test-suite/bugs/closed/5598.v b/test-suite/bugs/closed/5598.v new file mode 100644 index 000000000..55fef1a57 --- /dev/null +++ b/test-suite/bugs/closed/5598.v @@ -0,0 +1,8 @@ +(* Checking when discharge of an existing class is possible *) +Section foo. + Context {T} (a : T) (b : T). + Let k := eq_refl a. + Existing Class eq. + Fail Global Existing Instance k. + Existing Instance k. +End foo. diff --git a/test-suite/bugs/closed/5608.v b/test-suite/bugs/closed/5608.v new file mode 100644 index 000000000..f02eae69c --- /dev/null +++ b/test-suite/bugs/closed/5608.v @@ -0,0 +1,33 @@ +Reserved Notation "'slet' x .. y := A 'in' b" + (at level 200, x binder, y binder, b at level 200, format "'slet' x .. y := A 'in' '//' b"). +Reserved Notation "T x [1] = { A } ; 'return' ( b0 , b1 , .. , b2 )" + (at level 200, format "T x [1] = { A } ; '//' 'return' ( b0 , b1 , .. , b2 )"). + +Delimit Scope ctype_scope with ctype. +Local Open Scope ctype_scope. +Delimit Scope expr_scope with expr. +Inductive base_type := TZ | TWord (logsz : nat). +Inductive flat_type := Tbase (T : base_type) | Prod (A B : flat_type). +Context {var : base_type -> Type}. +Fixpoint interp_flat_type (interp_base_type : base_type -> Type) (t : +flat_type) := + match t with + | Tbase t => interp_base_type t + | Prod x y => prod (interp_flat_type interp_base_type x) (interp_flat_type +interp_base_type y) + end. +Inductive exprf : flat_type -> Type := +| Var {t} (v : var t) : exprf (Tbase t) +| LetIn {tx} (ex : exprf tx) {tC} (eC : interp_flat_type var tx -> exprf tC) : +exprf tC +| Pair {tx} (ex : exprf tx) {ty} (ey : exprf ty) : exprf (Prod tx ty). +Global Arguments Var {_} _. +Global Arguments LetIn {_} _ {_} _. +Global Arguments Pair {_} _ {_} _. +Notation "T x [1] = { A } ; 'return' ( b0 , b1 , .. , b2 )" := (LetIn (tx:=T) A +(fun x => Pair .. (Pair b0%expr b1%expr) .. b2%expr)) : expr_scope. +Definition foo := + (fun x3 => + (LetIn (Var x3) (fun x18 : var TZ + => (Pair (Var x18) (Var x18))))). +Print foo. diff --git a/test-suite/bugs/closed/5683.v b/test-suite/bugs/closed/5683.v new file mode 100644 index 000000000..b5c6a48ec --- /dev/null +++ b/test-suite/bugs/closed/5683.v @@ -0,0 +1,71 @@ +Require Import Program.Tactics. +Require Import FunctionalExtensionality. + +Inductive Succ A := +| Succ_O : Succ A +| Succ_S : A -> Succ A. +Arguments Succ_O {A}. +Arguments Succ_S {A} _. + +Inductive Zero : Type :=. + +Inductive ty := +| ty_nat : ty +| ty_arr : ty -> ty -> ty. + +Inductive term A := +| term_abs : ty -> term (Succ A) -> term A +| term_app : term A -> term A -> term A +| term_var : A -> term A +| term_nat : nat -> term A. +Arguments term_abs {A} _ _. +Arguments term_app {A} _ _. +Arguments term_var {A} _. +Arguments term_nat {A} _. + +Class Functor F := +{ + ret : forall {A}, A -> F A; + fmap : forall {A B}, (A -> B) -> F A -> F B; + fmap_id : forall {A} (fa : F A), fmap (@id A) fa = fa; + fmap_compose : forall {A B C} (fa : F A) (g : B -> C) (h : A -> B), fmap (fun +a => g (h a)) fa = fmap g (fmap h fa) +}. + +Class Monad M `{Functor M} := +{ + bind : forall {A B}, M A -> (A -> M B) -> M B; + ret_left_id : forall {A B} (a : A) (f : A -> M B), bind (ret a) f = f a; + ret_right_id : forall {A} (m : M A), bind m ret = m; + bind_assoc : forall {A B C} (m : M A) (f : A -> M B) (g : B -> M C), bind +(bind m f) g = bind m (fun x => bind (f x) g) +}. + +Instance Succ_Functor : Functor Succ. +Proof. + unshelve econstructor. + - intros A B f fa. + destruct fa. + + apply Succ_O. + + apply Succ_S. tauto. + - intros. apply Succ_S. assumption. + - intros A [|a]; reflexivity. + - intros A B C [|a] g h; reflexivity. +Defined. + +(* Anomaly: Not an arity *) +Program Fixpoint term_bind {A B} (tm : term A) (f : A -> term B) : term B := + let Succ_f (var : Succ A) := + match var with + | Succ_O => term_var Succ_O + | Succ_S var' => _ + end in + match tm with + | term_app tm1 tm2 => term_app (term_bind tm1 f) (term_bind tm2 f) + | term_abs ty body => term_abs ty (term_bind body Succ_f) + | term_var a => f a + | term_nat n => term_nat n + end. +Next Obligation. + intros. +Admitted. diff --git a/test-suite/bugs/closed/5697.v b/test-suite/bugs/closed/5697.v new file mode 100644 index 000000000..c653f992a --- /dev/null +++ b/test-suite/bugs/closed/5697.v @@ -0,0 +1,19 @@ +Set Primitive Projections. + +Record foo : Type := Foo { foo_car: nat }. + +Goal forall x y : nat, x <> y -> Foo x <> Foo y. +Proof. +intros. +intros H'. +congruence. +Qed. + +Record bar (A : Type) : Type := Bar { bar_car: A }. + +Goal forall x y : nat, x <> y -> Bar nat x <> Bar nat y. +Proof. +intros. +intros H'. +congruence. +Qed. diff --git a/test-suite/bugs/closed/HoTT_coq_032.v b/test-suite/bugs/closed/HoTT_coq_032.v index 39a7103d1..40abb215e 100644 --- a/test-suite/bugs/closed/HoTT_coq_032.v +++ b/test-suite/bugs/closed/HoTT_coq_032.v @@ -1,4 +1,3 @@ -(* -*- mode: coq; coq-prog-args: ("-xml") -*- *) Set Implicit Arguments. Generalizable All Variables. Set Asymmetric Patterns. diff --git a/test-suite/coq-makefile/coqdoc1/run.sh b/test-suite/coq-makefile/coqdoc1/run.sh index 1feff7479..dc5a500db 100755 --- a/test-suite/coq-makefile/coqdoc1/run.sh +++ b/test-suite/coq-makefile/coqdoc1/run.sh @@ -15,6 +15,7 @@ sort -u > desired <<EOT ./test ./test/test_plugin.cmi ./test/test_plugin.cmx +./test/test_plugin.cmxa ./test/test_plugin.cmxs ./test/test.glob ./test/test.v diff --git a/test-suite/coq-makefile/coqdoc2/run.sh b/test-suite/coq-makefile/coqdoc2/run.sh index 1feff7479..dc5a500db 100755 --- a/test-suite/coq-makefile/coqdoc2/run.sh +++ b/test-suite/coq-makefile/coqdoc2/run.sh @@ -15,6 +15,7 @@ sort -u > desired <<EOT ./test ./test/test_plugin.cmi ./test/test_plugin.cmx +./test/test_plugin.cmxa ./test/test_plugin.cmxs ./test/test.glob ./test/test.v diff --git a/test-suite/coq-makefile/findlib-package/Makefile.local b/test-suite/coq-makefile/findlib-package/Makefile.local new file mode 100644 index 000000000..0f4a7d995 --- /dev/null +++ b/test-suite/coq-makefile/findlib-package/Makefile.local @@ -0,0 +1 @@ +CAMLPKGS += -package foo diff --git a/test-suite/coq-makefile/findlib-package/_CoqProject b/test-suite/coq-makefile/findlib-package/_CoqProject new file mode 100644 index 000000000..69f47302e --- /dev/null +++ b/test-suite/coq-makefile/findlib-package/_CoqProject @@ -0,0 +1,10 @@ +-R src test +-R theories test +-I src + +src/test_plugin.mlpack +src/test.ml4 +src/test.mli +src/test_aux.ml +src/test_aux.mli +theories/test.v diff --git a/test-suite/coq-makefile/findlib-package/findlib/foo/META b/test-suite/coq-makefile/findlib-package/findlib/foo/META new file mode 100644 index 000000000..ff5f1c7c9 --- /dev/null +++ b/test-suite/coq-makefile/findlib-package/findlib/foo/META @@ -0,0 +1,4 @@ +archive(byte)="foo.cma" +archive(native)="foo.cmxa" +linkopts="-linkall" +requires="str" diff --git a/test-suite/coq-makefile/findlib-package/findlib/foo/Makefile b/test-suite/coq-makefile/findlib-package/findlib/foo/Makefile new file mode 100644 index 000000000..1615bfd06 --- /dev/null +++ b/test-suite/coq-makefile/findlib-package/findlib/foo/Makefile @@ -0,0 +1,14 @@ +-include ../../Makefile.conf + +CO="$(COQMF_OCAMLFIND)" opt +CB="$(COQMF_OCAMLFIND)" ocamlc + +all: + $(CO) -c foolib.ml + $(CO) -a foolib.cmx -o foo.cmxa + $(CB) -c foolib.ml + $(CB) -a foolib.cmo -o foo.cma + $(CB) -c foo.mli # empty .mli file, to be understood + +clean: + rm -f *.cmo *.cma *.cmx *.cmxa *.cmi *.o *.a diff --git a/test-suite/coq-makefile/findlib-package/findlib/foo/foo.mli b/test-suite/coq-makefile/findlib-package/findlib/foo/foo.mli new file mode 100644 index 000000000..e69de29bb --- /dev/null +++ b/test-suite/coq-makefile/findlib-package/findlib/foo/foo.mli diff --git a/test-suite/coq-makefile/findlib-package/findlib/foo/foolib.ml b/test-suite/coq-makefile/findlib-package/findlib/foo/foolib.ml new file mode 100644 index 000000000..81306fb89 --- /dev/null +++ b/test-suite/coq-makefile/findlib-package/findlib/foo/foolib.ml @@ -0,0 +1,2 @@ +let foo () = + assert(Str.search_forward (Str.regexp "foo") "barfoobar" 0 = 3) diff --git a/test-suite/coq-makefile/findlib-package/run.sh b/test-suite/coq-makefile/findlib-package/run.sh new file mode 100755 index 000000000..5b24df639 --- /dev/null +++ b/test-suite/coq-makefile/findlib-package/run.sh @@ -0,0 +1,18 @@ +#!/usr/bin/env bash + +. ../template/init.sh + +echo "let () = Foolib.foo ();;" >> src/test_aux.ml +export OCAMLPATH=$OCAMLPATH:$PWD/findlib +if which cygpath 2>/dev/null; then + # the only way I found to pass OCAMLPATH on win is to have it contain + # only one entry + export OCAMLPATH=`cygpath -w $PWD/findlib` +fi +make -C findlib/foo clean +coq_makefile -f _CoqProject -o Makefile +cat Makefile.conf +cat Makefile.local +make -C findlib/foo +make +make byte diff --git a/test-suite/coq-makefile/mlpack1/run.sh b/test-suite/coq-makefile/mlpack1/run.sh index 51669f28f..03df9cf05 100755 --- a/test-suite/coq-makefile/mlpack1/run.sh +++ b/test-suite/coq-makefile/mlpack1/run.sh @@ -15,6 +15,7 @@ sort > desired <<EOT ./test/test.glob ./test/test_plugin.cmi ./test/test_plugin.cmx +./test/test_plugin.cmxa ./test/test_plugin.cmxs ./test/test.v ./test/test.vo diff --git a/test-suite/coq-makefile/mlpack2/run.sh b/test-suite/coq-makefile/mlpack2/run.sh index 51669f28f..03df9cf05 100755 --- a/test-suite/coq-makefile/mlpack2/run.sh +++ b/test-suite/coq-makefile/mlpack2/run.sh @@ -15,6 +15,7 @@ sort > desired <<EOT ./test/test.glob ./test/test_plugin.cmi ./test/test_plugin.cmx +./test/test_plugin.cmxa ./test/test_plugin.cmxs ./test/test.v ./test/test.vo diff --git a/test-suite/coq-makefile/native1/run.sh b/test-suite/coq-makefile/native1/run.sh index 3bec11cb7..89bafe9ad 100755 --- a/test-suite/coq-makefile/native1/run.sh +++ b/test-suite/coq-makefile/native1/run.sh @@ -18,6 +18,7 @@ sort > desired <<EOT ./test/test.glob ./test/test_plugin.cmi ./test/test_plugin.cmx +./test/test_plugin.cmxa ./test/test_plugin.cmxs ./test/test.v ./test/test.vo diff --git a/test-suite/coqchk/cumulativity.v b/test-suite/coqchk/cumulativity.v index a978f6b90..7906a5b15 100644 --- a/test-suite/coqchk/cumulativity.v +++ b/test-suite/coqchk/cumulativity.v @@ -1,5 +1,5 @@ Set Universe Polymorphism. -Set Inductive Cumulativity. +Set Polymorphic Inductive Cumulativity. Set Printing Universes. Inductive List (A: Type) := nil | cons : A -> List A -> List A. diff --git a/test-suite/coqdoc/bug5648.html.out b/test-suite/coqdoc/bug5648.html.out new file mode 100644 index 000000000..06789c1c1 --- /dev/null +++ b/test-suite/coqdoc/bug5648.html.out @@ -0,0 +1,53 @@ +<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN" +"http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd"> +<html xmlns="http://www.w3.org/1999/xhtml"> +<head> +<meta http-equiv="Content-Type" content="text/html; charset=iso-8859-1" /> +<link href="coqdoc.css" rel="stylesheet" type="text/css" /> +<title>Coqdoc.bug5648</title> +</head> + +<body> + +<div id="page"> + +<div id="header"> +</div> + +<div id="main"> + +<h1 class="libtitle">Library Coqdoc.bug5648</h1> + +<div class="code"> +<span class="id" title="keyword">Lemma</span> <a name="a"><span class="id" title="lemma">a</span></a> : <a class="idref" href="http://coq.inria.fr/stdlib/Coq.Init.Logic.html#True"><span class="id" title="inductive">True</span></a>.<br/> +<span class="id" title="keyword">Proof</span>.<br/> +<span class="id" title="tactic">auto</span>.<br/> +<span class="id" title="keyword">Qed</span>.<br/> + +<br/> +<span class="id" title="keyword">Variant</span> <a name="t"><span class="id" title="inductive">t</span></a> :=<br/> +| <a name="A"><span class="id" title="constructor">A</span></a> | <a name="Add"><span class="id" title="constructor">Add</span></a> | <a name="G"><span class="id" title="constructor">G</span></a> | <a name="Goal"><span class="id" title="constructor">Goal</span></a> | <a name="L"><span class="id" title="constructor">L</span></a> | <a name="Lemma"><span class="id" title="constructor">Lemma</span></a> | <a name="P"><span class="id" title="constructor">P</span></a> | <a name="Proof"><span class="id" title="constructor">Proof</span></a> .<br/> + +<br/> +<span class="id" title="keyword">Definition</span> <a name="d"><span class="id" title="definition">d</span></a> <span class="id" title="var">x</span> :=<br/> + <span class="id" title="keyword">match</span> <a class="idref" href="Coqdoc.bug5648.html#x"><span class="id" title="variable">x</span></a> <span class="id" title="keyword">with</span><br/> + | <a class="idref" href="Coqdoc.bug5648.html#A"><span class="id" title="constructor">A</span></a> => 0<br/> + | <a class="idref" href="Coqdoc.bug5648.html#Add"><span class="id" title="constructor">Add</span></a> => 1<br/> + | <a class="idref" href="Coqdoc.bug5648.html#G"><span class="id" title="constructor">G</span></a> => 2<br/> + | <a class="idref" href="Coqdoc.bug5648.html#Goal"><span class="id" title="constructor">Goal</span></a> => 3<br/> + | <a class="idref" href="Coqdoc.bug5648.html#L"><span class="id" title="constructor">L</span></a> => 4<br/> + | <a class="idref" href="Coqdoc.bug5648.html#Lemma"><span class="id" title="constructor">Lemma</span></a> => 5<br/> + | <a class="idref" href="Coqdoc.bug5648.html#P"><span class="id" title="constructor">P</span></a> => 6<br/> + | <a class="idref" href="Coqdoc.bug5648.html#Proof"><span class="id" title="constructor">Proof</span></a> => 7<br/> + <span class="id" title="keyword">end</span>.<br/> +</div> +</div> + +<div id="footer"> +<hr/><a href="index.html">Index</a><hr/>This page has been generated by <a href="http://coq.inria.fr/">coqdoc</a> +</div> + +</div> + +</body> +</html>
\ No newline at end of file diff --git a/test-suite/coqdoc/bug5648.tex.out b/test-suite/coqdoc/bug5648.tex.out new file mode 100644 index 000000000..b0b732eff --- /dev/null +++ b/test-suite/coqdoc/bug5648.tex.out @@ -0,0 +1,49 @@ +\documentclass[12pt]{report} +\usepackage[]{inputenc} +\usepackage[T1]{fontenc} +\usepackage{fullpage} +\usepackage{coqdoc} +\usepackage{amsmath,amssymb} +\usepackage{url} +\begin{document} +\coqlibrary{Coqdoc.bug5648}{Library }{Coqdoc.bug5648} + +\begin{coqdoccode} +\coqdocnoindent +\coqdockw{Lemma} \coqdef{Coqdoc.bug5648.a}{a}{\coqdoclemma{a}} : \coqexternalref{True}{http://coq.inria.fr/stdlib/Coq.Init.Logic}{\coqdocinductive{True}}.\coqdoceol +\coqdocnoindent +\coqdockw{Proof}.\coqdoceol +\coqdocnoindent +\coqdoctac{auto}.\coqdoceol +\coqdocnoindent +\coqdockw{Qed}.\coqdoceol +\coqdocemptyline +\coqdocnoindent +\coqdockw{Variant} \coqdef{Coqdoc.bug5648.t}{t}{\coqdocinductive{t}} :=\coqdoceol +\coqdocnoindent +\ensuremath{|} \coqdef{Coqdoc.bug5648.A}{A}{\coqdocconstructor{A}} \ensuremath{|} \coqdef{Coqdoc.bug5648.Add}{Add}{\coqdocconstructor{Add}} \ensuremath{|} \coqdef{Coqdoc.bug5648.G}{G}{\coqdocconstructor{G}} \ensuremath{|} \coqdef{Coqdoc.bug5648.Goal}{Goal}{\coqdocconstructor{Goal}} \ensuremath{|} \coqdef{Coqdoc.bug5648.L}{L}{\coqdocconstructor{L}} \ensuremath{|} \coqdef{Coqdoc.bug5648.Lemma}{Lemma}{\coqdocconstructor{Lemma}} \ensuremath{|} \coqdef{Coqdoc.bug5648.P}{P}{\coqdocconstructor{P}} \ensuremath{|} \coqdef{Coqdoc.bug5648.Proof}{Proof}{\coqdocconstructor{Proof}} .\coqdoceol +\coqdocemptyline +\coqdocnoindent +\coqdockw{Definition} \coqdef{Coqdoc.bug5648.d}{d}{\coqdocdefinition{d}} \coqdocvar{x} :=\coqdoceol +\coqdocindent{1.00em} +\coqdockw{match} \coqdocvariable{x} \coqdockw{with}\coqdoceol +\coqdocindent{1.00em} +\ensuremath{|} \coqref{Coqdoc.bug5648.A}{\coqdocconstructor{A}} \ensuremath{\Rightarrow} 0\coqdoceol +\coqdocindent{1.00em} +\ensuremath{|} \coqref{Coqdoc.bug5648.Add}{\coqdocconstructor{Add}} \ensuremath{\Rightarrow} 1\coqdoceol +\coqdocindent{1.00em} +\ensuremath{|} \coqref{Coqdoc.bug5648.G}{\coqdocconstructor{G}} \ensuremath{\Rightarrow} 2\coqdoceol +\coqdocindent{1.00em} +\ensuremath{|} \coqref{Coqdoc.bug5648.Goal}{\coqdocconstructor{Goal}} \ensuremath{\Rightarrow} 3\coqdoceol +\coqdocindent{1.00em} +\ensuremath{|} \coqref{Coqdoc.bug5648.L}{\coqdocconstructor{L}} \ensuremath{\Rightarrow} 4\coqdoceol +\coqdocindent{1.00em} +\ensuremath{|} \coqref{Coqdoc.bug5648.Lemma}{\coqdocconstructor{Lemma}} \ensuremath{\Rightarrow} 5\coqdoceol +\coqdocindent{1.00em} +\ensuremath{|} \coqref{Coqdoc.bug5648.P}{\coqdocconstructor{P}} \ensuremath{\Rightarrow} 6\coqdoceol +\coqdocindent{1.00em} +\ensuremath{|} \coqref{Coqdoc.bug5648.Proof}{\coqdocconstructor{Proof}} \ensuremath{\Rightarrow} 7\coqdoceol +\coqdocindent{1.00em} +\coqdockw{end}.\coqdoceol +\end{coqdoccode} +\end{document} diff --git a/test-suite/coqdoc/bug5648.v b/test-suite/coqdoc/bug5648.v new file mode 100644 index 000000000..9b62dd1e1 --- /dev/null +++ b/test-suite/coqdoc/bug5648.v @@ -0,0 +1,19 @@ +Lemma a : True. +Proof. +auto. +Qed. + +Variant t := +| A | Add | G | Goal | L | Lemma | P | Proof . + +Definition d x := + match x with + | A => 0 + | Add => 1 + | G => 2 + | Goal => 3 + | L => 4 + | Lemma => 5 + | P => 6 + | Proof => 7 + end. diff --git a/test-suite/coqdoc/links.html.out b/test-suite/coqdoc/links.html.out new file mode 100644 index 000000000..7d7d01c1b --- /dev/null +++ b/test-suite/coqdoc/links.html.out @@ -0,0 +1,206 @@ +<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN" +"http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd"> +<html xmlns="http://www.w3.org/1999/xhtml"> +<head> +<meta http-equiv="Content-Type" content="text/html; charset=iso-8859-1" /> +<link href="coqdoc.css" rel="stylesheet" type="text/css" /> +<title>Coqdoc.links</title> +</head> + +<body> + +<div id="page"> + +<div id="header"> +</div> + +<div id="main"> + +<h1 class="libtitle">Library Coqdoc.links</h1> + +<div class="code"> +</div> + +<div class="doc"> +Various checks for coqdoc + +<div class="paragraph"> </div> + +<ul class="doclist"> +<li> symbols should not be inlined in string g + +</li> +<li> links to both kinds of notations in a' should work to the right notation + +</li> +<li> with utf8 option, forall must be unicode + +</li> +<li> splitting between symbols and ident should be correct in a' and c + +</li> +<li> ".." should be rendered correctly + +</li> +</ul> + +</div> +<div class="code"> + +<br/> +<span class="id" title="keyword">Require</span> <span class="id" title="keyword">Import</span> <a class="idref" href="http://coq.inria.fr/stdlib/Coq.Strings.String.html#"><span class="id" title="library">String</span></a>.<br/> + +<br/> +<span class="id" title="keyword">Definition</span> <a name="g"><span class="id" title="definition">g</span></a> := "dfjkh""sdfhj forall <> * ~"%<span class="id" title="var">string</span>.<br/> + +<br/> +<span class="id" title="keyword">Definition</span> <a name="a"><span class="id" title="definition">a</span></a> (<span class="id" title="var">b</span>: <a class="idref" href="http://coq.inria.fr/stdlib/Coq.Init.Datatypes.html#nat"><span class="id" title="inductive">nat</span></a>) := <a class="idref" href="Coqdoc.links.html#b"><span class="id" title="variable">b</span></a>.<br/> + +<br/> +<span class="id" title="keyword">Definition</span> <a name="f"><span class="id" title="definition">f</span></a> := <span class="id" title="keyword">forall</span> <span class="id" title="var">C</span>:<span class="id" title="keyword">Prop</span>, <a class="idref" href="Coqdoc.links.html#C"><span class="id" title="variable">C</span></a>.<br/> + +<br/> +<span class="id" title="keyword">Notation</span> <a name="1a1c7f13320341c3638e9edcc3e6389d"><span class="id" title="notation">"</span></a>n ++ m" := (<a class="idref" href="http://coq.inria.fr/stdlib/Coq.Init.Peano.html#plus"><span class="id" title="abbreviation">plus</span></a> <span class="id" title="var">n</span> <span class="id" title="var">m</span>).<br/> + +<br/> +<span class="id" title="keyword">Notation</span> <a name="1a1c7f13320341c3638e9edcc3e6389d"><span class="id" title="notation">"</span></a>n ++ m" := (<a class="idref" href="http://coq.inria.fr/stdlib/Coq.Init.Peano.html#mult"><span class="id" title="abbreviation">mult</span></a> <span class="id" title="var">n</span> <span class="id" title="var">m</span>). +<br/> +<span class="id" title="keyword">Notation</span> <a name="6b97e27793a3d22f5c0d1dd63170fd68"><span class="id" title="notation">"</span></a>n ** m" := (<a class="idref" href="http://coq.inria.fr/stdlib/Coq.Init.Peano.html#plus"><span class="id" title="abbreviation">plus</span></a> <span class="id" title="var">n</span> <span class="id" title="var">m</span>) (<span class="id" title="tactic">at</span> <span class="id" title="keyword">level</span> 60).<br/> + +<br/> +<span class="id" title="keyword">Notation</span> <a name="3e01fbae4590c7b7699ff99ce61580e1"><span class="id" title="notation">"</span></a>n ▵ m" := (<a class="idref" href="http://coq.inria.fr/stdlib/Coq.Init.Peano.html#plus"><span class="id" title="abbreviation">plus</span></a> <span class="id" title="var">n</span> <span class="id" title="var">m</span>) (<span class="id" title="tactic">at</span> <span class="id" title="keyword">level</span> 60).<br/> + +<br/> +<span class="id" title="keyword">Notation</span> <a name="347f39a83bf7d45676cff54fd7e8966f"><span class="id" title="notation">"</span></a>n '_' ++ 'x' m" := (<a class="idref" href="http://coq.inria.fr/stdlib/Coq.Init.Peano.html#plus"><span class="id" title="abbreviation">plus</span></a> <span class="id" title="var">n</span> <span class="id" title="var">m</span>) (<span class="id" title="tactic">at</span> <span class="id" title="keyword">level</span> 3).<br/> + +<br/> +<span class="id" title="keyword">Inductive</span> <a name="eq"><span class="id" title="inductive">eq</span></a> (<span class="id" title="var">A</span>:<span class="id" title="keyword">Type</span>) (<span class="id" title="var">x</span>:<a class="idref" href="Coqdoc.links.html#A"><span class="id" title="variable">A</span></a>) : <span class="id" title="var">A</span> <a class="idref" href="http://coq.inria.fr/stdlib/Coq.Init.Logic.html#d43e996736952df71ebeeae74d10a287"><span class="id" title="notation">-></span></a> <span class="id" title="keyword">Prop</span> := <a name="eq_refl"><span class="id" title="constructor">eq_refl</span></a> : <a class="idref" href="Coqdoc.links.html#x"><span class="id" title="variable">x</span></a> <a class="idref" href="Coqdoc.links.html#8f9364556521ebb498093f28eea2240f"><span class="id" title="notation">=</span></a> <a class="idref" href="Coqdoc.links.html#x"><span class="id" title="variable">x</span></a> <a class="idref" href="Coqdoc.links.html#8f9364556521ebb498093f28eea2240f"><span class="id" title="notation">:></span></a><a class="idref" href="Coqdoc.links.html#A"><span class="id" title="variable">A</span></a><br/> +<br/> +<span class="id" title="keyword">where</span> <a name="8f9364556521ebb498093f28eea2240f"><span class="id" title="notation">"</span></a>x = y :> A" := (@<a class="idref" href="Coqdoc.links.html#eq"><span class="id" title="variable">eq</span></a> <span class="id" title="var">A</span> <span class="id" title="var">x</span> <span class="id" title="var">y</span>) : <span class="id" title="var">type_scope</span>.<br/> + +<br/> +<span class="id" title="keyword">Definition</span> <a name="eq0"><span class="id" title="definition">eq0</span></a> := 0 <a class="idref" href="Coqdoc.links.html#8f9364556521ebb498093f28eea2240f"><span class="id" title="notation">=</span></a> 0 <a class="idref" href="Coqdoc.links.html#8f9364556521ebb498093f28eea2240f"><span class="id" title="notation">:></span></a> <a class="idref" href="http://coq.inria.fr/stdlib/Coq.Init.Datatypes.html#nat"><span class="id" title="inductive">nat</span></a>.<br/> + +<br/> +<span class="id" title="keyword">Notation</span> <a name="548d1059c499c9b2a9b95b07e68c2090"><span class="id" title="notation">"</span></a>( x # y ; .. ; z )" := (<a class="idref" href="http://coq.inria.fr/stdlib/Coq.Init.Datatypes.html#pair"><span class="id" title="constructor">pair</span></a> .. (<a class="idref" href="http://coq.inria.fr/stdlib/Coq.Init.Datatypes.html#pair"><span class="id" title="constructor">pair</span></a> <span class="id" title="var">x</span> <span class="id" title="var">y</span>) .. <span class="id" title="var">z</span>).<br/> + +<br/> +<span class="id" title="keyword">Definition</span> <a name="9f5a1d89cbd4d38f5e289576db7123d1"><span class="id" title="definition">b_α</span></a> := <a class="idref" href="http://coq.inria.fr/stdlib/Coq.Init.Datatypes.html#44400027531d4bc3f586a1997dc874c0"><span class="id" title="notation">(</span></a><a class="idref" href="Coqdoc.links.html#548d1059c499c9b2a9b95b07e68c2090"><span class="id" title="notation">(</span></a>0<a class="idref" href="Coqdoc.links.html#548d1059c499c9b2a9b95b07e68c2090"><span class="id" title="notation">#</span></a>0<a class="idref" href="Coqdoc.links.html#548d1059c499c9b2a9b95b07e68c2090"><span class="id" title="notation">;</span></a>0<a class="idref" href="Coqdoc.links.html#548d1059c499c9b2a9b95b07e68c2090"><span class="id" title="notation">)</span></a> <a class="idref" href="http://coq.inria.fr/stdlib/Coq.Init.Datatypes.html#44400027531d4bc3f586a1997dc874c0"><span class="id" title="notation">,</span></a> <a class="idref" href="http://coq.inria.fr/stdlib/Coq.Init.Datatypes.html#44400027531d4bc3f586a1997dc874c0"><span class="id" title="notation">(</span></a>0 <a class="idref" href="Coqdoc.links.html#6b97e27793a3d22f5c0d1dd63170fd68"><span class="id" title="notation">**</span></a> 0<a class="idref" href="http://coq.inria.fr/stdlib/Coq.Init.Datatypes.html#44400027531d4bc3f586a1997dc874c0"><span class="id" title="notation">))</span></a>.<br/> + +<br/> +<span class="id" title="keyword">Notation</span> <a name="h"><span class="id" title="abbreviation">h</span></a> := <a class="idref" href="Coqdoc.links.html#a"><span class="id" title="definition">a</span></a>.<br/> + +<br/> + <span class="id" title="keyword">Section</span> <a name="test"><span class="id" title="section">test</span></a>.<br/> + +<br/> + <span class="id" title="keyword">Variables</span> <a name="test.b'"><span class="id" title="variable">b'</span></a> <a name="test.b2"><span class="id" title="variable">b2</span></a>: <a class="idref" href="http://coq.inria.fr/stdlib/Coq.Init.Datatypes.html#nat"><span class="id" title="inductive">nat</span></a>.<br/> + +<br/> + <span class="id" title="keyword">Notation</span> <a name="4ab0449b36c75cf94e08c5822ea83e3d"><span class="id" title="notation">"</span></a>n + m" := (<span class="id" title="var">n</span> <a class="idref" href="Coqdoc.links.html#3e01fbae4590c7b7699ff99ce61580e1"><span class="id" title="notation">▵</span></a> <span class="id" title="var">m</span>) : <span class="id" title="var">my_scope</span>.<br/> + +<br/> + <span class="id" title="keyword">Delimit</span> <span class="id" title="keyword">Scope</span> <span class="id" title="var">my_scope</span> <span class="id" title="keyword">with</span> <span class="id" title="var">my</span>.<br/> + +<br/> + <span class="id" title="keyword">Notation</span> <a name="l"><span class="id" title="abbreviation">l</span></a> := 0.<br/> + +<br/> + <span class="id" title="keyword">Definition</span> <a name="ab410a966ac148e9b78c65c6cdf301fd"><span class="id" title="definition">α</span></a> := (0 <a class="idref" href="Coqdoc.links.html#4ab0449b36c75cf94e08c5822ea83e3d"><span class="id" title="notation">+</span></a> <a class="idref" href="Coqdoc.links.html#l"><span class="id" title="abbreviation">l</span></a>)%<span class="id" title="var">my</span>.<br/> + +<br/> + <span class="id" title="keyword">Definition</span> <a name="a'"><span class="id" title="definition">a'</span></a> <span class="id" title="var">b</span> := <a class="idref" href="Coqdoc.links.html#test.b'"><span class="id" title="variable">b'</span></a><a class="idref" href="Coqdoc.links.html#1a1c7f13320341c3638e9edcc3e6389d"><span class="id" title="notation">++</span></a>0<a class="idref" href="Coqdoc.links.html#1a1c7f13320341c3638e9edcc3e6389d"><span class="id" title="notation">++</span></a><a class="idref" href="Coqdoc.links.html#test.b2"><span class="id" title="variable">b2</span></a> <a class="idref" href="Coqdoc.links.html#347f39a83bf7d45676cff54fd7e8966f"><span class="id" title="notation">_</span></a> <a class="idref" href="Coqdoc.links.html#347f39a83bf7d45676cff54fd7e8966f"><span class="id" title="notation">++</span></a><a class="idref" href="Coqdoc.links.html#347f39a83bf7d45676cff54fd7e8966f"><span class="id" title="notation">x</span></a> <a class="idref" href="Coqdoc.links.html#b"><span class="id" title="variable">b</span></a>.<br/> + +<br/> + <span class="id" title="keyword">Definition</span> <a name="c"><span class="id" title="definition">c</span></a> := <a class="idref" href="http://coq.inria.fr/stdlib/Coq.Init.Specif.html#5bf2050e90b21ebc82dc5463d1ba338e"><span class="id" title="notation">{</span></a><a class="idref" href="http://coq.inria.fr/stdlib/Coq.Init.Logic.html#True"><span class="id" title="inductive">True</span></a><a class="idref" href="http://coq.inria.fr/stdlib/Coq.Init.Specif.html#5bf2050e90b21ebc82dc5463d1ba338e"><span class="id" title="notation">}+{</span></a><a class="idref" href="http://coq.inria.fr/stdlib/Coq.Init.Logic.html#True"><span class="id" title="inductive">True</span></a><a class="idref" href="http://coq.inria.fr/stdlib/Coq.Init.Specif.html#5bf2050e90b21ebc82dc5463d1ba338e"><span class="id" title="notation">}</span></a>.<br/> + +<br/> + <span class="id" title="keyword">Definition</span> <a name="d"><span class="id" title="definition">d</span></a> := (1<a class="idref" href="http://coq.inria.fr/stdlib/Coq.Init.Peano.html#b3eea360671e1b32b18a26e15b3aace3"><span class="id" title="notation">+</span></a>2)%<span class="id" title="var">nat</span>.<br/> + +<br/> + <span class="id" title="keyword">Lemma</span> <a name="e"><span class="id" title="lemma">e</span></a> : <a class="idref" href="http://coq.inria.fr/stdlib/Coq.Init.Datatypes.html#nat"><span class="id" title="inductive">nat</span></a> <a class="idref" href="http://coq.inria.fr/stdlib/Coq.Init.Datatypes.html#3dcaec3b772747610227247939f96b01"><span class="id" title="notation">+</span></a> <a class="idref" href="http://coq.inria.fr/stdlib/Coq.Init.Datatypes.html#nat"><span class="id" title="inductive">nat</span></a>.<br/> + <span class="id" title="var">Admitted</span>.<br/> + +<br/> + <span class="id" title="keyword">End</span> <a class="idref" href="Coqdoc.links.html#test"><span class="id" title="section">test</span></a>.<br/> + +<br/> + <span class="id" title="keyword">Section</span> <a name="test2"><span class="id" title="section">test2</span></a>.<br/> + +<br/> + <span class="id" title="keyword">Variables</span> <a name="test2.b'"><span class="id" title="variable">b'</span></a>: <a class="idref" href="http://coq.inria.fr/stdlib/Coq.Init.Datatypes.html#nat"><span class="id" title="inductive">nat</span></a>.<br/> + +<br/> + <span class="id" title="keyword">Section</span> <a name="test2.test"><span class="id" title="section">test</span></a>.<br/> + +<br/> + <span class="id" title="keyword">Variables</span> <a name="test2.test.b2"><span class="id" title="variable">b2</span></a>: <a class="idref" href="http://coq.inria.fr/stdlib/Coq.Init.Datatypes.html#nat"><span class="id" title="inductive">nat</span></a>.<br/> + +<br/> + <span class="id" title="keyword">Definition</span> <a name="a''"><span class="id" title="definition">a''</span></a> <span class="id" title="var">b</span> := <a class="idref" href="Coqdoc.links.html#test2.b'"><span class="id" title="variable">b'</span></a> <a class="idref" href="Coqdoc.links.html#1a1c7f13320341c3638e9edcc3e6389d"><span class="id" title="notation">++</span></a> <a class="idref" href="http://coq.inria.fr/stdlib/Coq.Init.Datatypes.html#O"><span class="id" title="constructor">O</span></a> <a class="idref" href="Coqdoc.links.html#1a1c7f13320341c3638e9edcc3e6389d"><span class="id" title="notation">++</span></a> <a class="idref" href="Coqdoc.links.html#test2.test.b2"><span class="id" title="variable">b2</span></a> <a class="idref" href="Coqdoc.links.html#347f39a83bf7d45676cff54fd7e8966f"><span class="id" title="notation">_</span></a> <a class="idref" href="Coqdoc.links.html#347f39a83bf7d45676cff54fd7e8966f"><span class="id" title="notation">++</span></a> <a class="idref" href="Coqdoc.links.html#347f39a83bf7d45676cff54fd7e8966f"><span class="id" title="notation">x</span></a> <a class="idref" href="Coqdoc.links.html#b"><span class="id" title="variable">b</span></a> <a class="idref" href="http://coq.inria.fr/stdlib/Coq.Init.Peano.html#b3eea360671e1b32b18a26e15b3aace3"><span class="id" title="notation">+</span></a> <a class="idref" href="Coqdoc.links.html#h"><span class="id" title="abbreviation">h</span></a> 0.<br/> + +<br/> + <span class="id" title="keyword">End</span> <a class="idref" href="Coqdoc.links.html#test2.test"><span class="id" title="section">test</span></a>.<br/> + +<br/> + <span class="id" title="keyword">End</span> <a class="idref" href="Coqdoc.links.html#test2"><span class="id" title="section">test2</span></a>.<br/> + +<br/> +</div> + +<div class="doc"> +skip +<div class="paragraph"> </div> + + skip +<div class="paragraph"> </div> + + skip +<div class="paragraph"> </div> + + skip +<div class="paragraph"> </div> + + skip +<div class="paragraph"> </div> + + skip +<div class="paragraph"> </div> + + skip +<div class="paragraph"> </div> + + skip +<div class="paragraph"> </div> + + skip +<div class="paragraph"> </div> + + skip +<div class="paragraph"> </div> + + skip +<div class="paragraph"> </div> + + skip +<div class="paragraph"> </div> + + skip +<div class="paragraph"> </div> + + skip +</div> +<div class="code"> + +<br/> +</div> +</div> + +<div id="footer"> +<hr/><a href="index.html">Index</a><hr/>This page has been generated by <a href="http://coq.inria.fr/">coqdoc</a> +</div> + +</div> + +</body> +</html>
\ No newline at end of file diff --git a/test-suite/coqdoc/links.tex.out b/test-suite/coqdoc/links.tex.out new file mode 100644 index 000000000..844fb3031 --- /dev/null +++ b/test-suite/coqdoc/links.tex.out @@ -0,0 +1,162 @@ +\documentclass[12pt]{report} +\usepackage[]{inputenc} +\usepackage[T1]{fontenc} +\usepackage{fullpage} +\usepackage{coqdoc} +\usepackage{amsmath,amssymb} +\usepackage{url} +\begin{document} +\coqlibrary{Coqdoc.links}{Library }{Coqdoc.links} + +\begin{coqdoccode} +\end{coqdoccode} +Various checks for coqdoc + + + +\begin{itemize} +\item symbols should not be inlined in string g + +\item links to both kinds of notations in a' should work to the right notation + +\item with utf8 option, forall must be unicode + +\item splitting between symbols and ident should be correct in a' and c + +\item ``..'' should be rendered correctly + +\end{itemize} +\begin{coqdoccode} +\coqdocemptyline +\coqdocnoindent +\coqdockw{Require} \coqdockw{Import} \coqexternalref{}{http://coq.inria.fr/stdlib/Coq.Strings.String}{\coqdoclibrary{String}}.\coqdoceol +\coqdocemptyline +\coqdocnoindent +\coqdockw{Definition} \coqdef{Coqdoc.links.g}{g}{\coqdocdefinition{g}} := "dfjkh""sdfhj forall <> * \~{}"\%\coqdocvar{string}.\coqdoceol +\coqdocemptyline +\coqdocnoindent +\coqdockw{Definition} \coqdef{Coqdoc.links.a}{a}{\coqdocdefinition{a}} (\coqdocvar{b}: \coqexternalref{nat}{http://coq.inria.fr/stdlib/Coq.Init.Datatypes}{\coqdocinductive{nat}}) := \coqdocvariable{b}.\coqdoceol +\coqdocemptyline +\coqdocnoindent +\coqdockw{Definition} \coqdef{Coqdoc.links.f}{f}{\coqdocdefinition{f}} := \coqdockw{\ensuremath{\forall}} \coqdocvar{C}:\coqdockw{Prop}, \coqdocvariable{C}.\coqdoceol +\coqdocemptyline +\coqdocnoindent +\coqdockw{Notation} \coqdef{Coqdoc.links.::x '++' x}{"}{"}n ++ m" := (\coqexternalref{plus}{http://coq.inria.fr/stdlib/Coq.Init.Peano}{\coqdocabbreviation{plus}} \coqdocvar{n} \coqdocvar{m}).\coqdoceol +\coqdocemptyline +\coqdocnoindent +\coqdockw{Notation} \coqdef{Coqdoc.links.::x '++' x}{"}{"}n ++ m" := (\coqexternalref{mult}{http://coq.inria.fr/stdlib/Coq.Init.Peano}{\coqdocabbreviation{mult}} \coqdocvar{n} \coqdocvar{m}). \coqdocemptyline +\coqdocnoindent +\coqdockw{Notation} \coqdef{Coqdoc.links.::x '**' x}{"}{"}n ** m" := (\coqexternalref{plus}{http://coq.inria.fr/stdlib/Coq.Init.Peano}{\coqdocabbreviation{plus}} \coqdocvar{n} \coqdocvar{m}) (\coqdoctac{at} \coqdockw{level} 60).\coqdoceol +\coqdocemptyline +\coqdocnoindent +\coqdockw{Notation} \coqdef{Coqdoc.links.::x 'xE2x96xB5' x}{"}{"}n ▵ m" := (\coqexternalref{plus}{http://coq.inria.fr/stdlib/Coq.Init.Peano}{\coqdocabbreviation{plus}} \coqdocvar{n} \coqdocvar{m}) (\coqdoctac{at} \coqdockw{level} 60).\coqdoceol +\coqdocemptyline +\coqdocnoindent +\coqdockw{Notation} \coqdef{Coqdoc.links.::x ''' ''' '++' 'x' x}{"}{"}n '\_' ++ 'x' m" := (\coqexternalref{plus}{http://coq.inria.fr/stdlib/Coq.Init.Peano}{\coqdocabbreviation{plus}} \coqdocvar{n} \coqdocvar{m}) (\coqdoctac{at} \coqdockw{level} 3).\coqdoceol +\coqdocemptyline +\coqdocnoindent +\coqdockw{Inductive} \coqdef{Coqdoc.links.eq}{eq}{\coqdocinductive{eq}} (\coqdocvar{A}:\coqdockw{Type}) (\coqdocvar{x}:\coqdocvariable{A}) : \coqdocvar{A} \coqexternalref{:type scope:x '->' x}{http://coq.inria.fr/stdlib/Coq.Init.Logic}{\coqdocnotation{\ensuremath{\rightarrow}}} \coqdockw{Prop} := \coqdef{Coqdoc.links.eq refl}{eq\_refl}{\coqdocconstructor{eq\_refl}} : \coqdocvariable{x} \coqref{Coqdoc.links.:type scope:x '=' x ':>' x}{\coqdocnotation{=}} \coqdocvariable{x} \coqref{Coqdoc.links.:type scope:x '=' x ':>' x}{\coqdocnotation{:>}}\coqdocvariable{A}\coqdoceol +\coqdocnoindent +\coqdoceol +\coqdocnoindent +\coqdockw{where} \coqdef{Coqdoc.links.:type scope:x '=' x ':>' x}{"}{"}x = y :> A" := (@\coqdocvariable{eq} \coqdocvar{A} \coqdocvar{x} \coqdocvar{y}) : \coqdocvar{type\_scope}.\coqdoceol +\coqdocemptyline +\coqdocnoindent +\coqdockw{Definition} \coqdef{Coqdoc.links.eq0}{eq0}{\coqdocdefinition{eq0}} := 0 \coqref{Coqdoc.links.:type scope:x '=' x ':>' x}{\coqdocnotation{=}} 0 \coqref{Coqdoc.links.:type scope:x '=' x ':>' x}{\coqdocnotation{:>}} \coqexternalref{nat}{http://coq.inria.fr/stdlib/Coq.Init.Datatypes}{\coqdocinductive{nat}}.\coqdoceol +\coqdocemptyline +\coqdocnoindent +\coqdockw{Notation} \coqdef{Coqdoc.links.::'(' x 'x23' x ';' '..' ';' x ')'}{"}{"}( x \# y ; .. ; z )" := (\coqexternalref{pair}{http://coq.inria.fr/stdlib/Coq.Init.Datatypes}{\coqdocconstructor{pair}} .. (\coqexternalref{pair}{http://coq.inria.fr/stdlib/Coq.Init.Datatypes}{\coqdocconstructor{pair}} \coqdocvar{x} \coqdocvar{y}) .. \coqdocvar{z}).\coqdoceol +\coqdocemptyline +\coqdocnoindent +\coqdockw{Definition} \coqdef{Coqdoc.links.b xCExB1}{b\_α}{\coqdocdefinition{b\_α}} := \coqexternalref{:core scope:'(' x ',' x ',' '..' ',' x ')'}{http://coq.inria.fr/stdlib/Coq.Init.Datatypes}{\coqdocnotation{(}}\coqref{Coqdoc.links.::'(' x 'x23' x ';' '..' ';' x ')'}{\coqdocnotation{(}}0\coqref{Coqdoc.links.::'(' x 'x23' x ';' '..' ';' x ')'}{\coqdocnotation{\#}}0\coqref{Coqdoc.links.::'(' x 'x23' x ';' '..' ';' x ')'}{\coqdocnotation{;}}0\coqref{Coqdoc.links.::'(' x 'x23' x ';' '..' ';' x ')'}{\coqdocnotation{)}} \coqexternalref{:core scope:'(' x ',' x ',' '..' ',' x ')'}{http://coq.inria.fr/stdlib/Coq.Init.Datatypes}{\coqdocnotation{,}} \coqexternalref{:core scope:'(' x ',' x ',' '..' ',' x ')'}{http://coq.inria.fr/stdlib/Coq.Init.Datatypes}{\coqdocnotation{(}}0 \coqref{Coqdoc.links.::x '**' x}{\coqdocnotation{**}} 0\coqexternalref{:core scope:'(' x ',' x ',' '..' ',' x ')'}{http://coq.inria.fr/stdlib/Coq.Init.Datatypes}{\coqdocnotation{))}}.\coqdoceol +\coqdocemptyline +\coqdocnoindent +\coqdockw{Notation} \coqdef{Coqdoc.links.h}{h}{\coqdocabbreviation{h}} := \coqref{Coqdoc.links.a}{\coqdocdefinition{a}}.\coqdoceol +\coqdocemptyline +\coqdocindent{1.00em} +\coqdockw{Section} \coqdef{Coqdoc.links.test}{test}{\coqdocsection{test}}.\coqdoceol +\coqdocemptyline +\coqdocindent{2.00em} +\coqdockw{Variables} \coqdef{Coqdoc.links.test.b'}{b'}{\coqdocvariable{b'}} \coqdef{Coqdoc.links.test.b2}{b2}{\coqdocvariable{b2}}: \coqexternalref{nat}{http://coq.inria.fr/stdlib/Coq.Init.Datatypes}{\coqdocinductive{nat}}.\coqdoceol +\coqdocemptyline +\coqdocindent{2.00em} +\coqdockw{Notation} \coqdef{Coqdoc.links.test.:my scope:x '+' x}{"}{"}n + m" := (\coqdocvar{n} \coqref{Coqdoc.links.::x 'xE2x96xB5' x}{\coqdocnotation{▵}} \coqdocvar{m}) : \coqdocvar{my\_scope}.\coqdoceol +\coqdocemptyline +\coqdocindent{2.00em} +\coqdockw{Delimit} \coqdockw{Scope} \coqdocvar{my\_scope} \coqdockw{with} \coqdocvar{my}.\coqdoceol +\coqdocemptyline +\coqdocindent{2.00em} +\coqdockw{Notation} \coqdef{Coqdoc.links.l}{l}{\coqdocabbreviation{l}} := 0.\coqdoceol +\coqdocemptyline +\coqdocindent{2.00em} +\coqdockw{Definition} \coqdef{Coqdoc.links.xCExB1}{α}{\coqdocdefinition{α}} := (0 \coqref{Coqdoc.links.test.:my scope:x '+' x}{\coqdocnotation{+}} \coqref{Coqdoc.links.l}{\coqdocabbreviation{l}})\%\coqdocvar{my}.\coqdoceol +\coqdocemptyline +\coqdocindent{2.00em} +\coqdockw{Definition} \coqdef{Coqdoc.links.a'}{a'}{\coqdocdefinition{a'}} \coqdocvar{b} := \coqdocvariable{b'}\coqref{Coqdoc.links.::x '++' x}{\coqdocnotation{++}}0\coqref{Coqdoc.links.::x '++' x}{\coqdocnotation{++}}\coqdocvariable{b2} \coqref{Coqdoc.links.::x ''' ''' '++' 'x' x}{\coqdocnotation{\_}} \coqref{Coqdoc.links.::x ''' ''' '++' 'x' x}{\coqdocnotation{++}}\coqref{Coqdoc.links.::x ''' ''' '++' 'x' x}{\coqdocnotation{x}} \coqdocvariable{b}.\coqdoceol +\coqdocemptyline +\coqdocindent{2.00em} +\coqdockw{Definition} \coqdef{Coqdoc.links.c}{c}{\coqdocdefinition{c}} := \coqexternalref{:type scope:'x7B' x 'x7D' '+' 'x7B' x 'x7D'}{http://coq.inria.fr/stdlib/Coq.Init.Specif}{\coqdocnotation{\{}}\coqexternalref{True}{http://coq.inria.fr/stdlib/Coq.Init.Logic}{\coqdocinductive{True}}\coqexternalref{:type scope:'x7B' x 'x7D' '+' 'x7B' x 'x7D'}{http://coq.inria.fr/stdlib/Coq.Init.Specif}{\coqdocnotation{\}+\{}}\coqexternalref{True}{http://coq.inria.fr/stdlib/Coq.Init.Logic}{\coqdocinductive{True}}\coqexternalref{:type scope:'x7B' x 'x7D' '+' 'x7B' x 'x7D'}{http://coq.inria.fr/stdlib/Coq.Init.Specif}{\coqdocnotation{\}}}.\coqdoceol +\coqdocemptyline +\coqdocindent{2.00em} +\coqdockw{Definition} \coqdef{Coqdoc.links.d}{d}{\coqdocdefinition{d}} := (1\coqexternalref{:nat scope:x '+' x}{http://coq.inria.fr/stdlib/Coq.Init.Peano}{\coqdocnotation{+}}2)\%\coqdocvar{nat}.\coqdoceol +\coqdocemptyline +\coqdocindent{2.00em} +\coqdockw{Lemma} \coqdef{Coqdoc.links.e}{e}{\coqdoclemma{e}} : \coqexternalref{nat}{http://coq.inria.fr/stdlib/Coq.Init.Datatypes}{\coqdocinductive{nat}} \coqexternalref{:type scope:x '+' x}{http://coq.inria.fr/stdlib/Coq.Init.Datatypes}{\coqdocnotation{+}} \coqexternalref{nat}{http://coq.inria.fr/stdlib/Coq.Init.Datatypes}{\coqdocinductive{nat}}.\coqdoceol +\coqdocindent{2.00em} +\coqdocvar{Admitted}.\coqdoceol +\coqdocemptyline +\coqdocindent{1.00em} +\coqdockw{End} \coqref{Coqdoc.links.test}{\coqdocsection{test}}.\coqdoceol +\coqdocemptyline +\coqdocindent{1.00em} +\coqdockw{Section} \coqdef{Coqdoc.links.test2}{test2}{\coqdocsection{test2}}.\coqdoceol +\coqdocemptyline +\coqdocindent{2.00em} +\coqdockw{Variables} \coqdef{Coqdoc.links.test2.b'}{b'}{\coqdocvariable{b'}}: \coqexternalref{nat}{http://coq.inria.fr/stdlib/Coq.Init.Datatypes}{\coqdocinductive{nat}}.\coqdoceol +\coqdocemptyline +\coqdocindent{2.00em} +\coqdockw{Section} \coqdef{Coqdoc.links.test2.test}{test}{\coqdocsection{test}}.\coqdoceol +\coqdocemptyline +\coqdocindent{3.00em} +\coqdockw{Variables} \coqdef{Coqdoc.links.test2.test.b2}{b2}{\coqdocvariable{b2}}: \coqexternalref{nat}{http://coq.inria.fr/stdlib/Coq.Init.Datatypes}{\coqdocinductive{nat}}.\coqdoceol +\coqdocemptyline +\coqdocindent{3.00em} +\coqdockw{Definition} \coqdef{Coqdoc.links.a''}{a'{}'}{\coqdocdefinition{a'{}'}} \coqdocvar{b} := \coqdocvariable{b'} \coqref{Coqdoc.links.::x '++' x}{\coqdocnotation{++}} \coqexternalref{O}{http://coq.inria.fr/stdlib/Coq.Init.Datatypes}{\coqdocconstructor{O}} \coqref{Coqdoc.links.::x '++' x}{\coqdocnotation{++}} \coqdocvariable{b2} \coqref{Coqdoc.links.::x ''' ''' '++' 'x' x}{\coqdocnotation{\_}} \coqref{Coqdoc.links.::x ''' ''' '++' 'x' x}{\coqdocnotation{++}} \coqref{Coqdoc.links.::x ''' ''' '++' 'x' x}{\coqdocnotation{x}} \coqdocvariable{b} \coqexternalref{:nat scope:x '+' x}{http://coq.inria.fr/stdlib/Coq.Init.Peano}{\coqdocnotation{+}} \coqref{Coqdoc.links.h}{\coqdocabbreviation{h}} 0.\coqdoceol +\coqdocemptyline +\coqdocindent{2.00em} +\coqdockw{End} \coqref{Coqdoc.links.test2.test}{\coqdocsection{test}}.\coqdoceol +\coqdocemptyline +\coqdocindent{1.00em} +\coqdockw{End} \coqref{Coqdoc.links.test2}{\coqdocsection{test2}}.\coqdoceol +\coqdocemptyline +\end{coqdoccode} +skip + + skip + + skip + + skip + + skip + + skip + + skip + + skip + + skip + + skip + + skip + + skip + + skip + + skip \begin{coqdoccode} +\coqdocemptyline +\end{coqdoccode} +\end{document} diff --git a/test-suite/output/Notations3.out b/test-suite/output/Notations3.out index a9ae74fd6..e5dbfcb4b 100644 --- a/test-suite/output/Notations3.out +++ b/test-suite/output/Notations3.out @@ -1,3 +1,5 @@ +{x : nat | x = 0} + {True /\ False} + {forall x : nat, x = 0} + : Set [<0, 2 >] : nat * nat * (nat * nat) [<0, 2 >] @@ -109,9 +111,14 @@ fun x : ?A => x === x : forall x : ?A, x = x where ?A : [x : ?A |- Type] (x cannot be used) -{0, 1} +{{0, 1}} : nat * nat -{0, 1, 2} +{{0, 1, 2}} : nat * (nat * nat) -{0, 1, 2, 3} +{{0, 1, 2, 3}} : nat * (nat * (nat * nat)) +letpair x [1] = {0}; +return (1, 2, 3, 4) + : nat * nat * nat * nat +{{ 1 | 1 // 1 }} + : nat diff --git a/test-suite/output/Notations3.v b/test-suite/output/Notations3.v index dee0f70f7..b1015137d 100644 --- a/test-suite/output/Notations3.v +++ b/test-suite/output/Notations3.v @@ -1,4 +1,9 @@ (**********************************************************************) +(* Check precedence, spacing, etc. in printing with curly brackets *) + +Check {x|x=0}+{True/\False}+{forall x, x=0}. + +(**********************************************************************) (* Check printing of notations with several instances of a recursive pattern *) (* Was wrong but I could not trigger a problem due to the collision between *) (* different instances of ".." *) @@ -161,10 +166,23 @@ End Bug4765. Notation "x === x" := (eq_refl x) (only printing, at level 10). Check (fun x => eq_refl x). -(**********************************************************************) (* Test recursive notations with the recursive pattern repeated on the right *) -Notation "{ x , .. , y , z }" := (pair x .. (pair y z) ..). -Check {0,1}. -Check {0,1,2}. -Check {0,1,2,3}. +Notation "{{ x , .. , y , z }}" := (pair x .. (pair y z) ..). +Check {{0,1}}. +Check {{0,1,2}}. +Check {{0,1,2,3}}. + +(* Test printing of #5608 *) + +Reserved Notation "'letpair' x [1] = { A } ; 'return' ( b0 , b1 , .. , b2 )" + (at level 200, format "'letpair' x [1] = { A } ; '//' 'return' ( b0 , b1 , .. , b2 )"). +Notation "'letpair' x [1] = { a } ; 'return' ( b0 , b1 , .. , b2 )" := + (let x:=a in ( .. (b0,b1) .., b2)). +Check letpair x [1] = {0}; return (1,2,3,4). + +(* Test spacing in #5569 *) + +Notation "{ { xL | xR // xcut } }" := (xL+xR+xcut) + (at level 0, xR at level 39, format "{ { xL | xR // xcut } }"). +Check 1+1+1. diff --git a/test-suite/output/UnclosedBlocks.out b/test-suite/output/UnclosedBlocks.out new file mode 100644 index 000000000..b83e94ad4 --- /dev/null +++ b/test-suite/output/UnclosedBlocks.out @@ -0,0 +1,3 @@ + +Error: The section Baz, module type Bar and module Foo need to be closed. + diff --git a/test-suite/output/UnclosedBlocks.v b/test-suite/output/UnclosedBlocks.v new file mode 100644 index 000000000..854bd6a6d --- /dev/null +++ b/test-suite/output/UnclosedBlocks.v @@ -0,0 +1,8 @@ +(* -*- mode: coq; coq-prog-args: ("-compile" "UnclosedBlocks.v") *) +Module Foo. + Module Closed. + End Closed. + Module Type Bar. + Section Baz. + (* end-of-compilation error message reports unclosed sections, blocks, and + module types *) diff --git a/test-suite/success/cumulativity.v b/test-suite/success/cumulativity.v index ebf817cfc..0ee85712e 100644 --- a/test-suite/success/cumulativity.v +++ b/test-suite/success/cumulativity.v @@ -1,5 +1,11 @@ +Polymorphic Cumulative Inductive T1 := t1 : T1. +Fail Monomorphic Cumulative Inductive T2 := t2 : T2. + +Polymorphic Cumulative Record R1 := { r1 : T1 }. +Fail Monomorphic Cumulative Inductive R2 := {r2 : T1}. + Set Universe Polymorphism. -Set Inductive Cumulativity. +Set Polymorphic Inductive Cumulativity. Set Printing Universes. Inductive List (A: Type) := nil | cons : A -> List A -> List A. @@ -62,4 +68,33 @@ End subtyping_test. Record A : Type := { a :> Type; }. -Record B (X : A) : Type := { b : X; }.
\ No newline at end of file +Record B (X : A) : Type := { b : X; }. + +NonCumulative Inductive NCList (A: Type) + := ncnil | nccons : A -> NCList A -> NCList A. + +Section NCListLift. + Universe i j. + + Constraint i < j. + + Fail Definition LiftNCL {A} : NCList@{i} A -> NCList@{j} A := fun x => x. + +End NCListLift. + +Inductive eq@{i} {A : Type@{i}} (x : A) : A -> Type@{i} := eq_refl : eq x x. + +Definition funext_type@{a b e} (A : Type@{a}) (B : A -> Type@{b}) + := forall f g : (forall a, B a), + (forall x, eq@{e} (f x) (g x)) + -> eq@{e} f g. + +Section down. + Universes a b e e'. + Constraint e' < e. + Lemma funext_down {A B} + : @funext_type@{a b e} A B -> @funext_type@{a b e'} A B. + Proof. + intros H f g Hfg. exact (H f g Hfg). + Defined. +End down. diff --git a/test-suite/success/forward.v b/test-suite/success/forward.v index 0ed5b524f..4e36dec15 100644 --- a/test-suite/success/forward.v +++ b/test-suite/success/forward.v @@ -16,3 +16,14 @@ eremember (S (S ?[x])). instantiate (x:=0). reflexivity. Qed. + +(* Don't know if it is good or not but the compatibility tells that + the asserted goal to prove is subject to beta-iota but not the + asserted hypothesis *) + +Goal True. +assert ((fun x => x) False). +Fail match goal with |- (?f ?a) => idtac end. (* should be beta-iota reduced *) +2:match goal with _: (?f ?a) |- _ => idtac end. (* should not be beta-iota reduced *) +Abort. + diff --git a/test-suite/success/ltac.v b/test-suite/success/ltac.v index 1d35f1ef6..29e373eaa 100644 --- a/test-suite/success/ltac.v +++ b/test-suite/success/ltac.v @@ -337,3 +337,14 @@ Goal True. evar (0=0). Abort. +(* Test location of hypothesis in "symmetry in H". This was broken in + 8.6 where H, when the oldest hyp, was moved at the place of most + recent hypothesis *) + +Goal 0=1 -> True -> True. +intros H H0. +symmetry in H. +(* H should be the first hypothesis *) +match goal with h:_ |- _ => assert (h=h) end. (* h should be H0 *) +exact (eq_refl H0). +Abort. diff --git a/theories/Init/Notations.v b/theories/Init/Notations.v index e67ae6a92..5e8d2faa5 100644 --- a/theories/Init/Notations.v +++ b/theories/Init/Notations.v @@ -66,6 +66,9 @@ Reserved Notation "{ x }" (at level 0, x at level 99). (** Notations for sigma-types or subsets *) +Reserved Notation "{ A } + { B }" (at level 50, left associativity). +Reserved Notation "A + { B }" (at level 50, left associativity). + Reserved Notation "{ x | P }" (at level 0, x at level 99). Reserved Notation "{ x | P & Q }" (at level 0, x at level 99). diff --git a/tools/CoqMakefile.in b/tools/CoqMakefile.in index 3a8ca7b8d..f4d1118d0 100644 --- a/tools/CoqMakefile.in +++ b/tools/CoqMakefile.in @@ -52,7 +52,7 @@ HASNATDYNLINK := $(COQMF_HASNATDYNLINK) # # Parameters are make variable assignments. # They can be passed to (each call to) make on the command line. -# They can also be put in @LOCAL_FILE@ once an forall. +# They can also be put in @LOCAL_FILE@ once an for all. # For retro-compatibility reasons they can be put in the _CoqProject, but this # practice is discouraged since _CoqProject better not contain make specific # code (be nice to user interfaces). @@ -63,11 +63,11 @@ VERBOSE ?= # Time the Coq process (set to non empty), and how (see default value) TIMED?= TIMECMD?= -# Use /usr/bin/time on linux, gtime on Mac OS +# Use /usr/bin/env time on linux, gtime on Mac OS TIMEFMT?="$* (real: %e, user: %U, sys: %S, mem: %M ko)" ifneq (,$(TIMED)) -ifeq (0,$(shell /usr/bin/time -f $(TIMEFMT) true >/dev/null 2>/dev/null; echo $$?)) -STDTIME?=/usr/bin/time -f $(TIMEFMT) +ifeq (0,$(shell /usr/bin/env time -f $(TIMEFMT) true >/dev/null 2>/dev/null; echo $$?)) +STDTIME?=/usr/bin/env time -f $(TIMEFMT) else ifeq (0,$(shell gtime -f $(TIMEFMT) true >/dev/null 2>/dev/null; echo $$?)) STDTIME?=gtime -f $(TIMEFMT) @@ -76,7 +76,7 @@ STDTIME?=time endif endif else -STDTIME?=/usr/bin/time -f $(TIMEFMT) +STDTIME?=/usr/bin/env time -f $(TIMEFMT) endif # Coq binaries @@ -96,11 +96,14 @@ COQMAKE_BOTH_SINGLE_TIMING_FILES ?= "$(COQLIB)/tools/make-both-single-timing-fil BEFORE ?= AFTER ?= +# FIXME this should be generated by Coq (modules already linked by Coq) +CAMLDONTLINK=camlp5.gramlib,unix,str + # OCaml binaries CAMLC ?= "$(OCAMLFIND)" ocamlc -c -rectypes -thread CAMLOPTC ?= "$(OCAMLFIND)" opt -c -rectypes -thread -CAMLLINK ?= "$(OCAMLFIND)" ocamlc -rectypes -thread -CAMLOPTLINK ?= "$(OCAMLFIND)" opt -rectypes -thread +CAMLLINK ?= "$(OCAMLFIND)" ocamlc -rectypes -thread -linkpkg -dontlink $(CAMLDONTLINK) +CAMLOPTLINK ?= "$(OCAMLFIND)" opt -rectypes -thread -linkpkg -dontlink $(CAMLDONTLINK) CAMLDOC ?= "$(OCAMLFIND)" ocamldoc -rectypes CAMLDEP ?= "$(OCAMLFIND)" ocamldep -slash -ml-synonym .ml4 -ml-synonym .mlpack @@ -111,6 +114,11 @@ DESTDIR ?= CAMLDEBUG ?= COQDEBUG ?= +# Extra flags to the OCaml compiler +CAMLFLAGS ?= +# Extra packages to be linked in (as in findlib -package) +CAMLPKGS ?= + # Option for making timing files TIMING?= # Output file names for timed builds @@ -151,7 +159,7 @@ OPT?= # The DYNOBJ and DYNLIB variables are used by "coqdep -dyndep var" in .v.d ifeq '$(OPT)' '-byte' USEBYTE:=true -DYNOBJ:=.cmo +DYNOBJ:=.cma DYNLIB:=.cma else USEBYTE:= @@ -170,7 +178,7 @@ COQMAKEFILE_VERSION:=@COQ_VERSION@ COQSRCLIBS?= $(foreach d,$(COQ_SRC_SUBDIRS), -I "$(COQLIB)$(d)") -CAMLFLAGS=$(OCAMLLIBS) $(COQSRCLIBS) -I $(CAMLP4LIB) $(OCAML_API_FLAGS) +CAMLFLAGS+=$(OCAMLLIBS) $(COQSRCLIBS) -I $(CAMLP4LIB) $(OCAML_API_FLAGS) CAMLLIB:=$(shell "$(OCAMLFIND)" printconf stdlib) @@ -440,7 +448,7 @@ beautify: $(BEAUTYFILES) # There rules can be extended in @LOCAL_FILE@ # Extensions can't assume when they run. -install: install-extra +install: $(HIDE)for f in $(FILESTOINSTALL); do\ df="`$(COQMKFILE) -destination-of "$$f" $(COQLIBS)`";\ if [ "$$?" != "0" -o -z "$$df" ]; then\ @@ -451,6 +459,7 @@ install: install-extra echo INSTALL "$$f" "$(COQLIBINSTALL)/$$df";\ fi;\ done + $(HIDE)$(MAKE) install-extra -f "$(SELF)" install-extra:: @# Extension point .PHONY: install install-extra @@ -558,46 +567,51 @@ archclean:: $(MLIFILES:.mli=.cmi): %.cmi: %.mli $(SHOW)'CAMLC -c $<' - $(HIDE)$(CAMLC) $(CAMLDEBUG) $(CAMLFLAGS) $< + $(HIDE)$(CAMLC) $(CAMLDEBUG) $(CAMLFLAGS) $(CAMLPKGS) $< $(ML4FILES:.ml4=.cmo): %.cmo: %.ml4 $(SHOW)'CAMLC -pp -c $<' - $(HIDE)$(CAMLC) $(CAMLDEBUG) $(CAMLFLAGS) $(PP) -impl $< + $(HIDE)$(CAMLC) $(CAMLDEBUG) $(CAMLFLAGS) $(CAMLPKGS) $(PP) -impl $< $(ML4FILES:.ml4=.cmx): %.cmx: %.ml4 $(SHOW)'CAMLOPT -pp -c $(FOR_PACK) $<' - $(HIDE)$(CAMLOPTC) $(CAMLDEBUG) $(CAMLFLAGS) $(PP) $(FOR_PACK) -impl $< + $(HIDE)$(CAMLOPTC) $(CAMLDEBUG) $(CAMLFLAGS) $(CAMLPKGS) $(PP) $(FOR_PACK) -impl $< $(MLFILES:.ml=.cmo): %.cmo: %.ml $(SHOW)'CAMLC -c $<' - $(HIDE)$(CAMLC) $(CAMLDEBUG) $(CAMLFLAGS) $< + $(HIDE)$(CAMLC) $(CAMLDEBUG) $(CAMLFLAGS) $(CAMLPKGS) $< $(MLFILES:.ml=.cmx): %.cmx: %.ml $(SHOW)'CAMLOPT -c $(FOR_PACK) $<' - $(HIDE)$(CAMLOPTC) $(CAMLDEBUG) $(CAMLFLAGS) $(FOR_PACK) $< + $(HIDE)$(CAMLOPTC) $(CAMLDEBUG) $(CAMLFLAGS) $(CAMLPKGS) $(FOR_PACK) $< $(MLLIBFILES:.mllib=.cmxs): %.cmxs: %.cmxa $(SHOW)'CAMLOPT -shared -o $@' - $(HIDE)$(CAMLOPTLINK) $(CAMLDEBUG) $(CAMLFLAGS) \ + $(HIDE)$(CAMLOPTLINK) $(CAMLDEBUG) $(CAMLFLAGS) $(CAMLPKGS) \ -linkall -shared -o $@ $< $(MLLIBFILES:.mllib=.cma): %.cma: | %.mllib $(SHOW)'CAMLC -a -o $@' - $(HIDE)$(CAMLLINK) $(CAMLDEBUG) $(CAMLFLAGS) -a -o $@ $^ + $(HIDE)$(CAMLLINK) $(CAMLDEBUG) $(CAMLFLAGS) $(CAMLPKGS) -a -o $@ $^ $(MLLIBFILES:.mllib=.cmxa): %.cmxa: | %.mllib $(SHOW)'CAMLOPT -a -o $@' - $(HIDE)$(CAMLOPTLINK) $(CAMLDEBUG) $(CAMLFLAGS) -a -o $@ $^ + $(HIDE)$(CAMLOPTLINK) $(CAMLDEBUG) $(CAMLFLAGS) $(CAMLPKGS) -a -o $@ $^ -$(MLPACKFILES:.mlpack=.cmxs): %.cmxs: %.cmx +$(MLPACKFILES:.mlpack=.cmxs): %.cmxs: %.cmxa $(SHOW)'CAMLOPT -shared -o $@' - $(HIDE)$(CAMLOPTLINK) $(CAMLDEBUG) $(CAMLFLAGS) -shared -o $@ $< + $(HIDE)$(CAMLOPTLINK) $(CAMLDEBUG) $(CAMLFLAGS) $(CAMLPKGS) \ + -shared -linkall -o $@ $< + +$(MLPACKFILES:.mlpack=.cmxa): %.cmxa: %.cmx + $(SHOW)'CAMLOPT -a -o $@' + $(HIDE)$(CAMLOPTLINK) $(CAMLDEBUG) $(CAMLFLAGS) -a -o $@ $< $(MLPACKFILES:.mlpack=.cma): %.cma: %.cmo | %.mlpack $(SHOW)'CAMLC -a -o $@' - $(HIDE)$(CAMLLINK) $(CAMLDEBUG) $(CAMLFLAGS) -a -o $@ $^ + $(HIDE)$(CAMLLINK) $(CAMLDEBUG) $(CAMLFLAGS) $(CAMLPKGS) -a -o $@ $^ $(MLPACKFILES:.mlpack=.cmo): %.cmo: | %.mlpack $(SHOW)'CAMLC -pack -o $@' @@ -610,7 +624,8 @@ $(MLPACKFILES:.mlpack=.cmx): %.cmx: | %.mlpack # This rule is for _CoqProject with no .mllib nor .mlpack $(filter-out $(MLLIBFILES:.mllib=.cmxs) $(MLPACKFILES:.mlpack=.cmxs) $(addsuffix .cmxs,$(PACKEDFILES)) $(addsuffix .cmxs,$(LIBEDFILES)),$(MLFILES:.ml=.cmxs) $(ML4FILES:.ml4=.cmxs)): %.cmxs: %.cmx $(SHOW)'[deprecated,use-mllib-or-mlpack] CAMLOPT -shared -o $@' - $(HIDE)$(CAMLOPTLINK) $(CAMLDEBUG) $(CAMLFLAGS) -shared -o $@ $< + $(HIDE)$(CAMLOPTLINK) $(CAMLDEBUG) $(CAMLFLAGS) $(CAMLPKGS) \ + -shared -o $@ $< ifneq (,$(TIMING)) TIMING_EXTRA = > $<.$(TIMING_EXT) @@ -734,7 +749,7 @@ printenv:: # file you can extend the merlin-hook target in @LOCAL_FILE@ .merlin: $(SHOW)'FILL .merlin' - $(HIDE)echo 'FLG -rectypes' > .merlin + $(HIDE)echo 'FLG -rectypes -thread' > .merlin $(HIDE)echo 'B $(COQLIB)' >> .merlin $(HIDE)echo 'S $(COQLIB)' >> .merlin $(HIDE)$(foreach d,$(COQ_SRC_SUBDIRS), \ diff --git a/tools/beautify-archive b/tools/beautify-archive index 6bfa974a5..a327ea44e 100755 --- a/tools/beautify-archive +++ b/tools/beautify-archive @@ -23,7 +23,7 @@ cp -pr /tmp/$OLDARCHIVE.$$ $NEWARCHIVE cd $NEWARCHIVE rm description || true make clean -make COQFLAGS='-beautify -q $(OPT) $(COQLIBS) $(OTHERFLAGS) $(COQ_XML)' || \ +make COQFLAGS='-beautify -q $(OPT) $(COQLIBS) $(OTHERFLAGS)' || \ { echo ---- Failed to beautify; exit 1; } echo -------- Upgrading files in the beautification directory -------------- beaufiles=`find . -name \*.v$BEAUTIFYSUFFIX` diff --git a/tools/check-translate b/tools/check-translate index 3dd824053..acb6f4590 100755 --- a/tools/check-translate +++ b/tools/check-translate @@ -2,7 +2,7 @@ echo -------------- Producing translated files --------------------- rm */*/*.v8 >& /dev/null -make COQ_XML=-translate theories || { echo ---- Failed to translate; exit 1; } +make COQOPTS=-translate theories || { echo ---- Failed to translate; exit 1; } if [ -e translated ]; then rm -r translated; fi if [ -e successful-translation ]; then rm -r successful-translation; fi if [ -e failed-translation ]; then rm -r failed-translation; fi diff --git a/tools/coq_makefile.ml b/tools/coq_makefile.ml index 0f38d1938..de76bf98b 100644 --- a/tools/coq_makefile.ml +++ b/tools/coq_makefile.ml @@ -114,13 +114,12 @@ let read_whole_file s = close_in ic; Buffer.contents b -let makefile_template = - let template = "/tools/CoqMakefile.in" in - Coq_config.coqlib ^ template - let quote s = if String.contains s ' ' then "'" ^ s ^ "'" else s let generate_makefile oc conf_file local_file args project = + let makefile_template = + let template = "/tools/CoqMakefile.in" in + Envars.coqlib () ^ template in let s = read_whole_file makefile_template in let s = List.fold_left (fun s (k,v) -> Str.global_replace (Str.regexp_string k) v s) s @@ -424,7 +423,7 @@ let _ = check_overlapping_include project; - Envars.set_coqlib ~fail:(fun x -> x); + Envars.set_coqlib ~fail:(fun x -> Printf.eprintf "Error: %s\n" x; exit 1); let ocm = Option.cata open_out stdout project.makefile in generate_makefile ocm conf_file local_file (prog :: args) project; diff --git a/tools/coqc.ml b/tools/coqc.ml index 4595af6e8..862225d3d 100644 --- a/tools/coqc.ml +++ b/tools/coqc.ml @@ -94,7 +94,7 @@ let parse_args () = | ("-bt"|"-debug"|"-nolib"|"-boot"|"-time"|"-profile-ltac" |"-batch"|"-noinit"|"-nois"|"-noglob"|"-no-glob" |"-q"|"-profile"|"-just-parsing"|"-echo" |"-quiet" - |"-silent"|"-m"|"-xml"|"-beautify"|"-strict-implicit" + |"-silent"|"-m"|"-beautify"|"-strict-implicit" |"-impredicative-set"|"-vm"|"-native-compiler" |"-indices-matter"|"-quick"|"-type-in-type" |"-async-proofs-always-delegate"|"-async-proofs-never-reopen-branch" diff --git a/tools/coqdoc/index.ml b/tools/coqdoc/index.ml index 8ba615670..1bbf76490 100644 --- a/tools/coqdoc/index.ml +++ b/tools/coqdoc/index.ml @@ -117,7 +117,7 @@ let find_module m = if Hashtbl.mem local_modules m then Local else - try External (Filename.concat (find_external_library m) m) + try External (find_external_library m ^ "/" ^ m) with Not_found -> Unknown diff --git a/tools/coqdoc/output.ml b/tools/coqdoc/output.ml index 5c0d2a39b..d043c4a58 100644 --- a/tools/coqdoc/output.ml +++ b/tools/coqdoc/output.ml @@ -693,25 +693,21 @@ module Html = struct printf "<span class=\"id\" title=\"keyword\">%s</span>" (translate s) let ident s loc = - if is_keyword s then begin - printf "<span class=\"id\" title=\"keyword\">%s</span>" (translate s) - end else begin - try - match loc with - | None -> raise Not_found - | Some loc -> - reference (translate s) (Index.find (get_module false) loc) - with Not_found -> - if is_tactic s then - printf "<span class=\"id\" title=\"tactic\">%s</span>" (translate s) - else - if !Cdglobals.interpolate && !in_doc (* always a var otherwise *) - then - try reference (translate s) (Index.find_string (get_module false) s) - with _ -> Tokens.output_tagged_ident_string s - else - Tokens.output_tagged_ident_string s - end + try + match loc with + | None -> raise Not_found + | Some loc -> + reference (translate s) (Index.find (get_module false) loc) + with Not_found -> + if is_tactic s then + printf "<span class=\"id\" title=\"tactic\">%s</span>" (translate s) + else if is_keyword s then + printf "<span class=\"id\" title=\"keyword\">%s</span>" (translate s) + else if !Cdglobals.interpolate && !in_doc (* always a var otherwise *) then + try reference (translate s) (Index.find_string (get_module false) s) + with Not_found -> Tokens.output_tagged_ident_string s + else + Tokens.output_tagged_ident_string s let proofbox () = printf "<font size=-2>☐</font>" diff --git a/toplevel/coqinit.ml b/toplevel/coqinit.ml index 326ef5471..5ca886965 100644 --- a/toplevel/coqinit.ml +++ b/toplevel/coqinit.ml @@ -125,15 +125,3 @@ let init_ocaml_path () = in Mltop.add_ml_dir (Envars.coqlib ()); List.iter add_subdir Coq_config.all_src_dirs - -let get_compat_version ?(allow_old = true) = function - | "8.8" -> Flags.Current - | "8.7" -> Flags.V8_7 - | "8.6" -> Flags.V8_6 - | "8.5" -> Flags.V8_5 - | ("8.4" | "8.3" | "8.2" | "8.1" | "8.0") as s -> - if allow_old then Flags.VOld else - CErrors.user_err ~hdr:"get_compat_version" - (str "Compatibility with version " ++ str s ++ str " not supported.") - | s -> CErrors.user_err ~hdr:"get_compat_version" - (str "Unknown compatibility version \"" ++ str s ++ str "\".") diff --git a/toplevel/coqinit.mli b/toplevel/coqinit.mli index bf8558d10..3432e79cc 100644 --- a/toplevel/coqinit.mli +++ b/toplevel/coqinit.mli @@ -24,5 +24,3 @@ val init_load_path : unit -> unit val init_library_roots : unit -> unit val init_ocaml_path : unit -> unit - -val get_compat_version : ?allow_old:bool -> string -> Flags.compat_version diff --git a/toplevel/coqtop.ml b/toplevel/coqtop.ml index 8fe27b3b9..0f8524e92 100644 --- a/toplevel/coqtop.ml +++ b/toplevel/coqtop.ml @@ -516,7 +516,7 @@ let parse_args arglist = Flags.async_proofs_delegation_threshold:= get_float opt (next ()) |"-worker-id" -> set_worker_id opt (next ()) |"-compat" -> - let v = get_compat_version ~allow_old:false (next ()) in + let v = G_vernac.parse_compat_version ~allow_old:false (next ()) in Flags.compat_version := v; add_compat_require v |"-compile" -> add_compile false (next ()) |"-compile-verbose" -> add_compile true (next ()) @@ -585,7 +585,6 @@ let parse_args arglist = |"-v"|"--version" -> Usage.version (exitcode ()) |"-print-version"|"--print-version" -> Usage.machine_readable_version (exitcode ()) |"-where" -> print_where := true - |"-xml" -> Flags.xml_export := true (* Unknown option *) | s -> extras := s :: !extras diff --git a/toplevel/usage.ml b/toplevel/usage.ml index 962bb4302..d596e36f3 100644 --- a/toplevel/usage.ml +++ b/toplevel/usage.ml @@ -78,9 +78,6 @@ let print_usage_channel co command = \n -impredicative-set set sort Set impredicative\ \n -indices-matter levels of indices (and nonuniform parameters) contribute to the level of inductives\ \n -type-in-type disable universe consistency checking\ -\n -xml export XML files either to the hierarchy rooted in\ -\n the directory $COQ_XML_LIBRARY_ROOT (if set) or to\ -\n stdout (if unset)\ \n -time display the time taken by each command\ \n -profile-ltac display the time taken by each (sub)tactic\ \n -m, --memory display total heap size at program exit\ diff --git a/toplevel/vernac.ml b/toplevel/vernac.ml index fe853c093..bfab44770 100644 --- a/toplevel/vernac.ml +++ b/toplevel/vernac.ml @@ -243,10 +243,6 @@ let process_expr sid loc_ast = checknav_deep loc_ast; interp_vernac sid loc_ast -(* XML output hooks *) -let (f_xml_start_library, xml_start_library) = Hook.make ~default:ignore () -let (f_xml_end_library, xml_end_library) = Hook.make ~default:ignore () - let warn_file_no_extension = CWarnings.create ~name:"file-no-extension" ~category:"filesystem" (fun (f,ext) -> @@ -308,7 +304,6 @@ let compile verbosely f = ~v_file:long_f_dot_v); Dumpglob.start_dump_glob ~vfile:long_f_dot_v ~vofile:long_f_dot_vo; Dumpglob.dump_string ("F" ^ Names.DirPath.to_string ldir ^ "\n"); - if !Flags.xml_export then Hook.get f_xml_start_library (); let wall_clock1 = Unix.gettimeofday () in let _ = load_vernac verbosely (Stm.get_current_state ()) long_f_dot_v in Stm.join (); @@ -318,7 +313,6 @@ let compile verbosely f = Aux_file.record_in_aux_at "vo_compile_time" (Printf.sprintf "%.3f" (wall_clock2 -. wall_clock1)); Aux_file.stop_aux_file (); - if !Flags.xml_export then Hook.get f_xml_end_library (); Dumpglob.end_dump_glob () | BuildVio -> let long_f_dot_v = ensure_v f in diff --git a/toplevel/vernac.mli b/toplevel/vernac.mli index 77c4f44e1..bccf560e1 100644 --- a/toplevel/vernac.mli +++ b/toplevel/vernac.mli @@ -21,7 +21,3 @@ val load_vernac : bool -> Stateid.t -> string -> Stateid.t (** Compile a vernac file, (f is assumed without .v suffix) *) val compile : bool -> string -> unit - -(** Set XML hooks *) -val xml_start_library : (unit -> unit) Hook.t -val xml_end_library : (unit -> unit) Hook.t diff --git a/vernac/command.ml b/vernac/command.ml index e04bebe33..32ab5401a 100644 --- a/vernac/command.ml +++ b/vernac/command.ml @@ -241,7 +241,7 @@ let do_assumptions_unbound_univs (_, poly, _ as kind) nl l = else l in (* We intepret all declarations in the same evar_map, i.e. as a telescope. *) - let _,l = List.fold_map (fun (env,ienv) (is_coe,(idl,c)) -> + let _,l = List.fold_left_map (fun (env,ienv) (is_coe,(idl,c)) -> let t,imps = interp_assumption evdref env ienv [] c in let env = push_named_context (List.map (fun (_,id) -> LocalAssum (id,t)) idl) env in @@ -367,7 +367,7 @@ let prepare_param = function let rec check_anonymous_type ind = let open Glob_term in - match ind.CAst.v with + match DAst.get ind with | GSort (GType []) -> true | GProd ( _, _, _, e) | GLetIn (_, _, _, e) @@ -393,8 +393,9 @@ let is_impredicative env u = let interp_ind_arity env evdref ind = let c = intern_gen IsType env ind.ind_arity in - let imps = Implicit_quantifiers.implicits_of_glob_constr ~with_products:true c in - let t, impls = understand_tcc_evars env evdref ~expected_type:IsType c, imps in + let impls = Implicit_quantifiers.implicits_of_glob_constr ~with_products:true c in + let (evd,t) = understand_tcc env !evdref ~expected_type:IsType c in + evdref := evd; let pseudo_poly = check_anonymous_type c in let () = if not (Reductionops.is_arity env !evdref t) then user_err ?loc:(constr_loc ind.ind_arity) (str "Not an arity") diff --git a/vernac/himsg.ml b/vernac/himsg.ml index 0e5184905..2be10a039 100644 --- a/vernac/himsg.ml +++ b/vernac/himsg.ml @@ -100,17 +100,18 @@ let pr_ljudge_env e s c = let v,t = pr_ljudge_env e s c in (quote v,quote t) (** A canonisation procedure for constr such that comparing there externalisation catches more equalities *) -let canonize_constr c = +let canonize_constr sigma c = (* replaces all the names in binders by [dn] ("default name"), ensures that [alpha]-equivalent terms will have the same externalisation. *) + let open EConstr in let dn = Name.Anonymous in let rec canonize_binders c = - match Term.kind_of_term c with + match EConstr.kind sigma c with | Prod (_,t,b) -> mkProd(dn,t,b) | Lambda (_,t,b) -> mkLambda(dn,t,b) | LetIn (_,u,t,b) -> mkLetIn(dn,u,t,b) - | _ -> Term.map_constr canonize_binders c + | _ -> EConstr.map sigma canonize_binders c in canonize_binders c @@ -118,8 +119,8 @@ let canonize_constr c = let display_eq ~flags env sigma t1 t2 = (* terms are canonized, then their externalisation is compared syntactically *) let open Constrextern in - let t1 = canonize_constr t1 in - let t2 = canonize_constr t2 in + let t1 = canonize_constr sigma t1 in + let t2 = canonize_constr sigma t2 in let ct1 = Flags.with_options flags (fun () -> extern_constr false env sigma t1) () in let ct2 = Flags.with_options flags (fun () -> extern_constr false env sigma t2) () in Constrexpr_ops.constr_expr_eq ct1 ct2 @@ -129,7 +130,7 @@ let display_eq ~flags env sigma t1 t2 = let rec pr_explicit_aux env sigma t1 t2 = function | [] -> (** no specified flags: default. *) - (quote (Printer.pr_lconstr_env env sigma t1), quote (Printer.pr_lconstr_env env sigma t2)) + (quote (Printer.pr_leconstr_env env sigma t1), quote (Printer.pr_leconstr_env env sigma t2)) | flags :: rem -> let equal = display_eq ~flags env sigma t1 t2 in if equal then @@ -153,7 +154,7 @@ let explicit_flags = [print_universes; print_implicits; print_coercions; print_no_symbol] (** and more! *) ] let pr_explicit env sigma t1 t2 = - pr_explicit_aux env sigma (EConstr.to_constr sigma t1) (EConstr.to_constr sigma t2) explicit_flags + pr_explicit_aux env sigma t1 t2 explicit_flags let pr_db env i = try diff --git a/vernac/metasyntax.ml b/vernac/metasyntax.ml index c0974d0a7..8b042a3ca 100644 --- a/vernac/metasyntax.ml +++ b/vernac/metasyntax.ml @@ -522,35 +522,11 @@ let read_recursive_format sl fmt = let slfmt, fmt = get_head fmt in slfmt, get_tail (slfmt, fmt) -let warn_skip_spaces_curly = - CWarnings.create ~name:"skip-spaces-curly" ~category:"parsing" - (fun () ->strbrk "Skipping spaces inside curly brackets") - -let rec drop_spacing = function - | UnpCut _ :: fmt -> warn_skip_spaces_curly (); drop_spacing fmt - | UnpTerminal s' :: fmt when String.equal s' (String.make (String.length s') ' ') -> warn_skip_spaces_curly (); drop_spacing fmt - | fmt -> fmt - -let has_closing_curly_brace symbs fmt = - (* TODO: recognize and fail in case a box overlaps a pair of curly braces *) - let fmt = drop_spacing fmt in - match symbs, fmt with - | NonTerminal s :: symbs, (UnpTerminal s' as u) :: fmt when Id.equal s (Id.of_string s') -> - let fmt = drop_spacing fmt in - (match fmt with - | UnpTerminal "}" :: fmt -> Some (u :: fmt) - | _ -> None) - | _ -> None - let hunks_of_format (from,(vars,typs)) symfmt = - let a = ref None in let rec aux = function | symbs, (UnpTerminal s' as u) :: fmt when String.equal s' (String.make (String.length s') ' ') -> let symbs, l = aux (symbs,fmt) in symbs, u :: l - | symbs, (UnpTerminal "{") :: fmt when (a := has_closing_curly_brace symbs fmt; !a <> None) -> - let newfmt = Option.get !a in - aux (symbs,newfmt) | Terminal s :: symbs, (UnpTerminal s') :: fmt when String.equal s (String.drop_simple_quotes s') -> let symbs, l = aux (symbs,fmt) in symbs, UnpTerminal s :: l @@ -705,26 +681,40 @@ let recompute_assoc typs = (**************************************************************************) (* Registration of syntax extensions (parsing/printing, no interpretation)*) -let pr_arg_level from = function +let pr_arg_level from (lev,typ) = + let pplev = match lev with | (n,L) when Int.equal n from -> str "at next level" | (n,E) -> str "at level " ++ int n | (n,L) -> str "at level below " ++ int n | (n,Prec m) when Int.equal m n -> str "at level " ++ int n - | (n,_) -> str "Unknown level" - -let pr_level ntn (from,args) = + | (n,_) -> str "Unknown level" in + let pptyp = match typ with + | NtnInternTypeConstr -> mt () + | NtnInternTypeBinder -> str " " ++ surround (str "binder") + | NtnInternTypeIdent -> str " " ++ surround (str "ident") in + pplev ++ pptyp + +let pr_level ntn (from,args,typs) = str "at level " ++ int from ++ spc () ++ str "with arguments" ++ spc() ++ - prlist_with_sep pr_comma (pr_arg_level from) args + prlist_with_sep pr_comma (pr_arg_level from) (List.combine args typs) let error_incompatible_level ntn oldprec prec = user_err - (str "Notation " ++ str ntn ++ str " is already defined" ++ spc() ++ + (str "Notation " ++ qstring ntn ++ str " is already defined" ++ spc() ++ + pr_level ntn oldprec ++ + spc() ++ str "while it is now required to be" ++ spc() ++ + pr_level ntn prec ++ str ".") + +let error_parsing_incompatible_level ntn ntn' oldprec prec = + user_err + (str "Notation " ++ qstring ntn ++ str " relies on a parsing rule for " ++ qstring ntn' ++ spc() ++ + str " which is already defined" ++ spc() ++ pr_level ntn oldprec ++ spc() ++ str "while it is now required to be" ++ spc() ++ pr_level ntn prec ++ str ".") type syntax_extension = { - synext_level : Notation.level; + synext_level : Notation_term.level; synext_notation : notation; synext_notgram : notation_grammar; synext_unparsing : unparsing list; @@ -736,7 +726,17 @@ let is_active_compat = function | None -> true | Some v -> 0 <= Flags.version_compare v !Flags.compat_version -type syntax_extension_obj = locality_flag * syntax_extension list +type syntax_extension_obj = locality_flag * syntax_extension + +let check_and_extend_constr_grammar ntn rule = + try + let ntn_for_grammar = rule.notgram_notation in + if String.equal ntn ntn_for_grammar then raise Not_found; + let prec = rule.notgram_level in + let oldprec = Notation.level_of_notation ntn_for_grammar in + if not (Notation.level_eq prec oldprec) then error_parsing_incompatible_level ntn ntn_for_grammar oldprec prec; + with Not_found -> + Egramcoq.extend_constr_grammar rule let cache_one_syntax_extension se = let ntn = se.synext_notation in @@ -744,31 +744,30 @@ let cache_one_syntax_extension se = let onlyprint = se.synext_notgram.notgram_onlyprinting in try let oldprec = Notation.level_of_notation ntn in - if not (Notation.level_eq prec oldprec) then error_incompatible_level ntn oldprec prec + if not (Notation.level_eq prec oldprec) then error_incompatible_level ntn oldprec prec; with Not_found -> if is_active_compat se.synext_compat then begin (* Reserve the notation level *) Notation.declare_notation_level ntn prec; (* Declare the parsing rule *) - if not onlyprint then Egramcoq.extend_constr_grammar prec se.synext_notgram; + if not onlyprint then List.iter (check_and_extend_constr_grammar ntn) se.synext_notgram.notgram_rules; (* Declare the notation rule *) Notation.declare_notation_rule ntn - ~extra:se.synext_extra (se.synext_unparsing, fst prec) se.synext_notgram + ~extra:se.synext_extra (se.synext_unparsing, pi1 prec) se.synext_notgram end let cache_syntax_extension (_, (_, sy)) = - List.iter cache_one_syntax_extension sy + cache_one_syntax_extension sy let subst_parsing_rule subst x = x let subst_printing_rule subst x = x let subst_syntax_extension (subst, (local, sy)) = - let map sy = { sy with - synext_notgram = subst_parsing_rule subst sy.synext_notgram; + (local, { sy with + synext_notgram = { sy.synext_notgram with notgram_rules = List.map (subst_parsing_rule subst) sy.synext_notgram.notgram_rules }; synext_unparsing = subst_printing_rule subst sy.synext_unparsing; - } in - (local, List.map map sy) + }) let classify_syntax_definition (local, _ as o) = if local then Dispose else Substitute o @@ -1049,13 +1048,10 @@ let remove_curly_brackets l = | Terminal "{" as t1 :: l -> let br,next = skip_break [] l in (match next with - | NonTerminal _ as x :: l' as l0 -> + | NonTerminal _ as x :: l' -> let br',next' = skip_break [] l' in (match next' with - | Terminal "}" as t2 :: l'' as l1 -> - if not (List.equal Notation.symbol_eq l l0) || - not (List.equal Notation.symbol_eq l' l1) then - warn_skip_spaces_curly (); + | Terminal "}" as t2 :: l'' -> if deb && List.is_empty l'' then [t1;x;t2] else begin check_curly_brackets_notation_exists (); x :: aux false l'' @@ -1067,6 +1063,8 @@ let remove_curly_brackets l = module SynData = struct + type subentry_types = (Id.t * (production_level, production_position) constr_entry_key_gen) list + (* XXX: Document *) type syn_data = { @@ -1089,17 +1087,28 @@ module SynData = struct intern_typs : notation_var_internalization_type list; (* Notation data for parsing *) - - level : int; - syntax_data : (Id.t * (production_level, production_position) constr_entry_key_gen) list * (* typs *) - symbol list; (* symbols *) + level : level; + pa_syntax_data : subentry_types * symbol list; + pp_syntax_data : subentry_types * symbol list; not_data : notation * (* notation *) - (int * parenRelation) list * (* precedence *) + level * (* level, precedence, types *) bool; (* needs_squash *) } end +let find_subentry_types n assoc etyps symbols = + let innerlevel = NumLevel 200 in + let typs = + find_symbols + (NumLevel n,BorderProd(Left,assoc)) + (innerlevel,InternalProd) + (NumLevel n,BorderProd(Right,assoc)) + symbols in + let sy_typs = List.map (set_entry_type etyps) typs in + let prec = List.map (assoc_of_type n) sy_typs in + sy_typs, prec + let compute_syntax_data df modifiers = let open SynData in let open NotationMods in @@ -1115,27 +1124,24 @@ let compute_syntax_data df modifiers = (* Notations for interp and grammar *) let ntn_for_interp = make_notation_key symbols in - let symbols' = remove_curly_brackets symbols in - let ntn_for_grammar = make_notation_key symbols' in - if not onlyprint then check_rule_productivity symbols'; - - (* Misc *) - let need_squash = not (List.equal Notation.symbol_eq symbols symbols') in - let msgs,n = find_precedence mods.level mods.etyps symbols' in - let innerlevel = NumLevel 200 in - let typs = - find_symbols - (NumLevel n,BorderProd(Left,assoc)) - (innerlevel,InternalProd) - (NumLevel n,BorderProd(Right,assoc)) - symbols' in + let symbols_for_grammar = remove_curly_brackets symbols in + let need_squash = not (List.equal Notation.symbol_eq symbols symbols_for_grammar) in + let ntn_for_grammar = if need_squash then make_notation_key symbols_for_grammar else ntn_for_interp in + if not onlyprint then check_rule_productivity symbols_for_grammar; + let msgs,n = find_precedence mods.level mods.etyps symbols in (* To globalize... *) let etyps = join_auxiliary_recursive_types recvars mods.etyps in - let sy_typs = List.map (set_entry_type etyps) typs in - let prec = List.map (assoc_of_type n) sy_typs in + let sy_typs, prec = + find_subentry_types n assoc etyps symbols in + let sy_typs_for_grammar, prec_for_grammar = + if need_squash then + find_subentry_types n assoc etyps symbols_for_grammar + else + sy_typs, prec in let i_typs = set_internalization_type sy_typs in - let sy_data = (sy_typs,symbols') in - let sy_fulldata = (ntn_for_grammar,prec,need_squash) in + let pa_sy_data = (sy_typs_for_grammar,symbols_for_grammar) in + let pp_sy_data = (sy_typs,symbols) in + let sy_fulldata = (ntn_for_grammar,(n,prec_for_grammar,i_typs),need_squash) in let df' = ((Lib.library_dp(),Lib.current_dirpath true),df) in let i_data = ntn_for_interp, df' in @@ -1154,8 +1160,9 @@ let compute_syntax_data df modifiers = mainvars; intern_typs = i_typs; - level = n; - syntax_data = sy_data; + level = (n,prec,i_typs); + pa_syntax_data = pa_sy_data; + pp_syntax_data = pp_sy_data; not_data = sy_fulldata; } @@ -1236,25 +1243,9 @@ let with_syntax_protection f x = (**********************************************************************) (* Recovering existing syntax *) -let contract_notation ntn = - if String.equal ntn "{ _ }" then ntn else - let rec aux ntn i = - if i <= String.length ntn - 5 then - let ntn' = - if String.is_sub "{ _ }" ntn i && - (i = 0 || ntn.[i-1] = ' ') && - (i = String.length ntn - 5 || ntn.[i+5] = ' ') - then - String.sub ntn 0 i ^ "_" ^ - String.sub ntn (i+5) (String.length ntn -i-5) - else ntn in - aux ntn' (i+1) - else ntn in - aux ntn 0 - exception NoSyntaxRule -let recover_syntax ntn = +let recover_notation_syntax ntn = try let prec = Notation.level_of_notation ntn in let pp_rule,_ = Notation.find_notation_printing_rule ntn in @@ -1271,29 +1262,25 @@ let recover_syntax ntn = raise NoSyntaxRule let recover_squash_syntax sy = - let sq = recover_syntax "{ _ }" in - [sy; sq] - -let recover_notation_syntax rawntn = - let ntn = contract_notation rawntn in - let sy = recover_syntax ntn in - let need_squash = not (String.equal ntn rawntn) in - let rules = if need_squash then recover_squash_syntax sy else [sy] in - sy.synext_notgram.notgram_typs, rules, sy.synext_notgram.notgram_onlyprinting + let sq = recover_notation_syntax "{ _ }" in + sy :: sq.synext_notgram.notgram_rules (**********************************************************************) (* Main entry point for building parsing and printing rules *) -let make_pa_rule i_typs level (typs,symbols) ntn onlyprint = +let make_pa_rule level (typs,symbols) ntn need_squash = let assoc = recompute_assoc typs in let prod = make_production typs symbols in - { notgram_level = level; + let sy = { + notgram_level = level; notgram_assoc = assoc; notgram_notation = ntn; notgram_prods = prod; - notgram_typs = i_typs; - notgram_onlyprinting = onlyprint; - } + } in + (* By construction, the rule for "{ _ }" is declared, but we need to + redeclare it because the file where it is declared needs not be open + when the current file opens (especially in presence of -nois) *) + if need_squash then recover_squash_syntax sy else [sy] let make_pp_rule level (typs,symbols) fmt = match fmt with @@ -1302,21 +1289,16 @@ let make_pp_rule level (typs,symbols) fmt = (* let make_syntax_rules i_typs (ntn,prec,need_squash) sy_data fmt extra onlyprint compat = *) let make_syntax_rules (sd : SynData.syn_data) = let open SynData in - let ntn, prec, need_squash = sd.not_data in - let pa_rule = make_pa_rule sd.intern_typs sd.level sd.syntax_data ntn sd.only_printing in - let pp_rule = make_pp_rule sd.level sd.syntax_data sd.format in - let sy = { - synext_level = (sd.level, prec); - synext_notation = ntn; - synext_notgram = pa_rule; + let ntn_for_grammar, prec_for_grammar, need_squash = sd.not_data in + let pa_rule = make_pa_rule prec_for_grammar sd.pa_syntax_data ntn_for_grammar need_squash in + let pp_rule = make_pp_rule (pi1 sd.level) sd.pp_syntax_data sd.format in { + synext_level = sd.level; + synext_notation = fst sd.info; + synext_notgram = { notgram_onlyprinting = sd.only_printing; notgram_rules = pa_rule }; synext_unparsing = pp_rule; synext_extra = sd.extra; synext_compat = sd.compat; - } in - (* By construction, the rule for "{ _ }" is declared, but we need to - redeclare it because the file where it is declared needs not be open - when the current file opens (especially in presence of -nois) *) - if need_squash then recover_squash_syntax sy else [sy] + } (**********************************************************************) (* Main functions about notations *) @@ -1361,11 +1343,11 @@ let add_notation_interpretation_core local df ?(impls=empty_internalization_env) let (recvars,mainvars,symbs) = analyze_notation_tokens ~onlyprint dfs in (* Recover types of variables and pa/pp rules; redeclare them if needed *) let i_typs, onlyprint = if not (is_numeral symbs) then begin - let i_typs,sy_rules,onlyprint' = recover_notation_syntax (make_notation_key symbs) in - let () = Lib.add_anonymous_leaf (inSyntaxExtension (local,sy_rules)) in + let sy = recover_notation_syntax (make_notation_key symbs) in + let () = Lib.add_anonymous_leaf (inSyntaxExtension (local,sy)) in (** If the only printing flag has been explicitly requested, put it back *) - let onlyprint = onlyprint || onlyprint' in - i_typs, onlyprint + let onlyprint = onlyprint || sy.synext_notgram.notgram_onlyprinting in + pi3 sy.synext_level, onlyprint end else [], false in (* Declare interpretation *) let path = (Lib.library_dp(), Lib.current_dirpath true) in diff --git a/vernac/obligations.ml b/vernac/obligations.ml index 28aeaa725..a4fe49020 100644 --- a/vernac/obligations.ml +++ b/vernac/obligations.ml @@ -650,7 +650,7 @@ let declare_obligation prg obl body ty uctx = let constant = Declare.declare_constant obl.obl_name ~local:true (DefinitionEntry ce,IsProof Property) in - if not opaque then add_hint false prg constant; + if not opaque then add_hint (Locality.make_section_locality None) prg constant; definition_message obl.obl_name; true, { obl with obl_body = if poly then diff --git a/vernac/vernacentries.ml b/vernac/vernacentries.ml index adf24d23b..d2ba9eb1c 100644 --- a/vernac/vernacentries.ml +++ b/vernac/vernacentries.ml @@ -522,7 +522,21 @@ let vernac_assumption locality poly (local, kind) l nl = let status = do_assumptions kind nl l in if not status then Feedback.feedback Feedback.AddedAxiom +let should_treat_as_cumulative cum poly = + if poly then + match cum with + | GlobalCumulativity | LocalCumulativity -> true + | GlobalNonCumulativity | LocalNonCumulativity -> false + else + match cum with + | GlobalCumulativity | GlobalNonCumulativity -> false + | LocalCumulativity -> + user_err Pp.(str "The Cumulative prefix can only be used in a polymorphic context.") + | LocalNonCumulativity -> + user_err Pp.(str "The NonCumulative prefix can only be used in a polymorphic context.") + let vernac_record cum k poly finite struc binders sort nameopt cfs = + let is_cumulative = should_treat_as_cumulative cum poly in let const = match nameopt with | None -> add_prefix "Build_" (snd (fst (snd struc))) | Some (_,id as lid) -> @@ -533,13 +547,14 @@ let vernac_record cum k poly finite struc binders sort nameopt cfs = match x with | Vernacexpr.AssumExpr ((loc, Name id), _) -> Dumpglob.dump_definition (loc,id) false "proj" | _ -> ()) cfs); - ignore(Record.definition_structure (k,cum,poly,finite,struc,binders,cfs,const,sort)) + ignore(Record.definition_structure (k,is_cumulative,poly,finite,struc,binders,cfs,const,sort)) (** When [poly] is true the type is declared polymorphic. When [lo] is true, then the type is declared private (as per the [Private] keyword). [finite] indicates whether the type is inductive, co-inductive or neither. *) let vernac_inductive cum poly lo finite indl = + let is_cumulative = should_treat_as_cumulative cum poly in if Dumpglob.dump () then List.iter (fun (((coe,(lid,_)), _, _, _, cstrs), _) -> match cstrs with @@ -576,7 +591,7 @@ let vernac_inductive cum poly lo finite indl = | _ -> user_err Pp.(str "Cannot handle mutually (co)inductive records.") in let indl = List.map unpack indl in - do_mutual_inductive indl cum poly lo finite + do_mutual_inductive indl is_cumulative poly lo finite let vernac_fixpoint locality poly local l = let local = enforce_locality_exp locality local in @@ -1215,7 +1230,7 @@ let vernac_reserve bl = let env = Global.env() in let sigma = Evd.from_env env in let t,ctx = Constrintern.interp_type env sigma c in - let t = Detyping.detype false [] env (Evd.from_ctx ctx) (EConstr.of_constr t) in + let t = Detyping.detype Detyping.Now false [] env (Evd.from_ctx ctx) (EConstr.of_constr t) in let t,_ = Notation_ops.notation_constr_of_glob_constr (default_env ()) t in Reserve.declare_reserved_type idl t) in List.iter sb_decl bl @@ -1363,10 +1378,10 @@ let _ = let _ = declare_bool_option { optdepr = false; - optname = "inductive cumulativity"; - optkey = ["Inductive"; "Cumulativity"]; - optread = Flags.is_inductive_cumulativity; - optwrite = Flags.make_inductive_cumulativity } + optname = "Polymorphic inductive cumulativity"; + optkey = ["Polymorphic"; "Inductive"; "Cumulativity"]; + optread = Flags.is_polymorphic_inductive_cumulativity; + optwrite = Flags.make_polymorphic_inductive_cumulativity } let _ = declare_int_option @@ -1442,6 +1457,22 @@ let _ = optread = CWarnings.get_flags; optwrite = CWarnings.set_flags } +let _ = + declare_string_option + { optdepr = false; + optname = "native_compute profiler output"; + optkey = ["NativeCompute"; "Profile"; "Filename"]; + optread = Nativenorm.get_profile_filename; + optwrite = Nativenorm.set_profile_filename } + +let _ = + declare_bool_option + { optdepr = false; + optname = "enable native compute profiling"; + optkey = ["NativeCompute"; "Profiling"]; + optread = Nativenorm.get_profiling_enabled; + optwrite = Nativenorm.set_profiling_enabled } + let vernac_set_strategy locality l = let local = make_locality locality in let glob_ref r = |