diff options
324 files changed, 5282 insertions, 3423 deletions
diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index 708ddced15..e688fbd463 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -10,7 +10,7 @@ stages: variables: # Format: $IMAGE-V$DATE [Cache is not used as of today but kept here # for reference] - CACHEKEY: "bionic_coq-V2019-03-11-V1" + CACHEKEY: "bionic_coq-V2019-03-12-V1" IMAGE: "$CI_REGISTRY_IMAGE:$CACHEKEY" # By default, jobs run in the base switch; override to select another switch OPAM_SWITCH: "base" @@ -55,7 +55,7 @@ after_script: ###################################################### # TODO figure out how to build doc for installed Coq -.build-template: &build-template +.build-template: stage: build artifacts: name: "$CI_JOB_NAME" @@ -91,7 +91,7 @@ after_script: - set +e # Template for building Coq + stdlib, typical use: overload the switch -.dune-template: &dune-template +.dune-template: stage: build dependencies: [] script: @@ -107,7 +107,7 @@ after_script: - _build/ expire_in: 1 week -.dune-ci-template: &dune-ci-template +.dune-ci-template: stage: test dependencies: - build:edge+flambda:dune:dev @@ -117,10 +117,10 @@ after_script: - make -f Makefile.dune "$DUNE_TARGET" - echo 'end:coq.test' - set +e - variables: &dune-ci-template-vars + variables: OPAM_SWITCH: edge OPAM_VARIANT: "+flambda" - artifacts: &dune-ci-template-artifacts + artifacts: name: "$CI_JOB_NAME" expire_in: 1 month @@ -129,7 +129,7 @@ after_script: # purpose, we add a spurious dependency `not-a-real-job` that must be # overridden otherwise the CI will fail. -.doc-template: &doc-template +.doc-template: stage: test dependencies: - not-a-real-job @@ -143,7 +143,7 @@ after_script: - _install_ci/share/doc/coq/ # set dependencies when using -.test-suite-template: &test-suite-template +.test-suite-template: stage: test dependencies: - not-a-real-job @@ -162,7 +162,7 @@ after_script: - test-suite/logs # set dependencies when using -.validate-template: &validate-template +.validate-template: stage: test dependencies: - not-a-real-job @@ -172,7 +172,7 @@ after_script: - for regexp in 's/.vo//' 's:lib/coq/plugins:Coq:' 's:lib/coq/theories:Coq:' 's:/:.:g'; do sed -z -i "$regexp" vofiles; done - xargs -0 --arg-file=vofiles bin/coqchk -silent -o -m -coqlib lib/coq/ -.ci-template: &ci-template +.ci-template: stage: test script: - set -e @@ -183,15 +183,15 @@ after_script: dependencies: - build:base -.ci-template-flambda: &ci-template-flambda - <<: *ci-template +.ci-template-flambda: + extends: .ci-template dependencies: - build:edge+flambda variables: OPAM_SWITCH: "edge" OPAM_VARIANT: "+flambda" -.windows-template: &windows-template +.windows-template: stage: test artifacts: name: "%CI_JOB_NAME%" @@ -209,7 +209,7 @@ after_script: variables: - $WINDOWS =~ /enabled/ -.deploy-template: &deploy-template +.deploy-template: stage: deploy before_script: - which ssh-agent || ( apt-get update -y && apt-get install openssh-client -y ) @@ -221,7 +221,7 @@ after_script: - git config --global user.email "coqbot@users.noreply.github.com" build:base: - <<: *build-template + extends: .build-template variables: COQ_EXTRA_CONF: "-native-compiler yes -coqide opt" # coqdoc for stdlib, until we know how to build it from installed Coq @@ -230,13 +230,13 @@ build:base: # no coqide for 32bit: libgtk installation problems build:base+32bit: - <<: *build-template + extends: .build-template variables: OPAM_VARIANT: "+32bit" COQ_EXTRA_CONF: "-native-compiler yes" build:edge+flambda: - <<: *build-template + extends: .build-template variables: OPAM_SWITCH: edge OPAM_VARIANT: "+flambda" @@ -244,30 +244,36 @@ build:edge+flambda: COQ_EXTRA_CONF_QUOTE: "-O3 -unbox-closures" build:edge+flambda:dune:dev: - <<: *dune-template + extends: .dune-template build:base+async: - <<: *build-template + extends: .build-template stage: test variables: COQ_EXTRA_CONF: "-native-compiler yes -coqide opt" COQUSERFLAGS: "-async-proofs on" allow_failure: true # See https://github.com/coq/coq/issues/9658 + only: + variables: + - $UNRELIABLE =~ /enabled/ build:quick: - <<: *build-template + extends: .build-template variables: COQ_EXTRA_CONF: "-native-compiler no" QUICK: "1" allow_failure: true # See https://github.com/coq/coq/issues/9637 + only: + variables: + - $UNRELIABLE =~ /enabled/ windows64: - <<: *windows-template + extends: .windows-template variables: ARCH: "64" windows32: - <<: *windows-template + extends: .windows-template variables: ARCH: "32" except: @@ -300,7 +306,7 @@ pkg:opam: OPAM_SWITCH: "edge" OPAM_VARIANT: "+flambda" -.nix-template: &nix-template +.nix-template: image: nixorg/nix:latest # Minimal NixOS image which doesn't even contain git stage: test variables: @@ -314,6 +320,7 @@ pkg:opam: dependencies: [] # We don't need to download build artifacts before_script: [] # We don't want to use the shared 'before_script' script: + - cat /proc/{cpu,mem}info || true # Use current worktree as tmpdir to allow exporting artifacts in case of failure - export TMPDIR=$PWD # We build an expression rather than a direct URL to not be dependent on @@ -327,7 +334,7 @@ pkg:opam: - nix-build-coq.drv-0/*/test-suite/logs pkg:nix:deploy: - <<: *nix-template + extends: .nix-template environment: name: cachix url: https://coq.cachix.org @@ -339,7 +346,7 @@ pkg:nix:deploy: - /^v.*\..*$/ pkg:nix:deploy:channel: - <<: *deploy-template + extends: .deploy-template environment: name: cachix url: https://coq.cachix.org @@ -351,41 +358,38 @@ pkg:nix:deploy:channel: script: - echo "$CACHIX_DEPLOYMENT_KEY" | tr -d '\r' | ssh-add - > /dev/null - git fetch --unshallow - - git push git@github.com:coq/coq-on-cachix "${CI_COMMIT_REF_NAME}" + - git branch -v + - git push git@github.com:coq/coq-on-cachix "${CI_COMMIT_SHA}":"${CI_COMMIT_REF_NAME}" pkg:nix: - <<: *nix-template + extends: .nix-template except: - master - /^v.*\..*$/ doc:refman: - <<: *doc-template + extends: .doc-template dependencies: - build:base doc:refman:dune: - <<: *dune-ci-template + extends: .dune-ci-template variables: - <<: *dune-ci-template-vars DUNE_TARGET: refman-html artifacts: - <<: *dune-ci-template-artifacts paths: - _build/default/doc/sphinx_build/html doc:stdlib:dune: - <<: *dune-ci-template + extends: .dune-ci-template variables: - <<: *dune-ci-template-vars DUNE_TARGET: stdlib-html artifacts: - <<: *dune-ci-template-artifacts paths: - _build/default/doc/stdlib/html doc:refman:deploy: - <<: *deploy-template + extends: .deploy-template environment: name: deployment url: https://coq.github.io/ @@ -412,29 +416,27 @@ doc:refman:deploy: - git push # TODO: rebase and retry on failure doc:ml-api:odoc: - <<: *dune-ci-template + extends: .dune-ci-template variables: - <<: *dune-ci-template-vars DUNE_TARGET: apidoc artifacts: - <<: *dune-ci-template-artifacts paths: - _build/default/_doc/ test-suite:base: - <<: *test-suite-template + extends: .test-suite-template dependencies: - build:base test-suite:base+32bit: - <<: *test-suite-template + extends: .test-suite-template dependencies: - build:base+32bit variables: OPAM_VARIANT: "+32bit" test-suite:edge+flambda: - <<: *test-suite-template + extends: .test-suite-template dependencies: - build:edge+flambda variables: @@ -507,26 +509,30 @@ test-suite:edge+trunk+dune: allow_failure: true test-suite:base+async: - <<: *test-suite-template + extends: .test-suite-template dependencies: - build:base variables: COQFLAGS: "-async-proofs on" + allow_failure: true + only: + variables: + - $UNRELIABLE =~ /enabled/ validate:base: - <<: *validate-template + extends: .validate-template dependencies: - build:base validate:base+32bit: - <<: *validate-template + extends: .validate-template dependencies: - build:base+32bit variables: OPAM_VARIANT: "+32bit" validate:edge+flambda: - <<: *validate-template + extends: .validate-template dependencies: - build:edge+flambda variables: @@ -534,101 +540,104 @@ validate:edge+flambda: OPAM_VARIANT: "+flambda" validate:quick: - <<: *validate-template + extends: .validate-template dependencies: - build:quick + only: + variables: + - $UNRELIABLE =~ /enabled/ # Libraries are by convention the projects that depend on Coq # but not on its ML API library:ci-bedrock2: - <<: *ci-template + extends: .ci-template library:ci-color: - <<: *ci-template-flambda + extends: .ci-template-flambda library:ci-compcert: - <<: *ci-template-flambda + extends: .ci-template-flambda library:ci-coquelicot: - <<: *ci-template + extends: .ci-template library:ci-cross-crypto: - <<: *ci-template + extends: .ci-template library:ci-fcsl-pcm: - <<: *ci-template + extends: .ci-template library:ci-fiat-crypto: - <<: *ci-template-flambda + extends: .ci-template-flambda library:ci-fiat-crypto-legacy: - <<: *ci-template-flambda + extends: .ci-template-flambda library:ci-flocq: - <<: *ci-template + extends: .ci-template library:ci-corn: - <<: *ci-template-flambda + extends: .ci-template-flambda library:ci-geocoq: - <<: *ci-template-flambda + extends: .ci-template-flambda library:ci-hott: - <<: *ci-template + extends: .ci-template library:ci-iris-lambda-rust: - <<: *ci-template-flambda + extends: .ci-template-flambda library:ci-math-comp: - <<: *ci-template-flambda + extends: .ci-template-flambda library:ci-sf: - <<: *ci-template + extends: .ci-template library:ci-stdlib2: - <<: *ci-template-flambda + extends: .ci-template-flambda library:ci-unimath: - <<: *ci-template-flambda + extends: .ci-template-flambda library:ci-verdi-raft: - <<: *ci-template-flambda + extends: .ci-template-flambda library:ci-vst: - <<: *ci-template-flambda + extends: .ci-template-flambda # Plugins are by definition the projects that depend on Coq's ML API plugin:ci-aac_tactics: - <<: *ci-template + extends: .ci-template plugin:ci-bignums: - <<: *ci-template + extends: .ci-template plugin:ci-coq_dpdgraph: - <<: *ci-template + extends: .ci-template plugin:ci-coqhammer: - <<: *ci-template + extends: .ci-template plugin:ci-elpi: - <<: *ci-template + extends: .ci-template plugin:ci-equations: - <<: *ci-template + extends: .ci-template plugin:ci-fiat_parsers: - <<: *ci-template + extends: .ci-template plugin:ci-ltac2: - <<: *ci-template + extends: .ci-template plugin:ci-mtac2: - <<: *ci-template + extends: .ci-template plugin:ci-paramcoq: - <<: *ci-template + extends: .ci-template plugin:plugin-tutorial: stage: test @@ -638,7 +647,7 @@ plugin:plugin-tutorial: - make -j "$NJOBS" plugin-tutorial plugin:ci-quickchick: - <<: *ci-template-flambda + extends: .ci-template-flambda plugin:ci-relation-algebra: - <<: *ci-template + extends: .ci-template diff --git a/CHANGES.md b/CHANGES.md index 59cc17c233..a1548f730b 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -17,6 +17,8 @@ OCaml and dependencies Coqide +- CoqIDE now depends on gtk+3 and lablgtk3, rather than gtk+2 and lablgtk2. + - CoqIDE now properly sets the module name for a given file based on its path, see -topfile change entry for more details. @@ -175,6 +177,8 @@ Standard Library - The `Coq.Numbers.Cyclic.Int31` library is deprecated. +- Added lemmas about `Z.testbit`, `Z.ones`, and `Z.modulo`. + Universes - Added `Print Universes Subgraph` variant of `Print Universes`. @@ -184,6 +188,11 @@ Universes for the "Private Polymorphic Universes" option (and Unset it to get the previous behaviour). +SProp + +- Added a universe "SProp" for definitionally proof irrelevant + propositions. Use with -allow-sprop. See manual for details. + Inductives - An option and attributes to control the automatic decision to @@ -222,6 +231,12 @@ SSReflect - `=> {x..} /H` -> `=> /v {x..H}` - `rewrite {x..} H` -> `rewrite E {x..H}` +Diffs + +- Some error messages that show problems with a pair of non-matching values will now + highlight the differences. + + Changes from 8.8.2 to 8.9+beta1 =============================== @@ -43,8 +43,8 @@ WHAT DO YOU NEED ? - a C compiler - - for CoqIDE, the lablgtk development files (version >= 2.18.5), - and the GTK 2.x libraries including gtksourceview2. + - for CoqIDE, the lablgtk development files (version >= 3.0.0), + and the GTK 3.x libraries including gtksourceview3. Note that num and lablgtk should be properly registered with findlib/ocamlfind as Coq's makefile will use it to locate the diff --git a/Makefile.build b/Makefile.build index 2e4700be88..2a071fd820 100644 --- a/Makefile.build +++ b/Makefile.build @@ -200,7 +200,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=$(NATIVECOMPUTE) $(COQWARNERROR) $(COQUSERFLAGS) +COQOPTS=$(NATIVECOMPUTE) $(COQWARNERROR) $(COQUSERFLAGS) -allow-sprop # Beware this depends on the makefile being in a particular dir, we # should pass an absolute path here but windows is tricky # c.f. https://github.com/coq/coq/pull/9560 diff --git a/Makefile.ide b/Makefile.ide index db1cc3746d..778863d1fc 100644 --- a/Makefile.ide +++ b/Makefile.ide @@ -17,7 +17,6 @@ ## Coqide-related variables set by ./configure in config/Makefile -#COQIDEINCLUDES : something like -I +lablgtk2 #HASCOQIDE : opt / byte / no #IDEFLAGS : some extra cma, for instance #IDEOPTCDEPS : on windows, ide/ide_win32_stubs.o ide/coq_icon.o @@ -41,7 +40,11 @@ COQIDEINAPP:=$(COQIDEAPP)/Contents/MacOS/coqide IDESRCDIRS:= $(CORESRCDIRS) ide ide/protocol -COQIDEFLAGS=$(addprefix -I , $(IDESRCDIRS)) $(COQIDEINCLUDES) +ifeq ($(HASCOQIDE),no) +COQIDEFLAGS=$(addprefix -I , $(IDESRCDIRS)) +else +COQIDEFLAGS=$(addprefix -I , $(IDESRCDIRS)) -package lablgtk3-sourceview3 +endif IDEDEPS:=config/config.cma clib/clib.cma lib/lib.cma ide/protocol/ideprotocol.cma IDECMA:=ide/ide.cma @@ -56,11 +59,11 @@ IDEFILES=$(wildcard ide/*.lang) ide/coq_style.xml ide/coq.png ide/MacOS/default_ ## GTK for Coqide MacOS bundle -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 +GTKSHARE=$(shell pkg-config --variable=prefix gtk+-3.0)/share +GTKBIN=$(shell pkg-config --variable=prefix gtk+-3.0)/bin +GTKLIBS=$(shell pkg-config --variable=libdir gtk+-3.0) +PIXBUFBIN=$(shell pkg-config --variable=prefix gdk-pixbuf-3.0)/bin +SOURCEVIEWSHARE=$(shell pkg-config --variable=prefix gtksourceview-3.0)/share ########################################################################### # CoqIde special targets @@ -98,7 +101,7 @@ ifeq ($(HASCOQIDE),opt) $(COQIDE): $(LINKIDEOPT) $(SHOW)'OCAMLOPT -o $@' $(HIDE)$(OCAMLOPT) $(COQIDEFLAGS) $(OPTFLAGS) -o $@ \ - -linkpkg -package str,unix,dynlink,threads,lablgtk2.sourceview2 $(IDEFLAGS:.cma=.cmxa) $^ + -linkpkg -package str,unix,dynlink,threads,lablgtk3-sourceview3 -linkall $(IDEFLAGS:.cma=.cmxa) $^ $(STRIP_HIDE) $@ else $(COQIDE): $(COQIDEBYTE) @@ -108,7 +111,7 @@ endif $(COQIDEBYTE): $(LINKIDE) $(SHOW)'OCAMLC -o $@' $(HIDE)$(OCAMLC) $(COQIDEFLAGS) $(BYTEFLAGS) -o $@ \ - -linkpkg -package str,unix,dynlink,threads,lablgtk2.sourceview2 $(IDEFLAGS) $(IDECDEPSFLAGS) $^ + -linkpkg -package str,unix,dynlink,threads,lablgtk3-sourceview3 $(IDEFLAGS) $(IDECDEPSFLAGS) $^ ide/coqide_os_specific.ml: ide/coqide_$(IDEINT).ml.in config/Makefile @rm -f $@ @@ -128,7 +131,7 @@ ide/%.cmx: ide/%.ml $(HIDE)$(OCAMLOPT) $(COQIDEFLAGS) $(OPTFLAGS) -c $< # We need to compile this file without -safe-string due mess with -# lablgtk API. Other option is to require lablgtk >= 2.8.16 +# lablgtk API. Other option is to require lablgtk >= 3.0.0 ide/ideutils.cmo: ide/ideutils.ml $(SHOW)'OCAMLC $<' $(HIDE)$(filter-out -safe-string,$(OCAMLC)) $(COQIDEFLAGS) $(BYTEFLAGS) -c $< @@ -228,7 +231,7 @@ $(COQIDEAPP)/Contents: $(COQIDEINAPP): ide/macos_prehook.cmx $(LINKIDEOPT) | $(COQIDEAPP)/Contents $(SHOW)'OCAMLOPT -o $@' $(HIDE)$(OCAMLOPT) $(COQIDEFLAGS) $(OPTFLAGS) -o $@ \ - -linkpkg -package str,unix,dynlink,threads,lablgtk2.sourceview2 $(IDEFLAGS:.cma=.cmxa) $^ + -linkpkg -package str,unix,dynlink,threads,lablgtk3.sourceview3 $(IDEFLAGS:.cma=.cmxa) $^ $(STRIP_HIDE) $@ $(COQIDEAPP)/Contents/Resources/share: $(COQIDEAPP)/Contents diff --git a/checker/checkInductive.ml b/checker/checkInductive.ml index b681fb876e..4f4527ca12 100644 --- a/checker/checkInductive.ml +++ b/checker/checkInductive.ml @@ -25,7 +25,7 @@ let to_entry (mb:mutual_inductive_body) : Entries.mutual_inductive_entry = let nparams = List.length mb.mind_params_ctxt in (* include letins *) let mind_entry_record = match mb.mind_record with | NotRecord -> None | FakeRecord -> Some None - | PrimRecord data -> Some (Some (Array.map pi1 data)) + | PrimRecord data -> Some (Some (Array.map (fun (x,_,_,_) -> x) data)) in let mind_entry_universes = match mb.mind_universes with | Monomorphic univs -> Monomorphic_entry univs @@ -95,8 +95,8 @@ let eq_in_context (ctx1, t1) (ctx2, t2) = let check_packet env mind ind { mind_typename; mind_arity_ctxt; mind_arity; mind_consnames; mind_user_lc; mind_nrealargs; mind_nrealdecls; mind_kelim; mind_nf_lc; - mind_consnrealargs; mind_consnrealdecls; mind_recargs; mind_nb_constant; - mind_nb_args; mind_reloc_tbl } = + mind_consnrealargs; mind_consnrealdecls; mind_recargs; mind_relevance; + mind_nb_constant; mind_nb_args; mind_reloc_tbl } = let check = check mind in ignore mind_typename; (* passed through *) @@ -117,6 +117,8 @@ let check_packet env mind ind check "mind_recargs" (Rtree.equal eq_recarg ind.mind_recargs mind_recargs); + check "mind_relevant" (Sorts.relevance_equal ind.mind_relevance mind_relevance); + check "mind_nb_args" Int.(equal ind.mind_nb_args mind_nb_args); check "mind_nb_constant" Int.(equal ind.mind_nb_constant mind_nb_constant); check "mind_reloc_tbl" (eq_reloc_tbl ind.mind_reloc_tbl mind_reloc_tbl); @@ -128,7 +130,8 @@ let check_same_record r1 r2 = match r1, r2 with | PrimRecord r1, PrimRecord r2 -> (* The kernel doesn't care about the names, we just need to check that the saved types are correct. *) - Array.for_all2 (fun (_,_,tys1) (_,_,tys2) -> + Array.for_all2 (fun (_,_,r1,tys1) (_,_,r2,tys2) -> + Array.equal Sorts.relevance_equal r1 r2 && Array.equal Constr.equal tys1 tys2) r1 r2 | (NotRecord | FakeRecord | PrimRecord _), _ -> false diff --git a/checker/checker.ml b/checker/checker.ml index d3f346d76b..cbac9cb570 100644 --- a/checker/checker.ml +++ b/checker/checker.ml @@ -146,6 +146,7 @@ let make_senv () = let senv = Safe_typing.set_engagement !impredicative_set senv in let senv = Safe_typing.set_indices_matter !indices_matter senv in let senv = Safe_typing.set_VM false senv in + let senv = Safe_typing.set_allow_sprop true senv in (* be smarter later *) Safe_typing.set_native_compiler false senv let admit_list = ref ([] : object_file list) @@ -296,6 +297,8 @@ let explain_exn = function | IllFormedRecBody _ -> str"IllFormedRecBody" | IllTypedRecBody _ -> str"IllTypedRecBody" | UnsatisfiedConstraints _ -> str"UnsatisfiedConstraints" + | DisallowedSProp -> str"DisallowedSProp" + | BadRelevance -> str"BadRelevance" | UndeclaredUniverse _ -> str"UndeclaredUniverse")) | InductiveError e -> @@ -383,6 +386,7 @@ let init_with_argv argv = let _fhandle = Feedback.(add_feeder (console_feedback_listener Format.err_formatter)) in try parse_args argv; + CWarnings.set_flags ("+"^Typeops.warn_bad_relevance_name); if !Flags.debug then Printexc.record_backtrace true; Envars.set_coqlib ~fail:(fun x -> CErrors.user_err Pp.(str x)); Flags.if_verbose print_header (); diff --git a/checker/values.ml b/checker/values.ml index bcac3014be..5cbf0ff298 100644 --- a/checker/values.ml +++ b/checker/values.ml @@ -95,9 +95,9 @@ let v_cons = v_tuple "constructor" [|v_ind;Int|] (** kernel/univ *) let v_level_global = v_tuple "Level.Global.t" [|v_dp;Int|] -let v_raw_level = v_sum "raw_level" 2 (* Prop, Set *) +let v_raw_level = v_sum "raw_level" 3 (* SProp, Prop, Set *) [|(*Level*)[|v_level_global|]; (*Var*)[|Int|]|] -let v_level = v_tuple "level" [|Int;v_raw_level|] +let v_level = v_tuple "level" [|Int;v_raw_level|] let v_expr = v_tuple "levelexpr" [|v_level;Int|] let v_univ = List v_expr @@ -116,8 +116,11 @@ let v_context_set = v_tuple "universe_context_set" [|v_hset v_level;v_cstrs|] (** kernel/term *) -let v_sort = v_sum "sort" 2 (*Prop, Set*) [|[|v_univ(*Type*)|]|] -let v_sortfam = v_enum "sorts_family" 3 +let v_sort = v_sum "sort" 3 (*SProp, Prop, Set*) [|[|v_univ(*Type*)|]|] +let v_sortfam = v_enum "sorts_family" 4 + +let v_relevance = v_sum "relevance" 2 [||] +let v_binder_annot x = v_tuple "binder_annot" [|x;v_relevance|] let v_puniverses v = v_tuple "punivs" [|v;v_instance|] @@ -126,7 +129,7 @@ let v_boollist = List v_bool let v_caseinfo = let v_cstyle = v_enum "case_style" 5 in let v_cprint = v_tuple "case_printing" [|v_boollist;Array v_boollist;v_cstyle|] in - v_tuple "case_info" [|v_ind;Int;Array Int;Array Int;v_cprint|] + v_tuple "case_info" [|v_ind;Int;Array Int;Array Int;v_relevance;v_cprint|] let v_cast = v_enum "cast_kind" 4 @@ -141,9 +144,9 @@ let rec v_constr = [|Fail "Evar"|]; (* Evar *) [|v_sort|]; (* Sort *) [|v_constr;v_cast;v_constr|]; (* Cast *) - [|v_name;v_constr;v_constr|]; (* Prod *) - [|v_name;v_constr;v_constr|]; (* Lambda *) - [|v_name;v_constr;v_constr;v_constr|]; (* LetIn *) + [|v_binder_annot v_name;v_constr;v_constr|]; (* Prod *) + [|v_binder_annot v_name;v_constr;v_constr|]; (* Lambda *) + [|v_binder_annot v_name;v_constr;v_constr;v_constr|]; (* LetIn *) [|v_constr;Array v_constr|]; (* App *) [|v_puniverses v_cst|]; (* Const *) [|v_puniverses v_ind|]; (* Ind *) @@ -156,12 +159,13 @@ let rec v_constr = |]) and v_prec = Tuple ("prec_declaration", - [|Array v_name; Array v_constr; Array v_constr|]) + [|Array (v_binder_annot v_name); Array v_constr; Array v_constr|]) and v_fix = Tuple ("pfixpoint", [|Tuple ("fix2",[|Array Int;Int|]);v_prec|]) and v_cofix = Tuple ("pcofixpoint",[|Int;v_prec|]) -let v_rdecl = v_sum "rel_declaration" 0 [| [|v_name; v_constr|]; (* LocalAssum *) - [|v_name; v_constr; v_constr|] |] (* LocalDef *) +let v_rdecl = v_sum "rel_declaration" 0 + [| [|v_binder_annot v_name; v_constr|]; (* LocalAssum *) + [|v_binder_annot v_name; v_constr; v_constr|] |] (* LocalDef *) let v_rctxt = List v_rdecl let v_section_ctxt = v_enum "emptylist" 1 @@ -231,6 +235,7 @@ let v_cb = v_tuple "constant_body" [|v_section_ctxt; v_cst_def; v_constr; + v_relevance; Any; v_univs; Opt v_context_set; @@ -265,6 +270,7 @@ let v_one_ind = v_tuple "one_inductive_body" Array Int; Array Int; v_wfp; + v_relevance; Int; Int; Any|] @@ -273,7 +279,7 @@ let v_finite = v_enum "recursivity_kind" 3 let v_record_info = v_sum "record_info" 2 - [| [| Array (v_tuple "record" [| v_id; Array v_id; Array v_constr |]) |] |] + [| [| Array (v_tuple "record" [| v_id; Array v_id; Array v_relevance; Array v_constr |]) |] |] let v_ind_pack = v_tuple "mutual_inductive_body" [|Array v_one_ind; diff --git a/clib/cArray.ml b/clib/cArray.ml index e0a1859184..774e3a56a6 100644 --- a/clib/cArray.ml +++ b/clib/cArray.ml @@ -52,6 +52,8 @@ sig val map2_i : (int -> 'a -> 'b -> 'c) -> 'a array -> 'b array -> 'c array val map3 : ('a -> 'b -> 'c -> 'd) -> 'a array -> 'b array -> 'c array -> 'd array + val map3_i : + (int -> 'a -> 'b -> 'c -> 'd) -> 'a array -> 'b array -> 'c array -> 'd array val map_left : ('a -> 'b) -> 'a array -> 'b array val iter2_i : (int -> 'a -> 'b -> unit) -> 'a array -> 'b array -> unit val fold_left_map : ('a -> 'b -> 'a * 'c) -> 'a -> 'b array -> 'a * 'c array @@ -66,6 +68,7 @@ sig module Smart : sig val map : ('a -> 'a) -> 'a array -> 'a array + val map_i : (int -> 'a -> 'a) -> 'a array -> 'a array val map2 : ('a -> 'b -> 'b) -> 'a array -> 'b array -> 'b array val fold_left_map : ('a -> 'b -> 'a * 'b) -> 'a -> 'b array -> 'a * 'b array val fold_left2_map : ('a -> 'b -> 'c -> 'a * 'c) -> 'a -> 'b array -> 'c array -> 'a * 'c array @@ -358,6 +361,21 @@ let map3 f v1 v2 v3 = res end +let map3_i f v1 v2 v3 = + let len1 = Array.length v1 in + let len2 = Array.length v2 in + let len3 = Array.length v3 in + let () = if not (Int.equal len1 len2 && Int.equal len1 len3) then invalid_arg "Array.map3_i" in + if Int.equal len1 0 then + [| |] + else begin + let res = Array.make len1 (f 0 (uget v1 0) (uget v2 0) (uget v3 0)) in + for i = 1 to pred len1 do + Array.unsafe_set res i (f i (uget v1 i) (uget v2 i) (uget v3 i)) + done; + res + end + let map_left f a = (* Ocaml does not guarantee Array.map is LR *) let l = Array.length a in (* (even if so), then we rewrite it *) if Int.equal l 0 then [||] else begin @@ -465,6 +483,36 @@ struct ans end else ar + (* Same as map_i but smart *) + let map_i f (ar : 'a array) = + let len = Array.length ar in + let i = ref 0 in + let break = ref true in + let temp = ref None in + while !break && (!i < len) do + let v = Array.unsafe_get ar !i in + let v' = f !i v in + if v == v' then incr i + else begin + break := false; + temp := Some v'; + end + done; + if !i < len then begin + (* The array is not the same as the original one *) + let ans : 'a array = Array.copy ar in + let v = match !temp with None -> assert false | Some x -> x in + Array.unsafe_set ans !i v; + incr i; + while !i < len do + let v = Array.unsafe_get ans !i in + let v' = f !i v in + if v != v' then Array.unsafe_set ans !i v'; + incr i + done; + ans + end else ar + let map2 f aux_ar ar = let len = Array.length ar in let aux_len = Array.length aux_ar in diff --git a/clib/cArray.mli b/clib/cArray.mli index 21479d2b45..c1b29bb9d3 100644 --- a/clib/cArray.mli +++ b/clib/cArray.mli @@ -83,6 +83,8 @@ sig val map2_i : (int -> 'a -> 'b -> 'c) -> 'a array -> 'b array -> 'c array val map3 : ('a -> 'b -> 'c -> 'd) -> 'a array -> 'b array -> 'c array -> 'd array + val map3_i : + (int -> 'a -> 'b -> 'c -> 'd) -> 'a array -> 'b array -> 'c array -> 'd array val map_left : ('a -> 'b) -> 'a array -> 'b array (** As [map] but guaranteed to be left-to-right. *) @@ -127,6 +129,8 @@ sig (** [Smart.map f a] behaves as [map f a] but returns [a] instead of a copy when [f x == x] for all [x] in [a]. *) + val map_i : (int -> 'a -> 'a) -> 'a array -> 'a array + val map2 : ('a -> 'b -> 'b) -> 'a array -> 'b array -> 'b array (** [Smart.map2 f a b] behaves as [map2 f a b] but returns [a] instead of a copy when [f x y == y] for all [x] in [a] and [y] in [b] pointwise. *) diff --git a/clib/cList.ml b/clib/cList.ml index 524945ef23..aa01f6e5b5 100644 --- a/clib/cList.ml +++ b/clib/cList.ml @@ -98,6 +98,7 @@ sig val split : ('a * 'b) list -> 'a list * 'b list val combine : 'a list -> 'b list -> ('a * 'b) list val split3 : ('a * 'b * 'c) list -> 'a list * 'b list * 'c list + val split4 : ('a * 'b * 'c * 'd) list -> 'a list * 'b list * 'c list * 'd list val combine3 : 'a list -> 'b list -> 'c list -> ('a * 'b * 'c) list val add_set : 'a eq -> 'a -> 'a list -> 'a list val eq_set : 'a eq -> 'a list -> 'a list -> bool @@ -846,6 +847,12 @@ let split3 = function split3_loop cp cq cr l; (cast cp, cast cq, cast cr) +(** XXX TODO tailrec *) +let rec split4 = function + | [] -> ([], [], [], []) + | (a,b,c,d)::l -> + let (ra, rb, rc, rd) = split4 l in (a::ra, b::rb, c::rc, d::rd) + let rec combine3_loop p l1 l2 l3 = match l1, l2, l3 with | [], [], [] -> () | x :: l1, y :: l2, z :: l3 -> diff --git a/clib/cList.mli b/clib/cList.mli index 8582e6cd65..a2fe0b759a 100644 --- a/clib/cList.mli +++ b/clib/cList.mli @@ -308,6 +308,9 @@ sig val split3 : ('a * 'b * 'c) list -> 'a list * 'b list * 'c list (** Like [split] but for triples *) + val split4 : ('a * 'b * 'c * 'd) list -> 'a list * 'b list * 'c list * 'd list + (** Like [split] but for quads *) + val combine3 : 'a list -> 'b list -> 'c list -> ('a * 'b * 'c) list (** Like [combine] but for triples *) diff --git a/configure.ml b/configure.ml index 8b6fccb5e3..5b99851f83 100644 --- a/configure.ml +++ b/configure.ml @@ -150,7 +150,11 @@ let numeric_prefix_list s = let max = String.length s in let i = ref 0 in while !i < max && isnum s.[!i] do incr i done; - string_split '.' (String.sub s 0 !i) + match string_split '.' (String.sub s 0 !i) with + | [v] -> [v;"0";"0"] + | [v1;v2] -> [v1;v2;"0"] + | [v1;v2;""] -> [v1;v2;"0"] (* e.g. because it ends with ".beta" *) + | v -> v (** Combined existence and directory tests *) @@ -226,7 +230,6 @@ type preferences = { docdir : string option; coqdocdir : string option; ocamlfindcmd : string option; - lablgtkdir : string option; arch : string option; natdynlink : bool; coqide : ide option; @@ -263,7 +266,6 @@ let default = { docdir = None; coqdocdir = None; ocamlfindcmd = None; - lablgtkdir = None; arch = None; natdynlink = true; coqide = None; @@ -368,8 +370,6 @@ let args_options = Arg.align [ "<dir> Where to install Coqdoc style files"; "-ocamlfind", arg_string_option (fun p ocamlfindcmd -> { p with ocamlfindcmd }), "<dir> Specifies the ocamlfind command to use"; - "-lablgtkdir", arg_string_option (fun p lablgtkdir -> { p with lablgtkdir }), - "<dir> Specifies the path to the Lablgtk library"; "-flambda-opts", arg_string_list ' ' (fun p flambda_flags -> { p with flambda_flags }), "<flags> Specifies additional flags to be passed to the flambda optimizing compiler"; "-arch", arg_string_option (fun p arch -> { p with arch }), @@ -697,75 +697,31 @@ let check_for_numlib () = let numlib = check_for_numlib () -(** * lablgtk2 and CoqIDE *) +(** * lablgtk3 and CoqIDE *) -type source = Manual | OCamlFind | Stdlib - -let get_source = function -| Manual -> "manually provided" -| OCamlFind -> "via ocamlfind" -| Stdlib -> "in OCaml library" - -(** Is some location a suitable LablGtk2 installation ? *) - -let check_lablgtkdir ?(fatal=false) src dir = - let yell msg = if fatal then die msg else (warn "%s" msg; false) in - let msg = get_source src in - if not (dir_exists dir) then - yell (sprintf "No such directory '%s' (%s)." dir msg) - else if not (Sys.file_exists (dir/"gSourceView2.cmi")) then - yell (sprintf "Incomplete LablGtk2 (%s): no %s/gSourceView2.cmi." msg dir) - else if not (Sys.file_exists (dir/"glib.mli")) then - yell (sprintf "Incomplete LablGtk2 (%s): no %s/glib.mli." msg dir) - else true - -(** Detect and/or verify the Lablgtk2 location *) +(** Detect and/or verify the Lablgtk3 location *) let get_lablgtkdir () = - match !prefs.lablgtkdir with - | Some dir -> - let msg = Manual in - if check_lablgtkdir ~fatal:true msg dir then dir, msg - else "", msg - | None -> - let msg = OCamlFind in - let d1,_ = tryrun camlexec.find ["query";"lablgtk2.sourceview2"] in - if d1 <> "" && check_lablgtkdir msg d1 then d1, msg - else - (* In debian wheezy, ocamlfind knows only of lablgtk2 *) - let d2,_ = tryrun camlexec.find ["query";"lablgtk2"] in - if d2 <> "" && d2 <> d1 && check_lablgtkdir msg d2 then d2, msg - else - let msg = Stdlib in - let d3 = camllib^"/lablgtk2" in - if check_lablgtkdir msg d3 then d3, msg - else "", msg + tryrun camlexec.find ["query";"lablgtk3-sourceview3"] (** Detect and/or verify the Lablgtk2 version *) -let check_lablgtk_version src dir = match src with -| Manual | Stdlib -> - warn "Could not check the version of lablgtk2.\nMake sure your version is at least 2.18.3."; - (true, "an unknown version") -| OCamlFind -> - let v, _ = tryrun camlexec.find ["query"; "-format"; "%v"; "lablgtk2"] in - try - let vi = List.map s2i (numeric_prefix_list v) in - if vi < [2; 16; 0] then +let check_lablgtk_version () = + let v, _ = tryrun camlexec.find ["query"; "-format"; "%v"; "lablgtk3"] in + (true, v) + +(* ejgallego: we wait to do version checks until an official release is out *) +(* try + let vi = numeric_prefix_list v in + (* Temporary hack *) + if vi = ["3";"0";"beta3"] then (false, v) else + let vi = List.map s2i vi in + if vi < [3; 0; 0] then (false, v) - else if vi < [2; 18; 3] then - begin - (* Version 2.18.3 is known to report incorrectly as 2.18.0, and Launchpad packages report as version 2.16.0 due to a misconfigured META file; see https://bugs.launchpad.net/ubuntu/+source/lablgtk2/+bug/1577236 *) - warn "Your installed lablgtk reports as %s.\n\ -It is possible that the installed version is actually more recent\n\ -but reports an incorrect version. If the installed version is\n\ -actually more recent than 2.18.3, that's fine; if it is not,\n -CoqIDE will compile but may be very unstable." v; - (true, "an unknown version") - end else (true, v) with _ -> (false, v) +*) let pr_ide = function No -> "no" | Byte -> "only bytecode" | Opt -> "native" @@ -788,19 +744,19 @@ let lablgtkdir = ref "" let check_coqide () = if !prefs.coqide = Some No then set_ide No "CoqIde manually disabled"; let dir, via = get_lablgtkdir () in - if dir = "" then set_ide No "LablGtk2 not found"; - let (ok, version) = check_lablgtk_version via dir in - let found = sprintf "LablGtk2 found (%s, %s)" (get_source via) version in - if not ok then set_ide No (found^", but too old (required >= 2.18.3, found " ^ version ^ ")"); - (* We're now sure to produce at least one kind of coqide *) - lablgtkdir := shorten_camllib dir; - if !prefs.coqide = Some Byte then set_ide Byte (found^", bytecode requested"); - if best_compiler<>"opt" then set_ide Byte (found^", but no native compiler"); - if not (Sys.file_exists (dir/"gtkThread.cmx")) then - set_ide Byte (found^", but no native LablGtk2"); - if not (Sys.file_exists (camllib/"threads"/"threads.cmxa")) then - set_ide Byte (found^", but no native threads"); - set_ide Opt (found^", with native threads") + if dir = "" + then set_ide No "LablGtk3 not found" + else + let (ok, version) = check_lablgtk_version () in + let found = sprintf "LablGtk3 found (%s)" version in + if not ok then set_ide No (found^", but too old (required >= 3.0, found " ^ version ^ ")"); + (* We're now sure to produce at least one kind of coqide *) + lablgtkdir := shorten_camllib dir; + if !prefs.coqide = Some Byte then set_ide Byte (found^", bytecode requested"); + if best_compiler <> "opt" then set_ide Byte (found^", but no native compiler"); + if not (Sys.file_exists (camllib/"threads"/"threads.cmxa")) then + set_ide Byte (found^", but no native threads"); + set_ide Opt (found^", with native threads") let coqide = try check_coqide () @@ -808,19 +764,16 @@ let coqide = (** System-specific CoqIde flags *) -let lablgtkincludes = ref "" let idearchflags = ref "" let idearchfile = ref "" let idecdepsflags = ref "" let idearchdef = ref "X11" let coqide_flags () = - if !lablgtkdir <> "" then lablgtkincludes := sprintf "-I %S" !lablgtkdir; match coqide, arch with | "opt", "Darwin" when !prefs.macintegration -> let osxdir,_ = tryrun camlexec.find ["query";"lablgtkosx"] in if osxdir <> "" then begin - lablgtkincludes := sprintf "%s -I %S" !lablgtkincludes osxdir; idearchflags := "lablgtkosx.cma"; idearchdef := "QUARTZ" end @@ -1011,7 +964,7 @@ let print_summary () = if best_compiler = "opt" then pr " Native dynamic link support : %B\n" hasnatdynlink; if coqide <> "no" then - pr " Lablgtk2 library in : %s\n" (esc !lablgtkdir); + pr " Lablgtk3 library in : %s\n" (esc !lablgtkdir); if !idearchdef = "QUARTZ" then pr " Mac OS integration is on\n"; pr " CoqIde : %s\n" coqide; @@ -1203,7 +1156,6 @@ let write_makefile f = pr "# Unix systems and no profiling: strip\n"; pr "STRIP=%s\n\n" strip; pr "# LablGTK\n"; - pr "COQIDEINCLUDES=%s\n\n" !lablgtkincludes; pr "# CoqIde (no/byte/opt)\n"; pr "HASCOQIDE=%s\n" coqide; pr "IDEFLAGS=%s\n" !idearchflags; diff --git a/coqide.opam b/coqide.opam index 314943a881..c82fa72564 100644 --- a/coqide.opam +++ b/coqide.opam @@ -17,10 +17,10 @@ dev-repo: "git+https://github.com/coq/coq.git" license: "LGPL-2.1" depends: [ - "dune" { build & >= "1.4.0" } + "dune" { build & >= "1.4.0" } "coqide-server" - "conf-gtksourceview" - "lablgtk" { >= "2.18.5" } + "lablgtk3" { >= "3.0.beta5" } + "lablgtk3-sourceview3" { >= "3.0.beta5" } ] build-env: [ diff --git a/coqpp/coqpp_main.ml b/coqpp/coqpp_main.ml index cc76c44651..d33eef135f 100644 --- a/coqpp/coqpp_main.ml +++ b/coqpp/coqpp_main.ml @@ -493,7 +493,7 @@ let print_ast fmt arg = let pr fmt () = fprintf fmt "Vernacextend.vernac_argument_extend ~name:%a @[{@\n\ Vernacextend.arg_parsing = %a;@\n\ - Vernacextend.arg_printer = %a;@\n}@]" + Vernacextend.arg_printer = fun env sigma -> %a;@\n}@]" print_string name print_rules (name, arg.vernacargext_rules) print_printer arg.vernacargext_printer in @@ -579,7 +579,7 @@ let print_ast fmt arg = Tacentries.arg_intern = @[%a@];@\n\ Tacentries.arg_subst = @[%a@];@\n\ Tacentries.arg_interp = @[%a@];@\n\ - Tacentries.arg_printer = @[((%a), (%a), (%a))@];@\n}@]" + Tacentries.arg_printer = @[((fun env sigma -> %a), (fun env sigma -> %a), (fun env sigma -> %a))@];@\n}@]" print_string name VernacArgumentExt.print_rules (name, arg.argext_rules) pr_tag arg.argext_type diff --git a/default.nix b/default.nix index 3290f5dee8..1e2cb3625d 100644 --- a/default.nix +++ b/default.nix @@ -21,11 +21,7 @@ # Once the build is finished, you will find, in the current directory, # a symlink to where Coq was installed. -{ pkgs ? - (import (fetchTarball { - url = "https://github.com/NixOS/nixpkgs/archive/11cf7d6e1ffd5fbc09a51b76d668ad0858a772ed.tar.gz"; - sha256 = "0zcg4mgfdk3ryiqj1j5iv5bljjvsgi6q6j9z1vkq383c4g4clc72"; - }) {}) +{ pkgs ? import ./dev/nixpkgs.nix {} , ocamlPackages ? pkgs.ocamlPackages , buildIde ? true , buildDoc ? true @@ -49,7 +45,10 @@ stdenv.mkDerivation rec { dune ] ++ (with ocamlPackages; [ ocaml findlib num ]) - ++ optional buildIde ocamlPackages.lablgtk + ++ optionals buildIde [ + ocamlPackages.lablgtk3-sourceview3 + glib gnome3.defaultIconTheme wrapGAppsHook + ] ++ optionals buildDoc [ # Sphinx doc dependencies pkgconfig (python3.withPackages @@ -83,6 +82,8 @@ stdenv.mkDerivation rec { prefixKey = "-prefix "; + enableParallelBuilding = true; + buildFlags = [ "world" "byte" ] ++ optional buildDoc "doc-html"; installTargets = diff --git a/dev/build/windows/MakeCoq_MinGW.bat b/dev/build/windows/MakeCoq_MinGW.bat index c8cfcf60c8..c3f3a97ff5 100755 --- a/dev/build/windows/MakeCoq_MinGW.bat +++ b/dev/build/windows/MakeCoq_MinGW.bat @@ -331,7 +331,7 @@ IF "%CYGWIN_QUIET%" == "Y" ( )
IF "%GTK_FROM_SOURCES%"=="N" (
- SET CYGWIN_OPT= %CYGWIN_OPT% -P mingw64-%ARCH%-gtk2.0,mingw64-%ARCH%-gtksourceview2.0
+ SET CYGWIN_OPT= %CYGWIN_OPT% -P mingw64-%ARCH%-gtk3,mingw64-%ARCH%-gtksourceview3.0
)
REM Cygwin setup sets proper ACLs (permissions) for folders it CREATES.
diff --git a/dev/build/windows/makecoq_mingw.sh b/dev/build/windows/makecoq_mingw.sh index 43f44a80b4..4c5bd29236 100755 --- a/dev/build/windows/makecoq_mingw.sh +++ b/dev/build/windows/makecoq_mingw.sh @@ -742,7 +742,7 @@ function make_fontconfig { ##### ICONV ##### function make_libiconv { - build_conf_make_inst http://ftp.gnu.org/pub/gnu/libiconv libiconv-1.14 tar.gz true + build_conf_make_inst http://ftp.gnu.org/pub/gnu/libiconv libiconv-1.15 tar.gz true } ##### UNISTRING ##### @@ -816,7 +816,9 @@ function make_glib { make_gettext make_libffi make_libpcre + build_conf_make_inst http://ftp.gnome.org/pub/gnome/sources/glib/2.57 glib-2.57.1 tar.xz true + } ##### ATK ##### @@ -824,7 +826,7 @@ function make_glib { function make_atk { make_gettext make_glib - build_conf_make_inst http://ftp.gnome.org/pub/gnome/sources/atk/2.29 atk-2.29.1 tar.xz true + build_conf_make_inst http://ftp.gnome.org/pub/gnome/sources/atk/2.30 atk-2.30.0 tar.xz true } ##### PIXBUF ##### @@ -837,7 +839,7 @@ function make_gdk-pixbuf { # CONFIGURE PARAMETERS # --with-included-loaders=yes statically links the image file format handlers # This avoids "Cannot open pixbuf loader module file '/usr/x86_64-w64-mingw32/sys-root/mingw/lib/gdk-pixbuf-2.0/2.10.0/loaders.cache': No such file or directory" - build_conf_make_inst http://ftp.gnome.org/pub/GNOME/sources/gdk-pixbuf/2.36 gdk-pixbuf-2.36.12 tar.xz true --with-included-loaders=yes + build_conf_make_inst http://ftp.gnome.org/pub/GNOME/sources/gdk-pixbuf/2.38 gdk-pixbuf-2.38.0 tar.xz true --with-included-loaders=yes } ##### CAIRO ##### @@ -848,7 +850,7 @@ function make_cairo { make_glib make_pixman make_fontconfig - build_conf_make_inst http://cairographics.org/releases rcairo-1.15.13 tar.xz true + build_conf_make_inst http://cairographics.org/releases rcairo-1.16.2 tar.xz true } ##### PANGO ##### @@ -857,37 +859,23 @@ function make_pango { make_cairo make_glib make_fontconfig - build_conf_make_inst http://ftp.gnome.org/pub/GNOME/sources/pango/1.42 pango-1.42.1 tar.xz true + build_conf_make_inst http://ftp.gnome.org/pub/GNOME/sources/pango/1.42 pango-1.42.4 tar.xz true } -##### GTK2 ##### +##### GTK3 ##### -function patch_gtk2 { - rm gtk/gtk.def -} +function make_gtk3 { -function make_gtk2 { - # Cygwin packet dependencies: gtk-update-icon-cache if [ "$GTK_FROM_SOURCES" == "Y" ]; then - make_glib - make_atk - make_pango - make_gdk-pixbuf - make_cairo - build_conf_make_inst http://ftp.gnome.org/pub/gnome/sources/gtk+/2.24 gtk+-2.24.32 tar.xz patch_gtk2 - fi -} - -##### GTK3 ##### -function make_gtk3 { - make_glib - make_atk - make_pango - make_gdk-pixbuf - make_cairo - make_libepoxy - build_conf_make_inst http://ftp.gnome.org/pub/gnome/sources/gtk+/3.22 gtk+-3.22.30 tar.xz true + make_glib + make_atk + make_pango + make_gdk-pixbuf + make_cairo + make_libepoxy + build_conf_make_inst http://ftp.gnome.org/pub/gnome/sources/gtk+/3.24 gtk+-3.24.5 tar.xz true + fi # make all incl. tests and examples runs through fine # make install fails with issue with @@ -918,17 +906,17 @@ function make_libxml2 { fi } -##### GTK-SOURCEVIEW2 ##### +##### GTK-SOURCEVIEW3 ##### -function make_gtk_sourceview2 { +function make_gtk_sourceview3 { # Cygwin packet dependencies: intltool # gtksourceview-2.11.2 requires GTK2 # gtksourceview-2.91.9 requires GTK3 # => We use gtksourceview-2.11.2 which seems to be the newest GTK2 based one if [ "$GTK_FROM_SOURCES" == "Y" ]; then - make_gtk2 + make_gtk3 make_libxml2 - build_conf_make_inst https://download.gnome.org/sources/gtksourceview/2.11 gtksourceview-2.11.2 tar.bz2 true + build_conf_make_inst https://download.gnome.org/sources/gtksourceview/3.24 gtksourceview-3.24.9 tar.bz2 true fi } @@ -977,7 +965,7 @@ function get_flex_dll_link_bin { # Build flexdll and flexlink from sources after building OCaml function make_flex_dll_link { - if build_prep https://github.com/alainfrisch/flexdll/releases/download/0.37/ flexdll-bin-0.37 zip ; then + if build_prep https://github.com/alainfrisch/flexdll/archive 0.37 tar.gz 1 flexdll-0.37 ; then if [ "$TARGET_ARCH" == "i686-w64-mingw32" ]; then # shellcheck disable=SC2086 log1 make $MAKE_OPT build_mingw flexlink.exe @@ -1014,11 +1002,21 @@ function make_ln { fi } +##### ARCH-pkg-config replacement ##### + +# cygwin replaced ARCH-pkg-config with a shell script, which doesn't work e.g. for dune on Windows. +# This builds a binary replacement for the shell script and puts it into the bin_special folder. +# There is no global installation since it is module specific what pkg-config is needed under what name. + +function make_arch_pkg_config { + gcc -DARCH="$TARGET_ARCH" -o bin_special/pkg-config.exe $PATCHES/pkg-config.c +} + ##### OCAML ##### function make_ocaml { get_flex_dll_link_bin - if build_prep https://github.com/ocaml/ocaml/archive 4.07.0 tar.gz 1 ocaml-4.07.0 ; then + if build_prep https://github.com/ocaml/ocaml/archive 4.07.1 tar.gz 1 ocaml-4.07.1 ; then # See README.win32.adoc cp config/m-nt.h byterun/caml/m.h cp config/s-nt.h byterun/caml/s.h @@ -1073,7 +1071,6 @@ function make_ocaml { function make_ocaml_tools { make_findlib - # make_camlp5 } ##### OCAML EXTRA LIBRARIES ##### @@ -1082,7 +1079,6 @@ function make_ocaml_libs { make_num make_findlib make_lablgtk - # make_stdint } ##### Ocaml num library ##### @@ -1130,6 +1126,20 @@ function make_findlib { fi } +##### Dune build system ##### + +function make_dune { + make_ocaml + + if build_prep https://github.com/ocaml/dune/archive/ 1.6.3 tar.gz 1 dune-1.6.3 ; then + + log2 make release + log2 make install + + build_post + fi +} + ##### MENHIR Ocaml Parser Generator ##### function make_menhir { @@ -1144,108 +1154,44 @@ function make_menhir { fi } -##### CAMLP4 Ocaml Preprocessor ##### - -function make_camlp4 { - # OCaml up to 4.01 includes camlp4, from 4.02 it isn't included - # Check if command camlp4 exists, if not build camlp4 - if ! command camlp4 ; then - make_ocaml - make_findlib - if build_prep https://github.com/ocaml/camlp4/archive 4.06+2 tar.gz 1 camlp4-4.06+2 ; then - # See https://github.com/ocaml/camlp4/issues/41#issuecomment-112018910 - logn configure ./configure - # Note: camlp4 doesn't support -j 8, so don't pass MAKE_OPT - log2 make all - log2 make install - log2 make clean - build_post - fi - fi -} - -##### CAMLP5 Ocaml Preprocessor ##### - -function make_camlp5 { - make_ocaml - make_findlib - - if build_prep https://github.com/camlp5/camlp5/archive rel706 tar.gz 1 camlp5-rel706; then - logn configure ./configure - # Somehow my virus scanner has the boot.new/SAVED directory locked after the move for a second => repeat until success - sed -i 's/mv boot.new boot/until mv boot.new boot; do sleep 1; done/' Makefile - # shellcheck disable=SC2086 - log1 make world.opt $MAKE_OPT - log2 make install - # For some reason gramlib.a is not copied, but it is required by Coq - cp lib/gramlib.a "$PREFIXOCAML/libocaml/camlp5/" - # For some reason META is not copied, but it is required by coq_makefile - log2 make -C etc META - mkdir -p "$PREFIXOCAML/libocaml/site-lib/camlp5/" - cp etc/META "$PREFIXOCAML/libocaml/site-lib/camlp5/" - log2 make clean - build_post - fi -} - ##### LABLGTK Ocaml GTK binding ##### # Note: when rebuilding lablgtk by deleting the .finished file, # also delete <root>\usr\x86_64-w64-mingw32\sys-root\mingw\lib\site-lib # Otherwise make install fails -function make_lablgtk { - make_ocaml - make_findlib - # make_camlp4 # required by lablgtk-2.18.3 and lablgtk-2.18.5 - make_gtk2 - make_gtk_sourceview2 - if build_prep https://forge.ocamlcore.org/frs/download.php/1726 lablgtk-2.18.6 tar.gz 1 ; then - # configure should be fixed to search for $TARGET_ARCH-pkg-config.exe - cp "/bin/$TARGET_ARCH-pkg-config" bin_special/pkg-config - logn configure ./configure --build="$BUILD" --host="$HOST" --target="$TARGET" --prefix="$PREFIXOCAML" - - # lablgtk shows occasional errors with -j, so don't pass $MAKE_OPT - - # lablgtk binary needs to be stripped - otherwise flexdll goes wild - # Fix version 1: explicit strip after failed build - this randomly fails in CI - # See https://sympa.inria.fr/sympa/arc/caml-list/2015-10/msg00204.html - # logn make-world-pre make world || true - # $TARGET_ARCH-strip.exe --strip-unneeded src/dlllablgtk2.dll - - # Fix version 2: Strip by passing linker argument rather than explicit call to strip - # See https://github.com/alainfrisch/flexdll/issues/6 - # Argument to ocamlmklib: -ldopt "-link -Wl,-s" - # -ldopt is the okamlmklib linker prefix option - # -link is the flexlink linker prefix option - # -Wl, is the gcc (linker driver) linker prefix option - # -s is the gnu linker option for stripping symbols - # These changes are included in dev/build/windows/patches_coq/lablgtk-2.18.3.patch - - log2 make world - - # lablgtk does not escape FINDLIBDIR path, which can contain backslashes - sed -i "s|^FINDLIBDIR=.*|FINDLIBDIR=$PREFIXOCAML/libocaml/site-lib|" config.make +function make_ocaml_cairo2 { + if build_prep https://github.com/Chris00/ocaml-cairo/archive 0.6 tar.gz 1 ocaml_cairo2-0.6; then + make_arch_pkg_config - log2 make install - log2 make clean + log2 dune build cairo2.install + log2 dune install cairo2 + log2 dune clean build_post + fi } -##### Ocaml Stdint ##### - -function make_stdint { +function make_lablgtk { make_ocaml make_findlib - if build_prep https://github.com/andrenth/ocaml-stdint/archive 0.3.0 tar.gz 1 Stdint-0.3.0; then - # Note: the setup gets the proper install path from ocamlfind, but for whatever reason it wants - # to create an empty folder in some folder which defaults to C:\Program Files. - # The --preifx overrides this. Id didn't see any files created in /tmp/extra. - log_1_3 ocaml setup.ml -configure --prefix /tmp/extra - log_1_3 ocaml setup.ml -build - log_1_3 ocaml setup.ml -install - log_1_3 ocaml setup.ml -clean + make_dune + make_gtk3 + make_gtk_sourceview3 + make_ocaml_cairo2 + + if build_prep https://github.com/garrigue/lablgtk/archive 3.0.beta5 tar.gz 1 lablgtk-3.0.beta5 ; then + make_arch_pkg_config + + # lablgtk3 includes more packages that are not relevant for Coq, + # such as gtkspell + log2 dune build -p lablgtk3 + log2 dune install lablgtk3 + + log2 dune build -p lablgtk3-sourceview3 + log2 dune install lablgtk3-sourceview3 + + log2 dune clean build_post fi } @@ -1270,42 +1216,44 @@ function copy_coq_dlls { # Select all missing DLLs from the module list, right click "copy filenames" # Delay loaded DLLs from Windows can be ignored (hour-glass icon at begin of line) # Do this recursively until there are no further missing DLLs (File close + reopen) - # For running this quickly, just do "cd coq-<ver> ; call copy_coq_dlls ; cd .." at the end of this script. + # For running this quickly, just do "cd coq-<ver> ; copy_coq_dlls ; cd .." at the end of this script. # Do the same for coqc and ocamlc (usually doesn't result in additional files) - copy_coq_dll LIBATK-1.0-0.DLL copy_coq_dll LIBCAIRO-2.DLL - copy_coq_dll LIBEXPAT-1.DLL - copy_coq_dll LIBFFI-6.DLL copy_coq_dll LIBFONTCONFIG-1.DLL copy_coq_dll LIBFREETYPE-6.DLL - copy_coq_dll LIBGDK-WIN32-2.0-0.DLL + copy_coq_dll LIBGDK-3-0.DLL copy_coq_dll LIBGDK_PIXBUF-2.0-0.DLL - copy_coq_dll LIBGIO-2.0-0.DLL copy_coq_dll LIBGLIB-2.0-0.DLL - copy_coq_dll LIBGMODULE-2.0-0.DLL copy_coq_dll LIBGOBJECT-2.0-0.DLL - copy_coq_dll LIBGTK-WIN32-2.0-0.DLL - copy_coq_dll LIBINTL-8.DLL + copy_coq_dll LIBGTK-3-0.DLL + copy_coq_dll LIBGTKSOURCEVIEW-3.0-1.DLL copy_coq_dll LIBPANGO-1.0-0.DLL + copy_coq_dll LIBATK-1.0-0.DLL + copy_coq_dll LIBBZ2-1.DLL + copy_coq_dll LIBCAIRO-GOBJECT-2.DLL + copy_coq_dll LIBEPOXY-0.DLL + copy_coq_dll LIBEXPAT-1.DLL + copy_coq_dll LIBFFI-6.DLL + copy_coq_dll LIBGIO-2.0-0.DLL + copy_coq_dll LIBGMODULE-2.0-0.DLL + copy_coq_dll LIBINTL-8.DLL copy_coq_dll LIBPANGOCAIRO-1.0-0.DLL copy_coq_dll LIBPANGOWIN32-1.0-0.DLL - copy_coq_dll libpcre-1.dll + copy_coq_dll LIBPCRE-1.DLL copy_coq_dll LIBPIXMAN-1-0.DLL copy_coq_dll LIBPNG16-16.DLL copy_coq_dll LIBXML2-2.DLL copy_coq_dll ZLIB1.DLL + copy_coq_dll ICONV.DLL + copy_coq_dll LIBLZMA-5.DLL + copy_coq_dll LIBPANGOFT2-1.0-0.DLL + copy_coq_dll LIBHARFBUZZ-0.DLL # Depends on if GTK is built from sources if [ "$GTK_FROM_SOURCES" == "Y" ]; then - copy_coq_dll libiconv-2.dll - else - copy_coq_dll ICONV.DLL - copy_coq_dll LIBBZ2-1.DLL - copy_coq_dll LIBGTKSOURCEVIEW-2.0-0.DLL - copy_coq_dll LIBHARFBUZZ-0.DLL - copy_coq_dll LIBLZMA-5.DLL - copy_coq_dll LIBPANGOFT2-1.0-0.DLL + echo "Building GTK from sources is currently not supported" + exit 1 fi; # Architecture dependent files @@ -1335,14 +1283,14 @@ function copy_coq_objects { # Copy required GTK config and suport files -function copq_coq_gtk { - echo 'gtk-theme-name = "MS-Windows"' > "$PREFIX/etc/gtk-2.0/gtkrc" - echo 'gtk-fallback-icon-theme = "Tango"' >> "$PREFIX/etc/gtk-2.0/gtkrc" +function copy_coq_gtk { + echo 'gtk-theme-name = "Default"' > "$PREFIX/etc/gtk-3.0/gtkrc" + echo 'gtk-fallback-icon-theme = "Tango"' >> "$PREFIX/etc/gtk-3.0/gtkrc" if [ "$INSTALLMODE" == "absolute" ] || [ "$INSTALLMODE" == "relocatable" ]; then - install_glob "$PREFIX/etc/gtk-2.0" '*' "$PREFIXCOQ/gtk-2.0" - install_glob "$PREFIX/share/gtksourceview-2.0/language-specs" '*' "$PREFIXCOQ/share/gtksourceview-2.0/language-specs" - install_glob "$PREFIX/share/gtksourceview-2.0/styles" '*' "$PREFIXCOQ/share/gtksourceview-2.0/styles" + install_glob "$PREFIX/etc/gtk-3.0" '*' "$PREFIXCOQ/gtk-3.0" + install_glob "$PREFIX/share/gtksourceview-3.0/language-specs" '*' "$PREFIXCOQ/share/gtksourceview-3.0/language-specs" + install_glob "$PREFIX/share/gtksourceview-3.0/styles" '*' "$PREFIXCOQ/share/gtksourceview-3.0/styles" install_rec "$PREFIX/share/themes" '*' "$PREFIXCOQ/share/themes" # This below item look like a bug in make install @@ -1351,10 +1299,7 @@ function copq_coq_gtk { else COQSHARE="$PREFIXCOQ/share/" fi - if [[ ! $COQ_VERSION == 8.4* ]] ; then - 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 "$COQSHARE"*.png "$PREFIXCOQ/ide" rmdir "$PREFIXCOQ/share/coq" || true @@ -1383,7 +1328,6 @@ function make_coq { make_ocaml make_num make_findlib - # make_camlp5 make_lablgtk if case $COQ_VERSION in @@ -1437,11 +1381,12 @@ function make_coq { log2 make install log1 copy_coq_dlls + log1 copy_coq_gtk + if [ "$INSTALLOCAML" == "Y" ]; then copy_coq_objects fi - log1 copq_coq_gtk log1 copy_coq_license # make clean seems to be broken for 8.5pl2 diff --git a/dev/build/windows/patches_coq/VST.patch b/dev/build/windows/patches_coq/VST.patch index 2c8c46373f..2c8c46373f 100755..100644 --- a/dev/build/windows/patches_coq/VST.patch +++ b/dev/build/windows/patches_coq/VST.patch diff --git a/dev/build/windows/patches_coq/flexdll-0.37.patch b/dev/build/windows/patches_coq/flexdll-0.37.patch new file mode 100644 index 0000000000..82806f9ea4 --- /dev/null +++ b/dev/build/windows/patches_coq/flexdll-0.37.patch @@ -0,0 +1,19 @@ +diff/patch file created on Tue, Feb 19, 2019 9:41:26 PM with: +difftar-folder.sh tarballs/flexdll-0.37.tar.gz flexdll-0.37 1 +TARFILE= tarballs/flexdll-0.37.tar.gz +FOLDER= flexdll-0.37 +TARSTRIP= 1 +TARPREFIX= flexdll-0.37/ +ORIGFOLDER= flexdll-0.37.orig +--- flexdll-0.37.orig/cmdline.ml 2017-10-25 10:40:46.000000000 +0200 ++++ flexdll-0.37/cmdline.ml 2019-02-19 21:41:18.157024900 +0100 +@@ -248,6 +248,9 @@ + String.sub s 0 2 :: String.sub s 2 (String.length s - 2) :: tr rest + | s :: rest when String.length s >= 5 && String.sub s 0 5 = "/link" -> + "-link" :: String.sub s 5 (String.length s - 5) :: tr rest ++ (* Convert gcc linker option prefix -Wl, to flexlink linker prefix -link *) ++ | s :: rest when String.length s >= 6 && String.sub s 0 5 = "-Wl,-" -> ++ "-link" :: String.sub s 4 (String.length s - 4) :: tr rest + | "-arg" :: x :: rest -> + tr (Array.to_list (Arg.read_arg x)) @ rest + | "-arg0" :: x :: rest -> diff --git a/dev/build/windows/patches_coq/gtksourceview-2.11.2.patch b/dev/build/windows/patches_coq/gtksourceview-2.11.2.patch deleted file mode 100644 index 73a098d12a..0000000000 --- a/dev/build/windows/patches_coq/gtksourceview-2.11.2.patch +++ /dev/null @@ -1,213 +0,0 @@ -diff -c -r gtksourceview-2.11.2.orig/gtksourceview/gtksourceiter.c gtksourceview-2.11.2.patched/gtksourceview/gtksourceiter.c -*** gtksourceview-2.11.2.orig/gtksourceview/gtksourceiter.c 2010-05-30 12:24:14.000000000 +0200 ---- gtksourceview-2.11.2.patched/gtksourceview/gtksourceiter.c 2015-10-27 14:58:54.422888400 +0100 -*************** -*** 80,86 **** - /* If string contains prefix, check that prefix is not followed - * by a unicode mark symbol, e.g. that trailing 'a' in prefix - * is not part of two-char a-with-hat symbol in string. */ -! return type != G_UNICODE_COMBINING_MARK && - type != G_UNICODE_ENCLOSING_MARK && - type != G_UNICODE_NON_SPACING_MARK; - } ---- 80,86 ---- - /* If string contains prefix, check that prefix is not followed - * by a unicode mark symbol, e.g. that trailing 'a' in prefix - * is not part of two-char a-with-hat symbol in string. */ -! return type != G_UNICODE_SPACING_MARK && - type != G_UNICODE_ENCLOSING_MARK && - type != G_UNICODE_NON_SPACING_MARK; - } -diff -c -r gtksourceview-2.11.2.orig/gtksourceview/gtksourcelanguagemanager.c gtksourceview-2.11.2.patched/gtksourceview/gtksourcelanguagemanager.c -*** gtksourceview-2.11.2.orig/gtksourceview/gtksourcelanguagemanager.c 2010-05-30 12:24:14.000000000 +0200 ---- gtksourceview-2.11.2.patched/gtksourceview/gtksourcelanguagemanager.c 2015-10-27 14:55:30.294477600 +0100 -*************** -*** 274,280 **** - * containg a list of language files directories. - * The array is owned by @lm and must not be modified. - */ -! G_CONST_RETURN gchar* G_CONST_RETURN * - gtk_source_language_manager_get_search_path (GtkSourceLanguageManager *lm) - { - g_return_val_if_fail (GTK_IS_SOURCE_LANGUAGE_MANAGER (lm), NULL); ---- 274,280 ---- - * containg a list of language files directories. - * The array is owned by @lm and must not be modified. - */ -! const gchar* const * - gtk_source_language_manager_get_search_path (GtkSourceLanguageManager *lm) - { - g_return_val_if_fail (GTK_IS_SOURCE_LANGUAGE_MANAGER (lm), NULL); -*************** -*** 392,398 **** - * available languages or %NULL if no language is available. The array - * is owned by @lm and must not be modified. - */ -! G_CONST_RETURN gchar* G_CONST_RETURN * - gtk_source_language_manager_get_language_ids (GtkSourceLanguageManager *lm) - { - g_return_val_if_fail (GTK_IS_SOURCE_LANGUAGE_MANAGER (lm), NULL); ---- 392,398 ---- - * available languages or %NULL if no language is available. The array - * is owned by @lm and must not be modified. - */ -! const gchar* const * - gtk_source_language_manager_get_language_ids (GtkSourceLanguageManager *lm) - { - g_return_val_if_fail (GTK_IS_SOURCE_LANGUAGE_MANAGER (lm), NULL); -diff -c -r gtksourceview-2.11.2.orig/gtksourceview/gtksourcelanguagemanager.h gtksourceview-2.11.2.patched/gtksourceview/gtksourcelanguagemanager.h -*** gtksourceview-2.11.2.orig/gtksourceview/gtksourcelanguagemanager.h 2009-11-15 00:41:33.000000000 +0100 ---- gtksourceview-2.11.2.patched/gtksourceview/gtksourcelanguagemanager.h 2015-10-27 14:55:30.518500000 +0100 -*************** -*** 62,74 **** - - GtkSourceLanguageManager *gtk_source_language_manager_get_default (void); - -! G_CONST_RETURN gchar* G_CONST_RETURN * - gtk_source_language_manager_get_search_path (GtkSourceLanguageManager *lm); - - void gtk_source_language_manager_set_search_path (GtkSourceLanguageManager *lm, - gchar **dirs); - -! G_CONST_RETURN gchar* G_CONST_RETURN * - gtk_source_language_manager_get_language_ids (GtkSourceLanguageManager *lm); - - GtkSourceLanguage *gtk_source_language_manager_get_language (GtkSourceLanguageManager *lm, ---- 62,74 ---- - - GtkSourceLanguageManager *gtk_source_language_manager_get_default (void); - -! const gchar* const * - gtk_source_language_manager_get_search_path (GtkSourceLanguageManager *lm); - - void gtk_source_language_manager_set_search_path (GtkSourceLanguageManager *lm, - gchar **dirs); - -! const gchar* const * - gtk_source_language_manager_get_language_ids (GtkSourceLanguageManager *lm); - - GtkSourceLanguage *gtk_source_language_manager_get_language (GtkSourceLanguageManager *lm, -diff -c -r gtksourceview-2.11.2.orig/gtksourceview/gtksourcestylescheme.c gtksourceview-2.11.2.patched/gtksourceview/gtksourcestylescheme.c -*** gtksourceview-2.11.2.orig/gtksourceview/gtksourcestylescheme.c 2010-05-30 12:24:14.000000000 +0200 ---- gtksourceview-2.11.2.patched/gtksourceview/gtksourcestylescheme.c 2015-10-27 14:55:30.545502700 +0100 -*************** -*** 310,316 **** - * - * Since: 2.0 - */ -! G_CONST_RETURN gchar* G_CONST_RETURN * - gtk_source_style_scheme_get_authors (GtkSourceStyleScheme *scheme) - { - g_return_val_if_fail (GTK_IS_SOURCE_STYLE_SCHEME (scheme), NULL); ---- 310,316 ---- - * - * Since: 2.0 - */ -! const gchar* const * - gtk_source_style_scheme_get_authors (GtkSourceStyleScheme *scheme) - { - g_return_val_if_fail (GTK_IS_SOURCE_STYLE_SCHEME (scheme), NULL); -*************** -*** 318,324 **** - if (scheme->priv->authors == NULL) - return NULL; - -! return (G_CONST_RETURN gchar* G_CONST_RETURN *)scheme->priv->authors->pdata; - } - - /** ---- 318,324 ---- - if (scheme->priv->authors == NULL) - return NULL; - -! return (const gchar* const *)scheme->priv->authors->pdata; - } - - /** -diff -c -r gtksourceview-2.11.2.orig/gtksourceview/gtksourcestylescheme.h gtksourceview-2.11.2.patched/gtksourceview/gtksourcestylescheme.h -*** gtksourceview-2.11.2.orig/gtksourceview/gtksourcestylescheme.h 2010-03-29 15:02:56.000000000 +0200 ---- gtksourceview-2.11.2.patched/gtksourceview/gtksourcestylescheme.h 2015-10-27 14:55:30.565504700 +0100 -*************** -*** 61,67 **** - const gchar *gtk_source_style_scheme_get_name (GtkSourceStyleScheme *scheme); - const gchar *gtk_source_style_scheme_get_description(GtkSourceStyleScheme *scheme); - -! G_CONST_RETURN gchar* G_CONST_RETURN * - gtk_source_style_scheme_get_authors (GtkSourceStyleScheme *scheme); - - const gchar *gtk_source_style_scheme_get_filename (GtkSourceStyleScheme *scheme); ---- 61,67 ---- - const gchar *gtk_source_style_scheme_get_name (GtkSourceStyleScheme *scheme); - const gchar *gtk_source_style_scheme_get_description(GtkSourceStyleScheme *scheme); - -! const gchar* const * - gtk_source_style_scheme_get_authors (GtkSourceStyleScheme *scheme); - - const gchar *gtk_source_style_scheme_get_filename (GtkSourceStyleScheme *scheme); -diff -c -r gtksourceview-2.11.2.orig/gtksourceview/gtksourcestyleschememanager.c gtksourceview-2.11.2.patched/gtksourceview/gtksourcestyleschememanager.c -*** gtksourceview-2.11.2.orig/gtksourceview/gtksourcestyleschememanager.c 2010-05-30 12:24:14.000000000 +0200 ---- gtksourceview-2.11.2.patched/gtksourceview/gtksourcestyleschememanager.c 2015-10-27 14:55:30.583506500 +0100 -*************** -*** 515,521 **** - * of string containing the search path. - * The array is owned by the @manager and must not be modified. - */ -! G_CONST_RETURN gchar* G_CONST_RETURN * - gtk_source_style_scheme_manager_get_search_path (GtkSourceStyleSchemeManager *manager) - { - g_return_val_if_fail (GTK_IS_SOURCE_STYLE_SCHEME_MANAGER (manager), NULL); ---- 515,521 ---- - * of string containing the search path. - * The array is owned by the @manager and must not be modified. - */ -! const gchar* const * - gtk_source_style_scheme_manager_get_search_path (GtkSourceStyleSchemeManager *manager) - { - g_return_val_if_fail (GTK_IS_SOURCE_STYLE_SCHEME_MANAGER (manager), NULL); -*************** -*** 554,560 **** - * of string containing the ids of the available style schemes or %NULL if no - * style scheme is available. The array is owned by the @manager and must not be modified. - */ -! G_CONST_RETURN gchar* G_CONST_RETURN * - gtk_source_style_scheme_manager_get_scheme_ids (GtkSourceStyleSchemeManager *manager) - { - g_return_val_if_fail (GTK_IS_SOURCE_STYLE_SCHEME_MANAGER (manager), NULL); ---- 554,560 ---- - * of string containing the ids of the available style schemes or %NULL if no - * style scheme is available. The array is owned by the @manager and must not be modified. - */ -! const gchar* const * - gtk_source_style_scheme_manager_get_scheme_ids (GtkSourceStyleSchemeManager *manager) - { - g_return_val_if_fail (GTK_IS_SOURCE_STYLE_SCHEME_MANAGER (manager), NULL); -diff -c -r gtksourceview-2.11.2.orig/gtksourceview/gtksourcestyleschememanager.h gtksourceview-2.11.2.patched/gtksourceview/gtksourcestyleschememanager.h -*** gtksourceview-2.11.2.orig/gtksourceview/gtksourcestyleschememanager.h 2009-11-15 00:41:33.000000000 +0100 ---- gtksourceview-2.11.2.patched/gtksourceview/gtksourcestyleschememanager.h 2015-10-27 14:56:24.498897500 +0100 -*************** -*** 73,84 **** - void gtk_source_style_scheme_manager_prepend_search_path (GtkSourceStyleSchemeManager *manager, - const gchar *path); - -! G_CONST_RETURN gchar* G_CONST_RETURN * - gtk_source_style_scheme_manager_get_search_path (GtkSourceStyleSchemeManager *manager); - - void gtk_source_style_scheme_manager_force_rescan (GtkSourceStyleSchemeManager *manager); - -! G_CONST_RETURN gchar* G_CONST_RETURN * - gtk_source_style_scheme_manager_get_scheme_ids (GtkSourceStyleSchemeManager *manager); - - GtkSourceStyleScheme *gtk_source_style_scheme_manager_get_scheme (GtkSourceStyleSchemeManager *manager, ---- 73,84 ---- - void gtk_source_style_scheme_manager_prepend_search_path (GtkSourceStyleSchemeManager *manager, - const gchar *path); - -! const gchar* const * - gtk_source_style_scheme_manager_get_search_path (GtkSourceStyleSchemeManager *manager); - - void gtk_source_style_scheme_manager_force_rescan (GtkSourceStyleSchemeManager *manager); - -! const gchar* const * - gtk_source_style_scheme_manager_get_scheme_ids (GtkSourceStyleSchemeManager *manager); - - GtkSourceStyleScheme *gtk_source_style_scheme_manager_get_scheme (GtkSourceStyleSchemeManager *manager, diff --git a/dev/build/windows/patches_coq/lablgtk-2.18.6.patch b/dev/build/windows/patches_coq/lablgtk-3.0.beta5.patch index 23c303135d..1c6a038da9 100644 --- a/dev/build/windows/patches_coq/lablgtk-2.18.6.patch +++ b/dev/build/windows/patches_coq/lablgtk-3.0.beta5.patch @@ -1,33 +1,12 @@ -diff/patch file created on Wed, Apr 25, 2018 11:08:05 AM with: -difftar-folder.sh ../coq-msoegtrop/dev/build/windows/source_cache/lablgtk-2.18.3.tar.gz lablgtk-2.18.3 1 -TARFILE= ../coq-msoegtrop/dev/build/windows/source_cache/lablgtk-2.18.3.tar.gz -FOLDER= lablgtk-2.18.3 +diff/patch file created on Wed, Feb 20, 2019 11:29:48 AM with: +difftar-folder.sh tarballs/lablgtk-3.0.beta4.tar.gz lablgtk-3.0.beta4 1 +TARFILE= tarballs/lablgtk-3.0.beta4.tar.gz +FOLDER= lablgtk-3.0.beta4 TARSTRIP= 1 -TARPREFIX= lablgtk-2.18.3/ -ORIGFOLDER= lablgtk-2.18.3.orig ---- lablgtk-2.18.3.orig/configure 2014-10-29 08:51:05.000000000 +0100 -+++ lablgtk-2.18.3/configure 2018-04-25 10:58:54.454501600 +0200 -@@ -2667,7 +2667,7 @@ - fi - - --if test "`$OCAMLFIND printconf stdlib`" != "`$CAMLC -where`"; then -+if test "`$OCAMLFIND printconf stdlib | tr '\\' '/'`" != "`$CAMLC -where | tr '\\' '/'`"; then - { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: Ignoring ocamlfind" >&5 - $as_echo "$as_me: WARNING: Ignoring ocamlfind" >&2;} - OCAMLFIND=no ---- lablgtk-2.18.3.orig/src/glib.mli 2014-10-29 08:51:06.000000000 +0100 -+++ lablgtk-2.18.3/src/glib.mli 2018-04-25 10:58:54.493555500 +0200 -@@ -75,6 +75,7 @@ - type condition = [ `ERR | `HUP | `IN | `NVAL | `OUT | `PRI] - type id - val channel_of_descr : Unix.file_descr -> channel -+ val channel_of_descr_socket : Unix.file_descr -> channel - val add_watch : - cond:condition list -> callback:(condition list -> bool) -> ?prio:int -> channel -> id - val remove : id -> unit ---- lablgtk-2.18.3.orig/src/glib.ml 2014-10-29 08:51:06.000000000 +0100 -+++ lablgtk-2.18.3/src/glib.ml 2018-04-25 10:58:54.479543500 +0200 +TARPREFIX= lablgtk-3.0.beta4/ +ORIGFOLDER= lablgtk-3.0.beta4.orig +--- lablgtk-3.0.beta4.orig/src/glib.ml 2019-02-11 07:08:17.000000000 +0100 ++++ lablgtk-3.0.beta4/src/glib.ml 2019-02-20 11:28:28.439137100 +0100 @@ -72,6 +72,8 @@ type id external channel_of_descr : Unix.file_descr -> channel @@ -37,22 +16,18 @@ ORIGFOLDER= lablgtk-2.18.3.orig external remove : id -> unit = "ml_g_source_remove" external add_watch : cond:condition list -> callback:(condition list -> bool) -> ?prio:int -> channel -> id ---- lablgtk-2.18.3.orig/src/Makefile 2014-10-29 08:51:06.000000000 +0100 -+++ lablgtk-2.18.3/src/Makefile 2018-04-25 10:58:54.506522500 +0200 -@@ -461,9 +461,9 @@ - do rm -f "$(BINDIR)"/$$f; done - - lablgtk.cma liblablgtk2$(XA): $(COBJS) $(MLOBJS) -- $(LIBRARIAN) -o lablgtk -oc lablgtk2 $^ $(GTKLIBS) -+ $(LIBRARIAN) -ldopt "-link -Wl,-s" -o lablgtk -oc lablgtk2 $^ $(GTKLIBS) - lablgtk.cmxa: $(COBJS) $(MLOBJS:.cmo=.cmx) -- $(LIBRARIAN) -o lablgtk -oc lablgtk2 $^ $(GTKLIBS) -+ $(LIBRARIAN) -ldopt "-link -Wl,-s" -o lablgtk -oc lablgtk2 $^ $(GTKLIBS) - lablgtk.cmxs: DYNLINKLIBS=$(GTK_LIBS) - - lablgtkgl.cma liblablgtkgl2$(XA): $(GLCOBJS) $(GLMLOBJS) ---- lablgtk-2.18.3.orig/src/ml_glib.c 2014-10-29 08:51:06.000000000 +0100 -+++ lablgtk-2.18.3/src/ml_glib.c 2018-04-25 10:58:54.539535600 +0200 +--- lablgtk-3.0.beta4.orig/src/glib.mli 2019-02-11 07:08:17.000000000 +0100 ++++ lablgtk-3.0.beta4/src/glib.mli 2019-02-20 11:28:28.423592200 +0100 +@@ -75,6 +75,7 @@ + type condition = [ `ERR | `HUP | `IN | `NVAL | `OUT | `PRI] + type id + val channel_of_descr : Unix.file_descr -> channel ++ val channel_of_descr_socket : Unix.file_descr -> channel + val add_watch : + cond:condition list -> callback:(condition list -> bool) -> ?prio:int -> channel -> id + val remove : id -> unit +--- lablgtk-3.0.beta4.orig/src/ml_glib.c 2019-02-11 07:08:17.000000000 +0100 ++++ lablgtk-3.0.beta4/src/ml_glib.c 2019-02-20 11:28:28.455395900 +0100 @@ -25,6 +25,8 @@ #include <string.h> #include <locale.h> @@ -74,7 +49,7 @@ ORIGFOLDER= lablgtk-2.18.3.orig #include "wrappers.h" #include "ml_glib.h" #include "glib_tags.h" -@@ -325,14 +332,23 @@ +@@ -326,14 +333,23 @@ #ifndef _WIN32 ML_1 (g_io_channel_unix_new, Int_val, Val_GIOChannel_noref) diff --git a/dev/build/windows/patches_coq/pkg-config.c b/dev/build/windows/patches_coq/pkg-config.c new file mode 100755 index 0000000000..e4fdcd4d7d --- /dev/null +++ b/dev/build/windows/patches_coq/pkg-config.c @@ -0,0 +1,29 @@ +// MinGW personality wrapper for pkgconf +// This is an excutable replacement for the shell scripts /bin/ARCH-pkg-config +// Compile with e.g. +// gcc pkg-config.c -DARCH=x86_64-w64-mingw32 -o pkg-config.exe +// gcc pkg-config.c -DARCH=i686-w64-mingw32 -o pkg-config.exe +// ATTENTION: Do not compile with MinGW-gcc, compile with cygwin gcc! +// +// To test it execute e.g. +// $ ./pkg-config --path zlib +// /usr/x86_64-w64-mingw32/sys-root/mingw/lib/pkgconfig/zlib.pc + +#include <unistd.h> + +#define STRINGIFY1(arg) #arg +#define STRINGIFY(arg) STRINGIFY1(arg) + +int main(int argc, char *argv[]) +{ + // +1 for extra argument, +1 for trailing NULL + char * argvnew[argc+2]; + int id=0, is=0; + + argvnew[id++] = argv[is++]; + argvnew[id++] = "--personality="STRINGIFY(ARCH); + while( is<argc ) argvnew[id++] = argv[is++]; + argvnew[id++] = 0; + + return execv("/usr/bin/pkgconf", argvnew); +} diff --git a/dev/build/windows/patches_coq/quickchick.patch b/dev/build/windows/patches_coq/quickchick.patch index 1afa6e7f95..1afa6e7f95 100755..100644 --- a/dev/build/windows/patches_coq/quickchick.patch +++ b/dev/build/windows/patches_coq/quickchick.patch diff --git a/dev/ci/ci-bedrock2.sh b/dev/ci/ci-bedrock2.sh index 2ac78d3c2b..2d242d80a4 100755 --- a/dev/ci/ci-bedrock2.sh +++ b/dev/ci/ci-bedrock2.sh @@ -6,4 +6,4 @@ ci_dir="$(dirname "$0")" FORCE_GIT=1 git_download bedrock2 -( cd "${CI_BUILD_DIR}/bedrock2" && git submodule update --init --recursive && COQMF_ARGS='-arg "-async-proofs-tac-j 1"' make ) +( cd "${CI_BUILD_DIR}/bedrock2" && git submodule update --init --recursive && COQMF_ARGS='-arg "-async-proofs-tac-j 1"' make | iconv -t UTF-8 -c `#9767` ) diff --git a/dev/ci/ci-paramcoq.sh b/dev/ci/ci-paramcoq.sh index c641af2abb..d2e0ee89bf 100755 --- a/dev/ci/ci-paramcoq.sh +++ b/dev/ci/ci-paramcoq.sh @@ -5,4 +5,4 @@ ci_dir="$(dirname "$0")" git_download paramcoq -( cd "${CI_BUILD_DIR}/paramcoq" && make && make install ) +( cd "${CI_BUILD_DIR}/paramcoq" && make && make install && cd test-suite && make examples) diff --git a/dev/ci/docker/bionic_coq/Dockerfile b/dev/ci/docker/bionic_coq/Dockerfile index ac763547b6..e553cbed1b 100644 --- a/dev/ci/docker/bionic_coq/Dockerfile +++ b/dev/ci/docker/bionic_coq/Dockerfile @@ -1,4 +1,4 @@ -# CACHEKEY: "bionic_coq-V2019-03-11-V1" +# CACHEKEY: "bionic_coq-V2019-03-12-V1" # ^^ Update when modifying this file. FROM ubuntu:bionic @@ -10,7 +10,7 @@ RUN apt-get update -qq && apt-get install --no-install-recommends -y -qq \ # Dependencies of the image, the test-suite and external projects m4 automake autoconf time wget rsync git gcc-multilib build-essential unzip \ # Dependencies of lablgtk (for CoqIDE) - libgtk2.0-dev libgtksourceview2.0-dev \ + libgtksourceview-3.0-dev \ # Dependencies of stdlib and sphinx doc texlive-latex-extra texlive-fonts-recommended texlive-xetex latexmk \ xindy python3-pip python3-setuptools python3-pexpect python3-bs4 \ @@ -22,7 +22,7 @@ RUN pip3 install sphinx==1.7.8 sphinx_rtd_theme==0.2.5b2 \ antlr4-python3-runtime==4.7.1 sphinxcontrib-bibtex==0.4.0 # We need to install OPAM 2.0 manually for now. -RUN wget https://github.com/ocaml/opam/releases/download/2.0.0/opam-2.0.0-x86_64-linux -O /usr/bin/opam && chmod 755 /usr/bin/opam +RUN wget https://github.com/ocaml/opam/releases/download/2.0.3/opam-2.0.3-x86_64-linux -O /usr/bin/opam && chmod 755 /usr/bin/opam # Basic OPAM setup ENV NJOBS="2" \ @@ -41,7 +41,10 @@ ENV BASE_OPAM="num ocamlfind.1.8.0 dune.1.6.2 ounit.2.0.8 odoc.1.4.0" \ CI_OPAM="menhir.20181113 elpi.1.1.0 ocamlgraph.1.8.8" # BASE switch; CI_OPAM contains Coq's CI dependencies. -ENV COQIDE_OPAM="lablgtk.2.18.5 conf-gtksourceview.2" +ENV COQIDE_OPAM="cairo2.0.6 lablgtk3-sourceview3.3.0.beta5" + +# Must add this to COQIDE_OPAM{,_EDGE} when we update the opam +# packages "lablgtk3-gtksourceview3" # base switch RUN opam init -a --disable-sandboxing --compiler="$COMPILER" default https://opam.ocaml.org && eval $(opam env) && opam update && \ @@ -53,7 +56,7 @@ RUN opam switch create "${COMPILER}+32bit" && eval $(opam env) && \ # EDGE switch ENV COMPILER_EDGE="4.07.1" \ - COQIDE_OPAM_EDGE="lablgtk.2.18.6 conf-gtksourceview.2" \ + COQIDE_OPAM_EDGE="cairo2.0.6 lablgtk3-sourceview3.3.0.beta5" \ BASE_OPAM_EDGE="dune-release.1.1.0" # EDGE+flambda switch, we install CI_OPAM as to be able to use diff --git a/dev/ci/nix/coq.nix b/dev/ci/nix/coq.nix index ecd280e58d..b610790f61 100644 --- a/dev/ci/nix/coq.nix +++ b/dev/ci/nix/coq.nix @@ -5,5 +5,4 @@ let coq = callPackage wd { buildDoc = false; doInstallCheck = false; coq-version coq.overrideAttrs (o: { name = "coq-local-${branch}"; src = fetchGit "${wd}"; - enableParallelBuilding = true; }) diff --git a/dev/ci/nix/default.nix b/dev/ci/nix/default.nix index 94e0a666e2..17070e66ee 100644 --- a/dev/ci/nix/default.nix +++ b/dev/ci/nix/default.nix @@ -1,4 +1,4 @@ -{ pkgs ? import <nixpkgs> {} +{ pkgs ? import ../../nixpkgs.nix {} , branch , wd , project ? "xyz" @@ -20,8 +20,17 @@ let mathcomp = coqPackages.mathcomp.overrideAttrs (o: { let ssreflect = coqPackages.ssreflect.overrideAttrs (o: { inherit (mathcomp) src; }); in -let coq-ext-lib = coqPackages.coq-ext-lib; in -let simple-io = coqPackages.simple-io; in + +let coq-ext-lib = coqPackages.coq-ext-lib.overrideAttrs (o: { + src = fetchTarball "https://github.com/coq-ext-lib/coq-ext-lib/tarball/master"; + }); in + +let simple-io = + (coqPackages.simple-io.override { inherit coq-ext-lib; }) + .overrideAttrs (o: { + src = fetchTarball "https://github.com/Lysxia/coq-simple-io/tarball/master"; + }); in + let bignums = coqPackages.bignums.overrideAttrs (o: if bn == "release" then {} else if bn == "master" then { src = fetchTarball https://github.com/coq/bignums/archive/master.tar.gz; } else diff --git a/dev/ci/nix/quickchick.nix b/dev/ci/nix/quickchick.nix index 46bf02ae3c..b90f1e4f88 100644 --- a/dev/ci/nix/quickchick.nix +++ b/dev/ci/nix/quickchick.nix @@ -1,5 +1,5 @@ { ocamlPackages, ssreflect, coq-ext-lib, simple-io }: { buildInputs = with ocamlPackages; [ ocaml findlib ocamlbuild num ]; - coqBuildInputs = [ ssreflect coq-ext-lib simple-io ]; + coqBuildInputs = [ ssreflect simple-io ]; } diff --git a/dev/ci/user-overlays/08817-sprop.sh b/dev/ci/user-overlays/08817-sprop.sh new file mode 100644 index 0000000000..81e18226ed --- /dev/null +++ b/dev/ci/user-overlays/08817-sprop.sh @@ -0,0 +1,34 @@ +if [ "$CI_PULL_REQUEST" = "8817" ] || [ "$CI_BRANCH" = "sprop" ]; then + aac_tactics_CI_REF=sprop + aac_tactics_CI_GITURL=https://github.com/SkySkimmer/aac-tactics + + coq_dpdgraph_CI_REF=sprop + coq_dpdgraph_CI_GITURL=https://github.com/SkySkimmer/coq-dpdgraph + + coqhammer_CI_REF=sprop + coqhammer_CI_GITURL=https://github.com/SkySkimmer/coqhammer + + elpi_CI_REF=sprop + elpi_CI_GITURL=https://github.com/SkySkimmer/coq-elpi + + equations_CI_REF=sprop + equations_CI_GITURL=https://github.com/SkySkimmer/Coq-Equations + + ltac2_CI_REF=sprop + ltac2_CI_GITURL=https://github.com/SkySkimmer/ltac2 + + unicoq_CI_REF=sprop + unicoq_CI_GITURL=https://github.com/SkySkimmer/unicoq + + mtac2_CI_REF=sprop + mtac2_CI_GITURL=https://github.com/SkySkimmer/mtac2 + + paramcoq_CI_REF=sprop + paramcoq_CI_GITURL=https://github.com/SkySkimmer/paramcoq + + quickchick_CI_REF=sprop + quickchick_CI_GITURL=https://github.com/SkySkimmer/QuickChick + + relation_algebra_CI_REF=sprop + relation_algebra_CI_GITURL=https://github.com/SkySkimmer/relation-algebra +fi diff --git a/dev/ci/user-overlays/09678-printed-by-env.sh b/dev/ci/user-overlays/09678-printed-by-env.sh new file mode 100644 index 0000000000..ccb3498764 --- /dev/null +++ b/dev/ci/user-overlays/09678-printed-by-env.sh @@ -0,0 +1,14 @@ + +if [ "$CI_PULL_REQUEST" = "9678" ] || [ "$CI_BRANCH" = "printed-by-env" ]; then + elpi_CI_REF=printed-by-env + elpi_CI_GITURL=https://github.com/maximedenes/coq-elpi + + equations_CI_REF=printed-by-env + equations_CI_GITURL=https://github.com/maximedenes/Coq-Equations + + ltac2_CI_REF=printed-by-env + ltac2_CI_GITURL=https://github.com/maximedenes/ltac2 + + quickchick_CI_REF=printed-by-env + quickchick_CI_GITURL=https://github.com/maximedenes/QuickChick +fi diff --git a/dev/doc/SProp.md b/dev/doc/SProp.md new file mode 100644 index 0000000000..f263dbb867 --- /dev/null +++ b/dev/doc/SProp.md @@ -0,0 +1,41 @@ +# Notes on SProp + +(ml API side, see refman for user side) + +## Relevance + +All kernel binders (`Prod`/`Lambda`/`LetIn`/`Context` elements) are +now annotated with a value in `type Sorts.relevance = Relevant | +Irrelevant`. It should verify that the binder's type lives in `SProp` +iff the annotation is `Irrelevant`. + +As a plugin you can generally just use `Relevant` everywhere, the +kernel will fix it if needed when it checks the terms you produce. The +only issue is that if you generate `Relevant` when it should have been +`Irrelevant` you won't be able to use proof irrelevance on that +variable until the kernel fixes it. See refman for examples as Coq +also uses `Relevant` incorrectly in some places. + +This annotation is done by transforming the binder name `'a` into a +`'a Context.binder_annot = { binder_name : 'a; binder_relevance : +Sorts.relevance }`, eg `Prod of Name.t * types * types` becomes `Prod +of Name.t Context.binder_annot * types * types`. + +If you just carry binder names around without looking at them no +change is needed, eg if you have `match foo with Lambda (x, a, b) -> +Prod (x, a, type_of (push_rel (LocalAssum (x,a)) env) b)`. Otherwise +see `context.mli` for a few combinators on the `binder_annot` type. + +When making `Relevant` annotations you can use some convenience +functions from `Context` (eg `annotR x = make_annot x Relevant`), also +`mkArrowR` from `Constr`/`EConstr` which has the signature of the old +`mkArrow`. + +You can enable the debug warning `bad-relevance` to help find places +where you generate incorrect annotations. + +Relevance can be inferred from a well-typed term using functions in +`Retypeops` (for `Constr`) and `Retyping` (for `EConstr`). For `x` a +term, note the difference between its relevance as a term (is `x : +(_ : SProp)`) and as a type (is `x : SProp`), there are functions for +both kinds. diff --git a/dev/doc/changes.md b/dev/doc/changes.md index 491a75bb3d..416253fad1 100644 --- a/dev/doc/changes.md +++ b/dev/doc/changes.md @@ -12,6 +12,8 @@ ### ML API +SProp was added, see <SProp.md> + General deprecation - All functions marked [@@ocaml.deprecated] in 8.8 have been @@ -52,6 +54,15 @@ Macros: where `atts : Vernacexpr.vernac_flags` was bound in the expression and had to be manually parsed. +- `PRINTED BY` now binds `env` and `sigma`, and expects printers which take + as parameters term printers parametrized by an environment and an `evar_map`. + +Printers + +- `Ppconstr.pr_constr_expr`, `Ppconstr.lconstr_expr`, + `Ppconstr.pr_constr_pattern_expr` and `Ppconstr.pr_lconstr_pattern_expr` + now all take an environment and an `evar_map`. + Libobject - A Higher-level API for objects with fixed scope was introduced. It supports the following kinds of objects: diff --git a/dev/nixpkgs.nix b/dev/nixpkgs.nix new file mode 100644 index 0000000000..4aa0f04964 --- /dev/null +++ b/dev/nixpkgs.nix @@ -0,0 +1,4 @@ +import (fetchTarball { + url = "https://github.com/NixOS/nixpkgs/archive/2923bd5d0669f1ec6ab03ddce052e9c5efb46d8f.tar.gz"; + sha256 = "16cn93rpxfql5idhigyjyhc013a3hwzyy2dl1xv7h2p78sk728vw"; +}) diff --git a/dev/top_printers.ml b/dev/top_printers.ml index a3d2f33216..499bbba37e 100644 --- a/dev/top_printers.ml +++ b/dev/top_printers.ml @@ -20,6 +20,7 @@ open Univ open Environ open Printer open Constr +open Context open Genarg open Clenv @@ -71,7 +72,7 @@ let pr_econstr t = Printer.pr_econstr_env env sigma t let ppconstr x = pp (pr_constr x) let ppeconstr x = pp (pr_econstr x) -let ppconstr_expr x = pp (Ppconstr.pr_constr_expr x) +let ppconstr_expr x = let sigma,env = Pfedit.get_current_context () in pp (Ppconstr.pr_constr_expr env sigma x) let ppsconstr x = ppconstr (Mod_subst.force_constr x) let ppconstr_univ x = Constrextern.with_universes ppconstr x let ppglob_constr = (fun x -> pp(pr_lglob_constr_env (Global.env()) x)) @@ -306,6 +307,7 @@ let constr_display csr = incr cnt; pp (str "with " ++ int !cnt ++ str" " ++ Level.pr u ++ fnl ()) and sort_display = function + | SProp -> "SProp" | Set -> "Set" | Prop -> "Prop" | Type u -> univ_display u; @@ -315,7 +317,7 @@ let constr_display csr = Array.fold_right (fun x i -> level_display x; (string_of_int !cnt)^(if not(i="") then (" "^i) else "")) (Instance.to_array l) "" - and name_display = function + and name_display x = match x.binder_name with | Name id -> "Name("^(Id.to_string id)^")" | Anonymous -> "Anonymous" @@ -335,13 +337,13 @@ let print_pure_constr csr = | Cast (c,_, t) -> open_hovbox 1; print_string "("; (term_display c); print_cut(); print_string "::"; (term_display t); print_string ")"; close_box() - | Prod (Name(id),t,c) -> + | Prod ({binder_name=Name(id)},t,c) -> open_hovbox 1; print_string"("; print_string (Id.to_string id); print_string ":"; box_display t; print_string ")"; print_cut(); box_display c; close_box() - | Prod (Anonymous,t,c) -> + | Prod ({binder_name=Anonymous},t,c) -> print_string"("; box_display t; print_cut(); print_string "->"; box_display c; print_string ")"; | Lambda (na,t,c) -> @@ -430,12 +432,13 @@ let print_pure_constr csr = Array.iter (fun u -> print_space (); pp (Level.pr u)) (Instance.to_array u) and sort_display = function + | SProp -> print_string "SProp" | Set -> print_string "Set" | Prop -> print_string "Prop" | Type u -> open_hbox(); print_string "Type("; pp (pr_uni u); print_string ")"; close_box() - and name_display = function + and name_display x = match x.binder_name with | Name id -> print_string (Id.to_string id) | Anonymous -> print_string "_" (* Remove the top names for library and Scratch to avoid long names *) diff --git a/dev/vm_printers.ml b/dev/vm_printers.ml index dc30793a6e..863d930968 100644 --- a/dev/vm_printers.ml +++ b/dev/vm_printers.ml @@ -25,6 +25,7 @@ let print_vfix_app () = print_string "vfix_app" let print_vswith () = print_string "switch" let ppsort = function + | SProp -> print_string "SProp" | Set -> print_string "Set" | Prop -> print_string "Prop" | Type u -> print_string "Type" diff --git a/doc/common/macros.tex b/doc/common/macros.tex index 927a912fbf..e790d20e00 100644 --- a/doc/common/macros.tex +++ b/doc/common/macros.tex @@ -273,6 +273,7 @@ \newcommand{\nS}{\mbox{\textsf{S}}} \newcommand{\node}{\mbox{\textsf{node}}} \newcommand{\Nil}{\mbox{\textsf{nil}}} +\newcommand{\SProp}{\mbox{\textsf{SProp}}} \newcommand{\Prop}{\mbox{\textsf{Prop}}} \newcommand{\Set}{\mbox{\textsf{Set}}} \newcommand{\si}{\mbox{\textsf{if}}} diff --git a/doc/plugin_tutorial/tuto3/src/construction_game.ml b/doc/plugin_tutorial/tuto3/src/construction_game.ml index 9d9f894e18..663113d012 100644 --- a/doc/plugin_tutorial/tuto3/src/construction_game.ml +++ b/doc/plugin_tutorial/tuto3/src/construction_game.ml @@ -1,4 +1,5 @@ open Pp +open Context let find_reference = Coqlib.find_reference [@ocaml.warning "-3"] @@ -32,7 +33,7 @@ let dangling_identity env evd = let evd, arg_type = Evarutil.new_evar env evd type_type in (* Notice the use of a De Bruijn index for the inner occurrence of the bound variable. *) - evd, EConstr.mkLambda(Names.Name (Names.Id.of_string "x"), arg_type, + evd, EConstr.mkLambda(nameR (Names.Id.of_string "x"), arg_type, EConstr.mkRel 1) let dangling_identity2 env evd = @@ -40,7 +41,7 @@ let dangling_identity2 env evd = is meant to be a type. *) let evd, (arg_type, type_type) = Evarutil.new_type_evar env evd Evd.univ_rigid in - evd, EConstr.mkLambda(Names.Name (Names.Id.of_string "x"), arg_type, + evd, EConstr.mkLambda(nameR (Names.Id.of_string "x"), arg_type, EConstr.mkRel 1) let example_sort_app_lambda () = diff --git a/doc/plugin_tutorial/tuto3/src/tuto_tactic.ml b/doc/plugin_tutorial/tuto3/src/tuto_tactic.ml index 8f2c387d09..2d541087ce 100644 --- a/doc/plugin_tutorial/tuto3/src/tuto_tactic.ml +++ b/doc/plugin_tutorial/tuto3/src/tuto_tactic.ml @@ -116,11 +116,11 @@ let repackage i h_hyps_id = Goal.enter begin fun gl -> mkApp (c_U (), [| ty2; mkVar h_hyps_id|]) |]) in Refine.refine ~typecheck:true begin fun evd -> let evd, new_goal = Evarutil.new_evar env evd - (mkProd (Names.Name.Anonymous, - mkApp(c_H (), [| new_packed_type |]), - Vars.lift 1 concl)) in - evd, mkApp (new_goal, - [|mkApp(c_M (), [|new_packed_type; new_packed_value |]) |]) + (mkArrowR (mkApp(c_H (), [| new_packed_type |])) + (Vars.lift 1 concl)) + in + evd, mkApp (new_goal, + [|mkApp(c_M (), [|new_packed_type; new_packed_value |]) |]) end end diff --git a/doc/sphinx/_static/diffs-error-message.png b/doc/sphinx/_static/diffs-error-message.png Binary files differnew file mode 100644 index 0000000000..6733d9c6a9 --- /dev/null +++ b/doc/sphinx/_static/diffs-error-message.png diff --git a/doc/sphinx/addendum/sprop.rst b/doc/sphinx/addendum/sprop.rst new file mode 100644 index 0000000000..015b84c530 --- /dev/null +++ b/doc/sphinx/addendum/sprop.rst @@ -0,0 +1,236 @@ +.. _sprop: + +SProp (proof irrelevant propositions) +===================================== + +.. warning:: + + The status of strict propositions is experimental. + +This section describes the extension of |Coq| with definitionally +proof irrelevant propositions (types in the sort :math:`\SProp`, also +known as strict propositions). To use :math:`\SProp` you must pass +``-allow-sprop`` to the |Coq| program or use :opt:`Allow StrictProp`. + +.. opt:: Allow StrictProp + :name: Allow StrictProp + + Allows using :math:`\SProp` when set and forbids it when unset. The + initial value depends on whether you used the command line + ``-allow-sprop``. + +.. coqtop:: none + + Set Allow StrictProp. + +Some of the definitions described in this document are available +through ``Coq.Logic.StrictProp``, which see. + +Basic constructs +---------------- + +The purpose of :math:`\SProp` is to provide types where all elements +are convertible: + +.. coqdoc:: + + Definition irrelevance (A:SProp) (P:A -> Prop) (x:A) (v:P x) (y:A) : P y := v. + +Since we have definitional :ref:`eta-expansion` for +functions, the property of being a type of definitionally irrelevant +values is impredicative, and so is :math:`\SProp`: + +.. coqdoc:: + + Check fun (A:Type) (B:A -> SProp) => (forall x:A, B x) : SProp. + +.. warning:: + + Conversion checking through bytecode or native code compilation + currently does not understand proof irrelevance. + +In order to keep conversion tractable, cumulativity for :math:`\SProp` +is forbidden: + +.. coqtop:: all + + Fail Check (fun (A:SProp) => A : Type). + +We can explicitly lift strict propositions into the relevant world by +using a wrapping inductive type. The inductive stops definitional +proof irrelevance from escaping. + +.. coqtop:: in + + Inductive Box (A:SProp) : Prop := box : A -> Box A. + Arguments box {_} _. + +.. coqtop:: all + + Fail Check fun (A:SProp) (x y : Box A) => eq_refl : x = y. + +.. doesn't get merged with the above if coqdoc +.. coqtop:: in + + Definition box_irrelevant (A:SProp) (x y : Box A) : x = y + := match x, y with box x, box y => eq_refl end. + +In the other direction, we can use impredicativity to "squash" a +relevant type, making an irrelevant approximation. + +.. coqdoc:: + + Definition iSquash (A:Type) : SProp + := forall P : SProp, (A -> P) -> P. + Definition isquash A : A -> iSquash A + := fun a P f => f a. + Definition iSquash_sind A (P : iSquash A -> SProp) (H : forall x : A, P (isquash A x)) + : forall x : iSquash A, P x + := fun x => x (P x) (H : A -> P x). + +Or more conveniently (but equivalently) + +.. coqdoc:: + + Inductive Squash (A:Type) : SProp := squash : A -> Squash A. + +Most inductives types defined in :math:`\SProp` are squashed types, +i.e. they can only be eliminated to construct proofs of other strict +propositions. Empty types are the only exception. + +.. coqtop:: in + + Inductive sEmpty : SProp := . + +.. coqtop:: all + + Check sEmpty_rect. + +.. note:: + + Eliminators to strict propositions are called ``foo_sind``, in the + same way that eliminators to propositions are called ``foo_ind``. + +Primitive records in :math:`\SProp` are allowed when fields are strict +propositions, for instance: + +.. coqtop:: in + + Set Primitive Projections. + Record sProd (A B : SProp) : SProp := { sfst : A; ssnd : B }. + +On the other hand, to avoid having definitionally irrelevant types in +non-:math:`\SProp` sorts (through record η-extensionality), primitive +records in relevant sorts must have at least one relevant field. + +.. coqtop:: all + + Set Warnings "+non-primitive-record". + Fail Record rBox (A:SProp) : Prop := rbox { runbox : A }. + +.. coqdoc:: + + Record ssig (A:Type) (P:A -> SProp) : Type := { spr1 : A; spr2 : P spr1 }. + +Note that ``rBox`` works as an emulated record, which is equivalent to +the Box inductive. + +Encodings for strict propositions +--------------------------------- + +The elimination for unit types can be encoded by a trivial function +thanks to proof irrelevance: + +.. coqdoc:: + + Inductive sUnit : SProp := stt. + Definition sUnit_rect (P:sUnit->Type) (v:P stt) (x:sUnit) : P x := v. + +By using empty and unit types as base values, we can encode other +strict propositions. For instance: + +.. coqdoc:: + + Definition is_true (b:bool) : SProp := if b then sUnit else sEmpty. + + Definition is_true_eq_true b : is_true b -> true = b + := match b with + | true => fun _ => eq_refl + | false => sEmpty_ind _ + end. + + Definition eq_true_is_true b (H:true=b) : is_true b + := match H in _ = x return is_true x with eq_refl => stt end. + +Issues with non-cumulativity +---------------------------- + +During normal term elaboration, we don't always know that a type is a +strict proposition early enough. For instance: + +.. coqdoc:: + + Definition constant_0 : ?[T] -> nat := fun _ : sUnit => 0. + +While checking the type of the constant, we only know that ``?[T]`` +must inhabit some sort. Putting it in some floating universe ``u`` +would disallow instantiating it by ``sUnit : SProp``. + +In order to make the system usable without having to annotate every +instance of :math:`\SProp`, we consider :math:`\SProp` to be a subtype +of every universe during elaboration (i.e. outside the kernel). Then +once we have a fully elaborated term it is sent to the kernel which +will check that we didn't actually need cumulativity of :math:`\SProp` +(in the example above, ``u`` doesn't appear in the final term). + +This means that some errors will be delayed until ``Qed``: + +.. coqtop:: in + + Lemma foo : Prop. + Proof. pose (fun A : SProp => A : Type); exact True. + +.. coqtop:: all + + Fail Qed. + +.. coqtop:: in + + Abort. + +.. opt:: Elaboration StrictProp Cumulativity + :name: Elaboration StrictProp Cumulativity + + Unset this option (it's on by default) to be strict with regard to + :math:`\SProp` cumulativity during elaboration. + +The implementation of proof irrelevance uses inferred "relevance" +marks on binders to determine which variables are irrelevant. Together +with non-cumulativity this allows us to avoid retyping during +conversion. However during elaboration cumulativity is allowed and so +the algorithm may miss some irrelevance: + +.. coqtop:: all + + Fail Definition late_mark := fun (A:SProp) (P:A -> Prop) x y (v:P x) => v : P y. + +The binders for ``x`` and ``y`` are created before their type is known +to be ``A``, so they're not marked irrelevant. This can be avoided +with sufficient annotation of binders (see ``irrelevance`` at the +beginning of this chapter) or by bypassing the conversion check in +tactics. + +.. coqdoc:: + + Definition late_mark := fun (A:SProp) (P:A -> Prop) x y (v:P x) => + ltac:(exact_no_check v) : P y. + +The kernel will re-infer the marks on the fully elaborated term, and +so correctly converts ``x`` and ``y``. + +.. warn:: Bad relevance + + This is a developer warning, disabled by default. It is emitted by + the kernel when it is passed a term with incorrect relevance marks. + To avoid conversion issues as in ``late_mark`` you may wish to use + it to find when your tactics are producing incorrect marks. diff --git a/doc/sphinx/index.html.rst b/doc/sphinx/index.html.rst index a652b9e1ca..5a349fcf75 100644 --- a/doc/sphinx/index.html.rst +++ b/doc/sphinx/index.html.rst @@ -74,6 +74,7 @@ Contents addendum/parallel-proof-processing addendum/miscellaneous-extensions addendum/universe-polymorphism + addendum/sprop .. toctree:: :caption: Reference diff --git a/doc/sphinx/index.latex.rst b/doc/sphinx/index.latex.rst index 9e9eb330fe..ff3971aee4 100644 --- a/doc/sphinx/index.latex.rst +++ b/doc/sphinx/index.latex.rst @@ -81,6 +81,7 @@ Addendum addendum/parallel-proof-processing addendum/miscellaneous-extensions addendum/universe-polymorphism + addendum/sprop .. toctree:: zebibliography diff --git a/doc/sphinx/language/cic.rst b/doc/sphinx/language/cic.rst index e05df65c63..ef183174d7 100644 --- a/doc/sphinx/language/cic.rst +++ b/doc/sphinx/language/cic.rst @@ -36,21 +36,29 @@ Sorts ~~~~~~~~~~~ All sorts have a type and there is an infinite well-founded typing -hierarchy of sorts whose base sorts are :math:`\Prop` and :math:`\Set`. +hierarchy of sorts whose base sorts are :math:`\SProp`, :math:`\Prop` +and :math:`\Set`. The sort :math:`\Prop` intends to be the type of logical propositions. If :math:`M` is a logical proposition then it denotes the class of terms representing proofs of :math:`M`. An object :math:`m` belonging to :math:`M` witnesses the fact that :math:`M` is provable. An object of type :math:`\Prop` is called a proposition. +The sort :math:`\SProp` is like :math:`\Prop` but the propositions in +:math:`\SProp` are known to have irrelevant proofs (all proofs are +equal). Objects of type :math:`\SProp` are called strict propositions. +:math:`\SProp` is rejected except when using the compiler option +``-allow-sprop``. See :ref:`sprop` for information about using +:math:`\SProp`. + The sort :math:`\Set` intends to be the type of small sets. This includes data types such as booleans and naturals, but also products, subsets, and function types over these data types. -:math:`\Prop` and :math:`\Set` themselves can be manipulated as ordinary terms. +:math:`\SProp`, :math:`\Prop` and :math:`\Set` themselves can be manipulated as ordinary terms. Consequently they also have a type. Because assuming simply that :math:`\Set` has type :math:`\Set` leads to an inconsistent theory :cite:`Coq86`, the language of -|Cic| has infinitely many sorts. There are, in addition to :math:`\Set` and :math:`\Prop` +|Cic| has infinitely many sorts. There are, in addition to the base sorts, a hierarchy of universes :math:`\Type(i)` for any integer :math:`i ≥ 1`. Like :math:`\Set`, all of the sorts :math:`\Type(i)` contain small sets such as @@ -63,7 +71,7 @@ Formally, we call :math:`\Sort` the set of sorts which is defined by: .. math:: - \Sort \equiv \{\Prop,\Set,\Type(i)\;|\; i~∈ ℕ\} + \Sort \equiv \{\SProp,\Prop,\Set,\Type(i)\;|\; i~∈ ℕ\} Their properties, such as: :math:`\Prop:\Type(1)`, :math:`\Set:\Type(1)`, and :math:`\Type(i):\Type(i+1)`, are defined in Section :ref:`subtyping-rules`. @@ -113,7 +121,7 @@ language of the *Calculus of Inductive Constructions* is built from the following rules. -#. the sorts :math:`\Set`, :math:`\Prop`, :math:`\Type(i)` are terms. +#. the sorts :math:`\SProp`, :math:`\Prop`, :math:`\Set`, :math:`\Type(i)` are terms. #. variables, hereafter ranged over by letters :math:`x`, :math:`y`, etc., are terms #. constants, hereafter ranged over by letters :math:`c`, :math:`d`, etc., are terms. #. if :math:`x` is a variable and :math:`T`, :math:`U` are terms then @@ -293,6 +301,12 @@ following rules. --------------- \WF{E;~c:=t:T}{} +.. inference:: Ax-SProp + + \WFE{\Gamma} + ---------------------- + \WTEG{\SProp}{\Type(1)} + .. inference:: Ax-Prop \WFE{\Gamma} @@ -325,6 +339,14 @@ following rules. ---------------------------------------------------------- \WTEG{c}{T} +.. inference:: Prod-SProp + + \WTEG{T}{s} + s \in {\Sort} + \WTE{\Gamma::(x:T)}{U}{\SProp} + ----------------------------- + \WTEG{\forall~x:T,U}{\SProp} + .. inference:: Prod-Prop \WTEG{T}{s} @@ -336,14 +358,15 @@ following rules. .. inference:: Prod-Set \WTEG{T}{s} - s \in \{\Prop, \Set\} + s \in \{\SProp, \Prop, \Set\} \WTE{\Gamma::(x:T)}{U}{\Set} ---------------------------- \WTEG{∀ x:T,~U}{\Set} .. inference:: Prod-Type - \WTEG{T}{\Type(i)} + \WTEG{T}{s} + s \in \{\SProp, \Type{i}\} \WTE{\Gamma::(x:T)}{U}{\Type(i)} -------------------------------- \WTEG{∀ x:T,~U}{\Type(i)} @@ -524,6 +547,14 @@ for :math:`x` an arbitrary variable name fresh in :math:`t`. because the type of the reduced term :math:`∀ x:\Type(2),~\Type(1)` would not be convertible to the type of the original term :math:`∀ x:\Type(1),~\Type(1)`. +.. _proof-irrelevance: + +Proof Irrelevance +~~~~~~~~~~~~~~~~~ + +It is legal to identify any two terms whose common type is a strict +proposition :math:`A : \SProp`. Terms in a strict propositions are +therefore called *irrelevant*. .. _convertibility: @@ -540,7 +571,7 @@ We say that two terms :math:`t_1` and :math:`t_2` are global environment :math:`E` and local context :math:`Γ` iff there exist terms :math:`u_1` and :math:`u_2` such that :math:`E[Γ] ⊢ t_1 \triangleright … \triangleright u_1` and :math:`E[Γ] ⊢ t_2 \triangleright … \triangleright u_2` and either :math:`u_1` and -:math:`u_2` are identical, or they are convertible up to η-expansion, +:math:`u_2` are identical up to irrelevant subterms, or they are convertible up to η-expansion, i.e. :math:`u_1` is :math:`λ x:T.~u_1'` and :math:`u_2 x` is recursively convertible to :math:`u_1'`, or, symmetrically, :math:`u_2` is :math:`λx:T.~u_2'` @@ -612,6 +643,7 @@ a *subtyping* relation inductively defined by: #. for any :math:`i`, :math:`E[Γ] ⊢ \Set ≤_{βδιζη} \Type(i)`, #. :math:`E[Γ] ⊢ \Prop ≤_{βδιζη} \Set`, hence, by transitivity, :math:`E[Γ] ⊢ \Prop ≤_{βδιζη} \Type(i)`, for any :math:`i` + (note: :math:`\SProp` is not related by cumulativity to any other term) #. if :math:`E[Γ] ⊢ T =_{βδιζη} U` and :math:`E[Γ::(x:T)] ⊢ T' ≤_{βδιζη} U'` then :math:`E[Γ] ⊢ ∀x:T,~T′ ≤_{βδιζη} ∀ x:U,~U′`. @@ -980,9 +1012,9 @@ provided that the following side conditions hold: One can remark that there is a constraint between the sort of the arity of the inductive type and the sort of the type of its constructors which will always be satisfied for the impredicative -sort :math:`\Prop` but may fail to define inductive type on sort :math:`\Set` and -generate constraints between universes for inductive types in -the Type hierarchy. +sorts :math:`\SProp` and :math:`\Prop` but may fail to define +inductive type on sort :math:`\Set` and generate constraints +between universes for inductive types in the Type hierarchy. .. example:: @@ -1339,14 +1371,15 @@ There is no restriction on the sort of the predicate to be eliminated. The case of Inductive definitions of sort :math:`\Prop` is a bit more complicated, because of our interpretation of this sort. The only -harmless allowed elimination, is the one when predicate :math:`P` is also of -sort :math:`\Prop`. +harmless allowed eliminations, are the ones when predicate :math:`P` +is also of sort :math:`\Prop` or is of the morally smaller sort +:math:`\SProp`. .. inference:: Prop - ~ - --------------- - [I:\Prop|I→\Prop] + s ∈ \{\SProp,\Prop\} + -------------------- + [I:\Prop|I→s] :math:`\Prop` is the type of logical propositions, the proofs of properties :math:`P` in @@ -1434,6 +1467,14 @@ type. An empty definition has no constructors, in that case also, elimination on any sort is allowed. +.. _Eliminaton-for-SProp: + +Inductive types in :math:`\SProp` must have no constructors (i.e. be +empty) to be eliminated to produce relevant values. + +Note that thanks to proof irrelevance elimination functions can be +produced for other types, for instance the elimination for a unit type +is the identity. .. _Type-of-branches: diff --git a/doc/sphinx/language/gallina-specification-language.rst b/doc/sphinx/language/gallina-specification-language.rst index 9bd41d79b7..02fb9d84ce 100644 --- a/doc/sphinx/language/gallina-specification-language.rst +++ b/doc/sphinx/language/gallina-specification-language.rst @@ -94,8 +94,8 @@ Keywords employed otherwise:: _ as at cofix else end exists exists2 fix for - forall fun if IF in let match mod Prop return - Set then Type using where with + forall fun if IF in let match mod return + SProp Prop Set Type then using where with Special tokens The following sequences of characters are special tokens:: @@ -159,7 +159,7 @@ is described in Chapter :ref:`syntaxextensionsandinterpretationscopes`. : ' `pattern` name : `ident` | _ qualid : `ident` | `qualid` `access_ident` - sort : Prop | Set | Type + sort : SProp | Prop | Set | Type fix_bodies : `fix_body` : `fix_body` with `fix_body` with … with `fix_body` for `ident` cofix_bodies : `cofix_body` @@ -218,13 +218,17 @@ numbers (see :ref:`datatypes`). .. index:: single: Set (sort) + single: SProp single: Prop single: Type Sorts ----- -There are three sorts :g:`Set`, :g:`Prop` and :g:`Type`. +There are four sorts :g:`SProp`, :g:`Prop`, :g:`Set` and :g:`Type`. + +- :g:`SProp` is the universe of *definitionally irrelevant + propositions* (also called *strict propositions*). - :g:`Prop` is the universe of *logical propositions*. The logical propositions themselves are typing the proofs. We denote propositions by :production:`form`. @@ -235,7 +239,7 @@ There are three sorts :g:`Set`, :g:`Prop` and :g:`Type`. specifications by :production:`specif`. This constitutes a semantic subclass of the syntactic class :token:`term`. -- :g:`Type` is the type of :g:`Prop` and :g:`Set` +- :g:`Type` is the type of sorts. More on sorts can be found in Section :ref:`sorts`. @@ -767,9 +771,9 @@ Simple inductive types are the names of its constructors and :token:`type` their respective types. Depending on the universe where the inductive type :token:`ident` lives (e.g. its type :token:`sort`), Coq provides a number of destructors. - Destructors are named :token:`ident`\ ``_ind``, :token:`ident`\ ``_rec`` - or :token:`ident`\ ``_rect`` which respectively correspond to elimination - principles on :g:`Prop`, :g:`Set` and :g:`Type`. + Destructors are named :token:`ident`\ ``_sind``,:token:`ident`\ ``_ind``, + :token:`ident`\ ``_rec`` or :token:`ident`\ ``_rect`` which respectively + correspond to elimination principles on :g:`SProp`, :g:`Prop`, :g:`Set` and :g:`Type`. The type of the destructors expresses structural induction/recursion principles over objects of type :token:`ident`. The constant :token:`ident`\ ``_ind`` is always provided, diff --git a/doc/sphinx/proof-engine/proof-handling.rst b/doc/sphinx/proof-engine/proof-handling.rst index 27360f02d3..07215a0c7e 100644 --- a/doc/sphinx/proof-engine/proof-handling.rst +++ b/doc/sphinx/proof-engine/proof-handling.rst @@ -628,7 +628,8 @@ Showing differences between proof steps --------------------------------------- -Coq can automatically highlight the differences between successive proof steps. +Coq can automatically highlight the differences between successive proof steps and between +values in some error messages. For example, the following screenshots of CoqIDE and coqtop show the application of the same :tacn:`intros` tactic. The tactic creates two new hypotheses, highlighted in green. The conclusion is entirely in pale green because although it’s changed, no tokens were added @@ -665,15 +666,24 @@ new, no line of old text is shown for them. .. image:: ../_static/diffs-coqtop-on3.png :alt: coqtop with Set Diffs on +This image shows an error message with diff highlighting in CoqIDE: + +.. + + .. image:: ../_static/diffs-error-message.png + :alt: |CoqIDE| error message with diffs + How to enable diffs ``````````````````` .. opt:: Diffs %( "on" %| "off" %| "removed" %) :name: Diffs - The “on” option highlights added tokens in green, while the “removed” option + The “on” setting highlights added tokens in green, while the “removed” setting additionally reprints items with removed tokens in red. Unchanged tokens in - modified items are shown with pale green or red. (Colors are user-configurable.) + modified items are shown with pale green or red. Diffs in error messages + use red and green for the compared values; they appear regardless of the setting. + (Colors are user-configurable.) For coqtop, showing diffs can be enabled when starting coqtop with the ``-diffs on|off|removed`` command-line option or by setting the :opt:`Diffs` option diff --git a/doc/sphinx/refman-preamble.sty b/doc/sphinx/refman-preamble.sty index 8f7b1bb1e8..90a63a5a2d 100644 --- a/doc/sphinx/refman-preamble.sty +++ b/doc/sphinx/refman-preamble.sty @@ -58,6 +58,7 @@ \newcommand{\Pair}{\textsf{pair}} \newcommand{\plus}{\mathsf{plus}} \newcommand{\Prod}{\textsf{prod}} +\newcommand{\SProp}{\textsf{SProp}} \newcommand{\Prop}{\textsf{Prop}} \newcommand{\return}{\kw{return}} \newcommand{\Set}{\textsf{Set}} diff --git a/doc/stdlib/index-list.html.template b/doc/stdlib/index-list.html.template index 7b21b67eea..fd79996bb7 100644 --- a/doc/stdlib/index-list.html.template +++ b/doc/stdlib/index-list.html.template @@ -33,6 +33,7 @@ through the <tt>Require Import</tt> command.</p> </dt> <dd> theories/Logic/SetIsType.v + theories/Logic/StrictProp.v theories/Logic/Classical_Pred_Type.v theories/Logic/Classical_Prop.v (theories/Logic/Classical.v) diff --git a/engine/eConstr.ml b/engine/eConstr.ml index 8756ebfdf2..981f9454e4 100644 --- a/engine/eConstr.ml +++ b/engine/eConstr.ml @@ -48,9 +48,10 @@ type 'a puniverses = 'a * EInstance.t let in_punivs a = (a, EInstance.empty) +let mkSProp = of_kind (Sort (ESorts.make Sorts.sprop)) let mkProp = of_kind (Sort (ESorts.make Sorts.prop)) let mkSet = of_kind (Sort (ESorts.make Sorts.set)) -let mkType u = of_kind (Sort (ESorts.make (Sorts.Type u))) +let mkType u = of_kind (Sort (ESorts.make (Sorts.sort_of_univ u))) let mkRel n = of_kind (Rel n) let mkVar id = of_kind (Var id) let mkMeta n = of_kind (Meta n) @@ -72,7 +73,8 @@ let mkCase (ci, c, r, p) = of_kind (Case (ci, c, r, p)) let mkFix f = of_kind (Fix f) let mkCoFix f = of_kind (CoFix f) let mkProj (p, c) = of_kind (Proj (p, c)) -let mkArrow t1 t2 = of_kind (Prod (Anonymous, t1, t2)) +let mkArrow t1 r t2 = of_kind (Prod (make_annot Anonymous r, t1, t2)) +let mkArrowR t1 t2 = mkArrow t1 Sorts.Relevant t2 let mkInt i = of_kind (Int i) let mkRef (gr,u) = let open GlobRef in match gr with @@ -81,6 +83,8 @@ let mkRef (gr,u) = let open GlobRef in match gr with | ConstructRef c -> mkConstructU (c,u) | VarRef x -> mkVar x +let type1 = mkSort Sorts.type1 + let applist (f, arg) = mkApp (f, Array.of_list arg) let applistc f arg = mkApp (f, Array.of_list arg) @@ -665,9 +669,9 @@ let mkLambda_or_LetIn decl c = | LocalAssum (na,t) -> mkLambda (na, t, c) | LocalDef (na,b,t) -> mkLetIn (na, b, t, c) -let mkNamedProd id typ c = mkProd (Name id, typ, Vars.subst_var id c) -let mkNamedLambda id typ c = mkLambda (Name id, typ, Vars.subst_var id c) -let mkNamedLetIn id c1 t c2 = mkLetIn (Name id, c1, t, Vars.subst_var id c2) +let mkNamedProd id typ c = mkProd (map_annot Name.mk_name id, typ, Vars.subst_var id.binder_name c) +let mkNamedLambda id typ c = mkLambda (map_annot Name.mk_name id, typ, Vars.subst_var id.binder_name c) +let mkNamedLetIn id c1 t c2 = mkLetIn (map_annot Name.mk_name id, c1, t, Vars.subst_var id.binder_name c2) let mkNamedProd_or_LetIn decl c = let open Context.Named.Declaration in diff --git a/engine/eConstr.mli b/engine/eConstr.mli index 2f4cf7d5d0..25ceffbd04 100644 --- a/engine/eConstr.mli +++ b/engine/eConstr.mli @@ -104,13 +104,14 @@ val mkVar : Id.t -> t val mkMeta : metavariable -> t val mkEvar : t pexistential -> t val mkSort : Sorts.t -> t +val mkSProp : t val mkProp : t val mkSet : t val mkType : Univ.Universe.t -> t val mkCast : t * cast_kind * t -> t -val mkProd : Name.t * t * t -> t -val mkLambda : Name.t * t * t -> t -val mkLetIn : Name.t * t * t * t -> t +val mkProd : Name.t Context.binder_annot * t * t -> t +val mkLambda : Name.t Context.binder_annot * t * t -> t +val mkLetIn : Name.t Context.binder_annot * t * t * t -> t val mkApp : t * t array -> t val mkConst : Constant.t -> t val mkConstU : Constant.t * EInstance.t -> t @@ -123,11 +124,14 @@ val mkConstructUi : (inductive * EInstance.t) * int -> t val mkCase : case_info * t * t * t array -> t val mkFix : (t, t) pfixpoint -> t val mkCoFix : (t, t) pcofixpoint -> t -val mkArrow : t -> t -> t +val mkArrow : t -> Sorts.relevance -> t -> t +val mkArrowR : t -> t -> t val mkInt : Uint63.t -> t val mkRef : GlobRef.t * EInstance.t -> t +val type1 : t + val applist : t * t list -> t val applistc : t -> t list -> t @@ -136,9 +140,9 @@ val mkLambda_or_LetIn : rel_declaration -> t -> t val it_mkProd_or_LetIn : t -> rel_context -> t val it_mkLambda_or_LetIn : t -> rel_context -> t -val mkNamedLambda : Id.t -> types -> constr -> constr -val mkNamedLetIn : Id.t -> constr -> types -> constr -> constr -val mkNamedProd : Id.t -> types -> types -> types +val mkNamedLambda : Id.t Context.binder_annot -> types -> constr -> constr +val mkNamedLetIn : Id.t Context.binder_annot -> constr -> types -> constr -> constr +val mkNamedProd : Id.t Context.binder_annot -> types -> types -> types val mkNamedLambda_or_LetIn : named_declaration -> types -> types val mkNamedProd_or_LetIn : named_declaration -> types -> types @@ -176,9 +180,9 @@ val destMeta : Evd.evar_map -> t -> metavariable val destVar : Evd.evar_map -> t -> Id.t val destSort : Evd.evar_map -> t -> ESorts.t val destCast : Evd.evar_map -> t -> t * cast_kind * t -val destProd : Evd.evar_map -> t -> Name.t * types * types -val destLambda : Evd.evar_map -> t -> Name.t * types * t -val destLetIn : Evd.evar_map -> t -> Name.t * t * types * t +val destProd : Evd.evar_map -> t -> Name.t Context.binder_annot * types * types +val destLambda : Evd.evar_map -> t -> Name.t Context.binder_annot * types * t +val destLetIn : Evd.evar_map -> t -> Name.t Context.binder_annot * t * types * t val destApp : Evd.evar_map -> t -> t * t array val destConst : Evd.evar_map -> t -> Constant.t * EInstance.t val destEvar : Evd.evar_map -> t -> t pexistential @@ -194,7 +198,7 @@ val destRef : Evd.evar_map -> t -> GlobRef.t * EInstance.t val decompose_app : Evd.evar_map -> t -> t * t list (** Pops lambda abstractions until there are no more, skipping casts. *) -val decompose_lam : Evd.evar_map -> t -> (Name.t * t) list * t +val decompose_lam : Evd.evar_map -> t -> (Name.t Context.binder_annot * t) list * t (** Pops lambda abstractions and letins until there are no more, skipping casts. *) val decompose_lam_assum : Evd.evar_map -> t -> rel_context * t @@ -210,10 +214,10 @@ val decompose_lam_n_assum : Evd.evar_map -> int -> t -> rel_context * t @raise UserError if the term doesn't have enough lambdas/letins. *) val decompose_lam_n_decls : Evd.evar_map -> int -> t -> rel_context * t -val compose_lam : (Name.t * t) list -> t -> t +val compose_lam : (Name.t Context.binder_annot * t) list -> t -> t val to_lambda : Evd.evar_map -> int -> t -> t -val decompose_prod : Evd.evar_map -> t -> (Name.t * t) list * t +val decompose_prod : Evd.evar_map -> t -> (Name.t Context.binder_annot * t) list * t val decompose_prod_assum : Evd.evar_map -> t -> rel_context * t val decompose_prod_n_assum : Evd.evar_map -> int -> t -> rel_context * t diff --git a/engine/evarutil.ml b/engine/evarutil.ml index 840c14b241..96beb72a56 100644 --- a/engine/evarutil.ml +++ b/engine/evarutil.ml @@ -11,6 +11,7 @@ open CErrors open Util open Names +open Context open Constr open Environ open Evd @@ -781,13 +782,13 @@ let cached_evar_of_hyp cache sigma decl accu = match cache with in NamedDecl.fold_constr fold decl accu | Some cache -> - let id = NamedDecl.get_id decl in + let id = NamedDecl.get_annot decl in let r = - try Id.Map.find id cache.cache + try Id.Map.find id.binder_name cache.cache with Not_found -> (* Dummy value *) let r = ref (NamedDecl.LocalAssum (id, EConstr.mkProp), Evar.Set.empty) in - let () = cache.cache <- Id.Map.add id r cache.cache in + let () = cache.cache <- Id.Map.add id.binder_name r cache.cache in r in let (decl', evs) = !r in @@ -836,7 +837,7 @@ let occur_evar_upto sigma n c = let judge_of_new_Type evd = let open EConstr in let (evd', s) = new_univ_variable univ_rigid evd in - (evd', { uj_val = mkSort (Sorts.Type s); uj_type = mkSort (Sorts.Type (Univ.super s)) }) + (evd', { uj_val = mkType s; uj_type = mkType (Univ.super s) }) let subterm_source evk ?where (loc,k) = let evk = match k with diff --git a/engine/evd.ml b/engine/evd.ml index dd2be29bd9..b89222cf8e 100644 --- a/engine/evd.ml +++ b/engine/evd.ml @@ -898,7 +898,7 @@ let new_univ_variable ?loc ?name rigid evd = let new_sort_variable ?loc ?name rigid d = let (d', u) = new_univ_variable ?loc rigid ?name d in - (d', Type u) + (d', Sorts.sort_of_univ u) let add_global_univ d u = { d with universes = UState.add_global_univ d.universes u } @@ -962,10 +962,10 @@ let normalize_universe_instance evd l = let normalize_sort evars s = match s with - | Prop | Set -> s + | SProp | Prop | Set -> s | Type u -> let u' = normalize_universe evars u in - if u' == u then s else Type u' + if u' == u then s else Sorts.sort_of_univ u' (* FIXME inefficient *) let set_eq_sort env d s1 s2 = diff --git a/engine/namegen.ml b/engine/namegen.ml index 7ef4108c22..10ece55a63 100644 --- a/engine/namegen.ml +++ b/engine/namegen.ml @@ -18,6 +18,7 @@ open Util open Names open Term open Constr +open Context open Environ open EConstr open Vars @@ -117,7 +118,7 @@ let head_name sigma c = (* Find the head constant of a constr if any *) | Const _ | Ind _ | Construct _ | Var _ as c -> Some (Nametab.basename_of_global (global_of_constr c)) | Fix ((_,i),(lna,_,_)) | CoFix (i,(lna,_,_)) -> - Some (match lna.(i) with Name id -> id | _ -> assert false) + Some (match lna.(i).binder_name with Name id -> id | _ -> assert false) | Sort _ | Rel _ | Meta _|Evar _|Case (_, _, _, _) | Int _ -> None in hdrec c @@ -136,6 +137,7 @@ let lowercase_first_char id = (* First character of a constr *) s ^ Unicode.lowercase_first_char s' let sort_hdchar = function + | SProp -> "P" | Prop -> "P" | Set -> "S" | Type _ -> "T" @@ -154,12 +156,12 @@ let hdchar env sigma c = | Rel n -> (if n<=k then "p" (* the initial term is flexible product/function *) else - try match lookup_rel (n-k) env with - | LocalAssum (Name id,_) | LocalDef (Name id,_,_) -> lowercase_first_char id - | LocalAssum (Anonymous,t) | LocalDef (Anonymous,_,t) -> hdrec 0 (lift (n-k) t) + try match let d = lookup_rel (n-k) env in get_name d, get_type d with + | Name id, _ -> lowercase_first_char id + | Anonymous, t -> hdrec 0 (lift (n-k) t) with Not_found -> "y") | Fix ((_,i),(lna,_,_)) | CoFix (i,(lna,_,_)) -> - let id = match lna.(i) with Name id -> id | _ -> assert false in + let id = match lna.(i).binder_name with Name id -> id | _ -> assert false in lowercase_first_char id | Evar _ (* We could do better... *) | Meta _ | Case (_, _, _, _) -> "y" @@ -175,18 +177,20 @@ let named_hd env sigma a = function | Anonymous -> Name (Id.of_string (hdchar env sigma a)) | x -> x -let mkProd_name env sigma (n,a,b) = mkProd (named_hd env sigma a n, a, b) -let mkLambda_name env sigma (n,a,b) = mkLambda (named_hd env sigma a n, a, b) +let mkProd_name env sigma (n,a,b) = mkProd (map_annot (named_hd env sigma a) n, a, b) +let mkLambda_name env sigma (n,a,b) = mkLambda (map_annot (named_hd env sigma a) n, a, b) let lambda_name = mkLambda_name let prod_name = mkProd_name -let prod_create env sigma (a,b) = mkProd (named_hd env sigma a Anonymous, a, b) -let lambda_create env sigma (a,b) = mkLambda (named_hd env sigma a Anonymous, a, b) +let prod_create env sigma (r,a,b) = + mkProd (make_annot (named_hd env sigma a Anonymous) r, a, b) +let lambda_create env sigma (r,a,b) = + mkLambda (make_annot (named_hd env sigma a Anonymous) r, a, b) let name_assumption env sigma = function - | LocalAssum (na,t) -> LocalAssum (named_hd env sigma t na, t) - | LocalDef (na,c,t) -> LocalDef (named_hd env sigma c na, c, t) + | LocalAssum (na,t) -> LocalAssum (map_annot (named_hd env sigma t) na, t) + | LocalDef (na,c,t) -> LocalDef (map_annot (named_hd env sigma c) na, c, t) let name_context env sigma hyps = snd @@ -456,13 +460,13 @@ let rename_bound_vars_as_displayed sigma avoid env c = | Prod (na,c1,c2) -> let na',avoid' = compute_displayed_name_in sigma - (RenamingElsewhereFor (env,c2)) avoid na c2 in - mkProd (na', c1, rename avoid' (na' :: env) c2) + (RenamingElsewhereFor (env,c2)) avoid na.binder_name c2 in + mkProd ({na with binder_name=na'}, c1, rename avoid' (na' :: env) c2) | LetIn (na,c1,t,c2) -> let na',avoid' = compute_displayed_let_name_in sigma - (RenamingElsewhereFor (env,c2)) avoid na c2 in - mkLetIn (na',c1,t, rename avoid' (na' :: env) c2) + (RenamingElsewhereFor (env,c2)) avoid na.binder_name c2 in + mkLetIn ({na with binder_name=na'},c1,t, rename avoid' (na' :: env) c2) | Cast (c,k,t) -> mkCast (rename avoid env c, k,t) | _ -> c in diff --git a/engine/namegen.mli b/engine/namegen.mli index 3722cbed24..240fd8fa81 100644 --- a/engine/namegen.mli +++ b/engine/namegen.mli @@ -44,15 +44,15 @@ val id_of_name_using_hdchar : env -> evar_map -> types -> Name.t -> Id.t val named_hd : env -> evar_map -> types -> Name.t -> Name.t val head_name : evar_map -> types -> Id.t option -val mkProd_name : env -> evar_map -> Name.t * types * types -> types -val mkLambda_name : env -> evar_map -> Name.t * types * constr -> constr +val mkProd_name : env -> evar_map -> Name.t Context.binder_annot * types * types -> types +val mkLambda_name : env -> evar_map -> Name.t Context.binder_annot * types * constr -> constr (** Deprecated synonyms of [mkProd_name] and [mkLambda_name] *) -val prod_name : env -> evar_map -> Name.t * types * types -> types -val lambda_name : env -> evar_map -> Name.t * types * constr -> constr +val prod_name : env -> evar_map -> Name.t Context.binder_annot * types * types -> types +val lambda_name : env -> evar_map -> Name.t Context.binder_annot * types * constr -> constr -val prod_create : env -> evar_map -> types * types -> constr -val lambda_create : env -> evar_map -> types * constr -> constr +val prod_create : env -> evar_map -> Sorts.relevance * types * types -> constr +val lambda_create : env -> evar_map -> Sorts.relevance * types * constr -> constr val name_assumption : env -> evar_map -> rel_declaration -> rel_declaration val name_context : env -> evar_map -> rel_context -> rel_context diff --git a/engine/nameops.ml b/engine/nameops.ml index 15e201347c..2047772cfe 100644 --- a/engine/nameops.ml +++ b/engine/nameops.ml @@ -132,6 +132,7 @@ sig 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 pick_annot : t Context.binder_annot -> t Context.binder_annot -> t Context.binder_annot val cons : t -> Id.t list -> Id.t list val to_option : Name.t -> Id.t option @@ -176,6 +177,11 @@ struct | Name _ -> na1 | Anonymous -> na2 + let pick_annot na1 na2 = + let open Context in + match na1.binder_name with + | Name _ -> na1 | Anonymous -> na2 + let cons na l = match na with | Anonymous -> l diff --git a/engine/nameops.mli b/engine/nameops.mli index a5308904f5..0e75fed045 100644 --- a/engine/nameops.mli +++ b/engine/nameops.mli @@ -84,6 +84,9 @@ module Name : sig (** [pick na na'] returns [Anonymous] if both names are [Anonymous]. Pick one of [na] or [na'] otherwise. *) + val pick_annot : Name.t Context.binder_annot -> Name.t Context.binder_annot -> + Name.t Context.binder_annot + val cons : Name.t -> Id.t list -> Id.t list (** [cons na l] returns [id::l] if [na] is [Name id] and [l] otherwise. *) diff --git a/engine/proofview.ml b/engine/proofview.ml index a725444e81..2d693e0259 100644 --- a/engine/proofview.ml +++ b/engine/proofview.ml @@ -876,9 +876,9 @@ module Progress = struct let eq_named_declaration d1 d2 = match d1, d2 with | LocalAssum (i1,t1), LocalAssum (i2,t2) -> - Names.Id.equal i1 i2 && eq_constr sigma1 sigma2 t1 t2 + Context.eq_annot Names.Id.equal i1 i2 && eq_constr sigma1 sigma2 t1 t2 | LocalDef (i1,c1,t1), LocalDef (i2,c2,t2) -> - Names.Id.equal i1 i2 && eq_constr sigma1 sigma2 c1 c2 + Context.eq_annot Names.Id.equal i1 i2 && eq_constr sigma1 sigma2 c1 c2 && eq_constr sigma1 sigma2 t1 t2 | _ -> false diff --git a/engine/termops.ml b/engine/termops.ml index 2f766afaa6..8e12c9be88 100644 --- a/engine/termops.ml +++ b/engine/termops.ml @@ -15,6 +15,7 @@ open Names open Nameops open Term open Constr +open Context open Vars open Environ @@ -115,8 +116,8 @@ let pr_decl env sigma (decl,ok) = let open NamedDecl in let print_constr = print_kconstr in match decl with - | LocalAssum (id,_) -> if ok then Id.print id else (str "{" ++ Id.print id ++ str "}") - | LocalDef (id,c,_) -> str (if ok then "(" else "{") ++ Id.print id ++ str ":=" ++ + | LocalAssum ({binder_name=id},_) -> if ok then Id.print id else (str "{" ++ Id.print id ++ str "}") + | LocalDef ({binder_name=id},c,_) -> str (if ok then "(" else "{") ++ Id.print id ++ str ":=" ++ print_constr env sigma c ++ str (if ok then ")" else "}") let pr_evar_source env sigma = function @@ -248,8 +249,8 @@ let pr_evar_universe_context ctx = let print_env_short env sigma = let print_constr = print_kconstr in let pr_rel_decl = function - | RelDecl.LocalAssum (n,_) -> Name.print n - | RelDecl.LocalDef (n,b,_) -> str "(" ++ Name.print n ++ str " := " + | RelDecl.LocalAssum (n,_) -> Name.print n.binder_name + | RelDecl.LocalDef (n,b,_) -> str "(" ++ Name.print n.binder_name ++ str " := " ++ print_constr env sigma (EConstr.of_constr b) ++ str ")" in let pr_named_decl = NamedDecl.to_rel_decl %> pr_rel_decl in @@ -459,9 +460,10 @@ let push_named_rec_types (lna,typarray,_) env = let ctxt = Array.map2_i (fun i na t -> - match na with - | Name id -> LocalAssum (id, lift i t) - | Anonymous -> anomaly (Pp.str "Fix declarations must be named.")) + let id = map_annot (function + | Name id -> id + | Anonymous -> anomaly (Pp.str "Fix declarations must be named.")) na + in LocalAssum (id, lift i t)) lna typarray in Array.fold_left (fun e assum -> push_named assum e) env ctxt @@ -469,14 +471,11 @@ let push_named_rec_types (lna,typarray,_) env = let lookup_rel_id id sign = let open RelDecl in let rec lookrec n = function - | [] -> - raise Not_found - | (LocalAssum (Anonymous, _) | LocalDef (Anonymous,_,_)) :: l -> - lookrec (n + 1) l - | LocalAssum (Name id', t) :: l -> - if Names.Id.equal id' id then (n,None,t) else lookrec (n + 1) l - | LocalDef (Name id', b, t) :: l -> - if Names.Id.equal id' id then (n,Some b,t) else lookrec (n + 1) l + | [] -> raise Not_found + | decl :: l -> + if Names.Name.equal (Name id) (get_name decl) + then (n, get_value decl, get_type decl) + else lookrec (n+1) l in lookrec 1 sign @@ -1098,7 +1097,8 @@ let is_template_polymorphic_ind env sigma f = let base_sort_cmp pb s0 s1 = match (s0,s1) with - | Prop, Prop | Set, Set | Type _, Type _ -> true + | SProp, SProp | Prop, Prop | Set, Set | Type _, Type _ -> true + | SProp, _ | _, SProp -> false | Prop, Set | Prop, Type _ | Set, Type _ -> pb == Reduction.CUMUL | Set, Prop | Type _, Prop | Type _, Set -> false @@ -1352,7 +1352,7 @@ let compact_named_context sign = let clear_named_body id env = let open NamedDecl in let aux _ = function - | LocalDef (id',c,t) when Id.equal id id' -> push_named (LocalAssum (id,t)) + | LocalDef (id',c,t) when Id.equal id id'.binder_name -> push_named (LocalAssum (id',t)) | d -> push_named d in fold_named_context aux env ~init:(reset_context env) diff --git a/engine/termops.mli b/engine/termops.mli index dea59e9efc..1dd9941c5e 100644 --- a/engine/termops.mli +++ b/engine/termops.mli @@ -23,9 +23,9 @@ val pr_fix : ('a -> Pp.t) -> ('a, 'a) pfixpoint -> Pp.t [@@ocaml.deprecated "Use [Constr.debug_print_fix]"] (** about contexts *) -val push_rel_assum : Name.t * types -> env -> env -val push_rels_assum : (Name.t * Constr.types) list -> env -> env -val push_named_rec_types : Name.t array * Constr.types array * 'a -> env -> env +val push_rel_assum : Name.t Context.binder_annot * types -> env -> env +val push_rels_assum : (Name.t Context.binder_annot * Constr.types) list -> env -> env +val push_named_rec_types : Name.t Context.binder_annot array * Constr.types array * 'a -> env -> env val lookup_rel_id : Id.t -> ('c, 't) Context.Rel.pt -> int * 'c option * 't (** Associates the contents of an identifier in a [rel_context]. Raise @@ -40,8 +40,8 @@ val rel_list : int -> int -> constr list (** iterators/destructors on terms *) val mkProd_or_LetIn : rel_declaration -> types -> types val mkProd_wo_LetIn : rel_declaration -> types -> types -val it_mkProd : types -> (Name.t * types) list -> types -val it_mkLambda : constr -> (Name.t * types) list -> constr +val it_mkProd : types -> (Name.t Context.binder_annot * types) list -> types +val it_mkLambda : constr -> (Name.t Context.binder_annot * types) list -> constr val it_mkProd_or_LetIn : types -> rel_context -> types val it_mkProd_wo_LetIn : types -> rel_context -> types val it_mkLambda_or_LetIn : Constr.constr -> Constr.rel_context -> Constr.constr @@ -246,7 +246,7 @@ val add_vname : Id.Set.t -> Name.t -> Id.Set.t (** other signature iterators *) val process_rel_context : (rel_declaration -> env -> env) -> env -> env -val assums_of_rel_context : ('c, 't) Context.Rel.pt -> (Name.t * 't) list +val assums_of_rel_context : ('c, 't) Context.Rel.pt -> (Name.t Context.binder_annot * 't) list val lift_rel_context : int -> Constr.rel_context -> Constr.rel_context val substl_rel_context : Constr.constr list -> Constr.rel_context -> Constr.rel_context val smash_rel_context : Constr.rel_context -> Constr.rel_context (** expand lets in context *) diff --git a/engine/uState.ml b/engine/uState.ml index 77d1896683..6f4f40e2c5 100644 --- a/engine/uState.ml +++ b/engine/uState.ml @@ -37,18 +37,25 @@ type t = uctx_initial_universes : UGraph.t; (** The graph at the creation of the evar_map *) uctx_weak_constraints : UPairSet.t } - + +let initial_sprop_cumulative = UGraph.make_sprop_cumulative UGraph.initial_universes + let empty = { uctx_names = UNameMap.empty, LMap.empty; uctx_local = ContextSet.empty; uctx_seff_univs = LSet.empty; uctx_univ_variables = LMap.empty; uctx_univ_algebraic = LSet.empty; - uctx_universes = UGraph.initial_universes; - uctx_initial_universes = UGraph.initial_universes; + uctx_universes = initial_sprop_cumulative; + uctx_initial_universes = initial_sprop_cumulative; uctx_weak_constraints = UPairSet.empty; } +let elaboration_sprop_cumul = + Goptions.declare_bool_option_and_ref ~depr:false ~name:"SProp cumulativity during elaboration" + ~key:["Elaboration";"StrictProp";"Cumulativity"] ~value:true + let make u = + let u = if elaboration_sprop_cumul () then UGraph.make_sprop_cumulative u else u in { empty with uctx_universes = u; uctx_initial_universes = u} @@ -710,7 +717,7 @@ let universe_of_name uctx s = UNameMap.find s (fst uctx.uctx_names) let update_sigma_env uctx env = - let univs = Environ.universes env in + let univs = UGraph.make_sprop_cumulative (Environ.universes env) in let eunivs = { uctx with uctx_initial_universes = univs; uctx_universes = univs } diff --git a/engine/univGen.ml b/engine/univGen.ml index 40c4c909fe..c310331b15 100644 --- a/engine/univGen.ml +++ b/engine/univGen.ml @@ -28,7 +28,7 @@ let fresh_level () = (* TODO: remove *) let new_univ () = Univ.Universe.make (fresh_level ()) let new_Type () = mkType (new_univ ()) -let new_Type_sort () = Type (new_univ ()) +let new_Type_sort () = sort_of_univ (new_univ ()) let fresh_instance auctx = let inst = Array.init (AUContext.size auctx) (fun _ -> fresh_level()) in @@ -128,11 +128,12 @@ let type_of_reference env r = let type_of_global t = type_of_reference (Global.env ()) t let fresh_sort_in_family = function + | InSProp -> Sorts.sprop, ContextSet.empty | InProp -> Sorts.prop, ContextSet.empty | InSet -> Sorts.set, ContextSet.empty | InType -> let u = fresh_level () in - Type (Univ.Universe.make u), ContextSet.singleton u + sort_of_univ (Univ.Universe.make u), ContextSet.singleton u let new_sort_in_family sf = fst (fresh_sort_in_family sf) diff --git a/engine/univMinim.ml b/engine/univMinim.ml index 1619ac3d34..46ff6340b4 100644 --- a/engine/univMinim.ml +++ b/engine/univMinim.ml @@ -268,6 +268,7 @@ let minimize_univ_variables ctx us algs left right cstrs = module UPairs = OrderedType.UnorderedPair(Univ.Level) module UPairSet = Set.Make (UPairs) +(* TODO check is_small/sprop *) let normalize_context_set g ctx us algs weak = let (ctx, csts) = ContextSet.levels ctx, ContextSet.constraints ctx in (* Keep the Prop/Set <= i constraints separate for minimization *) @@ -275,7 +276,7 @@ let normalize_context_set g ctx us algs weak = Constraint.partition (fun (l,d,r) -> d == Le && Level.is_small l) csts in let smallles = if get_set_minimization () - then Constraint.filter (fun (l,d,r) -> LSet.mem r ctx) smallles + then Constraint.filter (fun (l,d,r) -> LSet.mem r ctx && not (Level.is_sprop l)) smallles else Constraint.empty in let csts, partition = diff --git a/ide/configwin.ml b/ide/configwin.ml index 24be721631..79a1eae880 100644 --- a/ide/configwin.ml +++ b/ide/configwin.ml @@ -37,8 +37,10 @@ type return_button = | Return_cancel let string = Configwin_ihm.string +(* let strings = Configwin_ihm.strings let list = Configwin_ihm.list +*) let bool = Configwin_ihm.bool let combo = Configwin_ihm.combo let custom = Configwin_ihm.custom diff --git a/ide/configwin.mli b/ide/configwin.mli index 0ee77d69b5..fa22846d19 100644 --- a/ide/configwin.mli +++ b/ide/configwin.mli @@ -69,6 +69,7 @@ val string : ?editable: bool -> ?expand: bool -> ?help: string -> val bool : ?editable: bool -> ?help: string -> ?f: (bool -> unit) -> string -> bool -> parameter_kind +(* (** [strings label value] creates a string list parameter. @param editable indicate if the value is editable (default is [true]). @param help an optional help message. @@ -119,6 +120,7 @@ val list : ?editable: bool -> ?help: string -> ('a -> string list) -> 'a list -> parameter_kind +*) (** [combo label choices value] creates a combo parameter. @param editable indicate if the value is editable (default is [true]). diff --git a/ide/configwin_ihm.ml b/ide/configwin_ihm.ml index 8420d930d5..0f3fd38a7a 100644 --- a/ide/configwin_ihm.ml +++ b/ide/configwin_ihm.ml @@ -27,6 +27,10 @@ open Configwin_types +let set_help_tip wev = function + | None -> () + | Some help -> GtkBase.Widget.Tooltip.set_text wev#as_widget help + let modifiers_to_string m = let rec iter m s = match m with @@ -55,7 +59,7 @@ class type widget = let debug = false let dbg s = if debug then Minilib.log s else () - +(* (** This class builds a frame with a clist and two buttons : one to add items and one to remove the selected items. The class takes in parameter a function used to add items and @@ -71,7 +75,6 @@ class ['a] list_selection_box f_color (eq : 'a -> 'a -> bool) add_function title editable - (tt:GData.tooltips) = let _ = dbg "list_selection_box" in let wev = GBin.event_box () in @@ -94,12 +97,8 @@ class ['a] list_selection_box ~titles_show: true ~packing: wscroll#add () in - let _ = - match help_opt with - None -> () - | Some help -> - tt#set_tip ~text: help ~privat: help wev#coerce - in (* the vbox for the buttons *) + let _ = set_help_tip wev help_opt in + (* the vbox for the buttons *) let vbox_buttons = GPack.vbox () in let _ = if editable then @@ -279,10 +278,10 @@ class ['a] list_selection_box (* initialize the clist with the listref *) self#update !listref end;; - +*) (** This class is used to build a box for a string parameter.*) -class string_param_box param (tt:GData.tooltips) = +class string_param_box param = let _ = dbg "string_param_box" in let hbox = GPack.hbox () in let wev = GBin.event_box ~packing: (hbox#pack ~expand: false ~padding: 2) () in @@ -292,12 +291,7 @@ class string_param_box param (tt:GData.tooltips) = ~packing: (hbox#pack ~expand: param.string_expand ~padding: 2) () in - let _ = - match param.string_help with - None -> () - | Some help -> - tt#set_tip ~text: help ~privat: help wev#coerce - in + let _ = set_help_tip wev param.string_help in let _ = we#set_text (param.string_to_string param.string_value) in object (self) @@ -316,17 +310,12 @@ class string_param_box param (tt:GData.tooltips) = end ;; (** This class is used to build a box for a combo parameter.*) -class combo_param_box param (tt:GData.tooltips) = +class combo_param_box param = let _ = dbg "combo_param_box" in let hbox = GPack.hbox () in let wev = GBin.event_box ~packing: (hbox#pack ~expand: false ~padding: 2) () in let _wl = GMisc.label ~text: param.combo_label ~packing: wev#add () in - let _ = - match param.combo_help with - None -> () - | Some help -> - tt#set_tip ~text: help ~privat: help wev#coerce - in + let _ = set_help_tip wev param.combo_help in let get_value = if not param.combo_new_allowed then let wc = GEdit.combo_box_text ~strings: param.combo_choices @@ -341,13 +330,13 @@ class combo_param_box param (tt:GData.tooltips) = fun () -> match GEdit.text_combo_get_active wc with |None -> "" |Some s -> s else let (wc,_) = GEdit.combo_box_entry_text - ~strings: param.combo_choices - ~packing: (hbox#pack ~expand: param.combo_expand ~padding: 2) - () + ~strings: param.combo_choices + ~packing: (hbox#pack ~expand: param.combo_expand ~padding: 2) + () in let _ = wc#entry#set_editable param.combo_editable in let _ = wc#entry#set_text param.combo_value in - fun () -> wc#entry#text + fun () -> wc#entry#text in object (self) @@ -365,7 +354,7 @@ object (self) end ;; (** Class used to pack a custom box. *) -class custom_param_box param (tt:GData.tooltips) = +class custom_param_box param = let _ = dbg "custom_param_box" in let top = match param.custom_framed with @@ -381,7 +370,7 @@ class custom_param_box param (tt:GData.tooltips) = end (** This class is used to build a box for a text parameter.*) -class text_param_box param (tt:GData.tooltips) = +class text_param_box param = let _ = dbg "text_param_box" in let wf = GBin.frame ~label: param.string_label ~height: 100 () in let wev = GBin.event_box ~packing: wf#add () in @@ -395,12 +384,7 @@ class text_param_box param (tt:GData.tooltips) = ~packing: wscroll#add () in - let _ = - match param.string_help with - None -> () - | Some help -> - tt#set_tip ~text: help ~privat: help wev#coerce - in + let _ = set_help_tip wev param.string_help in let _ = dbg "text_param_box: buffer creation" in let buffer = GText.buffer () in @@ -427,17 +411,13 @@ class text_param_box param (tt:GData.tooltips) = end ;; (** This class is used to build a box for a boolean parameter.*) -class bool_param_box param (tt:GData.tooltips) = +class bool_param_box param = let _ = dbg "bool_param_box" in let wchk = GButton.check_button ~label: param.bool_label () in - let _ = - match param.bool_help with - None -> () - | Some help -> tt#set_tip ~text: help ~privat: help wchk#coerce - in + let _ = set_help_tip wchk param.bool_help in let _ = wchk#set_active param.bool_value in let _ = wchk#misc#set_sensitive param.bool_editable in @@ -471,14 +451,7 @@ class modifiers_param_box param = else value := List.filter ((<>) modifier) !value))) param.md_allow in - let _ = - match param.md_help with - None -> () - | Some help -> - let tooltips = GData.tooltips () in - ignore (hbox#connect#destroy ~callback: tooltips#destroy); - tooltips#set_tip wev#coerce ~text: help ~privat: help - in + let _ = set_help_tip wev param.md_help in object (self) (** This method returns the main box ready to be packed. *) @@ -493,9 +466,9 @@ class modifiers_param_box param = else () end ;; - +(* (** This class is used to build a box for a parameter whose values are a list.*) -class ['a] list_param_box (param : 'a list_param) (tt:GData.tooltips) = +class ['a] list_param_box (param : 'a list_param) = let _ = dbg "list_param_box" in let listref = ref param.list_value in let frame_selection = new list_selection_box @@ -520,9 +493,10 @@ class ['a] list_param_box (param : 'a list_param) (tt:GData.tooltips) = param.list_f_apply !listref ; param.list_value <- !listref end ;; +*) (** This class creates a configuration box from a configuration structure *) -class configuration_box (tt : GData.tooltips) conf_struct = +class configuration_box conf_struct = let main_box = GPack.hbox () in @@ -553,27 +527,27 @@ class configuration_box (tt : GData.tooltips) conf_struct = let make_param (main_box : #GPack.box) = function | String_param p -> - let box = new string_param_box p tt in + let box = new string_param_box p in let _ = main_box#pack ~expand: false ~padding: 2 box#box in box | Combo_param p -> - let box = new combo_param_box p tt in + let box = new combo_param_box p in let _ = main_box#pack ~expand: false ~padding: 2 box#box in box | Text_param p -> - let box = new text_param_box p tt in + let box = new text_param_box p in let _ = main_box#pack ~expand: p.string_expand ~padding: 2 box#box in box | Bool_param p -> - let box = new bool_param_box p tt in + let box = new bool_param_box p in let _ = main_box#pack ~expand: false ~padding: 2 box#box in box | List_param f -> - let box = f tt in + let box = f () in let _ = main_box#pack ~expand: true ~padding: 2 box#box in box | Custom_param p -> - let box = new custom_param_box p tt in + let box = new custom_param_box p in let _ = main_box#pack ~expand: p.custom_expand ~padding: 2 box#box in box | Modifiers_param p -> @@ -684,11 +658,9 @@ let edit ?(with_apply=true) ?parent ?height ?width () in - let tooltips = GData.tooltips () in - - let config_box = new configuration_box tooltips conf_struct in + let config_box = new configuration_box conf_struct in - let _ = dialog#vbox#add config_box#box#coerce in + let _ = dialog#vbox#pack ~expand:true config_box#box#coerce in if with_apply then dialog#add_button Configwin_messages.mApply `APPLY; @@ -697,7 +669,6 @@ let edit ?(with_apply=true) dialog#add_button Configwin_messages.mCancel `CANCEL; let destroy () = - tooltips#destroy () ; dialog#destroy (); in let rec iter rep = @@ -714,10 +685,12 @@ let edit ?(with_apply=true) in iter Return_cancel +(* let edit_string l s = match GToolbox.input_string ~title: l ~text: s Configwin_messages.mValue with None -> s | Some s2 -> s2 +*) (** Create a string param. *) let string ?(editable=true) ?(expand=true) ?help ?(f=(fun _ -> ())) label v = @@ -744,6 +717,7 @@ let bool ?(editable=true) ?help ?(f=(fun _ -> ())) label v = bool_f_apply = f ; } +(* (** Create a list param. *) let list ?(editable=true) ?help ?(f=(fun (_:'a list) -> ())) @@ -753,7 +727,7 @@ let list ?(editable=true) ?help ?titles ?(color=(fun (_:'a) -> (None : string option))) label (f_strings : 'a -> string list) v = List_param - (fun tt -> + (fun () -> new list_param_box { list_label = label ; @@ -768,7 +742,6 @@ let list ?(editable=true) ?help list_f_add = add ; list_f_apply = f ; } - tt ) (** Create a strings param. *) @@ -777,6 +750,7 @@ let strings ?(editable=true) ?help ?(eq=Pervasives.(=)) ?(add=(fun () -> [])) label v = list ~editable ?help ~f ~eq ~edit: (edit_string label) ~add label (fun s -> [s]) v +*) (** Create a combo param. *) let combo ?(editable=true) ?(expand=true) ?help ?(f=(fun _ -> ())) diff --git a/ide/configwin_ihm.mli b/ide/configwin_ihm.mli index 772a0958ff..ce6cd4d7c1 100644 --- a/ide/configwin_ihm.mli +++ b/ide/configwin_ihm.mli @@ -29,6 +29,7 @@ val string : ?editable: bool -> ?expand: bool -> ?help: string -> ?f: (string -> unit) -> string -> string -> parameter_kind val bool : ?editable: bool -> ?help: string -> ?f: (bool -> unit) -> string -> bool -> parameter_kind +(* val strings : ?editable: bool -> ?help: string -> ?f: (string list -> unit) -> ?eq: (string -> string -> bool) -> @@ -45,6 +46,7 @@ val list : ?editable: bool -> ?help: string -> ('a -> string list) -> 'a list -> parameter_kind +*) val combo : ?editable: bool -> ?expand: bool -> ?help: string -> ?f: (string -> unit) -> ?new_allowed: bool -> ?blank_allowed: bool -> diff --git a/ide/configwin_types.ml b/ide/configwin_types.ml index 9e339d135d..251e3dded3 100644 --- a/ide/configwin_types.ml +++ b/ide/configwin_types.ml @@ -97,7 +97,7 @@ type modifiers_param = { (** This type represents the different kinds of parameters. *) type parameter_kind = String_param of string string_param - | List_param of (GData.tooltips -> <box: GObj.widget ; apply : unit>) + | List_param of (unit -> <box: GObj.widget ; apply : unit>) | Bool_param of bool_param | Text_param of string string_param | Combo_param of combo_param diff --git a/ide/coq.ml b/ide/coq.ml index e7eea4ced2..a420a3cbf5 100644 --- a/ide/coq.ml +++ b/ide/coq.ml @@ -128,16 +128,15 @@ and asks_for_coqtop args = let () = pb_mes#destroy () in filter_coq_opts args | `DELETE_EVENT | `NO -> - let () = pb_mes#destroy () in - let cmd_sel = GWindow.file_selection + let file = select_file_for_open ~title:"coqidetop to execute (edit your preference then)" - ~filename:(coqtop_path ()) ~urgency_hint:true () in - match cmd_sel#run () with - | `OK -> - let () = custom_coqtop := (Some cmd_sel#filename) in - let () = cmd_sel#destroy () in + ~filter:false + ~filename:(coqtop_path ()) () in + match file with + | Some _ -> + let () = custom_coqtop := file in filter_coq_opts args - | `CANCEL | `DELETE_EVENT | `HELP -> exit 0 + | None -> exit 0 exception WrongExitStatus of string diff --git a/ide/coqOps.ml b/ide/coqOps.ml index 8da9900724..4aa801c2b2 100644 --- a/ide/coqOps.ml +++ b/ide/coqOps.ml @@ -250,6 +250,7 @@ object(self) feedback_timer.Ideutils.run ~ms:300 ~callback:self#process_feedback; let md = segment_model document in segment#set_model md; +(* let on_click id = let find _ _ s = Int.equal s.index id in let sentence = Doc.find document find in @@ -266,6 +267,7 @@ object(self) ignore (script#scroll_to_iter ~use_align:true ~yalign:0. iter) in let _ = segment#connect#clicked ~callback:on_click in +*) () method private tooltip_callback ~x ~y ~kbd tooltip = diff --git a/ide/coqide.ml b/ide/coqide.ml index 94778e0c60..eaeeaa0001 100644 --- a/ide/coqide.ml +++ b/ide/coqide.ml @@ -193,7 +193,7 @@ let confirm_save ok = let select_and_save ?parent ~saveas ?filename sn = let do_save = if saveas then sn.fileops#saveas ?parent else sn.fileops#save in let title = if saveas then "Save file as" else "Save file" in - match select_file_for_save ~title ?filename () with + match select_file_for_save ~title ?parent ?filename () with |None -> false |Some f -> let ok = do_save f in @@ -213,7 +213,8 @@ let check_save ?parent ~saveas sn = exception DontQuit let check_quit ?parent saveall = - (try save_pref () with _ -> flash_info "Cannot save preferences"); + (try save_pref () + with e -> flash_info ("Cannot save preferences (" ^ Printexc.to_string e ^ ")")); let is_modified sn = sn.buffer#modified in if List.exists is_modified notebook#pages then begin let answ = Configwin_ihm.question_box ~title:"Quit" @@ -271,11 +272,11 @@ let newfile _ = let index = notebook#append_term session in notebook#goto_page index -let load _ = +let load ?parent _ = let filename = try notebook#current_term.fileops#filename with Invalid_argument _ -> None in - match select_file_for_open ~title:"Load file" ?filename () with + match select_file_for_open ~title:"Load file" ?parent ?filename () with | None -> () | Some f -> FileAux.load_file f @@ -359,7 +360,7 @@ let print sn = Filename.quote (Filename.basename f_name) ^ " | " ^ cmd_print#get in let w = GWindow.window ~title:"Print" ~modal:true - ~position:`CENTER ~wm_class:"CoqIDE" ~wm_name: "CoqIDE" () + ~position:`CENTER ~wmclass:("CoqIDE","CoqIDE") () in let v = GPack.vbox ~spacing:10 ~border_width:10 ~packing:w#add () in @@ -812,7 +813,7 @@ let zoom_fit sn = let space = script#misc#allocation.Gtk.width in let cols = script#right_margin_position in let pango_ctx = script#misc#pango_context in - let layout = pango_ctx#create_layout in + let layout = pango_ctx#create_layout#as_layout in let fsize = Pango.Font.get_size (Pango.Font.from_string text_font#get) in Pango.Layout.set_text layout (String.make cols 'X'); let tlen = fst (Pango.Layout.get_pixel_size layout) in @@ -939,7 +940,7 @@ let emit_to_focus window sgn = let build_ui () = let w = GWindow.window - ~wm_class:"CoqIde" ~wm_name:"CoqIde" + ~wmclass:("CoqIde","CoqIde") ~width:window_width#get ~height:window_height#get ~title:"CoqIde" () in @@ -972,7 +973,7 @@ let build_ui () = menu file_menu [ item "File" ~label:"_File"; item "New" ~callback:File.newfile ~stock:`NEW; - item "Open" ~callback:File.load ~stock:`OPEN; + item "Open" ~callback:(File.load ~parent:w) ~stock:`OPEN; item "Save" ~callback:(File.save ~parent:w) ~stock:`SAVE ~tooltip:"Save current buffer"; item "Save as" ~label:"S_ave as" ~stock:`SAVE_AS ~callback:(File.saveas ~parent:w); item "Save all" ~label:"Sa_ve all" ~callback:File.saveall; @@ -1021,7 +1022,8 @@ let build_ui () = ~callback:(fun _ -> begin try Preferences.configure ~apply:refresh_notebook_pos w - with _ -> flash_info "Cannot save preferences" + with e -> + flash_info ("Editing preferences failed (" ^ Printexc.to_string e ^ ")") end; reset_revert_timer ()); ]; @@ -1220,10 +1222,10 @@ let build_ui () = ((Coqide_ui.ui_m#get_widget "/CoqIde ToolBar")#as_widget) in let () = GtkButton.Toolbar.set - ~orientation:`HORIZONTAL ~style:`ICONS ~tooltips:true tbar + ~orientation:`HORIZONTAL ~style:`ICONS tbar in - let toolbar = new GObj.widget tbar in - let () = vbox#pack toolbar in + let toolbar = new GButton.toolbar tbar in + let () = vbox#pack toolbar#coerce in (* Emacs/PG mode *) NanoPG.init w notebook all_menus; @@ -1303,11 +1305,6 @@ let build_ui () = let _ = source_style#connect#changed ~callback:refresh_style in let _ = source_language#connect#changed ~callback:refresh_language in - (* Color configuration *) - Tags.Script.incomplete#set_property - (`BACKGROUND_STIPPLE - (Gdk.Bitmap.create_from_data ~width:2 ~height:2 "\x01\x02")); - (* Showtime ! *) w#show (); w diff --git a/ide/coqide_main.ml b/ide/coqide_main.ml index 21f513b8f4..79420b3857 100644 --- a/ide/coqide_main.ml +++ b/ide/coqide_main.ml @@ -8,7 +8,7 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) -let _ = GtkMain.Main.init () +let _ = Coqide.set_signal_handlers () (* We handle Gtk warning messages ourselves : - on win32, we don't want them to end on a non-existing console @@ -29,7 +29,7 @@ (wrapped false) (modules (:standard \ document fake_ide idetop coqide_main)) (optional) - (libraries coqide-server.protocol coqide-server.core lablgtk2.sourceview2)) + (libraries coqide-server.protocol coqide-server.core lablgtk3-sourceview3)) (rule (targets coqide_os_specific.ml) diff --git a/ide/ide.mllib b/ide/ide.mllib index a7ade71307..30ac5c9ad7 100644 --- a/ide/ide.mllib +++ b/ide/ide.mllib @@ -9,7 +9,6 @@ Config_lexer Utf8_convert Preferences Project_file -Topfmt Ideutils Coq Coq_lex diff --git a/ide/ideutils.ml b/ide/ideutils.ml index 5beaba3604..8c5b3fcc5b 100644 --- a/ide/ideutils.ml +++ b/ide/ideutils.ml @@ -8,9 +8,10 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) - open Preferences +let _ = GtkMain.Main.init () + let warn_image () = let img = GMisc.image () in img#set_stock `DIALOG_WARNING; @@ -229,14 +230,17 @@ let current_dir () = match project_path#get with | None -> "" | Some dir -> dir -let select_file_for_open ~title ?filename () = +let select_file_for_open ~title ?(filter=true) ?parent ?filename () = let file_chooser = - GWindow.file_chooser_dialog ~action:`OPEN ~modal:true ~title () + GWindow.file_chooser_dialog ~action:`OPEN ~modal:true ~title ?parent () in file_chooser#add_button_stock `CANCEL `CANCEL ; file_chooser#add_select_button_stock `OPEN `OPEN ; - file_chooser#add_filter (filter_coq_files ()); - file_chooser#add_filter (filter_all_files ()); + if filter then + begin + file_chooser#add_filter (filter_coq_files ()); + file_chooser#add_filter (filter_all_files ()) + end; file_chooser#set_default_response `OPEN; let dir = match filename with | None -> current_dir () @@ -255,10 +259,10 @@ let select_file_for_open ~title ?filename () = file_chooser#destroy (); file -let select_file_for_save ~title ?filename () = +let select_file_for_save ~title ?parent ?filename () = let file = ref None in let file_chooser = - GWindow.file_chooser_dialog ~action:`SAVE ~modal:true ~title () + GWindow.file_chooser_dialog ~action:`SAVE ~modal:true ~title ?parent () in file_chooser#add_button_stock `CANCEL `CANCEL ; file_chooser#add_select_button_stock `SAVE `SAVE ; diff --git a/ide/ideutils.mli b/ide/ideutils.mli index 531c71cd4b..57f59d19fe 100644 --- a/ide/ideutils.mli +++ b/ide/ideutils.mli @@ -30,9 +30,10 @@ val find_tag_limits : GText.tag -> GText.iter -> GText.iter * GText.iter val find_tag_start : GText.tag -> GText.iter -> GText.iter val find_tag_stop : GText.tag -> GText.iter -> GText.iter -val select_file_for_open : title:string -> ?filename:string -> unit -> string option +val select_file_for_open : + title:string -> ?filter:bool -> ?parent:GWindow.window -> ?filename:string -> unit -> string option val select_file_for_save : - title:string -> ?filename:string -> unit -> string option + title:string -> ?parent:GWindow.window -> ?filename:string -> unit -> string option val try_convert : string -> string val try_export : string -> string -> bool val stock_to_widget : diff --git a/ide/nanoPG.ml b/ide/nanoPG.ml index f2913b1d1d..d85d87142c 100644 --- a/ide/nanoPG.ml +++ b/ide/nanoPG.ml @@ -52,7 +52,7 @@ let pr_key t = type action = | Action of string * string | Callback of (gui -> unit) - | Edit of (status -> GSourceView2.source_buffer -> GText.iter -> + | Edit of (status -> GSourceView3.source_buffer -> GText.iter -> (string -> string -> unit) -> status) | Motion of (status -> GText.iter -> GText.iter * status) diff --git a/ide/preferences.ml b/ide/preferences.ml index fb0eea1405..69dbc0b235 100644 --- a/ide/preferences.ml +++ b/ide/preferences.ml @@ -12,10 +12,10 @@ open Configwin let pref_file = Filename.concat (Minilib.coqide_config_home ()) "coqiderc" let accel_file = Filename.concat (Minilib.coqide_config_home ()) "coqide.keys" -let lang_manager = GSourceView2.source_language_manager ~default:true +let lang_manager = GSourceView3.source_language_manager ~default:true let () = lang_manager#set_search_path ((Minilib.coqide_data_dirs ())@lang_manager#search_path) -let style_manager = GSourceView2.source_style_scheme_manager ~default:true +let style_manager = GSourceView3.source_style_scheme_manager ~default:true let () = style_manager#set_search_path ((Minilib.coqide_data_dirs ())@style_manager#search_path) @@ -73,11 +73,11 @@ object (self) method default = default end -let stick (pref : 'a preference) (obj : #GObj.widget as 'obj) +let stick (pref : 'a preference) (obj : < connect : #GObj.widget_signals ; .. >) (cb : 'a -> unit) = let _ = cb pref#get in let p_id = pref#connect#changed ~callback:(fun v -> cb v) in - let _ = obj#misc#connect#destroy ~callback:(fun () -> pref#connect#disconnect p_id) in + let _ = obj#connect#destroy ~callback:(fun () -> pref#connect#disconnect p_id) in () (** Useful marshallers *) @@ -413,8 +413,11 @@ let attach_fg (pref : string preference) (tag : GText.tag) = let processing_color = new preference ~name:["processing_color"] ~init:"light blue" ~repr:Repr.(string) +let incompletely_processed_color = + new preference ~name:["incompletely_processed_color"] ~init:"light sky blue" ~repr:Repr.(string) + let _ = attach_bg processing_color Tags.Script.to_process -let _ = attach_bg processing_color Tags.Script.incomplete +let _ = attach_bg incompletely_processed_color Tags.Script.incomplete let tags = ref Util.String.Map.empty @@ -575,7 +578,7 @@ object (self) | None -> set#set_active true | Some c -> set#set_active false; - but#set_color (Tags.color_of_string c) + but#set_color (Gdk.Color.color_parse c) in track tag.tag_bg_color bg_color bg_unset; track tag.tag_fg_color fg_color fg_unset; @@ -587,7 +590,7 @@ object (self) method tag = let get but set = if set#active then None - else Some (Tags.string_of_color but#color) + else Some (Gdk.Color.color_to_string but#color) in { tag_bg_color = get bg_color bg_unset; @@ -691,7 +694,7 @@ let configure ?(apply=(fun () -> ())) parent = let config_color = let box = GPack.vbox () in - let table = GPack.table + let grid = GPack.grid ~row_spacings:5 ~col_spacings:5 ~border_width:2 @@ -703,19 +706,19 @@ let configure ?(apply=(fun () -> ())) parent = in let iter i (text, pref) = let label = GMisc.label - ~text ~packing:(table#attach ~expand:`X ~left:0 ~top:i) () + ~text ~packing:(grid#attach (*~expand:`X*) ~left:0 ~top:i) () in let () = label#set_xalign 0. in let button = GButton.color_button - ~color:(Tags.color_of_string pref#get) - ~packing:(table#attach ~left:1 ~top:i) () + ~color:(Gdk.Color.color_parse pref#get) + ~packing:(grid#attach ~left:1 ~top:i) () in let _ = button#connect#color_set ~callback:begin fun () -> - pref#set (Tags.string_of_color button#color) + pref#set (Gdk.Color.color_to_string button#color) end in let reset _ = pref#reset (); - button#set_color Tags.(color_of_string pref#get) + button#set_color (Gdk.Color.color_parse pref#get) in let _ = reset_button#connect#clicked ~callback:reset in () @@ -724,6 +727,7 @@ let configure ?(apply=(fun () -> ())) parent = ("Background color", background_color); ("Background color of processed text", processed_color); ("Background color of text being processed", processing_color); + ("Background color of incompletely processed Qed", incompletely_processed_color); ("Background color of errors", error_color); ("Foreground color of errors", error_fg_color); ] in @@ -740,7 +744,7 @@ let configure ?(apply=(fun () -> ())) parent = ~packing:(box#pack ~expand:true) () in - let table = GPack.table + let grid = GPack.grid ~row_spacings:5 ~col_spacings:5 ~border_width:2 @@ -750,13 +754,13 @@ let configure ?(apply=(fun () -> ())) parent = let cb = ref [] in let iter text tag = let label = GMisc.label - ~text ~packing:(table#attach ~expand:`X ~left:0 ~top:!i) () + ~text ~packing:(grid#attach (*~expand:`X*) ~left:0 ~top:!i) () in let () = label#set_xalign 0. in let button = tag_button () in let callback () = tag#set button#tag in button#set_tag tag#get; - table#attach ~left:1 ~top:!i button#coerce; + grid#attach ~left:1 ~top:!i button#coerce; incr i; cb := callback :: !cb; in @@ -921,6 +925,7 @@ let configure ?(apply=(fun () -> ())) parent = else cmd_browse#get]) cmd_browse#get in +(* let automatic_tactics = strings ~f:automatic_tactics#set @@ -929,12 +934,14 @@ let configure ?(apply=(fun () -> ())) parent = automatic_tactics#get in +*) let contextual_menus_on_goal = pbool "Contextual menus on goal" contextual_menus_on_goal in let misc = [contextual_menus_on_goal;stop_before;reset_on_tab_switch; vertical_tabs;opposite_tabs] in +(* let add_user_query () = let input_string l v = match GToolbox.input_string ~title:l v with @@ -964,6 +971,7 @@ let configure ?(apply=(fun () -> ())) parent = user_queries#get in +*) (* ATTENTION !!!!! L'onglet Fonts doit etre en premier pour eviter un bug !!!! (shame on Benjamin) *) @@ -987,12 +995,14 @@ let configure ?(apply=(fun () -> ())) parent = Section("Externals", None, [cmd_coqtop;cmd_coqc;cmd_make;cmd_coqmakefile; cmd_coqdoc; cmd_print;cmd_editor;cmd_browse]); +(* Section("Tactics Wizard", None, [automatic_tactics]); +*) Section("Shortcuts", Some `PREFERENCES, [modifiers_valid; modifier_for_tactics; modifier_for_templates; modifier_for_display; modifier_for_navigation; - modifier_for_queries; user_queries]); + modifier_for_queries (*; user_queries *)]); Section("Misc", Some `ADD, misc)] in diff --git a/ide/preferences.mli b/ide/preferences.mli index cf2265781c..8745c2ae91 100644 --- a/ide/preferences.mli +++ b/ide/preferences.mli @@ -8,8 +8,8 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) -val lang_manager : GSourceView2.source_language_manager -val style_manager : GSourceView2.source_style_scheme_manager +val lang_manager : GSourceView3.source_language_manager +val style_manager : GSourceView3.source_style_scheme_manager type project_behavior = Ignore_args | Append_args | Subst_args type inputenc = Elocale | Eutf8 | Emanual of string @@ -108,6 +108,6 @@ val load_pref : unit -> unit val configure : ?apply:(unit -> unit) -> GWindow.window -> unit val stick : 'a preference -> - (#GObj.widget as 'obj) -> ('a -> unit) -> unit + < connect : #GObj.widget_signals ; .. > -> ('a -> unit) -> unit val use_default_doc_url : string diff --git a/ide/session.ml b/ide/session.ml index e2427a9b51..fd21515ca5 100644 --- a/ide/session.ml +++ b/ide/session.ml @@ -47,7 +47,7 @@ type session = { } let create_buffer () = - let buffer = GSourceView2.source_buffer + let buffer = GSourceView3.source_buffer ~tag_table:Tags.Script.table ~highlight_matching_brackets:true ?language:(lang_manager#language source_language#get) @@ -257,7 +257,7 @@ let make_table_widget ?sort cd cb = ~model:store ~packing:frame#add () in let () = data#set_headers_visible true in let () = data#set_headers_clickable true in - let refresh clr = data#misc#modify_base [`NORMAL, `NAME clr] in + let refresh clr = data#misc#modify_bg [`NORMAL, `NAME clr] in let _ = background_color#connect#changed ~callback:refresh in let _ = data#misc#connect#realize ~callback:(fun () -> refresh background_color#get) in let mk_rend c = GTree.cell_renderer_text [], ["text",c] in @@ -442,11 +442,11 @@ let build_layout (sn:session) = let eval_paned = GPack.paned `HORIZONTAL ~border_width:5 ~packing:(session_box#pack ~expand:true) () in let script_frame = GBin.frame ~shadow_type:`IN - ~packing:eval_paned#add1 () in + ~packing:(eval_paned#pack1 ~shrink:false) () in let script_scroll = GBin.scrolled_window ~vpolicy:`AUTOMATIC ~hpolicy:`AUTOMATIC ~packing:script_frame#add () in let state_paned = GPack.paned `VERTICAL - ~packing:eval_paned#add2 () in + ~packing:(eval_paned#pack2 ~shrink:false) () in (* Proof buffer. *) diff --git a/ide/tags.ml b/ide/tags.ml index 60195e8acb..e9dbcb9e67 100644 --- a/ide/tags.ml +++ b/ide/tags.ml @@ -24,7 +24,7 @@ struct let error_bg = make_tag table ~name:"error_bg" [] let to_process = make_tag table ~name:"to_process" [] let processed = make_tag table ~name:"processed" [] - let incomplete = make_tag table ~name:"incomplete" [`BACKGROUND_STIPPLE_SET true] + let incomplete = make_tag table ~name:"incomplete" [] let unjustified = make_tag table ~name:"unjustified" [`BACKGROUND "gold"] let tooltip = make_tag table ~name:"tooltip" [] (* debug:`BACKGROUND "blue" *) let ephemere = @@ -48,13 +48,3 @@ struct let warning = make_tag table ~name:"warning" [`FOREGROUND "orange"] let item = make_tag table ~name:"item" [`WEIGHT `BOLD] end - -let string_of_color clr = - let r = Gdk.Color.red clr in - let g = Gdk.Color.green clr in - let b = Gdk.Color.blue clr in - Printf.sprintf "#%04X%04X%04X" r g b - -let color_of_string s = - let colormap = Gdk.Color.get_system_colormap () in - Gdk.Color.alloc ~colormap (`NAME s) diff --git a/ide/tags.mli b/ide/tags.mli index 3194f87971..1df934fddf 100644 --- a/ide/tags.mli +++ b/ide/tags.mli @@ -41,6 +41,3 @@ sig val warning : GText.tag val item : GText.tag end - -val string_of_color : Gdk.color -> string -val color_of_string : string -> Gdk.color diff --git a/ide/wg_Command.ml b/ide/wg_Command.ml index 06281d6287..be400a5f2d 100644 --- a/ide/wg_Command.ml +++ b/ide/wg_Command.ml @@ -100,10 +100,10 @@ object(self) router#register_route route_id result; r_bin#add_with_viewport (result :> GObj.widget); views <- (frame#coerce, result, combo#entry) :: views; - let cb clr = result#misc#modify_base [`NORMAL, `NAME clr] in + let cb clr = result#misc#modify_bg [`NORMAL, `NAME clr] in let _ = background_color#connect#changed ~callback:cb in let _ = result#misc#connect#realize ~callback:(fun () -> cb background_color#get) in - let cb ft = result#misc#modify_font (Pango.Font.from_string ft) in + let cb ft = result#misc#modify_font (GPango.font_description_from_string ft) in stick text_font result cb; result#misc#set_can_focus true; (* false causes problems for selection *) let callback () = @@ -163,8 +163,8 @@ object(self) frame#visible method private refresh_color clr = - let clr = Tags.color_of_string clr in - let iter (_,view,_) = view#misc#modify_base [`NORMAL, `COLOR clr] in + let clr = Gdk.Color.color_parse clr in + let iter (_,view,_) = view#misc#modify_bg [`NORMAL, `COLOR clr] in List.iter iter views initializer diff --git a/ide/wg_Detachable.ml b/ide/wg_Detachable.ml index d753687077..755a42eadd 100644 --- a/ide/wg_Detachable.ml +++ b/ide/wg_Detachable.ml @@ -15,6 +15,9 @@ class type detachable_signals = method detached : callback:(GObj.widget -> unit) -> unit end +(* Cannot do a local warning in 4.05.0, fixme when we use a newer + OCaml to avoid the warning in the method itself. *) +[@@@ocaml.warning "-7"] class detachable (obj : ([> Gtk.box] as 'a) Gobject.obj) = object(self) diff --git a/ide/wg_Find.ml b/ide/wg_Find.ml index 7d2d7da570..fe079e8a9e 100644 --- a/ide/wg_Find.ml +++ b/ide/wg_Find.ml @@ -14,10 +14,10 @@ class finder name (view : GText.view) = let widget = Wg_Detachable.detachable ~title:(Printf.sprintf "Find & Replace (%s)" name) () in - let replace_box = GPack.table ~columns:4 ~rows:2 ~homogeneous:false + let replace_box = GPack.grid (* ~columns:4 ~rows:2 *) ~col_homogeneous:false ~row_homogeneous:false ~packing:widget#add () in let hb = GPack.hbox ~packing:(replace_box#attach - ~left:1 ~top:0 ~expand:`X ~fill:`X) () in + ~left:1 ~top:0 (*~expand:`X ~fill:`X*)) () in let use_regex = GButton.check_button ~label:"Regular expression" ~packing:(hb#pack ~expand:false ~fill:true ~padding:3) () in @@ -26,25 +26,25 @@ class finder name (view : GText.view) = ~packing:(hb#pack ~expand:false ~fill:true ~padding:3) () in let _ = GMisc.label ~text:"Find:" ~xalign:1.0 ~packing:(replace_box#attach - ~xpadding:3 ~ypadding:3 ~left:0 ~top:1 ~fill:`X) () in + (*~xpadding:3 ~ypadding:3*) ~left:0 ~top:1 (*~fill:`X*)) () in let _ = GMisc.label ~text:"Replace:" ~xalign:1.0 ~packing:(replace_box#attach - ~xpadding:3 ~ypadding:3 ~left:0 ~top:2 ~fill:`X) () in + (* ~xpadding:3 ~ypadding:3*) ~left:0 ~top:2 (*~fill:`X*)) () in let find_entry = GEdit.entry ~editable:true ~packing:(replace_box#attach - ~xpadding:3 ~ypadding:3 ~left:1 ~top:1 ~expand:`X ~fill:`X) () in + (*~xpadding:3 ~ypadding:3*) ~left:1 ~top:1 (*~expand:`X ~fill:`X*)) () in let replace_entry = GEdit.entry ~editable:true ~packing:(replace_box#attach - ~xpadding:3 ~ypadding:3 ~left:1 ~top:2 ~expand:`X ~fill:`X) () in + (*~xpadding:3 ~ypadding:3*) ~left:1 ~top:2 (*~expand:`X ~fill:`X*)) () in let next_button = GButton.button ~label:"_Next" ~use_mnemonic:true - ~packing:(replace_box#attach ~xpadding:3 ~ypadding:3 ~left:2 ~top:1) () in + ~packing:(replace_box#attach (*~xpadding:3 ~ypadding:3*) ~left:2 ~top:1) () in let previous_button = GButton.button ~label:"_Previous" ~use_mnemonic:true - ~packing:(replace_box#attach ~xpadding:3 ~ypadding:3 ~left:3 ~top:1) () in + ~packing:(replace_box#attach (*~xpadding:3 ~ypadding:3*) ~left:3 ~top:1) () in let replace_button = GButton.button ~label:"_Replace" ~use_mnemonic:true - ~packing:(replace_box#attach ~xpadding:3 ~ypadding:3 ~left:2 ~top:2) () in + ~packing:(replace_box#attach (*~xpadding:3 ~ypadding:3*) ~left:2 ~top:2) () in let replace_all_button = GButton.button ~label:"Replace _All" ~use_mnemonic:true - ~packing:(replace_box#attach ~xpadding:3 ~ypadding:3 ~left:3 ~top:2) () in + ~packing:(replace_box#attach (*~xpadding:3 ~ypadding:3*) ~left:3 ~top:2) () in object (self) val mutable last_found = None @@ -135,13 +135,13 @@ class finder name (view : GText.view) = view#buffer#end_user_action () method private set_not_found () = - find_entry#misc#modify_base [`NORMAL, `NAME "#F7E6E6"]; + find_entry#misc#modify_bg [`NORMAL, `NAME "#F7E6E6"]; method private set_found () = - find_entry#misc#modify_base [`NORMAL, `NAME "#BAF9CE"] + find_entry#misc#modify_bg [`NORMAL, `NAME "#BAF9CE"] method private set_normal () = - find_entry#misc#modify_base [`NORMAL, `NAME "white"] + find_entry#misc#modify_bg [`NORMAL, `NAME "white"] method private find_from backward ?(wrapped=false) (starti : GText.iter) = let found = diff --git a/ide/wg_MessageView.ml b/ide/wg_MessageView.ml index 6b09b344b5..7943b099fc 100644 --- a/ide/wg_MessageView.ml +++ b/ide/wg_MessageView.ml @@ -42,7 +42,7 @@ class type message_view = end let message_view () : message_view = - let buffer = GSourceView2.source_buffer + let buffer = GSourceView3.source_buffer ~highlight_matching_brackets:true ~tag_table:Tags.Message.table () in @@ -50,7 +50,7 @@ let message_view () : message_view = let box = GPack.vbox () in let scroll = GBin.scrolled_window ~vpolicy:`AUTOMATIC ~hpolicy:`AUTOMATIC ~packing:(box#pack ~expand:true) () in - let view = GSourceView2.source_view + let view = GSourceView3.source_view ~source_buffer:buffer ~packing:scroll#add ~editable:false ~cursor_visible:false ~wrap_mode:`WORD () in @@ -59,10 +59,10 @@ let message_view () : message_view = let _ = buffer#add_selection_clipboard default_clipboard in let () = view#set_left_margin 2 in view#misc#show (); - let cb clr = view#misc#modify_base [`NORMAL, `NAME clr] in + let cb clr = view#misc#modify_bg [`NORMAL, `NAME clr] in let _ = background_color#connect#changed ~callback:cb in let _ = view#misc#connect#realize ~callback:(fun () -> cb background_color#get) in - let cb ft = view#misc#modify_font (Pango.Font.from_string ft) in + let cb ft = view#misc#modify_font (GPango.font_description_from_string ft) in stick text_font view cb; (* Inserts at point, advances the mark *) diff --git a/ide/wg_Notebook.mli b/ide/wg_Notebook.mli index 85ecdf6cdd..9447b21c0b 100644 --- a/ide/wg_Notebook.mli +++ b/ide/wg_Notebook.mli @@ -28,11 +28,10 @@ val create : ('a -> GObj.widget option * GObj.widget option * GObj.widget) -> ('a -> unit) -> ?enable_popup:bool -> - ?homogeneous_tabs:bool -> + ?group_name:string -> ?scrollable:bool -> ?show_border:bool -> ?show_tabs:bool -> - ?tab_border:int -> ?tab_pos:Gtk.Tags.position -> ?border_width:int -> ?width:int -> diff --git a/ide/wg_ProofView.ml b/ide/wg_ProofView.ml index 9be562d3ed..596df227b7 100644 --- a/ide/wg_ProofView.ml +++ b/ide/wg_ProofView.ml @@ -193,21 +193,21 @@ let display mode (view : #GText.view_skel) goals hints evars = let proof_view () = - let buffer = GSourceView2.source_buffer + let buffer = GSourceView3.source_buffer ~highlight_matching_brackets:true ~tag_table:Tags.Proof.table () in let text_buffer = new GText.buffer buffer#as_buffer in - let view = GSourceView2.source_view + let view = GSourceView3.source_view ~source_buffer:buffer ~editable:false ~wrap_mode:`WORD () in let () = Gtk_parsing.fix_double_click view in let default_clipboard = GData.clipboard Gdk.Atom.primary in let _ = buffer#add_selection_clipboard default_clipboard in - let cb clr = view#misc#modify_base [`NORMAL, `NAME clr] in + let cb clr = view#misc#modify_bg [`NORMAL, `NAME clr] in let _ = background_color#connect#changed ~callback:cb in let _ = view#misc#connect#realize ~callback:(fun () -> cb background_color#get) in - let cb ft = view#misc#modify_font (Pango.Font.from_string ft) in + let cb ft = view#misc#modify_font (GPango.font_description_from_string ft) in stick text_font view cb; let pf = object diff --git a/ide/wg_ScriptView.ml b/ide/wg_ScriptView.ml index 5e26c50797..e95176bf4d 100644 --- a/ide/wg_ScriptView.ml +++ b/ide/wg_ScriptView.ml @@ -284,12 +284,12 @@ end class script_view (tv : source_view) (ct : Coq.coqtop) = -let view = new GSourceView2.source_view (Gobject.unsafe_cast tv) in +let view = new GSourceView3.source_view (Gobject.unsafe_cast tv) in let completion = new Wg_Completion.complete_model ct view#buffer in let popup = new Wg_Completion.complete_popup completion (view :> GText.view) in object (self) - inherit GSourceView2.source_view (Gobject.unsafe_cast tv) + inherit GSourceView3.source_view (Gobject.unsafe_cast tv) val undo_manager = new undo_manager view#buffer @@ -461,7 +461,7 @@ object (self) in let _ = GtkSignal.connect ~sgn:move_line_signal ~callback obj in (* Plug on preferences *) - let cb clr = self#misc#modify_base [`NORMAL, `NAME clr] in + let cb clr = self#misc#modify_bg [`NORMAL, `NAME clr] in let _ = background_color#connect#changed ~callback:cb in let _ = self#misc#connect#realize ~callback:(fun () -> cb background_color#get) in @@ -484,24 +484,24 @@ object (self) stick tab_length self self#set_tab_width; stick auto_complete self self#set_auto_complete; - let cb ft = self#misc#modify_font (Pango.Font.from_string ft) in + let cb ft = self#misc#modify_font (GPango.font_description_from_string ft) in stick text_font self cb; () end -let script_view ct ?(source_buffer:GSourceView2.source_buffer option) ?draw_spaces = - GtkSourceView2.SourceView.make_params [] ~cont:( +let script_view ct ?(source_buffer:GSourceView3.source_buffer option) ?draw_spaces = + GtkSourceView3.SourceView.make_params [] ~cont:( GtkText.View.make_params ~cont:( GContainer.pack_container ~create: (fun pl -> let w = match source_buffer with - | None -> GtkSourceView2.SourceView.new_ () - | Some buf -> GtkSourceView2.SourceView.new_with_buffer + | None -> GtkSourceView3.SourceView.new_ () + | Some buf -> GtkSourceView3.SourceView.new_with_buffer (Gobject.try_cast buf#as_buffer "GtkSourceBuffer") in let w = Gobject.unsafe_cast w in Gobject.set_params (Gobject.try_cast w "GtkSourceView") pl; - Gaux.may ~f:(GtkSourceView2.SourceView.set_draw_spaces w) draw_spaces; + Gaux.may ~f:(GtkSourceView3.SourceView.set_draw_spaces w) draw_spaces; ((new script_view w ct) : script_view)))) diff --git a/ide/wg_ScriptView.mli b/ide/wg_ScriptView.mli index be6510dbe2..ef7e92ff38 100644 --- a/ide/wg_ScriptView.mli +++ b/ide/wg_ScriptView.mli @@ -14,7 +14,7 @@ type source_view = [ Gtk.text_view | `sourceview ] Gtk.obj class script_view : source_view -> Coq.coqtop -> object - inherit GSourceView2.source_view + inherit GSourceView3.source_view method undo : unit -> unit method redo : unit -> unit method clear_undo : unit -> unit @@ -31,8 +31,8 @@ object end val script_view : Coq.coqtop -> - ?source_buffer:GSourceView2.source_buffer -> - ?draw_spaces:SourceView2Enums.source_draw_spaces_flags list -> + ?source_buffer:GSourceView3.source_buffer -> + ?draw_spaces:SourceView3Enums.source_draw_spaces_flags list -> ?auto_indent:bool -> ?highlight_current_line:bool -> ?indent_on_tab:bool -> @@ -42,7 +42,7 @@ val script_view : Coq.coqtop -> ?show_line_marks:bool -> ?show_line_numbers:bool -> ?show_right_margin:bool -> - ?smart_home_end:SourceView2Enums.source_smart_home_end_type -> + ?smart_home_end:SourceView3Enums.source_smart_home_end_type -> ?tab_width:int -> ?editable:bool -> ?cursor_visible:bool -> diff --git a/ide/wg_Segment.ml b/ide/wg_Segment.ml index 3b2572f9d2..2e5de64254 100644 --- a/ide/wg_Segment.ml +++ b/ide/wg_Segment.ml @@ -8,8 +8,10 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) +(* open Util open Preferences +*) type color = GDraw.color @@ -22,6 +24,7 @@ object method fold : 'a. ('a -> color -> 'a) -> 'a -> 'a end +(* let i2f = float_of_int let f2i = int_of_float @@ -32,14 +35,14 @@ let color_eq (c1 : GDraw.color) (c2 : GDraw.color) = match c1, c2 with | `RGB (r1, g1, b1), `RGB (r2, g2, b2) -> r1 = r2 && g1 = g2 && b1 = b2 | `WHITE, `WHITE -> true | _ -> false - +*) class type segment_signals = object inherit GObj.misc_signals inherit GUtil.add_ml_signals method clicked : callback:(int -> unit) -> GtkSignal.id end - +(* class segment_signals_impl obj (clicked : 'a GUtil.signal) : segment_signals = object val after = false @@ -47,11 +50,14 @@ object inherit GUtil.add_ml_signals obj [clicked#disconnect] method clicked = clicked#connect ~after end +*) class segment () = let box = GBin.frame () in +(* let eventbox = GBin.event_box ~packing:box#add () in let draw = GMisc.image ~packing:eventbox#add () in +*) object (self) inherit GObj.widget box#as_widget @@ -60,11 +66,13 @@ object (self) val mutable height = 20 val mutable model : model option = None val mutable default : color = `WHITE +(* val mutable pixmap : GDraw.pixmap = GDraw.pixmap ~width:1 ~height:1 () +*) val clicked = new GUtil.signal () val mutable need_refresh = false val refresh_timer = Ideutils.mktimer () - +(* initializer box#misc#set_size_request ~height (); let cb rect = @@ -95,17 +103,18 @@ object (self) draw#set_pixmap pixmap; refresh_timer.Ideutils.run ~ms:300 ~callback:(fun () -> if need_refresh then self#refresh (); true) - +*) method set_model md = model <- Some md; let changed_cb = function | `INSERT | `REMOVE -> if self#misc#visible then need_refresh <- true | `SET (i, color) -> - if self#misc#visible then self#fill_range color i (i + 1) + () +(* if self#misc#visible then self#fill_range color i (i + 1)*) in md#changed ~callback:changed_cb - +(* method private fill_range color i j = match model with | None -> () | Some md -> @@ -150,5 +159,6 @@ object (self) method connect = new segment_signals_impl box#as_widget clicked +*) end diff --git a/ide/wg_Segment.mli b/ide/wg_Segment.mli index 07f545fee7..84d487f35f 100644 --- a/ide/wg_Segment.mli +++ b/ide/wg_Segment.mli @@ -31,7 +31,9 @@ class segment : unit -> inherit GObj.widget val obj : Gtk.widget Gtk.obj method set_model : model -> unit +(* method connect : segment_signals method default_color : color method set_default_color : color -> unit +*) end diff --git a/interp/constrextern.ml b/interp/constrextern.ml index 8e49800982..c2afa097bb 100644 --- a/interp/constrextern.ml +++ b/interp/constrextern.ml @@ -755,6 +755,7 @@ let extended_glob_local_binder_of_decl ?loc u = DAst.make ?loc (extended_glob_lo (* mapping glob_constr to constr_expr *) let extern_glob_sort = function + | GSProp -> GSProp | GProp -> GProp | GSet -> GSet | GType _ as s when !print_universes -> s @@ -1313,7 +1314,10 @@ let rec glob_of_pat avoid env sigma pat = DAst.make @@ match pat with Array.map (fun (bl,_,_) -> bl) v, Array.map (fun (_,_,ty) -> ty) v, Array.map (fun (_,bd,_) -> bd) v) - | PSort s -> GSort s + | PSort Sorts.InSProp -> GSort GSProp + | PSort Sorts.InProp -> GSort GProp + | PSort Sorts.InSet -> GSort GSet + | PSort Sorts.InType -> GSort (GType []) | PInt i -> GInt i let extern_constr_pattern env sigma pat = diff --git a/interp/constrintern.ml b/interp/constrintern.ml index 7f1dc70d95..5ede9d6a99 100644 --- a/interp/constrintern.ml +++ b/interp/constrintern.ml @@ -16,6 +16,7 @@ open Names open Nameops open Namegen open Constr +open Context open Libnames open Globnames open Impargs @@ -1020,6 +1021,7 @@ let sort_info_of_level_info (info: level_info) : (Libnames.qualid * int) option let glob_sort_of_level (level: glob_level) : glob_sort = match level with + | GSProp -> GSProp | GProp -> GProp | GSet -> GSet | GType info -> GType [sort_info_of_level_info info] @@ -2182,7 +2184,7 @@ let internalize globalenv env pattern_mode (_, ntnvars as lvar) c = (add_name match_acc CAst.(make ?loc x)) (CAst.make ?loc x::var_acc) | _ -> let fresh = - Namegen.next_name_away_with_default_using_types "iV" cano_name forbidden_names (EConstr.of_constr ty) in + Namegen.next_name_away_with_default_using_types "iV" cano_name.binder_name forbidden_names (EConstr.of_constr ty) in canonize_args t tt (Id.Set.add fresh forbidden_names) ((fresh,c)::match_acc) ((CAst.make ?loc:(cases_pattern_loc c) @@ Name fresh)::var_acc) end @@ -2431,9 +2433,10 @@ let interp_glob_context_evars ?(program_mode=false) env sigma k bl = in let sigma, t = understand_tcc ~flags env sigma ~expected_type:IsType t' in match b with - None -> - let d = LocalAssum (na,t) in - let impls = + None -> + let r = Retyping.relevance_of_type env sigma t in + let d = LocalAssum (make_annot na r,t) in + let impls = if k == Implicit then let na = match na with Name n -> Some n | Anonymous -> None in (ExplByPos (n, na), (true, true, true)) :: impls @@ -2442,7 +2445,8 @@ let interp_glob_context_evars ?(program_mode=false) env sigma k bl = (push_rel d env, sigma, d::params, succ n, impls) | Some b -> let sigma, c = understand_tcc ~flags env sigma ~expected_type:(OfType t) b in - let d = LocalDef (na, c, t) in + let r = Retyping.relevance_of_type env sigma t in + let d = LocalDef (make_annot na r, c, t) in (push_rel d env, sigma, d::params, n, impls)) (env,sigma,[],k+1,[]) (List.rev bl) in sigma, ((env, par), impls) diff --git a/interp/declare.ml b/interp/declare.ml index 4371b15c82..08a6ac5f7b 100644 --- a/interp/declare.ml +++ b/interp/declare.ml @@ -370,7 +370,7 @@ let declare_projections univs mind = let mib = Environ.lookup_mind mind env in match mib.mind_record with | PrimRecord info -> - let iter_ind i (_, labs, _) = + let iter_ind i (_, labs, _, _) = let ind = (mind, i) in let projs = Inductiveops.compute_projections env ind in Array.iter2_i (declare_one_projection univs ind ~proj_npars:mib.mind_nparams) labs projs diff --git a/interp/discharge.ml b/interp/discharge.ml index 353b0f6057..1efd13adb1 100644 --- a/interp/discharge.ml +++ b/interp/discharge.ml @@ -69,7 +69,7 @@ let refresh_polymorphic_type_of_inductive (_,mip) = | RegularArity s -> s.mind_user_arity, false | TemplateArity ar -> let ctx = List.rev mip.mind_arity_ctxt in - mkArity (List.rev ctx, Type ar.template_level), true + mkArity (List.rev ctx, Sorts.sort_of_univ ar.template_level), true let process_inductive info modlist mib = let section_decls = Lib.named_of_variable_context info.Lib.abstr_ctx in @@ -103,7 +103,7 @@ let process_inductive info modlist mib = let (params',inds') = abstract_inductive section_decls' nparamdecls inds in let record = match mib.mind_record with | PrimRecord info -> - Some (Some (Array.map pi1 info)) + Some (Some (Array.map (fun (x,_,_,_) -> x) info)) | FakeRecord -> Some None | NotRecord -> None in diff --git a/interp/impargs.ml b/interp/impargs.ml index 0f9bff7f1d..d83a0ce918 100644 --- a/interp/impargs.ml +++ b/interp/impargs.ml @@ -243,7 +243,7 @@ let compute_implicits_names_gen all env sigma t = let t = whd_all env sigma t in match kind sigma t with | Prod (na,a,b) -> - let na',avoid' = find_displayed_name_in sigma all avoid na (names,b) in + let na',avoid' = find_displayed_name_in sigma all avoid na.Context.binder_name (names,b) in aux (push_rel (LocalAssum (na,a)) env) avoid' (na'::names) b | _ -> List.rev names in aux env Id.Set.empty [] t @@ -445,7 +445,8 @@ let compute_mib_implicits flags kn = (fun i mip -> (* No need to care about constraints here *) let ty, _ = Typeops.type_of_global_in_context env (IndRef (kn,i)) in - Context.Rel.Declaration.LocalAssum (Name mip.mind_typename, ty)) + let r = Inductive.relevance_of_inductive env (kn,i) in + Context.Rel.Declaration.LocalAssum (Context.make_annot (Name mip.mind_typename) r, ty)) mib.mind_packets) in let env_ar = Environ.push_rel_context ar env in let imps_one_inductive i mip = diff --git a/interp/implicit_quantifiers.ml b/interp/implicit_quantifiers.ml index 4f3037b1fc..854651e7b7 100644 --- a/interp/implicit_quantifiers.ml +++ b/interp/implicit_quantifiers.ml @@ -10,6 +10,7 @@ (*i*) open Names +open Context open Decl_kinds open CErrors open Util @@ -175,10 +176,10 @@ let combine_params avoid fn applied needed = match app, need with [], [] -> List.rev ids, avoid - | app, (_, (LocalAssum (Name id, _) | LocalDef (Name id, _, _))) :: need when Id.List.mem_assoc id named -> + | app, (_, (LocalAssum ({binder_name=Name id}, _) | LocalDef ({binder_name=Name id}, _, _))) :: need when Id.List.mem_assoc id named -> aux (Id.List.assoc id named :: ids) avoid app need - | (x, None) :: app, (None, (LocalAssum (Name id, _) | LocalDef (Name id, _, _))) :: need -> + | (x, None) :: app, (None, (LocalAssum ({binder_name=Name id}, _) | LocalDef ({binder_name=Name id}, _, _))) :: need -> aux (x :: ids) avoid app need | _, (Some cl, _ as d) :: need -> diff --git a/kernel/cClosure.ml b/kernel/cClosure.ml index 5fec55fea1..412637c4b6 100644 --- a/kernel/cClosure.ml +++ b/kernel/cClosure.ml @@ -29,6 +29,7 @@ open Pp open Names open Constr open Declarations +open Context open Environ open Vars open Esubst @@ -98,7 +99,7 @@ module type RedFlagsSig = sig val red_projection : reds -> Projection.t -> bool end -module RedFlags = (struct +module RedFlags : RedFlagsSig = struct (* [r_const=(true,cl)] means all constants but those in [cl] *) (* [r_const=(false,cl)] means only those in [cl] *) @@ -195,7 +196,7 @@ module RedFlags = (struct if Projection.unfolded p then true else red_set red (fCONST (Projection.constant p)) -end : RedFlagsSig) +end open RedFlags @@ -282,12 +283,63 @@ let assoc_defined id env = match Environ.lookup_named id env with type red_state = Norm | Cstr | Whnf | Red let neutr = function - | (Whnf|Norm) -> Whnf - | (Red|Cstr) -> Red + | Whnf|Norm -> Whnf + | Red|Cstr -> Red + +type optrel = Unknown | KnownR | KnownI + +let opt_of_rel = function + | Sorts.Relevant -> KnownR + | Sorts.Irrelevant -> KnownI + +module Mark : sig + + type t + + val mark : red_state -> optrel -> t + val relevance : t -> optrel + val red_state : t -> red_state + + val neutr : t -> t + + val set_norm : t -> t + +end = struct + type t = int + + let[@inline] of_state = function + | Norm -> 0b00 | Cstr -> 0b01 | Whnf -> 0b10 | Red -> 0b11 + + let[@inline] of_relevance = function + | Unknown -> 0 + | KnownR -> 0b01 + | KnownI -> 0b10 + + let[@inline] mark state relevance = (of_state state) * 4 + (of_relevance relevance) + + let[@inline] relevance x = match x land 0b11 with + | 0b00 -> Unknown + | 0b01 -> KnownR + | 0b10 -> KnownI + | _ -> assert false + + let[@inline] red_state x = match x land 0b1100 with + | 0b0000 -> Norm + | 0b0100 -> Cstr + | 0b1000 -> Whnf + | 0b1100 -> Red + | _ -> assert false + + let[@inline] neutr x = x lor 0b1000 (* Whnf|Norm -> Whnf | Red|Cstr -> Red *) + + let[@inline] set_norm x = x land 0b0011 +end +let mark = Mark.mark type fconstr = { - mutable norm: red_state; - mutable term: fterm } + mutable mark : Mark.t; + mutable term: fterm; +} and fterm = | FRel of int @@ -300,9 +352,9 @@ and fterm = | FFix of fixpoint * fconstr subs | FCoFix of cofixpoint * fconstr subs | FCaseT of case_info * constr * fconstr * constr array * fconstr subs (* predicate and branches are closures *) - | FLambda of int * (Name.t * constr) list * constr * fconstr subs - | FProd of Name.t * fconstr * constr * fconstr subs - | FLetIn of Name.t * fconstr * fconstr * constr * fconstr subs + | FLambda of int * (Name.t Context.binder_annot * constr) list * constr * fconstr subs + | FProd of Name.t Context.binder_annot * fconstr * constr * fconstr subs + | FLetIn of Name.t Context.binder_annot * fconstr * fconstr * constr * fconstr subs | FEvar of existential * fconstr subs | FInt of Uint63.t | FLIFT of int * fconstr @@ -310,20 +362,20 @@ and fterm = | FLOCKED let fterm_of v = v.term -let set_norm v = v.norm <- Norm -let is_val v = match v.norm with Norm -> true | Cstr | Whnf | Red -> false +let set_norm v = v.mark <- Mark.set_norm v.mark +let is_val v = match Mark.red_state v.mark with Norm -> true | Cstr | Whnf | Red -> false -let mk_atom c = {norm=Norm;term=FAtom c} -let mk_red f = {norm=Red;term=f} +let mk_atom c = {mark=mark Norm Unknown;term=FAtom c} +let mk_red f = {mark=mark Red Unknown;term=f} (* Could issue a warning if no is still Red, pointing out that we loose sharing. *) -let update ~share v1 no t = +let update ~share v1 mark t = if share then - (v1.norm <- no; + (v1.mark <- mark; v1.term <- t; v1) - else {norm=no;term=t} + else {mark;term=t;} (** Reduction cache *) @@ -383,16 +435,19 @@ let rec stack_args_size = function lft_fconstr always create a new cell, while lift_fconstr avoids it when the lift is 0. *) let rec lft_fconstr n ft = + let r = Mark.relevance ft.mark in match ft.term with | (FInd _|FConstruct _|FFlex(ConstKey _|VarKey _)|FInt _) -> ft - | FRel i -> {norm=Norm;term=FRel(i+n)} - | FLambda(k,tys,f,e) -> {norm=Cstr; term=FLambda(k,tys,f,subs_shft(n,e))} - | FFix(fx,e) -> {norm=Cstr; term=FFix(fx,subs_shft(n,e))} - | FCoFix(cfx,e) -> {norm=Cstr; term=FCoFix(cfx,subs_shft(n,e))} + | FRel i -> {mark=mark Norm r;term=FRel(i+n)} + | FLambda(k,tys,f,e) -> {mark=mark Cstr r; term=FLambda(k,tys,f,subs_shft(n,e))} + | FFix(fx,e) -> + {mark=mark Cstr r; term=FFix(fx,subs_shft(n,e))} + | FCoFix(cfx,e) -> + {mark=mark Cstr r; term=FCoFix(cfx,subs_shft(n,e))} | FLIFT(k,m) -> lft_fconstr (n+k) m | FLOCKED -> assert false | FFlex (RelKey _) | FAtom _ | FApp _ | FProj _ | FCaseT _ | FProd _ - | FLetIn _ | FEvar _ | FCLOS _ -> {norm=ft.norm; term=FLIFT(n,ft)} + | FLetIn _ | FEvar _ | FCLOS _ -> {mark=ft.mark; term=FLIFT(n,ft)} let lift_fconstr k f = if Int.equal k 0 then f else lft_fconstr k f let lift_fconstr_vect k v = @@ -401,9 +456,9 @@ let lift_fconstr_vect k v = let clos_rel e i = match expand_rel i e with | Inl(n,mt) -> lift_fconstr n mt - | Inr(k,None) -> {norm=Norm; term= FRel k} + | Inr(k,None) -> {mark=mark Norm Unknown; term= FRel k} | Inr(k,Some p) -> - lift_fconstr (k-p) {norm=Red;term=FFlex(RelKey p)} + lift_fconstr (k-p) {mark=mark Red Unknown;term=FFlex(RelKey p)} (* since the head may be reducible, we might introduce lifts of 0 *) let compact_stack head stk = @@ -414,7 +469,7 @@ let compact_stack head stk = lost by the update operation *) let h' = lft_fconstr depth head in (** The stack contains [Zupdate] marks only if in sharing mode *) - let _ = update ~share:true m h'.norm h'.term in + let _ = update ~share:true m h'.mark h'.term in strip_rec depth s | ((ZcaseT _ | Zproj _ | Zfix _ | Zapp _ | Zprimitive _) :: _ | []) as stk -> zshift depth stk in @@ -423,7 +478,7 @@ let compact_stack head stk = (* Put an update mark in the stack, only if needed *) let zupdate info m s = let share = info.i_cache.i_share in - if share && begin match m.norm with Red -> true | Norm | Whnf | Cstr -> false end + if share && begin match Mark.red_state m.mark with Red -> true | Norm | Whnf | Cstr -> false end then let s' = compact_stack m s in let _ = m.term <- FLOCKED in @@ -436,25 +491,25 @@ let mk_lambda env t = let destFLambda clos_fun t = match [@ocaml.warning "-4"] t.term with - | FLambda(_,[(na,ty)],b,e) -> (na,clos_fun e ty,clos_fun (subs_lift e) b) - | FLambda(n,(na,ty)::tys,b,e) -> - (na,clos_fun e ty,{norm=Cstr;term=FLambda(n-1,tys,b,subs_lift e)}) - | _ -> assert false -(* t must be a FLambda and binding list cannot be empty *) + FLambda(_,[(na,ty)],b,e) -> (na,clos_fun e ty,clos_fun (subs_lift e) b) + | FLambda(n,(na,ty)::tys,b,e) -> + (na,clos_fun e ty,{mark=t.mark;term=FLambda(n-1,tys,b,subs_lift e)}) + | _ -> assert false + (* t must be a FLambda and binding list cannot be empty *) (* Optimization: do not enclose variables in a closure. Makes variable access much faster *) let mk_clos e t = match kind t with | Rel i -> clos_rel e i - | Var x -> { norm = Red; term = FFlex (VarKey x) } - | Const c -> { norm = Red; term = FFlex (ConstKey c) } - | Meta _ | Sort _ -> { norm = Norm; term = FAtom t } - | Ind kn -> { norm = Norm; term = FInd kn } - | Construct kn -> { norm = Cstr; term = FConstruct kn } - | Int i -> {norm = Cstr; term = FInt i} + | Var x -> {mark = mark Red Unknown; term = FFlex (VarKey x) } + | Const c -> {mark = mark Red Unknown; term = FFlex (ConstKey c) } + | Meta _ | Sort _ -> {mark = mark Norm KnownR; term = FAtom t } + | Ind kn -> {mark = mark Norm KnownR; term = FInd kn } + | Construct kn -> {mark = mark Cstr Unknown; term = FConstruct kn } + | Int i -> {mark = mark Cstr Unknown; term = FInt i} | (CoFix _|Lambda _|Fix _|Prod _|Evar _|App _|Case _|Cast _|LetIn _|Proj _) -> - {norm = Red; term = FCLOS(t,e)} + {mark = mark Red Unknown; term = FCLOS(t,e)} let inject c = mk_clos (subs_id 0) c @@ -606,23 +661,25 @@ let rec fstrong unfreeze_fun lfts v = let rec zip m stk = match stk with | [] -> m - | Zapp args :: s -> zip {norm=neutr m.norm; term=FApp(m, args)} s + | Zapp args :: s -> zip {mark=Mark.neutr m.mark; term=FApp(m, args)} s | ZcaseT(ci,p,br,e)::s -> let t = FCaseT(ci, p, m, br, e) in - zip {norm=neutr m.norm; term=t} s + let mark = mark (neutr (Mark.red_state m.mark)) Unknown in + zip {mark; term=t} s | Zproj p :: s -> - zip {norm=neutr m.norm; term=FProj(Projection.make p true,m)} s + let mark = mark (neutr (Mark.red_state m.mark)) Unknown in + zip {mark; term=FProj(Projection.make p true,m)} s | Zfix(fx,par)::s -> zip fx (par @ append_stack [|m|] s) | Zshift(n)::s -> zip (lift_fconstr n m) s | Zupdate(rf)::s -> (** The stack contains [Zupdate] marks only if in sharing mode *) - zip (update ~share:true rf m.norm m.term) s + zip (update ~share:true rf m.mark m.term) s | Zprimitive(_op,c,rargs,kargs)::s -> let args = List.rev_append rargs (m::List.map snd kargs) in - let f = {norm = Red;term = FFlex (ConstKey c)} in - zip {norm=neutr m.norm; term = FApp (f, Array.of_list args)} s + let f = {mark = mark Red Unknown;term = FFlex (ConstKey c)} in + zip {mark=mark (neutr (Mark.red_state m.mark)) KnownR; term = FApp (f, Array.of_list args)} s let fapp_stack (m,stk) = zip m stk @@ -640,21 +697,21 @@ let strip_update_shift_app_red head stk = strip_rec (e::rstk) (lift_fconstr k h) (depth+k) s | (Zapp args :: s) -> strip_rec (Zapp args :: rstk) - {norm=h.norm;term=FApp(h,args)} depth s + {mark=h.mark;term=FApp(h,args)} depth s | Zupdate(m)::s -> (** The stack contains [Zupdate] marks only if in sharing mode *) - strip_rec rstk (update ~share:true m h.norm h.term) depth s + strip_rec rstk (update ~share:true m h.mark h.term) depth s | ((ZcaseT _ | Zproj _ | Zfix _ | Zprimitive _) :: _ | []) as stk -> (depth,List.rev rstk, stk) in strip_rec [] head 0 stk let strip_update_shift_app head stack = - assert (match head.norm with Red -> false | Norm | Cstr | Whnf -> true); + assert (match Mark.red_state head.mark with Red -> false | Norm | Cstr | Whnf -> true); strip_update_shift_app_red head stack let get_nth_arg head n stk = - assert (match head.norm with Red -> false | Norm | Cstr | Whnf -> true); + assert (match Mark.red_state head.mark with Red -> false | Norm | Cstr | Whnf -> true); let rec strip_rec rstk h n = function | Zshift(k) as e :: s -> strip_rec (e::rstk) (lift_fconstr k h) n s @@ -662,7 +719,7 @@ let get_nth_arg head n stk = let q = Array.length args in if n >= q then - strip_rec (Zapp args::rstk) {norm=h.norm;term=FApp(h,args)} (n-q) s' + strip_rec (Zapp args::rstk) {mark=h.mark;term=FApp(h,args)} (n-q) s' else let bef = Array.sub args 0 n in let aft = Array.sub args (n+1) (q-n-1) in @@ -671,7 +728,7 @@ let get_nth_arg head n stk = (Some (stk', args.(n)), append_stack aft s') | Zupdate(m)::s -> (** The stack contains [Zupdate] mark only if in sharing mode *) - strip_rec rstk (update ~share:true m h.norm h.term) n s + strip_rec rstk (update ~share:true m h.mark h.term) n s | ((ZcaseT _ | Zproj _ | Zfix _ | Zprimitive _) :: _ | []) as s -> (None, List.rev rstk @ s) in strip_rec [] head n stk @@ -680,7 +737,7 @@ let get_nth_arg head n stk = let rec get_args n tys f e = function | Zupdate r :: s -> (** The stack contains [Zupdate] mark only if in sharing mode *) - let _hd = update ~share:true r Cstr (FLambda(n,tys,f,e)) in + let _hd = update ~share:true r (mark Cstr (Mark.relevance r.mark)) (FLambda(n,tys,f,e)) in get_args n tys f e s | Zshift k :: s -> get_args n tys f (subs_shft (k,e)) s @@ -695,7 +752,7 @@ let rec get_args n tys f e = function let etys = List.skipn na tys in get_args (n-na) etys f (subs_cons(l,e)) s | ((ZcaseT _ | Zproj _ | Zfix _ | Zprimitive _) :: _ | []) as stk -> - (Inr {norm=Cstr;term=FLambda(n,tys,f,e)}, stk) + (Inr {mark=mark Cstr Unknown;term=FLambda(n,tys,f,e)}, stk) (* Eta expansion: add a reference to implicit surrounding lambda at end of stack *) let rec eta_expand_stack = function @@ -703,7 +760,7 @@ let rec eta_expand_stack = function | Zshift _ | Zupdate _ | Zprimitive _ as e) :: s -> e :: eta_expand_stack s | [] -> - [Zshift 1; Zapp [|{norm=Norm; term= FRel 1}|]] + [Zshift 1; Zapp [|{mark=mark Norm Unknown; term= FRel 1}|]] (* Get the arguments of a native operator *) let rec skip_native_args rargs nargs = @@ -731,12 +788,12 @@ let get_native_args op c stk = (skip_native_args [] (List.rev rnargs), Zapp (Array.of_list eargs) :: s') | rnargs, kargs, _ -> - strip_rec rnargs {norm = h.norm;term=FApp(h, args)} depth kargs s' + strip_rec rnargs {mark = h.mark;term=FApp(h, args)} depth kargs s' end | Zupdate(m) :: s -> - strip_rec rnargs (update ~share:true m h.norm h.term) depth kargs s + strip_rec rnargs (update ~share:true m h.mark h.term) depth kargs s | (Zprimitive _ | ZcaseT _ | Zproj _ | Zfix _) :: _ | [] -> assert false - in strip_rec [] {norm = Red;term = FFlex(ConstKey c)} 0 kargs stk + in strip_rec [] {mark = mark Red Unknown;term = FFlex(ConstKey c)} 0 kargs stk let get_native_args1 op c stk = match get_native_args op c stk with @@ -807,7 +864,7 @@ let eta_expand_ind_stack env ind m s (f, s') = (** Try to drop the params, might fail on partially applied constructors. *) let argss = try_drop_parameters depth pars args in let hstack = Array.map (fun p -> - { norm = Red; (* right can't be a constructor though *) + { mark = mark Red Unknown; (* right can't be a constructor though *) term = FProj (Projection.make p true, right) }) projs in @@ -835,13 +892,15 @@ let rec project_nth_arg n = function let contract_fix_vect fix = let (thisbody, make_body, env, nfix) = match [@ocaml.warning "-4"] fix with - | FFix (((reci,i),(_,_,bds as rdcl)),env) -> + | FFix (((reci,i),(nas,_,bds as rdcl)),env) -> (bds.(i), - (fun j -> { norm = Cstr; term = FFix (((reci,j),rdcl),env) }), + (fun j -> { mark = mark Cstr (opt_of_rel nas.(j).binder_relevance); + term = FFix (((reci,j),rdcl),env) }), env, Array.length bds) - | FCoFix ((i,(_,_,bds as rdcl)),env) -> + | FCoFix ((i,(nas,_,bds as rdcl)),env) -> (bds.(i), - (fun j -> { norm = Cstr; term = FCoFix ((j,rdcl),env) }), + (fun j -> { mark = mark Cstr (opt_of_rel nas.(j).binder_relevance); + term = FCoFix ((j,rdcl),env) }), env, Array.length bds) | _ -> assert false in @@ -865,7 +924,7 @@ let rec knh info m stk = | FLOCKED -> assert false | FApp(a,b) -> knh info a (append_stack b (zupdate info m stk)) | FCaseT(ci,p,t,br,e) -> knh info t (ZcaseT(ci,p,br,e)::zupdate info m stk) - | FFix(((ri,n),(_,_,_)),_) -> + | FFix(((ri,n),_),_) -> (match get_nth_arg m ri.(n) stk with (Some(pars,arg),stk') -> knh info arg (Zfix(m,pars)::stk') | (None, stk') -> (m,stk')) @@ -886,18 +945,18 @@ and knht info e t stk = knht info e a (append_stack (mk_clos_vect e b) stk) | Case(ci,p,t,br) -> knht info e t (ZcaseT(ci, p, br, e)::stk) - | Fix fx -> knh info { norm = Cstr; term = FFix (fx, e) } stk + | Fix fx -> knh info { mark = mark Cstr Unknown; term = FFix (fx, e) } stk | Cast(a,_,_) -> knht info e a stk | Rel n -> knh info (clos_rel e n) stk - | Proj (p, c) -> knh info { norm = Red; term = FProj (p, mk_clos e c) } stk + | Proj (p, c) -> knh info { mark = mark Red Unknown; term = FProj (p, mk_clos e c) } stk | (Ind _|Const _|Construct _|Var _|Meta _ | Sort _ | Int _) -> (mk_clos e t, stk) - | CoFix cfx -> { norm = Cstr; term = FCoFix (cfx,e) }, stk - | Lambda _ -> { norm = Cstr; term = mk_lambda e t }, stk + | CoFix cfx -> { mark = mark Cstr Unknown; term = FCoFix (cfx,e) }, stk + | Lambda _ -> { mark = mark Cstr Unknown; term = mk_lambda e t }, stk | Prod (n, t, c) -> - { norm = Whnf; term = FProd (n, mk_clos e t, c, e) }, stk + { mark = mark Whnf KnownR; term = FProd (n, mk_clos e t, c, e) }, stk | LetIn (n,b,t,c) -> - { norm = Red; term = FLetIn (n, mk_clos e b, mk_clos e t, c, e) }, stk - | Evar ev -> { norm = Red; term = FEvar (ev, e) }, stk + { mark = mark Red Unknown; term = FLetIn (n, mk_clos e b, mk_clos e t, c, e) }, stk + | Evar ev -> { mark = mark Red Unknown; term = FEvar (ev, e) }, stk let inject c = mk_clos (subs_id 0) c @@ -919,7 +978,7 @@ module FNativeEntries = | FInt i -> i | _ -> raise Primred.NativeDestKO - let dummy = {norm = Norm; term = FRel 0} + let dummy = {mark = mark Norm KnownR; term = FRel 0} let current_retro = ref Retroknowledge.empty let defined_int = ref false @@ -929,7 +988,7 @@ module FNativeEntries = match retro.Retroknowledge.retro_int63 with | Some c -> defined_int := true; - fint := { norm = Norm; term = FFlex (ConstKey (Univ.in_punivs c)) } + fint := { mark = mark Norm KnownR; term = FFlex (ConstKey (Univ.in_punivs c)) } | None -> defined_int := false let defined_bool = ref false @@ -940,8 +999,8 @@ module FNativeEntries = match retro.Retroknowledge.retro_bool with | Some (ct,cf) -> defined_bool := true; - ftrue := { norm = Cstr; term = FConstruct (Univ.in_punivs ct) }; - ffalse := { norm = Cstr; term = FConstruct (Univ.in_punivs cf) } + ftrue := { mark = mark Cstr KnownR; term = FConstruct (Univ.in_punivs ct) }; + ffalse := { mark = mark Cstr KnownR; term = FConstruct (Univ.in_punivs cf) } | None -> defined_bool :=false let defined_carry = ref false @@ -952,8 +1011,8 @@ module FNativeEntries = match retro.Retroknowledge.retro_carry with | Some(c0,c1) -> defined_carry := true; - fC0 := { norm = Cstr; term = FConstruct (Univ.in_punivs c0) }; - fC1 := { norm = Cstr; term = FConstruct (Univ.in_punivs c1) } + fC0 := { mark = mark Cstr KnownR; term = FConstruct (Univ.in_punivs c0) }; + fC1 := { mark = mark Cstr KnownR; term = FConstruct (Univ.in_punivs c1) } | None -> defined_carry := false let defined_pair = ref false @@ -963,7 +1022,7 @@ module FNativeEntries = match retro.Retroknowledge.retro_pair with | Some c -> defined_pair := true; - fPair := { norm = Cstr; term = FConstruct (Univ.in_punivs c) } + fPair := { mark = mark Cstr KnownR; term = FConstruct (Univ.in_punivs c) } | None -> defined_pair := false let defined_cmp = ref false @@ -975,9 +1034,9 @@ module FNativeEntries = match retro.Retroknowledge.retro_cmp with | Some (cEq, cLt, cGt) -> defined_cmp := true; - fEq := { norm = Cstr; term = FConstruct (Univ.in_punivs cEq) }; - fLt := { norm = Cstr; term = FConstruct (Univ.in_punivs cLt) }; - fGt := { norm = Cstr; term = FConstruct (Univ.in_punivs cGt) } + fEq := { mark = mark Cstr KnownR; term = FConstruct (Univ.in_punivs cEq) }; + fLt := { mark = mark Cstr KnownR; term = FConstruct (Univ.in_punivs cLt) }; + fGt := { mark = mark Cstr KnownR; term = FConstruct (Univ.in_punivs cGt) } | None -> defined_cmp := false let defined_refl = ref false @@ -988,7 +1047,7 @@ module FNativeEntries = match retro.Retroknowledge.retro_refl with | Some crefl -> defined_refl := true; - frefl := { norm = Cstr; term = FConstruct (Univ.in_punivs crefl) } + frefl := { mark = mark Cstr KnownR; term = FConstruct (Univ.in_punivs crefl) } | None -> defined_refl := false let init env = @@ -1025,7 +1084,7 @@ module FNativeEntries = let mkInt env i = check_int env; - { norm = Norm; term = FInt i } + { mark = mark Norm KnownR; term = FInt i } let mkBool env b = check_bool env; @@ -1033,12 +1092,12 @@ module FNativeEntries = let mkCarry env b e = check_carry env; - {norm = Cstr; + {mark = mark Cstr KnownR; term = FApp ((if b then !fC1 else !fC0),[|!fint;e|])} let mkIntPair env e1 e2 = check_pair env; - { norm = Cstr; term = FApp(!fPair, [|!fint;!fint;e1;e2|]) } + { mark = mark Cstr KnownR; term = FApp(!fPair, [|!fint;!fint;e1;e2|]) } let mkLt env = check_cmp env; @@ -1124,8 +1183,8 @@ let rec knr info tab m stk = begin match FredNative.red_prim (info_env info) () op args with | Some m -> kni info tab m s | None -> - let f = {norm = Whnf; term = FFlex (ConstKey c)} in - let m = {norm = Whnf; term = FApp(f,args)} in + let f = {mark = mark Whnf KnownR; term = FFlex (ConstKey c)} in + let m = {mark = mark Whnf KnownR; term = FApp(f,args)} in (m,s) end | (kd,a)::nargs -> @@ -1194,12 +1253,12 @@ and norm_head info tab m = if is_val m then (incr prune; term_of_fconstr m) else match m.term with | FLambda(_n,tys,f,e) -> - let (e',rvtys) = - List.fold_left (fun (e,ctxt) (na,ty) -> - (subs_lift e, (na,kl info tab (mk_clos e ty))::ctxt)) - (e,[]) tys in - let bd = kl info tab (mk_clos e' f) in - List.fold_left (fun b (na,ty) -> mkLambda(na,ty,b)) bd rvtys + let (e',info,rvtys) = + List.fold_left (fun (e,info,ctxt) (na,ty) -> + (subs_lift e, info, (na,kl info tab (mk_clos e ty))::ctxt)) + (e,info,[]) tys in + let bd = kl info tab (mk_clos e' f) in + List.fold_left (fun b (na,ty) -> mkLambda(na,ty,b)) bd rvtys | FLetIn(na,a,b,f,e) -> let c = mk_clos (subs_lift e) f in mkLetIn(na, kl info tab a, kl info tab b, kl info tab c) @@ -1232,7 +1291,7 @@ let whd_val info tab v = let norm_val info tab v = with_stats (lazy (kl info tab v)) -let whd_stack infos tab m stk = match m.norm with +let whd_stack infos tab m stk = match Mark.red_state m.mark with | Whnf | Norm -> (** No need to perform [kni] nor to unlock updates because every head subterm of [m] is [Whnf] or [Norm] *) @@ -1269,3 +1328,6 @@ let unfold_reference info tab key = ref_value_cache info tab key else Undef None | RelKey _ -> ref_value_cache info tab key + +let relevance_of f = Mark.relevance f.mark +let set_relevance r f = f.mark <- Mark.mark (Mark.red_state f.mark) (opt_of_rel r) diff --git a/kernel/cClosure.mli b/kernel/cClosure.mli index bd04677374..b1b69dded8 100644 --- a/kernel/cClosure.mli +++ b/kernel/cClosure.mli @@ -114,9 +114,9 @@ type fterm = | FFix of fixpoint * fconstr subs | FCoFix of cofixpoint * fconstr subs | FCaseT of case_info * constr * fconstr * constr array * fconstr subs (* predicate and branches are closures *) - | FLambda of int * (Name.t * constr) list * constr * fconstr subs - | FProd of Name.t * fconstr * constr * fconstr subs - | FLetIn of Name.t * fconstr * fconstr * constr * fconstr subs + | FLambda of int * (Name.t Context.binder_annot * constr) list * constr * fconstr subs + | FProd of Name.t Context.binder_annot * fconstr * constr * fconstr subs + | FLetIn of Name.t Context.binder_annot * fconstr * fconstr * constr * fconstr subs | FEvar of existential * fconstr subs | FInt of Uint63.t | FLIFT of int * fconstr @@ -165,7 +165,12 @@ val mk_red : fterm -> fconstr val fterm_of : fconstr -> fterm val term_of_fconstr : fconstr -> constr val destFLambda : - (fconstr subs -> constr -> fconstr) -> fconstr -> Name.t * fconstr * fconstr + (fconstr subs -> constr -> fconstr) -> fconstr -> Name.t Context.binder_annot * fconstr * fconstr + +type optrel = Unknown | KnownR | KnownI + +val relevance_of : fconstr -> optrel +val set_relevance : Sorts.relevance -> fconstr -> unit (** Global and local constant cache *) type clos_infos diff --git a/kernel/cbytegen.ml b/kernel/cbytegen.ml index 718584b3d4..69f004307d 100644 --- a/kernel/cbytegen.ml +++ b/kernel/cbytegen.ml @@ -550,7 +550,7 @@ let rec compile_lam env cenv lam sz cont = else comp_app compile_structured_constant compile_universe cenv (Const_ind ind) (Univ.Instance.to_array u) sz cont - | Lsort (Sorts.Prop | Sorts.Set as s) -> + | Lsort (Sorts.SProp | Sorts.Prop | Sorts.Set as s) -> compile_structured_constant cenv (Const_sort s) sz cont | Lsort (Sorts.Type u) -> (* We represent universes as a global constant with local universes @@ -562,10 +562,10 @@ let rec compile_lam env cenv lam sz cont = compile_fv_elem cenv (FVuniv_var idx) sz cont in if List.is_empty s then - compile_structured_constant cenv (Const_sort (Sorts.Type u)) sz cont + compile_structured_constant cenv (Const_sort (Sorts.sort_of_univ u)) sz cont else comp_app compile_structured_constant compile_get_univ cenv - (Const_sort (Sorts.Type u)) (Array.of_list s) sz cont + (Const_sort (Sorts.sort_of_univ u)) (Array.of_list s) sz cont | Llet (_id,def,body) -> compile_lam env cenv def sz diff --git a/kernel/clambda.ml b/kernel/clambda.ml index 5c21a5ec25..a764cca354 100644 --- a/kernel/clambda.ml +++ b/kernel/clambda.ml @@ -15,8 +15,8 @@ type lambda = | Lvar of Id.t | Levar of Evar.t * lambda array | Lprod of lambda * lambda - | Llam of Name.t array * lambda - | Llet of Name.t * lambda * lambda + | Llam of Name.t Context.binder_annot array * lambda + | Llet of Name.t Context.binder_annot * lambda * lambda | Lapp of lambda * lambda array | Lconst of pconstant | Lprim of pconstant option * CPrimitives.t * lambda array @@ -38,15 +38,17 @@ type lambda = stored in [extra_branches]. *) and lam_branches = { constant_branches : lambda array; - nonconstant_branches : (Name.t array * lambda) array } + nonconstant_branches : (Name.t Context.binder_annot array * lambda) array } (* extra_branches : (name array * lambda) array } *) -and fix_decl = Name.t array * lambda array * lambda array +and fix_decl = Name.t Context.binder_annot array * lambda array * lambda array (** Printing **) +let pr_annot x = Name.print x.Context.binder_name + let pp_names ids = - prlist_with_sep (fun _ -> brk(1,1)) Name.print (Array.to_list ids) + prlist_with_sep (fun _ -> brk(1,1)) pr_annot (Array.to_list ids) let pp_rel name n = Name.print name ++ str "##" ++ int n @@ -55,6 +57,7 @@ let pp_sort s = match Sorts.family s with | InSet -> str "Set" | InProp -> str "Prop" + | InSProp -> str "SProp" | InType -> str "Type" let rec pp_lam lam = @@ -79,7 +82,7 @@ let rec pp_lam lam = str ")") | Llet(id,def,body) -> hov 0 (str "let " ++ - Name.print id ++ + pr_annot id ++ str ":=" ++ pp_lam def ++ str " in" ++ @@ -119,7 +122,7 @@ let rec pp_lam lam = v 0 (prlist_with_sep spc (fun (na,i,ty,bd) -> - Name.print na ++ str"/" ++ int i ++ str":" ++ + pr_annot na ++ str"/" ++ int i ++ str":" ++ pp_lam ty ++ cut() ++ str":=" ++ pp_lam bd) (Array.to_list fixl)) ++ str"}") @@ -131,7 +134,7 @@ let rec pp_lam lam = v 0 (prlist_with_sep spc (fun (na,ty,bd) -> - Name.print na ++ str":" ++ pp_lam ty ++ + pr_annot na ++ str":" ++ pp_lam ty ++ cut() ++ str":=" ++ pp_lam bd) (Array.to_list fixl)) ++ str"}") | Lmakeblock(tag, args) -> @@ -393,8 +396,8 @@ and reduce_lapp substf lids body substa largs = Llet(id, a, body) | [], [] -> simplify substf body | _::_, _ -> - Llam(Array.of_list lids, simplify (liftn (List.length lids) substf) body) - | [], _::_ -> simplify_app substf body substa (Array.of_list largs) + Llam(Array.of_list lids, simplify (liftn (List.length lids) substf) body) + | [], _ -> simplify_app substf body substa (Array.of_list largs) @@ -511,7 +514,8 @@ let make_args start _end = (* Translation of constructors *) let expand_constructor tag nparams arity = - let ids = Array.make (nparams + arity) Anonymous in + let anon = Context.make_annot Anonymous Sorts.Relevant in (* TODO relevance *) + let ids = Array.make (nparams + arity) anon in if arity = 0 then mkLlam ids (Lint tag) else let args = make_args arity 1 in @@ -553,7 +557,8 @@ let prim kn p args = Lprim(Some kn, p, args) let expand_prim kn op arity = - let ids = Array.make arity Anonymous in + (* primitives are always Relevant *) + let ids = Array.make arity Context.anonR in let args = make_args arity 1 in Llam(ids, prim kn op args) @@ -628,7 +633,7 @@ struct construct_tbl = Hashtbl.create 111 } - let push_rel env id = Vect.push env.name_rel id + let push_rel env id = Vect.push env.name_rel id.Context.binder_name let push_rels env ids = Array.iter (push_rel env) ids @@ -678,7 +683,7 @@ let rec lambda_of_constr env c = Renv.push_rel env id; let lc = lambda_of_constr env codom in Renv.pop env; - Lprod(ld, Llam([|id|], lc)) + Lprod(ld, Llam([|id|], lc)) | Lambda _ -> let params, body = decompose_lam c in @@ -725,7 +730,8 @@ let rec lambda_of_constr env c = match b with | Llam(ids, body) when Array.length ids = arity -> (ids, body) | _ -> - let ids = Array.make arity Anonymous in + let anon = Context.make_annot Anonymous Sorts.Relevant in (* TODO relevance *) + let ids = Array.make arity anon in let args = make_args arity 1 in let ll = lam_lift arity b in (ids, mkLapp ll args) @@ -800,7 +806,7 @@ let optimize_lambda lam = let lambda_of_constr ~optimize genv c = let env = Renv.make genv in - let ids = List.rev_map Context.Rel.Declaration.get_name (rel_context genv) in + let ids = List.rev_map Context.Rel.Declaration.get_annot (rel_context genv) in Renv.push_rels env (Array.of_list ids); let lam = lambda_of_constr env c in let lam = if optimize then optimize_lambda lam else lam in diff --git a/kernel/clambda.mli b/kernel/clambda.mli index 4d921fd45e..1476bb6e45 100644 --- a/kernel/clambda.mli +++ b/kernel/clambda.mli @@ -8,8 +8,8 @@ type lambda = | Lvar of Id.t | Levar of Evar.t * lambda array | Lprod of lambda * lambda - | Llam of Name.t array * lambda - | Llet of Name.t * lambda * lambda + | Llam of Name.t Context.binder_annot array * lambda + | Llet of Name.t Context.binder_annot * lambda * lambda | Lapp of lambda * lambda array | Lconst of pconstant | Lprim of pconstant option * CPrimitives.t * lambda array @@ -28,15 +28,15 @@ type lambda = and lam_branches = { constant_branches : lambda array; - nonconstant_branches : (Name.t array * lambda) array } + nonconstant_branches : (Name.t Context.binder_annot array * lambda) array } -and fix_decl = Name.t array * lambda array * lambda array +and fix_decl = Name.t Context.binder_annot array * lambda array * lambda array exception TooLargeInductive of Pp.t val lambda_of_constr : optimize:bool -> env -> Constr.t -> lambda -val decompose_Llam : lambda -> Name.t array * lambda +val decompose_Llam : lambda -> Name.t Context.binder_annot array * lambda val get_alias : env -> Constant.t -> Constant.t diff --git a/kernel/constr.ml b/kernel/constr.ml index c392494e95..d74c96af84 100644 --- a/kernel/constr.ml +++ b/kernel/constr.ml @@ -28,6 +28,7 @@ open Util open Names open Univ +open Context type existential_key = Evar.t type metavariable = int @@ -60,6 +61,7 @@ type case_info = in addition to the parameters of the related inductive type NOTE: "lets" are therefore excluded from the count NOTE: parameters of the inductive type are also excluded from the count *) + ci_relevance : Sorts.relevance; ci_pp_info : case_printing (* not interpreted by the kernel *) } @@ -71,7 +73,7 @@ type case_info = the same order (i.e. last argument first) *) type 'constr pexistential = existential_key * 'constr array type ('constr, 'types) prec_declaration = - Name.t array * 'types array * 'constr array + Name.t binder_annot array * 'types array * 'constr array type ('constr, 'types) pfixpoint = (int array * int) * ('constr, 'types) prec_declaration type ('constr, 'types) pcofixpoint = @@ -90,9 +92,9 @@ type ('constr, 'types, 'sort, 'univs) kind_of_term = | Evar of 'constr pexistential | Sort of 'sort | Cast of 'constr * cast_kind * 'types - | Prod of Name.t * 'types * 'types - | Lambda of Name.t * 'types * 'constr - | LetIn of Name.t * 'constr * 'types * 'constr + | Prod of Name.t binder_annot * 'types * 'types + | Lambda of Name.t binder_annot * 'types * 'constr + | LetIn of Name.t binder_annot * 'constr * 'types * 'constr | App of 'constr * 'constr array | Const of (Constant.t * 'univs) | Ind of (inductive * 'univs) @@ -127,13 +129,15 @@ let rels = let mkRel n = if 0<n && n<=16 then rels.(n-1) else Rel n (* Construct a type *) +let mkSProp = Sort Sorts.sprop let mkProp = Sort Sorts.prop let mkSet = Sort Sorts.set -let mkType u = Sort (Sorts.Type u) +let mkType u = Sort (Sorts.sort_of_univ u) let mkSort = function + | Sorts.SProp -> mkSProp | Sorts.Prop -> mkProp (* Easy sharing *) | Sorts.Set -> mkSet - | s -> Sort s + | Sorts.Type _ as s -> Sort s (* Constructs the term t1::t2, i.e. the term t1 casted with the type t2 *) (* (that means t2 is declared as the type of t1) *) @@ -856,7 +860,7 @@ let compare_head_gen_leq_with kind1 kind2 leq_universes leq_sorts eq leq nargs t | App (c1, l1), App (c2, l2) -> let len = Array.length l1 in Int.equal len (Array.length l2) && - eq (nargs+len) c1 c2 && Array.equal_norefl (eq 0) l1 l2 + leq (nargs+len) c1 c2 && Array.equal_norefl (eq 0) l1 l2 | Proj (p1,c1), Proj (p2,c2) -> Projection.equal p1 p2 && eq 0 c1 c2 | Evar (e1,l1), Evar (e2,l2) -> Evar.equal e1 e2 && Array.equal (eq 0) l1 l2 | Const (c1,u1), Const (c2,u2) -> @@ -1181,16 +1185,16 @@ let hashcons (sh_sort,sh_ci,sh_construct,sh_ind,sh_con,sh_na,sh_id) = | Prod (na,t,c) -> let t, ht = sh_rec t and c, hc = sh_rec c in - (Prod (sh_na na, t, c), combinesmall 4 (combine3 (Name.hash na) ht hc)) + (Prod (sh_na na, t, c), combinesmall 4 (combine3 (hash_annot Name.hash na) ht hc)) | Lambda (na,t,c) -> let t, ht = sh_rec t and c, hc = sh_rec c in - (Lambda (sh_na na, t, c), combinesmall 5 (combine3 (Name.hash na) ht hc)) + (Lambda (sh_na na, t, c), combinesmall 5 (combine3 (hash_annot Name.hash na) ht hc)) | LetIn (na,b,t,c) -> let b, hb = sh_rec b in let t, ht = sh_rec t in let c, hc = sh_rec c in - (LetIn (sh_na na, b, t, c), combinesmall 6 (combine4 (Name.hash na) hb ht hc)) + (LetIn (sh_na na, b, t, c), combinesmall 6 (combine4 (hash_annot Name.hash na) hb ht hc)) | App (c,l) -> let c, hc = sh_rec c in let l, hl = hash_term_array l in @@ -1214,24 +1218,24 @@ let hashcons (sh_sort,sh_ci,sh_construct,sh_ind,sh_con,sh_na,sh_id) = let p, hp = sh_rec p and c, hc = sh_rec c in let bl,hbl = hash_term_array bl in - let hbl = combine (combine hc hp) hbl in + let hbl = combine (combine hc hp) hbl in (Case (sh_ci ci, p, c, bl), combinesmall 12 hbl) | Fix (ln,(lna,tl,bl)) -> - let bl,hbl = hash_term_array bl in + let bl,hbl = hash_term_array bl in let tl,htl = hash_term_array tl in let () = Array.iteri (fun i x -> Array.unsafe_set lna i (sh_na x)) lna in - let fold accu na = combine (Name.hash na) accu in + let fold accu na = combine (hash_annot Name.hash na) accu in let hna = Array.fold_left fold 0 lna in let h = combine3 hna hbl htl in - (Fix (ln,(lna,tl,bl)), combinesmall 13 h) + (Fix (ln,(lna,tl,bl)), combinesmall 13 h) | CoFix(ln,(lna,tl,bl)) -> - let bl,hbl = hash_term_array bl in + let bl,hbl = hash_term_array bl in let tl,htl = hash_term_array tl in let () = Array.iteri (fun i x -> Array.unsafe_set lna i (sh_na x)) lna in - let fold accu na = combine (Name.hash na) accu in + let fold accu na = combine (hash_annot Name.hash na) accu in let hna = Array.fold_left fold 0 lna in let h = combine3 hna hbl htl in - (CoFix (ln,(lna,tl,bl)), combinesmall 14 h) + (CoFix (ln,(lna,tl,bl)), combinesmall 14 h) | Meta n -> (t, combinesmall 15 n) | Rel n -> @@ -1322,6 +1326,7 @@ struct info1.style == info2.style let eq ci ci' = ci.ci_ind == ci'.ci_ind && + ci.ci_relevance == ci'.ci_relevance && Int.equal ci.ci_npar ci'.ci_npar && Array.equal Int.equal ci.ci_cstr_ndecls ci'.ci_cstr_ndecls && (* we use [Array.equal] on purpose *) Array.equal Int.equal ci.ci_cstr_nargs ci'.ci_cstr_nargs && (* we use [Array.equal] on purpose *) @@ -1345,7 +1350,7 @@ struct let h3 = Array.fold_left combine 0 ci.ci_cstr_ndecls in let h4 = Array.fold_left combine 0 ci.ci_cstr_nargs in let h5 = hash_pp_info ci.ci_pp_info in - combine5 h1 h2 h3 h4 h5 + combinesmall (Sorts.relevance_hash ci.ci_relevance) (combine5 h1 h2 h3 h4 h5) end module Hcaseinfo = Hashcons.Make(CaseinfoHash) @@ -1354,6 +1359,18 @@ let case_info_hash = CaseinfoHash.hash let hcons_caseinfo = Hashcons.simple_hcons Hcaseinfo.generate Hcaseinfo.hcons hcons_ind +module Hannotinfo = struct + type t = Name.t binder_annot + type u = Name.t -> Name.t + let hash = hash_annot Name.hash + let eq = eq_annot (fun na1 na2 -> na1 == na2) + let hashcons h {binder_name=na;binder_relevance} = + {binder_name=h na;binder_relevance} + end +module Hannot = Hashcons.Make(Hannotinfo) + +let hcons_annot = Hashcons.simple_hcons Hannot.generate Hannot.hcons Name.hcons + let hcons = hashcons (Sorts.hcons, @@ -1361,7 +1378,7 @@ let hcons = hcons_construct, hcons_ind, hcons_con, - Name.hcons, + hcons_annot, Id.hcons) (* let hcons_types = hcons_constr *) @@ -1377,7 +1394,7 @@ type compacted_context = compacted_declaration list let debug_print_fix pr_constr ((t,i),(lna,tl,bl)) = let open Pp in - let fixl = Array.mapi (fun i na -> (na,t.(i),tl.(i),bl.(i))) lna in + let fixl = Array.mapi (fun i na -> (na.binder_name,t.(i),tl.(i),bl.(i))) lna in hov 1 (str"fix " ++ int i ++ spc() ++ str"{" ++ v 0 (prlist_with_sep spc (fun (na,i,ty,bd) -> @@ -1399,17 +1416,17 @@ let rec debug_print c = | Cast (c,_, t) -> hov 1 (str"(" ++ debug_print c ++ cut() ++ str":" ++ debug_print t ++ str")") - | Prod (Name(id),t,c) -> hov 1 + | Prod ({binder_name=Name id;_},t,c) -> hov 1 (str"forall " ++ Id.print id ++ str":" ++ debug_print t ++ str"," ++ spc() ++ debug_print c) - | Prod (Anonymous,t,c) -> hov 0 + | Prod ({binder_name=Anonymous;_},t,c) -> hov 0 (str"(" ++ debug_print t ++ str " ->" ++ spc() ++ debug_print c ++ str")") | Lambda (na,t,c) -> hov 1 - (str"fun " ++ Name.print na ++ str":" ++ + (str"fun " ++ Name.print na.binder_name ++ str":" ++ debug_print t ++ str" =>" ++ spc() ++ debug_print c) | LetIn (na,b,t,c) -> hov 0 - (str"let " ++ Name.print na ++ str":=" ++ debug_print b ++ + (str"let " ++ Name.print na.binder_name ++ str":=" ++ debug_print b ++ str":" ++ brk(1,2) ++ debug_print t ++ cut() ++ debug_print c) | App (c,l) -> hov 1 @@ -1434,7 +1451,7 @@ let rec debug_print c = hov 1 (str"cofix " ++ int i ++ spc() ++ str"{" ++ v 0 (prlist_with_sep spc (fun (na,ty,bd) -> - Name.print na ++ str":" ++ debug_print ty ++ + Name.print na.binder_name ++ str":" ++ debug_print ty ++ cut() ++ str":=" ++ debug_print bd) (Array.to_list fixl)) ++ str"}") | Int i -> str"Int("++str (Uint63.to_string i) ++ str")" diff --git a/kernel/constr.mli b/kernel/constr.mli index fdc3296a6a..7fc57cdb8a 100644 --- a/kernel/constr.mli +++ b/kernel/constr.mli @@ -45,6 +45,7 @@ type case_info = in addition to the parameters of the related inductive type NOTE: "lets" are therefore excluded from the count NOTE: parameters of the inductive type are also excluded from the count *) + ci_relevance : Sorts.relevance; (* relevance of the predicate (not of the inductive!) *) ci_pp_info : case_printing (* not interpreted by the kernel *) } @@ -84,6 +85,7 @@ val mkEvar : existential -> constr (** Construct a sort *) val mkSort : Sorts.t -> types +val mkSProp : types val mkProp : types val mkSet : types val mkType : Univ.Universe.t -> types @@ -97,13 +99,13 @@ type cast_kind = VMcast | NATIVEcast | DEFAULTcast | REVERTcast val mkCast : constr * cast_kind * constr -> constr (** Constructs the product [(x:t1)t2] *) -val mkProd : Name.t * types * types -> types +val mkProd : Name.t Context.binder_annot * types * types -> types (** Constructs the abstraction \[x:t{_ 1}\]t{_ 2} *) -val mkLambda : Name.t * types * constr -> constr +val mkLambda : Name.t Context.binder_annot * types * constr -> constr (** Constructs the product [let x = t1 : t2 in t3] *) -val mkLetIn : Name.t * constr * types * constr -> constr +val mkLetIn : Name.t Context.binder_annot * constr * types * constr -> constr (** [mkApp (f, [|t1; ...; tN|]] constructs the application {%html:(f t<sub>1</sub> ... t<sub>n</sub>)%} @@ -160,7 +162,7 @@ val mkCase : case_info * constr * constr * constr array -> constr where the length of the {% $ %}j{% $ %}th context is {% $ %}ij{% $ %}. *) type ('constr, 'types) prec_declaration = - Name.t array * 'types array * 'constr array + Name.t Context.binder_annot array * 'types array * 'constr array type ('constr, 'types) pfixpoint = (int array * int) * ('constr, 'types) prec_declaration (* The array of [int]'s tells for each component of the array of @@ -213,9 +215,9 @@ type ('constr, 'types, 'sort, 'univs) kind_of_term = | Evar of 'constr pexistential | Sort of 'sort | Cast of 'constr * cast_kind * 'types - | Prod of Name.t * 'types * 'types (** Concrete syntax ["forall A:B,C"] is represented as [Prod (A,B,C)]. *) - | Lambda of Name.t * 'types * 'constr (** Concrete syntax ["fun A:B => C"] is represented as [Lambda (A,B,C)]. *) - | LetIn of Name.t * 'constr * 'types * 'constr (** Concrete syntax ["let A:C := B in D"] is represented as [LetIn (A,B,C,D)]. *) + | Prod of Name.t Context.binder_annot * 'types * 'types (** Concrete syntax ["forall A:B,C"] is represented as [Prod (A,B,C)]. *) + | Lambda of Name.t Context.binder_annot * 'types * 'constr (** Concrete syntax ["fun A:B => C"] is represented as [Lambda (A,B,C)]. *) + | LetIn of Name.t Context.binder_annot * 'constr * 'types * 'constr (** Concrete syntax ["let A:C := B in D"] is represented as [LetIn (A,B,C,D)]. *) | App of 'constr * 'constr array (** Concrete syntax ["(F P1 P2 ... Pn)"] is represented as [App (F, [|P1; P2; ...; Pn|])]. The {!mkApp} constructor also enforces the following invariant: @@ -297,13 +299,13 @@ val destSort : constr -> Sorts.t val destCast : constr -> constr * cast_kind * constr (** Destructs the product {% $ %}(x:t_1)t_2{% $ %} *) -val destProd : types -> Name.t * types * types +val destProd : types -> Name.t Context.binder_annot * types * types (** Destructs the abstraction {% $ %}[x:t_1]t_2{% $ %} *) -val destLambda : constr -> Name.t * types * constr +val destLambda : constr -> Name.t Context.binder_annot * types * constr (** Destructs the let {% $ %}[x:=b:t_1]t_2{% $ %} *) -val destLetIn : constr -> Name.t * constr * types * constr +val destLetIn : constr -> Name.t Context.binder_annot * constr * types * constr (** Destructs an application *) val destApp : constr -> constr * constr array diff --git a/kernel/context.ml b/kernel/context.ml index 1cc6e79485..290e85294b 100644 --- a/kernel/context.ml +++ b/kernel/context.ml @@ -31,6 +31,27 @@ open Util open Names +type 'a binder_annot = { binder_name : 'a; binder_relevance : Sorts.relevance } + +let eq_annot eq {binder_name=na1;binder_relevance=r1} {binder_name=na2;binder_relevance=r2} = + eq na1 na2 && Sorts.relevance_equal r1 r2 + +let hash_annot h {binder_name=n;binder_relevance=r} = + Hashset.Combine.combinesmall (Sorts.relevance_hash r) (h n) + +let map_annot f {binder_name=na;binder_relevance} = + {binder_name=f na;binder_relevance} + +let make_annot x r = {binder_name=x;binder_relevance=r} + +let binder_name x = x.binder_name +let binder_relevance x = x.binder_relevance + +let annotR x = make_annot x Sorts.Relevant + +let nameR x = annotR (Name x) +let anonR = annotR Anonymous + (** Representation of contexts that can capture anonymous as well as non-anonymous variables. Individual declarations are then designated by de Bruijn indexes. *) module Rel = @@ -40,13 +61,14 @@ struct struct (* local declaration *) type ('constr, 'types) pt = - | LocalAssum of Name.t * 'types (** name, type *) - | LocalDef of Name.t * 'constr * 'types (** name, value, type *) + | LocalAssum of Name.t binder_annot * 'types (** name, type *) + | LocalDef of Name.t binder_annot * 'constr * 'types (** name, value, type *) + + let get_annot = function + | LocalAssum (na,_) | LocalDef (na,_,_) -> na (** Return the name bound by a given declaration. *) - let get_name = function - | LocalAssum (na,_) - | LocalDef (na,_,_) -> na + let get_name x = (get_annot x).binder_name (** Return [Some value] for local-declarations and [None] for local-assumptions. *) let get_value = function @@ -57,11 +79,13 @@ struct let get_type = function | LocalAssum (_,ty) | LocalDef (_,_,ty) -> ty - + + let get_relevance x = (get_annot x).binder_relevance + (** Set the name that is bound by a given declaration. *) let set_name na = function - | LocalAssum (_,ty) -> LocalAssum (na, ty) - | LocalDef (_,v,ty) -> LocalDef (na, v, ty) + | LocalAssum (x,ty) -> LocalAssum ({x with binder_name=na}, ty) + | LocalDef (x,v,ty) -> LocalDef ({x with binder_name=na}, v, ty) (** Set the type of the bound variable in a given declaration. *) let set_type ty = function @@ -92,20 +116,17 @@ struct let equal eq decl1 decl2 = match decl1, decl2 with | LocalAssum (n1,ty1), LocalAssum (n2, ty2) -> - Name.equal n1 n2 && eq ty1 ty2 + eq_annot Name.equal n1 n2 && eq ty1 ty2 | LocalDef (n1,v1,ty1), LocalDef (n2,v2,ty2) -> - Name.equal n1 n2 && eq v1 v2 && eq ty1 ty2 + eq_annot Name.equal n1 n2 && eq v1 v2 && eq ty1 ty2 | _ -> false (** Map the name bound by a given declaration. *) - let map_name f = function - | LocalAssum (na, ty) as decl -> - let na' = f na in - if na == na' then decl else LocalAssum (na', ty) - | LocalDef (na, v, ty) as decl -> - let na' = f na in - if na == na' then decl else LocalDef (na', v, ty) + let map_name f x = + let na = get_name x in + let na' = f na in + if na == na' then x else set_name na' x (** For local assumptions, this function returns the original local assumptions. For local definitions, this function maps the value in the local definition. *) @@ -120,7 +141,7 @@ struct | LocalAssum (na, ty) as decl -> let ty' = f ty in if ty == ty' then decl else LocalAssum (na, ty') - | LocalDef (na, v, ty) as decl -> + | LocalDef (na, v, ty) as decl -> let ty' = f ty in if ty == ty' then decl else LocalDef (na, v, ty') @@ -250,13 +271,14 @@ struct struct (** local declaration *) type ('constr, 'types) pt = - | LocalAssum of Id.t * 'types (** identifier, type *) - | LocalDef of Id.t * 'constr * 'types (** identifier, value, type *) + | LocalAssum of Id.t binder_annot * 'types (** identifier, type *) + | LocalDef of Id.t binder_annot * 'constr * 'types (** identifier, value, type *) + + let get_annot = function + | LocalAssum (na,_) | LocalDef (na,_,_) -> na (** Return the identifier bound by a given declaration. *) - let get_id = function - | LocalAssum (id,_) -> id - | LocalDef (id,_,_) -> id + let get_id x = (get_annot x).binder_name (** Return [Some value] for local-declarations and [None] for local-assumptions. *) let get_value = function @@ -268,10 +290,14 @@ struct | LocalAssum (_,ty) | LocalDef (_,_,ty) -> ty + let get_relevance x = (get_annot x).binder_relevance + (** Set the identifier that is bound by a given declaration. *) - let set_id id = function - | LocalAssum (_,ty) -> LocalAssum (id, ty) - | LocalDef (_, v, ty) -> LocalDef (id, v, ty) + let set_id id = + let set x = {x with binder_name = id} in + function + | LocalAssum (x,ty) -> LocalAssum (set x, ty) + | LocalDef (x, v, ty) -> LocalDef (set x, v, ty) (** Set the type of the bound variable in a given declaration. *) let set_type ty = function @@ -302,20 +328,17 @@ struct let equal eq decl1 decl2 = match decl1, decl2 with | LocalAssum (id1, ty1), LocalAssum (id2, ty2) -> - Id.equal id1 id2 && eq ty1 ty2 + eq_annot Id.equal id1 id2 && eq ty1 ty2 | LocalDef (id1, v1, ty1), LocalDef (id2, v2, ty2) -> - Id.equal id1 id2 && eq v1 v2 && eq ty1 ty2 + eq_annot Id.equal id1 id2 && eq v1 v2 && eq ty1 ty2 | _ -> false (** Map the identifier bound by a given declaration. *) - let map_id f = function - | LocalAssum (id, ty) as decl -> - let id' = f id in - if id == id' then decl else LocalAssum (id', ty) - | LocalDef (id, v, ty) as decl -> - let id' = f id in - if id == id' then decl else LocalDef (id', v, ty) + let map_id f x = + let id = get_id x in + let id' = f id in + if id == id' then x else set_id id' x (** For local assumptions, this function returns the original local assumptions. For local definitions, this function maps the value in the local definition. *) @@ -369,15 +392,17 @@ struct let of_rel_decl f = function | Rel.Declaration.LocalAssum (na,t) -> - LocalAssum (f na, t) + LocalAssum (map_annot f na, t) | Rel.Declaration.LocalDef (na,v,t) -> - LocalDef (f na, v, t) - - let to_rel_decl = function + LocalDef (map_annot f na, v, t) + + let to_rel_decl = + let name x = {binder_name=Name x.binder_name;binder_relevance=x.binder_relevance} in + function | LocalAssum (id,t) -> - Rel.Declaration.LocalAssum (Name id, t) + Rel.Declaration.LocalAssum (name id, t) | LocalDef (id,v,t) -> - Rel.Declaration.LocalDef (Name id,v,t) + Rel.Declaration.LocalDef (name id,v,t) end (** Named-context is represented as a list of declarations. @@ -430,7 +455,7 @@ struct gives [Var id1, Var id3]. All [idj] are supposed distinct. *) let to_instance mk l = let filter = function - | Declaration.LocalAssum (id, _) -> Some (mk id) + | Declaration.LocalAssum (id, _) -> Some (mk id.binder_name) | _ -> None in List.map_filter filter l @@ -441,8 +466,8 @@ module Compacted = module Declaration = struct type ('constr, 'types) pt = - | LocalAssum of Id.t list * 'types - | LocalDef of Id.t list * 'constr * 'types + | LocalAssum of Id.t binder_annot list * 'types + | LocalDef of Id.t binder_annot list * 'constr * 'types let map_constr f = function | LocalAssum (ids, ty) as decl -> diff --git a/kernel/context.mli b/kernel/context.mli index 8acae73680..7b67e54ba4 100644 --- a/kernel/context.mli +++ b/kernel/context.mli @@ -24,6 +24,27 @@ open Names +type 'a binder_annot = { binder_name : 'a; binder_relevance : Sorts.relevance } +val eq_annot : ('a -> 'a -> bool) -> 'a binder_annot -> 'a binder_annot -> bool + +val hash_annot : ('a -> int) -> 'a binder_annot -> int + +val map_annot : ('a -> 'b) -> 'a binder_annot -> 'b binder_annot + +val make_annot : 'a -> Sorts.relevance -> 'a binder_annot + +val binder_name : 'a binder_annot -> 'a +val binder_relevance : 'a binder_annot -> Sorts.relevance + +val annotR : 'a -> 'a binder_annot +(** Always Relevant *) + +val nameR : Id.t -> Name.t binder_annot +(** Relevant + Name *) + +val anonR : Name.t binder_annot +(** Relevant + Anonymous *) + (** Representation of contexts that can capture anonymous as well as non-anonymous variables. Individual declarations are then designated by de Bruijn indexes. *) module Rel : @@ -32,8 +53,10 @@ sig sig (* local declaration *) type ('constr, 'types) pt = - | LocalAssum of Name.t * 'types (** name, type *) - | LocalDef of Name.t * 'constr * 'types (** name, value, type *) + | LocalAssum of Name.t binder_annot * 'types (** name, type *) + | LocalDef of Name.t binder_annot * 'constr * 'types (** name, value, type *) + + val get_annot : _ pt -> Name.t binder_annot (** Return the name bound by a given declaration. *) val get_name : ('c, 't) pt -> Name.t @@ -44,6 +67,8 @@ sig (** Return the type of the name bound by a given declaration. *) val get_type : ('c, 't) pt -> 't + val get_relevance : ('c, 't) pt -> Sorts.relevance + (** Set the name that is bound by a given declaration. *) val set_name : Name.t -> ('c, 't) pt -> ('c, 't) pt @@ -87,7 +112,7 @@ sig (** Reduce all terms in a given declaration to a single value. *) val fold_constr : ('c -> 'a -> 'a) -> ('c, 'c) pt -> 'a -> 'a - val to_tuple : ('c, 't) pt -> Name.t * 'c option * 't + val to_tuple : ('c, 't) pt -> Name.t binder_annot * 'c option * 't (** Turn [LocalDef] into [LocalAssum], identity otherwise. *) val drop_body : ('c, 't) pt -> ('c, 't) pt @@ -156,8 +181,10 @@ sig module Declaration : sig type ('constr, 'types) pt = - | LocalAssum of Id.t * 'types (** identifier, type *) - | LocalDef of Id.t * 'constr * 'types (** identifier, value, type *) + | LocalAssum of Id.t binder_annot * 'types (** identifier, type *) + | LocalDef of Id.t binder_annot * 'constr * 'types (** identifier, value, type *) + + val get_annot : _ pt -> Id.t binder_annot (** Return the identifier bound by a given declaration. *) val get_id : ('c, 't) pt -> Id.t @@ -168,6 +195,8 @@ sig (** Return the type of the name bound by a given declaration. *) val get_type : ('c, 't) pt -> 't + val get_relevance : ('c, 't) pt -> Sorts.relevance + (** Set the identifier that is bound by a given declaration. *) val set_id : Id.t -> ('c, 't) pt -> ('c, 't) pt @@ -208,8 +237,8 @@ sig (** Reduce all terms in a given declaration to a single value. *) val fold_constr : ('c -> 'a -> 'a) -> ('c, 'c) pt -> 'a -> 'a - val to_tuple : ('c, 't) pt -> Id.t * 'c option * 't - val of_tuple : Id.t * 'c option * 't -> ('c, 't) pt + val to_tuple : ('c, 't) pt -> Id.t binder_annot * 'c option * 't + val of_tuple : Id.t binder_annot * 'c option * 't -> ('c, 't) pt (** Turn [LocalDef] into [LocalAssum], identity otherwise. *) val drop_body : ('c, 't) pt -> ('c, 't) pt @@ -276,8 +305,8 @@ sig module Declaration : sig type ('constr, 'types) pt = - | LocalAssum of Id.t list * 'types - | LocalDef of Id.t list * 'constr * 'types + | LocalAssum of Id.t binder_annot list * 'types + | LocalDef of Id.t binder_annot list * 'constr * 'types val map_constr : ('c -> 'c) -> ('c, 'c) pt -> ('c, 'c) pt val of_named_decl : ('c, 't) Named.Declaration.pt -> ('c, 't) pt diff --git a/kernel/cooking.ml b/kernel/cooking.ml index 22de9bfad5..9b974c4ecc 100644 --- a/kernel/cooking.ml +++ b/kernel/cooking.ml @@ -21,6 +21,7 @@ open Term open Constr open Declarations open Univ +open Context module NamedDecl = Context.Named.Declaration module RelDecl = Context.Rel.Declaration @@ -134,12 +135,12 @@ let abstract_context hyps = | NamedDecl.LocalDef (id, b, t) -> let b = Vars.subst_vars subst b in let t = Vars.subst_vars subst t in - id, RelDecl.LocalDef (Name id, b, t) + id, RelDecl.LocalDef (map_annot Name.mk_name id, b, t) | NamedDecl.LocalAssum (id, t) -> let t = Vars.subst_vars subst t in - id, RelDecl.LocalAssum (Name id, t) + id, RelDecl.LocalAssum (map_annot Name.mk_name id, t) in - (decl :: ctx, id :: subst) + (decl :: ctx, id.binder_name :: subst) in Context.Named.fold_outside fold hyps ~init:([], []) @@ -159,6 +160,7 @@ type result = { cook_type : types; cook_universes : universes; cook_private_univs : Univ.ContextSet.t option; + cook_relevance : Sorts.relevance; cook_inline : inline; cook_context : Constr.named_context option; } @@ -241,6 +243,7 @@ let cook_constant ~hcons { from = cb; info } = cook_type = typ; cook_universes = univs; cook_private_univs = private_univs; + cook_relevance = cb.const_relevance; cook_inline = cb.const_inline_code; cook_context = Some const_hyps; } diff --git a/kernel/cooking.mli b/kernel/cooking.mli index 89b5c60ad5..b0f143c47d 100644 --- a/kernel/cooking.mli +++ b/kernel/cooking.mli @@ -22,6 +22,7 @@ type result = { cook_type : types; cook_universes : universes; cook_private_univs : Univ.ContextSet.t option; + cook_relevance : Sorts.relevance; cook_inline : inline; cook_context : Constr.named_context option; } diff --git a/kernel/declarations.ml b/kernel/declarations.ml index 567850645e..5551742c02 100644 --- a/kernel/declarations.ml +++ b/kernel/declarations.ml @@ -91,6 +91,7 @@ type constant_body = { const_hyps : Constr.named_context; (** New: younger hyp at top *) const_body : Constr.t Mod_subst.substituted constant_def; const_type : types; + const_relevance : Sorts.relevance; const_body_code : Cemitcodes.to_patch_substituted option; const_universes : universes; const_private_poly_univs : Univ.ContextSet.t option; @@ -133,7 +134,7 @@ v} type record_info = | NotRecord | FakeRecord -| PrimRecord of (Id.t * Label.t array * types array) array +| PrimRecord of (Id.t * Label.t array * Sorts.relevance array * types array) array type regular_inductive_arity = { mind_user_arity : types; @@ -176,6 +177,8 @@ type one_inductive_body = { mind_recargs : wf_paths; (** Signature of recursive arguments in the constructors *) + mind_relevance : Sorts.relevance; + (** {8 Datas for bytecode compilation } *) mind_nb_constant : int; (** number of constant constructor *) diff --git a/kernel/declareops.ml b/kernel/declareops.ml index d56502a095..de9a052096 100644 --- a/kernel/declareops.ml +++ b/kernel/declareops.ml @@ -114,6 +114,7 @@ let subst_const_body sub cb = Option.map (Cemitcodes.subst_to_patch_subst sub) cb.const_body_code; const_universes = cb.const_universes; const_private_poly_univs = cb.const_private_poly_univs; + const_relevance = cb.const_relevance; const_inline_code = cb.const_inline_code; const_typing_flags = cb.const_typing_flags } @@ -222,6 +223,7 @@ let subst_mind_packet sub mbp = mind_nrealdecls = mbp.mind_nrealdecls; mind_kelim = mbp.mind_kelim; mind_recargs = subst_wf_paths sub mbp.mind_recargs (*wf_paths*); + mind_relevance = mbp.mind_relevance; mind_nb_constant = mbp.mind_nb_constant; mind_nb_args = mbp.mind_nb_args; mind_reloc_tbl = mbp.mind_reloc_tbl } @@ -230,10 +232,10 @@ let subst_mind_record sub r = match r with | NotRecord -> NotRecord | FakeRecord -> FakeRecord | PrimRecord infos -> - let map (id, ps, pb as info) = + let map (id, ps, rs, pb as info) = let pb' = Array.Smart.map (subst_mps sub) pb in if pb' == pb then info - else (id, ps, pb') + else (id, ps, rs, pb') in let infos' = Array.Smart.map map infos in if infos' == infos then r else PrimRecord infos' @@ -269,21 +271,32 @@ let inductive_make_projection ind mib ~proj_arg = match mib.mind_record with | NotRecord | FakeRecord -> None | PrimRecord infos -> + let _, labs, _, _ = infos.(snd ind) in Some (Names.Projection.Repr.make ind ~proj_npars:mib.mind_nparams ~proj_arg - (pi2 infos.(snd ind)).(proj_arg)) + labs.(proj_arg)) let inductive_make_projections ind mib = match mib.mind_record with | NotRecord | FakeRecord -> None | PrimRecord infos -> + let _, labs, _, _ = infos.(snd ind) in let projs = Array.mapi (fun proj_arg lab -> Names.Projection.Repr.make ind ~proj_npars:mib.mind_nparams ~proj_arg lab) - (pi2 infos.(snd ind)) + labs in Some projs +let relevance_of_projection_repr mib p = + let _mind,i = Names.Projection.Repr.inductive p in + match mib.mind_record with + | NotRecord | FakeRecord -> + CErrors.anomaly ~label:"relevance_of_projection" Pp.(str "not a projection") + | PrimRecord infos -> + let _,_,rs,_ = infos.(i) in + rs.(Names.Projection.Repr.arg p) + (** {6 Hash-consing of inductive declarations } *) let hcons_regular_ind_arity a = diff --git a/kernel/declareops.mli b/kernel/declareops.mli index 23a44433b3..54a853fc81 100644 --- a/kernel/declareops.mli +++ b/kernel/declareops.mli @@ -70,6 +70,8 @@ val inductive_make_projection : Names.inductive -> mutual_inductive_body -> proj val inductive_make_projections : Names.inductive -> mutual_inductive_body -> Names.Projection.Repr.t array option +val relevance_of_projection_repr : mutual_inductive_body -> Names.Projection.Repr.t -> Sorts.relevance + (** {6 Kernel flags} *) (** A default, safe set of flags for kernel type-checking *) diff --git a/kernel/environ.ml b/kernel/environ.ml index ab046f02f7..97c9f8654a 100644 --- a/kernel/environ.ml +++ b/kernel/environ.ml @@ -59,7 +59,8 @@ type globals = { type stratification = { env_universes : UGraph.t; - env_engagement : engagement + env_engagement : engagement; + env_sprop_allowed : bool; } type val_kind = @@ -117,7 +118,9 @@ let empty_env = { env_nb_rel = 0; env_stratification = { env_universes = UGraph.initial_universes; - env_engagement = PredicativeSet }; + env_engagement = PredicativeSet; + env_sprop_allowed = false; + }; env_typing_flags = Declareops.safe_flags Conv_oracle.empty; retroknowledge = Retroknowledge.empty; indirect_pterms = Opaqueproof.empty_opaquetab } @@ -243,7 +246,7 @@ let is_impredicative_set env = | _ -> false let is_impredicative_sort env = function - | Sorts.Prop -> true + | Sorts.SProp | Sorts.Prop -> true | Sorts.Set -> is_impredicative_set env | Sorts.Type _ -> false @@ -432,6 +435,14 @@ let set_typing_flags c env = (* Unsafe *) if same_flags env.env_typing_flags c then env else { env with env_typing_flags = c } +let make_sprop_cumulative = map_universes UGraph.make_sprop_cumulative + +let set_allow_sprop b env = + { env with env_stratification = + { env.env_stratification with env_sprop_allowed = b } } + +let sprop_allowed env = env.env_stratification.env_sprop_allowed + (* Global constants *) let no_link_info = NotLinked @@ -537,7 +548,7 @@ let lookup_projection p env = match mib.mind_record with | NotRecord | FakeRecord -> anomaly ~label:"lookup_projection" Pp.(str "not a projection") | PrimRecord infos -> - let _,_,typs = infos.(i) in + let _,_,_,typs = infos.(i) in typs.(Projection.arg p) let get_projection env ind ~proj_arg = diff --git a/kernel/environ.mli b/kernel/environ.mli index 0df9b91c4a..8c6bc105c7 100644 --- a/kernel/environ.mli +++ b/kernel/environ.mli @@ -51,7 +51,8 @@ type globals type stratification = { env_universes : UGraph.t; - env_engagement : engagement + env_engagement : engagement; + env_sprop_allowed : bool; } type named_context_val = private { @@ -290,6 +291,9 @@ val push_subgraph : Univ.ContextSet.t -> env -> env val set_engagement : engagement -> env -> env val set_typing_flags : typing_flags -> env -> env +val make_sprop_cumulative : env -> env +val set_allow_sprop : bool -> env -> env +val sprop_allowed : env -> bool val universes_of_global : env -> GlobRef.t -> AUContext.t diff --git a/kernel/indTyping.ml b/kernel/indTyping.ml index a5dafc5ab5..4e6e595331 100644 --- a/kernel/indTyping.ml +++ b/kernel/indTyping.ml @@ -122,73 +122,106 @@ let check_cumulativity univs variances env_ar params data = (************************** Type checking *******************************) (************************************************************************) -type univ_info = { ind_squashed : bool; +type univ_info = { ind_squashed : bool; ind_has_relevant_arg : bool; ind_min_univ : Universe.t option; (* Some for template *) ind_univ : Universe.t } -let check_univ_leq env u info = +let check_univ_leq ?(is_real_arg=false) env u info = let ind_univ = info.ind_univ in - if type_in_type env || (UGraph.check_leq (universes env) u ind_univ) + let info = if not info.ind_has_relevant_arg && is_real_arg && not (Univ.Universe.is_sprop u) + then {info with ind_has_relevant_arg=true} + else info + in + (* Inductive types provide explicit lifting from SProp to other universes, so allow SProp <= any. *) + if type_in_type env || Univ.Universe.is_sprop u || UGraph.check_leq (universes env) u ind_univ then { info with ind_min_univ = Option.map (Universe.sup u) info.ind_min_univ } else if is_impredicative_univ env ind_univ then if Option.is_empty info.ind_min_univ then { info with ind_squashed = true } else raise (InductiveError BadUnivs) else raise (InductiveError BadUnivs) -let check_indices_matter env_params info indices = - let check_index d (info,env) = +let check_context_univs ~ctor env info ctx = + let check_one d (info,env) = let info = match d with | LocalAssum (_,t) -> (* could be retyping if it becomes available in the kernel *) let tj = Typeops.infer_type env t in - check_univ_leq env (Sorts.univ_of_sort tj.utj_type) info + check_univ_leq ~is_real_arg:ctor env (Sorts.univ_of_sort tj.utj_type) info | LocalDef _ -> info in info, push_rel d env in + fst (Context.Rel.fold_outside ~init:(info,env) check_one ctx) + +let check_indices_matter env_params info indices = if not (indices_matter env_params) then info - else fst (Context.Rel.fold_outside ~init:(info,env_params) check_index indices) + else check_context_univs ~ctor:false env_params info indices (* env_ar contains the inductives before the current ones in the block, and no parameters *) let check_arity env_params env_ar ind = let {utj_val=arity;utj_type=_} = Typeops.infer_type env_params ind.mind_entry_arity in let indices, ind_sort = Reduction.dest_arity env_params arity in let ind_min_univ = if ind.mind_entry_template then Some Universe.type0m else None in - let univ_info = {ind_squashed=false;ind_min_univ;ind_univ=Sorts.univ_of_sort ind_sort} in + let univ_info = { + ind_squashed=false; + ind_has_relevant_arg=false; + ind_min_univ; + ind_univ=Sorts.univ_of_sort ind_sort; + } + in let univ_info = check_indices_matter env_params univ_info indices in (* We do not need to generate the universe of the arity with params; if later, after the validation of the inductive definition, full_arity is used as argument or subject to cast, an upper universe will be generated *) let arity = it_mkProd_or_LetIn arity (Environ.rel_context env_params) in - push_rel (LocalAssum (Name ind.mind_entry_typename, arity)) env_ar, + let x = Context.make_annot (Name ind.mind_entry_typename) (Sorts.relevance_of_sort ind_sort) in + push_rel (LocalAssum (x, arity)) env_ar, (arity, indices, univ_info) -let check_constructor_univs env_ar_par univ_info (args,_) = +let check_constructor_univs env_ar_par info (args,_) = (* We ignore the output, positivity will check that it's the expected inductive type *) - (* NB: very similar to check_indices_matter but that will change with SProp *) - fst (Context.Rel.fold_outside ~init:(univ_info,env_ar_par) (fun d (univ_info,env) -> - let univ_info = match d with - | LocalDef _ -> univ_info - | LocalAssum (_,t) -> - (* could be retyping if it becomes available in the kernel *) - let tj = Typeops.infer_type env t in - check_univ_leq env (Sorts.univ_of_sort tj.utj_type) univ_info - in - univ_info, push_rel d env) - args) - -let check_constructors env_ar_par params lc (arity,indices,univ_info) = + check_context_univs ~ctor:true env_ar_par info args + +let check_constructors env_ar_par isrecord params lc (arity,indices,univ_info) = let lc = Array.map_of_list (fun c -> (Typeops.infer_type env_ar_par c).utj_val) lc in let splayed_lc = Array.map (Reduction.dest_prod_assum env_ar_par) lc in - let univ_info = if Array.length lc <= 1 then univ_info - else check_univ_leq env_ar_par Univ.Universe.type0 univ_info + let univ_info = match Array.length lc with + (* Empty type: all OK *) + | 0 -> univ_info + + (* SProp primitive records are OK, if we squash and become fakerecord also OK *) + | 1 when isrecord -> univ_info + + (* Unit and identity types must squash if SProp *) + | 1 -> check_univ_leq env_ar_par Univ.Universe.type0m univ_info + + (* More than 1 constructor: must squash if Prop/SProp *) + | _ -> check_univ_leq env_ar_par Univ.Universe.type0 univ_info in let univ_info = Array.fold_left (check_constructor_univs env_ar_par) univ_info splayed_lc in (* generalize the constructors over the parameters *) let lc = Array.map (fun c -> Term.it_mkProd_or_LetIn c params) lc in (arity, lc), (indices, splayed_lc), univ_info +let check_record data = + List.for_all (fun (_,(_,splayed_lc),info) -> + (* records must have all projections definable -> equivalent to not being squashed *) + not info.ind_squashed + (* relevant records must have at least 1 relevant argument *) + && (Univ.Universe.is_sprop info.ind_univ + || info.ind_has_relevant_arg) + && (match splayed_lc with + (* records must have 1 constructor with at least 1 argument, and no anonymous fields *) + | [|ctx,_|] -> + let module D = Context.Rel.Declaration in + List.exists D.is_local_assum ctx && + List.for_all (fun d -> not (D.is_local_assum d) + || not (Name.is_anonymous (D.get_name d))) + ctx + | _ -> false)) + data + (* Allowed eliminations *) (* Previous comment: *) @@ -199,16 +232,18 @@ let check_constructors env_ar_par params lc (arity,indices,univ_info) = (* - all_sorts in case of small, unitary Prop (not smashed) *) (* - logical_sorts in case of large, unitary Prop (smashed) *) -let all_sorts = [InProp;InSet;InType] -let small_sorts = [InProp;InSet] -let logical_sorts = [InProp] +let all_sorts = [InSProp;InProp;InSet;InType] +let small_sorts = [InSProp;InProp;InSet] +let logical_sorts = [InSProp;InProp] +let sprop_sorts = [InSProp] -let allowed_sorts {ind_squashed;ind_univ;ind_min_univ=_} = +let allowed_sorts {ind_squashed;ind_univ;ind_min_univ=_;ind_has_relevant_arg=_} = if not ind_squashed then all_sorts else match Sorts.family (Sorts.sort_of_univ ind_univ) with | InType -> assert false | InSet -> small_sorts | InProp -> logical_sorts + | InSProp -> sprop_sorts (* Returns the list [x_1, ..., x_n] of levels contributing to template polymorphism. The elements x_k is None if the k-th parameter (starting @@ -268,18 +303,38 @@ let typecheck_inductive env (mie:mutual_inductive_entry) = in (* Params *) - let env_params = Typeops.check_context env_univs mie.mind_entry_params in - let params = Environ.rel_context env_params in + let env_params, params = Typeops.check_context env_univs mie.mind_entry_params in (* Arities *) let env_ar, data = List.fold_left_map (check_arity env_params) env_univs mie.mind_entry_inds in let env_ar_par = push_rel_context params env_ar in (* Constructors *) - let data = List.map2 (fun ind data -> check_constructors env_ar_par params ind.mind_entry_lc data) + let isrecord = match mie.mind_entry_record with + | Some (Some _) -> true + | Some None | None -> false + in + let data = List.map2 (fun ind data -> + check_constructors env_ar_par isrecord params ind.mind_entry_lc data) mie.mind_entry_inds data in + let record = mie.mind_entry_record in + let data, record = match record with + | None | Some None -> data, record + | Some (Some _) -> + if check_record data then + data, record + else + (* if someone tried to declare a record as SProp but it can't + be primitive we must squash. *) + let data = List.map (fun (a,b,univs) -> + a,b,check_univ_leq env_ar_par Univ.Universe.type0m univs) + data + in + data, Some None + in + let () = match mie.mind_entry_variance with | None -> () | Some variances -> @@ -298,4 +353,4 @@ let typecheck_inductive env (mie:mutual_inductive_entry) = Environ.push_rel_context ctx env in - env_ar_par, univs, mie.mind_entry_variance, params, Array.of_list data + env_ar_par, univs, mie.mind_entry_variance, record, params, Array.of_list data diff --git a/kernel/indTyping.mli b/kernel/indTyping.mli index 2598548f3f..ad51af66a2 100644 --- a/kernel/indTyping.mli +++ b/kernel/indTyping.mli @@ -17,6 +17,7 @@ open Declarations - environment with inductives + parameters in rel context - abstracted universes - checked variance info + - record entry (checked to be OK) - parameters - for each inductive, (arity * constructors) (with params) @@ -26,6 +27,7 @@ open Declarations val typecheck_inductive : env -> mutual_inductive_entry -> env * universes * Univ.Variance.t array option + * Names.Id.t array option option * Constr.rel_context * ((inductive_arity * Constr.types array) * (Constr.rel_context * (Constr.rel_context * Constr.types) array) * diff --git a/kernel/indtypes.ml b/kernel/indtypes.ml index 457c17907e..009eb3da38 100644 --- a/kernel/indtypes.ml +++ b/kernel/indtypes.ml @@ -173,7 +173,9 @@ let ienv_push_inductive (env, n, ntypes, ra_env) ((mi,u),lrecparams) = let specif = (lookup_mind_specif env mi, u) in let ty = type_of_inductive env specif in let env' = - let decl = LocalAssum (Anonymous, hnf_prod_applist env ty lrecparams) in + let r = (snd (fst specif)).mind_relevance in + let anon = Context.make_annot Anonymous r in + let decl = LocalAssum (anon, hnf_prod_applist env ty lrecparams) in push_rel decl env in let ra_env' = (Imbr mi,(Rtree.mk_rec_calls 1).(0)) :: @@ -186,8 +188,8 @@ let rec ienv_decompose_prod (env,_,_,_ as ienv) n c = if Int.equal n 0 then (ienv,c) else let c' = whd_all env c in match kind c' with - Prod(na,a,b) -> - let ienv' = ienv_push_var ienv (na,a,mk_norec) in + Prod(na,a,b) -> + let ienv' = ienv_push_var ienv (na,a,mk_norec) in ienv_decompose_prod ienv' (n-1) b | _ -> assert false @@ -215,7 +217,7 @@ let check_positivity_one ~chkpos recursive (env,_,ntypes,_ as ienv) paramsctxt ( let rec check_pos (env, n, ntypes, ra_env as ienv) nmr c = let x,largs = decompose_app (whd_all env c) in match kind x with - | Prod (na,b,d) -> + | Prod (na,b,d) -> let () = assert (List.is_empty largs) in (** If one of the inductives of the mutually inductive block occurs in the left-hand side of a product, then @@ -406,8 +408,6 @@ let used_section_variables env inds = let rel_vect n m = Array.init m (fun i -> mkRel(n+m-i)) let rel_list n m = Array.to_list (rel_vect n m) -exception UndefinableExpansion - (** From a rel context describing the constructor arguments, build an expansion function. The term built is expecting to be substituted first by @@ -433,7 +433,7 @@ let compute_projections (kn, i as ind) mib = mkRel 1 :: List.map (lift 1) subst in subst in - let projections decl (i, j, labs, pbs, letsubst) = + let projections decl (i, j, labs, rs, pbs, letsubst) = match decl with | LocalDef (_na,c,_t) -> (* From [params, field1,..,fieldj |- c(params,field1,..,fieldj)] @@ -445,10 +445,11 @@ let compute_projections (kn, i as ind) mib = (* From [params-wo-let, x:I |- subst:(params, x:I, field1,..,fieldj)] to [params-wo-let, x:I |- subst:(params, x:I, field1,..,fieldj+1)] *) let letsubst = c2 :: letsubst in - (i, j+1, labs, pbs, letsubst) + (i, j+1, labs, rs, pbs, letsubst) | LocalAssum (na,t) -> - match na with + match na.Context.binder_name with | Name id -> + let r = na.Context.binder_relevance in let lab = Label.of_id id in let kn = Projection.Repr.make ind ~proj_npars:mib.mind_nparams ~proj_arg:i lab in (* from [params, field1,..,fieldj |- t(params,field1,..,fieldj)] @@ -460,14 +461,15 @@ let compute_projections (kn, i as ind) mib = (* from [params, x:I, field1,..,fieldj |- t(field1,..,fieldj)] to [params, x:I |- t(proj1 x,..,projj x)] *) let fterm = mkProj (Projection.make kn false, mkRel 1) in - (i + 1, j + 1, lab :: labs, projty :: pbs, fterm :: letsubst) - | Anonymous -> raise UndefinableExpansion + (i + 1, j + 1, lab :: labs, r :: rs, projty :: pbs, fterm :: letsubst) + | Anonymous -> assert false (* checked by indTyping *) in - let (_, _, labs, pbs, _letsubst) = - List.fold_right projections ctx (0, 1, [], [], paramsletsubst) + let (_, _, labs, rs, pbs, _letsubst) = + List.fold_right projections ctx (0, 1, [], [], [], paramsletsubst) in - Array.of_list (List.rev labs), - Array.of_list (List.rev pbs) + Array.of_list (List.rev labs), + Array.of_list (List.rev rs), + Array.of_list (List.rev pbs) let build_inductive env names prv univs variance paramsctxt kn isrecord isfinite inds nmr recargs = let ntypes = Array.length inds in @@ -483,7 +485,11 @@ let build_inductive env names prv univs variance paramsctxt kn isrecord isfinite splayed_lc in let consnrealargs = Array.map (fun (d,_) -> Context.Rel.nhyps d) - splayed_lc in + splayed_lc in + let mind_relevance = match arity with + | RegularArity { mind_sort;_ } -> Sorts.relevance_of_sort mind_sort + | TemplateArity _ -> Sorts.Relevant + in (* Assigning VM tags to constructors *) let nconst, nblock = ref 0, ref 0 in let transf num = @@ -510,8 +516,9 @@ let build_inductive env names prv univs variance paramsctxt kn isrecord isfinite mind_consnrealargs = consnrealargs; mind_user_lc = lc; mind_nf_lc = nf_lc; - mind_recargs = recarg; - mind_nb_constant = !nconst; + mind_recargs = recarg; + mind_relevance; + mind_nb_constant = !nconst; mind_nb_args = !nblock; mind_reloc_tbl = rtbl; } in @@ -534,24 +541,12 @@ let build_inductive env names prv univs variance paramsctxt kn isrecord isfinite in let record_info = match isrecord with | Some (Some rid) -> - let is_record pkt = - if Array.length pkt.mind_consnames != 1 then - user_err ~hdr:"build_inductive" - Pp.(str "Primitive records must have exactly one constructor.") - else if pkt.mind_consnrealargs.(0) = 0 then - user_err ~hdr:"build_inductive" - Pp.(str "Primitive records must have at least one constructor argument.") - else List.exists (Sorts.family_equal Sorts.InType) pkt.mind_kelim - in (** The elimination criterion ensures that all projections can be defined. *) - if Array.for_all is_record packets then - let map i id = - let labs, projs = compute_projections (kn, i) mib in - (id, labs, projs) - in - try PrimRecord (Array.mapi map rid) - with UndefinableExpansion -> FakeRecord - else FakeRecord + let map i id = + let labs, rs, projs = compute_projections (kn, i) mib in + (id, labs, rs, projs) + in + PrimRecord (Array.mapi map rid) | Some None -> FakeRecord | None -> NotRecord in @@ -562,7 +557,7 @@ let build_inductive env names prv univs variance paramsctxt kn isrecord isfinite let check_inductive env kn mie = (* First type-check the inductive definition *) - let (env_ar_par, univs, variance, paramsctxt, inds) = IndTyping.typecheck_inductive env mie in + let (env_ar_par, univs, variance, record, paramsctxt, inds) = IndTyping.typecheck_inductive env mie in (* Then check positivity conditions *) let chkpos = (Environ.typing_flags env).check_guarded in let names = Array.map_of_list (fun entry -> entry.mind_entry_typename, entry.mind_entry_consnames) @@ -574,5 +569,5 @@ let check_inductive env kn mie = in (* Build the inductive packets *) build_inductive env names mie.mind_entry_private univs variance - paramsctxt kn mie.mind_entry_record mie.mind_entry_finite + paramsctxt kn record mie.mind_entry_finite inds nmr recargs diff --git a/kernel/inductive.ml b/kernel/inductive.ml index f4c2483c14..7452038ba5 100644 --- a/kernel/inductive.ml +++ b/kernel/inductive.ml @@ -188,13 +188,17 @@ let instantiate_universes env ctx ar argsorts = (* Non singleton type not containing types are interpretable in Set *) else if is_type0_univ level then Sorts.set (* This is a Type with constraints *) - else Sorts.Type level + else Sorts.sort_of_univ level in (ctx, ty) (* Type of an inductive type *) -let type_of_inductive_gen ?(polyprop=true) env ((_mib,mip),u) paramtyps = +let relevance_of_inductive env ind = + let _, mip = lookup_mind_specif env ind in + mip.mind_relevance + +let type_of_inductive_gen ?(polyprop=true) env ((_,mip),u) paramtyps = match mip.mind_arity with | RegularArity a -> subst_instance_constr u a.mind_user_arity | TemplateArity ar -> @@ -226,7 +230,10 @@ let type_of_inductive_knowing_parameters env ?(polyprop=true) mip args = (* The max of an array of universes *) let cumulate_constructor_univ u = let open Sorts in function - | Prop -> u + | SProp | Prop -> + (* SProp is non cumulative but allowed in constructors of any + inductive (except non-sprop primitive records) *) + u | Set -> Universe.sup Universe.type0 u | Type u' -> Universe.sup u u' @@ -298,16 +305,12 @@ let build_dependent_inductive ind (_,mip) params = @ Context.Rel.to_extended_list mkRel 0 realargs) (* This exception is local *) -exception LocalArity of (Sorts.family * Sorts.family * arity_error) option +exception LocalArity of (Sorts.family list * Sorts.family * Sorts.family * arity_error) option let check_allowed_sort ksort specif = - let open Sorts in - let eq_ksort s = match ksort, s with - | InProp, InProp | InSet, InSet | InType, InType -> true - | _ -> false in - if not (CList.exists eq_ksort (elim_sorts specif)) then + if not (CList.exists (Sorts.family_equal ksort) (elim_sorts specif)) then let s = inductive_sort_family (snd specif) in - raise (LocalArity (Some(ksort,s,error_elim_explain ksort s))) + raise (LocalArity (Some(elim_sorts specif, ksort,s,error_elim_explain ksort s))) let is_correct_arity env c pj ind specif params = let arsign,_ = get_instantiated_arity ind specif params in @@ -321,7 +324,7 @@ let is_correct_arity env c pj ind specif params = srec (push_rel (LocalAssum (na1,a1)) env) t ar' (* The last Prod domain is the type of the scrutinee *) | Prod (na1,a1,a2), [] -> (* whnf of t was not needed here! *) - let env' = push_rel (LocalAssum (na1,a1)) env in + let env' = push_rel (LocalAssum (na1,a1)) env in let ksort = match kind (whd_all env' a2) with | Sort s -> Sorts.family s | _ -> raise (LocalArity None) in @@ -337,7 +340,7 @@ let is_correct_arity env c pj ind specif params = in try srec env pj.uj_type (List.rev arsign) with LocalArity kinds -> - error_elim_arity env ind (elim_sorts specif) c pj kinds + error_elim_arity env ind c pj kinds (************************************************************************) @@ -380,13 +383,14 @@ let type_case_branches env (pind,largs) pj c = (************************************************************************) (* Checking the case annotation is relevant *) -let check_case_info env (indsp,u) ci = +let check_case_info env (indsp,u) r ci = let (mib,mip as spec) = lookup_mind_specif env indsp in if not (eq_ind indsp ci.ci_ind) || not (Int.equal mib.mind_nparams ci.ci_npar) || not (Array.equal Int.equal mip.mind_consnrealdecls ci.ci_cstr_ndecls) || not (Array.equal Int.equal mip.mind_consnrealargs ci.ci_cstr_nargs) || + not (ci.ci_relevance == r) || is_primitive_record spec then raise (TypeError(env,WrongCaseInfo((indsp,u),ci))) @@ -575,7 +579,9 @@ let ienv_push_inductive (env, ra_env) ((mind,u),lpar) = let mib = Environ.lookup_mind mind env in let ntypes = mib.mind_ntypes in let push_ind specif env = - let decl = LocalAssum (Anonymous, hnf_prod_applist env (type_of_inductive env ((mib,specif),u)) lpar) in + let r = specif.mind_relevance in + let anon = Context.make_annot Anonymous r in + let decl = LocalAssum (anon, hnf_prod_applist env (type_of_inductive env ((mib,specif),u)) lpar) in push_rel decl env in let env = Array.fold_right push_ind mib.mind_packets env in @@ -596,7 +602,8 @@ let rec ienv_decompose_prod (env,_ as ienv) n c = let dummy_univ = Level.(make (UGlobal.make (DirPath.make [Id.of_string "implicit"]) 0)) let dummy_implicit_sort = mkType (Universe.make dummy_univ) let lambda_implicit_lift n a = - let lambda_implicit a = mkLambda (Anonymous, dummy_implicit_sort, a) in + let anon = Context.make_annot Anonymous Sorts.Relevant in + let lambda_implicit a = mkLambda (anon, dummy_implicit_sort, a) in iterate lambda_implicit n (lift n a) (* This removes global parameters of the inductive types in lc (for @@ -1022,7 +1029,7 @@ let check_one_fix renv recpos trees def = check_rec_call (assign_var_spec renv (1,recArgsDecrArg)) [] body else match kind body with - | Lambda (x,a,b) -> + | Lambda (x,a,b) -> check_rec_call renv [] a; let renv' = push_var_renv renv (x,a) in check_nested_fix_body renv' (decr-1) recArgsDecrArg b @@ -1055,7 +1062,7 @@ let inductive_of_mutfix env ((nvect,bodynum),(names,types,bodies as recdef)) = match kind (whd_all env def) with | Lambda (x,a,b) -> if noccur_with_meta n nbfix a then - let env' = push_rel (LocalAssum (x,a)) env in + let env' = push_rel (LocalAssum (x,a)) env in if Int.equal n (k + 1) then (* get the inductive type of the fixpoint *) let (mind, _) = @@ -1068,8 +1075,19 @@ let inductive_of_mutfix env ((nvect,bodynum),(names,types,bodies as recdef)) = (mind, (env', b)) else check_occur env' (n+1) b else anomaly ~label:"check_one_fix" (Pp.str "Bad occurrence of recursive call.") - | _ -> raise_err env i NotEnoughAbstractionInFixBody in - check_occur fixenv 1 def in + | _ -> raise_err env i NotEnoughAbstractionInFixBody + in + let ((ind, _), _) as res = check_occur fixenv 1 def in + let _, ind = lookup_mind_specif env ind in + (* recursive sprop means non record with projections -> squashed *) + if Sorts.Irrelevant == ind.mind_relevance + then + begin + if names.(i).Context.binder_relevance == Sorts.Relevant + then raise_err env i FixpointOnIrrelevantInductive + end; + res + in (* Do it on every fixpoint *) let rv = Array.map2_i find_ind nvect bodies in (Array.map fst rv, Array.map snd rv) @@ -1112,7 +1130,7 @@ let rec codomain_is_coind env c = let b = whd_all env c in match kind b with | Prod (x,a,b) -> - codomain_is_coind (push_rel (LocalAssum (x,a)) env) b + codomain_is_coind (push_rel (LocalAssum (x,a)) env) b | _ -> (try find_coinductive env b with Not_found -> @@ -1150,7 +1168,7 @@ let check_one_cofix env nbfix def deftype = | _ -> anomaly_ill_typed () in process_args_of_constr (realargs, lra) - | Lambda (x,a,b) -> + | Lambda (x,a,b) -> let () = assert (List.is_empty args) in if noccur_with_meta n nbfix a then let env' = push_rel (LocalAssum (x,a)) env in diff --git a/kernel/inductive.mli b/kernel/inductive.mli index ad35c16c22..997a620742 100644 --- a/kernel/inductive.mli +++ b/kernel/inductive.mli @@ -45,6 +45,8 @@ val constrained_type_of_inductive : env -> mind_specif puniverses -> types const val constrained_type_of_inductive_knowing_parameters : env -> mind_specif puniverses -> types Lazy.t array -> types constrained +val relevance_of_inductive : env -> inductive -> Sorts.relevance + val type_of_inductive : env -> mind_specif puniverses -> types val type_of_inductive_knowing_parameters : @@ -93,7 +95,7 @@ val inductive_sort_family : one_inductive_body -> Sorts.family (** Check a [case_info] actually correspond to a Case expression on the given inductive type. *) -val check_case_info : env -> pinductive -> case_info -> unit +val check_case_info : env -> pinductive -> Sorts.relevance -> case_info -> unit (** {6 Guard conditions for fix and cofix-points. } *) diff --git a/kernel/kernel.mllib b/kernel/kernel.mllib index 5108744bde..59c1d5890f 100644 --- a/kernel/kernel.mllib +++ b/kernel/kernel.mllib @@ -26,6 +26,7 @@ Conv_oracle Environ Primred CClosure +Retypeops Reduction Clambda Nativelambda diff --git a/kernel/mod_typing.ml b/kernel/mod_typing.ml index 421d932d9a..2de5faa6df 100644 --- a/kernel/mod_typing.ml +++ b/kernel/mod_typing.ml @@ -80,6 +80,7 @@ let rec check_with_def env struc (idl,(c,ctx)) mp equiv = let c',cst = match cb.const_body with | Undef _ | OpaqueDef _ -> let j = Typeops.infer env' c in + assert (j.uj_val == c); (* relevances should already be correct here *) let typ = cb.const_type in let cst' = Reduction.infer_conv_leq env' (Environ.universes env') j.uj_type typ in @@ -101,6 +102,7 @@ let rec check_with_def env struc (idl,(c,ctx)) mp equiv = let cst = match cb.const_body with | Undef _ | OpaqueDef _ -> let j = Typeops.infer env' c in + assert (j.uj_val == c); (* relevances should already be correct here *) let typ = cb.const_type in let cst' = Reduction.infer_conv_leq env' (Environ.universes env') j.uj_type typ in diff --git a/kernel/nativecode.ml b/kernel/nativecode.ml index df60899b95..2dab14e732 100644 --- a/kernel/nativecode.ml +++ b/kernel/nativecode.ml @@ -11,6 +11,7 @@ open CErrors open Names open Constr +open Context open Declarations open Util open Nativevalues @@ -763,7 +764,7 @@ let empty_env univ () = } let push_rel env id = - let local = fresh_lname id in + let local = fresh_lname id.binder_name in local, { env with env_rel = MLlocal local :: env.env_rel; env_bound = env.env_bound + 1 @@ -772,7 +773,7 @@ let push_rel env id = let push_rels env ids = let lnames, env_rel = Array.fold_left (fun (names,env_rel) id -> - let local = fresh_lname id in + let local = fresh_lname id.binder_name in (local::names, MLlocal local::env_rel)) ([],env.env_rel) ids in Array.of_list (List.rev lnames), { env with env_rel = env_rel; @@ -1945,7 +1946,7 @@ let compile_mind mb mind stack = let tbl = ob.mind_reloc_tbl in (* Building info *) let ci = { ci_ind = ind; ci_npar = nparams; - ci_cstr_nargs = [|0|]; + ci_cstr_nargs = [|0|]; ci_relevance = ob.mind_relevance; ci_cstr_ndecls = [||] (*FIXME*); ci_pp_info = { ind_tags = []; cstr_tags = [||] (*FIXME*); style = RegularStyle } } in let asw = { asw_ind = ind; asw_prefix = ""; asw_ci = ci; @@ -1968,7 +1969,7 @@ let compile_mind mb mind stack = let projs = match mb.mind_record with | NotRecord | FakeRecord -> [] | PrimRecord info -> - let _, _, pbs = info.(i) in + let _, _, _, pbs = info.(i) in Array.fold_left_i add_proj [] pbs in projs @ constructors @ gtype :: accu :: stack diff --git a/kernel/nativelambda.ml b/kernel/nativelambda.ml index 0869f94042..ec3a7b893d 100644 --- a/kernel/nativelambda.ml +++ b/kernel/nativelambda.ml @@ -26,9 +26,9 @@ type lambda = | Lmeta of metavariable * lambda (* type *) | Levar of Evar.t * lambda array (* arguments *) | Lprod of lambda * lambda - | Llam of Name.t array * lambda - | Lrec of Name.t * lambda - | Llet of Name.t * lambda * lambda + | Llam of Name.t Context.binder_annot array * lambda + | Lrec of Name.t Context.binder_annot * lambda + | Llet of Name.t Context.binder_annot * lambda * lambda | Lapp of lambda * lambda array | Lconst of prefix * pconstant | Lproj of prefix * inductive * int (* prefix, inductive, index starting from 0 *) @@ -51,9 +51,9 @@ type lambda = | Llazy | Lforce -and lam_branches = (constructor * Name.t array * lambda) array +and lam_branches = (constructor * Name.t Context.binder_annot array * lambda) array -and fix_decl = Name.t array * lambda array * lambda array +and fix_decl = Name.t Context.binder_annot array * lambda array * lambda array type evars = { evars_val : existential -> constr option; @@ -362,7 +362,8 @@ let prim env kn p args = Lprim(prefix, kn, p, args) let expand_prim env kn op arity = - let ids = Array.make arity Anonymous in + (* primitives are always Relevant *) + let ids = Array.make arity Context.anonR in let args = make_args arity 1 in Llam(ids, prim env kn op args) @@ -395,7 +396,7 @@ module Cache = let get_construct_info cache env c : constructor_info = try ConstrTable.find cache c - with Not_found -> + with Not_found -> let ((mind,j), i) = c in let oib = lookup_mind mind env in let oip = oib.mind_packets.(j) in @@ -518,8 +519,10 @@ let rec lambda_of_constr cache env sigma c = else match b with | Llam(ids, body) when Int.equal (Array.length ids) arity -> (cn, ids, body) - | _ -> - let ids = Array.make arity Anonymous in + | _ -> + (** TODO relevance *) + let anon = Context.make_annot Anonymous Sorts.Relevant in + let ids = Array.make arity anon in let args = make_args arity 1 in let ll = lam_lift arity b in (cn, ids, mkLapp ll args) in diff --git a/kernel/nativelambda.mli b/kernel/nativelambda.mli index eb06522a33..b0de257a27 100644 --- a/kernel/nativelambda.mli +++ b/kernel/nativelambda.mli @@ -21,9 +21,9 @@ type lambda = | Lmeta of metavariable * lambda (* type *) | Levar of Evar.t * lambda array (* arguments *) | Lprod of lambda * lambda - | Llam of Name.t array * lambda - | Lrec of Name.t * lambda - | Llet of Name.t * lambda * lambda + | Llam of Name.t Context.binder_annot array * lambda + | Lrec of Name.t Context.binder_annot * lambda + | Llet of Name.t Context.binder_annot * lambda * lambda | Lapp of lambda * lambda array | Lconst of prefix * pconstant | Lproj of prefix * inductive * int (* prefix, inductive, index starting from 0 *) @@ -45,9 +45,9 @@ type lambda = | Llazy | Lforce -and lam_branches = (constructor * Name.t array * lambda) array +and lam_branches = (constructor * Name.t Context.binder_annot array * lambda) array -and fix_decl = Name.t array * lambda array * lambda array +and fix_decl = Name.t Context.binder_annot array * lambda array * lambda array type evars = { evars_val : existential -> constr option; @@ -55,8 +55,8 @@ type evars = val empty_evars : evars -val decompose_Llam : lambda -> Name.t array * lambda -val decompose_Llam_Llet : lambda -> (Name.t * lambda option) array * lambda +val decompose_Llam : lambda -> Name.t Context.binder_annot array * lambda +val decompose_Llam_Llet : lambda -> (Name.t Context.binder_annot * lambda option) array * lambda val is_lazy : constr -> bool val mk_lazy : lambda -> lambda diff --git a/kernel/nativevalues.ml b/kernel/nativevalues.ml index a6b48cd7e3..3eb51ffc59 100644 --- a/kernel/nativevalues.ml +++ b/kernel/nativevalues.ml @@ -117,11 +117,11 @@ let mk_ind_accu ind u = let mk_sort_accu s u = let open Sorts in match s with - | Prop | Set -> mk_accu (Asort s) + | SProp | Prop | Set -> mk_accu (Asort s) | Type s -> let u = Univ.Instance.of_array u in - let s = Univ.subst_instance_universe u s in - mk_accu (Asort (Type s)) + let s = Sorts.sort_of_univ (Univ.subst_instance_universe u s) in + mk_accu (Asort s) let mk_var_accu id = mk_accu (Avar id) diff --git a/kernel/reduction.ml b/kernel/reduction.ml index b583d33e29..2f11f3dd6b 100644 --- a/kernel/reduction.ml +++ b/kernel/reduction.ml @@ -193,8 +193,6 @@ type 'a extended_conversion_function = 'a -> 'a -> unit exception NotConvertible -exception NotConvertibleVect of int - (* Convertibility of sorts *) @@ -293,12 +291,6 @@ let conv_table_key infos k1 k2 cuniv = exception IrregularPatternShape -let rec skip_pattern n c = - if Int.equal n 0 then c - else match kind c with - | Lambda (_, _, c) -> skip_pattern (pred n) c - | _ -> raise IrregularPatternShape - let unfold_ref_with_args infos tab fl v = match unfold_reference infos tab fl with | Def def -> Some (def, v) @@ -310,6 +302,7 @@ let unfold_ref_with_args infos tab fl v = type conv_tab = { cnv_inf : clos_infos; + relevances : Sorts.relevance list; lft_tab : clos_tab; rgt_tab : clos_tab; } @@ -319,9 +312,23 @@ type conv_tab = { (** The same heap separation invariant must hold for the fconstr arguments passed to each respective side of the conversion function below. *) +let push_relevance infos r = + { infos with relevances = r.Context.binder_relevance :: infos.relevances } + +let rec skip_pattern infos n c1 c2 = + if Int.equal n 0 then infos, c1, c2 + else match kind c1, kind c2 with + | Lambda (x, _, c1), Lambda (_, _, c2) -> skip_pattern (push_relevance infos x) (pred n) c1 c2 + | _ -> raise IrregularPatternShape + +let is_irrelevant infos lft c = + let env = info_env infos.cnv_inf in + try Retypeops.relevance_of_fterm env infos.relevances lft c == Sorts.Irrelevant with _ -> false + (* Conversion between [lft1]term1 and [lft2]term2 *) let rec ccnv cv_pb l2r infos lft1 lft2 term1 term2 cuniv = - eqappr cv_pb l2r infos (lft1, (term1,[])) (lft2, (term2,[])) cuniv + try eqappr cv_pb l2r infos (lft1, (term1,[])) (lft2, (term2,[])) cuniv + with NotConvertible when is_irrelevant infos lft1 term1 && is_irrelevant infos lft2 term2 -> cuniv (* Conversion between [lft1](hd1 v1) and [lft2](hd2 v2) *) and eqappr cv_pb l2r infos (lft1,st1) (lft2,st2) cuniv = @@ -399,14 +406,14 @@ and eqappr cv_pb l2r infos (lft1,st1) (lft2,st2) cuniv = match unfold_projection infos.cnv_inf p2 with | Some s2 -> eqappr cv_pb l2r infos appr1 (lft2, (c2, (s2 :: v2))) cuniv - | None -> + | None -> if Projection.Repr.equal (Projection.repr p1) (Projection.repr p2) - && compare_stack_shape v1 v2 then + && compare_stack_shape v1 v2 then let el1 = el_stack lft1 v1 in let el2 = el_stack lft2 v2 in let u1 = ccnv CONV l2r infos el1 el2 c1 c2 cuniv in convert_stacks l2r infos lft1 lft2 v1 v2 u1 - else (* Two projections in WHNF: unfold *) + else (* Two projections in WHNF: unfold *) raise NotConvertible) | (FProj (p1,c1), t2) -> @@ -446,22 +453,22 @@ and eqappr cv_pb l2r infos (lft1,st1) (lft2,st2) cuniv = (* Inconsistency: we tolerate that v1, v2 contain shift and update but we throw them away *) if not (is_empty_stack v1 && is_empty_stack v2) then - anomaly (Pp.str "conversion was given ill-typed terms (FLambda)."); - let (_,ty1,bd1) = destFLambda mk_clos hd1 in + anomaly (Pp.str "conversion was given ill-typed terms (FLambda)."); + let (x1,ty1,bd1) = destFLambda mk_clos hd1 in let (_,ty2,bd2) = destFLambda mk_clos hd2 in let el1 = el_stack lft1 v1 in let el2 = el_stack lft2 v2 in let cuniv = ccnv CONV l2r infos el1 el2 ty1 ty2 cuniv in - ccnv CONV l2r infos (el_lift el1) (el_lift el2) bd1 bd2 cuniv + ccnv CONV l2r (push_relevance infos x1) (el_lift el1) (el_lift el2) bd1 bd2 cuniv - | (FProd (_, c1, c2, e), FProd (_, c'1, c'2, e')) -> + | (FProd (x1, c1, c2, e), FProd (_, c'1, c'2, e')) -> if not (is_empty_stack v1 && is_empty_stack v2) then anomaly (Pp.str "conversion was given ill-typed terms (FProd)."); (* Luo's system *) let el1 = el_stack lft1 v1 in let el2 = el_stack lft2 v2 in let cuniv = ccnv CONV l2r infos el1 el2 c1 c'1 cuniv in - ccnv cv_pb l2r infos (el_lift el1) (el_lift el2) (mk_clos (subs_lift e) c2) (mk_clos (subs_lift e') c'2) cuniv + ccnv cv_pb l2r (push_relevance infos x1) (el_lift el1) (el_lift el2) (mk_clos (subs_lift e) c2) (mk_clos (subs_lift e') c'2) cuniv (* Eta-expansion on the fly *) | (FLambda _, _) -> @@ -470,19 +477,21 @@ and eqappr cv_pb l2r infos (lft1,st1) (lft2,st2) cuniv = | _ -> anomaly (Pp.str "conversion was given unreduced term (FLambda).") in - let (_,_ty1,bd1) = destFLambda mk_clos hd1 in + let (x1,_ty1,bd1) = destFLambda mk_clos hd1 in + let infos = push_relevance infos x1 in eqappr CONV l2r infos - (el_lift lft1, (bd1, [])) (el_lift lft2, (hd2, eta_expand_stack v2)) cuniv + (el_lift lft1, (bd1, [])) (el_lift lft2, (hd2, eta_expand_stack v2)) cuniv | (_, FLambda _) -> let () = match v2 with | [] -> () | _ -> anomaly (Pp.str "conversion was given unreduced term (FLambda).") in - let (_,_ty2,bd2) = destFLambda mk_clos hd2 in + let (x2,_ty2,bd2) = destFLambda mk_clos hd2 in + let infos = push_relevance infos x2 in eqappr CONV l2r infos - (el_lift lft1, (hd1, eta_expand_stack v1)) (el_lift lft2, (bd2, [])) cuniv - + (el_lift lft1, (hd1, eta_expand_stack v1)) (el_lift lft2, (bd2, [])) cuniv + (* only one constant, defined var or defined rel *) | (FFlex fl1, c2) -> begin match unfold_ref_with_args infos.cnv_inf infos.lft_tab fl1 v1 with @@ -568,8 +577,8 @@ and eqappr cv_pb l2r infos (lft1,st1) (lft2,st2) cuniv = in convert_stacks l2r infos lft1 lft2 v1 v2 cuniv with Not_found -> raise NotConvertible) - | (FFix (((op1, i1),(_,tys1,cl1)),e1), FFix(((op2, i2),(_,tys2,cl2)),e2)) -> - if Int.equal i1 i2 && Array.equal Int.equal op1 op2 + | (FFix (((op1, i1),(na1,tys1,cl1)),e1), FFix(((op2, i2),(_,tys2,cl2)),e2)) -> + if Int.equal i1 i2 && Array.equal Int.equal op1 op2 then let n = Array.length cl1 in let fty1 = Array.map (mk_clos e1) tys1 in @@ -580,12 +589,14 @@ and eqappr cv_pb l2r infos (lft1,st1) (lft2,st2) cuniv = let el2 = el_stack lft2 v2 in let cuniv = convert_vect l2r infos el1 el2 fty1 fty2 cuniv in let cuniv = + let infos = Array.fold_left push_relevance infos na1 in convert_vect l2r infos - (el_liftn n el1) (el_liftn n el2) fcl1 fcl2 cuniv in + (el_liftn n el1) (el_liftn n el2) fcl1 fcl2 cuniv + in convert_stacks l2r infos lft1 lft2 v1 v2 cuniv else raise NotConvertible - | (FCoFix ((op1,(_,tys1,cl1)),e1), FCoFix((op2,(_,tys2,cl2)),e2)) -> + | (FCoFix ((op1,(na1,tys1,cl1)),e1), FCoFix((op2,(_,tys2,cl2)),e2)) -> if Int.equal op1 op2 then let n = Array.length cl1 in @@ -597,8 +608,10 @@ and eqappr cv_pb l2r infos (lft1,st1) (lft2,st2) cuniv = let el2 = el_stack lft2 v2 in let cuniv = convert_vect l2r infos el1 el2 fty1 fty2 cuniv in let cuniv = + let infos = Array.fold_left push_relevance infos na1 in convert_vect l2r infos - (el_liftn n el1) (el_liftn n el2) fcl1 fcl2 cuniv in + (el_liftn n el1) (el_liftn n el2) fcl1 fcl2 cuniv + in convert_stacks l2r infos lft1 lft2 v1 v2 cuniv else raise NotConvertible @@ -662,8 +675,8 @@ and convert_vect l2r infos lft1 lft2 v1 v2 cuniv = and convert_branches l2r infos ci e1 e2 lft1 lft2 br1 br2 cuniv = (** Skip comparison of the pattern types. We know that the two terms are living in a common type, thus this check is useless. *) - let fold n c1 c2 cuniv = match skip_pattern n c1, skip_pattern n c2 with - | (c1, c2) -> + let fold n c1 c2 cuniv = match skip_pattern infos n c1 c2 with + | (infos, c1, c2) -> let lft1 = el_liftn n lft1 in let lft2 = el_liftn n lft2 in let e1 = subs_liftn n e1 in @@ -680,6 +693,7 @@ let clos_gen_conv trans cv_pb l2r evars env univs t1 t2 = let infos = create_clos_infos ~evars reds env in let infos = { cnv_inf = infos; + relevances = List.map Context.Rel.Declaration.get_relevance (rel_context env); lft_tab = create_tab (); rgt_tab = create_tab (); } in @@ -701,7 +715,8 @@ let check_sort_cmp_universes env pb s0 s1 univs = | CONV -> check_eq univs u0 u1 in match (s0,s1) with - | Prop, Prop | Set, Set -> () + | SProp, SProp | Prop, Prop | Set, Set -> () + | SProp, _ | _, SProp -> raise NotConvertible | Prop, (Set | Type _) -> if not (is_cumul pb) then raise NotConvertible | Set, Prop -> raise NotConvertible | Set, Type u -> check_pb Univ.type0_univ u @@ -749,7 +764,8 @@ let infer_cmp_universes env pb s0 s1 univs = | CONV -> infer_eq univs u0 u1 in match (s0,s1) with - | Prop, Prop | Set, Set -> univs + | SProp, SProp | Prop, Prop | Set, Set -> univs + | SProp, _ | _, SProp -> raise NotConvertible | Prop, (Set | Type _) -> if not (is_cumul pb) then raise NotConvertible else univs | Set, Prop -> raise NotConvertible | Set, Type u -> infer_pb Univ.type0_univ u @@ -894,7 +910,7 @@ let dest_prod env = let t = whd_all env c in match kind t with | Prod (n,a,c0) -> - let d = LocalAssum (n,a) in + let d = LocalAssum (n,a) in decrec (push_rel d env) (Context.Rel.add d m) c0 | _ -> m,t in diff --git a/kernel/reduction.mli b/kernel/reduction.mli index 0408dbf057..7dcafb7d7b 100644 --- a/kernel/reduction.mli +++ b/kernel/reduction.mli @@ -27,7 +27,6 @@ val nf_betaiota : env -> constr -> constr s conversion functions *) exception NotConvertible -exception NotConvertibleVect of int type 'a kernel_conversion_function = env -> 'a -> 'a -> unit type 'a extended_conversion_function = diff --git a/kernel/retypeops.ml b/kernel/retypeops.ml new file mode 100644 index 0000000000..204dec3eda --- /dev/null +++ b/kernel/retypeops.ml @@ -0,0 +1,116 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +open Util +open Names +open Constr +open Declarations +open Environ +open Context + +module RelDecl = Context.Rel.Declaration + +let relevance_of_rel env n = + let decl = lookup_rel n env in + RelDecl.get_relevance decl + +let relevance_of_var env x = + let decl = lookup_named x env in + Context.Named.Declaration.get_relevance decl + +let relevance_of_constant env c = + let decl = lookup_constant c env in + decl.const_relevance + +let relevance_of_constructor env ((mi,i),_) = + let decl = lookup_mind mi env in + let packet = decl.mind_packets.(i) in + packet.mind_relevance + +let relevance_of_projection env p = + let mind = Projection.mind p in + let mib = lookup_mind mind env in + Declareops.relevance_of_projection_repr mib (Projection.repr p) + +let rec relevance_of_rel_extra env extra n = + match extra with + | [] -> relevance_of_rel env n + | r :: _ when Int.equal n 1 -> r + | _ :: extra -> relevance_of_rel_extra env extra (n-1) + +let relevance_of_flex env extra lft = function + | ConstKey (c,_) -> relevance_of_constant env c + | VarKey x -> relevance_of_var env x + | RelKey p -> relevance_of_rel_extra env extra (Esubst.reloc_rel p lft) + +let rec relevance_of_fterm env extra lft f = + let open CClosure in + match CClosure.relevance_of f with + | KnownR -> Sorts.Relevant + | KnownI -> Sorts.Irrelevant + | Unknown -> + let r = match fterm_of f with + | FRel n -> relevance_of_rel_extra env extra (Esubst.reloc_rel n lft) + | FAtom c -> relevance_of_term_extra env extra lft (Esubst.subs_id 0) c + | FFlex key -> relevance_of_flex env extra lft key + | FInt _ -> Sorts.Relevant + | FInd _ | FProd _ -> Sorts.Relevant (* types are always relevant *) + | FConstruct (c,_) -> relevance_of_constructor env c + | FApp (f, _) -> relevance_of_fterm env extra lft f + | FProj (p, _) -> relevance_of_projection env p + | FFix (((_,i),(lna,_,_)), _) -> (lna.(i)).binder_relevance + | FCoFix ((i,(lna,_,_)), _) -> (lna.(i)).binder_relevance + | FCaseT (ci, _, _, _, _) -> ci.ci_relevance + | FLambda (len, tys, bdy, e) -> + let extra = List.rev_append (List.map (fun (x,_) -> binder_relevance x) tys) extra in + let lft = Esubst.el_liftn len lft in + relevance_of_term_extra env extra lft e bdy + | FLetIn (x, _, _, bdy, e) -> + relevance_of_term_extra env (x.binder_relevance :: extra) + (Esubst.el_lift lft) (Esubst.subs_lift e) bdy + | FLIFT (k, f) -> relevance_of_fterm env extra (Esubst.el_shft k lft) f + | FCLOS (c, e) -> relevance_of_term_extra env extra lft e c + + | FEvar (_, _) -> Sorts.Relevant (* let's assume evars are relevant for now *) + | FLOCKED -> assert false + in + CClosure.set_relevance r f; + r + +and relevance_of_term_extra env extra lft subs c = + match kind c with + | Rel n -> + (match Esubst.expand_rel n subs with + | Inl (k, f) -> relevance_of_fterm env extra (Esubst.el_liftn k lft) f + | Inr (n, _) -> relevance_of_rel_extra env extra (Esubst.reloc_rel n lft)) + | Var x -> relevance_of_var env x + | Sort _ | Ind _ | Prod _ -> Sorts.Relevant (* types are always relevant *) + | Cast (c, _, _) -> relevance_of_term_extra env extra lft subs c + | Lambda ({binder_relevance=r;_}, _, bdy) -> + relevance_of_term_extra env (r::extra) (Esubst.el_lift lft) (Esubst.subs_lift subs) bdy + | LetIn ({binder_relevance=r;_}, _, _, bdy) -> + relevance_of_term_extra env (r::extra) (Esubst.el_lift lft) (Esubst.subs_lift subs) bdy + | App (c, _) -> relevance_of_term_extra env extra lft subs c + | Const (c,_) -> relevance_of_constant env c + | Construct (c,_) -> relevance_of_constructor env c + | Case (ci, _, _, _) -> ci.ci_relevance + | Fix ((_,i),(lna,_,_)) -> (lna.(i)).binder_relevance + | CoFix (i,(lna,_,_)) -> (lna.(i)).binder_relevance + | Proj (p, _) -> relevance_of_projection env p + | Int _ -> Sorts.Relevant + + | Meta _ | Evar _ -> Sorts.Relevant (* let's assume metas and evars are relevant for now *) + +let relevance_of_fterm env extra lft c = + if Environ.sprop_allowed env then relevance_of_fterm env extra lft c + else Sorts.Relevant + +let relevance_of_term env c = + if Environ.sprop_allowed env + then relevance_of_term_extra env [] Esubst.el_id (Esubst.subs_id 0) c + else Sorts.Relevant diff --git a/kernel/retypeops.mli b/kernel/retypeops.mli new file mode 100644 index 0000000000..f30c541c3f --- /dev/null +++ b/kernel/retypeops.mli @@ -0,0 +1,26 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(** We can take advantage of non-cumulativity of SProp to avoid fully + retyping terms when we just want to know if they inhabit some + proof-irrelevant type. *) + +val relevance_of_term : Environ.env -> Constr.constr -> Sorts.relevance + +val relevance_of_fterm : Environ.env -> Sorts.relevance list -> + Esubst.lift -> CClosure.fconstr -> + Sorts.relevance + + +(** Helpers *) +open Names +val relevance_of_rel_extra : Environ.env -> Sorts.relevance list -> int -> Sorts.relevance +val relevance_of_var : Environ.env -> Id.t -> Sorts.relevance +val relevance_of_constant : Environ.env -> Constant.t -> Sorts.relevance +val relevance_of_constructor : Environ.env -> constructor -> Sorts.relevance +val relevance_of_projection : Environ.env -> Projection.t -> Sorts.relevance diff --git a/kernel/safe_typing.ml b/kernel/safe_typing.ml index a05f7b9b04..673f025c75 100644 --- a/kernel/safe_typing.ml +++ b/kernel/safe_typing.ml @@ -211,6 +211,10 @@ let set_native_compiler b senv = let flags = Environ.typing_flags senv.env in set_typing_flags { flags with enable_native_compiler = b } senv +let make_sprop_cumulative senv = { senv with env = Environ.make_sprop_cumulative senv.env } + +let set_allow_sprop b senv = { senv with env = Environ.set_allow_sprop b senv.env } + (** Check that the engagement [c] expected by a library matches the current (initial) one *) let check_engagement env expected_impredicative_set = @@ -437,14 +441,16 @@ let safe_push_named d env = let push_named_def (id,de) senv = - let c, typ = Term_typing.translate_local_def senv.env id de in - let env'' = safe_push_named (LocalDef (id, c, typ)) senv.env in + let c, r, typ = Term_typing.translate_local_def senv.env id de in + let x = Context.make_annot id r in + let env'' = safe_push_named (LocalDef (x, c, typ)) senv.env in { senv with env = env'' } let push_named_assum ((id,t,poly),ctx) senv = let senv' = push_context_set poly ctx senv in - let t = Term_typing.translate_local_assum senv'.env t in - let env'' = safe_push_named (LocalAssum (id,t)) senv'.env in + let t, r = Term_typing.translate_local_assum senv'.env t in + let x = Context.make_annot id r in + let env'' = safe_push_named (LocalAssum (x,t)) senv'.env in {senv' with env=env''} @@ -603,7 +609,7 @@ let inline_side_effects env body side_eff = if List.is_empty side_eff then (body, Univ.ContextSet.empty, sigs) else (** Second step: compute the lifts and substitutions to apply *) - let cname c = Name (Label.to_id (Constant.label c)) in + let cname c r = Context.make_annot (Name (Label.to_id (Constant.label c))) r in let fold (subst, var, ctx, args) (c, cb, b) = let (b, opaque) = match cb.const_body, b with | Def b, _ -> (Mod_subst.force_constr b, false) @@ -616,7 +622,7 @@ let inline_side_effects env body side_eff = let ty = cb.const_type in let subst = Cmap_env.add c (Inr var) subst in let ctx = Univ.ContextSet.union ctx univs in - (subst, var + 1, ctx, (cname c, b, ty, opaque) :: args) + (subst, var + 1, ctx, (cname c cb.const_relevance, b, ty, opaque) :: args) | Polymorphic _ -> (** Inline the term to emulate universe polymorphism *) let subst = Cmap_env.add c (Inl b) subst in @@ -836,7 +842,7 @@ let check_mind mie lab = let add_mind l mie senv = let () = check_mind mie l in let kn = MutInd.make2 senv.modpath l in - let mib = Term_typing.translate_mind senv.env kn mie in + let mib = Indtypes.check_inductive senv.env kn mie in let mib = match mib.mind_hyps with [] -> Declareops.hcons_mind mib | _ -> mib in @@ -1239,7 +1245,7 @@ let check_register_ind ind r env = check_if (Constr.is_Type d) s; check_if (Constr.equal - (mkProd (Anonymous,mkRel 1, mkApp (mkRel 3,[|mkRel 2|]))) + (mkProd (Context.anonR,mkRel 1, mkApp (mkRel 3,[|mkRel 2|]))) cd) s in check_name 0 "C0"; diff --git a/kernel/safe_typing.mli b/kernel/safe_typing.mli index 8539fdd504..46c97c1fb8 100644 --- a/kernel/safe_typing.mli +++ b/kernel/safe_typing.mli @@ -141,6 +141,8 @@ val set_typing_flags : Declarations.typing_flags -> safe_transformer0 val set_share_reduction : bool -> safe_transformer0 val set_VM : bool -> safe_transformer0 val set_native_compiler : bool -> safe_transformer0 +val make_sprop_cumulative : safe_transformer0 +val set_allow_sprop : bool -> safe_transformer0 val check_engagement : Environ.env -> Declarations.set_predicativity -> unit diff --git a/kernel/sorts.ml b/kernel/sorts.ml index 566dce04c6..09c98ca1bc 100644 --- a/kernel/sorts.ml +++ b/kernel/sorts.ml @@ -10,13 +10,15 @@ open Univ -type family = InProp | InSet | InType +type family = InSProp | InProp | InSet | InType type t = + | SProp | Prop | Set | Type of Universe.t +let sprop = SProp let prop = Prop let set = Set let type1 = Type type1_univ @@ -25,15 +27,20 @@ let univ_of_sort = function | Type u -> u | Set -> Universe.type0 | Prop -> Universe.type0m + | SProp -> Universe.sprop let sort_of_univ u = - if is_type0m_univ u then prop + if Universe.is_sprop u then sprop + else if is_type0m_univ u then prop else if is_type0_univ u then set else Type u let compare s1 s2 = if s1 == s2 then 0 else match s1, s2 with + | SProp, SProp -> 0 + | SProp, _ -> -1 + | _, SProp -> 1 | Prop, Prop -> 0 | Prop, _ -> -1 | Set, Prop -> 1 @@ -44,34 +51,52 @@ let compare s1 s2 = let equal s1 s2 = Int.equal (compare s1 s2) 0 +let super = function + | SProp | Prop | Set -> Type (Universe.type1) + | Type u -> Type (Universe.super u) + +let is_sprop = function + | SProp -> true + | Prop | Set | Type _ -> false + let is_prop = function | Prop -> true - | Type u when Universe.equal Universe.type0m u -> true - | _ -> false + | SProp | Set | Type _ -> false let is_set = function | Set -> true - | Type u when Universe.equal Universe.type0 u -> true - | _ -> false + | SProp | Prop | Type _ -> false let is_small = function - | Prop | Set -> true - | Type u -> is_small_univ u + | SProp | Prop | Set -> true + | Type _ -> false let family = function + | SProp -> InSProp | Prop -> InProp | Set -> InSet - | Type u when is_type0m_univ u -> InProp - | Type u when is_type0_univ u -> InSet | Type _ -> InType +let family_compare a b = match a,b with + | InSProp, InSProp -> 0 + | InSProp, _ -> -1 + | _, InSProp -> 1 + | InProp, InProp -> 0 + | InProp, _ -> -1 + | _, InProp -> 1 + | InSet, InSet -> 0 + | InSet, _ -> -1 + | _, InSet -> 1 + | InType, InType -> 0 + let family_equal = (==) open Hashset.Combine let hash = function - | Prop -> combinesmall 1 0 - | Set -> combinesmall 1 1 + | SProp -> combinesmall 1 0 + | Prop -> combinesmall 1 1 + | Set -> combinesmall 1 2 | Type u -> let h = Univ.Universe.hash u in combinesmall 2 h @@ -103,12 +128,33 @@ module Hsorts = let hcons = Hashcons.simple_hcons Hsorts.generate Hsorts.hcons hcons_univ +(** On binders: is this variable proof relevant *) +type relevance = Relevant | Irrelevant + +let relevance_equal r1 r2 = match r1,r2 with + | Relevant, Relevant | Irrelevant, Irrelevant -> true + | (Relevant | Irrelevant), _ -> false + +let relevance_of_sort_family = function + | InSProp -> Irrelevant + | _ -> Relevant + +let relevance_hash = function + | Relevant -> 0 + | Irrelevant -> 1 + +let relevance_of_sort = function + | SProp -> Irrelevant + | _ -> Relevant + let debug_print = function - | Set -> Pp.(str "Set") + | SProp -> Pp.(str "SProp") | Prop -> Pp.(str "Prop") + | Set -> Pp.(str "Set") | Type u -> Pp.(str "Type(" ++ Univ.Universe.pr u ++ str ")") let pr_sort_family = function - | InSet -> Pp.(str "Set") + | InSProp -> Pp.(str "SProp") | InProp -> Pp.(str "Prop") + | InSet -> Pp.(str "Set") | InType -> Pp.(str "Type") diff --git a/kernel/sorts.mli b/kernel/sorts.mli index 6c5ce4df80..c49728b146 100644 --- a/kernel/sorts.mli +++ b/kernel/sorts.mli @@ -10,13 +10,15 @@ (** {6 The sorts of CCI. } *) -type family = InProp | InSet | InType +type family = InSProp | InProp | InSet | InType -type t = +type t = private + | SProp | Prop | Set | Type of Univ.Universe.t +val sprop : t val set : t val prop : t val type1 : t @@ -25,6 +27,7 @@ val equal : t -> t -> bool val compare : t -> t -> int val hash : t -> int +val is_sprop : t -> bool val is_set : t -> bool val is_prop : t -> bool val is_small : t -> bool @@ -32,6 +35,7 @@ val family : t -> family val hcons : t -> t +val family_compare : family -> family -> int val family_equal : family -> family -> bool module List : sig @@ -42,6 +46,18 @@ end val univ_of_sort : t -> Univ.Universe.t val sort_of_univ : Univ.Universe.t -> t +val super : t -> t + +(** On binders: is this variable proof relevant *) +type relevance = Relevant | Irrelevant + +val relevance_hash : relevance -> int + +val relevance_equal : relevance -> relevance -> bool + +val relevance_of_sort : t -> relevance +val relevance_of_sort_family : family -> relevance + val debug_print : t -> Pp.t val pr_sort_family : family -> Pp.t diff --git a/kernel/subtyping.ml b/kernel/subtyping.ml index dea72e8b59..1857ea3329 100644 --- a/kernel/subtyping.ml +++ b/kernel/subtyping.ml @@ -23,6 +23,7 @@ open Declareops open Reduction open Inductive open Modops +open Context open Mod_subst (*i*) @@ -190,8 +191,8 @@ let check_inductive cst env mp1 l info1 mp2 mib2 spec2 subst1 subst2 reso1 reso2 check (fun mib -> mib.mind_record <> NotRecord) (==) (fun x -> RecordFieldExpected x); if mib1.mind_record <> NotRecord then begin let rec names_prod_letin t = match kind t with - | Prod(n,_,t) -> n::(names_prod_letin t) - | LetIn(n,_,_,t) -> n::(names_prod_letin t) + | Prod(n,_,t) -> n.binder_name::(names_prod_letin t) + | LetIn(n,_,_,t) -> n.binder_name::(names_prod_letin t) | Cast(t,_,_) -> names_prod_letin t | _ -> [] in diff --git a/kernel/term.ml b/kernel/term.ml index 58b289eaa5..f09c45715f 100644 --- a/kernel/term.ml +++ b/kernel/term.ml @@ -14,13 +14,14 @@ open CErrors open Names open Vars open Constr +open Context (* Deprecated *) -type sorts_family = Sorts.family = InProp | InSet | InType +type sorts_family = Sorts.family = InSProp | InProp | InSet | InType [@@ocaml.deprecated "Alias for Sorts.family"] -type sorts = Sorts.t = - | Prop | Set +type sorts = Sorts.t = private + | SProp | Prop | Set | Type of Univ.Universe.t (** Type *) [@@ocaml.deprecated "Alias for Sorts.t"] @@ -32,9 +33,11 @@ type sorts = Sorts.t = (* Other term constructors *) (***************************) -let mkNamedProd id typ c = mkProd (Name id, typ, subst_var id c) -let mkNamedLambda id typ c = mkLambda (Name id, typ, subst_var id c) -let mkNamedLetIn id c1 t c2 = mkLetIn (Name id, c1, t, subst_var id c2) +let name_annot = map_annot Name.mk_name + +let mkNamedProd id typ c = mkProd (name_annot id, typ, subst_var id.binder_name c) +let mkNamedLambda id typ c = mkLambda (name_annot id, typ, subst_var id.binder_name c) +let mkNamedLetIn id c1 t c2 = mkLetIn (name_annot id, c1, t, subst_var id.binder_name c2) (* Constructs either [(x:t)c] or [[x=b:t]c] *) let mkProd_or_LetIn decl c = @@ -60,10 +63,11 @@ let mkNamedProd_wo_LetIn decl c = let open Context.Named.Declaration in match decl with | LocalAssum (id,t) -> mkNamedProd id t c - | LocalDef (id,b,_t) -> subst1 b (subst_var id c) + | LocalDef (id,b,_) -> subst1 b (subst_var id.binder_name c) (* non-dependent product t1 -> t2 *) -let mkArrow t1 t2 = mkProd (Anonymous, t1, t2) +let mkArrow t1 r t2 = mkProd (make_annot Anonymous r, t1, t2) +let mkArrowR t1 t2 = mkArrow t1 Sorts.Relevant t2 (* Constructs either [[x:t]c] or [[x=b:t]c] *) let mkLambda_or_LetIn decl c = @@ -366,8 +370,8 @@ let rec isArity c = type ('constr, 'types) kind_of_type = | SortType of Sorts.t | CastType of 'types * 'types - | ProdType of Name.t * 'types * 'types - | LetInType of Name.t * 'constr * 'types * 'types + | ProdType of Name.t Context.binder_annot * 'types * 'types + | LetInType of Name.t Context.binder_annot * 'constr * 'types * 'types | AtomicType of 'constr * 'constr array let kind_of_type t = match kind t with diff --git a/kernel/term.mli b/kernel/term.mli index 181d714ed7..4265324693 100644 --- a/kernel/term.mli +++ b/kernel/term.mli @@ -17,12 +17,15 @@ open Constr [forall (_:t1), t2]. Beware [t_2] is NOT lifted. Eg: in context [A:Prop], [A->A] is built by [(mkArrow (mkRel 1) (mkRel 2))] *) -val mkArrow : types -> types -> constr +val mkArrow : types -> Sorts.relevance -> types -> constr + +val mkArrowR : types -> types -> constr +(** For an always-relevant domain *) (** Named version of the functions from [Term]. *) -val mkNamedLambda : Id.t -> types -> constr -> constr -val mkNamedLetIn : Id.t -> constr -> types -> constr -> constr -val mkNamedProd : Id.t -> types -> types -> types +val mkNamedLambda : Id.t Context.binder_annot -> types -> constr -> constr +val mkNamedLetIn : Id.t Context.binder_annot -> constr -> types -> constr -> constr +val mkNamedProd : Id.t Context.binder_annot -> types -> types -> types (** Constructs either [(x:t)c] or [[x=b:t]c] *) val mkProd_or_LetIn : Constr.rel_declaration -> types -> types @@ -45,24 +48,24 @@ val appvectc : constr -> constr array -> constr (** [prodn n l b] = [forall (x_1:T_1)...(x_n:T_n), b] where [l] is [(x_n,T_n)...(x_1,T_1)...]. *) -val prodn : int -> (Name.t * constr) list -> constr -> constr +val prodn : int -> (Name.t Context.binder_annot * constr) list -> constr -> constr (** [compose_prod l b] @return [forall (x_1:T_1)...(x_n:T_n), b] where [l] is [(x_n,T_n)...(x_1,T_1)]. Inverse of [decompose_prod]. *) -val compose_prod : (Name.t * constr) list -> constr -> constr +val compose_prod : (Name.t Context.binder_annot * constr) list -> constr -> constr (** [lamn n l b] @return [fun (x_1:T_1)...(x_n:T_n) => b] where [l] is [(x_n,T_n)...(x_1,T_1)...]. *) -val lamn : int -> (Name.t * constr) list -> constr -> constr +val lamn : int -> (Name.t Context.binder_annot * constr) list -> constr -> constr (** [compose_lam l b] @return [fun (x_1:T_1)...(x_n:T_n) => b] where [l] is [(x_n,T_n)...(x_1,T_1)]. Inverse of [it_destLam] *) -val compose_lam : (Name.t * constr) list -> constr -> constr +val compose_lam : (Name.t Context.binder_annot * constr) list -> constr -> constr (** [to_lambda n l] @return [fun (x_1:T_1)...(x_n:T_n) => T] @@ -107,22 +110,22 @@ val prod_applist_assum : int -> types -> constr list -> types (** Transforms a product term {% $ %}(x_1:T_1)..(x_n:T_n)T{% $ %} into the pair {% $ %}([(x_n,T_n);...;(x_1,T_1)],T){% $ %}, where {% $ %}T{% $ %} is not a product. *) -val decompose_prod : constr -> (Name.t*constr) list * constr +val decompose_prod : constr -> (Name.t Context.binder_annot * constr) list * constr (** Transforms a lambda term {% $ %}[x_1:T_1]..[x_n:T_n]T{% $ %} into the pair {% $ %}([(x_n,T_n);...;(x_1,T_1)],T){% $ %}, where {% $ %}T{% $ %} is not a lambda. *) -val decompose_lam : constr -> (Name.t*constr) list * constr +val decompose_lam : constr -> (Name.t Context.binder_annot * constr) list * constr (** Given a positive integer n, decompose a product term {% $ %}(x_1:T_1)..(x_n:T_n)T{% $ %} into the pair {% $ %}([(xn,Tn);...;(x1,T1)],T){% $ %}. Raise a user error if not enough products. *) -val decompose_prod_n : int -> constr -> (Name.t * constr) list * constr +val decompose_prod_n : int -> constr -> (Name.t Context.binder_annot * constr) list * constr (** Given a positive integer {% $ %}n{% $ %}, decompose a lambda term {% $ %}[x_1:T_1]..[x_n:T_n]T{% $ %} into the pair {% $ %}([(x_n,T_n);...;(x_1,T_1)],T){% $ %}. Raise a user error if not enough lambdas. *) -val decompose_lam_n : int -> constr -> (Name.t * constr) list * constr +val decompose_lam_n : int -> constr -> (Name.t Context.binder_annot * constr) list * constr (** Extract the premisses and the conclusion of a term of the form "(xi:Ti) ... (xj:=cj:Tj) ..., T" where T is not a product nor a let *) @@ -183,17 +186,17 @@ val isArity : types -> bool type ('constr, 'types) kind_of_type = | SortType of Sorts.t | CastType of 'types * 'types - | ProdType of Name.t * 'types * 'types - | LetInType of Name.t * 'constr * 'types * 'types + | ProdType of Name.t Context.binder_annot * 'types * 'types + | LetInType of Name.t Context.binder_annot * 'constr * 'types * 'types | AtomicType of 'constr * 'constr array val kind_of_type : types -> (constr, types) kind_of_type (* Deprecated *) -type sorts_family = Sorts.family = InProp | InSet | InType +type sorts_family = Sorts.family = InSProp | InProp | InSet | InType [@@ocaml.deprecated "Alias for Sorts.family"] -type sorts = Sorts.t = - | Prop | Set +type sorts = Sorts.t = private + | SProp | Prop | Set | Type of Univ.Universe.t (** Type *) [@@ocaml.deprecated "Alias for Sorts.t"] diff --git a/kernel/term_typing.ml b/kernel/term_typing.ml index 929f1c13a3..faa4411e92 100644 --- a/kernel/term_typing.ml +++ b/kernel/term_typing.ml @@ -21,7 +21,6 @@ open Constr open Declarations open Environ open Entries -open Typeops module NamedDecl = Context.Named.Declaration @@ -72,15 +71,16 @@ let infer_declaration (type a) ~(trust : a trust) env (dcl : a constant_entry) = | Monomorphic_entry uctx -> push_context_set ~strict:true uctx env | Polymorphic_entry (_, uctx) -> push_context ~strict:false uctx env in - let j = infer env t in + let j = Typeops.infer env t in let usubst, univs = Declareops.abstract_universes uctx in - let c = Typeops.assumption_of_judgment env j in - let t = Constr.hcons (Vars.subst_univs_level_constr usubst c) in + let r = Typeops.assumption_of_judgment env j in + let t = Constr.hcons (Vars.subst_univs_level_constr usubst j.uj_val) in { Cooking.cook_body = Undef nl; cook_type = t; cook_universes = univs; cook_private_univs = None; + cook_relevance = r; cook_inline = false; cook_context = ctx; } @@ -93,12 +93,12 @@ let infer_declaration (type a) ~(trust : a trust) env (dcl : a constant_entry) = let env = push_context_set ~strict:true uctxt env in let ty = match otyp with | Some typ -> - let tyj = infer_type env typ in - check_primitive_type env op_t tyj.utj_val; - Constr.hcons tyj.utj_val + let typ = Typeops.infer_type env typ in + Typeops.check_primitive_type env op_t typ.utj_val; + Constr.hcons typ.utj_val | None -> match op_t with - | CPrimitives.OT_op op -> type_of_prim env op + | CPrimitives.OT_op op -> Typeops.type_of_prim env op | CPrimitives.OT_type _ -> mkSet in let cd = @@ -110,7 +110,8 @@ let infer_declaration (type a) ~(trust : a trust) env (dcl : a constant_entry) = cook_universes = Monomorphic uctxt; cook_private_univs = None; cook_inline = false; - cook_context = None + cook_context = None; + cook_relevance = Sorts.Relevant; } (** Definition [c] is opaque (Qed), non polymorphic and with a specified type, @@ -128,8 +129,8 @@ the polymorphic case const_entry_opaque = true; const_entry_universes = Monomorphic_entry univs; _ } as c) -> let env = push_context_set ~strict:true univs env in - let { const_entry_body = body; const_entry_feedback = feedback_id ; _ } = c in - let tyj = infer_type env typ in + let { const_entry_body = body; const_entry_feedback = feedback_id; _ } = c in + let tyj = Typeops.infer_type env typ in let proofterm = Future.chain body (fun ((body,uctx),side_eff) -> (* don't redeclare universes which are declared for the type *) @@ -137,17 +138,17 @@ the polymorphic case let j, uctx = match trust with | Pure -> let env = push_context_set uctx env in - let j = infer env body in - let _ = judge_of_cast env j DEFAULTcast tyj in + let j = Typeops.infer env body in + let _ = Typeops.judge_of_cast env j DEFAULTcast tyj in j, uctx | SideEffects handle -> let (body, uctx', valid_signatures) = handle env body side_eff in let uctx = Univ.ContextSet.union uctx uctx' in let env = push_context_set uctx env in let body,env,ectx = skip_trusted_seff valid_signatures body env in - let j = infer env body in + let j = Typeops.infer env body in let j = unzip ectx j in - let _ = judge_of_cast env j DEFAULTcast tyj in + let _ = Typeops.judge_of_cast env j DEFAULTcast tyj in j, uctx in let c = Constr.hcons j.uj_val in @@ -156,9 +157,10 @@ the polymorphic case let def = OpaqueDef (Opaqueproof.create proofterm) in { Cooking.cook_body = def; - cook_type = typ; + cook_type = tyj.utj_val; cook_universes = Monomorphic univs; cook_private_univs = None; + cook_relevance = Sorts.relevance_of_sort tyj.utj_type; cook_inline = c.const_entry_inline_code; cook_context = c.const_entry_secctx; } @@ -194,14 +196,14 @@ the polymorphic case in env, sbst, Polymorphic auctx, local in - let j = infer env body in + let j = Typeops.infer env body in let typ = match typ with | None -> Vars.subst_univs_level_constr usubst j.uj_type | Some t -> - let tj = infer_type env t in - let _ = judge_of_cast env j DEFAULTcast tj in - Vars.subst_univs_level_constr usubst t + let tj = Typeops.infer_type env t in + let _ = Typeops.judge_of_cast env j DEFAULTcast tj in + Vars.subst_univs_level_constr usubst tj.utj_val in let def = Constr.hcons (Vars.subst_univs_level_constr usubst j.uj_val) in let def = @@ -214,6 +216,7 @@ the polymorphic case cook_type = typ; cook_universes = univs; cook_private_univs = private_univs; + cook_relevance = Retypeops.relevance_of_term env j.uj_val; cook_inline = c.const_entry_inline_code; cook_context = c.const_entry_secctx; } @@ -309,6 +312,7 @@ let build_constant_declaration _kn env result = const_body_code = tps; const_universes = univs; const_private_poly_univs = result.cook_private_univs; + const_relevance = result.cook_relevance; const_inline_code = result.cook_inline; const_typing_flags = Environ.typing_flags env } @@ -319,9 +323,9 @@ let translate_constant mb env kn ce = (infer_declaration ~trust:mb env ce) let translate_local_assum env t = - let j = infer env t in + let j = Typeops.infer env t in let t = Typeops.assumption_of_judgment env j in - t + j.uj_val, t let translate_recipe ~hcons env kn r = build_constant_declaration kn env (Cooking.cook_constant ~hcons r) @@ -366,8 +370,4 @@ let translate_local_def env _id centry = p | Undef _ | Primitive _ -> assert false in - c, typ - -(* Insertion of inductive types. *) - -let translate_mind env kn mie = Indtypes.check_inductive env kn mie + c, decl.cook_relevance, typ diff --git a/kernel/term_typing.mli b/kernel/term_typing.mli index faf434c142..1fa5eca2e3 100644 --- a/kernel/term_typing.mli +++ b/kernel/term_typing.mli @@ -27,17 +27,14 @@ type _ trust = | SideEffects : 'a effect_handler -> 'a trust val translate_local_def : env -> Id.t -> section_def_entry -> - constr * types + constr * Sorts.relevance * types -val translate_local_assum : env -> types -> types +val translate_local_assum : env -> types -> types * Sorts.relevance val translate_constant : 'a trust -> env -> Constant.t -> 'a constant_entry -> constant_body -val translate_mind : - env -> MutInd.t -> mutual_inductive_entry -> mutual_inductive_body - val translate_recipe : hcons:bool -> env -> Constant.t -> Cooking.recipe -> constant_body (** Internal functions, mentioned here for debug purpose only *) diff --git a/kernel/type_errors.ml b/kernel/type_errors.ml index 481ffc290c..c45fe1cf00 100644 --- a/kernel/type_errors.ml +++ b/kernel/type_errors.ml @@ -33,6 +33,7 @@ type 'constr pguard_error = | RecCallInCasePred of 'constr | NotGuardedForm of 'constr | ReturnPredicateNotCoInductive of 'constr + | FixpointOnIrrelevantInductive type guard_error = constr pguard_error @@ -47,8 +48,8 @@ type ('constr, 'types) ptype_error = | NotAType of ('constr, 'types) punsafe_judgment | BadAssumption of ('constr, 'types) punsafe_judgment | ReferenceVariables of Id.t * 'constr - | ElimArity of pinductive * Sorts.family list * 'constr * ('constr, 'types) punsafe_judgment - * (Sorts.family * Sorts.family * arity_error) option + | ElimArity of pinductive * 'constr * ('constr, 'types) punsafe_judgment + * (Sorts.family list * Sorts.family * Sorts.family * arity_error) option | CaseNotInductive of ('constr, 'types) punsafe_judgment | WrongCaseInfo of pinductive * case_info | NumberBranches of ('constr, 'types) punsafe_judgment * int @@ -59,11 +60,13 @@ type ('constr, 'types) ptype_error = | CantApplyBadType of (int * 'constr * 'constr) * ('constr, 'types) punsafe_judgment * ('constr, 'types) punsafe_judgment array | CantApplyNonFunctional of ('constr, 'types) punsafe_judgment * ('constr, 'types) punsafe_judgment array - | IllFormedRecBody of 'constr pguard_error * Name.t array * int * env * ('constr, 'types) punsafe_judgment array + | IllFormedRecBody of 'constr pguard_error * Name.t Context.binder_annot array * int * env * ('constr, 'types) punsafe_judgment array | IllTypedRecBody of - int * Name.t array * ('constr, 'types) punsafe_judgment array * 'types array + int * Name.t Context.binder_annot array * ('constr, 'types) punsafe_judgment array * 'types array | UnsatisfiedConstraints of Univ.Constraint.t | UndeclaredUniverse of Univ.Level.t + | DisallowedSProp + | BadRelevance type type_error = (constr, types) ptype_error @@ -102,8 +105,8 @@ let error_assumption env j = let error_reference_variables env id c = raise (TypeError (env, ReferenceVariables (id,c))) -let error_elim_arity env ind aritylst c pj okinds = - raise (TypeError (env, ElimArity (ind,aritylst,c,pj,okinds))) +let error_elim_arity env ind c pj okinds = + raise (TypeError (env, ElimArity (ind,c,pj,okinds))) let error_case_not_inductive env j = raise (TypeError (env, CaseNotInductive j)) @@ -149,6 +152,12 @@ let error_unsatisfied_constraints env c = let error_undeclared_universe env l = raise (TypeError (env, UndeclaredUniverse l)) +let error_disallowed_sprop env = + raise (TypeError (env, DisallowedSProp)) + +let error_bad_relevance env = + raise (TypeError (env, BadRelevance)) + let map_pguard_error f = function | NotEnoughAbstractionInFixBody -> NotEnoughAbstractionInFixBody | RecursionNotOnInductiveType c -> RecursionNotOnInductiveType (f c) @@ -165,6 +174,7 @@ let map_pguard_error f = function | RecCallInCasePred c -> RecCallInCasePred (f c) | NotGuardedForm c -> NotGuardedForm (f c) | ReturnPredicateNotCoInductive c -> ReturnPredicateNotCoInductive (f c) +| FixpointOnIrrelevantInductive -> FixpointOnIrrelevantInductive let map_ptype_error f = function | UnboundRel n -> UnboundRel n @@ -172,7 +182,7 @@ let map_ptype_error f = function | NotAType j -> NotAType (on_judgment f j) | BadAssumption j -> BadAssumption (on_judgment f j) | ReferenceVariables (id, c) -> ReferenceVariables (id, f c) -| ElimArity (pi, dl, c, j, ar) -> ElimArity (pi, dl, f c, on_judgment f j, ar) +| ElimArity (pi, c, j, ar) -> ElimArity (pi, f c, on_judgment f j, ar) | CaseNotInductive j -> CaseNotInductive (on_judgment f j) | WrongCaseInfo (pi, ci) -> WrongCaseInfo (pi, ci) | NumberBranches (j, n) -> NumberBranches (on_judgment f j, n) @@ -189,3 +199,5 @@ let map_ptype_error f = function IllTypedRecBody (n, na, Array.map (on_judgment f) jv, Array.map f t) | UnsatisfiedConstraints g -> UnsatisfiedConstraints g | UndeclaredUniverse l -> UndeclaredUniverse l +| DisallowedSProp -> DisallowedSProp +| BadRelevance -> BadRelevance diff --git a/kernel/type_errors.mli b/kernel/type_errors.mli index c5ab9a4e73..88165a4f07 100644 --- a/kernel/type_errors.mli +++ b/kernel/type_errors.mli @@ -34,6 +34,7 @@ type 'constr pguard_error = | RecCallInCasePred of 'constr | NotGuardedForm of 'constr | ReturnPredicateNotCoInductive of 'constr + | FixpointOnIrrelevantInductive type guard_error = constr pguard_error @@ -48,8 +49,8 @@ type ('constr, 'types) ptype_error = | NotAType of ('constr, 'types) punsafe_judgment | BadAssumption of ('constr, 'types) punsafe_judgment | ReferenceVariables of Id.t * 'constr - | ElimArity of pinductive * Sorts.family list * 'constr * ('constr, 'types) punsafe_judgment - * (Sorts.family * Sorts.family * arity_error) option + | ElimArity of pinductive * 'constr * ('constr, 'types) punsafe_judgment + * (Sorts.family list * Sorts.family * Sorts.family * arity_error) option | CaseNotInductive of ('constr, 'types) punsafe_judgment | WrongCaseInfo of pinductive * case_info | NumberBranches of ('constr, 'types) punsafe_judgment * int @@ -60,11 +61,13 @@ type ('constr, 'types) ptype_error = | CantApplyBadType of (int * 'constr * 'constr) * ('constr, 'types) punsafe_judgment * ('constr, 'types) punsafe_judgment array | CantApplyNonFunctional of ('constr, 'types) punsafe_judgment * ('constr, 'types) punsafe_judgment array - | IllFormedRecBody of 'constr pguard_error * Name.t array * int * env * ('constr, 'types) punsafe_judgment array + | IllFormedRecBody of 'constr pguard_error * Name.t Context.binder_annot array * int * env * ('constr, 'types) punsafe_judgment array | IllTypedRecBody of - int * Name.t array * ('constr, 'types) punsafe_judgment array * 'types array + int * Name.t Context.binder_annot array * ('constr, 'types) punsafe_judgment array * 'types array | UnsatisfiedConstraints of Univ.Constraint.t | UndeclaredUniverse of Univ.Level.t + | DisallowedSProp + | BadRelevance type type_error = (constr, types) ptype_error @@ -100,8 +103,8 @@ val error_assumption : env -> unsafe_judgment -> 'a val error_reference_variables : env -> Id.t -> constr -> 'a val error_elim_arity : - env -> pinductive -> Sorts.family list -> constr -> unsafe_judgment -> - (Sorts.family * Sorts.family * arity_error) option -> 'a + env -> pinductive -> constr -> unsafe_judgment -> + (Sorts.family list * Sorts.family * Sorts.family * arity_error) option -> 'a val error_case_not_inductive : env -> unsafe_judgment -> 'a @@ -123,10 +126,10 @@ val error_cant_apply_bad_type : unsafe_judgment -> unsafe_judgment array -> 'a val error_ill_formed_rec_body : - env -> guard_error -> Name.t array -> int -> env -> unsafe_judgment array -> 'a + env -> guard_error -> Name.t Context.binder_annot array -> int -> env -> unsafe_judgment array -> 'a val error_ill_typed_rec_body : - env -> int -> Name.t array -> unsafe_judgment array -> types array -> 'a + env -> int -> Name.t Context.binder_annot array -> unsafe_judgment array -> types array -> 'a val error_elim_explain : Sorts.family -> Sorts.family -> arity_error @@ -134,5 +137,9 @@ val error_unsatisfied_constraints : env -> Univ.Constraint.t -> 'a val error_undeclared_universe : env -> Univ.Level.t -> 'a +val error_disallowed_sprop : env -> 'a + +val error_bad_relevance : env -> 'a + val map_pguard_error : ('c -> 'd) -> 'c pguard_error -> 'd pguard_error val map_ptype_error : ('c -> 'd) -> ('c, 'c) ptype_error -> ('d, 'd) ptype_error diff --git a/kernel/typeops.ml b/kernel/typeops.ml index 227a164549..12ffbf4357 100644 --- a/kernel/typeops.ml +++ b/kernel/typeops.ml @@ -12,8 +12,10 @@ open CErrors open Util open Names open Univ +open Sorts open Term open Constr +open Context open Vars open Declarations open Environ @@ -24,6 +26,8 @@ open Type_errors module RelDecl = Context.Rel.Declaration module NamedDecl = Context.Named.Declaration +exception NotConvertibleVect of int + let conv_leq l2r env x y = default_conv CUMUL ~l2r env x y let conv_leq_vecti env v1 v2 = @@ -47,11 +51,32 @@ let check_type env c t = (* This should be a type intended to be assumed. The error message is not as useful as for [type_judgment]. *) -let check_assumption env t ty = - try let _ = check_type env t ty in t +let infer_assumption env t ty = + try + let s = check_type env t ty in + (match s with Sorts.SProp -> Irrelevant | _ -> Relevant) with TypeError _ -> error_assumption env (make_judge t ty) +let warn_bad_relevance_name = "bad-relevance" +let warn_bad_relevance = + CWarnings.create ~name:warn_bad_relevance_name ~category:"debug" ~default:CWarnings.Disabled + Pp.(function + | None -> str "Bad relevance in case annotation." + | Some x -> str "Bad relevance for binder " ++ Name.print x.binder_name ++ str ".") + +let warn_bad_relevance_ci ?loc () = warn_bad_relevance ?loc None +let warn_bad_relevance ?loc x = warn_bad_relevance ?loc (Some x) + +let check_assumption env x t ty = + let r = x.binder_relevance in + let r' = infer_assumption env t ty in + let x = if Sorts.relevance_equal r r' + then x + else (warn_bad_relevance x; {x with binder_relevance = r'}) + in + x + (************************************************) (* Incremental typing rules: builds a typing judgment given the *) (* judgments for the subterms. *) @@ -69,7 +94,7 @@ let type_of_type u = mkType uu let type_of_sort = function - | Prop | Set -> type1 + | SProp | Prop | Set -> type1 | Type u -> type_of_type u (*s Type of a de Bruijn index. *) @@ -220,7 +245,7 @@ let type_of_prim env t = in let rec nary_int63_op arity ty = if Int.equal arity 0 then ty - else Constr.mkProd(Name (Id.of_string "x"), int_ty, nary_int63_op (arity-1) ty) + else Constr.mkProd(Context.nameR (Id.of_string "x"), int_ty, nary_int63_op (arity-1) ty) in let return_ty = let open CPrimitives in @@ -264,6 +289,7 @@ let judge_of_int env i = let sort_of_product env domsort rangsort = match (domsort, rangsort) with + | (_, SProp) | (SProp, _) -> rangsort (* Product rule (s,Prop,Prop) *) | (_, Prop) -> rangsort (* Product rule (Prop/Set,Set,Set) *) @@ -275,13 +301,13 @@ let sort_of_product env domsort rangsort = rangsort else (* Rule is (Type_i,Set,Type_i) in the Set-predicative calculus *) - Type (Universe.sup Universe.type0 u1) + Sorts.sort_of_univ (Universe.sup Universe.type0 u1) (* Product rule (Prop,Type_i,Type_i) *) - | (Set, Type u2) -> Type (Universe.sup Universe.type0 u2) + | (Set, Type u2) -> Sorts.sort_of_univ (Universe.sup Universe.type0 u2) (* Product rule (Prop,Type_i,Type_i) *) | (Prop, Type _) -> rangsort (* Product rule (Type_i,Type_i,Type_i) *) - | (Type u1, Type u2) -> Type (Universe.sup u1 u2) + | (Type u1, Type u2) -> Sorts.sort_of_univ (Universe.sup u1 u2) (* [judge_of_product env name (typ1,s1) (typ2,s2)] implements the rule @@ -376,11 +402,17 @@ let type_of_case env ci p pt c ct _lf lft = let (pind, _ as indspec) = try find_rectype env ct with Not_found -> error_case_not_inductive env (make_judge c ct) in - let () = check_case_info env pind ci in + let _, sp = try dest_arity env pt + with NotArity -> error_elim_arity env pind c (make_judge p pt) None in + let rp = Sorts.relevance_of_sort sp in + let ci = if ci.ci_relevance == rp then ci + else (warn_bad_relevance_ci (); {ci with ci_relevance=rp}) + in + let () = check_case_info env pind rp ci in let (bty,rslty) = type_case_branches env indspec (make_judge p pt) c in let () = check_branch_types env pind c ct lft bty in - rslty + ci, rslty let type_of_projection env p c ct = let pty = lookup_projection p env in @@ -455,6 +487,13 @@ let constr_of_global_in_context env r = (************************************************************************) (************************************************************************) +let check_binder_annot s x = + let r = x.binder_relevance in + let r' = Sorts.relevance_of_sort s in + if r' == r + then x + else (warn_bad_relevance x; {x with binder_relevance = r'}) + (* The typing machine. *) (* ATTENTION : faudra faire le typage du contexte des Const, Ind et Constructsi un jour cela devient des constructions @@ -463,88 +502,110 @@ let rec execute env cstr = let open Context.Rel.Declaration in match kind cstr with (* Atomic terms *) - | Sort s -> type_of_sort s + | Sort s -> + (match s with + | SProp -> if not (Environ.sprop_allowed env) then error_disallowed_sprop env + | _ -> ()); + cstr, type_of_sort s | Rel n -> - type_of_relative env n + cstr, type_of_relative env n | Var id -> - type_of_variable env id + cstr, type_of_variable env id | Const c -> - type_of_constant env c + cstr, type_of_constant env c | Proj (p, c) -> - let ct = execute env c in - type_of_projection env p c ct + let c', ct = execute env c in + let cstr = if c == c' then cstr else mkProj (p,c') in + cstr, type_of_projection env p c' ct (* Lambda calculus operators *) | App (f,args) -> - let argst = execute_array env args in - let ft = + let args', argst = execute_array env args in + let f', ft = match kind f with | Ind ind when Environ.template_polymorphic_pind ind env -> let args = Array.map (fun t -> lazy t) argst in - type_of_inductive_knowing_parameters env ind args + f, type_of_inductive_knowing_parameters env ind args | _ -> (* No template polymorphism *) execute env f in - - type_of_apply env f ft args argst + let cstr = if f == f' && args == args' then cstr else mkApp (f',args') in + cstr, type_of_apply env f' ft args' argst | Lambda (name,c1,c2) -> - let _ = execute_is_type env c1 in - let env1 = push_rel (LocalAssum (name,c1)) env in - let c2t = execute env1 c2 in - type_of_abstraction env name c1 c2t + let c1', s = execute_is_type env c1 in + let name' = check_binder_annot s name in + let env1 = push_rel (LocalAssum (name',c1')) env in + let c2', c2t = execute env1 c2 in + let cstr = if name == name' && c1 == c1' && c2 == c2' then cstr else mkLambda(name',c1',c2') in + cstr, type_of_abstraction env name' c1 c2t | Prod (name,c1,c2) -> - let vars = execute_is_type env c1 in - let env1 = push_rel (LocalAssum (name,c1)) env in - let vars' = execute_is_type env1 c2 in - type_of_product env name vars vars' + let c1', vars = execute_is_type env c1 in + let name' = check_binder_annot vars name in + let env1 = push_rel (LocalAssum (name',c1')) env in + let c2', vars' = execute_is_type env1 c2 in + let cstr = if name == name' && c1 == c1' && c2 == c2' then cstr else mkProd(name',c1',c2') in + cstr, type_of_product env name' vars vars' | LetIn (name,c1,c2,c3) -> - let c1t = execute env c1 in - let _c2s = execute_is_type env c2 in - let () = check_cast env c1 c1t DEFAULTcast c2 in - let env1 = push_rel (LocalDef (name,c1,c2)) env in - let c3t = execute env1 c3 in - subst1 c1 c3t + let c1', c1t = execute env c1 in + let c2', c2s = execute_is_type env c2 in + let name' = check_binder_annot c2s name in + let () = check_cast env c1' c1t DEFAULTcast c2' in + let env1 = push_rel (LocalDef (name',c1',c2')) env in + let c3', c3t = execute env1 c3 in + let cstr = if name == name' && c1 == c1' && c2 == c2' && c3 == c3' then cstr + else mkLetIn(name',c1',c2',c3') + in + cstr, subst1 c1 c3t | Cast (c,k,t) -> - let ct = execute env c in - let _ts = (check_type env t (execute env t)) in - let () = check_cast env c ct k t in - t + let c', ct = execute env c in + let t', _ts = execute_is_type env t in + let () = check_cast env c' ct k t' in + let cstr = if c == c' && t == t' then cstr else mkCast(c',k,t') in + cstr, t' (* Inductive types *) | Ind ind -> - type_of_inductive env ind + cstr, type_of_inductive env ind | Construct c -> - type_of_constructor env c + cstr, type_of_constructor env c | Case (ci,p,c,lf) -> - let ct = execute env c in - let pt = execute env p in - let lft = execute_array env lf in - type_of_case env ci p pt c ct lf lft - - | Fix ((_vn,i as vni),recdef) -> + let c', ct = execute env c in + let p', pt = execute env p in + let lf', lft = execute_array env lf in + let ci', t = type_of_case env ci p' pt c' ct lf' lft in + let cstr = if ci == ci' && c == c' && p == p' && lf == lf' then cstr + else mkCase(ci',p',c',lf') + in + cstr, t + + | Fix ((_vn,i as vni),recdef as fix) -> let (fix_ty,recdef') = execute_recdef env recdef i in - let fix = (vni,recdef') in - check_fix env fix; fix_ty + let cstr, fix = if recdef == recdef' then cstr, fix else + let fix = (vni,recdef') in mkFix fix, fix + in + check_fix env fix; cstr, fix_ty - | CoFix (i,recdef) -> + | CoFix (i,recdef as cofix) -> let (fix_ty,recdef') = execute_recdef env recdef i in - let cofix = (i,recdef') in - check_cofix env cofix; fix_ty + let cstr, cofix = if recdef == recdef' then cstr, cofix else + let cofix = (i,recdef') in mkCoFix cofix, cofix + in + check_cofix env cofix; cstr, fix_ty (* Primitive types *) - | Int _ -> type_of_int env - + | Int _ -> cstr, type_of_int env + (* Partial proofs: unsupported by the kernel *) | Meta _ -> anomaly (Pp.str "the kernel does not support metavariables.") @@ -553,18 +614,22 @@ let rec execute env cstr = anomaly (Pp.str "the kernel does not support existential variables.") and execute_is_type env constr = - let t = execute env constr in - check_type env constr t - -and execute_recdef env (names,lar,vdef) i = - let lart = execute_array env lar in - let lara = Array.map2 (check_assumption env) lar lart in - let env1 = push_rec_types (names,lara,vdef) env in - let vdeft = execute_array env1 vdef in - let () = check_fixpoint env1 names lara vdef vdeft in - (lara.(i),(names,lara,vdef)) - -and execute_array env = Array.map (execute env) + let c, t = execute env constr in + c, check_type env constr t + +and execute_recdef env (names,lar,vdef as recdef) i = + let lar', lart = execute_array env lar in + let names' = Array.Smart.map_i (fun i na -> check_assumption env na lar'.(i) lart.(i)) names in + let env1 = push_rec_types (names',lar',vdef) env in (* vdef is ignored *) + let vdef', vdeft = execute_array env1 vdef in + let () = check_fixpoint env1 names' lar' vdef' vdeft in + let recdef = if names == names' && lar == lar' && vdef == vdef' then recdef else (names',lar',vdef') in + (lar'.(i),recdef) + +and execute_array env cs = + let tys = Array.make (Array.length cs) mkProp in + let cs = Array.Smart.map_i (fun i c -> let c, ty = execute env c in tys.(i) <- ty; c) cs in + cs, tys (* Derived functions *) @@ -576,8 +641,8 @@ let check_wellformed_universes env c = let infer env constr = let () = check_wellformed_universes env constr in - let t = execute env constr in - make_judge constr t + let constr, t = execute env constr in + make_judge constr t let infer = if Flags.profile then @@ -586,7 +651,7 @@ let infer = else (fun b c -> infer b c) let assumption_of_judgment env {uj_val=c; uj_type=t} = - check_assumption env c t + infer_assumption env c t let type_judgment env {uj_val=c; uj_type=t} = let s = check_type env c t in @@ -594,30 +659,27 @@ let type_judgment env {uj_val=c; uj_type=t} = let infer_type env constr = let () = check_wellformed_universes env constr in - let t = execute env constr in + let constr, t = execute env constr in let s = check_type env constr t in {utj_val = constr; utj_type = s} -let infer_v env cv = - let () = Array.iter (check_wellformed_universes env) cv in - let jv = execute_array env cv in - make_judgev cv jv - (* Typing of several terms. *) let check_context env rels = let open Context.Rel.Declaration in - Context.Rel.fold_outside (fun d env -> + Context.Rel.fold_outside (fun d (env,rels) -> match d with - | LocalAssum (_,ty) -> - let _ = infer_type env ty in - push_rel d env - | LocalDef (_,bd,ty) -> + | LocalAssum (x,ty) -> + let jty = infer_type env ty in + let x = check_binder_annot jty.utj_type x in + push_rel d env, LocalAssum (x,jty.utj_val) :: rels + | LocalDef (x,bd,ty) -> let j1 = infer env bd in - let _ = infer_type env ty in + let jty = infer_type env ty in conv_leq false env j1.uj_type ty; - push_rel d env) - rels ~init:env + let x = check_binder_annot jty.utj_type x in + push_rel d env, LocalDef (x,j1.uj_val,jty.utj_val) :: rels) + rels ~init:(env,[]) let judge_of_prop = make_judge mkProp type1 let judge_of_set = make_judge mkSet type1 @@ -639,17 +701,17 @@ let judge_of_apply env funj argjv = let args, argtys = dest_judgev argjv in make_judge (mkApp (funj.uj_val, args)) (type_of_apply env funj.uj_val funj.uj_type args argtys) -let judge_of_abstraction env x varj bodyj = - make_judge (mkLambda (x, varj.utj_val, bodyj.uj_val)) - (type_of_abstraction env x varj.utj_val bodyj.uj_type) +(* let judge_of_abstraction env x varj bodyj = *) +(* make_judge (mkLambda (x, varj.utj_val, bodyj.uj_val)) *) +(* (type_of_abstraction env x varj.utj_val bodyj.uj_type) *) -let judge_of_product env x varj outj = - make_judge (mkProd (x, varj.utj_val, outj.utj_val)) - (mkSort (sort_of_product env varj.utj_type outj.utj_type)) +(* let judge_of_product env x varj outj = *) +(* make_judge (mkProd (x, varj.utj_val, outj.utj_val)) *) +(* (mkSort (sort_of_product env varj.utj_type outj.utj_type)) *) -let judge_of_letin _env name defj typj j = - make_judge (mkLetIn (name, defj.uj_val, typj.utj_val, j.uj_val)) - (subst1 defj.uj_val j.uj_type) +(* let judge_of_letin env name defj typj j = *) +(* make_judge (mkLetIn (name, defj.uj_val, typj.utj_val, j.uj_val)) *) +(* (subst1 defj.uj_val j.uj_type) *) let judge_of_cast env cj k tj = let () = check_cast env cj.uj_val cj.uj_type k tj.utj_val in @@ -664,8 +726,8 @@ let judge_of_constructor env cu = let judge_of_case env ci pj cj lfj = let lf, lft = dest_judgev lfj in - make_judge (mkCase (ci, (*nf_betaiota*) pj.uj_val, cj.uj_val, lft)) - (type_of_case env ci pj.uj_val pj.uj_type cj.uj_val cj.uj_type lf lft) + let ci, t = type_of_case env ci pj.uj_val pj.uj_type cj.uj_val cj.uj_type lf lft in + make_judge (mkCase (ci, (*nf_betaiota*) pj.uj_val, cj.uj_val, lft)) t (* Building type of primitive operators and type *) diff --git a/kernel/typeops.mli b/kernel/typeops.mli index 52c261c5e8..cc1885f42d 100644 --- a/kernel/typeops.mli +++ b/kernel/typeops.mli @@ -16,27 +16,29 @@ open Environ (** {6 Typing functions (not yet tagged as safe) } They return unsafe judgments that are "in context" of a set of - (local) universe variables (the ones that appear in the term) - and associated constraints. In case of polymorphic definitions, - these variables and constraints will be generalized. - *) + (local) universe variables (the ones that appear in the term) and + associated constraints. In case of polymorphic definitions, these + variables and constraints will be generalized. + When typechecking a term it may be updated to fix relevance marks. + Do not discard the result. *) val infer : env -> constr -> unsafe_judgment -val infer_v : env -> constr array -> unsafe_judgment array val infer_type : env -> types -> unsafe_type_judgment val check_context : - env -> Constr.rel_context -> env + env -> Constr.rel_context -> env * Constr.rel_context (** {6 Basic operations of the typing machine. } *) (** If [j] is the judgement {% $ %}c:t{% $ %}, then [assumption_of_judgement env j] returns the type {% $ %}c{% $ %}, checking that {% $ %}t{% $ %} is a sort. *) -val assumption_of_judgment : env -> unsafe_judgment -> types +val assumption_of_judgment : env -> unsafe_judgment -> Sorts.relevance val type_judgment : env -> unsafe_judgment -> unsafe_type_judgment +val check_binder_annot : Sorts.t -> Name.t Context.binder_annot -> Name.t Context.binder_annot + (** {6 Type of sorts. } *) val type1 : types val type_of_sort : Sorts.t -> types @@ -65,21 +67,21 @@ val judge_of_apply : -> unsafe_judgment (** {6 Type of an abstraction. } *) -val judge_of_abstraction : - env -> Name.t -> unsafe_type_judgment -> unsafe_judgment - -> unsafe_judgment +(* val judge_of_abstraction : *) +(* env -> Name.t -> unsafe_type_judgment -> unsafe_judgment *) +(* -> unsafe_judgment *) (** {6 Type of a product. } *) val sort_of_product : env -> Sorts.t -> Sorts.t -> Sorts.t -val type_of_product : env -> Name.t -> Sorts.t -> Sorts.t -> types -val judge_of_product : - env -> Name.t -> unsafe_type_judgment -> unsafe_type_judgment - -> unsafe_judgment +val type_of_product : env -> Name.t Context.binder_annot -> Sorts.t -> Sorts.t -> types +(* val judge_of_product : *) +(* env -> Name.t -> unsafe_type_judgment -> unsafe_type_judgment *) +(* -> unsafe_judgment *) (** s Type of a let in. *) -val judge_of_letin : - env -> Name.t -> unsafe_judgment -> unsafe_type_judgment -> unsafe_judgment - -> unsafe_judgment +(* val judge_of_letin : *) +(* env -> Name.t -> unsafe_judgment -> unsafe_type_judgment -> unsafe_judgment *) +(* -> unsafe_judgment *) (** {6 Type of a cast. } *) val judge_of_cast : @@ -128,3 +130,6 @@ val judge_of_int : env -> Uint63.t -> unsafe_judgment val type_of_prim_type : env -> CPrimitives.prim_type -> types val type_of_prim : env -> CPrimitives.t -> types + +val warn_bad_relevance_name : string +(** Allow the checker to make this warning into an error. *) diff --git a/kernel/uGraph.ml b/kernel/uGraph.ml index 8187dea41b..0d5b55ca1b 100644 --- a/kernel/uGraph.ml +++ b/kernel/uGraph.ml @@ -29,15 +29,22 @@ module G = AcyclicGraph.Make(struct code (eg add_universe with a constraint vs G.add with no constraint) *) -type t = G.t -type 'a check_function = 'a G.check_function +type t = { graph: G.t; sprop_cumulative : bool } +type 'a check_function = t -> 'a -> 'a -> bool + +let g_map f g = + let g' = f g.graph in + if g.graph == g' then g + else {g with graph=g'} + +let make_sprop_cumulative g = {g with sprop_cumulative=true} let check_smaller_expr g (u,n) (v,m) = let diff = n - m in match diff with - | 0 -> G.check_leq g u v - | 1 -> G.check_lt g u v - | x when x < 0 -> G.check_leq g u v + | 0 -> G.check_leq g.graph u v + | 1 -> G.check_lt g.graph u v + | x when x < 0 -> G.check_leq g.graph u v | _ -> false let exists_bigger g ul l = @@ -48,24 +55,28 @@ let real_check_leq g u v = Universe.for_all (fun ul -> exists_bigger g ul v) u let check_leq g u v = - Universe.equal u v || - is_type0m_univ u || - real_check_leq g u v + Universe.equal u v || (g.sprop_cumulative && Universe.is_sprop u) || + (not (Universe.is_sprop u) && not (Universe.is_sprop v) && + (is_type0m_univ u || + real_check_leq g u v)) let check_eq g u v = Universe.equal u v || - (real_check_leq g u v && real_check_leq g v u) + (not (Universe.is_sprop u || Universe.is_sprop v) && + (real_check_leq g u v && real_check_leq g v u)) -let check_eq_level = G.check_eq +let check_eq_level g u v = + u == v || + (not (Level.is_sprop u || Level.is_sprop v) && G.check_eq g.graph u v) -let empty_universes = G.empty +let empty_universes = {graph=G.empty; sprop_cumulative=false} let initial_universes = let big_rank = 1000000 in let g = G.empty in let g = G.add ~rank:big_rank Level.prop g in let g = G.add ~rank:big_rank Level.set g in - G.enforce_lt Level.prop Level.set g + {graph=G.enforce_lt Level.prop Level.set g; sprop_cumulative=false} let enforce_constraint (u,d,v) g = match d with @@ -73,6 +84,13 @@ let enforce_constraint (u,d,v) g = | Lt -> G.enforce_lt u v g | Eq -> G.enforce_eq u v g +let enforce_constraint (u,d,v as cst) g = + match Level.is_sprop u, d, Level.is_sprop v with + | false, _, false -> g_map (enforce_constraint cst) g + | true, (Eq|Le), true -> g + | true, Le, false when g.sprop_cumulative -> g + | _ -> raise (UniverseInconsistency (d,Universe.make u, Universe.make v, None)) + let merge_constraints csts g = Constraint.fold enforce_constraint csts g let check_constraint g (u,d,v) = @@ -81,6 +99,13 @@ let check_constraint g (u,d,v) = | Lt -> G.check_lt g u v | Eq -> G.check_eq g u v +let check_constraint g (u,d,v as cst) = + match Level.is_sprop u, d, Level.is_sprop v with + | false, _, false -> check_constraint g.graph cst + | true, (Eq|Le), true -> true + | true, Le, false -> g.sprop_cumulative + | _ -> false + let check_constraints csts g = Constraint.for_all (check_constraint g) csts let leq_expr (u,m) (v,n) = @@ -125,17 +150,17 @@ let enforce_leq_alg u v g = exception AlreadyDeclared = G.AlreadyDeclared let add_universe u strict g = - let g = G.add u g in + let graph = G.add u g.graph in let d = if strict then Lt else Le in - enforce_constraint (Level.set,d,u) g + enforce_constraint (Level.set,d,u) {g with graph} -let add_universe_unconstrained u g = G.add u g +let add_universe_unconstrained u g = {g with graph=G.add u g.graph} exception UndeclaredLevel = G.Undeclared -let check_declared_universes = G.check_declared +let check_declared_universes g l = G.check_declared g.graph (LSet.remove Level.sprop l) -let constraints_of_universes = G.constraints_of -let constraints_for = G.constraints_for +let constraints_of_universes g = G.constraints_of g.graph +let constraints_for ~kept g = G.constraints_for ~kept:(LSet.remove Level.sprop kept) g.graph (** Subtyping of polymorphic contexts *) @@ -160,18 +185,20 @@ let check_eq_instances g t1 t2 = (Int.equal i (Array.length t1)) || (check_eq_level g t1.(i) t2.(i) && aux (i + 1)) in aux 0) -let domain = G.domain -let choose = G.choose +let domain g = LSet.add Level.sprop (G.domain g.graph) +let choose p g u = if Level.is_sprop u + then if p u then Some u else None + else G.choose p g.graph u -let dump_universes = G.dump +let dump_universes f g = G.dump f g.graph -let check_universes_invariants g = G.check_invariants ~required_canonical:Level.is_small g +let check_universes_invariants g = G.check_invariants ~required_canonical:Level.is_small g.graph -let pr_universes = G.pr +let pr_universes prl g = G.pr prl g.graph let dummy_mp = Names.DirPath.make [Names.Id.of_string "Type"] let make_dummy i = Level.(make (UGlobal.make dummy_mp i)) -let sort_universes g = G.sort make_dummy [Level.prop;Level.set] g +let sort_universes g = g_map (G.sort make_dummy [Level.prop;Level.set]) g (** Profiling *) diff --git a/kernel/uGraph.mli b/kernel/uGraph.mli index e1a5d50425..17d6c6e6d3 100644 --- a/kernel/uGraph.mli +++ b/kernel/uGraph.mli @@ -13,6 +13,9 @@ open Univ (** {6 Graphs of universes. } *) type t +val make_sprop_cumulative : t -> t +(** Don't use this in the kernel, it makes the system incomplete. *) + type 'a check_function = t -> 'a -> 'a -> bool val check_leq : Universe.t check_function diff --git a/kernel/univ.ml b/kernel/univ.ml index 09bf695915..8263c68bf5 100644 --- a/kernel/univ.ml +++ b/kernel/univ.ml @@ -53,6 +53,7 @@ struct end type t = + | SProp | Prop | Set | Level of UGlobal.t @@ -63,6 +64,7 @@ struct let equal x y = x == y || match x, y with + | SProp, SProp -> true | Prop, Prop -> true | Set, Set -> true | Level l, Level l' -> UGlobal.equal l l' @@ -71,6 +73,9 @@ struct let compare u v = match u, v with + | SProp, SProp -> 0 + | SProp, _ -> -1 + | _, SProp -> 1 | Prop,Prop -> 0 | Prop, _ -> -1 | _, Prop -> 1 @@ -88,6 +93,7 @@ struct let hequal x y = x == y || match x, y with + | SProp, SProp -> true | Prop, Prop -> true | Set, Set -> true | Level (n,d), Level (n',d') -> @@ -96,6 +102,7 @@ struct | _ -> false let hcons = function + | SProp as x -> x | Prop as x -> x | Set as x -> x | Level (d,n) as x -> @@ -106,8 +113,9 @@ struct open Hashset.Combine let hash = function - | Prop -> combinesmall 1 0 - | Set -> combinesmall 1 1 + | SProp -> combinesmall 1 0 + | Prop -> combinesmall 1 1 + | Set -> combinesmall 1 2 | Var n -> combinesmall 2 n | Level (d, n) -> combinesmall 3 (combine n (Names.DirPath.hash d)) @@ -118,6 +126,7 @@ module Level = struct module UGlobal = RawLevel.UGlobal type raw_level = RawLevel.t = + | SProp | Prop | Set | Level of UGlobal.t @@ -155,11 +164,13 @@ module Level = struct let set = make Set let prop = make Prop + let sprop = make SProp let is_small x = match data x with | Level _ -> false | Var _ -> false + | SProp -> true | Prop -> true | Set -> true @@ -173,12 +184,18 @@ module Level = struct | Set -> true | _ -> false + let is_sprop x = + match data x with + | SProp -> true + | _ -> false + let compare u v = if u == v then 0 else RawLevel.compare (data u) (data v) let to_string x = match data x with + | SProp -> "SProp" | Prop -> "Prop" | Set -> "Set" | Level (d,n) -> Names.DirPath.to_string d^"."^string_of_int n @@ -188,6 +205,7 @@ module Level = struct let apart u v = match data u, data v with + | SProp, _ | _, SProp | Prop, Set | Set, Prop -> true | _ -> false @@ -308,6 +326,7 @@ struct if Int.equal n n' then Level.compare x x' else n - n' + let sprop = hcons (Level.sprop, 0) let prop = hcons (Level.prop, 0) let set = hcons (Level.set, 0) let type1 = hcons (Level.set, 1) @@ -326,16 +345,16 @@ struct let cmp = Level.compare u v in if Int.equal cmp 0 then n <= n' else if n <= n' then - (Level.is_prop u && Level.is_small v) + (Level.is_prop u && not (Level.is_sprop v)) else false let successor (u,n) = - if Level.is_prop u then type1 + if Level.is_small u then type1 else (u, n + 1) let addn k (u,n as x) = if k = 0 then x - else if Level.is_prop u then + else if Level.is_small u then (Level.set,n+k) else (u,n+k) @@ -353,13 +372,16 @@ struct left expression is "smaller" than the right one in both cases. *) let super (u,n) (v,n') = let cmp = Level.compare u v in - if Int.equal cmp 0 then SuperSame (n < n') + if Int.equal cmp 0 then SuperSame (n < n') else let open RawLevel in match Level.data u, n, Level.data v, n' with - | Prop, _, Prop, _ -> SuperSame (n < n') - | Prop, 0, _, _ -> SuperSame true - | _, _, Prop, 0 -> SuperSame false + | SProp, _, SProp, _ | Prop, _, Prop, _ -> SuperSame (n < n') + | SProp, 0, Prop, 0 -> SuperSame true + | Prop, 0, SProp, 0 -> SuperSame false + | (SProp | Prop), 0, _, _ -> SuperSame true + | _, _, (SProp | Prop), 0 -> SuperSame false + | _, _, _, _ -> SuperDiff cmp let to_string (v, n) = @@ -445,6 +467,8 @@ struct | [l] -> Expr.is_small l | _ -> false + let sprop = tip Expr.sprop + (* The lower predicative level of the hierarchy that contains (impredicative) Prop and singleton inductive types *) let type0m = tip Expr.prop @@ -454,8 +478,9 @@ struct (* When typing [Prop] and [Set], there is no constraint on the level, hence the definition of [type1_univ], the type of [Prop] *) - let type1 = tip (Expr.successor Expr.set) + let type1 = tip Expr.type1 + let is_sprop x = equal sprop x let is_type0m x = equal type0m x let is_type0 x = equal type0 x @@ -656,7 +681,7 @@ let enforce_eq u v c = let constraint_add_leq v u c = (* We just discard trivial constraints like u<=u *) if Expr.equal v u then c - else + else match v, u with | (x,n), (y,m) -> let j = m - n in @@ -679,7 +704,12 @@ let check_univ_leq u v = Universe.for_all (fun u -> check_univ_leq_one u v) u let enforce_leq u v c = - List.fold_left (fun c v -> (List.fold_left (fun c u -> constraint_add_leq u v c) c u)) c v + match is_sprop u, is_sprop v with + | true, true -> c + | true, false | false, true -> + raise (UniverseInconsistency (Le, u, v, None)) + | false, false -> + List.fold_left (fun c v -> (List.fold_left (fun c u -> constraint_add_leq u v c) c u)) c v let enforce_leq u v c = if check_univ_leq u v then c @@ -845,7 +875,7 @@ struct else Array.append x y let of_array a = - assert(Array.for_all (fun x -> not (Level.is_prop x)) a); + assert(Array.for_all (fun x -> not (Level.is_prop x || Level.is_sprop x)) a); a let to_array a = a diff --git a/kernel/univ.mli b/kernel/univ.mli index 1fbebee350..5543c35741 100644 --- a/kernel/univ.mli +++ b/kernel/univ.mli @@ -30,11 +30,13 @@ sig val set : t val prop : t + val sprop : t (** The set and prop universe levels. *) val is_small : t -> bool (** Is the universe set or prop? *) + val is_sprop : t -> bool val is_prop : t -> bool val is_set : t -> bool (** Is it specifically Prop or Set *) @@ -119,6 +121,8 @@ sig val sup : t -> t -> t (** The l.u.b. of 2 universes *) + val sprop : t + val type0m : t (** image of Prop in the universes hierarchy *) @@ -128,6 +132,10 @@ sig val type1 : t (** the universe of the type of Prop/Set *) + val is_sprop : t -> bool + val is_type0m : t -> bool + val is_type0 : t -> bool + val exists : (Level.t * int -> bool) -> t -> bool val for_all : (Level.t * int -> bool) -> t -> bool diff --git a/kernel/vmvalues.ml b/kernel/vmvalues.ml index 9a3eadf747..777a207013 100644 --- a/kernel/vmvalues.ml +++ b/kernel/vmvalues.ml @@ -8,7 +8,6 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) open Names -open Sorts open Univ open Constr @@ -138,6 +137,7 @@ let hash_annot_switch asw = let pp_sort s = let open Sorts in match s with + | SProp -> Pp.str "SProp" | Prop -> Pp.str "Prop" | Set -> Pp.str "Set" | Type u -> Pp.(str "Type@{" ++ Univ.pr_uni u ++ str "}") @@ -335,10 +335,10 @@ let rec whd_accu a stk = let args = Array.init (nargs args) (arg args) in let s = Obj.obj (Obj.field at 0) in begin match s with - | Type u -> + | Sorts.Type u -> let inst = Instance.of_array (Array.map uni_lvl_val args) in let u = Univ.subst_instance_universe inst u in - Vatom_stk (Asort (Type u), []) + Vatom_stk (Asort (Sorts.sort_of_univ u), []) | _ -> assert false end | _ -> assert false diff --git a/lib/cWarnings.ml b/lib/cWarnings.ml index 0cf989e494..f199e2e608 100644 --- a/lib/cWarnings.ml +++ b/lib/cWarnings.ml @@ -8,8 +8,6 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) -open Pp - type status = Disabled | Enabled | AsError @@ -158,6 +156,10 @@ let set_flags s = warning flags string, because the warning being created might have been set already. *) let create ~name ~category ?(default=Enabled) pp = + let pp x = let open Pp in + pp x ++ spc () ++ str "[" ++ str name ++ str "," ++ + str category ++ str "]" + in Hashtbl.replace warnings name { default; category; status = default }; add_warning_in_category ~name ~category; if default <> Disabled then @@ -166,13 +168,8 @@ let create ~name ~category ?(default=Enabled) pp = new warning is now known. *) set_flags !flags; fun ?loc x -> - let w = Hashtbl.find warnings name in - match w.status with - | Disabled -> () - | AsError -> CErrors.user_err ?loc (pp x) - | Enabled -> - let msg = - pp x ++ spc () ++ str "[" ++ str name ++ str "," ++ - str category ++ str "]" - in - Feedback.msg_warning ?loc msg + let w = Hashtbl.find warnings name in + match w.status with + | Disabled -> () + | AsError -> CErrors.user_err ?loc (pp x) + | Enabled -> Feedback.msg_warning ?loc (pp x) diff --git a/library/global.ml b/library/global.ml index cf996ce644..d9f8a6ffa3 100644 --- a/library/global.ml +++ b/library/global.ml @@ -90,6 +90,9 @@ let set_engagement c = globalize0 (Safe_typing.set_engagement c) let set_indices_matter b = globalize0 (Safe_typing.set_indices_matter b) let set_typing_flags c = globalize0 (Safe_typing.set_typing_flags c) let typing_flags () = Environ.typing_flags (env ()) +let make_sprop_cumulative () = globalize0 Safe_typing.make_sprop_cumulative +let set_allow_sprop b = globalize0 (Safe_typing.set_allow_sprop b) +let sprop_allowed () = Environ.sprop_allowed (env()) let export_private_constants ~in_section cd = globalize (Safe_typing.export_private_constants ~in_section cd) let add_constant ~in_section id d = globalize (Safe_typing.add_constant ~in_section (i2l id) d) let add_mind id mie = globalize (Safe_typing.add_mind (i2l id) mie) diff --git a/library/global.mli b/library/global.mli index afb017a905..ca88d2dafd 100644 --- a/library/global.mli +++ b/library/global.mli @@ -32,6 +32,9 @@ val set_engagement : Declarations.engagement -> unit val set_indices_matter : bool -> unit val set_typing_flags : Declarations.typing_flags -> unit val typing_flags : unit -> Declarations.typing_flags +val make_sprop_cumulative : unit -> unit +val set_allow_sprop : bool -> unit +val sprop_allowed : unit -> bool (** Variables, Local definitions, constants, inductive types *) diff --git a/parsing/g_constr.mlg b/parsing/g_constr.mlg index b3ae24e941..6f73a3e4ed 100644 --- a/parsing/g_constr.mlg +++ b/parsing/g_constr.mlg @@ -31,7 +31,7 @@ let ldots_var = Id.of_string ".." let constr_kw = [ "forall"; "fun"; "match"; "fix"; "cofix"; "with"; "in"; "for"; "end"; "as"; "let"; "if"; "then"; "else"; "return"; - "Prop"; "Set"; "Type"; ".("; "_"; ".."; + "SProp"; "Prop"; "Set"; "Type"; ".("; "_"; ".."; "`{"; "`("; "{|"; "|}" ] let _ = List.iter CLexer.add_keyword constr_kw @@ -153,6 +153,7 @@ GRAMMAR EXTEND Gram sort: [ [ "Set" -> { GSet } | "Prop" -> { GProp } + | "SProp" -> { GSProp } | "Type" -> { GType [] } | "Type"; "@{"; u = universe; "}" -> { GType u } ] ] @@ -160,6 +161,7 @@ GRAMMAR EXTEND Gram sort_family: [ [ "Set" -> { Sorts.InSet } | "Prop" -> { Sorts.InProp } + | "SProp" -> { Sorts.InSProp } | "Type" -> { Sorts.InType } ] ] ; @@ -323,6 +325,7 @@ GRAMMAR EXTEND Gram ; universe_level: [ [ "Set" -> { GSet } + (* no parsing SProp as a level *) | "Prop" -> { GProp } | "Type" -> { GType UUnknown } | "_" -> { GType UAnonymous } diff --git a/plugins/btauto/refl_btauto.ml b/plugins/btauto/refl_btauto.ml index 4d817625f5..1bdedcaf26 100644 --- a/plugins/btauto/refl_btauto.ml +++ b/plugins/btauto/refl_btauto.ml @@ -196,7 +196,7 @@ module Btauto = struct let assign = List.combine penv var in let map_msg (key, v) = let b = if v then str "true" else str "false" in - let sigma, env = Pfedit.get_current_context () in + let sigma, env = Tacmach.project gl, Tacmach.pf_env gl in let term = Printer.pr_constr_env env sigma key in term ++ spc () ++ str ":=" ++ spc () ++ b in diff --git a/plugins/cc/ccalgo.ml b/plugins/cc/ccalgo.ml index 575d964158..048ec56dee 100644 --- a/plugins/cc/ccalgo.ml +++ b/plugins/cc/ccalgo.ml @@ -17,6 +17,7 @@ open Pp open Names open Sorts open Constr +open Context open Vars open Goptions open Tacmach @@ -26,10 +27,6 @@ let init_size=5 let cc_verbose=ref false -let print_constr t = - let sigma, env = Pfedit.get_current_context () in - Printer.pr_econstr_env env sigma t - let debug x = if !cc_verbose then Feedback.msg_debug (x ()) @@ -421,11 +418,11 @@ let new_representative typ = let _A_ = Name (Id.of_string "A") let _B_ = Name (Id.of_string "A") -let _body_ = mkProd(Anonymous,mkRel 2,mkRel 2) +let _body_ = mkProd(make_annot Anonymous Sorts.Relevant,mkRel 2,mkRel 2) let cc_product s1 s2 = - mkLambda(_A_,mkSort(s1), - mkLambda(_B_,mkSort(s2),_body_)) + mkLambda(make_annot _A_ Sorts.Relevant,mkSort(s1), + mkLambda(make_annot _B_ Sorts.Relevant,mkSort(s2),_body_)) let rec constr_of_term = function Symb s-> s @@ -452,11 +449,11 @@ let rec canonize_name sigma c = let canon_mind = MutInd.make1 (MutInd.canonical kn) in mkConstructU (((canon_mind,i),j),u) | Prod (na,t,ct) -> - mkProd (na,func t, func ct) + mkProd (na,func t, func ct) | Lambda (na,t,ct) -> - mkLambda (na, func t,func ct) + mkLambda (na, func t,func ct) | LetIn (na,b,t,ct) -> - mkLetIn (na, func b,func t,func ct) + mkLetIn (na, func b,func t,func ct) | App (ct,l) -> mkApp (func ct,Array.Smart.map func l) | Proj(p,c) -> @@ -483,11 +480,11 @@ let rec inst_pattern subst = function (fun spat f -> Appli (f,inst_pattern subst spat)) args t -let pr_idx_term uf i = str "[" ++ int i ++ str ":=" ++ - print_constr (EConstr.of_constr (constr_of_term (term uf i))) ++ str "]" +let pr_idx_term env sigma uf i = str "[" ++ int i ++ str ":=" ++ + Printer.pr_econstr_env env sigma (EConstr.of_constr (constr_of_term (term uf i))) ++ str "]" -let pr_term t = str "[" ++ - print_constr (EConstr.of_constr (constr_of_term t)) ++ str "]" +let pr_term env sigma t = str "[" ++ + Printer.pr_econstr_env env sigma (EConstr.of_constr (constr_of_term t)) ++ str "]" let rec add_term state t= let uf=state.uf in @@ -602,16 +599,16 @@ let add_inst state (inst,int_subst) = begin debug (fun () -> (str "Adding new equality, depth="++ int state.rew_depth) ++ fnl () ++ - (str " [" ++ print_constr (EConstr.of_constr prf) ++ str " : " ++ - pr_term s ++ str " == " ++ pr_term t ++ str "]")); + (str " [" ++ Printer.pr_econstr_env state.env state.sigma (EConstr.of_constr prf) ++ str " : " ++ + pr_term state.env state.sigma s ++ str " == " ++ pr_term state.env state.sigma t ++ str "]")); add_equality state prf s t end else begin debug (fun () -> (str "Adding new disequality, depth="++ int state.rew_depth) ++ fnl () ++ - (str " [" ++ print_constr (EConstr.of_constr prf) ++ str " : " ++ - pr_term s ++ str " <> " ++ pr_term t ++ str "]")); + (str " [" ++ Printer.pr_econstr_env state.env state.sigma (EConstr.of_constr prf) ++ str " : " ++ + pr_term state.env state.sigma s ++ str " <> " ++ pr_term state.env state.sigma t ++ str "]")); add_disequality state (Hyp prf) s t end end @@ -639,8 +636,8 @@ let join_path uf i j= min_path (down_path uf i [],down_path uf j []) let union state i1 i2 eq= - debug (fun () -> str "Linking " ++ pr_idx_term state.uf i1 ++ - str " and " ++ pr_idx_term state.uf i2 ++ str "."); + debug (fun () -> str "Linking " ++ pr_idx_term state.env state.sigma state.uf i1 ++ + str " and " ++ pr_idx_term state.env state.sigma state.uf i2 ++ str "."); let r1= get_representative state.uf i1 and r2= get_representative state.uf i2 in link state.uf i1 i2 eq; @@ -680,8 +677,8 @@ let union state i1 i2 eq= let merge eq state = (* merge and no-merge *) debug - (fun () -> str "Merging " ++ pr_idx_term state.uf eq.lhs ++ - str " and " ++ pr_idx_term state.uf eq.rhs ++ str "."); + (fun () -> str "Merging " ++ pr_idx_term state.env state.sigma state.uf eq.lhs ++ + str " and " ++ pr_idx_term state.env state.sigma state.uf eq.rhs ++ str "."); let uf=state.uf in let i=find uf eq.lhs and j=find uf eq.rhs in @@ -693,7 +690,7 @@ let merge eq state = (* merge and no-merge *) let update t state = (* update 1 and 2 *) debug - (fun () -> str "Updating term " ++ pr_idx_term state.uf t ++ str "."); + (fun () -> str "Updating term " ++ pr_idx_term state.env state.sigma state.uf t ++ str "."); let (i,j) as sign = signature state.uf t in let (u,v) = subterms state.uf t in let rep = get_representative state.uf i in @@ -755,7 +752,7 @@ let process_constructor_mark t i rep pac state = let process_mark t m state = debug - (fun () -> str "Processing mark for term " ++ pr_idx_term state.uf t ++ str "."); + (fun () -> str "Processing mark for term " ++ pr_idx_term state.env state.sigma state.uf t ++ str "."); let i=find state.uf t in let rep=get_representative state.uf i in match m with @@ -776,8 +773,8 @@ let check_disequalities state = else (str "No", check_aux q) in let _ = debug - (fun () -> str "Checking if " ++ pr_idx_term state.uf dis.lhs ++ str " = " ++ - pr_idx_term state.uf dis.rhs ++ str " ... " ++ info) in + (fun () -> str "Checking if " ++ pr_idx_term state.env state.sigma state.uf dis.lhs ++ str " = " ++ + pr_idx_term state.env state.sigma state.uf dis.rhs ++ str " ... " ++ info) in ans | [] -> None in @@ -806,7 +803,8 @@ let __eps__ = Id.of_string "_eps_" let new_state_var typ state = let ids = Environ.ids_of_named_context_val (Environ.named_context_val state.env) in let id = Namegen.next_ident_away __eps__ ids in - state.env<- EConstr.push_named (Context.Named.Declaration.LocalAssum (id,typ)) state.env; + let r = Sorts.Relevant in (* TODO relevance *) + state.env<- EConstr.push_named (Context.Named.Declaration.LocalAssum (make_annot id r,typ)) state.env; id let complete_one_class state i= @@ -814,9 +812,9 @@ let complete_one_class state i= Partial pac -> let rec app t typ n = if n<=0 then t else - let _,etyp,rest= destProd typ in + let _,etyp,rest= destProd typ in let id = new_state_var (EConstr.of_constr etyp) state in - app (Appli(t,Eps id)) (substl [mkVar id] rest) (n-1) in + app (Appli(t,Eps id)) (substl [mkVar id] rest) (n-1) in let _c = Typing.unsafe_type_of state.env state.sigma (EConstr.of_constr (constr_of_term (term state.uf pac.cnode))) in let _c = EConstr.Unsafe.to_constr _c in diff --git a/plugins/cc/ccalgo.mli b/plugins/cc/ccalgo.mli index d52e83dc31..978969bf59 100644 --- a/plugins/cc/ccalgo.mli +++ b/plugins/cc/ccalgo.mli @@ -169,7 +169,7 @@ val find_instances : state -> (quant_eq * int array) list val execute : bool -> state -> explanation option -val pr_idx_term : forest -> int -> Pp.t +val pr_idx_term : Environ.env -> Evd.evar_map -> forest -> int -> Pp.t val empty_forest: unit -> forest diff --git a/plugins/cc/ccproof.ml b/plugins/cc/ccproof.ml index 1f1fa9c99a..4f46f8327a 100644 --- a/plugins/cc/ccproof.ml +++ b/plugins/cc/ccproof.ml @@ -94,65 +94,65 @@ let pinject p c n a = p_rhs=nth_arg p.p_rhs (n-a); p_rule=Inject(p,c,n,a)} -let rec equal_proof uf i j= - debug (fun () -> str "equal_proof " ++ pr_idx_term uf i ++ brk (1,20) ++ pr_idx_term uf j); +let rec equal_proof env sigma uf i j= + debug (fun () -> str "equal_proof " ++ pr_idx_term env sigma uf i ++ brk (1,20) ++ pr_idx_term env sigma uf j); if i=j then prefl (term uf i) else let (li,lj)=join_path uf i j in - ptrans (path_proof uf i li) (psym (path_proof uf j lj)) + ptrans (path_proof env sigma uf i li) (psym (path_proof env sigma uf j lj)) -and edge_proof uf ((i,j),eq)= - debug (fun () -> str "edge_proof " ++ pr_idx_term uf i ++ brk (1,20) ++ pr_idx_term uf j); - let pi=equal_proof uf i eq.lhs in - let pj=psym (equal_proof uf j eq.rhs) in +and edge_proof env sigma uf ((i,j),eq)= + debug (fun () -> str "edge_proof " ++ pr_idx_term env sigma uf i ++ brk (1,20) ++ pr_idx_term env sigma uf j); + let pi=equal_proof env sigma uf i eq.lhs in + let pj=psym (equal_proof env sigma uf j eq.rhs) in let pij= match eq.rule with Axiom (s,reversed)-> if reversed then psymax (axioms uf) s else pax (axioms uf) s - | Congruence ->congr_proof uf eq.lhs eq.rhs + | Congruence ->congr_proof env sigma uf eq.lhs eq.rhs | Injection (ti,ipac,tj,jpac,k) -> (* pi_k ipac = p_k jpac *) - let p=ind_proof uf ti ipac tj jpac in + let p=ind_proof env sigma uf ti ipac tj jpac in let cinfo= get_constructor_info uf ipac.cnode in pinject p cinfo.ci_constr cinfo.ci_nhyps k in ptrans (ptrans pi pij) pj -and constr_proof uf i ipac= - debug (fun () -> str "constr_proof " ++ pr_idx_term uf i ++ brk (1,20)); +and constr_proof env sigma uf i ipac= + debug (fun () -> str "constr_proof " ++ pr_idx_term env sigma uf i ++ brk (1,20)); let t=find_oldest_pac uf i ipac in - let eq_it=equal_proof uf i t in + let eq_it=equal_proof env sigma uf i t in if ipac.args=[] then eq_it else let fipac=tail_pac ipac in let (fi,arg)=subterms uf t in let targ=term uf arg in - let p=constr_proof uf fi fipac in + let p=constr_proof env sigma uf fi fipac in ptrans eq_it (pcongr p (prefl targ)) -and path_proof uf i l= - debug (fun () -> str "path_proof " ++ pr_idx_term uf i ++ brk (1,20) ++ str "{" ++ +and path_proof env sigma uf i l= + debug (fun () -> str "path_proof " ++ pr_idx_term env sigma uf i ++ brk (1,20) ++ str "{" ++ (prlist_with_sep (fun () -> str ",") (fun ((_,j),_) -> int j) l) ++ str "}"); match l with | [] -> prefl (term uf i) - | x::q->ptrans (path_proof uf (snd (fst x)) q) (edge_proof uf x) + | x::q->ptrans (path_proof env sigma uf (snd (fst x)) q) (edge_proof env sigma uf x) -and congr_proof uf i j= - debug (fun () -> str "congr_proof " ++ pr_idx_term uf i ++ brk (1,20) ++ pr_idx_term uf j); +and congr_proof env sigma uf i j= + debug (fun () -> str "congr_proof " ++ pr_idx_term env sigma uf i ++ brk (1,20) ++ pr_idx_term env sigma uf j); let (i1,i2) = subterms uf i and (j1,j2) = subterms uf j in - pcongr (equal_proof uf i1 j1) (equal_proof uf i2 j2) + pcongr (equal_proof env sigma uf i1 j1) (equal_proof env sigma uf i2 j2) -and ind_proof uf i ipac j jpac= - debug (fun () -> str "ind_proof " ++ pr_idx_term uf i ++ brk (1,20) ++ pr_idx_term uf j); - let p=equal_proof uf i j - and p1=constr_proof uf i ipac - and p2=constr_proof uf j jpac in +and ind_proof env sigma uf i ipac j jpac= + debug (fun () -> str "ind_proof " ++ pr_idx_term env sigma uf i ++ brk (1,20) ++ pr_idx_term env sigma uf j); + let p=equal_proof env sigma uf i j + and p1=constr_proof env sigma uf i ipac + and p2=constr_proof env sigma uf j jpac in ptrans (psym p1) (ptrans p p2) -let build_proof uf= +let build_proof env sigma uf= function - | `Prove (i,j) -> equal_proof uf i j - | `Discr (i,ci,j,cj)-> ind_proof uf i ci j cj + | `Prove (i,j) -> equal_proof env sigma uf i j + | `Discr (i,ci,j,cj)-> ind_proof env sigma uf i ci j cj diff --git a/plugins/cc/ccproof.mli b/plugins/cc/ccproof.mli index bebef241e1..9ea31259c1 100644 --- a/plugins/cc/ccproof.mli +++ b/plugins/cc/ccproof.mli @@ -41,20 +41,20 @@ val pinject : proof -> pconstructor -> int -> int -> proof (** Proof building functions *) -val equal_proof : forest -> int -> int -> proof +val equal_proof : Environ.env -> Evd.evar_map -> forest -> int -> int -> proof -val edge_proof : forest -> (int*int)*equality -> proof +val edge_proof : Environ.env -> Evd.evar_map -> forest -> (int*int)*equality -> proof -val path_proof : forest -> int -> ((int*int)*equality) list -> proof +val path_proof : Environ.env -> Evd.evar_map -> forest -> int -> ((int*int)*equality) list -> proof -val congr_proof : forest -> int -> int -> proof +val congr_proof : Environ.env -> Evd.evar_map -> forest -> int -> int -> proof -val ind_proof : forest -> int -> pa_constructor -> int -> pa_constructor -> proof +val ind_proof : Environ.env -> Evd.evar_map -> forest -> int -> pa_constructor -> int -> pa_constructor -> proof (** Main proof building function *) val build_proof : - forest -> + Environ.env -> Evd.evar_map -> forest -> [ `Discr of int * pa_constructor * int * pa_constructor | `Prove of int * int ] -> proof diff --git a/plugins/cc/cctac.ml b/plugins/cc/cctac.ml index 055d36747d..50fc2448fc 100644 --- a/plugins/cc/cctac.ml +++ b/plugins/cc/cctac.ml @@ -15,6 +15,7 @@ open Names open Inductiveops open Declarations open Constr +open Context open EConstr open Vars open Tactics @@ -151,19 +152,19 @@ let patterns_of_constr env sigma nrels term= let rec quantified_atom_of_constr env sigma nrels term = match EConstr.kind sigma (whd_delta env sigma term) with - Prod (id,atom,ff) -> + Prod (id,atom,ff) -> if is_global sigma (Lazy.force _False) ff then let patts=patterns_of_constr env sigma nrels atom in `Nrule patts else - quantified_atom_of_constr (EConstr.push_rel (RelDecl.LocalAssum (id,atom)) env) sigma (succ nrels) ff + quantified_atom_of_constr (EConstr.push_rel (RelDecl.LocalAssum (id,atom)) env) sigma (succ nrels) ff | _ -> let patts=patterns_of_constr env sigma nrels term in `Rule patts let litteral_of_constr env sigma term= match EConstr.kind sigma (whd_delta env sigma term) with - | Prod (id,atom,ff) -> + | Prod (id,atom,ff) -> if is_global sigma (Lazy.force _False) ff then match (atom_of_constr env sigma atom) with `Eq(t,a,b) -> `Neq(t,a,b) @@ -171,7 +172,7 @@ let litteral_of_constr env sigma term= else begin try - quantified_atom_of_constr (EConstr.push_rel (RelDecl.LocalAssum (id,atom)) env) sigma 1 ff + quantified_atom_of_constr (EConstr.push_rel (RelDecl.LocalAssum (id,atom)) env) sigma 1 ff with Not_found -> `Other (decompose_term env sigma term) end @@ -233,7 +234,7 @@ let build_projection intype (cstr:pconstructor) special default gls= 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) + sigma, mkLambda(make_annot (Name id) Sorts.Relevant,intype,body) (* generate an adhoc tactic following the proof tree *) @@ -318,7 +319,7 @@ let rec proof_tac p : unit Proofview.tactic = refresh_universes (type_of tx1) (fun typx -> refresh_universes (type_of (mkApp (tf1,[|tx1|]))) (fun typfx -> let id = Tacmach.New.pf_get_new_id (Id.of_string "f") gl in - let appx1 = mkLambda(Name id,typf,mkApp(mkRel 1,[|tx1|])) in + let appx1 = mkLambda(make_annot (Name id) Sorts.Relevant,typf,mkApp(mkRel 1,[|tx1|])) in let lemma1 = app_global_with_holes _f_equal [|typf;typfx;appx1;tf1;tf2|] 1 in let lemma2 = app_global_with_holes _f_equal [|typx;typfx;tf2;tx1;tx2|] 1 in let prf = @@ -377,7 +378,7 @@ let convert_to_goal_tac c t1 t2 p = let neweq= app_global _eq [|sort;tt1;tt2|] in let e = Tacmach.New.pf_get_new_id (Id.of_string "e") gl in let x = Tacmach.New.pf_get_new_id (Id.of_string "X") gl in - let identity=mkLambda (Name x,sort,mkRel 1) in + let identity=mkLambda (make_annot (Name x) Sorts.Relevant,sort,mkRel 1) in let endt = app_global _eq_rect [|sort;tt1;identity;c;tt2;mkVar e|] in Tacticals.New.tclTHENS (neweq (assert_before (Name e))) [proof_tac p; endt refine_exact_check] @@ -432,7 +433,7 @@ let cc_tactic depth additionnal_terms = debug (fun () -> Pp.str "Goal solved, generating proof ..."); match reason with Discrimination (i,ipac,j,jpac) -> - let p=build_proof uf (`Discr (i,ipac,j,jpac)) in + let p=build_proof (Tacmach.New.pf_env gl) sigma uf (`Discr (i,ipac,j,jpac)) in let cstr=(get_constructor_info uf ipac.cnode).ci_constr in discriminate_tac cstr p | Incomplete -> @@ -461,7 +462,8 @@ let cc_tactic depth additionnal_terms = Pp.str " replacing metavariables by arbitrary terms."); Tacticals.New.tclFAIL 0 (str "Incomplete") | Contradiction dis -> - let p=build_proof uf (`Prove (dis.lhs,dis.rhs)) in + let env = Proofview.Goal.env gl in + let p=build_proof env sigma uf (`Prove (dis.lhs,dis.rhs)) in let ta=term uf dis.lhs and tb=term uf dis.rhs in match dis.rule with Goal -> proof_tac p diff --git a/plugins/derive/derive.ml b/plugins/derive/derive.ml index d06a241969..afdbfa1999 100644 --- a/plugins/derive/derive.ml +++ b/plugins/derive/derive.ml @@ -9,6 +9,7 @@ (************************************************************************) open Constr +open Context open Context.Named.Declaration let map_const_entry_body (f:constr->constr) (x:Safe_typing.private_constants Entries.const_entry_body) @@ -39,7 +40,7 @@ let start_deriving f suchthat lemma = TCons ( env , sigma , f_type , (fun sigma ef -> let f_type = EConstr.Unsafe.to_constr f_type in let ef = EConstr.Unsafe.to_constr ef in - let env' = Environ.push_named (LocalDef (f, ef, f_type)) env in + let env' = Environ.push_named (LocalDef (annotR f, ef, f_type)) env in let sigma, suchthat = Constrintern.interp_type_evars ~program_mode:false env' sigma suchthat in TCons ( env' , sigma , suchthat , (fun sigma _ -> TNil sigma)))))) diff --git a/plugins/extraction/extract_env.ml b/plugins/extraction/extract_env.ml index b59e3b608c..0fa9be21c9 100644 --- a/plugins/extraction/extract_env.ml +++ b/plugins/extraction/extract_env.ml @@ -150,7 +150,7 @@ let check_fix env sg cb i = | Undef _ | OpaqueDef _ | Primitive _ -> raise Impossible let prec_declaration_equal sg (na1, ca1, ta1) (na2, ca2, ta2) = - Array.equal Name.equal na1 na2 && + Array.equal (Context.eq_annot Name.equal) na1 na2 && Array.equal (EConstr.eq_constr sg) ca1 ca2 && Array.equal (EConstr.eq_constr sg) ta1 ta2 diff --git a/plugins/extraction/extraction.ml b/plugins/extraction/extraction.ml index ef6c07bff2..c9cfd74362 100644 --- a/plugins/extraction/extraction.ml +++ b/plugins/extraction/extraction.ml @@ -13,6 +13,7 @@ open Util open Names open Term open Constr +open Context open Declarations open Declareops open Environ @@ -73,13 +74,18 @@ type flag = info * scheme (*s [flag_of_type] transforms a type [t] into a [flag]. Really important function. *) +let info_of_family = function + | InSProp | InProp -> Logic + | InSet | InType -> Info + +let info_of_sort s = info_of_family (Sorts.family s) + let rec flag_of_type env sg t : flag = let t = whd_all env sg t in match EConstr.kind sg t with | Prod (x,t,c) -> flag_of_type (EConstr.push_rel (LocalAssum (x,t)) env) sg c - | Sort s when Sorts.is_prop (EConstr.ESorts.kind sg s) -> (Logic,TypeScheme) - | Sort _ -> (Info,TypeScheme) - | _ -> if (sort_of env sg t) == InProp then (Logic,Default) else (Info,Default) + | Sort s -> (info_of_sort (EConstr.ESorts.kind sg s),TypeScheme) + | _ -> (info_of_family (sort_of env sg t),Default) (*s Two particular cases of [flag_of_type]. *) @@ -179,7 +185,7 @@ let rec type_sign_vl env sg c = | Prod (n,t,d) -> let s,vl = type_sign_vl (push_rel_assum (n,t) env) sg d in if not (is_info_scheme env sg t) then Kill Kprop::s, vl - else Keep::s, (make_typvar n vl) :: vl + else Keep::s, (make_typvar n.binder_name vl) :: vl | _ -> [],[] let rec nb_default_params env sg c = @@ -259,14 +265,14 @@ let rec extract_type env sg db j c args = (* We just accumulate the arguments. *) extract_type env sg db j d (Array.to_list args' @ args) | Lambda (_,_,d) -> - (match args with + (match args with | [] -> assert false (* A lambda cannot be a type. *) | a :: args -> extract_type env sg db j (EConstr.Vars.subst1 a d) args) | Prod (n,t,d) -> - assert (List.is_empty args); - let env' = push_rel_assum (n,t) env in + assert (List.is_empty args); + let env' = push_rel_assum (n,t) env in (match flag_of_type env sg t with - | (Info, Default) -> + | (Info, Default) -> (* Standard case: two [extract_type] ... *) let mld = extract_type env' sg (0::db) j d [] in (match expand env mld with @@ -291,7 +297,7 @@ let rec extract_type env sg db j c args = (match EConstr.lookup_rel n env with | LocalDef (_,t,_) -> extract_type env sg db j (EConstr.Vars.lift n t) args - | _ -> + | _ -> (* Asks [db] a translation for [n]. *) if n > List.length db then Tunknown else let n' = List.nth db (n-1) in @@ -492,8 +498,8 @@ and extract_really_ind env kn mib = (* Now we're sure it's a record. *) (* First, we find its field names. *) let rec names_prod t = match Constr.kind t with - | Prod(n,_,t) -> n::(names_prod t) - | LetIn(_,_,_,t) -> names_prod t + | Prod(n,_,t) -> n::(names_prod t) + | LetIn(_,_,_,t) -> names_prod t | Cast(t,_,_) -> names_prod t | _ -> [] in @@ -506,9 +512,9 @@ and extract_really_ind env kn mib = | [],[] -> [] | _::l, typ::typs when isTdummy (expand env typ) -> select_fields l typs - | Anonymous::l, typ::typs -> + | {binder_name=Anonymous}::l, typ::typs -> None :: (select_fields l typs) - | Name id::l, typ::typs -> + | {binder_name=Name id}::l, typ::typs -> let knp = Constant.make2 mp (Label.of_id id) in (* Is it safe to use [id] for projections [foo.id] ? *) if List.for_all ((==) Keep) (type2signature env typ) @@ -551,8 +557,8 @@ and extract_really_ind env kn mib = and extract_type_cons env sg db dbmap c i = match EConstr.kind sg (whd_all env sg c) with | Prod (n,t,d) -> - let env' = push_rel_assum (n,t) env in - let db' = (try Int.Map.find i dbmap with Not_found -> 0) :: db in + let env' = push_rel_assum (n,t) env in + let db' = (try Int.Map.find i dbmap with Not_found -> 0) :: db in let l = extract_type_cons env' sg db' dbmap d (i+1) in (extract_type env sg db 0 t []) :: l | _ -> [] @@ -615,17 +621,18 @@ let rec extract_term env sg mle mlt c args = | App (f,a) -> extract_term env sg mle mlt f (Array.to_list a @ args) | Lambda (n, t, d) -> - let id = id_of_name n in + let id = map_annot id_of_name n in + let idna = map_annot Name.mk_name id in (match args with | a :: l -> (* We make as many [LetIn] as possible. *) let l' = List.map (EConstr.Vars.lift 1) l in - let d' = EConstr.mkLetIn (Name id,a,t,applistc d l') in + let d' = EConstr.mkLetIn (idna,a,t,applistc d l') in extract_term env sg mle mlt d' [] - | [] -> - let env' = push_rel_assum (Name id, t) env in + | [] -> + let env' = push_rel_assum (idna, t) env in let id, a = - try check_default env sg t; Id id, new_meta() + try check_default env sg t; Id id.binder_name, new_meta() with NotDefault d -> Dummy, Tdummy d in let b = new_meta () in @@ -634,9 +641,9 @@ let rec extract_term env sg mle mlt c args = let d' = extract_term env' sg (Mlenv.push_type mle a) b d [] in put_magic_if magic (MLlam (id, d'))) | LetIn (n, c1, t1, c2) -> - let id = id_of_name n in - let env' = EConstr.push_rel (LocalDef (Name id, c1, t1)) env in - (* We directly push the args inside the [LetIn]. + let id = map_annot id_of_name n in + let env' = EConstr.push_rel (LocalDef (map_annot Name.mk_name id, c1, t1)) env in + (* We directly push the args inside the [LetIn]. TODO: the opt_let_app flag is supposed to prevent that *) let args' = List.map (EConstr.Vars.lift 1) args in (try @@ -649,7 +656,7 @@ let rec extract_term env sg mle mlt c args = then Mlenv.push_gen mle a else Mlenv.push_type mle a in - MLletin (Id id, c1', extract_term env' sg mle' mlt c2 args') + MLletin (Id id.binder_name, c1', extract_term env' sg mle' mlt c2 args') with NotDefault d -> let mle' = Mlenv.push_std_type mle (Tdummy d) in ast_pop (extract_term env' sg mle' mlt c2 args')) @@ -913,7 +920,7 @@ and extract_fix env sg mle i (fi,ti,ci as recd) mlt = metas.(i) <- mlt; let mle = Array.fold_left Mlenv.push_type mle metas in let ei = Array.map2 (extract_maybe_term env sg mle) metas ci in - MLfix (i, Array.map id_of_name fi, ei) + MLfix (i, Array.map (fun x -> id_of_name x.binder_name) fi, ei) (*S ML declarations. *) @@ -989,7 +996,7 @@ let extract_std_constant env sg kn body typ = (* The initial ML environment. *) let mle = List.fold_left Mlenv.push_std_type Mlenv.empty l in (* The lambdas names. *) - let ids = List.map (fun (n,_) -> Id (id_of_name n)) rels in + let ids = List.map (fun (n,_) -> Id (id_of_name n.binder_name)) rels in (* The according Coq environment. *) let env = push_rels_assum rels env in (* The real extraction: *) @@ -1055,12 +1062,15 @@ let fake_match_projection env p = ci_npar = mib.mind_nparams; ci_cstr_ndecls = mip.mind_consnrealdecls; ci_cstr_nargs = mip.mind_consnrealargs; + ci_relevance = Declareops.relevance_of_projection_repr mib p; ci_pp_info; } in let x = match mib.mind_record with | NotRecord | FakeRecord -> assert false - | PrimRecord info -> Name (pi1 info.(snd ind)) + | PrimRecord info -> + let x, _, _, _ = info.(snd ind) in + make_annot (Name x) mip.mind_relevance in let indty = mkApp (indu, Context.Rel.to_extended_vect mkRel 0 paramslet) in let rec fold arg j subst = function @@ -1068,7 +1078,7 @@ let fake_match_projection env p = | LocalAssum (na,ty) :: rem -> let ty = Vars.substl subst (liftn 1 j ty) in if arg != proj_arg then - let lab = match na with Name id -> Label.of_id id | Anonymous -> assert false in + let lab = match na.binder_name with Name id -> Label.of_id id | Anonymous -> assert false in let kn = Projection.Repr.make ind ~proj_npars:mib.mind_nparams ~proj_arg:arg lab in fold (arg+1) (j+1) (mkProj (Projection.make kn false, mkRel 1)::subst) rem else diff --git a/plugins/extraction/table.ml b/plugins/extraction/table.ml index 2058837b8e..399a77c596 100644 --- a/plugins/extraction/table.ml +++ b/plugins/extraction/table.ml @@ -449,11 +449,11 @@ let argnames_of_global r = let typ, _ = Typeops.type_of_global_in_context env r in let rels,_ = decompose_prod (Reduction.whd_all env typ) in - List.rev_map fst rels + List.rev_map (fun x -> Context.binder_name (fst x)) rels let msg_of_implicit = function | Kimplicit (r,i) -> - let name = match List.nth (argnames_of_global r) (i-1) with + let name = match (List.nth (argnames_of_global r) (i-1)) with | Anonymous -> "" | Name id -> "(" ^ Id.to_string id ^ ") " in diff --git a/plugins/firstorder/instances.ml b/plugins/firstorder/instances.ml index 286021d68e..1c9ab2e3bd 100644 --- a/plugins/firstorder/instances.ml +++ b/plugins/firstorder/instances.ml @@ -107,7 +107,7 @@ let mk_open_instance env evmap id idc m t = (* since we know we will get a product, reduction is not too expensive *) let (nam,_,_)=destProd evmap (whd_all env evmap typ) in - match nam with + match nam.Context.binder_name with Name id -> id | Anonymous -> dummy_bvid in let revt=substl (List.init m (fun i->mkRel (m-i))) t in @@ -115,7 +115,7 @@ let mk_open_instance env evmap id idc m t = if Int.equal n 0 then evmap, decls else let nid=(fresh_id_in_env avoid var_id env) in let (evmap, (c, _)) = Evarutil.new_type_evar env evmap Evd.univ_flexible in - let decl = LocalAssum (Name nid, c) in + let decl = LocalAssum (Context.make_annot (Name nid) Sorts.Relevant, c) in aux (n-1) (Id.Set.add nid avoid) (EConstr.push_rel decl env) evmap (decl::decls) in let evmap, decls = aux m Id.Set.empty env evmap [] in (evmap, decls, revt) diff --git a/plugins/firstorder/rules.ml b/plugins/firstorder/rules.ml index 832a98b7f8..7f06ab6777 100644 --- a/plugins/firstorder/rules.ml +++ b/plugins/firstorder/rules.ml @@ -163,9 +163,9 @@ let ll_ind_tac (ind,u as indu) largs backtrack id continue seq = let ll_arrow_tac a b c backtrack id continue seq= let open EConstr in let open Vars in - let cc=mkProd(Anonymous,a,(lift 1 b)) in - let d idc = mkLambda (Anonymous,b, - mkApp (idc, [|mkLambda (Anonymous,(lift 1 a),(mkRel 2))|])) in + let cc=mkProd(Context.make_annot Anonymous Sorts.Relevant,a,(lift 1 b)) in + let d idc = mkLambda (Context.make_annot Anonymous Sorts.Relevant,b, + mkApp (idc, [|mkLambda (Context.make_annot Anonymous Sorts.Relevant,(lift 1 a),(mkRel 2))|])) in tclORELSE (tclTHENS (cut c) [tclTHENLIST diff --git a/plugins/firstorder/sequent.ml b/plugins/firstorder/sequent.ml index 5958fe8203..01b18e2f30 100644 --- a/plugins/firstorder/sequent.ml +++ b/plugins/firstorder/sequent.ml @@ -235,7 +235,7 @@ let print_cmap map= str "| " ++ prlist Printer.pr_global l ++ str " : " ++ - Ppconstr.pr_constr_expr xc ++ + Ppconstr.pr_constr_expr env sigma xc ++ cut () ++ s in (v 0 diff --git a/plugins/firstorder/unify.ml b/plugins/firstorder/unify.ml index d63fe9d799..0c958ddee3 100644 --- a/plugins/firstorder/unify.ml +++ b/plugins/firstorder/unify.ml @@ -65,13 +65,13 @@ let unif evd t1 t2= bind i t else raise (UFAIL(nt1,nt2)) | Cast(_,_,_),_->Queue.add (strip_outer_cast evd nt1,nt2) bige | _,Cast(_,_,_)->Queue.add (nt1,strip_outer_cast evd nt2) bige - | (Prod(_,a,b),Prod(_,c,d))|(Lambda(_,a,b),Lambda(_,c,d))-> + | (Prod(_,a,b),Prod(_,c,d))|(Lambda(_,a,b),Lambda(_,c,d))-> Queue.add (a,c) bige;Queue.add (pop b,pop d) bige | Case (_,pa,ca,va),Case (_,pb,cb,vb)-> Queue.add (pa,pb) bige; Queue.add (ca,cb) bige; let l=Array.length va in - if not (Int.equal l (Array.length vb)) then + if not (Int.equal l (Array.length vb)) then raise (UFAIL (nt1,nt2)) else for i=0 to l-1 do diff --git a/plugins/funind/functional_principles_proofs.ml b/plugins/funind/functional_principles_proofs.ml index 6fd2f7c2bc..16f376931e 100644 --- a/plugins/funind/functional_principles_proofs.ml +++ b/plugins/funind/functional_principles_proofs.ml @@ -2,6 +2,7 @@ open Printer open CErrors open Util open Constr +open Context open EConstr open Vars open Namegen @@ -44,10 +45,6 @@ let observe_tac s tac g = observe_tac_stream (str s) tac g *) -let pr_leconstr_fp = - let sigma, env = Pfedit.get_current_context () in - Printer.pr_leconstr_env env sigma - let debug_queue = Stack.create () let rec print_debug_queue e = @@ -163,7 +160,7 @@ let rec incompatible_constructor_terms sigma t1 t2 = List.exists2 (incompatible_constructor_terms sigma) arg1 arg2 ) -let is_incompatible_eq sigma t = +let is_incompatible_eq env sigma t = let res = try match EConstr.kind sigma t with @@ -175,7 +172,7 @@ let is_incompatible_eq sigma t = | _ -> false with e when CErrors.noncritical e -> false in - if res then observe (str "is_incompatible_eq " ++ pr_leconstr_fp t); + if res then observe (str "is_incompatible_eq " ++ pr_leconstr_env env sigma t); res let change_hyp_with_using msg hyp_id t tac : tactic = @@ -302,7 +299,7 @@ let change_eq env sigma hyp_id (context:rel_context) x t end_of_type = in let old_context_length = List.length context + 1 in let witness_fun = - mkLetIn(Anonymous,make_refl_eq constructor t1_typ (fst t1),t, + mkLetIn(make_annot Anonymous Sorts.Relevant,make_refl_eq constructor t1_typ (fst t1),t, mkApp(mkVar hyp_id,Array.init old_context_length (fun i -> mkRel (old_context_length - i))) ) in @@ -312,7 +309,8 @@ let change_eq env sigma hyp_id (context:rel_context) x t end_of_type = try let witness = Int.Map.find i sub in if is_local_def decl then anomaly (Pp.str "can not redefine a rel!"); - (pop end_of_type,ctxt_size,mkLetIn (RelDecl.get_name decl, witness, RelDecl.get_type decl, witness_fun)) + (pop end_of_type,ctxt_size,mkLetIn (RelDecl.get_annot decl, + witness, RelDecl.get_type decl, witness_fun)) with Not_found -> (mkProd_or_LetIn decl end_of_type, ctxt_size + 1, mkLambda_or_LetIn decl witness_fun) ) @@ -428,7 +426,7 @@ let clean_hyp_with_heq ptes_infos eq_hyps hyp_id env sigma = else if isProd sigma type_of_hyp then begin - let (x,t_x,t') = destProd sigma type_of_hyp in + let (x,t_x,t') = destProd sigma type_of_hyp in let actual_real_type_of_hyp = it_mkProd_or_LetIn t' context in if is_property sigma ptes_infos t_x actual_real_type_of_hyp then begin @@ -478,7 +476,7 @@ let clean_hyp_with_heq ptes_infos eq_hyps hyp_id env sigma = (* ); *) raise TOREMOVE; (* False -> .. useless *) end - else if is_incompatible_eq sigma t_x then raise TOREMOVE (* t_x := C1 ... = C2 ... *) + else if is_incompatible_eq env sigma t_x then raise TOREMOVE (* t_x := C1 ... = C2 ... *) else if eq_constr sigma t_x coq_True (* Trivial => we remove this precons *) then (* observe (str "In "++Ppconstr.pr_id hyp_id++ *) @@ -541,7 +539,7 @@ let clean_hyp_with_heq ptes_infos eq_hyps hyp_id env sigma = (scan_type new_context new_t') with NoChange -> (* Last thing todo : push the rel in the context and continue *) - scan_type (LocalAssum (x,t_x) :: context) t' + scan_type (LocalAssum (x,t_x) :: context) t' end end else @@ -610,7 +608,7 @@ let treat_new_case ptes_infos nb_prod continue_tac term dyn_infos = anomaly (Pp.str "cannot compute new term value.") in let fun_body = - mkLambda(Anonymous, + mkLambda(make_annot Anonymous Sorts.Relevant, pf_unsafe_type_of g' term, Termops.replace_term (project g') term (mkRel 1) dyn_infos.info ) @@ -724,7 +722,7 @@ let build_proof (treat_new_case ptes_infos nb_instantiate_partial - (build_proof do_finalize) + (build_proof env sigma do_finalize) t dyn_infos) g' @@ -735,8 +733,8 @@ let build_proof ] g in - build_proof do_finalize_t {dyn_infos with info = t} g - | Lambda(n,t,b) -> + build_proof env sigma do_finalize_t {dyn_infos with info = t} g + | Lambda(n,t,b) -> begin match EConstr.kind sigma (pf_concl g) with | Prod _ -> @@ -751,7 +749,7 @@ let build_proof in let new_infos = {dyn_infos with info = new_term} in let do_prove new_hyps = - build_proof do_finalize + build_proof env sigma do_finalize {new_infos with rec_hyps = new_hyps; nb_rec_hyps = List.length new_hyps @@ -764,7 +762,7 @@ let build_proof do_finalize dyn_infos g end | Cast(t,_,_) -> - build_proof do_finalize {dyn_infos with info = t} g + build_proof env sigma do_finalize {dyn_infos with info = t} g | Const _ | Var _ | Meta _ | Evar _ | Sort _ | Construct _ | Ind _ | Int _ -> do_finalize dyn_infos g | App(_,_) -> @@ -780,7 +778,7 @@ let build_proof info = (f,args) } in - build_proof_args do_finalize new_infos g + build_proof_args env sigma do_finalize new_infos g | Const (c,_) when not (List.mem_f Constant.equal c fnames) -> let new_infos = { dyn_infos with @@ -788,13 +786,13 @@ let build_proof } in (* Pp.msgnl (str "proving in " ++ pr_lconstr_env (pf_env g) dyn_infos.info); *) - build_proof_args do_finalize new_infos g + build_proof_args env sigma do_finalize new_infos g | Const _ -> do_finalize dyn_infos g | Lambda _ -> let new_term = Reductionops.nf_beta env sigma dyn_infos.info in - build_proof do_finalize {dyn_infos with info = new_term} + build_proof env sigma do_finalize {dyn_infos with info = new_term} g | LetIn _ -> let new_infos = @@ -807,11 +805,11 @@ let build_proof h_reduce_with_zeta (Locusops.onHyp hyp_id)) dyn_infos.rec_hyps; h_reduce_with_zeta Locusops.onConcl; - build_proof do_finalize new_infos + build_proof env sigma do_finalize new_infos ] g | Cast(b,_,_) -> - build_proof do_finalize {dyn_infos with info = b } g + build_proof env sigma do_finalize {dyn_infos with info = b } g | Case _ | Fix _ | CoFix _ -> let new_finalize dyn_infos = let new_infos = @@ -819,9 +817,9 @@ let build_proof info = dyn_infos.info,args } in - build_proof_args do_finalize new_infos + build_proof_args env sigma do_finalize new_infos in - build_proof new_finalize {dyn_infos with info = f } g + build_proof env sigma new_finalize {dyn_infos with info = f } g end | Fix _ | CoFix _ -> user_err Pp.(str ( "Anonymous local (co)fixpoints are not handled yet")) @@ -841,13 +839,13 @@ let build_proof (fun hyp_id -> h_reduce_with_zeta (Locusops.onHyp hyp_id)) dyn_infos.rec_hyps; h_reduce_with_zeta Locusops.onConcl; - build_proof do_finalize new_infos + build_proof env sigma do_finalize new_infos ] g | Rel _ -> anomaly (Pp.str "Free var in goal conclusion!") - and build_proof do_finalize dyn_infos g = + and build_proof env sigma do_finalize dyn_infos g = (* observe (str "proving with "++Printer.pr_lconstr dyn_infos.info++ str " on goal " ++ pr_gls g); *) - observe_tac_stream (str "build_proof with " ++ pr_leconstr_fp dyn_infos.info ) (build_proof_aux do_finalize dyn_infos) g - and build_proof_args do_finalize dyn_infos (* f_args' args *) :tactic = + observe_tac_stream (str "build_proof with " ++ pr_leconstr_env env sigma dyn_infos.info ) (build_proof_aux do_finalize dyn_infos) g + and build_proof_args env sigma do_finalize dyn_infos (* f_args' args *) :tactic = fun g -> let (f_args',args) = dyn_infos.info in let tac : tactic = @@ -863,12 +861,12 @@ let build_proof let do_finalize dyn_infos = let new_arg = dyn_infos.info in (* tclTRYD *) - (build_proof_args + (build_proof_args env sigma do_finalize {dyn_infos with info = (mkApp(f_args',[|new_arg|])), args} ) in - build_proof do_finalize + build_proof env sigma do_finalize {dyn_infos with info = arg } g in @@ -880,7 +878,10 @@ let build_proof finish_proof dyn_infos) in (* observe_tac "build_proof" *) - (build_proof (clean_goal_with_heq ptes_infos do_finish_proof) dyn_infos) + fun g -> + let env = pf_env g in + let sigma = project g in + build_proof env sigma (clean_goal_with_heq ptes_infos do_finish_proof) dyn_infos g @@ -1149,7 +1150,7 @@ let prove_princ_for_struct (evd:Evd.evar_map ref) interactive_proof fun_num fnam let fix_offset = List.length princ_params in let ptes_to_fix,infos = match EConstr.kind (project g) fbody_with_full_params with - | Fix((idxs,i),(names,typess,bodies)) -> + | Fix((idxs,i),(names,typess,bodies)) -> let bodies_with_all_params = Array.map (fun body -> @@ -1164,7 +1165,7 @@ let prove_princ_for_struct (evd:Evd.evar_map ref) interactive_proof fun_num fnam (fun i types -> let types = prod_applist (project g) types (List.rev_map var_of_decl princ_params) in { idx = idxs.(i) - fix_offset; - name = Nameops.Name.get_id (fresh_id names.(i)); + name = Nameops.Name.get_id (fresh_id names.(i).binder_name); types = types; offset = fix_offset; nb_realargs = @@ -1195,9 +1196,9 @@ let prove_princ_for_struct (evd:Evd.evar_map ref) interactive_proof fun_num fnam applist(body,List.rev_map var_of_decl full_params)) in match EConstr.kind (project g) body_with_full_params with - | Fix((_,num),(_,_,bs)) -> + | Fix((_,num),(_,_,bs)) -> Reductionops.nf_betaiota (pf_env g) (project g) - ( + ( (applist (substl (List.rev @@ -1514,7 +1515,7 @@ let is_valid_hypothesis sigma predicates_name = let rec is_valid_hypothesis typ = is_pte typ || match EConstr.kind sigma typ with - | Prod(_,pte,typ') -> is_pte pte && is_valid_hypothesis typ' + | Prod(_,pte,typ') -> is_pte pte && is_valid_hypothesis typ' | _ -> false in is_valid_hypothesis @@ -1565,7 +1566,7 @@ let prove_principle_for_gen in let rec_arg_id = match List.rev post_rec_arg with - | (LocalAssum (Name id,_) | LocalDef (Name id,_,_)) :: _ -> id + | (LocalAssum ({binder_name=Name id},_) | LocalDef ({binder_name=Name id},_,_)) :: _ -> id | _ -> assert false in (* observe (str "rec_arg_id := " ++ pr_lconstr (mkVar rec_arg_id)); *) diff --git a/plugins/funind/functional_principles_types.ml b/plugins/funind/functional_principles_types.ml index ca09cad1f3..1217ba0eba 100644 --- a/plugins/funind/functional_principles_types.ml +++ b/plugins/funind/functional_principles_types.ml @@ -14,6 +14,7 @@ open Term open Sorts open Util open Constr +open Context open Vars open Namegen open Names @@ -72,7 +73,7 @@ let compute_new_princ_type_from_rel rel_to_fun sorts princ_type = then List.tl args else args in - Context.Named.Declaration.LocalAssum (Nameops.Name.get_id (Context.Rel.Declaration.get_name decl), + Context.Named.Declaration.LocalAssum (map_annot Nameops.Name.get_id (Context.Rel.Declaration.get_annot decl), Term.compose_prod real_args (mkSort new_sort)) in let new_predicates = @@ -137,14 +138,14 @@ let compute_new_princ_type_from_rel rel_to_fun sorts princ_type = | Rel n -> begin try match Environ.lookup_rel n env with - | LocalAssum (_,t) | LocalDef (_,_,t) when is_dom t -> raise Toberemoved + | LocalAssum (_,t) | LocalDef (_,_,t) when is_dom t -> raise Toberemoved | _ -> pre_princ,[] with Not_found -> assert false end - | Prod(x,t,b) -> - compute_new_princ_type_for_binder remove mkProd env x t b - | Lambda(x,t,b) -> - compute_new_princ_type_for_binder remove mkLambda env x t b + | Prod(x,t,b) -> + compute_new_princ_type_for_binder remove mkProd env x t b + | Lambda(x,t,b) -> + compute_new_princ_type_for_binder remove mkLambda env x t b | Ind _ | Construct _ when is_dom pre_princ -> raise Toberemoved | App(f,args) when is_dom f -> let var_to_be_removed = destRel (Array.last args) in @@ -164,8 +165,8 @@ let compute_new_princ_type_from_rel rel_to_fun sorts princ_type = let new_f,binders_to_remove_from_f = compute_new_princ_type remove env f in applistc new_f new_args, list_union_eq Constr.equal binders_to_remove_from_f binders_to_remove - | LetIn(x,v,t,b) -> - compute_new_princ_type_for_letin remove env x v t b + | LetIn(x,v,t,b) -> + compute_new_princ_type_for_letin remove env x v t b | _ -> pre_princ,[] in (* let _ = match Constr.kind pre_princ with *) @@ -181,14 +182,14 @@ let compute_new_princ_type_from_rel rel_to_fun sorts princ_type = begin try let new_t,binders_to_remove_from_t = compute_new_princ_type remove env t in - let new_x : Name.t = get_name (Termops.ids_of_context env) x in - let new_env = Environ.push_rel (LocalAssum (x,t)) env in + let new_x = map_annot (get_name (Termops.ids_of_context env)) x in + let new_env = Environ.push_rel (LocalAssum (x,t)) env in let new_b,binders_to_remove_from_b = compute_new_princ_type remove new_env b in if List.exists (Constr.equal (mkRel 1)) binders_to_remove_from_b then (pop new_b), filter_map (Constr.equal (mkRel 1)) pop binders_to_remove_from_b else ( - bind_fun(new_x,new_t,new_b), + bind_fun(new_x,new_t,new_b), list_union_eq Constr.equal binders_to_remove_from_t @@ -210,14 +211,14 @@ let compute_new_princ_type_from_rel rel_to_fun sorts princ_type = try let new_t,binders_to_remove_from_t = compute_new_princ_type remove env t in let new_v,binders_to_remove_from_v = compute_new_princ_type remove env v in - let new_x : Name.t = get_name (Termops.ids_of_context env) x in - let new_env = Environ.push_rel (LocalDef (x,v,t)) env in + let new_x = map_annot (get_name (Termops.ids_of_context env)) x in + let new_env = Environ.push_rel (LocalDef (x,v,t)) env in let new_b,binders_to_remove_from_b = compute_new_princ_type remove new_env b in if List.exists (Constr.equal (mkRel 1)) binders_to_remove_from_b then (pop new_b),filter_map (Constr.equal (mkRel 1)) pop binders_to_remove_from_b else ( - mkLetIn(new_x,new_v,new_t,new_b), + mkLetIn(new_x,new_v,new_t,new_b), list_union_eq Constr.equal (list_union_eq Constr.equal binders_to_remove_from_t binders_to_remove_from_v) @@ -250,8 +251,11 @@ let compute_new_princ_type_from_rel rel_to_fun sorts princ_type = in it_mkProd_or_LetIn (it_mkProd_or_LetIn - pre_res (List.map (function Context.Named.Declaration.LocalAssum (id,b) -> LocalAssum (Name (Hashtbl.find tbl id), b) - | Context.Named.Declaration.LocalDef (id,t,b) -> LocalDef (Name (Hashtbl.find tbl id), t, b)) + pre_res (List.map (function + | Context.Named.Declaration.LocalAssum (id,b) -> + LocalAssum (map_annot (fun id -> Name.mk_name (Hashtbl.find tbl id)) id, b) + | Context.Named.Declaration.LocalDef (id,t,b) -> + LocalDef (map_annot (fun id -> Name.mk_name (Hashtbl.find tbl id)) id, t, b)) new_predicates) ) (List.map (fun d -> Termops.map_rel_decl EConstr.Unsafe.to_constr d) princ_type_info.params) @@ -264,7 +268,7 @@ let change_property_sort evd toSort princ princName = let princ_info = compute_elim_sig evd princ in let change_sort_in_predicate decl = LocalAssum - (get_name decl, + (get_annot decl, let args,ty = decompose_prod (EConstr.Unsafe.to_constr (get_type decl)) in let s = destSort ty in Global.add_constraints (Univ.enforce_leq (univ_of_sort toSort) (univ_of_sort s) Univ.Constraint.empty); @@ -414,7 +418,7 @@ let get_funs_constant mp = | Fix((_,(na,_,_))) -> Array.mapi (fun i na -> - match na with + match na.binder_name with | Name id -> let const = Constant.make2 mp (Label.of_id id) in const,i @@ -451,7 +455,8 @@ let get_funs_constant mp = let first_params = List.hd l_params in List.iter (fun params -> - if not (List.equal (fun (n1, c1) (n2, c2) -> Name.equal n1 n2 && Constr.equal c1 c2) first_params params) + if not (List.equal (fun (n1, c1) (n2, c2) -> + eq_annot Name.equal n1 n2 && Constr.equal c1 c2) first_params params) then user_err Pp.(str "Not a mutal recursive block") ) l_params @@ -461,7 +466,7 @@ let get_funs_constant mp = try let extract_info is_first body = match Constr.kind body with - | Fix((idxs,_),(na,ta,ca)) -> (idxs,na,ta,ca) + | Fix((idxs,_),(na,ta,ca)) -> (idxs,na,ta,ca) | _ -> if is_first && Int.equal (List.length l_bodies) 1 then raise Not_Rec @@ -469,9 +474,9 @@ let get_funs_constant mp = in let first_infos = extract_info true (List.hd l_bodies) in let check body = (* Hope this is correct *) - let eq_infos (ia1, na1, ta1, ca1) (ia2, na2, ta2, ca2) = - Array.equal Int.equal ia1 ia2 && Array.equal Name.equal na1 na2 && - Array.equal Constr.equal ta1 ta2 && Array.equal Constr.equal ca1 ca2 + let eq_infos (ia1, na1, ta1, ca1) (ia2, na2, ta2, ca2) = + Array.equal Int.equal ia1 ia2 && Array.equal (eq_annot Name.equal) na1 na2 && + Array.equal Constr.equal ta1 ta2 && Array.equal Constr.equal ca1 ca2 in if not (eq_infos first_infos (extract_info false body)) then user_err Pp.(str "Not a mutal recursive block") diff --git a/plugins/funind/g_indfun.mlg b/plugins/funind/g_indfun.mlg index c4f8843e51..6f67ab4d8b 100644 --- a/plugins/funind/g_indfun.mlg +++ b/plugins/funind/g_indfun.mlg @@ -29,10 +29,10 @@ DECLARE PLUGIN "recdef_plugin" { -let pr_fun_ind_using prc prlc _ opt_c = +let pr_fun_ind_using env sigma prc prlc _ opt_c = match opt_c with | None -> mt () - | Some b -> spc () ++ hov 2 (str "using" ++ spc () ++ Miscprint.pr_with_bindings prc prlc b) + | Some b -> spc () ++ hov 2 (str "using" ++ spc () ++ Miscprint.pr_with_bindings (prc env sigma) (prlc env sigma) b) (* Duplication of printing functions because "'a with_bindings" is (internally) not uniform in 'a: indeed constr_with_bindings at the @@ -47,15 +47,15 @@ let pr_fun_ind_using_typed prc prlc _ opt_c = let env = Global.env () in let evd = Evd.from_env env in let (_, b) = b env evd in - spc () ++ hov 2 (str "using" ++ spc () ++ Miscprint.pr_with_bindings prc prlc b) + spc () ++ hov 2 (str "using" ++ spc () ++ Miscprint.pr_with_bindings (prc env evd) (prlc env evd) b) } ARGUMENT EXTEND fun_ind_using TYPED AS constr_with_bindings option PRINTED BY { pr_fun_ind_using_typed } - RAW_PRINTED BY { pr_fun_ind_using } - GLOB_PRINTED BY { pr_fun_ind_using } + RAW_PRINTED BY { pr_fun_ind_using env sigma } + GLOB_PRINTED BY { pr_fun_ind_using env sigma } | [ "using" constr_with_bindings(c) ] -> { Some c } | [ ] -> { None } END @@ -119,26 +119,26 @@ END { -let pr_constr_comma_sequence prc _ _ = prlist_with_sep pr_comma prc +let pr_constr_comma_sequence env sigma prc _ _ = prlist_with_sep pr_comma (prc env sigma) } ARGUMENT EXTEND constr_comma_sequence' TYPED AS constr list - PRINTED BY { pr_constr_comma_sequence } + PRINTED BY { pr_constr_comma_sequence env sigma } | [ constr(c) "," constr_comma_sequence'(l) ] -> { c::l } | [ constr(c) ] -> { [c] } END { -let pr_auto_using prc _prlc _prt = Pptactic.pr_auto_using prc +let pr_auto_using env sigma prc _prlc _prt = Pptactic.pr_auto_using (prc env sigma) } ARGUMENT EXTEND auto_using' TYPED AS constr list - PRINTED BY { pr_auto_using } + PRINTED BY { pr_auto_using env sigma } | [ "using" constr_comma_sequence'(l) ] -> { l } | [ ] -> { [] } END @@ -170,7 +170,7 @@ END { let () = - let raw_printer _ _ _ (loc,body) = Ppvernac.pr_rec_definition body in + let raw_printer env sigma _ _ _ (loc,body) = Ppvernac.pr_rec_definition body in Pptactic.declare_extra_vernac_genarg_pprule wit_function_rec_definition_loc raw_printer } diff --git a/plugins/funind/glob_term_to_relation.ml b/plugins/funind/glob_term_to_relation.ml index ba0a3bbb5c..f4807954a7 100644 --- a/plugins/funind/glob_term_to_relation.ml +++ b/plugins/funind/glob_term_to_relation.ml @@ -2,6 +2,7 @@ open Printer open Pp open Names open Constr +open Context open Vars open Glob_term open Glob_ops @@ -343,20 +344,21 @@ let raw_push_named (na,raw_value,raw_typ) env = match na with | Anonymous -> env | Name id -> - let typ,_ = Pretyping.understand env (Evd.from_env env) ~expected_type:Pretyping.IsType raw_typ in + let typ,_ = Pretyping.understand env (Evd.from_env env) ~expected_type:Pretyping.IsType raw_typ in + let na = make_annot id Sorts.Relevant in (* TODO relevance *) (match raw_value with | None -> - EConstr.push_named (NamedDecl.LocalAssum (id,typ)) env + EConstr.push_named (NamedDecl.LocalAssum (na,typ)) env | Some value -> - EConstr.push_named (NamedDecl.LocalDef (id, value, typ)) env) + EConstr.push_named (NamedDecl.LocalDef (na, value, typ)) env) -let add_pat_variables pat typ env : Environ.env = +let add_pat_variables sigma 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 DAst.get pat with - | PatVar na -> Environ.push_rel (RelDecl.LocalAssum (na,typ)) env + | PatVar na -> Environ.push_rel (RelDecl.LocalAssum (make_annot na Sorts.Relevant,typ)) env | PatCstr(c,patl,na) -> let Inductiveops.IndType(indf,indargs) = try Inductiveops.find_rectype env (Evd.from_env env) (EConstr.of_constr typ) @@ -373,18 +375,19 @@ let add_pat_variables pat typ env : Environ.env = Context.Rel.fold_outside (fun decl (env,ctxt) -> let open Context.Rel.Declaration in - let sigma, _ = Pfedit.get_current_context () in match decl with - | LocalAssum (Anonymous,_) | LocalDef (Anonymous,_,_) -> assert false - | LocalAssum (Name id, t) -> + | LocalAssum ({binder_name=Anonymous},_) | LocalDef ({binder_name=Anonymous},_,_) -> assert false + | LocalAssum ({binder_name=Name id} as na, t) -> + let na = {na with binder_name=id} in let new_t = substl ctxt t in observe (str "for variable " ++ Ppconstr.pr_id id ++ fnl () ++ str "old type := " ++ Printer.pr_lconstr_env env sigma t ++ fnl () ++ str "new type := " ++ Printer.pr_lconstr_env env sigma new_t ++ fnl () ); let open Context.Named.Declaration in - (Environ.push_named (LocalAssum (id,new_t)) env,mkVar id::ctxt) - | LocalDef (Name id, v, t) -> + (Environ.push_named (LocalAssum (na,new_t)) env,mkVar id::ctxt) + | LocalDef ({binder_name=Name id} as na, v, t) -> + let na = {na with binder_name=id} in let new_t = substl ctxt t in let new_v = substl ctxt v in observe (str "for variable " ++ Ppconstr.pr_id id ++ fnl () ++ @@ -394,7 +397,7 @@ let add_pat_variables pat typ env : Environ.env = str "new value := " ++ Printer.pr_lconstr_env env sigma new_v ++ fnl () ); let open Context.Named.Declaration in - (Environ.push_named (LocalDef (id,new_v,new_t)) env,mkVar id::ctxt) + (Environ.push_named (LocalDef (na,new_v,new_t)) env,mkVar id::ctxt) ) (Environ.rel_context new_env) ~init:(env,[]) @@ -472,7 +475,7 @@ let rec pattern_to_term_and_type env typ = DAst.with_val (function *) -let rec build_entry_lc env funnames avoid rt : glob_constr build_entry_return = +let rec build_entry_lc env sigma funnames avoid rt : glob_constr build_entry_return = observe (str " Entering : " ++ Printer.pr_glob_constr_env env rt); let open CAst in match DAst.get rt with @@ -484,7 +487,7 @@ let rec build_entry_lc env funnames avoid rt : glob_constr build_entry_return = let args_res : (glob_constr list) build_entry_return = List.fold_right (* create the arguments lists of constructors and combine them *) (fun arg ctxt_argsl -> - let arg_res = build_entry_lc env funnames ctxt_argsl.to_avoid arg in + let arg_res = build_entry_lc env sigma funnames ctxt_argsl.to_avoid arg in combine_results combine_args arg_res ctxt_argsl ) args @@ -503,7 +506,7 @@ let rec build_entry_lc env funnames avoid rt : glob_constr build_entry_return = | _ -> GApp(t,l) in - build_entry_lc env funnames avoid (aux f args) + build_entry_lc env sigma funnames avoid (aux f args) | GVar id when Id.Set.mem id funnames -> (* if we have [f t1 ... tn] with [f]$\in$[fnames] then we create a fresh variable [res], @@ -567,7 +570,8 @@ let rec build_entry_lc env funnames avoid rt : glob_constr build_entry_return = in build_entry_lc env - funnames + sigma + funnames avoid (mkGLetIn(new_n,v,t,mkGApp(new_b,args))) | GCases _ | GIf _ | GLetTuple _ -> @@ -575,7 +579,7 @@ let rec build_entry_lc env funnames avoid rt : glob_constr build_entry_return = we first compute the result from the case and then combine each of them with each of args one *) - let f_res = build_entry_lc env funnames args_res.to_avoid f in + let f_res = build_entry_lc env sigma funnames args_res.to_avoid f in combine_results combine_app f_res args_res | GCast(b,_) -> (* for an applied cast we just trash the cast part @@ -583,7 +587,7 @@ let rec build_entry_lc env funnames avoid rt : glob_constr build_entry_return = WARNING: We need to restart since [b] itself should be an application term *) - build_entry_lc env funnames avoid (mkGApp(b,args)) + build_entry_lc env sigma funnames avoid (mkGApp(b,args)) | GRec _ -> user_err Pp.(str "Not handled GRec") | GProd _ -> user_err Pp.(str "Cannot apply a type") | GInt _ -> user_err Pp.(str "Cannot apply an integer") @@ -595,14 +599,14 @@ let rec build_entry_lc env funnames avoid rt : glob_constr build_entry_return = then the one corresponding to the type and combine the two result *) - let t_res = build_entry_lc env funnames avoid t in + let t_res = build_entry_lc env sigma funnames avoid t in let new_n = match n with | Name _ -> n | Anonymous -> Name (Indfun_common.fresh_id [] "_x") in let new_env = raw_push_named (new_n,None,t) env in - let b_res = build_entry_lc new_env funnames avoid b in + let b_res = build_entry_lc new_env sigma funnames avoid b in combine_results (combine_lam new_n) t_res b_res | GProd(n,_,t,b) -> (* we first compute the list of constructor @@ -610,9 +614,9 @@ let rec build_entry_lc env funnames avoid rt : glob_constr build_entry_return = then the one corresponding to the type and combine the two result *) - let t_res = build_entry_lc env funnames avoid t in + let t_res = build_entry_lc env sigma funnames avoid t in let new_env = raw_push_named (n,None,t) env in - let b_res = build_entry_lc new_env funnames avoid b in + let b_res = build_entry_lc new_env sigma funnames avoid b in if List.length t_res.result = 1 && List.length b_res.result = 1 then combine_results (combine_prod2 n) t_res b_res else combine_results (combine_prod n) t_res b_res @@ -623,22 +627,23 @@ let rec build_entry_lc env funnames avoid rt : glob_constr build_entry_return = and combine the two result *) 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_res = build_entry_lc env sigma 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) v_as_constr in + let v_r = Sorts.Relevant in (* TODO relevance *) let new_env = match n with Anonymous -> env - | Name id -> EConstr.push_named (NamedDecl.LocalDef (id,v_as_constr,v_type)) env - in - let b_res = build_entry_lc new_env funnames avoid b in + | Name id -> EConstr.push_named (NamedDecl.LocalDef (make_annot id v_r,v_as_constr,v_type)) env + in + let b_res = build_entry_lc new_env sigma funnames avoid b in combine_results (combine_letin n) v_res b_res | GCases(_,_,el,brl) -> (* we create the discrimination function and treat the case itself *) let make_discr = make_discr_match brl in - build_entry_lc_from_case env funnames make_discr el brl avoid + build_entry_lc_from_case env sigma funnames make_discr el brl avoid | GIf(b,(na,e_option),lhs,rhs) -> let b_as_constr,ctx = Pretyping.understand env (Evd.from_env env) b in let b_typ = Typing.unsafe_type_of env (Evd.from_env env) b_as_constr in @@ -661,7 +666,7 @@ let rec build_entry_lc env funnames avoid rt : glob_constr build_entry_return = mkGCases(None,[(b,(Anonymous,None))],brl) in (* Pp.msgnl (str "new case := " ++ Printer.pr_glob_constr match_expr); *) - build_entry_lc env funnames avoid match_expr + build_entry_lc env sigma funnames avoid match_expr | GLetTuple(nal,_,b,e) -> begin let nal_as_glob_constr = @@ -685,13 +690,13 @@ let rec build_entry_lc env funnames avoid rt : glob_constr build_entry_return = assert (Int.equal (Array.length case_pats) 1); let br = CAst.make ([],[case_pats.(0)],e) in let match_expr = mkGCases(None,[b,(Anonymous,None)],[br]) in - build_entry_lc env funnames avoid match_expr + build_entry_lc env sigma funnames avoid match_expr end | GRec _ -> user_err Pp.(str "Not handled GRec") | GCast(b,_) -> - build_entry_lc env funnames avoid b -and build_entry_lc_from_case env funname make_discr + build_entry_lc env sigma funnames avoid b +and build_entry_lc_from_case env sigma funname make_discr (el:tomatch_tuples) (brl:Glob_term.cases_clauses) avoid : glob_constr build_entry_return = @@ -709,7 +714,7 @@ and build_entry_lc_from_case env funname make_discr let case_resl = List.fold_right (fun (case_arg,_) ctxt_argsl -> - let arg_res = build_entry_lc env funname ctxt_argsl.to_avoid case_arg in + let arg_res = build_entry_lc env sigma funname ctxt_argsl.to_avoid case_arg in combine_results combine_args arg_res ctxt_argsl ) el @@ -726,7 +731,7 @@ and build_entry_lc_from_case env funname make_discr List.map (fun ca -> let res = build_entry_lc_from_case_term - env types + env sigma types funname (make_discr) [] brl case_resl.to_avoid @@ -743,7 +748,7 @@ and build_entry_lc_from_case env funname make_discr [] results } -and build_entry_lc_from_case_term env types funname make_discr patterns_to_prevent brl avoid +and build_entry_lc_from_case_term env sigma types funname make_discr patterns_to_prevent brl avoid matched_expr = match brl with | [] -> (* computed_branches *) {result = [];to_avoid = avoid} @@ -754,14 +759,14 @@ and build_entry_lc_from_case_term env types funname make_discr patterns_to_preve (* building a list of precondition stating that we are not in this branch (will be used in the following recursive calls) *) - let new_env = List.fold_right2 add_pat_variables patl types env in + let new_env = List.fold_right2 (add_pat_variables sigma) patl types env in let not_those_patterns : (Id.t list -> glob_constr -> glob_constr) list = List.map2 (fun pat typ -> fun avoid pat'_as_term -> let renamed_pat,_,_ = alpha_pat avoid pat in let pat_ids = get_pattern_id renamed_pat in - let env_with_pat_ids = add_pat_variables pat typ new_env in + let env_with_pat_ids = add_pat_variables sigma pat typ new_env in List.fold_right (fun id acc -> let typ_of_id = @@ -793,6 +798,7 @@ and build_entry_lc_from_case_term env types funname make_discr patterns_to_preve let brl'_res = build_entry_lc_from_case_term env + sigma types funname make_discr @@ -857,7 +863,7 @@ and build_entry_lc_from_case_term env types funname make_discr patterns_to_preve ) in (* We compute the result of the value returned by the branch*) - let return_res = build_entry_lc new_env funname new_avoid return in + let return_res = build_entry_lc new_env sigma funname new_avoid return in (* and combine it with the preconds computed for this branch *) let this_branch_res = List.map @@ -890,8 +896,7 @@ let same_raw_term rt1 rt2 = | GRef(r1,_), GRef (r2,_) -> GlobRef.equal r1 r2 | GHole _, GHole _ -> true | _ -> false -let decompose_raw_eq lhs rhs = - let _, env = Pfedit.get_current_context () in +let decompose_raw_eq env lhs rhs = let rec decompose_raw_eq lhs rhs acc = observe (str "decomposing eq for " ++ pr_glob_constr_env env lhs ++ str " " ++ pr_glob_constr_env env rhs); let (rhd,lrhs) = glob_decompose_app rhs in @@ -939,9 +944,10 @@ let rec rebuild_cons env nb_args relname args crossed_types depth rt = let new_t = 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 = EConstr.push_rel (LocalAssum (n,t')) env in - let new_b,id_to_exclude = + let t',ctx = Pretyping.understand env (Evd.from_env env) new_t in + let r = Sorts.Relevant in (* TODO relevance *) + let new_env = EConstr.push_rel (LocalAssum (make_annot n r,t')) env in + let new_b,id_to_exclude = rebuild_cons new_env nb_args relname args new_crossed_types @@ -974,9 +980,10 @@ let rec rebuild_cons env nb_args relname args crossed_types depth rt = let new_args = List.map (replace_var_by_term id rt) args in let subst_b = if is_in_b then b else replace_var_by_term id rt b - in - let new_env = EConstr.push_rel (LocalAssum (n,t')) env in - let new_b,id_to_exclude = + in + let r = Sorts.Relevant in (* TODO relevance *) + let new_env = EConstr.push_rel (LocalAssum (make_annot n r,t')) env in + let new_b,id_to_exclude = rebuild_cons new_env nb_args relname @@ -1057,8 +1064,9 @@ let rec rebuild_cons env nb_args relname args crossed_types depth rt = in let new_env = let t',ctx = Pretyping.understand env (Evd.from_env env) eq' in - EConstr.push_rel (LocalAssum (n,t')) env - in + let r = Sorts.Relevant in (* TODO relevance *) + EConstr.push_rel (LocalAssum (make_annot n r,t')) env + in let new_b,id_to_exclude = rebuild_cons new_env @@ -1078,7 +1086,7 @@ let rec rebuild_cons env nb_args relname args crossed_types depth rt = -> begin try - let l = decompose_raw_eq rt1 rt2 in + let l = decompose_raw_eq env rt1 rt2 in if List.length l > 1 then let new_rt = @@ -1095,8 +1103,9 @@ let rec rebuild_cons env nb_args relname args crossed_types depth rt = with Continue -> observe (str "computing new type for prod : " ++ pr_glob_constr_env env rt); let t',ctx = Pretyping.understand env (Evd.from_env env) t in - let new_env = EConstr.push_rel (LocalAssum (n,t')) env in - let new_b,id_to_exclude = + let r = Sorts.Relevant in (* TODO relevance *) + let new_env = EConstr.push_rel (LocalAssum (make_annot n r,t')) env in + let new_b,id_to_exclude = rebuild_cons new_env nb_args relname args new_crossed_types @@ -1111,8 +1120,9 @@ let rec rebuild_cons env nb_args relname args crossed_types depth rt = | _ -> observe (str "computing new type for prod : " ++ pr_glob_constr_env env rt); let t',ctx = Pretyping.understand env (Evd.from_env env) t in - let new_env = EConstr.push_rel (LocalAssum (n,t')) env in - let new_b,id_to_exclude = + let r = Sorts.Relevant in (* TODO relevance *) + let new_env = EConstr.push_rel (LocalAssum (make_annot n r,t')) env in + let new_b,id_to_exclude = rebuild_cons new_env nb_args relname args new_crossed_types @@ -1132,8 +1142,9 @@ let rec rebuild_cons env nb_args relname args crossed_types depth rt = let t',ctx = Pretyping.understand env (Evd.from_env env) t in match n with | Name id -> - let new_env = EConstr.push_rel (LocalAssum (n,t')) env in - let new_b,id_to_exclude = + let r = Sorts.Relevant in (* TODO relevance *) + let new_env = EConstr.push_rel (LocalAssum (make_annot n r,t')) env in + let new_b,id_to_exclude = rebuild_cons new_env nb_args relname (args@[mkGVar id])new_crossed_types @@ -1158,7 +1169,7 @@ let rec rebuild_cons env nb_args relname args crossed_types depth rt = let type_t' = Typing.unsafe_type_of env evd t' in let t' = EConstr.Unsafe.to_constr t' in let type_t' = EConstr.Unsafe.to_constr type_t' in - let new_env = Environ.push_rel (LocalDef (n,t',type_t')) env in + let new_env = Environ.push_rel (LocalDef (make_annot n Sorts.Relevant,t',type_t')) env in let new_b,id_to_exclude = rebuild_cons new_env nb_args relname @@ -1182,8 +1193,9 @@ let rec rebuild_cons env nb_args relname args crossed_types depth rt = depth t in let t',ctx = Pretyping.understand env (Evd.from_env env) new_t in - let new_env = EConstr.push_rel (LocalAssum (na,t')) env in - let new_b,id_to_exclude = + let r = Sorts.Relevant in (* TODO relevance *) + let new_env = EConstr.push_rel (LocalAssum (make_annot na r,t')) env in + let new_b,id_to_exclude = rebuild_cons new_env nb_args relname args (t::crossed_types) @@ -1320,7 +1332,7 @@ let do_build_inductive let evd,t = Typing.type_of env evd (EConstr.mkConstU (c, u)) in let t = EConstr.Unsafe.to_constr t in evd, - Environ.push_named (LocalAssum (id,t)) + Environ.push_named (LocalAssum (make_annot id Sorts.Relevant,t)) env ) funnames @@ -1334,7 +1346,7 @@ let do_build_inductive resolve_and_replace_implicits ~expected_type:(Pretyping.OfType t) env evd rt ) rta in - let resa = Array.map (build_entry_lc env funnames_as_set []) rta in + let resa = Array.map (build_entry_lc env evd funnames_as_set []) rta in let env_with_graphs = let rel_arity i funargs = (* Rebuilding arities (with parameters) *) let rel_first_args :(Name.t * Glob_term.glob_constr * Glob_term.glob_constr option ) list = @@ -1364,7 +1376,8 @@ let do_build_inductive Util.Array.fold_left2 (fun env rel_name rel_ar -> let rex = fst (with_full_print (Constrintern.interp_constr env evd) rel_ar) in let rex = EConstr.Unsafe.to_constr rex in - Environ.push_named (LocalAssum (rel_name,rex)) env) env relnames rel_arities + let r = Sorts.Relevant in (* TODO relevance *) + Environ.push_named (LocalAssum (make_annot rel_name r,rex)) env) env relnames rel_arities in (* and of the real constructors*) let constr i res = diff --git a/plugins/funind/indfun.ml b/plugins/funind/indfun.ml index 42dc66dcf4..b69ca7080c 100644 --- a/plugins/funind/indfun.ml +++ b/plugins/funind/indfun.ml @@ -3,6 +3,7 @@ open Sorts open Util open Names open Constr +open Context open EConstr open Pp open Indfun_common @@ -49,7 +50,8 @@ let functional_induction with_clean c princl pat = user_err (str "Cannot find induction information on "++ Printer.pr_leconstr_env (Tacmach.pf_env g) sigma (mkConst c') ) in - match Tacticals.elimination_sort_of_goal g with + match Tacticals.elimination_sort_of_goal g with + | InSProp -> finfo.sprop_lemma | InProp -> finfo.prop_lemma | InSet -> finfo.rec_lemma | InType -> finfo.rect_lemma @@ -169,7 +171,8 @@ let build_newrecursive let evd, (_, (_, impls')) = Constrintern.interp_context_evars ~program_mode:false env evd bl in let impl = Constrintern.compute_internalization_data env0 evd Constrintern.Recursive arity impls' in let open Context.Named.Declaration in - (EConstr.push_named (LocalAssum (recname,arity)) env, Id.Map.add recname impl impls)) + let r = Sorts.Relevant in (* TODO relevance *) + (EConstr.push_named (LocalAssum (make_annot recname r,arity)) env, Id.Map.add recname impl impls)) (env0,Constrintern.empty_internalization_env) lnameargsardef in let recdef = (* Declare local notations *) @@ -621,8 +624,8 @@ let rebuild_bl aux bl typ = rebuild_bl aux bl typ let recompute_binder_list (fixpoint_exprl : (Vernacexpr.fixpoint_expr * Vernacexpr.decl_notation list) list) = let fixl,ntns = ComFixpoint.extract_fixpoint_components false fixpoint_exprl in - let ((_,_,typel),_,ctx,_) = ComFixpoint.interp_fixpoint ~cofix:false fixl ntns in - let constr_expr_typel = + let ((_,_,_,typel),_,ctx,_) = ComFixpoint.interp_fixpoint ~cofix:false fixl ntns in + let constr_expr_typel = 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 -> diff --git a/plugins/funind/indfun_common.ml b/plugins/funind/indfun_common.ml index cba3cc3d42..e34323abf4 100644 --- a/plugins/funind/indfun_common.ml +++ b/plugins/funind/indfun_common.ml @@ -199,6 +199,7 @@ type function_info = rect_lemma : Constant.t option; rec_lemma : Constant.t option; prop_lemma : Constant.t option; + sprop_lemma : Constant.t option; is_general : bool; (* Has this function been defined using general recursive definition *) } @@ -249,6 +250,7 @@ let subst_Function (subst,finfos) = let rect_lemma' = Option.Smart.map do_subst_con finfos.rect_lemma in let rec_lemma' = Option.Smart.map do_subst_con finfos.rec_lemma in let prop_lemma' = Option.Smart.map do_subst_con finfos.prop_lemma in + let sprop_lemma' = Option.Smart.map do_subst_con finfos.sprop_lemma in if function_constant' == finfos.function_constant && graph_ind' == finfos.graph_ind && equation_lemma' == finfos.equation_lemma && @@ -256,7 +258,8 @@ let subst_Function (subst,finfos) = completeness_lemma' == finfos.completeness_lemma && rect_lemma' == finfos.rect_lemma && rec_lemma' == finfos.rec_lemma && - prop_lemma' == finfos.prop_lemma + prop_lemma' == finfos.prop_lemma && + sprop_lemma' == finfos.sprop_lemma then finfos else { function_constant = function_constant'; @@ -267,17 +270,16 @@ let subst_Function (subst,finfos) = rect_lemma = rect_lemma' ; rec_lemma = rec_lemma'; prop_lemma = prop_lemma'; + sprop_lemma = sprop_lemma'; is_general = finfos.is_general } let discharge_Function (_,finfos) = Some finfos -let pr_ocst c = - let sigma, env = Pfedit.get_current_context () in +let pr_ocst env sigma c = Option.fold_right (fun v acc -> Printer.pr_lconstr_env env sigma (mkConst v)) c (mt ()) -let pr_info f_info = - let sigma, env = Pfedit.get_current_context () in +let pr_info env sigma f_info = str "function_constant := " ++ Printer.pr_lconstr_env env sigma (mkConst f_info.function_constant)++ fnl () ++ str "function_constant_type := " ++ @@ -285,17 +287,17 @@ let pr_info f_info = Printer.pr_lconstr_env env sigma (fst (Typeops.type_of_global_in_context env (ConstRef f_info.function_constant))) with e when CErrors.noncritical e -> mt ()) ++ fnl () ++ - str "equation_lemma := " ++ pr_ocst f_info.equation_lemma ++ fnl () ++ - str "completeness_lemma :=" ++ pr_ocst f_info.completeness_lemma ++ fnl () ++ - str "correctness_lemma := " ++ pr_ocst f_info.correctness_lemma ++ fnl () ++ - str "rect_lemma := " ++ pr_ocst f_info.rect_lemma ++ fnl () ++ - str "rec_lemma := " ++ pr_ocst f_info.rec_lemma ++ fnl () ++ - str "prop_lemma := " ++ pr_ocst f_info.prop_lemma ++ fnl () ++ + str "equation_lemma := " ++ pr_ocst env sigma f_info.equation_lemma ++ fnl () ++ + str "completeness_lemma :=" ++ pr_ocst env sigma f_info.completeness_lemma ++ fnl () ++ + str "correctness_lemma := " ++ pr_ocst env sigma f_info.correctness_lemma ++ fnl () ++ + str "rect_lemma := " ++ pr_ocst env sigma f_info.rect_lemma ++ fnl () ++ + str "rec_lemma := " ++ pr_ocst env sigma f_info.rec_lemma ++ fnl () ++ + str "prop_lemma := " ++ pr_ocst env sigma f_info.prop_lemma ++ fnl () ++ str "graph_ind := " ++ Printer.pr_lconstr_env env sigma (mkInd f_info.graph_ind) ++ fnl () -let pr_table tb = +let pr_table env sigma tb = let l = Cmap_env.fold (fun k v acc -> v::acc) tb [] in - Pp.prlist_with_sep fnl pr_info l + Pp.prlist_with_sep fnl (pr_info env sigma) l let in_Function : function_info -> Libobject.obj = let open Libobject in @@ -333,6 +335,7 @@ let add_Function is_general f = and rect_lemma = find_or_none (Nameops.add_suffix f_id "_rect") and rec_lemma = find_or_none (Nameops.add_suffix f_id "_rec") and prop_lemma = find_or_none (Nameops.add_suffix f_id "_ind") + and sprop_lemma = find_or_none (Nameops.add_suffix f_id "_sind") and graph_ind = match Nametab.locate (qualid_of_ident (mk_rel_id f_id)) with | IndRef ind -> ind | _ -> CErrors.anomaly (Pp.str "Not an inductive.") @@ -345,6 +348,7 @@ let add_Function is_general f = rect_lemma = rect_lemma; rec_lemma = rec_lemma; prop_lemma = prop_lemma; + sprop_lemma = sprop_lemma; graph_ind = graph_ind; is_general = is_general @@ -352,7 +356,7 @@ let add_Function is_general f = in update_Function finfos -let pr_table () = pr_table !from_function +let pr_table env sigma = pr_table env sigma !from_function (*********************************) (* Debuging *) let functional_induction_rewrite_dependent_proofs = ref true diff --git a/plugins/funind/indfun_common.mli b/plugins/funind/indfun_common.mli index 1e0b95df34..12facc5744 100644 --- a/plugins/funind/indfun_common.mli +++ b/plugins/funind/indfun_common.mli @@ -70,6 +70,7 @@ type function_info = rect_lemma : Constant.t option; rec_lemma : Constant.t option; prop_lemma : Constant.t option; + sprop_lemma : Constant.t option; is_general : bool; } @@ -82,8 +83,8 @@ val update_Function : function_info -> unit (** debugging *) -val pr_info : function_info -> Pp.t -val pr_table : unit -> Pp.t +val pr_info : Environ.env -> Evd.evar_map -> function_info -> Pp.t +val pr_table : Environ.env -> Evd.evar_map -> Pp.t (* val function_debug : bool ref *) @@ -109,9 +110,9 @@ val evaluable_of_global_reference : GlobRef.t -> Names.evaluable_global_referenc val list_rewrite : bool -> (EConstr.constr*bool) list -> Tacmach.tactic val decompose_lam_n : Evd.evar_map -> int -> EConstr.t -> - (Names.Name.t * EConstr.t) list * EConstr.t -val compose_lam : (Names.Name.t * EConstr.t) list -> EConstr.t -> EConstr.t -val compose_prod : (Names.Name.t * EConstr.t) list -> EConstr.t -> EConstr.t + (Names.Name.t Context.binder_annot * EConstr.t) list * EConstr.t +val compose_lam : (Names.Name.t Context.binder_annot * EConstr.t) list -> EConstr.t -> EConstr.t +val compose_prod : (Names.Name.t Context.binder_annot * EConstr.t) list -> EConstr.t -> EConstr.t type tcc_lemma_value = | Undefined diff --git a/plugins/funind/invfun.ml b/plugins/funind/invfun.ml index 95e2e9f6e5..37dbfec4c9 100644 --- a/plugins/funind/invfun.ml +++ b/plugins/funind/invfun.ml @@ -15,6 +15,7 @@ open Util open Names open Term open Constr +open Context open EConstr open Vars open Pp @@ -142,12 +143,13 @@ let generate_type evd g_to_f f graph i = \[\forall (x_1:t_1)\ldots(x_n:t_n), let fv := f x_1\ldots x_n in, forall res, \] i*) let pre_ctxt = - LocalAssum (Name res_id, lift 1 res_type) :: LocalDef (Name fv_id, mkApp (f,args_as_rels), res_type) :: fun_ctxt + LocalAssum (make_annot (Name res_id) Sorts.Relevant, lift 1 res_type) :: + LocalDef (make_annot (Name fv_id) Sorts.Relevant, mkApp (f,args_as_rels), res_type) :: fun_ctxt in (*i and we can return the solution depending on which lemma type we are defining i*) if g_to_f - then LocalAssum (Anonymous,graph_applied)::pre_ctxt,(lift 1 res_eq_f_of_args),graph - else LocalAssum (Anonymous,res_eq_f_of_args)::pre_ctxt,(lift 1 graph_applied),graph + then LocalAssum (make_annot Anonymous Sorts.Relevant,graph_applied)::pre_ctxt,(lift 1 res_eq_f_of_args),graph + else LocalAssum (make_annot Anonymous Sorts.Relevant,res_eq_f_of_args)::pre_ctxt,(lift 1 graph_applied),graph (* @@ -270,10 +272,10 @@ let prove_fun_correct evd funs_constr graphs_constr schemes lemmas_types_infos i let type_of_hid = pf_unsafe_type_of g (mkVar hid) in let sigma = project g in match EConstr.kind sigma type_of_hid with - | Prod(_,_,t') -> + | Prod(_,_,t') -> begin match EConstr.kind sigma t' with - | Prod(_,t'',t''') -> + | Prod(_,t'',t''') -> begin match EConstr.kind sigma t'',EConstr.kind sigma t''' with | App(eq,args), App(graph',_) @@ -358,17 +360,16 @@ let prove_fun_correct evd funs_constr graphs_constr schemes lemmas_types_infos i (* end of branche proof *) let lemmas = Array.map - (fun ((_,(ctxt,concl))) -> - match ctxt with - | [] | [_] | [_;_] -> anomaly (Pp.str "bad context.") - | hres::res::decl::ctxt -> - let res = EConstr.it_mkLambda_or_LetIn - (EConstr.it_mkProd_or_LetIn concl [hres;res]) - (LocalAssum (RelDecl.get_name decl, RelDecl.get_type decl) :: ctxt) - in - res - ) - lemmas_types_infos + (fun ((_,(ctxt,concl))) -> + match ctxt with + | [] | [_] | [_;_] -> anomaly (Pp.str "bad context.") + | hres::res::decl::ctxt -> + let res = EConstr.it_mkLambda_or_LetIn + (EConstr.it_mkProd_or_LetIn concl [hres;res]) + (LocalAssum (RelDecl.get_annot decl, RelDecl.get_type decl) :: ctxt) + in + res) + lemmas_types_infos in let param_names = fst (List.chop princ_infos.nparams args_names) in let params = List.map mkVar param_names in @@ -429,7 +430,7 @@ let generalize_dependent_of x hyp g = let open Context.Named.Declaration in tclMAP (function - | LocalAssum (id,t) when not (Id.equal id hyp) && + | LocalAssum ({binder_name=id},t) when not (Id.equal id hyp) && (Termops.occur_var (pf_env g) (project g) x t) -> tclTHEN (Proofview.V82.of_tactic (Tactics.generalize [mkVar id])) (thin [id]) | _ -> tclIDTAC ) @@ -456,7 +457,7 @@ and intros_with_rewrite_aux : Tacmach.tactic = let eq_ind = make_eq () in let sigma = project g in match EConstr.kind sigma (pf_concl g) with - | Prod(_,t,t') -> + | Prod(_,t,t') -> begin match EConstr.kind sigma t with | App(eq,args) when (EConstr.eq_constr sigma eq eq_ind) -> diff --git a/plugins/funind/recdef.ml b/plugins/funind/recdef.ml index 8746c37309..e19741a4e9 100644 --- a/plugins/funind/recdef.ml +++ b/plugins/funind/recdef.ml @@ -12,6 +12,7 @@ module CVars = Vars open Constr +open Context open EConstr open Vars open Namegen @@ -57,10 +58,6 @@ let coq_constant m s = EConstr.of_constr @@ UnivGen.constr_of_monomorphic_global let arith_Nat = ["Coq"; "Arith";"PeanoNat";"Nat"] let arith_Lt = ["Coq"; "Arith";"Lt"] -let pr_leconstr_rd = - let sigma, env = Pfedit.get_current_context () in - Printer.pr_leconstr_env env sigma - let coq_init_constant s = EConstr.of_constr ( UnivGen.constr_of_monomorphic_global @@ @@ -182,7 +179,7 @@ let (value_f: Constr.t list -> GlobRef.t -> Constr.t) = ) in let context = List.map - (fun (x, c) -> LocalAssum (Name x, c)) (List.combine rev_x_id_l (List.rev al)) + (fun (x, c) -> LocalAssum (make_annot (Name x) Sorts.Relevant, c)) (List.combine rev_x_id_l (List.rev al)) in let env = Environ.push_rel_context context (Global.env ()) in let glob_body = @@ -302,7 +299,7 @@ let tclUSER_if_not_mes concl_tac is_mes names_to_suppress = (* [check_not_nested forbidden e] checks that [e] does not contains any variable of [forbidden] *) -let check_not_nested sigma forbidden e = +let check_not_nested env sigma forbidden e = let rec check_not_nested e = match EConstr.kind sigma e with | Rel _ -> () @@ -329,7 +326,6 @@ let check_not_nested sigma forbidden e = try check_not_nested e with UserError(_,p) -> - let _, env = Pfedit.get_current_context () in user_err ~hdr:"_" (str "on expr : " ++ Printer.pr_leconstr_env env sigma e ++ str " " ++ p) (* ['a info] contains the local information for traveling *) @@ -388,9 +384,9 @@ let add_vars sigma forbidden e = let treat_case forbid_new_ids to_intros finalize_tac nb_lam e infos : tactic = fun g -> let rev_context,b = decompose_lam_n (project g) nb_lam e in - let ids = List.fold_left (fun acc (na,_) -> + let ids = List.fold_left (fun acc (na,_) -> let pre_id = - match na with + match na.binder_name with | Name x -> x | Anonymous -> ano_id in @@ -433,10 +429,10 @@ let rec travel_aux jinfo continuation_tac (expr_info:constr infos) g = match EConstr.kind sigma expr_info.info with | CoFix _ | Fix _ -> user_err Pp.(str "Function cannot treat local fixpoint or cofixpoint") | Proj _ -> user_err Pp.(str "Function cannot treat projections") - | LetIn(na,b,t,e) -> + | LetIn(na,b,t,e) -> begin let new_continuation_tac = - jinfo.letiN (na,b,t,e) expr_info continuation_tac + jinfo.letiN (na.binder_name,b,t,e) expr_info continuation_tac in travel jinfo new_continuation_tac {expr_info with info = b; is_final=false} g @@ -445,15 +441,15 @@ let rec travel_aux jinfo continuation_tac (expr_info:constr infos) g = | Prod _ -> begin try - check_not_nested sigma (expr_info.f_id::expr_info.forbidden_ids) expr_info.info; + check_not_nested (pf_env g) sigma (expr_info.f_id::expr_info.forbidden_ids) expr_info.info; jinfo.otherS () expr_info continuation_tac expr_info g with e when CErrors.noncritical e -> user_err ~hdr:"Recdef.travel" (str "the term " ++ Printer.pr_leconstr_env (pf_env g) sigma expr_info.info ++ str " can not contain a recursive call to " ++ Id.print expr_info.f_id) end - | Lambda(n,t,b) -> + | Lambda(n,t,b) -> begin try - check_not_nested sigma (expr_info.f_id::expr_info.forbidden_ids) expr_info.info; + check_not_nested (pf_env g) sigma (expr_info.f_id::expr_info.forbidden_ids) expr_info.info; jinfo.otherS () expr_info continuation_tac expr_info g with e when CErrors.noncritical e -> user_err ~hdr:"Recdef.travel" (str "the term " ++ Printer.pr_leconstr_env (pf_env g) sigma expr_info.info ++ str " can not contain a recursive call to " ++ Id.print expr_info.f_id) @@ -506,10 +502,11 @@ and travel_args jinfo is_final continuation_tac infos = in travel jinfo new_continuation_tac {infos with info=arg;is_final=false} -and travel jinfo continuation_tac expr_info = - observe_tac - (str jinfo.message ++ pr_leconstr_rd expr_info.info) - (travel_aux jinfo continuation_tac expr_info) +and travel jinfo continuation_tac expr_info = + fun g -> + observe_tac + (str jinfo.message ++ Printer.pr_leconstr_env (pf_env g) (project g) expr_info.info) + (travel_aux jinfo continuation_tac expr_info) g (* Termination proof *) @@ -651,7 +648,7 @@ let terminate_letin (na,b,t,e) expr_info continuation_tac info g = let new_forbidden = let forbid = try - check_not_nested sigma (expr_info.f_id::expr_info.forbidden_ids) b; + check_not_nested (pf_env g) sigma (expr_info.f_id::expr_info.forbidden_ids) b; true with e when CErrors.noncritical e -> false in @@ -710,7 +707,7 @@ let terminate_case next_step (ci,a,t,l) expr_info continuation_tac infos g = let sigma = project g in let f_is_present = try - check_not_nested sigma (expr_info.f_id::expr_info.forbidden_ids) a; + check_not_nested (pf_env g) sigma (expr_info.f_id::expr_info.forbidden_ids) a; false with e when CErrors.noncritical e -> true @@ -739,7 +736,7 @@ let terminate_case next_step (ci,a,t,l) expr_info continuation_tac infos g = let terminate_app_rec (f,args) expr_info continuation_tac _ g = let sigma = project g in - List.iter (check_not_nested sigma (expr_info.f_id::expr_info.forbidden_ids)) + List.iter (check_not_nested (pf_env g) sigma (expr_info.f_id::expr_info.forbidden_ids)) args; begin try @@ -853,8 +850,8 @@ let rec prove_le g = EConstr.is_global sigma (le ()) c | _ -> false in - let (h,t) = List.find (fun (_,t) -> matching_fun t) (pf_hyps_types g) - in + let (h,t) = List.find (fun (_,t) -> matching_fun t) (pf_hyps_types g) in + let h = h.binder_name in let y = let _,args = decompose_app sigma t in List.hd (List.tl args) @@ -877,10 +874,10 @@ let rec make_rewrite_list expr_info max = function let sigma = project g in let t_eq = compute_renamed_type g (mkVar hp) in let k,def = - let k_na,_,t = destProd sigma t_eq in - let _,_,t = destProd sigma t in - let def_na,_,_ = destProd sigma t in - Nameops.Name.get_id k_na,Nameops.Name.get_id def_na + let k_na,_,t = destProd sigma t_eq in + let _,_,t = destProd sigma t in + let def_na,_,_ = destProd sigma t in + Nameops.Name.get_id k_na.binder_name,Nameops.Name.get_id def_na.binder_name in Proofview.V82.of_tactic (general_rewrite_bindings false Locus.AllOccurrences true (* dep proofs also: *) true @@ -903,10 +900,10 @@ let make_rewrite expr_info l hp max = let sigma = project g in let t_eq = compute_renamed_type g (mkVar hp) in let k,def = - let k_na,_,t = destProd sigma t_eq in - let _,_,t = destProd sigma t in - let def_na,_,_ = destProd sigma t in - Nameops.Name.get_id k_na,Nameops.Name.get_id def_na + let k_na,_,t = destProd sigma t_eq in + let _,_,t = destProd sigma t in + let def_na,_,_ = destProd sigma t in + Nameops.Name.get_id k_na.binder_name,Nameops.Name.get_id def_na.binder_name in observe_tac (str "general_rewrite_bindings") (Proofview.V82.of_tactic (general_rewrite_bindings false Locus.AllOccurrences @@ -986,13 +983,19 @@ let rec intros_values_eq expr_info acc = )) let equation_others _ expr_info continuation_tac infos = + fun g -> + let env = pf_env g in + let sigma = project g in if expr_info.is_final && expr_info.is_main_branch - then - observe_tac (str "equation_others (cont_tac +intros) " ++ pr_leconstr_rd expr_info.info) + then + observe_tac (str "equation_others (cont_tac +intros) " ++ Printer.pr_leconstr_env env sigma expr_info.info) (tclTHEN (continuation_tac infos) - (observe_tac (str "intros_values_eq equation_others " ++ pr_leconstr_rd expr_info.info) (intros_values_eq expr_info []))) - else observe_tac (str "equation_others (cont_tac) " ++ pr_leconstr_rd expr_info.info) (continuation_tac infos) + (fun g -> + let env = pf_env g in + let sigma = project g in + observe_tac (str "intros_values_eq equation_others " ++ Printer.pr_leconstr_env env sigma expr_info.info) (intros_values_eq expr_info []) g)) g + else observe_tac (str "equation_others (cont_tac) " ++ Printer.pr_leconstr_env env sigma expr_info.info) (continuation_tac infos) g let equation_app f_and_args expr_info continuation_tac infos = if expr_info.is_final && expr_info.is_main_branch @@ -1054,20 +1057,19 @@ let compute_terminate_type nb_args func = let right = mkRel 5 in let delayed_force c = EConstr.Unsafe.to_constr (delayed_force c) in let equality = mkApp(delayed_force eq, [|lift 5 b; left; right|]) in - let result = (mkProd ((Name def_id) , lift 4 a_arrow_b, equality)) in + let result = (mkProd (make_annot (Name def_id) Sorts.Relevant, lift 4 a_arrow_b, equality)) in let cond = mkApp(delayed_force lt, [|(mkRel 2); (mkRel 1)|]) in let nb_iter = mkApp(delayed_force ex, [|delayed_force nat; (mkLambda - (Name - p_id, + (make_annot (Name p_id) Sorts.Relevant, delayed_force nat, - (mkProd (Name k_id, delayed_force nat, - mkArrow cond result))))|])in + (mkProd (make_annot (Name k_id) Sorts.Relevant, delayed_force nat, + mkArrow cond Sorts.Relevant result))))|])in let value = mkApp(constr_of_global (Util.delayed_force coq_sig_ref), [|b; - (mkLambda (Name v_id, b, nb_iter))|]) in + (mkLambda (make_annot (Name v_id) Sorts.Relevant, b, nb_iter))|]) in compose_prod rev_args value @@ -1165,15 +1167,15 @@ let whole_start (concl_tac:tactic) nb_args is_mes func input_type relation rec_a let func_body = EConstr.of_constr func_body in let (f_name, _, body1) = destLambda sigma func_body in let f_id = - match f_name with + match f_name.binder_name with | Name f_id -> next_ident_away_in_goal f_id ids | Anonymous -> anomaly (Pp.str "Anonymous function.") in let n_names_types,_ = decompose_lam_n sigma nb_args body1 in let n_ids,ids = List.fold_left - (fun (n_ids,ids) (n_name,_) -> - match n_name with + (fun (n_ids,ids) (n_name,_) -> + match n_name.binder_name with | Name id -> let n_id = next_ident_away_in_goal id ids in n_id::n_ids,n_id::ids @@ -1270,12 +1272,12 @@ let is_rec_res id = let clear_goals sigma = let rec clear_goal t = match EConstr.kind sigma t with - | Prod(Name id as na,t',b) -> + | Prod({binder_name=Name id} as na,t',b) -> let b' = clear_goal b in if noccurn sigma 1 b' && (is_rec_res id) then Vars.lift (-1) b' else if b' == b then t - else mkProd(na,t',b') + else mkProd(na,t',b') | _ -> EConstr.map sigma clear_goal t in List.map clear_goal @@ -1417,7 +1419,7 @@ let com_terminate nb_args ctx hook = let start_proof ctx (tac_start:tactic) (tac_end:tactic) = - let evd, env = Pfedit.get_current_context () in + let evd, env = Pfedit.get_current_context () in (* XXX *) Lemmas.start_proof thm_name (Global, false (* FIXME *), Proof Lemma) ~sign:(Environ.named_context_val env) ctx (EConstr.of_constr (compute_terminate_type nb_args fonctional_ref)) ~hook; @@ -1469,7 +1471,7 @@ let (com_eqn : int -> Id.t -> | ConstRef c -> is_opaque_constant c | _ -> anomaly ~label:"terminate_lemma" (Pp.str "not a constant.") in - let evd, env = Pfedit.get_current_context () in + let evd, env = Pfedit.get_current_context () in (* XXX *) let evd = Evd.from_ctx (Evd.evar_universe_context evd) in let f_constr = constr_of_global f_ref in let equation_lemma_type = subst1 f_constr equation_lemma_type in @@ -1519,7 +1521,8 @@ let recursive_definition is_mes function_name rec_impls type_of_f r rec_arg_num let env = Global.env() in let evd = Evd.from_env env in let evd, function_type = interp_type_evars ~program_mode:false env evd type_of_f in - let env = EConstr.push_named (Context.Named.Declaration.LocalAssum (function_name,function_type)) env in + let function_r = Sorts.Relevant in (* TODO relevance *) + let env = EConstr.push_named (Context.Named.Declaration.LocalAssum (make_annot function_name function_r,function_type)) env in (* Pp.msgnl (str "function type := " ++ Printer.pr_lconstr function_type); *) let evd, ty = interp_type_evars ~program_mode:false env evd ~impls:rec_impls eq in let evd = Evd.minimize_universes evd in @@ -1537,7 +1540,7 @@ let recursive_definition is_mes function_name rec_impls type_of_f r rec_arg_num (* Pp.msgnl (str "eq' := " ++ str (string_of_int rec_arg_num)); *) match Constr.kind eq' with | App(e,[|_;_;eq_fix|]) -> - mkLambda (Name function_name,function_type,subst_var function_name (compose_lam res_vars eq_fix)) + mkLambda (make_annot (Name function_name) Sorts.Relevant,function_type,subst_var function_name (compose_lam res_vars eq_fix)) | _ -> failwith "Recursive Definition (res not eq)" in let pre_rec_args,function_type_before_rec_arg = decompose_prod_n (rec_arg_num - 1) function_type in diff --git a/plugins/ltac/evar_tactics.ml b/plugins/ltac/evar_tactics.ml index b0277e9cc2..050fdcb608 100644 --- a/plugins/ltac/evar_tactics.ml +++ b/plugins/ltac/evar_tactics.ml @@ -11,6 +11,7 @@ open Util open Names open Constr +open Context open CErrors open Evar_refiner open Tacmach @@ -62,7 +63,7 @@ let instantiate_tac n c ido = evar_list sigma (EConstr.of_constr (NamedDecl.get_type decl)) | InHypValueOnly -> (match decl with - | LocalDef (_,body,_) -> evar_list sigma (EConstr.of_constr body) + | LocalDef (_,body,_) -> evar_list sigma (EConstr.of_constr body) | _ -> user_err Pp.(str "Not a defined hypothesis.")) in if List.length evl < n then user_err Pp.(str "Not enough uninstantiated existential variables."); @@ -108,5 +109,6 @@ let hget_evar n = if n <= 0 then user_err Pp.(str "Incorrect existential variable index."); let ev = List.nth evl (n-1) in let ev_type = EConstr.existential_type sigma ev in - Tactics.change_concl (mkLetIn (Name.Anonymous,mkEvar ev,ev_type,concl)) + let r = Retyping.relevance_of_type (Proofview.Goal.env gl) sigma ev_type in + Tactics.change_concl (mkLetIn (make_annot Name.Anonymous r,mkEvar ev,ev_type,concl)) end diff --git a/plugins/ltac/extraargs.mlg b/plugins/ltac/extraargs.mlg index 5d5d45c58f..eb9cacb975 100644 --- a/plugins/ltac/extraargs.mlg +++ b/plugins/ltac/extraargs.mlg @@ -145,31 +145,30 @@ END let pr_occurrences = pr_occurrences () () () -let pr_gen prc _prlc _prtac c = prc c +let pr_gen env sigma prc _prlc _prtac x = prc env sigma x -let pr_globc _prc _prlc _prtac (_,glob) = - let _, env = Pfedit.get_current_context () in +let pr_globc env sigma _prc _prlc _prtac (_,glob) = Printer.pr_glob_constr_env env glob let interp_glob ist gl (t,_) = Tacmach.project gl , (ist,t) let glob_glob = Tacintern.intern_constr -let pr_lconstr _ prc _ c = prc c +let pr_lconstr env sigma _ prc _ c = prc env sigma c let subst_glob = Tacsubst.subst_glob_constr_and_expr } ARGUMENT EXTEND glob - PRINTED BY { pr_globc } + PRINTED BY { pr_globc env sigma } INTERPRETED BY { interp_glob } GLOBALIZED BY { glob_glob } SUBSTITUTED BY { subst_glob } - RAW_PRINTED BY { pr_gen } - GLOB_PRINTED BY { pr_gen } + RAW_PRINTED BY { pr_gen env sigma } + GLOB_PRINTED BY { pr_gen env sigma } | [ constr(c) ] -> { c } END @@ -181,20 +180,20 @@ let l_constr = Pcoq.Constr.lconstr ARGUMENT EXTEND lconstr TYPED AS constr - PRINTED BY { pr_lconstr } + PRINTED BY { pr_lconstr env sigma } | [ l_constr(c) ] -> { c } END ARGUMENT EXTEND lglob TYPED AS glob - PRINTED BY { pr_globc } + PRINTED BY { pr_globc env sigma } INTERPRETED BY { interp_glob } GLOBALIZED BY { glob_glob } SUBSTITUTED BY { subst_glob } - RAW_PRINTED BY { pr_gen } - GLOB_PRINTED BY { pr_gen } + RAW_PRINTED BY { pr_gen env sigma } + GLOB_PRINTED BY { pr_gen env sigma } | [ lconstr(c) ] -> { c } END @@ -207,7 +206,7 @@ let interp_casted_constr ist gl c = ARGUMENT EXTEND casted_constr TYPED AS constr - PRINTED BY { pr_gen } + PRINTED BY { pr_gen env sigma } INTERPRETED BY { interp_casted_constr } | [ constr(c) ] -> { c } END @@ -296,23 +295,23 @@ END { -let pr_by_arg_tac _prc _prlc prtac opt_c = +let pr_by_arg_tac env sigma _prc _prlc prtac opt_c = match opt_c with | None -> mt () - | Some t -> hov 2 (str "by" ++ spc () ++ prtac (3,Notation_gram.E) t) + | Some t -> hov 2 (str "by" ++ spc () ++ prtac env sigma (3,Notation_gram.E) t) } ARGUMENT EXTEND by_arg_tac TYPED AS tactic option - PRINTED BY { pr_by_arg_tac } + PRINTED BY { pr_by_arg_tac env sigma } | [ "by" tactic3(c) ] -> { Some c } | [ ] -> { None } END { -let pr_by_arg_tac prtac opt_c = pr_by_arg_tac () () prtac opt_c +let pr_by_arg_tac env sigma prtac opt_c = pr_by_arg_tac env sigma () () prtac opt_c let pr_in_clause _ _ _ cl = Pptactic.pr_in_clause Pputils.pr_lident cl let pr_in_top_clause _ _ _ cl = Pptactic.pr_in_clause Id.print cl diff --git a/plugins/ltac/extraargs.mli b/plugins/ltac/extraargs.mli index 0509d6ae71..7f9eecbef5 100644 --- a/plugins/ltac/extraargs.mli +++ b/plugins/ltac/extraargs.mli @@ -65,8 +65,9 @@ val wit_by_arg_tac : glob_tactic_expr option, Geninterp.Val.t option) Genarg.genarg_type -val pr_by_arg_tac : - (int * Notation_gram.parenRelation -> raw_tactic_expr -> Pp.t) -> +val pr_by_arg_tac : + Environ.env -> Evd.evar_map -> + (Environ.env -> Evd.evar_map -> int * Notation_gram.parenRelation -> raw_tactic_expr -> Pp.t) -> raw_tactic_expr option -> Pp.t val test_lpar_id_colon : unit Pcoq.Entry.t diff --git a/plugins/ltac/extratactics.mlg b/plugins/ltac/extratactics.mlg index ffd8b71e5d..0428f08138 100644 --- a/plugins/ltac/extratactics.mlg +++ b/plugins/ltac/extratactics.mlg @@ -12,6 +12,7 @@ open Pp open Constr +open Context open Genarg open Stdarg open Tacarg @@ -674,7 +675,7 @@ let hResolve id c occ t = let sigma = Evd.merge_universe_context sigma ctx in let t_constr_type = Retyping.get_type_of env sigma t_constr in Proofview.tclTHEN (Proofview.Unsafe.tclEVARS sigma) - (change_concl (mkLetIn (Name.Anonymous,t_constr,t_constr_type,concl))) + (change_concl (mkLetIn (make_annot Name.Anonymous Sorts.Relevant,t_constr,t_constr_type,concl))) end let hResolve_auto id c t = diff --git a/plugins/ltac/g_auto.mlg b/plugins/ltac/g_auto.mlg index 663537f3e8..3a4b0571d4 100644 --- a/plugins/ltac/g_auto.mlg +++ b/plugins/ltac/g_auto.mlg @@ -62,21 +62,19 @@ let eval_uconstrs ist cs = let map c env sigma = c env sigma in 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,_) -> - let _, env = Pfedit.get_current_context () in +let pr_auto_using_raw env sigma _ _ _ = Pptactic.pr_auto_using @@ Ppconstr.pr_constr_expr env sigma +let pr_auto_using_glob env sigma _ _ _ = Pptactic.pr_auto_using (fun (c,_) -> Printer.pr_glob_constr_env env c) -let pr_auto_using _ _ _ = Pptactic.pr_auto_using - (let sigma, env = Pfedit.get_current_context () in - Printer.pr_closed_glob_env env sigma) +let pr_auto_using env sigma _ _ _ = Pptactic.pr_auto_using @@ + Printer.pr_closed_glob_env env sigma } ARGUMENT EXTEND auto_using TYPED AS uconstr list - PRINTED BY { pr_auto_using } - RAW_PRINTED BY { pr_auto_using_raw } - GLOB_PRINTED BY { pr_auto_using_glob } + PRINTED BY { pr_auto_using env sigma } + RAW_PRINTED BY { pr_auto_using_raw env sigma } + GLOB_PRINTED BY { pr_auto_using_glob env sigma } | [ "using" ne_uconstr_list_sep(l, ",") ] -> { l } | [ ] -> { [] } END diff --git a/plugins/ltac/g_ltac.mlg b/plugins/ltac/g_ltac.mlg index 4c24f51b1e..a348e2cea4 100644 --- a/plugins/ltac/g_ltac.mlg +++ b/plugins/ltac/g_ltac.mlg @@ -514,7 +514,7 @@ END let pr_ltac_ref = Libnames.pr_qualid -let pr_tacdef_body tacdef_body = +let pr_tacdef_body env sigma tacdef_body = let id, redef, body = match tacdef_body with | TacticDefinition ({CAst.v=id}, body) -> Id.print id, false, body @@ -528,12 +528,12 @@ let pr_tacdef_body tacdef_body = prlist (function Name.Anonymous -> str " _" | Name.Name id -> spc () ++ Id.print id) idl ++ (if redef then str" ::=" else str" :=") ++ brk(1,1) - ++ Pptactic.pr_raw_tactic body + ++ Pptactic.pr_raw_tactic env sigma body } VERNAC ARGUMENT EXTEND ltac_tacdef_body -PRINTED BY { pr_tacdef_body } +PRINTED BY { pr_tacdef_body env sigma } | [ tacdef_body(t) ] -> { t } END diff --git a/plugins/ltac/g_obligations.mlg b/plugins/ltac/g_obligations.mlg index cdee012a82..a12dee48a8 100644 --- a/plugins/ltac/g_obligations.mlg +++ b/plugins/ltac/g_obligations.mlg @@ -162,9 +162,9 @@ END (* Declare a printer for the content of Program tactics *) let () = - let printer _ _ _ = function + let printer env sigma _ _ _ = function | None -> mt () - | Some tac -> str "with" ++ spc () ++ Pptactic.pr_raw_tactic tac + | Some tac -> str "with" ++ spc () ++ Pptactic.pr_raw_tactic env sigma tac in Pptactic.declare_extra_vernac_genarg_pprule wit_withtac printer diff --git a/plugins/ltac/g_rewrite.mlg b/plugins/ltac/g_rewrite.mlg index db8d1b20d8..86a227415a 100644 --- a/plugins/ltac/g_rewrite.mlg +++ b/plugins/ltac/g_rewrite.mlg @@ -41,13 +41,11 @@ type constr_expr_with_bindings = constr_expr with_bindings type glob_constr_with_bindings = glob_constr_and_expr with_bindings type glob_constr_with_bindings_sign = interp_sign * glob_constr_and_expr with_bindings -let pr_glob_constr_with_bindings_sign _ _ _ (ge : glob_constr_with_bindings_sign) = - let _, env = Pfedit.get_current_context () in +let pr_glob_constr_with_bindings_sign env sigma _ _ _ (ge : glob_constr_with_bindings_sign) = Printer.pr_glob_constr_env env (fst (fst (snd ge))) -let pr_glob_constr_with_bindings _ _ _ (ge : glob_constr_with_bindings) = - let _, env = Pfedit.get_current_context () in +let pr_glob_constr_with_bindings env sigma _ _ _ (ge : glob_constr_with_bindings) = Printer.pr_glob_constr_env env (fst (fst ge)) -let pr_constr_expr_with_bindings prc _ _ (ge : constr_expr_with_bindings) = prc (fst ge) +let pr_constr_expr_with_bindings env sigma prc _ _ (ge : constr_expr_with_bindings) = prc env sigma (fst ge) let interp_glob_constr_with_bindings ist gl c = Tacmach.project gl , (ist, c) let glob_glob_constr_with_bindings ist l = Tacintern.intern_constr_with_bindings ist l let subst_glob_constr_with_bindings s c = @@ -56,14 +54,14 @@ let subst_glob_constr_with_bindings s c = } ARGUMENT EXTEND glob_constr_with_bindings - PRINTED BY { pr_glob_constr_with_bindings_sign } + PRINTED BY { pr_glob_constr_with_bindings_sign env sigma } INTERPRETED BY { interp_glob_constr_with_bindings } GLOBALIZED BY { glob_glob_constr_with_bindings } SUBSTITUTED BY { subst_glob_constr_with_bindings } - RAW_PRINTED BY { pr_constr_expr_with_bindings } - GLOB_PRINTED BY { pr_glob_constr_with_bindings } + RAW_PRINTED BY { pr_constr_expr_with_bindings env sigma } + GLOB_PRINTED BY { pr_glob_constr_with_bindings env sigma } | [ constr_with_bindings(bl) ] -> { bl } END @@ -80,17 +78,17 @@ let glob_strategy ist s = map_strategy (Tacintern.intern_constr ist) (fun c -> c let subst_strategy s str = str let pr_strategy _ _ _ (s : strategy) = Pp.str "<strategy>" -let pr_raw_strategy prc prlc _ (s : raw_strategy) = - let prr = Pptactic.pr_red_expr (prc, prlc, Pputils.pr_or_by_notation Libnames.pr_qualid, prc) in - Rewrite.pr_strategy prc prr s -let pr_glob_strategy prc prlc _ (s : glob_strategy) = - let prr = Pptactic.pr_red_expr +let pr_raw_strategy env sigma prc prlc _ (s : raw_strategy) = + let prr = Pptactic.pr_red_expr env sigma (prc, prlc, Pputils.pr_or_by_notation Libnames.pr_qualid, prc) in + Rewrite.pr_strategy (prc env sigma) prr s +let pr_glob_strategy env sigma prc prlc _ (s : glob_strategy) = + let prr = Pptactic.pr_red_expr env sigma (Ppconstr.pr_constr_expr, Ppconstr.pr_lconstr_expr, Pputils.pr_or_by_notation Libnames.pr_qualid, Ppconstr.pr_constr_expr) in - Rewrite.pr_strategy prc prr s + Rewrite.pr_strategy (prc env sigma) prr s } @@ -101,8 +99,8 @@ ARGUMENT EXTEND rewstrategy GLOBALIZED BY { glob_strategy } SUBSTITUTED BY { subst_strategy } - RAW_PRINTED BY { pr_raw_strategy } - GLOB_PRINTED BY { pr_glob_strategy } + RAW_PRINTED BY { pr_raw_strategy env sigma } + GLOB_PRINTED BY { pr_glob_strategy env sigma } | [ glob(c) ] -> { StratConstr (c, true) } | [ "<-" constr(c) ] -> { StratConstr (c, false) } @@ -224,7 +222,7 @@ let wit_binders = let binders = Pcoq.create_generic_entry Pcoq.utactic "binders" (Genarg.rawwit wit_binders) let () = - let raw_printer _ _ _ l = Pp.pr_non_empty_arg Ppconstr.pr_binders l in + let raw_printer env sigma _ _ _ l = Pp.pr_non_empty_arg (Ppconstr.pr_binders env sigma) l in Pptactic.declare_extra_vernac_genarg_pprule wit_binders raw_printer } diff --git a/plugins/ltac/pptactic.ml b/plugins/ltac/pptactic.ml index 5e3f4df192..1bdba699f7 100644 --- a/plugins/ltac/pptactic.ml +++ b/plugins/ltac/pptactic.ml @@ -71,40 +71,46 @@ let declare_notation_tactic_pprule kn pt = prnotation_tab := KNmap.add kn pt !prnotation_tab type 'a raw_extra_genarg_printer = - (constr_expr -> Pp.t) -> - (constr_expr -> Pp.t) -> - (tolerability -> raw_tactic_expr -> Pp.t) -> - 'a -> Pp.t + Environ.env -> Evd.evar_map -> + (Environ.env -> Evd.evar_map -> constr_expr -> Pp.t) -> + (Environ.env -> Evd.evar_map -> constr_expr -> Pp.t) -> + (Environ.env -> Evd.evar_map -> tolerability -> raw_tactic_expr -> Pp.t) -> + 'a -> Pp.t type 'a glob_extra_genarg_printer = - (glob_constr_and_expr -> Pp.t) -> - (glob_constr_and_expr -> Pp.t) -> - (tolerability -> glob_tactic_expr -> Pp.t) -> - 'a -> Pp.t + Environ.env -> Evd.evar_map -> + (Environ.env -> Evd.evar_map -> glob_constr_and_expr -> Pp.t) -> + (Environ.env -> Evd.evar_map -> glob_constr_and_expr -> Pp.t) -> + (Environ.env -> Evd.evar_map -> tolerability -> glob_tactic_expr -> Pp.t) -> + 'a -> Pp.t type 'a extra_genarg_printer = - (EConstr.constr -> Pp.t) -> - (EConstr.constr -> Pp.t) -> - (tolerability -> Val.t -> Pp.t) -> - 'a -> Pp.t + Environ.env -> Evd.evar_map -> + (Environ.env -> Evd.evar_map -> EConstr.constr -> Pp.t) -> + (Environ.env -> Evd.evar_map -> EConstr.constr -> Pp.t) -> + (Environ.env -> Evd.evar_map -> tolerability -> Val.t -> Pp.t) -> + 'a -> Pp.t type 'a raw_extra_genarg_printer_with_level = - (constr_expr -> Pp.t) -> - (constr_expr -> Pp.t) -> - (tolerability -> raw_tactic_expr -> Pp.t) -> - tolerability -> 'a -> Pp.t + Environ.env -> Evd.evar_map -> + (Environ.env -> Evd.evar_map -> constr_expr -> Pp.t) -> + (Environ.env -> Evd.evar_map -> constr_expr -> Pp.t) -> + (Environ.env -> Evd.evar_map -> tolerability -> raw_tactic_expr -> Pp.t) -> + tolerability -> 'a -> Pp.t type 'a glob_extra_genarg_printer_with_level = - (glob_constr_and_expr -> Pp.t) -> - (glob_constr_and_expr -> Pp.t) -> - (tolerability -> glob_tactic_expr -> Pp.t) -> - tolerability -> 'a -> Pp.t + Environ.env -> Evd.evar_map -> + (Environ.env -> Evd.evar_map -> glob_constr_and_expr -> Pp.t) -> + (Environ.env -> Evd.evar_map -> glob_constr_and_expr -> Pp.t) -> + (Environ.env -> Evd.evar_map -> tolerability -> glob_tactic_expr -> Pp.t) -> + tolerability -> 'a -> Pp.t type 'a extra_genarg_printer_with_level = - (EConstr.constr -> Pp.t) -> - (EConstr.constr -> Pp.t) -> - (tolerability -> Val.t -> Pp.t) -> - tolerability -> 'a -> Pp.t + Environ.env -> Evd.evar_map -> + (Environ.env -> Evd.evar_map -> EConstr.constr -> Pp.t) -> + (Environ.env -> Evd.evar_map -> EConstr.constr -> Pp.t) -> + (Environ.env -> Evd.evar_map -> tolerability -> Val.t -> Pp.t) -> + tolerability -> 'a -> Pp.t let string_of_genarg_arg (ArgumentType arg) = let rec aux : type a b c. (a, b, c) genarg_type -> string = function @@ -160,27 +166,27 @@ let string_of_genarg_arg (ArgumentType arg) = | _ -> default let pr_with_occurrences pr c = Ppred.pr_with_occurrences pr keyword c - let pr_red_expr pr c = Ppred.pr_red_expr pr keyword c + let pr_red_expr env sigma pr c = Ppred.pr_red_expr_env env sigma pr keyword c - let pr_may_eval test prc prlc pr2 pr3 = function + let pr_may_eval env sigma test prc prlc pr2 pr3 = function | ConstrEval (r,c) -> hov 0 (keyword "eval" ++ brk (1,1) ++ - pr_red_expr (prc,prlc,pr2,pr3) r ++ spc () ++ - keyword "in" ++ spc() ++ prc c) + pr_red_expr env sigma (prc,prlc,pr2,pr3) r ++ spc () ++ + keyword "in" ++ spc() ++ prc env sigma c) | ConstrContext ({CAst.v=id},c) -> hov 0 (keyword "context" ++ spc () ++ pr_id id ++ spc () ++ - str "[ " ++ prlc c ++ str " ]") + str "[ " ++ prlc env sigma c ++ str " ]") | ConstrTypeOf c -> - hov 1 (keyword "type of" ++ spc() ++ prc c) + hov 1 (keyword "type of" ++ spc() ++ prc env sigma c) | ConstrTerm c when test c -> - h 0 (str "(" ++ prc c ++ str ")") + h 0 (str "(" ++ prc env sigma c ++ str ")") | ConstrTerm c -> - prc c + prc env sigma c - let pr_may_eval a = - pr_may_eval (fun _ -> false) a + let pr_may_eval env sigma a = + pr_may_eval env sigma (fun _ -> false) a let pr_arg pr x = spc () ++ pr x @@ -647,15 +653,15 @@ let pr_goal_selector ~toplevel s = type 'a printer = { pr_tactic : tolerability -> 'tacexpr -> Pp.t; - pr_constr : 'trm -> Pp.t; - pr_lconstr : 'trm -> Pp.t; - pr_dconstr : 'dtrm -> Pp.t; - pr_pattern : 'pat -> Pp.t; - pr_lpattern : 'pat -> Pp.t; + pr_constr : Environ.env -> Evd.evar_map -> 'trm -> Pp.t; + pr_lconstr : Environ.env -> Evd.evar_map -> 'trm -> Pp.t; + pr_dconstr : Environ.env -> Evd.evar_map -> 'dtrm -> Pp.t; + pr_pattern : Environ.env -> Evd.evar_map -> 'pat -> Pp.t; + pr_lpattern : Environ.env -> Evd.evar_map -> 'pat -> Pp.t; pr_constant : 'cst -> Pp.t; pr_reference : 'ref -> Pp.t; pr_name : 'nam -> Pp.t; - pr_generic : 'lev generic_argument -> Pp.t; + pr_generic : Environ.env -> Evd.evar_map -> 'lev generic_argument -> Pp.t; pr_extend : int -> ml_tactic_entry -> 'a gen_tactic_arg list -> Pp.t; pr_alias : int -> KerName.t -> 'a gen_tactic_arg list -> Pp.t; } @@ -671,14 +677,14 @@ let pr_goal_selector ~toplevel s = level :'lev > - let pr_atom pr strip_prod_binders tag_atom = - let pr_with_bindings = pr_with_bindings pr.pr_constr pr.pr_lconstr in + let pr_atom env sigma pr strip_prod_binders tag_atom = + let pr_with_bindings = pr_with_bindings (pr.pr_constr env sigma) (pr.pr_lconstr env sigma) in let pr_with_bindings_arg_full = pr_with_bindings_arg in - let pr_with_bindings_arg = pr_with_bindings_arg pr.pr_constr pr.pr_lconstr in - let pr_red_expr = pr_red_expr (pr.pr_constr,pr.pr_lconstr,pr.pr_constant,pr.pr_pattern) in + let pr_with_bindings_arg = pr_with_bindings_arg (pr.pr_constr env sigma) (pr.pr_lconstr env sigma) in + let pr_red_expr = pr_red_expr env sigma (pr.pr_constr,pr.pr_lconstr,pr.pr_constant,pr.pr_pattern) in - let _pr_constrarg c = spc () ++ pr.pr_constr c in - let pr_lconstrarg c = spc () ++ pr.pr_lconstr c in + let _pr_constrarg c = spc () ++ pr.pr_constr env sigma c in + let pr_lconstrarg c = spc () ++ pr.pr_lconstr env sigma c in let pr_intarg n = spc () ++ int n in (* Some printing combinators *) @@ -688,7 +694,7 @@ let pr_goal_selector ~toplevel s = (* match t with | CHole _ -> spc() ++ prlist_with_sep spc (pr_lname) nal | _ ->*) - let s = prlist_with_sep spc pr_lname nal ++ str ":" ++ pr.pr_lconstr t in + let s = prlist_with_sep spc pr_lname nal ++ str ":" ++ pr.pr_lconstr env sigma t in spc() ++ hov 1 (str"(" ++ s ++ str")") in let pr_fix_tac (id,n,c) = @@ -723,7 +729,7 @@ let pr_goal_selector ~toplevel s = in hov 1 (str"(" ++ pr_id id ++ prlist pr_binder_fix bll ++ annot ++ str" :" ++ - pr_lconstrarg ty ++ str")") in + (pr_lconstrarg ty) ++ str")") in (* spc() ++ hov 0 (pr_id id ++ pr_intarg n ++ str":" ++ _pr_constrarg c) @@ -747,13 +753,13 @@ let pr_goal_selector ~toplevel s = hov 1 (primitive (if ev then "eintros" else "intros") ++ (match p with | [{CAst.v=IntroForthcoming false}] -> mt () - | _ -> spc () ++ prlist_with_sep spc (Miscprint.pr_intro_pattern pr.pr_dconstr) p)) + | _ -> spc () ++ prlist_with_sep spc (Miscprint.pr_intro_pattern @@ pr.pr_dconstr env sigma) p)) | TacApply (a,ev,cb,inhyp) -> hov 1 ( (if a then mt() else primitive "simple ") ++ primitive (with_evars ev "apply") ++ spc () ++ prlist_with_sep pr_comma pr_with_bindings_arg cb ++ - pr_non_empty_arg (pr_in_hyp_as pr.pr_dconstr pr.pr_name) inhyp + pr_non_empty_arg (pr_in_hyp_as (pr.pr_dconstr env sigma) pr.pr_name) inhyp ) | TacElim (ev,cb,cbo) -> hov 1 ( @@ -774,28 +780,28 @@ let pr_goal_selector ~toplevel s = | TacAssert (ev,b,Some tac,ipat,c) -> hov 1 ( primitive (if b then if ev then "eassert" else "assert" else if ev then "eenough" else "enough") ++ - pr_assumption pr.pr_constr pr.pr_dconstr pr.pr_lconstr ipat c ++ + pr_assumption (pr.pr_constr env sigma) (pr.pr_dconstr env sigma) (pr.pr_lconstr env sigma) ipat c ++ pr_non_empty_arg (pr_by_tactic (pr.pr_tactic (ltactical,E))) tac ) | TacAssert (ev,_,None,ipat,c) -> hov 1 ( primitive (if ev then "epose proof" else "pose proof") - ++ pr_assertion pr.pr_constr pr.pr_dconstr pr.pr_lconstr ipat c + ++ pr_assertion (pr.pr_constr env sigma) (pr.pr_dconstr env sigma) (pr.pr_lconstr env sigma) ipat c ) | TacGeneralize l -> hov 1 ( primitive "generalize" ++ spc () ++ prlist_with_sep pr_comma (fun (cl,na) -> - pr_with_occurrences pr.pr_constr cl ++ pr_as_name na) + pr_with_occurrences (pr.pr_constr env sigma) cl ++ pr_as_name na) l ) | TacLetTac (ev,na,c,cl,true,_) when Locusops.is_nowhere cl -> - hov 1 (primitive (if ev then "epose" else "pose") ++ pr_pose pr.pr_constr pr.pr_lconstr na c) + hov 1 (primitive (if ev then "epose" else "pose") ++ pr_pose (pr.pr_constr env sigma) (pr.pr_lconstr env sigma) na c) | TacLetTac (ev,na,c,cl,b,e) -> hov 1 ( primitive (if b then if ev then "eset" else "set" else if ev then "eremember" else "remember") ++ - (if b then pr_pose pr.pr_constr pr.pr_lconstr na c - else pr_pose_as_style pr.pr_constr na c) ++ + (if b then pr_pose (pr.pr_constr env sigma) (pr.pr_lconstr env sigma) na c + else pr_pose_as_style (pr.pr_constr env sigma) na c) ++ pr_opt (fun p -> pr_eqn_ipat p ++ spc ()) e ++ pr_non_empty_arg (pr_clauses (Some b) pr.pr_name) cl) (* | TacInstantiate (n,c,ConclLocation ()) -> @@ -815,8 +821,8 @@ let pr_goal_selector ~toplevel s = primitive (with_evars ev (if isrec then "induction" else "destruct")) ++ spc () ++ prlist_with_sep pr_comma (fun (h,ids,cl) -> - pr_destruction_arg pr.pr_dconstr pr.pr_dconstr h ++ - pr_non_empty_arg (pr_with_induction_names pr.pr_dconstr) ids ++ + pr_destruction_arg (pr.pr_dconstr env sigma) (pr.pr_dconstr env sigma) h ++ + pr_non_empty_arg (pr_with_induction_names (pr.pr_dconstr env sigma)) ids ++ pr_opt (pr_clauses None pr.pr_name) cl) l ++ pr_opt pr_eliminator el ) @@ -835,9 +841,9 @@ let pr_goal_selector ~toplevel s = None -> mt () | Some p -> - pr.pr_pattern p ++ spc () + pr.pr_pattern env sigma p ++ spc () ++ keyword "with" ++ spc () - ) ++ pr.pr_dconstr c ++ pr_non_empty_arg (pr_clauses (Some true) pr.pr_name) h + ) ++ pr.pr_dconstr env sigma c ++ pr_non_empty_arg (pr_clauses (Some true) pr.pr_name) h ) (* Equality and inversion *) @@ -848,7 +854,7 @@ let pr_goal_selector ~toplevel s = (fun () -> str ","++spc()) (fun (b,m,c) -> pr_orient b ++ pr_multi m ++ - pr_with_bindings_arg_full pr.pr_dconstr pr.pr_dconstr c) + pr_with_bindings_arg_full (pr.pr_dconstr env sigma) (pr.pr_dconstr env sigma) c) l ++ pr_non_empty_arg (pr_clauses (Some true) pr.pr_name) cl ++ pr_non_empty_arg (pr_by_tactic (pr.pr_tactic (ltactical,E))) tac @@ -857,28 +863,28 @@ let pr_goal_selector ~toplevel s = hov 1 ( primitive "dependent " ++ pr_inversion_kind k ++ spc () ++ pr_quantified_hypothesis hyp - ++ pr_with_inversion_names pr.pr_dconstr ids - ++ pr_with_constr pr.pr_constr c + ++ pr_with_inversion_names (pr.pr_dconstr env sigma) ids + ++ pr_with_constr (pr.pr_constr env sigma) c ) | TacInversion (NonDepInversion (k,cl,ids),hyp) -> hov 1 ( pr_inversion_kind k ++ spc () ++ pr_quantified_hypothesis hyp - ++ pr_non_empty_arg (pr_with_inversion_names pr.pr_dconstr) ids + ++ pr_non_empty_arg (pr_with_inversion_names @@ pr.pr_dconstr env sigma) ids ++ pr_non_empty_arg (pr_simple_hyp_clause pr.pr_name) cl ) | TacInversion (InversionUsing (c,cl),hyp) -> hov 1 ( primitive "inversion" ++ spc() ++ pr_quantified_hypothesis hyp ++ spc () - ++ keyword "using" ++ spc () ++ pr.pr_constr c + ++ keyword "using" ++ spc () ++ pr.pr_constr env sigma c ++ pr_non_empty_arg (pr_simple_hyp_clause pr.pr_name) cl ) ) in pr_atom1 - let make_pr_tac pr strip_prod_binders tag_atom tag = + let make_pr_tac env sigma pr strip_prod_binders tag_atom tag = let extract_binders = function | Tacexp (TacFun (lvar,body)) -> (lvar,Tacexp body) @@ -898,7 +904,7 @@ let pr_goal_selector ~toplevel s = let llc = List.map (fun (id,t) -> (id,extract_binders t)) llc in v 0 (hv 0 ( - pr_let_clauses recflag pr.pr_generic (pr_tac ltop) llc + pr_let_clauses recflag (pr.pr_generic env sigma) (pr_tac ltop) llc ++ spc () ++ keyword "in" ) ++ fnl () ++ pr_tac (llet,E) u), llet @@ -908,7 +914,7 @@ let pr_goal_selector ~toplevel s = ++ pr_tac ltop t ++ spc () ++ keyword "with" ++ prlist (fun r -> fnl () ++ str "| " - ++ pr_match_rule true (pr_tac ltop) pr.pr_lpattern r + ++ pr_match_rule true (pr_tac ltop) (pr.pr_lpattern env sigma) r ) lrul ++ fnl() ++ keyword "end"), lmatch @@ -918,7 +924,7 @@ let pr_goal_selector ~toplevel s = ++ keyword (if lr then "match reverse goal with" else "match goal with") ++ prlist (fun r -> fnl () ++ str "| " - ++ pr_match_rule false (pr_tac ltop) pr.pr_lpattern r + ++ pr_match_rule false (pr_tac ltop) (pr.pr_lpattern env sigma) r ) lrul ++ fnl() ++ keyword "end"), lmatch | TacFun (lvar,body) -> @@ -1041,17 +1047,17 @@ let pr_goal_selector ~toplevel s = | TacId l -> keyword "idtac" ++ prlist (pr_arg (pr_message_token pr.pr_name)) l, latom | TacAtom { CAst.loc; v=t } -> - pr_with_comments ?loc (hov 1 (pr_atom pr strip_prod_binders tag_atom t)), ltatom + pr_with_comments ?loc (hov 1 (pr_atom env sigma pr strip_prod_binders tag_atom t)), ltatom | TacArg { CAst.v=Tacexp e } -> pr_tac inherited e, latom | TacArg { CAst.v=ConstrMayEval (ConstrTerm c) } -> - keyword "constr:" ++ pr.pr_constr c, latom + keyword "constr:" ++ pr.pr_constr env sigma c, latom | TacArg { CAst.v=ConstrMayEval c } -> - pr_may_eval pr.pr_constr pr.pr_lconstr pr.pr_constant pr.pr_pattern c, leval + pr_may_eval env sigma pr.pr_constr pr.pr_lconstr pr.pr_constant pr.pr_pattern c, leval | TacArg { CAst.v=TacFreshId l } -> primitive "fresh" ++ pr_fresh_ids l, latom | TacArg { CAst.v=TacGeneric arg } -> - pr.pr_generic arg, latom + pr.pr_generic env sigma arg, latom | TacArg { CAst.v=TacCall {CAst.v=(f,[])} } -> pr.pr_reference f, latom | TacArg { CAst.v=TacCall {CAst.loc; v=(f,l)} } -> @@ -1074,11 +1080,11 @@ let pr_goal_selector ~toplevel s = | Reference r -> pr.pr_reference r | ConstrMayEval c -> - pr_may_eval pr.pr_constr pr.pr_lconstr pr.pr_constant pr.pr_pattern c + pr_may_eval env sigma pr.pr_constr pr.pr_lconstr pr.pr_constant pr.pr_pattern c | TacFreshId l -> keyword "fresh" ++ pr_fresh_ids l | TacPretype c -> - keyword "type_term" ++ pr.pr_constr c + keyword "type_term" ++ pr.pr_constr env sigma c | TacNumgoals -> keyword "numgoals" | (TacCall _|Tacexp _ | TacGeneric _) as a -> @@ -1098,9 +1104,9 @@ let pr_goal_selector ~toplevel s = let raw_printers = (strip_prod_binders_expr) - let rec pr_raw_tactic_level n (t:raw_tactic_expr) = + let rec pr_raw_tactic_level env sigma n (t:raw_tactic_expr) = let pr = { - pr_tactic = pr_raw_tactic_level; + pr_tactic = pr_raw_tactic_level env sigma; pr_constr = pr_constr_expr; pr_dconstr = pr_constr_expr; pr_lconstr = pr_lconstr_expr; @@ -1109,16 +1115,16 @@ let pr_goal_selector ~toplevel s = pr_constant = pr_or_by_notation pr_qualid; pr_reference = pr_qualid; pr_name = pr_lident; - pr_generic = (fun arg -> Pputils.pr_raw_generic (Global.env ()) arg); - pr_extend = pr_raw_extend_rec pr_raw_tactic_level; - pr_alias = pr_raw_alias pr_raw_tactic_level; + pr_generic = Pputils.pr_raw_generic; + pr_extend = pr_raw_extend_rec @@ pr_raw_tactic_level env sigma; + pr_alias = pr_raw_alias @@ pr_raw_tactic_level env sigma; } in - make_pr_tac + make_pr_tac env sigma pr raw_printers tag_raw_atomic_tactic_expr tag_raw_tactic_expr n t - let pr_raw_tactic = pr_raw_tactic_level ltop + let pr_raw_tactic env sigma = pr_raw_tactic_level env sigma ltop let pr_and_constr_expr pr (c,_) = pr c @@ -1131,19 +1137,19 @@ let pr_goal_selector ~toplevel s = let rec prtac n (t:glob_tactic_expr) = let pr = { pr_tactic = prtac; - pr_constr = pr_and_constr_expr (pr_glob_constr_env env); - pr_dconstr = pr_and_constr_expr (pr_glob_constr_env env); - pr_lconstr = pr_and_constr_expr (pr_lglob_constr_env env); - pr_pattern = pr_pat_and_constr_expr (pr_glob_constr_env env); - pr_lpattern = pr_pat_and_constr_expr (pr_lglob_constr_env env); + pr_constr = (fun env sigma -> pr_and_constr_expr (pr_glob_constr_env env)); + pr_dconstr = (fun env sigma -> pr_and_constr_expr (pr_glob_constr_env env)); + pr_lconstr = (fun env sigma -> pr_and_constr_expr (pr_lglob_constr_env env)); + pr_pattern = (fun env sigma -> pr_pat_and_constr_expr (pr_glob_constr_env env)); + pr_lpattern = (fun env sigma -> pr_pat_and_constr_expr (pr_lglob_constr_env env)); pr_constant = pr_or_var (pr_and_short_name (pr_evaluable_reference_env env)); pr_reference = pr_ltac_or_var (pr_located pr_ltac_constant); pr_name = pr_lident; - pr_generic = (fun arg -> Pputils.pr_glb_generic (Global.env ()) arg); + pr_generic = Pputils.pr_glb_generic; pr_extend = pr_glob_extend_rec prtac; pr_alias = pr_glob_alias prtac; } in - make_pr_tac + make_pr_tac env (Evd.from_env env) pr glob_printers tag_glob_atomic_tactic_expr tag_glob_tactic_expr n t @@ -1158,7 +1164,7 @@ let pr_goal_selector ~toplevel s = if n=0 then (List.rev acc, EConstr.of_constr ty) else match Constr.kind ty with | Constr.Prod(na,a,b) -> - strip_ty (([CAst.make na],EConstr.of_constr a)::acc) (n-1) b + strip_ty (([CAst.make na.Context.binder_name],EConstr.of_constr a)::acc) (n-1) b | _ -> user_err Pp.(str "Cannot translate fix tactic: not enough products") in strip_ty [] n ty @@ -1166,11 +1172,11 @@ let pr_goal_selector ~toplevel s = let prtac (t:atomic_tactic_expr) = let pr = { pr_tactic = (fun _ _ -> str "<tactic>"); - pr_constr = (fun c -> pr_econstr_env env sigma c); - pr_dconstr = pr_and_constr_expr (pr_glob_constr_env env); - pr_lconstr = (fun c -> pr_leconstr_env env sigma c); - pr_pattern = pr_constr_pattern_env env sigma; - pr_lpattern = pr_lconstr_pattern_env env sigma; + pr_constr = pr_econstr_env; + pr_dconstr = (fun env sigma -> pr_and_constr_expr (pr_glob_constr_env env)); + pr_lconstr = pr_leconstr_env; + pr_pattern = pr_constr_pattern_env; + pr_lpattern = pr_lconstr_pattern_env; pr_constant = pr_evaluable_reference_env env; pr_reference = pr_located pr_ltac_constant; pr_name = pr_id; @@ -1180,7 +1186,7 @@ let pr_goal_selector ~toplevel s = pr_alias = (fun _ _ _ -> assert false); } in - pr_atom pr strip_prod_binders_constr tag_atomic_tactic_expr t + pr_atom env sigma pr strip_prod_binders_constr tag_atomic_tactic_expr t in prtac t @@ -1188,9 +1194,9 @@ let pr_goal_selector ~toplevel s = let pr_glb_generic = Pputils.pr_glb_generic - let pr_raw_extend _ = pr_raw_extend_rec pr_raw_tactic_level + let pr_raw_extend env sigma = pr_raw_extend_rec @@ pr_raw_tactic_level env sigma - let pr_glob_extend env = pr_glob_extend_rec (pr_glob_tactic_level env) + let pr_glob_extend env sigma = pr_glob_extend_rec (pr_glob_tactic_level env) let pr_alias pr lev key args = pr_alias_gen (fun _ arg -> pr arg) lev key args @@ -1209,16 +1215,17 @@ let declare_extra_genarg_pprule wit | _ -> user_err Pp.(str "Can declare a pretty-printing rule only for extra argument types.") end; let f x = - Genprint.PrinterBasic (fun () -> - f pr_constr_expr pr_lconstr_expr pr_raw_tactic_level x) in + Genprint.PrinterBasic (fun env sigma -> + f env sigma pr_constr_expr pr_lconstr_expr pr_raw_tactic_level x) in let g x = - Genprint.PrinterBasic (fun () -> - let env = Global.env () in - g (pr_and_constr_expr (pr_glob_constr_env env)) (pr_and_constr_expr (pr_lglob_constr_env env)) (pr_glob_tactic_level env) x) + Genprint.PrinterBasic (fun env sigma -> + g env sigma (fun env sigma -> pr_and_constr_expr (pr_glob_constr_env env)) + (fun env sigma -> pr_and_constr_expr (pr_lglob_constr_env env)) + (fun env sigma -> pr_glob_tactic_level env) x) in let h x = Genprint.TopPrinterNeedsContext (fun env sigma -> - h (pr_econstr_env env sigma) (pr_leconstr_env env sigma) (fun _ _ -> str "<tactic>") x) + h env sigma pr_econstr_env pr_leconstr_env (fun _env _sigma _ _ -> str "<tactic>") x) in Genprint.register_print0 wit f g h @@ -1235,27 +1242,28 @@ let declare_extra_genarg_pprule_with_level wit PrinterNeedsLevel { default_already_surrounded = default_surrounded; default_ensure_surrounded = default_non_surrounded; - printer = (fun n -> - f pr_constr_expr pr_lconstr_expr pr_raw_tactic_level n x) } in + printer = (fun env sigma n -> + f env sigma pr_constr_expr pr_lconstr_expr pr_raw_tactic_level n x) } in let g x = - let env = Global.env () in PrinterNeedsLevel { default_already_surrounded = default_surrounded; default_ensure_surrounded = default_non_surrounded; - printer = (fun n -> - g (pr_and_constr_expr (pr_glob_constr_env env)) (pr_and_constr_expr (pr_lglob_constr_env env)) (pr_glob_tactic_level env) n x) } + printer = (fun env sigma n -> + g env sigma (fun env sigma -> pr_and_constr_expr (pr_glob_constr_env env)) + (fun env sigma -> pr_and_constr_expr (pr_lglob_constr_env env)) + (fun env sigma -> pr_glob_tactic_level env) n x) } in let h x = TopPrinterNeedsContextAndLevel { default_already_surrounded = default_surrounded; default_ensure_surrounded = default_non_surrounded; printer = (fun env sigma n -> - h (pr_econstr_env env sigma) (pr_leconstr_env env sigma) (fun _ _ -> str "<tactic>") n x) } + h env sigma pr_econstr_env pr_leconstr_env (fun _env _sigma _ _ -> str "<tactic>") n x) } in Genprint.register_print0 wit f g h let declare_extra_vernac_genarg_pprule wit f = - let f x = Genprint.PrinterBasic (fun () -> f pr_constr_expr pr_lconstr_expr pr_raw_tactic_level x) in + let f x = Genprint.PrinterBasic (fun env sigma -> f env sigma pr_constr_expr pr_lconstr_expr pr_raw_tactic_level x) in Genprint.register_vernac_print0 wit f (** Registering *) @@ -1265,8 +1273,8 @@ let pr_intro_pattern_env p = Genprint.TopPrinterNeedsContext (fun env sigma -> Miscprint.pr_intro_pattern print_constr p) let pr_red_expr_env r = Genprint.TopPrinterNeedsContext (fun env sigma -> - pr_red_expr (pr_econstr_env env sigma, pr_leconstr_env env sigma, - pr_evaluable_reference_env env, pr_constr_pattern_env env sigma) r) + pr_red_expr env sigma (pr_econstr_env, pr_leconstr_env, + pr_evaluable_reference_env env, pr_constr_pattern_env) r) let pr_bindings_env bl = Genprint.TopPrinterNeedsContext (fun env sigma -> let sigma, bl = bl env sigma in @@ -1292,19 +1300,18 @@ let make_constr_printer f c = Genprint.default_ensure_surrounded = Ppconstr.lsimpleconstr; Genprint.printer = (fun env sigma n -> f env sigma n c)} -let lift f a = Genprint.PrinterBasic (fun () -> f a) +let lift f a = Genprint.PrinterBasic (fun env sigma -> f a) +let lift_env f a = Genprint.PrinterBasic (fun env sigma -> f env sigma a) let lift_top f a = Genprint.TopPrinterBasic (fun () -> f a) let register_basic_print0 wit f g h = Genprint.register_print0 wit (lift f) (lift g) (lift_top h) -let pr_glob_constr_pptac c = - let _, env = Pfedit.get_current_context () in +let pr_glob_constr_pptac env sigma c = pr_glob_constr_env env c -let pr_lglob_constr_pptac c = - let _, env = Pfedit.get_current_context () in +let pr_lglob_constr_pptac env sigma c = pr_lglob_constr_env env c let () = @@ -1318,8 +1325,8 @@ let () = register_basic_print0 wit_var pr_lident pr_lident pr_id; register_print0 wit_intro_pattern - (lift (Miscprint.pr_intro_pattern pr_constr_expr)) - (lift (Miscprint.pr_intro_pattern (fun (c,_) -> pr_glob_constr_pptac c))) + (lift_env (fun env sigma -> Miscprint.pr_intro_pattern @@ pr_constr_expr env sigma)) + (lift_env (fun env sigma -> Miscprint.pr_intro_pattern (fun (c,_) -> pr_glob_constr_pptac env sigma c))) pr_intro_pattern_env; Genprint.register_print0 wit_clause_dft_concl @@ -1329,47 +1336,55 @@ let () = ; Genprint.register_print0 wit_constr - (lift Ppconstr.pr_lconstr_expr) - (lift (fun (c, _) -> pr_lglob_constr_pptac c)) + (lift_env Ppconstr.pr_lconstr_expr) + (lift_env (fun env sigma (c, _) -> pr_lglob_constr_pptac env sigma c)) (make_constr_printer Printer.pr_econstr_n_env) ; Genprint.register_print0 wit_uconstr - (lift Ppconstr.pr_constr_expr) - (lift (fun (c,_) -> pr_glob_constr_pptac c)) + (lift_env Ppconstr.pr_constr_expr) + (lift_env (fun env sigma (c,_) -> pr_glob_constr_pptac env sigma c)) (make_constr_printer Printer.pr_closed_glob_n_env) ; Genprint.register_print0 wit_open_constr - (lift Ppconstr.pr_constr_expr) - (lift (fun (c, _) -> pr_glob_constr_pptac c)) + (lift_env Ppconstr.pr_constr_expr) + (lift_env (fun env sigma (c, _) -> pr_glob_constr_pptac env sigma c)) (make_constr_printer Printer.pr_econstr_n_env) ; Genprint.register_print0 wit_red_expr - (lift (pr_red_expr (pr_constr_expr, pr_lconstr_expr, pr_or_by_notation pr_qualid, pr_constr_pattern_expr))) - (lift (pr_red_expr (pr_and_constr_expr pr_glob_constr_pptac, pr_and_constr_expr pr_lglob_constr_pptac, pr_or_var (pr_and_short_name pr_evaluable_reference), pr_pat_and_constr_expr pr_glob_constr_pptac))) + (lift_env (fun env sigma -> pr_red_expr env sigma (pr_constr_expr, pr_lconstr_expr, pr_or_by_notation pr_qualid, pr_constr_pattern_expr))) + (lift_env (fun env sigma -> pr_red_expr env sigma + ((fun env sigma -> pr_and_constr_expr @@ pr_glob_constr_pptac env sigma), + (fun env sigma -> pr_and_constr_expr @@ pr_lglob_constr_pptac env sigma), + pr_or_var (pr_and_short_name pr_evaluable_reference), + (fun env sigma -> pr_pat_and_constr_expr @@ pr_glob_constr_pptac env sigma)))) pr_red_expr_env ; register_basic_print0 wit_quant_hyp pr_quantified_hypothesis pr_quantified_hypothesis pr_quantified_hypothesis; register_print0 wit_bindings - (lift (Miscprint.pr_bindings_no_with pr_constr_expr pr_lconstr_expr)) - (lift (Miscprint.pr_bindings_no_with (pr_and_constr_expr pr_glob_constr_pptac) (pr_and_constr_expr pr_lglob_constr_pptac))) + (lift_env (fun env sigma -> Miscprint.pr_bindings_no_with (pr_constr_expr env sigma) + (pr_lconstr_expr env sigma))) + (lift_env (fun env sigma -> Miscprint.pr_bindings_no_with (pr_and_constr_expr @@ pr_glob_constr_pptac env sigma) (pr_and_constr_expr @@ pr_lglob_constr_pptac env sigma))) pr_bindings_env ; register_print0 wit_constr_with_bindings - (lift (pr_with_bindings pr_constr_expr pr_lconstr_expr)) - (lift (pr_with_bindings (pr_and_constr_expr pr_glob_constr_pptac) (pr_and_constr_expr pr_lglob_constr_pptac))) + (lift_env (fun env sigma -> pr_with_bindings (pr_constr_expr env sigma) (pr_lconstr_expr env sigma))) + (lift_env (fun env sigma -> pr_with_bindings (pr_and_constr_expr @@ pr_glob_constr_pptac env sigma) + (pr_and_constr_expr @@ pr_lglob_constr_pptac env sigma))) pr_with_bindings_env ; register_print0 wit_open_constr_with_bindings - (lift (pr_with_bindings pr_constr_expr pr_lconstr_expr)) - (lift (pr_with_bindings (pr_and_constr_expr pr_glob_constr_pptac) (pr_and_constr_expr pr_lglob_constr_pptac))) + (lift_env (fun env sigma -> pr_with_bindings (pr_constr_expr env sigma) (pr_lconstr_expr env sigma))) + (lift_env (fun env sigma -> pr_with_bindings (pr_and_constr_expr @@ pr_glob_constr_pptac env sigma) + (pr_and_constr_expr @@ pr_lglob_constr_pptac env sigma))) pr_with_bindings_env ; register_print0 Tacarg.wit_destruction_arg - (lift (pr_destruction_arg pr_constr_expr pr_lconstr_expr)) - (lift (pr_destruction_arg (pr_and_constr_expr pr_glob_constr_pptac) (pr_and_constr_expr pr_lglob_constr_pptac))) + (lift_env (fun env sigma -> pr_destruction_arg (pr_constr_expr env sigma) (pr_lconstr_expr env sigma))) + (lift_env (fun env sigma -> pr_destruction_arg (pr_and_constr_expr @@ pr_glob_constr_pptac env sigma) + (pr_and_constr_expr @@ pr_lglob_constr_pptac env sigma))) pr_destruction_arg_env ; register_basic_print0 Stdarg.wit_int int int int; @@ -1379,12 +1394,12 @@ let () = register_basic_print0 Stdarg.wit_string qstring qstring qstring let () = - let printer _ _ prtac = prtac in + let printer env sigma _ _ prtac = prtac env sigma in declare_extra_genarg_pprule_with_level wit_tactic printer printer printer ltop (0,E) let () = - let pr_unit _ _ _ _ () = str "()" in - let printer _ _ prtac = prtac in + let pr_unit _env _sigma _ _ _ _ () = str "()" in + let printer env sigma _ _ prtac = prtac env sigma in declare_extra_genarg_pprule_with_level wit_ltac printer printer pr_unit ltop (0,E) diff --git a/plugins/ltac/pptactic.mli b/plugins/ltac/pptactic.mli index bc47036d92..70af09833d 100644 --- a/plugins/ltac/pptactic.mli +++ b/plugins/ltac/pptactic.mli @@ -26,40 +26,46 @@ type 'a grammar_tactic_prod_item_expr = | TacNonTerm of ('a * Names.Id.t option) Loc.located type 'a raw_extra_genarg_printer = - (constr_expr -> Pp.t) -> - (constr_expr -> Pp.t) -> - (tolerability -> raw_tactic_expr -> Pp.t) -> - 'a -> Pp.t + Environ.env -> Evd.evar_map -> + (Environ.env -> Evd.evar_map -> constr_expr -> Pp.t) -> + (Environ.env -> Evd.evar_map -> constr_expr -> Pp.t) -> + (Environ.env -> Evd.evar_map -> tolerability -> raw_tactic_expr -> Pp.t) -> + 'a -> Pp.t type 'a glob_extra_genarg_printer = - (glob_constr_and_expr -> Pp.t) -> - (glob_constr_and_expr -> Pp.t) -> - (tolerability -> glob_tactic_expr -> Pp.t) -> - 'a -> Pp.t + Environ.env -> Evd.evar_map -> + (Environ.env -> Evd.evar_map -> glob_constr_and_expr -> Pp.t) -> + (Environ.env -> Evd.evar_map -> glob_constr_and_expr -> Pp.t) -> + (Environ.env -> Evd.evar_map -> tolerability -> glob_tactic_expr -> Pp.t) -> + 'a -> Pp.t type 'a extra_genarg_printer = - (EConstr.t -> Pp.t) -> - (EConstr.t -> Pp.t) -> - (tolerability -> Val.t -> Pp.t) -> - 'a -> Pp.t + Environ.env -> Evd.evar_map -> + (Environ.env -> Evd.evar_map -> EConstr.constr -> Pp.t) -> + (Environ.env -> Evd.evar_map -> EConstr.constr -> Pp.t) -> + (Environ.env -> Evd.evar_map -> tolerability -> Val.t -> Pp.t) -> + 'a -> Pp.t type 'a raw_extra_genarg_printer_with_level = - (constr_expr -> Pp.t) -> - (constr_expr -> Pp.t) -> - (tolerability -> raw_tactic_expr -> Pp.t) -> - tolerability -> 'a -> Pp.t + Environ.env -> Evd.evar_map -> + (Environ.env -> Evd.evar_map -> constr_expr -> Pp.t) -> + (Environ.env -> Evd.evar_map -> constr_expr -> Pp.t) -> + (Environ.env -> Evd.evar_map -> tolerability -> raw_tactic_expr -> Pp.t) -> + tolerability -> 'a -> Pp.t type 'a glob_extra_genarg_printer_with_level = - (glob_constr_and_expr -> Pp.t) -> - (glob_constr_and_expr -> Pp.t) -> - (tolerability -> glob_tactic_expr -> Pp.t) -> - tolerability -> 'a -> Pp.t + Environ.env -> Evd.evar_map -> + (Environ.env -> Evd.evar_map -> glob_constr_and_expr -> Pp.t) -> + (Environ.env -> Evd.evar_map -> glob_constr_and_expr -> Pp.t) -> + (Environ.env -> Evd.evar_map -> tolerability -> glob_tactic_expr -> Pp.t) -> + tolerability -> 'a -> Pp.t type 'a extra_genarg_printer_with_level = - (EConstr.constr -> Pp.t) -> - (EConstr.constr -> Pp.t) -> - (tolerability -> Val.t -> Pp.t) -> - tolerability -> 'a -> Pp.t + Environ.env -> Evd.evar_map -> + (Environ.env -> Evd.evar_map -> EConstr.constr -> Pp.t) -> + (Environ.env -> Evd.evar_map -> EConstr.constr -> Pp.t) -> + (Environ.env -> Evd.evar_map -> tolerability -> Val.t -> Pp.t) -> + tolerability -> 'a -> Pp.t val declare_extra_genarg_pprule : ('a, 'b, 'c) genarg_type -> @@ -91,12 +97,13 @@ val declare_notation_tactic_pprule : KerName.t -> pp_tactic -> unit val pr_with_occurrences : ('a -> Pp.t) -> 'a Locus.with_occurrences -> Pp.t -val pr_red_expr : - ('a -> Pp.t) * ('a -> Pp.t) * ('b -> Pp.t) * ('c -> Pp.t) -> +val pr_red_expr : env -> Evd.evar_map -> + (env -> Evd.evar_map -> 'a -> Pp.t) * (env -> Evd.evar_map -> 'a -> Pp.t) * ('b -> Pp.t) * (env -> Evd.evar_map -> 'c -> Pp.t) -> ('a,'b,'c) Genredexpr.red_expr_gen -> Pp.t val pr_may_eval : - ('a -> Pp.t) -> ('a -> Pp.t) -> ('b -> Pp.t) -> - ('c -> Pp.t) -> ('a,'b,'c) Genredexpr.may_eval -> Pp.t + env -> Evd.evar_map -> + (env -> Evd.evar_map -> 'a -> Pp.t) -> (env -> Evd.evar_map -> 'a -> Pp.t) -> ('b -> Pp.t) -> + (env -> Evd.evar_map -> 'c -> Pp.t) -> ('a,'b,'c) Genredexpr.may_eval -> Pp.t val pr_and_short_name : ('a -> Pp.t) -> 'a Genredexpr.and_short_name -> Pp.t @@ -111,14 +118,14 @@ val pr_clauses : (* default: *) bool option -> ('a -> Pp.t) -> 'a Locus.clause_expr -> Pp.t (* Some true = default is concl; Some false = default is all; None = no default *) -val pr_raw_generic : env -> rlevel generic_argument -> Pp.t +val pr_raw_generic : env -> Evd.evar_map -> rlevel generic_argument -> Pp.t -val pr_glb_generic : env -> glevel generic_argument -> Pp.t +val pr_glb_generic : env -> Evd.evar_map -> glevel generic_argument -> Pp.t -val pr_raw_extend: env -> int -> +val pr_raw_extend: env -> Evd.evar_map -> int -> ml_tactic_entry -> raw_tactic_arg list -> Pp.t -val pr_glob_extend: env -> int -> +val pr_glob_extend: env -> Evd.evar_map -> int -> ml_tactic_entry -> glob_tactic_arg list -> Pp.t val pr_extend : @@ -131,9 +138,9 @@ val pr_alias : (Val.t -> Pp.t) -> val pr_ltac_constant : ltac_constant -> Pp.t -val pr_raw_tactic : raw_tactic_expr -> Pp.t +val pr_raw_tactic : env -> Evd.evar_map -> raw_tactic_expr -> Pp.t -val pr_raw_tactic_level : tolerability -> raw_tactic_expr -> Pp.t +val pr_raw_tactic_level : env -> Evd.evar_map -> tolerability -> raw_tactic_expr -> Pp.t val pr_glob_tactic : env -> glob_tactic_expr -> Pp.t diff --git a/plugins/ltac/rewrite.ml b/plugins/ltac/rewrite.ml index e78d0f93a4..b1d5c0252f 100644 --- a/plugins/ltac/rewrite.ml +++ b/plugins/ltac/rewrite.ml @@ -15,6 +15,7 @@ open Names open Nameops open Namegen open Constr +open Context open EConstr open Vars open Reduction @@ -220,23 +221,23 @@ end) = struct let rec aux env evars ty l = let t = Reductionops.whd_all env (goalevars evars) ty in match EConstr.kind (goalevars evars) t, l with - | Prod (na, ty, b), obj :: cstrs -> + | Prod (na, ty, b), obj :: cstrs -> let b = Reductionops.nf_betaiota env (goalevars evars) b in - if noccurn (goalevars evars) 1 b (* non-dependent product *) then + if noccurn (goalevars evars) 1 b (* non-dependent product *) then let ty = Reductionops.nf_betaiota env (goalevars evars) ty in let (evars, b', arg, cstrs) = aux env evars (subst1 mkProp b) cstrs in let evars, relty = mk_relty evars env ty obj in let evars, newarg = app_poly env evars respectful [| ty ; b' ; relty ; arg |] in - evars, mkProd(na, ty, b), newarg, (ty, Some relty) :: cstrs + evars, mkProd(na, ty, b), newarg, (ty, Some relty) :: cstrs else let (evars, b, arg, cstrs) = - aux (push_rel (LocalAssum (na, ty)) env) evars b cstrs + aux (push_rel (LocalAssum (na, ty)) env) evars b cstrs in let ty = Reductionops.nf_betaiota env (goalevars evars) ty in - let pred = mkLambda (na, ty, b) in - let liftarg = mkLambda (na, ty, arg) in - let evars, arg' = app_poly env evars forall_relation [| ty ; pred ; liftarg |] in - if Option.is_empty obj then evars, mkProd(na, ty, b), arg', (ty, None) :: cstrs + let pred = mkLambda (na, ty, b) in + let liftarg = mkLambda (na, ty, arg) in + let evars, arg' = app_poly env evars forall_relation [| ty ; pred ; liftarg |] in + if Option.is_empty obj then evars, mkProd(na, ty, b), arg', (ty, None) :: cstrs else user_err Pp.(str "build_signature: no constraint can apply on a dependent argument") | _, obj :: _ -> anomaly ~label:"build_signature" (Pp.str "not enough products.") | _, [] -> @@ -253,7 +254,7 @@ end) = struct let unfold_impl sigma t = match EConstr.kind sigma t with | App (arrow, [| a; b |])(* when eq_constr arrow (Lazy.force impl) *) -> - mkProd (Anonymous, a, lift 1 b) + mkProd (make_annot Anonymous Sorts.Relevant, a, lift 1 b) | _ -> assert false let unfold_all sigma t = @@ -279,7 +280,7 @@ end) = struct (app_poly env evd arrow [| a; b |]), unfold_impl (* (evd, mkProd (Anonymous, a, b)), (fun x -> x) *) else if bp then (* Dummy forall *) - (app_poly env evd coq_all [| a; mkLambda (Anonymous, a, lift 1 b) |]), unfold_forall + (app_poly env evd coq_all [| a; mkLambda (make_annot Anonymous Sorts.Relevant, a, lift 1 b) |]), unfold_forall else (* None in Prop, use arrow *) (app_poly env evd arrow [| a; b |]), unfold_impl @@ -308,7 +309,8 @@ end) = struct app_poly env evd pointwise_relation [| t; lift (-1) car; lift (-1) rel |] else app_poly env evd forall_relation - [| t; mkLambda (n, t, car); mkLambda (n, t, rel) |] + [| t; mkLambda (make_annot n Sorts.Relevant, t, car); + mkLambda (make_annot n Sorts.Relevant, t, rel) |] let lift_cstr env evars (args : constr list) c ty cstr = let start evars env car = @@ -323,15 +325,15 @@ end) = struct else let sigma = goalevars evars in match EConstr.kind sigma (Reductionops.whd_all env sigma prod) with - | Prod (na, ty, b) -> + | Prod (na, ty, b) -> if noccurn sigma 1 b then let b' = lift (-1) b in let evars, rb = aux evars env b' (pred n) in app_poly env evars pointwise_relation [| ty; b'; rb |] else - let evars, rb = aux evars (push_rel (LocalAssum (na, ty)) env) b (pred n) in + let evars, rb = aux evars (push_rel (LocalAssum (na, ty)) env) b (pred n) in app_poly env evars forall_relation - [| ty; mkLambda (na, ty, b); mkLambda (na, ty, rb) |] + [| ty; mkLambda (na, ty, b); mkLambda (na, ty, rb) |] | _ -> raise Not_found in let rec find env c ty = function @@ -481,8 +483,9 @@ let rec decompose_app_rel env evd t = | App (f, [|arg|]) -> let (f', argl, argr) = decompose_app_rel env evd arg in let ty = Typing.unsafe_type_of env evd argl in - let f'' = mkLambda (Name default_dependent_ident, ty, - mkLambda (Name (Id.of_string "y"), lift 1 ty, + let r = Retyping.relevance_of_type env evd ty in + let f'' = mkLambda (make_annot (Name default_dependent_ident) r, ty, + mkLambda (make_annot (Name (Id.of_string "y")) r, lift 1 ty, mkApp (lift 2 f, [| mkApp (lift 2 f', [| mkRel 2; mkRel 1 |]) |]))) in (f'', argl, argr) | App (f, args) -> @@ -522,7 +525,7 @@ let decompose_applied_relation env sigma (c,l) = | Some c -> c | None -> let ctx,t' = Reductionops.splay_prod env sigma ctype in (* Search for underlying eq *) - match find_rel (it_mkProd_or_LetIn t' (List.map (fun (n,t) -> LocalAssum (n, t)) ctx)) with + match find_rel (it_mkProd_or_LetIn t' (List.map (fun (n,t) -> LocalAssum (n, t)) ctx)) with | Some c -> c | None -> user_err Pp.(str "Cannot find an homogeneous relation to rewrite.") @@ -803,7 +806,7 @@ let resolve_morphism env avoid oldt m ?(fnewt=fun x -> x) args args' (b,cstr) ev else TypeGlobal.do_subrelation, TypeGlobal.apply_subrelation in EConstr.push_named - (LocalDef (Id.of_string "do_subrelation", + (LocalDef (make_annot (Id.of_string "do_subrelation") Sorts.Relevant, snd (app_poly_sort b env evars dosub [||]), snd (app_poly_nocheck env evars appsub [||]))) env @@ -906,7 +909,7 @@ let make_leibniz_proof env c ty r = let prf = e_app_poly env evars coq_f_equal [| r.rew_car; ty; - mkLambda (Anonymous, r.rew_car, c); + mkLambda (make_annot Anonymous Sorts.Relevant, r.rew_car, c); r.rew_from; r.rew_to; prf |] in RewPrf (rel, prf) | RewCast k -> r.rew_prf @@ -1103,7 +1106,7 @@ let subterm all flags (s : 'a pure_strategy) : 'a pure_strategy = (* else *) | Prod (n, dom, codom) -> - let lam = mkLambda (n, dom, codom) in + let lam = mkLambda (n, dom, codom) in let (evars', app), unfold = if eq_constr (fst evars) ty mkProp then (app_poly_sort prop env evars coq_all [| dom; lam |]), TypeGlobal.unfold_all @@ -1149,9 +1152,9 @@ let subterm all flags (s : 'a pure_strategy) : 'a pure_strategy = (* | _ -> b') *) | Lambda (n, t, b) when flags.under_lambdas -> - let n' = Nameops.Name.map (fun id -> Tactics.fresh_id_in_env unfresh id env) n in + let n' = map_annot (Nameops.Name.map (fun id -> Tactics.fresh_id_in_env unfresh id env)) n in let open Context.Rel.Declaration in - let env' = EConstr.push_rel (LocalAssum (n', t)) env in + let env' = EConstr.push_rel (LocalAssum (n', t)) env in let bty = Retyping.get_type_of env' (goalevars evars) b in let unlift = if prop then PropGlobal.unlift_cstr else TypeGlobal.unlift_cstr in let state, b' = s.strategy { state ; env = env' ; unfresh ; @@ -1166,15 +1169,15 @@ let subterm all flags (s : 'a pure_strategy) : 'a pure_strategy = let point = if prop then PropGlobal.pointwise_or_dep_relation else TypeGlobal.pointwise_or_dep_relation in - let evars, rel = point env r.rew_evars n' t r.rew_car rel in - let prf = mkLambda (n', t, prf) in + let evars, rel = point env r.rew_evars n'.binder_name t r.rew_car rel in + let prf = mkLambda (n', t, prf) in { r with rew_prf = RewPrf (rel, prf); rew_evars = evars } | x -> r in Success { r with - rew_car = mkProd (n, t, r.rew_car); - rew_from = mkLambda(n, t, r.rew_from); - rew_to = mkLambda (n, t, r.rew_to) } + rew_car = mkProd (n, t, r.rew_car); + rew_from = mkLambda(n, t, r.rew_from); + rew_to = mkLambda (n, t, r.rew_to) } | Fail | Identity -> b' in state, res @@ -1516,7 +1519,7 @@ let cl_rewrite_clause_aux ?(abs=None) strat env avoid sigma concl is_hyp : resul | Some (t, ty) -> let t = Reductionops.nf_evar evars' t in let ty = Reductionops.nf_evar evars' ty in - mkApp (mkLambda (Name (Id.of_string "lemma"), ty, p), [| t |]) + mkApp (mkLambda (make_annot (Name (Id.of_string "lemma")) Sorts.Relevant, ty, p), [| t |]) in let proof = match is_hyp with | None -> term @@ -1542,7 +1545,8 @@ let assert_replacing id newt tac = let after, before = List.split_when (NamedDecl.get_id %> Id.equal id) ctx in let nc = match before with | [] -> assert false - | d :: rem -> insert_dependent env sigma (LocalAssum (NamedDecl.get_id d, newt)) [] after @ rem + | d :: rem -> insert_dependent env sigma + (LocalAssum (make_annot (NamedDecl.get_id d) Sorts.Relevant, newt)) [] after @ rem in let env' = Environ.reset_with_named_context (val_of_named_context nc) env in Refine.refine ~typecheck:true begin fun sigma -> @@ -1586,7 +1590,7 @@ let cl_rewrite_clause_newtac ?abs ?origsigma ~progress strat clause = tclTHENFIRST (assert_replacing id newt tac) (beta_hyp id) | Some id, None -> Proofview.Unsafe.tclEVARS undef <*> - convert_hyp_no_check (LocalAssum (id, newt)) <*> + convert_hyp_no_check (LocalAssum (make_annot id Sorts.Relevant, newt)) <*> beta_hyp id | None, Some p -> Proofview.Unsafe.tclEVARS undef <*> @@ -1905,7 +1909,7 @@ let build_morphism_signature env sigma m = let cstrs = let rec aux t = match EConstr.kind sigma t with - | Prod (na, a, b) -> + | Prod (na, a, b) -> None :: aux b | _ -> [] in aux t diff --git a/plugins/ltac/taccoerce.ml b/plugins/ltac/taccoerce.ml index 026c00b849..fcab98c7e8 100644 --- a/plugins/ltac/taccoerce.ml +++ b/plugins/ltac/taccoerce.ml @@ -199,7 +199,8 @@ let id_of_name = function basename | Sort s -> begin - match ESorts.kind sigma s with + match ESorts.kind sigma s with + | Sorts.SProp -> Label.to_id (Label.make "SProp") | Sorts.Prop -> Label.to_id (Label.make "Prop") | Sorts.Set -> Label.to_id (Label.make "Set") | Sorts.Type _ -> Label.to_id (Label.make "Type") diff --git a/plugins/ltac/tactic_debug.ml b/plugins/ltac/tactic_debug.ml index 99b9e881f6..52a83a038f 100644 --- a/plugins/ltac/tactic_debug.ml +++ b/plugins/ltac/tactic_debug.ml @@ -19,11 +19,9 @@ let prtac x = Pptactic.pr_glob_tactic (Global.env()) x let prmatchpatt env sigma hyp = Pptactic.pr_match_pattern (Printer.pr_constr_pattern_env env sigma) hyp -let prmatchrl rl = +let prmatchrl env sigma rl = Pptactic.pr_match_rule false (Pptactic.pr_glob_tactic (Global.env())) - (fun (_,p) -> - let sigma, env = Pfedit.get_current_context () in - Printer.pr_constr_pattern_env env sigma p) rl + (fun (_,p) -> Printer.pr_constr_pattern_env env sigma p) rl (* This module intends to be a beginning of debugger for tactic expressions. Currently, it is quite simple and we can hope to have, in the future, a more @@ -246,13 +244,13 @@ let db_constr debug env sigma c = else return () (* Prints the pattern rule *) -let db_pattern_rule debug num r = +let db_pattern_rule debug env sigma num r = let open Proofview.NonLogical in is_debug debug >>= fun db -> if db then begin msg_tac_debug (str "Pattern rule " ++ int num ++ str ":" ++ fnl () ++ - str "|" ++ spc () ++ prmatchrl r) + str "|" ++ spc () ++ prmatchrl env sigma r) end else return () diff --git a/plugins/ltac/tactic_debug.mli b/plugins/ltac/tactic_debug.mli index 91e8510b92..74ea4e6b74 100644 --- a/plugins/ltac/tactic_debug.mli +++ b/plugins/ltac/tactic_debug.mli @@ -40,7 +40,7 @@ val db_constr : debug_info -> env -> evar_map -> constr -> unit Proofview.NonLog (** Prints the pattern rule *) val db_pattern_rule : - debug_info -> int -> (Genintern.glob_constr_and_expr * constr_pattern,glob_tactic_expr) match_rule -> unit Proofview.NonLogical.t + debug_info -> env -> evar_map -> int -> (Genintern.glob_constr_and_expr * constr_pattern,glob_tactic_expr) match_rule -> unit Proofview.NonLogical.t (** Prints a matched hypothesis *) val db_matched_hyp : diff --git a/plugins/ltac/tactic_matching.ml b/plugins/ltac/tactic_matching.ml index 54924f1644..2b5e496168 100644 --- a/plugins/ltac/tactic_matching.ml +++ b/plugins/ltac/tactic_matching.ml @@ -12,6 +12,7 @@ (lazy)match and (lazy)match goal. *) open Names +open Context open Tacexpr open Context.Named.Declaration @@ -299,8 +300,8 @@ module PatternMatching (E:StaticEnvironment) = struct | LocalDef (id,body,hyp) -> pattern_match_term false bodypat body () <*> pattern_match_term true typepat hyp () <*> - put_terms (id_map_try_add_name hypname (EConstr.mkVar id) empty_term_subst) <*> - return id + put_terms (id_map_try_add_name hypname (EConstr.mkVar id.binder_name) empty_term_subst) <*> + return id.binder_name | LocalAssum (id,hyp) -> fail (** [hyp_match pat hyps] dispatches to diff --git a/plugins/ltac/tauto.ml b/plugins/ltac/tauto.ml index 19256e054d..4c65445b89 100644 --- a/plugins/ltac/tauto.ml +++ b/plugins/ltac/tauto.ml @@ -142,7 +142,7 @@ let flatten_contravariant_conj _ ist = ~onlybinary:flags.binary_mode typ with | Some (_,args) -> - let newtyp = List.fold_right mkArrow args c in + let newtyp = List.fold_right (fun a b -> mkArrow a Sorts.Relevant b) args c in let intros = tclMAP (fun _ -> intro) args in let by = tclTHENLIST [intros; apply hyp; split; assumption] in tclTHENLIST [assert_ ~by newtyp; clear (destVar sigma hyp)] @@ -173,7 +173,7 @@ let flatten_contravariant_disj _ ist = typ with | Some (_,args) -> let map i arg = - let typ = mkArrow arg c in + let typ = mkArrow arg Sorts.Relevant c in let ci = Tactics.constructor_tac false None (succ i) Tactypes.NoBindings in let by = tclTHENLIST [intro; apply hyp; ci; assumption] in assert_ ~by typ diff --git a/plugins/micromega/coq_micromega.ml b/plugins/micromega/coq_micromega.ml index 7adae148bd..7db47e13a5 100644 --- a/plugins/micromega/coq_micromega.ml +++ b/plugins/micromega/coq_micromega.ml @@ -23,6 +23,7 @@ open Names open Goptions open Mutils open Constr +open Context open Tactypes (** @@ -876,11 +877,9 @@ struct * This is the big generic function for expression parsers. *) - let parse_expr sigma parse_constant parse_exp ops_spec env term = + let parse_expr cenv sigma parse_constant parse_exp ops_spec env term = if debug - then ( - let _, env = Pfedit.get_current_context () in - Feedback.msg_debug (Pp.str "parse_expr: " ++ Printer.pr_leconstr_env env sigma term)); + then Feedback.msg_debug (Pp.str "parse_expr: " ++ Printer.pr_leconstr_env cenv sigma term); (* let constant_or_variable env term = @@ -999,8 +998,7 @@ struct | _ -> raise ParseError - let rconstant sigma term = - let _, env = Pfedit.get_current_context () in + let rconstant env sigma term = if debug then Feedback.msg_debug (Pp.str "rconstant: " ++ Printer.pr_leconstr_env env sigma term ++ fnl ()); let res = rconstant sigma term in @@ -1009,7 +1007,7 @@ struct res - let parse_zexpr sigma = parse_expr sigma + let parse_zexpr env sigma = parse_expr env sigma (zconstant sigma) (fun expr x -> let exp = (parse_z sigma x) in @@ -1018,7 +1016,7 @@ struct | _ -> Mc.PEpow(expr, Mc.Z.to_N exp)) zop_spec - let parse_qexpr sigma = parse_expr sigma + let parse_qexpr env sigma = parse_expr env sigma (qconstant sigma) (fun expr x -> let exp = parse_z sigma x in @@ -1033,8 +1031,8 @@ struct Mc.PEpow(expr,exp)) qop_spec - let parse_rexpr sigma = parse_expr sigma - (rconstant sigma) + let parse_rexpr env sigma = parse_expr env sigma + (rconstant env sigma) (fun expr x -> let exp = Mc.N.of_nat (parse_nat sigma x) in Mc.PEpow(expr,exp)) @@ -1047,8 +1045,8 @@ struct match EConstr.kind sigma cstr with | App(op,args) -> let (op,lhs,rhs) = parse_op gl (op,args) in - let (e1,env) = parse_expr sigma env lhs in - let (e2,env) = parse_expr sigma env rhs in + let (e1,env) = parse_expr gl.env sigma env lhs in + let (e2,env) = parse_expr gl.env sigma env rhs in ({Mc.flhs = e1; Mc.fop = op;Mc.frhs = e2},env) | _ -> failwith "error : parse_arith(2)" @@ -1243,7 +1241,7 @@ let dump_rexpr = lazy let prodn n env b = let rec prodrec = function | (0, env, b) -> b - | (n, ((v,t)::l), b) -> prodrec (n-1, l, EConstr.mkProd (v,t,b)) + | (n, ((v,t)::l), b) -> prodrec (n-1, l, EConstr.mkProd (make_annot v Sorts.Relevant,t,b)) | _ -> assert false in prodrec (n,env,b) @@ -1293,8 +1291,8 @@ let make_goal_of_formula sigma dexpr form = | FF -> Lazy.force coq_False | C(x,y) -> EConstr.mkApp(Lazy.force coq_and,[|xdump pi xi x ; xdump pi xi y|]) | D(x,y) -> EConstr.mkApp(Lazy.force coq_or,[| xdump pi xi x ; xdump pi xi y|]) - | I(x,_,y) -> EConstr.mkArrow (xdump pi xi x) (xdump (pi+1) (xi+1) y) - | N(x) -> EConstr.mkArrow (xdump pi xi x) (Lazy.force coq_False) + | I(x,_,y) -> EConstr.mkArrow (xdump pi xi x) Sorts.Relevant (xdump (pi+1) (xi+1) y) + | N(x) -> EConstr.mkArrow (xdump pi xi x) Sorts.Relevant (Lazy.force coq_False) | A(x,_,_) -> dump_cstr xi x | X(t) -> let idx = Env.get_rank props sigma t in EConstr.mkRel (pi+idx) in @@ -1327,7 +1325,7 @@ let make_goal_of_formula sigma dexpr form = | (e::l) -> let (name,expr,typ) = e in xset (EConstr.mkNamedLetIn - (Names.Id.of_string name) + (make_annot (Names.Id.of_string name) Sorts.Relevant) expr typ acc) l in xset concl l @@ -1614,7 +1612,7 @@ let abstract_formula hyps f = | I(f1,hyp,f2) -> (match xabs f1 , hyp, xabs f2 with | X a1 , Some _ , af2 -> af2 - | X a1 , None , X a2 -> X (EConstr.mkArrow a1 a2) + | X a1 , None , X a2 -> X (EConstr.mkArrow a1 Sorts.Relevant a2) | af1 , _ , af2 -> I(af1,hyp,af2) ) | FF -> FF diff --git a/plugins/micromega/micromega_plugin.mlpack b/plugins/micromega/micromega_plugin.mlpack index 2baf6608a4..e3aa0dab7d 100644 --- a/plugins/micromega/micromega_plugin.mlpack +++ b/plugins/micromega/micromega_plugin.mlpack @@ -1,8 +1,8 @@ +Micromega Mutils Itv Vect Sos_types -Micromega Polynomial Mfourier Simplex diff --git a/plugins/omega/coq_omega.ml b/plugins/omega/coq_omega.ml index dff25b3a42..4802608fda 100644 --- a/plugins/omega/coq_omega.ml +++ b/plugins/omega/coq_omega.ml @@ -19,6 +19,7 @@ open CErrors open Util open Names open Constr +open Context open Nameops open EConstr open Tacticals.New @@ -431,8 +432,8 @@ let destructurate_prop sigma t = | Ind (isp,_), args -> Kapp (Other (string_of_path (path_of_global (IndRef isp))),args) | Var id,[] -> Kvar id - | Prod (Anonymous,typ,body), [] -> Kimp(typ,body) - | Prod (Name _,_,_),[] -> CErrors.user_err Pp.(str "Omega: Not a quantifier-free goal") + | Prod ({binder_name=Anonymous},typ,body), [] -> Kimp(typ,body) + | Prod ({binder_name=Name _},_,_),[] -> CErrors.user_err Pp.(str "Omega: Not a quantifier-free goal") | _ -> Kufo let nf = Tacred.simpl @@ -499,13 +500,13 @@ let context sigma operation path (t : constr) = | (p, Fix ((_,n as ln),(tys,lna,v))) -> let l = Array.length v in let v' = Array.copy v in - v'.(n)<- loop (Pervasives.(+) i l) p v.(n); (mkFix (ln,(tys,lna,v'))) + v'.(n)<- loop (Pervasives.(+) i l) p v.(n); (mkFix (ln,(tys,lna,v'))) | ((P_TYPE :: p), Prod (n,t,c)) -> - (mkProd (n,loop i p t,c)) + (mkProd (n,loop i p t,c)) | ((P_TYPE :: p), Lambda (n,t,c)) -> - (mkLambda (n,loop i p t,c)) + (mkLambda (n,loop i p t,c)) | ((P_TYPE :: p), LetIn (n,b,t,c)) -> - (mkLetIn (n,b,loop i p t,c)) + (mkLetIn (n,b,loop i p t,c)) | (p, _) -> failwith ("abstract_path " ^ string_of_int(List.length p)) in @@ -528,7 +529,7 @@ let occurrence sigma path (t : constr) = let abstract_path sigma typ path t = let term_occur = ref (mkRel 0) in let abstract = context sigma (fun i t -> term_occur:= t; mkRel i) path t in - mkLambda (Name (Id.of_string "x"), typ, abstract), !term_occur + mkLambda (make_annot (Name (Id.of_string "x")) Sorts.Relevant, typ, abstract), !term_occur let focused_simpl path = let open Tacmach.New in @@ -604,10 +605,10 @@ let clever_rewrite_base_poly typ p result theorem = let t = applist (mkLambda - (Name (Id.of_string "P"), - mkArrow typ mkProp, + (make_annot (Name (Id.of_string "P")) Sorts.Relevant, + mkArrow typ Sorts.Relevant mkProp, mkLambda - (Name (Id.of_string "H"), + (make_annot (Name (Id.of_string "H")) Sorts.Relevant, applist (mkRel 1,[result]), mkApp (Lazy.force coq_eq_ind_r, [| typ; result; mkRel 2; mkRel 1; occ; theorem |]))), @@ -1264,7 +1265,7 @@ let replay_history tactic_normalisation = mkApp (Lazy.force coq_ex, [| Lazy.force coq_Z; mkLambda - (Name vid, + (make_annot (Name vid) Sorts.Relevant, Lazy.force coq_Z, mk_eq (mkRel 1) eq1) |]) in @@ -1725,11 +1726,11 @@ let destructure_hyps = try match destructurate_type env sigma typ with | Kapp(Nat,_) | Kapp(Z,_) -> - let hid = fresh_id Id.Set.empty (add_suffix i "_eqn") gl in - let hty = mk_gen_eq typ (mkVar i) body in + let hid = fresh_id Id.Set.empty (add_suffix i.binder_name "_eqn") gl in + let hty = mk_gen_eq typ (mkVar i.binder_name) body in tclTHEN (assert_by (Name hid) hty reflexivity) - (loop (LocalAssum (hid, hty) :: lit)) + (loop (LocalAssum (make_annot hid Sorts.Relevant, hty) :: lit)) | _ -> loop lit with e when catchable_exception e -> loop lit end @@ -1742,18 +1743,20 @@ let destructure_hyps = | Kapp(Or,[t1;t2]) -> (tclTHENS (elim_id i) - [ onClearedName i (fun i -> (loop (LocalAssum (i,t1)::lit))); - onClearedName i (fun i -> (loop (LocalAssum (i,t2)::lit))) ]) + [ onClearedName i (fun i -> (loop (LocalAssum (make_annot i Sorts.Relevant,t1)::lit))); + onClearedName i (fun i -> (loop (LocalAssum (make_annot i Sorts.Relevant,t2)::lit))) ]) | Kapp(And,[t1;t2]) -> tclTHEN (elim_id i) (onClearedName2 i (fun i1 i2 -> - loop (LocalAssum (i1,t1) :: LocalAssum (i2,t2) :: lit))) + loop (LocalAssum (make_annot i1 Sorts.Relevant,t1) :: + LocalAssum (make_annot i2 Sorts.Relevant,t2) :: lit))) | Kapp(Iff,[t1;t2]) -> tclTHEN (elim_id i) (onClearedName2 i (fun i1 i2 -> - loop (LocalAssum (i1,mkArrow t1 t2) :: LocalAssum (i2,mkArrow t2 t1) :: lit))) + loop (LocalAssum (make_annot i1 Sorts.Relevant,mkArrow t1 Sorts.Relevant t2) :: + LocalAssum (make_annot i2 Sorts.Relevant,mkArrow t2 Sorts.Relevant t1) :: lit))) | Kimp(t1,t2) -> (* t1 and t2 might be in Type rather than Prop. For t1, the decidability check will ensure being Prop. *) @@ -1764,7 +1767,7 @@ let destructure_hyps = (generalize_tac [mkApp (Lazy.force coq_imp_simp, [| t1; t2; d1; mkVar i|])]); (onClearedName i (fun i -> - (loop (LocalAssum (i,mk_or (mk_not t1) t2) :: lit)))) + (loop (LocalAssum (make_annot i Sorts.Relevant,mk_or (mk_not t1) t2) :: lit)))) ] else loop lit @@ -1775,7 +1778,7 @@ let destructure_hyps = (generalize_tac [mkApp (Lazy.force coq_not_or,[| t1; t2; mkVar i |])]); (onClearedName i (fun i -> - (loop (LocalAssum (i,mk_and (mk_not t1) (mk_not t2)) :: lit)))) + (loop (LocalAssum (make_annot i Sorts.Relevant,mk_and (mk_not t1) (mk_not t2)) :: lit)))) ] | Kapp(And,[t1;t2]) -> let d1 = decidability t1 in @@ -1784,7 +1787,7 @@ let destructure_hyps = [mkApp (Lazy.force coq_not_and, [| t1; t2; d1; mkVar i |])]); (onClearedName i (fun i -> - (loop (LocalAssum (i,mk_or (mk_not t1) (mk_not t2)) :: lit)))) + (loop (LocalAssum (make_annot i Sorts.Relevant,mk_or (mk_not t1) (mk_not t2)) :: lit)))) ] | Kapp(Iff,[t1;t2]) -> let d1 = decidability t1 in @@ -1794,7 +1797,7 @@ let destructure_hyps = [mkApp (Lazy.force coq_not_iff, [| t1; t2; d1; d2; mkVar i |])]); (onClearedName i (fun i -> - (loop (LocalAssum (i, mk_or (mk_and t1 (mk_not t2)) + (loop (LocalAssum (make_annot i Sorts.Relevant,mk_or (mk_and t1 (mk_not t2)) (mk_and (mk_not t1) t2)) :: lit)))) ] | Kimp(t1,t2) -> @@ -1806,14 +1809,14 @@ let destructure_hyps = [mkApp (Lazy.force coq_not_imp, [| t1; t2; d1; mkVar i |])]); (onClearedName i (fun i -> - (loop (LocalAssum (i,mk_and t1 (mk_not t2)) :: lit)))) + (loop (LocalAssum (make_annot i Sorts.Relevant,mk_and t1 (mk_not t2)) :: lit)))) ] | Kapp(Not,[t]) -> let d = decidability t in tclTHENLIST [ (generalize_tac [mkApp (Lazy.force coq_not_not, [| t; d; mkVar i |])]); - (onClearedName i (fun i -> (loop (LocalAssum (i,t) :: lit)))) + (onClearedName i (fun i -> (loop (LocalAssum (make_annot i Sorts.Relevant,t) :: lit)))) ] | Kapp(op,[t1;t2]) -> (try diff --git a/plugins/rtauto/refl_tauto.ml b/plugins/rtauto/refl_tauto.ml index a6b6c57ff9..89528fe357 100644 --- a/plugins/rtauto/refl_tauto.ml +++ b/plugins/rtauto/refl_tauto.ml @@ -16,6 +16,7 @@ open CErrors open Util open Term open Constr +open Context open Proof_search open Context.Named.Declaration @@ -127,7 +128,7 @@ let rec make_hyps env sigma atom_env lenv = function | LocalAssum (id,typ)::rest -> let hrec= make_hyps env sigma atom_env (typ::lenv) rest in - if List.exists (fun c -> Termops.local_occur_var Evd.empty (* FIXME *) id c) lenv || + if List.exists (fun c -> Termops.local_occur_var Evd.empty (* FIXME *) id.binder_name c) lenv || (Retyping.get_sort_family_of env sigma typ != InProp) then hrec @@ -291,7 +292,7 @@ let rtauto_tac = build_form formula; build_proof [] 0 prf|]) in let term= - applistc main (List.rev_map (fun (id,_) -> mkVar id) hyps) in + applistc main (List.rev_map (fun (id,_) -> mkVar id.binder_name) hyps) in let build_end_time=System.get_time () in let () = if !verbose then begin diff --git a/plugins/rtauto/refl_tauto.mli b/plugins/rtauto/refl_tauto.mli index 49b5ee5ac7..3de0ba44df 100644 --- a/plugins/rtauto/refl_tauto.mli +++ b/plugins/rtauto/refl_tauto.mli @@ -23,6 +23,6 @@ val make_hyps -> atom_env -> EConstr.types list -> EConstr.named_context - -> (Names.Id.t * Proof_search.form) list + -> (Names.Id.t Context.binder_annot * Proof_search.form) list val rtauto_tac : unit Proofview.tactic diff --git a/plugins/setoid_ring/g_newring.mlg b/plugins/setoid_ring/g_newring.mlg index f59ca4cef4..3ce6478700 100644 --- a/plugins/setoid_ring/g_newring.mlg +++ b/plugins/setoid_ring/g_newring.mlg @@ -38,24 +38,24 @@ END open Pptactic open Ppconstr -let pr_ring_mod = function - | Ring_kind (Computational eq_test) -> str "decidable" ++ pr_arg pr_constr_expr eq_test +let pr_ring_mod env sigma = function + | Ring_kind (Computational eq_test) -> str "decidable" ++ pr_arg (pr_constr_expr env sigma) eq_test | Ring_kind Abstract -> str "abstract" - | Ring_kind (Morphism morph) -> str "morphism" ++ pr_arg pr_constr_expr morph - | Const_tac (CstTac cst_tac) -> str "constants" ++ spc () ++ str "[" ++ pr_raw_tactic cst_tac ++ str "]" + | Ring_kind (Morphism morph) -> str "morphism" ++ pr_arg (pr_constr_expr env sigma) morph + | Const_tac (CstTac cst_tac) -> str "constants" ++ spc () ++ str "[" ++ pr_raw_tactic env sigma cst_tac ++ str "]" | Const_tac (Closed l) -> str "closed" ++ spc () ++ str "[" ++ prlist_with_sep spc pr_qualid l ++ str "]" - | Pre_tac t -> str "preprocess" ++ spc () ++ str "[" ++ pr_raw_tactic t ++ str "]" - | Post_tac t -> str "postprocess" ++ spc () ++ str "[" ++ pr_raw_tactic t ++ str "]" - | Setoid(sth,ext) -> str "setoid" ++ pr_arg pr_constr_expr sth ++ pr_arg pr_constr_expr ext - | Pow_spec(Closed l,spec) -> str "power_tac" ++ pr_arg pr_constr_expr spec ++ spc () ++ str "[" ++ prlist_with_sep spc pr_qualid l ++ str "]" - | Pow_spec(CstTac cst_tac,spec) -> str "power_tac" ++ pr_arg pr_constr_expr spec ++ spc () ++ str "[" ++ pr_raw_tactic cst_tac ++ str "]" - | Sign_spec t -> str "sign" ++ pr_arg pr_constr_expr t - | Div_spec t -> str "div" ++ pr_arg pr_constr_expr t + | Pre_tac t -> str "preprocess" ++ spc () ++ str "[" ++ pr_raw_tactic env sigma t ++ str "]" + | Post_tac t -> str "postprocess" ++ spc () ++ str "[" ++ pr_raw_tactic env sigma t ++ str "]" + | Setoid(sth,ext) -> str "setoid" ++ pr_arg (pr_constr_expr env sigma) sth ++ pr_arg (pr_constr_expr env sigma) ext + | Pow_spec(Closed l,spec) -> str "power_tac" ++ pr_arg (pr_constr_expr env sigma) spec ++ spc () ++ str "[" ++ prlist_with_sep spc pr_qualid l ++ str "]" + | Pow_spec(CstTac cst_tac,spec) -> str "power_tac" ++ pr_arg (pr_constr_expr env sigma) spec ++ spc () ++ str "[" ++ pr_raw_tactic env sigma cst_tac ++ str "]" + | Sign_spec t -> str "sign" ++ pr_arg (pr_constr_expr env sigma) t + | Div_spec t -> str "div" ++ pr_arg (pr_constr_expr env sigma) t } VERNAC ARGUMENT EXTEND ring_mod - PRINTED BY { pr_ring_mod } + PRINTED BY { pr_ring_mod env sigma } | [ "decidable" constr(eq_test) ] -> { Ring_kind(Computational eq_test) } | [ "abstract" ] -> { Ring_kind Abstract } | [ "morphism" constr(morph) ] -> { Ring_kind(Morphism morph) } @@ -74,12 +74,12 @@ END { -let pr_ring_mods l = surround (prlist_with_sep pr_comma pr_ring_mod l) +let pr_ring_mods env sigma l = surround (prlist_with_sep pr_comma (pr_ring_mod env sigma) l) } VERNAC ARGUMENT EXTEND ring_mods - PRINTED BY { pr_ring_mods } + PRINTED BY { pr_ring_mods env sigma } | [ "(" ne_ring_mod_list_sep(mods, ",") ")" ] -> { mods } END @@ -104,26 +104,26 @@ END { -let pr_field_mod = function - | Ring_mod m -> pr_ring_mod m - | Inject inj -> str "completeness" ++ pr_arg pr_constr_expr inj +let pr_field_mod env sigma = function + | Ring_mod m -> pr_ring_mod env sigma m + | Inject inj -> str "completeness" ++ pr_arg (pr_constr_expr env sigma) inj } VERNAC ARGUMENT EXTEND field_mod - PRINTED BY { pr_field_mod } + PRINTED BY { pr_field_mod env sigma } | [ ring_mod(m) ] -> { Ring_mod m } | [ "completeness" constr(inj) ] -> { Inject inj } END { -let pr_field_mods l = surround (prlist_with_sep pr_comma pr_field_mod l) +let pr_field_mods env sigma l = surround (prlist_with_sep pr_comma (pr_field_mod env sigma) l) } VERNAC ARGUMENT EXTEND field_mods - PRINTED BY { pr_field_mods } + PRINTED BY { pr_field_mods env sigma } | [ "(" ne_field_mod_list_sep(mods, ",") ")" ] -> { mods } END diff --git a/plugins/ssr/ssrcommon.ml b/plugins/ssr/ssrcommon.ml index 0961edb6cb..6956120a6a 100644 --- a/plugins/ssr/ssrcommon.ml +++ b/plugins/ssr/ssrcommon.ml @@ -15,6 +15,7 @@ open Names open Evd open Term open Constr +open Context open Termops open Printer open Locusops @@ -429,15 +430,16 @@ let convert_concl t = Tactics.convert_concl t DEFAULTcast let rename_hd_prod orig_name_ref gl = match EConstr.kind (project gl) (pf_concl gl) with - | Prod(_,src,tgt) -> - Proofview.V82.of_tactic (convert_concl_no_check (EConstr.mkProd (!orig_name_ref,src,tgt))) gl + | Prod(x,src,tgt) -> + let x = {x with binder_name = !orig_name_ref} in + Proofview.V82.of_tactic (convert_concl_no_check (EConstr.mkProd (x,src,tgt))) gl | _ -> CErrors.anomaly (str "gentac creates no product") (* Reduction that preserves the Prod/Let spine of the "in" tactical. *) let inc_safe n = if n = 0 then n else n + 1 let rec safe_depth s c = match EConstr.kind s c with -| LetIn (Name x, _, _, c') when is_discharged_id x -> safe_depth s c' + 1 +| LetIn ({binder_name=Name x}, _, _, c') when is_discharged_id x -> safe_depth s c' + 1 | LetIn (_, _, _, c') | Prod (_, _, c') -> inc_safe (safe_depth s c') | _ -> 0 @@ -529,7 +531,7 @@ let pf_abs_evars2 gl rigid (sigma, c0) = let concl = EConstr.Unsafe.to_constr evi.evar_concl in let dc = EConstr.Unsafe.to_named_context (CList.firstn n (evar_filtered_context evi)) in let abs_dc c = function - | NamedDecl.LocalDef (x,b,t) -> mkNamedLetIn x b t (mkArrow t c) + | NamedDecl.LocalDef (x,b,t) -> mkNamedLetIn x b t (mkArrow t x.binder_relevance c) | NamedDecl.LocalAssum (x,t) -> mkNamedProd x t c in let t = Context.Named.fold_inside abs_dc ~init:concl dc in nf_evar sigma t in @@ -552,7 +554,7 @@ let pf_abs_evars2 gl rigid (sigma, c0) = | _ -> Constr.map_with_binders ((+) 1) get i c in let rec loop c i = function | (_, (n, t)) :: evl -> - loop (mkLambda (mk_evar_name n, get (i - 1) t, c)) (i - 1) evl + loop (mkLambda (make_annot (mk_evar_name n) Sorts.Relevant, get (i - 1) t, c)) (i - 1) evl | [] -> c in List.length evlist, EConstr.of_constr (loop (get 1 c0) 1 evlist), List.map fst evlist, ucst @@ -590,7 +592,7 @@ let pf_abs_evars_pirrel gl (sigma, c0) = let concl = EConstr.Unsafe.to_constr evi.evar_concl in let dc = EConstr.Unsafe.to_named_context (CList.firstn n (evar_filtered_context evi)) in let abs_dc c = function - | NamedDecl.LocalDef (x,b,t) -> mkNamedLetIn x b t (mkArrow t c) + | NamedDecl.LocalDef (x,b,t) -> mkNamedLetIn x b t (mkArrow t x.binder_relevance c) | NamedDecl.LocalAssum (x,t) -> mkNamedProd x t c in let t = Context.Named.fold_inside abs_dc ~init:concl dc in nf_evar sigma0 (nf_evar sigma t) in @@ -646,7 +648,7 @@ let pf_abs_evars_pirrel gl (sigma, c0) = | (_, (n, t, _)) :: evl -> let t = get evlist (i - 1) t in let n = Name (Id.of_string (ssr_anon_hyp ^ string_of_int n)) in - loopP evlist (mkProd (n, t, c)) (i - 1) evl + loopP evlist (mkProd (make_annot n Sorts.Relevant, t, c)) (i - 1) evl | [] -> c in let rec loop c i = function | (_, (n, t, _)) :: evl -> @@ -658,7 +660,7 @@ let pf_abs_evars_pirrel gl (sigma, c0) = List.map (fun (k,_) -> mkRel (fst (lookup k i evlist))) (List.rev t_evplist) in let c = if extra_args = [] then c else app extra_args 1 c in - loop (mkLambda (mk_evar_name n, t, c)) (i - 1) evl + loop (mkLambda (make_annot (mk_evar_name n) Sorts.Relevant, t, c)) (i - 1) evl | [] -> c in let res = loop (get evlist 1 c0) 1 evlist in pp(lazy(str"res= " ++ pr_constr res)); @@ -679,6 +681,9 @@ let pf_type_id gl t = Id.of_string (Namegen.hdchar (pf_env gl) (project gl) t) let pfe_type_of gl t = let sigma, ty = pf_type_of gl t in re_sig (sig_it gl) sigma, ty +let pfe_type_relevance_of gl t = + let gl, ty = pfe_type_of gl t in + gl, ty, pf_apply Retyping.relevance_of_term gl t let pf_type_of gl t = let sigma, ty = pf_type_of gl (EConstr.of_constr t) in re_sig (sig_it gl) sigma, EConstr.Unsafe.to_constr ty @@ -710,13 +715,13 @@ let pf_abs_cterm gl n c0 = | _ -> [], strip i c in let rec strip_evars i c = match Constr.kind c with | Lambda (x, t1, c1) when i < n -> - let na = nb_evar_deps x in + let na = nb_evar_deps x.binder_name in let dl, t2 = strip_ndeps (i + na) i t1 in let na' = List.length dl in eva.(i) <- Array.of_list (na - na' :: dl); let x' = if na' = 0 then Name (pf_type_id gl (EConstr.of_constr t2)) else mk_evar_name na' in - mkLambda (x', t2, strip_evars (i + 1) c1) + mkLambda ({x with binder_name=x'}, t2, strip_evars (i + 1) c1) (* if noccurn 1 c2 then lift (-1) c2 else mkLambda (Name (pf_type_id gl t2), t2, c2) *) | _ -> strip i c in @@ -739,9 +744,9 @@ let rec constr_name sigma c = match EConstr.kind sigma c with | _ -> Anonymous let pf_mkprod gl c ?(name=constr_name (project gl) c) cl = - let gl, t = pfe_type_of gl c in - if name <> Anonymous || EConstr.Vars.noccurn (project gl) 1 cl then gl, EConstr.mkProd (name, t, cl) else - gl, EConstr.mkProd (Name (pf_type_id gl t), t, cl) + let gl, t, r = pfe_type_relevance_of gl c in + if name <> Anonymous || EConstr.Vars.noccurn (project gl) 1 cl then gl, EConstr.mkProd (make_annot name r, t, cl) else + gl, EConstr.mkProd (make_annot (Name (pf_type_id gl t)) r, t, cl) let pf_abs_prod name gl c cl = pf_mkprod gl c ~name (Termops.subst_term (project gl) c cl) @@ -783,13 +788,17 @@ let mkRefl t c gl = let discharge_hyp (id', (id, mode)) gl = let cl' = Vars.subst_var id (pf_concl gl) in - match pf_get_hyp gl id, mode with - | NamedDecl.LocalAssum (_, t), _ | NamedDecl.LocalDef (_, _, t), "(" -> - Proofview.V82.of_tactic (Tactics.apply_type ~typecheck:true (EConstr.of_constr (mkProd (Name id', t, cl'))) + let decl = pf_get_hyp gl id in + match decl, mode with + | NamedDecl.LocalAssum _, _ | NamedDecl.LocalDef _, "(" -> + let id' = {(NamedDecl.get_annot decl) with binder_name = Name id'} in + Proofview.V82.of_tactic (Tactics.apply_type ~typecheck:true + (EConstr.of_constr (mkProd (id', NamedDecl.get_type decl, cl'))) [EConstr.of_constr (mkVar id)]) gl | NamedDecl.LocalDef (_, v, t), _ -> + let id' = {(NamedDecl.get_annot decl) with binder_name = Name id'} in Proofview.V82.of_tactic - (convert_concl (EConstr.of_constr (mkLetIn (Name id', v, t, cl')))) gl + (convert_concl (EConstr.of_constr (mkLetIn (id', v, t, cl')))) gl (* wildcard names *) let clear_wilds wilds gl = @@ -983,7 +992,7 @@ let applyn ~with_evars ?beta ?(with_shelve=false) n t gl = let rec loop sigma bo args = function (* saturate with metas *) | 0 -> EConstr.mkApp (t, Array.of_list (List.rev args)), re_sig si sigma | n -> match EConstr.kind sigma bo with - | Lambda (_, ty, bo) -> + | Lambda (_, ty, bo) -> if not (EConstr.Vars.closed0 sigma ty) then raise dependent_apply_error; let m = Evarutil.new_meta () in @@ -1019,7 +1028,7 @@ let () = CLexer.set_keyword_state frozen_lexer ;; let rec fst_prod red tac = Proofview.Goal.enter begin fun gl -> let concl = Proofview.Goal.concl gl in match EConstr.kind (Proofview.Goal.sigma gl) concl with - | Prod (id,_,tgt) | LetIn(id,_,_,tgt) -> tac id + | Prod (id,_,tgt) | LetIn(id,_,_,tgt) -> tac id.binder_name | _ -> if red then Tacticals.New.tclZEROMSG (str"No product even after head-reduction.") else Tacticals.New.tclTHEN Tactics.hnf_in_concl (fst_prod true tac) end @@ -1122,14 +1131,14 @@ let pf_interp_gen_aux gl to_ind ((oclr, occ), t) = errorstrm (str "@ can be used with variables only") else match Tacmach.pf_get_hyp gl (EConstr.destVar sigma c) with | NamedDecl.LocalAssum _ -> errorstrm (str "@ can be used with let-ins only") - | NamedDecl.LocalDef (name, b, ty) -> true, pat, EConstr.mkLetIn (Name name,b,ty,cl),c,clr,ucst,gl + | NamedDecl.LocalDef (name, b, ty) -> true, pat, EConstr.mkLetIn (map_annot Name.mk_name name,b,ty,cl),c,clr,ucst,gl else let gl, ccl = pf_mkprod gl c cl in false, pat, ccl, c, clr,ucst,gl else if to_ind && occ = None then let nv, p, _, ucst' = pf_abs_evars gl (fst pat, c) in let ucst = UState.union ucst ucst' in if nv = 0 then anomaly "occur_existential but no evars" else - let gl, pty = pfe_type_of gl p in - false, pat, EConstr.mkProd (constr_name (project gl) c, pty, Tacmach.pf_concl gl), p, clr,ucst,gl + let gl, pty, rp = pfe_type_relevance_of gl p in + false, pat, EConstr.mkProd (make_annot (constr_name (project gl) c) rp, pty, Tacmach.pf_concl gl), p, clr,ucst,gl else CErrors.user_err ?loc:(loc_of_cpattern t) (str "generalized term didn't match") let apply_type x xs = Proofview.V82.of_tactic (Tactics.apply_type ~typecheck:true x xs) @@ -1223,7 +1232,7 @@ let abs_wgen keep_let f gen (gl,args,c) = let evar_closed t p = if occur_existential sigma t then CErrors.user_err ?loc:(loc_of_cpattern p) ~hdr:"ssreflect" - (pr_constr_pat (EConstr.Unsafe.to_constr t) ++ + (pr_constr_pat env sigma (EConstr.Unsafe.to_constr t) ++ str" contains holes and matches no subterm of the goal") in match gen with | _, Some ((x, mode), None) when mode = "@" || (mode = " " && keep_let) -> @@ -1235,7 +1244,10 @@ let abs_wgen keep_let f gen (gl,args,c) = (EConstr.Vars.subst_var x c) | _, Some ((x, _), None) -> let x = hoi_id x in - gl, EConstr.mkVar x :: args, EConstr.mkProd (Name (f x),Tacmach.pf_get_hyp_typ gl x, EConstr.Vars.subst_var x c) + let hyp = Tacmach.pf_get_hyp gl x in + let x' = make_annot (Name (f x)) (NamedDecl.get_relevance hyp) in + let prod = EConstr.mkProd (x', NamedDecl.get_type hyp, EConstr.Vars.subst_var x c) in + gl, EConstr.mkVar x :: args, prod | _, Some ((x, "@"), Some p) -> let x = hoi_id x in let cp = interp_cpattern gl p None in @@ -1246,8 +1258,8 @@ let abs_wgen keep_let f gen (gl,args,c) = let t = EConstr.of_constr t in evar_closed t p; let ut = red_product_skip_id env sigma t in - let gl, ty = pfe_type_of gl t in - pf_merge_uc ucst gl, args, EConstr.mkLetIn(Name (f x), ut, ty, c) + let gl, ty, r = pfe_type_relevance_of gl t in + pf_merge_uc ucst gl, args, EConstr.mkLetIn(make_annot (Name (f x)) r, ut, ty, c) | _, Some ((x, _), Some p) -> let x = hoi_id x in let cp = interp_cpattern gl p None in @@ -1257,8 +1269,8 @@ let abs_wgen keep_let f gen (gl,args,c) = let c = EConstr.of_constr c in let t = EConstr.of_constr t in evar_closed t p; - let gl, ty = pfe_type_of gl t in - pf_merge_uc ucst gl, t :: args, EConstr.mkProd(Name (f x), ty, c) + let gl, ty, r = pfe_type_relevance_of gl t in + pf_merge_uc ucst gl, t :: args, EConstr.mkProd(make_annot (Name (f x)) r, ty, c) | _ -> gl, args, c let clr_of_wgen gen clrs = match gen with @@ -1321,8 +1333,8 @@ let unsafe_intro env decl b = end let set_decl_id id = let open Context in function - | Rel.Declaration.LocalAssum(name,ty) -> Named.Declaration.LocalAssum(id,ty) - | Rel.Declaration.LocalDef(name,ty,t) -> Named.Declaration.LocalDef(id,ty,t) + | Rel.Declaration.LocalAssum(name,ty) -> Named.Declaration.LocalAssum({name with binder_name=id},ty) + | Rel.Declaration.LocalDef(name,ty,t) -> Named.Declaration.LocalDef({name with binder_name=id},ty,t) let rec decompose_assum env sigma orig_goal = let open Context in @@ -1400,8 +1412,8 @@ let tclRENAME_HD_PROD name = Goal.enter begin fun gl -> let concl = Goal.concl gl in let sigma = Goal.sigma gl in match EConstr.kind sigma concl with - | Prod(_,src,tgt) -> - convert_concl_no_check EConstr.(mkProd (name,src,tgt)) + | Prod(x,src,tgt) -> + convert_concl_no_check EConstr.(mkProd ({x with binder_name = name},src,tgt)) | _ -> CErrors.anomaly (Pp.str "rename_hd_prod: no head product") end @@ -1429,11 +1441,12 @@ let tacMKPROD c ?name cl = tacCONSTR_NAME ?name c >>= fun name -> Goal.enter_one ~__LOC__ begin fun g -> let sigma, env = Goal.sigma g, Goal.env g in + let r = Retyping.relevance_of_term env sigma c in if name <> Names.Name.Anonymous || EConstr.Vars.noccurn sigma 1 cl - then tclUNIT (EConstr.mkProd (name, t, cl)) + then tclUNIT (EConstr.mkProd (make_annot name r, t, cl)) else let name = Names.Id.of_string (Namegen.hdchar env sigma t) in - tclUNIT (EConstr.mkProd (Names.Name.Name name, t, cl)) + tclUNIT (EConstr.mkProd (make_annot (Name.Name name) r, t, cl)) end let tacINTERP_CPATTERN cp = diff --git a/plugins/ssr/ssrcommon.mli b/plugins/ssr/ssrcommon.mli index e642b5e788..9662daa7c7 100644 --- a/plugins/ssr/ssrcommon.mli +++ b/plugins/ssr/ssrcommon.mli @@ -155,7 +155,7 @@ val pf_e_type_of : val splay_open_constr : Goal.goal Evd.sigma -> evar_map * EConstr.t -> - (Names.Name.t * EConstr.t) list * EConstr.t + (Names.Name.t Context.binder_annot * EConstr.t) list * EConstr.t val isAppInd : Environ.env -> Evd.evar_map -> EConstr.types -> bool val mk_term : ssrtermkind -> constr_expr -> ssrterm @@ -205,6 +205,9 @@ val pf_type_of : val pfe_type_of : Goal.goal Evd.sigma -> EConstr.t -> Goal.goal Evd.sigma * EConstr.types +val pfe_type_relevance_of : + Goal.goal Evd.sigma -> + EConstr.t -> Goal.goal Evd.sigma * EConstr.types * Sorts.relevance val pf_abs_prod : Name.t -> Goal.goal Evd.sigma -> diff --git a/plugins/ssr/ssrelim.ml b/plugins/ssr/ssrelim.ml index 7216849948..3fc05437da 100644 --- a/plugins/ssr/ssrelim.ml +++ b/plugins/ssr/ssrelim.ml @@ -15,6 +15,7 @@ open Names open Printer open Term open Constr +open Context open Termops open Tactypes open Tacmach @@ -132,7 +133,7 @@ let ssrelim ?(is_case=false) deps what ?elim eqid elim_intro_tac = | _ -> false in let match_pat env p occ h cl = let sigma0 = project orig_gl in - ppdebug(lazy Pp.(str"matching: " ++ pr_occ occ ++ pp_pattern p)); + ppdebug(lazy Pp.(str"matching: " ++ pr_occ occ ++ pp_pattern env p)); let (c,ucst), cl = fill_occ_pattern ~raise_NoMatch:true env sigma0 (EConstr.Unsafe.to_constr cl) p occ h in ppdebug(lazy Pp.(str" got: " ++ pr_constr_env env sigma0 c)); @@ -238,8 +239,8 @@ let ssrelim ?(is_case=false) deps what ?elim eqid elim_intro_tac = let elimty = Reductionops.whd_all env (project gl) elimty in seed, cty, elim, elimty, elim_args, n_elim_args, elim_is_dep, is_rec, pred, gl in - ppdebug(lazy Pp.(str"elim= "++ pr_constr_pat (EConstr.Unsafe.to_constr elim))); - ppdebug(lazy Pp.(str"elimty= "++ pr_constr_pat (EConstr.Unsafe.to_constr elimty))); + ppdebug(lazy Pp.(str"elim= "++ pr_constr_pat env (project gl) (EConstr.Unsafe.to_constr elim))); + ppdebug(lazy Pp.(str"elimty= "++ pr_constr_pat env (project gl) (EConstr.Unsafe.to_constr elimty))); let inf_deps_r = match EConstr.kind_of_type (project gl) elimty with | AtomicType (_, args) -> List.rev (Array.to_list args) | _ -> assert false in @@ -284,8 +285,8 @@ let ssrelim ?(is_case=false) deps what ?elim eqid elim_intro_tac = (* Patterns for the inductive types indexes to be bound in pred are computed * looking at the ones provided by the user and the inferred ones looking at * the type of the elimination principle *) - let pp_pat (_,p,_,occ) = Pp.(pr_occ occ ++ pp_pattern p) in - let pp_inf_pat gl (_,_,t,_) = pr_constr_pat (EConstr.Unsafe.to_constr (fire_subst gl t)) in + let pp_pat (_,p,_,occ) = Pp.(pr_occ occ ++ pp_pattern env p) in + let pp_inf_pat gl (_,_,t,_) = pr_constr_pat env (project gl) (EConstr.Unsafe.to_constr (fire_subst gl t)) in let patterns, clr, gl = let rec loop patterns clr i = function | [],[] -> patterns, clr, gl @@ -299,7 +300,7 @@ let ssrelim ?(is_case=false) deps what ?elim eqid elim_intro_tac = loop (patterns @ [i, p, inf_t, occ]) (clr_t @ clr) (i+1) (deps, inf_deps) | [], c :: inf_deps -> - ppdebug(lazy Pp.(str"adding inf pattern " ++ pr_constr_pat (EConstr.Unsafe.to_constr c))); + ppdebug(lazy Pp.(str"adding inf pattern " ++ pr_constr_pat env (project gl) (EConstr.Unsafe.to_constr c))); loop (patterns @ [i, mkTpat gl c, c, allocc]) clr (i+1) ([], inf_deps) | _::_, [] -> errorstrm Pp.(str "Too many dependent abstractions") in @@ -322,11 +323,11 @@ let ssrelim ?(is_case=false) deps what ?elim eqid elim_intro_tac = let elim_pred, gen_eq_tac, clr, gl = let error gl t inf_t = errorstrm Pp.(str"The given pattern matches the term"++ spc()++pp_term gl t++spc()++str"while the inferred pattern"++ - spc()++pr_constr_pat (EConstr.Unsafe.to_constr (fire_subst gl inf_t))++spc()++ str"doesn't") in + spc()++pr_constr_pat env (project gl) (EConstr.Unsafe.to_constr (fire_subst gl inf_t))++spc()++ str"doesn't") in let match_or_postpone (cl, gl, post) (h, p, inf_t, occ) = let p = unif_redex gl p inf_t in if is_undef_pat p then - let () = ppdebug(lazy Pp.(str"postponing " ++ pp_pattern p)) in + let () = ppdebug(lazy Pp.(str"postponing " ++ pp_pattern env p)) in cl, gl, post @ [h, p, inf_t, occ] else try let c, cl, ucst = match_pat env p occ h cl in @@ -364,14 +365,14 @@ let ssrelim ?(is_case=false) deps what ?elim eqid elim_intro_tac = let gl, eq = get_eq_type gl in let gen_eq_tac, gl = let refl = EConstr.mkApp (eq, [|t; c; c|]) in - let new_concl = EConstr.mkArrow refl (EConstr.Vars.lift 1 (pf_concl orig_gl)) in + let new_concl = EConstr.mkArrow refl Sorts.Relevant (EConstr.Vars.lift 1 (pf_concl orig_gl)) in let new_concl = fire_subst gl new_concl in let erefl, gl = mkRefl t c gl in let erefl = fire_subst gl erefl in apply_type new_concl [erefl], gl in let rel = k + if c_is_head_p then 1 else 0 in let src, gl = mkProt EConstr.mkProp EConstr.(mkApp (eq,[|t; c; mkRel rel|])) gl in - let concl = EConstr.mkArrow src (EConstr.Vars.lift 1 concl) in + let concl = EConstr.mkArrow src Sorts.Relevant (EConstr.Vars.lift 1 concl) in let clr = if deps <> [] then clr else [] in concl, gen_eq_tac, clr, gl | _ -> concl, Tacticals.tclIDTAC, clr, gl in @@ -407,7 +408,7 @@ let ssrelim ?(is_case=false) deps what ?elim eqid elim_intro_tac = if not (Evar.Set.is_empty inter) then begin let i = Evar.Set.choose inter in let pat = List.find (fun t -> Evar.Set.mem i (evars_of_term t)) patterns in - errorstrm Pp.(str"Pattern"++spc()++pr_constr_pat (EConstr.Unsafe.to_constr pat)++spc()++ + errorstrm Pp.(str"Pattern"++spc()++pr_constr_pat env (project gl) (EConstr.Unsafe.to_constr pat)++spc()++ str"was not completely instantiated and one of its variables"++spc()++ str"occurs in the type of another non-instantiated pattern variable"); end @@ -446,7 +447,7 @@ let injecteq_id = mk_internal_id "injection equation" let revtoptac n0 gl = let n = pf_nb_prod gl - n0 in let dc, cl = EConstr.decompose_prod_n_assum (project gl) n (pf_concl gl) in - let dc' = dc @ [Context.Rel.Declaration.LocalAssum(Name rev_id, EConstr.it_mkProd_or_LetIn cl (List.rev dc))] in + let dc' = dc @ [Context.Rel.Declaration.LocalAssum(make_annot (Name rev_id) Sorts.Relevant, EConstr.it_mkProd_or_LetIn cl (List.rev dc))] in let f = EConstr.it_mkLambda_or_LetIn (mkEtaApp (EConstr.mkRel (n + 1)) (-n) 1) dc' in Refiner.refiner ~check:true EConstr.Unsafe.(to_constr (EConstr.mkApp (f, [|Evarutil.mk_new_meta ()|]))) gl @@ -486,7 +487,7 @@ let perform_injection c gl = CErrors.user_err (Pp.str "can't decompose a quantified equality") else let cl = pf_concl gl in let n = List.length dc in let c_eq = mkEtaApp c n 2 in - let cl1 = EConstr.mkLambda EConstr.(Anonymous, mkArrow eqt cl, mkApp (mkRel 1, [|c_eq|])) in + let cl1 = EConstr.mkLambda EConstr.(make_annot Anonymous Sorts.Relevant, mkArrow eqt Sorts.Relevant cl, mkApp (mkRel 1, [|c_eq|])) in let id = injecteq_id in let id_with_ebind = (EConstr.mkVar id, NoBindings) in let injtac = Tacticals.tclTHEN (introid id) (injectidl2rtac id id_with_ebind) in diff --git a/plugins/ssr/ssrequality.ml b/plugins/ssr/ssrequality.ml index 64e023c68a..15480c7a45 100644 --- a/plugins/ssr/ssrequality.ml +++ b/plugins/ssr/ssrequality.ml @@ -15,6 +15,7 @@ open Util open Names open Term open Constr +open Context open Vars open Locus open Printer @@ -136,7 +137,7 @@ let newssrcongrtac arg ist gl = (fun ty -> congrtac (arg, Detyping.detype Detyping.Now false Id.Set.empty (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 + let arrow = EConstr.mkArrow lhs Sorts.Relevant (EConstr.Vars.lift 1 rhs) in tclMATCH_GOAL (arrow, gl') (fun gl' -> [|fs gl' lhs;fs gl' rhs|]) (fun lr -> tclTHEN (Proofview.V82.of_tactic (Tactics.apply (ssr_congr lr))) (congrtac (arg, mkRType) ist)) (fun _ _ -> errorstrm Pp.(str"Conclusion is not an equality nor an arrow"))) @@ -198,13 +199,13 @@ let simplintac occ rdx sim gl = | SimplCut (n,m) -> tclTHEN (simptac m) (tclTRY (donetac n)) gl | _ -> simpltac sim gl -let rec get_evalref sigma c = match EConstr.kind sigma c with +let rec get_evalref env sigma c = match EConstr.kind sigma c with | Var id -> EvalVarRef id | Const (k,_) -> EvalConstRef k - | App (c', _) -> get_evalref sigma c' - | Cast (c', _, _) -> get_evalref sigma c' + | App (c', _) -> get_evalref env sigma c' + | Cast (c', _, _) -> get_evalref env sigma c' | Proj(c,_) -> EvalConstRef(Projection.constant c) - | _ -> errorstrm Pp.(str "The term " ++ pr_constr_pat (EConstr.Unsafe.to_constr c) ++ str " is not unfoldable") + | _ -> errorstrm Pp.(str "The term " ++ pr_constr_pat env sigma (EConstr.Unsafe.to_constr c) ++ str " is not unfoldable") (* Strip a pattern generated by a prenex implicit to its constant. *) let strip_unfold_term _ ((sigma, t) as p) kt = match EConstr.kind sigma t with @@ -229,7 +230,7 @@ let unfoldintac occ rdx t (kt,_) gl = let sigma0, concl0, env0 = project gl, pf_concl gl, pf_env gl in let (sigma, t), const = strip_unfold_term env0 t kt in let body env t c = - Tacred.unfoldn [AllOccurrences, get_evalref sigma t] env sigma0 c in + Tacred.unfoldn [AllOccurrences, get_evalref env sigma t] env sigma0 c in let easy = occ = None && rdx = None in let red_flags = if easy then CClosure.betaiotazeta else CClosure.betaiota in let beta env = Reductionops.clos_norm_flags red_flags env sigma0 in @@ -243,7 +244,7 @@ let unfoldintac occ rdx t (kt,_) gl = try find_T env c h ~k:(fun env c _ _ -> EConstr.Unsafe.to_constr (body env t (EConstr.of_constr c))) with NoMatch when easy -> c | NoMatch | NoProgress -> errorstrm Pp.(str"No occurrence of " - ++ pr_constr_pat (EConstr.Unsafe.to_constr t) ++ spc() ++ str "in " ++ Printer.pr_constr_env env sigma c)), + ++ pr_constr_pat env sigma (EConstr.Unsafe.to_constr t) ++ spc() ++ str "in " ++ Printer.pr_constr_env env sigma c)), (fun () -> try end_T () with | NoMatch when easy -> fake_pmatcher_end () | NoMatch -> anomaly "unfoldintac") @@ -269,12 +270,12 @@ let unfoldintac occ rdx t (kt,_) gl = else try EConstr.Unsafe.to_constr @@ body env t (fs (unify_HO env sigma (EConstr.of_constr c) t) t) with _ -> errorstrm Pp.(str "The term " ++ - pr_constr_env env sigma c ++spc()++ str "does not unify with " ++ pr_constr_pat (EConstr.Unsafe.to_constr t))), + pr_constr_env env sigma c ++spc()++ str "does not unify with " ++ pr_constr_pat env sigma (EConstr.Unsafe.to_constr t))), fake_pmatcher_end in let concl = let concl0 = EConstr.Unsafe.to_constr concl0 in try beta env0 (EConstr.of_constr (eval_pattern env0 sigma0 concl0 rdx occ unfold)) - with Option.IsNone -> errorstrm Pp.(str"Failed to unfold " ++ pr_constr_pat (EConstr.Unsafe.to_constr t)) in + with Option.IsNone -> errorstrm Pp.(str"Failed to unfold " ++ pr_constr_pat env0 sigma (EConstr.Unsafe.to_constr t)) in let _ = conclude () in Proofview.V82.of_tactic (convert_concl concl) gl ;; @@ -297,8 +298,8 @@ let foldtac occ rdx ft gl = try let sigma = unify_HO env sigma (EConstr.of_constr c) (EConstr.of_constr t) in EConstr.to_constr ~abort_on_undefined_evars:false sigma (EConstr.of_constr t) - with _ -> errorstrm Pp.(str "fold pattern " ++ pr_constr_pat t ++ spc () - ++ str "does not match redex " ++ pr_constr_pat c)), + with _ -> errorstrm Pp.(str "fold pattern " ++ pr_constr_pat env sigma t ++ spc () + ++ str "does not match redex " ++ pr_constr_pat env sigma c)), fake_pmatcher_end in let concl0 = EConstr.Unsafe.to_constr concl0 in let concl = eval_pattern env0 sigma0 concl0 rdx occ fold in @@ -335,7 +336,7 @@ let pirrel_rewrite pred rdx rdx_ty new_rdx dir (sigma, c) c_ty gl = let (sigma, ev) = Evarutil.new_evar env sigma (beta (EConstr.Vars.subst1 new_rdx pred)) in (sigma, ev) in - let pred = EConstr.mkNamedLambda pattern_id rdx_ty pred in + let pred = EConstr.mkNamedLambda (make_annot pattern_id Sorts.Relevant) rdx_ty pred in let elim, gl = let ((kn, i) as ind, _), unfolded_c_ty = pf_reduce_to_quantified_ind gl c_ty in let sort = elimination_sort_of_goal gl in @@ -362,7 +363,7 @@ let pirrel_rewrite pred rdx rdx_ty new_rdx dir (sigma, c) c_ty gl = let names = let rec aux t = function 0 -> [] | n -> let t = Reductionops.whd_all env sigma t in match EConstr.kind_of_type sigma t with - | ProdType (name, _, t) -> name :: aux t (n-1) + | ProdType (name, _, t) -> name.binder_name :: aux t (n-1) | _ -> assert false in aux hd_ty (Array.length args) in hd_ty, Util.List.map_filter (fun (t, name) -> let evs = Evar.Set.elements (Evarutil.undefined_evars_of_term sigma t) in @@ -403,7 +404,7 @@ let rwcltac cl rdx dir sr gl = let new_rdx = if dir = L2R then a.(2) else a.(1) in pirrel_rewrite cl rdx rdxt new_rdx dir (sigma,c) c_ty, tclIDTAC, gl | _ -> - let cl' = EConstr.mkApp (EConstr.mkNamedLambda pattern_id rdxt cl, [|rdx|]) in + let cl' = EConstr.mkApp (EConstr.mkNamedLambda (make_annot pattern_id Sorts.Relevant) rdxt cl, [|rdx|]) in let sigma, _ = Typing.type_of env sigma cl' in let gl = pf_merge_uc_of sigma gl in Proofview.V82.of_tactic (convert_concl cl'), rewritetac dir r', gl @@ -411,10 +412,10 @@ let rwcltac cl rdx dir sr gl = let dc, r2 = EConstr.decompose_lam_n_assum (project gl) n r' in let r3, _, r3t = try EConstr.destCast (project gl) r2 with _ -> - errorstrm Pp.(str "no cast from " ++ pr_constr_pat (EConstr.Unsafe.to_constr (snd sr)) + errorstrm Pp.(str "no cast from " ++ pr_constr_pat (pf_env gl) (project gl) (EConstr.Unsafe.to_constr (snd sr)) ++ str " to " ++ pr_econstr_env (pf_env gl) (project gl) r2) in - let cl' = EConstr.mkNamedProd rule_id (EConstr.it_mkProd_or_LetIn r3t dc) (EConstr.Vars.lift 1 cl) in - let cl'' = EConstr.mkNamedProd pattern_id rdxt cl' in + let cl' = EConstr.mkNamedProd (make_annot rule_id Sorts.Relevant) (EConstr.it_mkProd_or_LetIn r3t dc) (EConstr.Vars.lift 1 cl) in + let cl'' = EConstr.mkNamedProd (make_annot pattern_id Sorts.Relevant) rdxt cl' in let itacs = [introid pattern_id; introid rule_id] in let cltac = Proofview.V82.of_tactic (Tactics.clear [pattern_id; rule_id]) in let rwtacs = [rewritetac dir (EConstr.mkVar rule_id); cltac] in @@ -426,7 +427,9 @@ let rwcltac cl rdx dir sr gl = if occur_existential (project gl) (Tacmach.pf_concl gl) then errorstrm Pp.(str "Rewriting impacts evars") else errorstrm Pp.(str "Dependent type error in rewrite of " - ++ pr_constr_env (pf_env gl) (project gl) (Term.mkNamedLambda pattern_id (EConstr.Unsafe.to_constr rdxt) (EConstr.Unsafe.to_constr cl))) + ++ pr_constr_env (pf_env gl) (project gl) + (Term.mkNamedLambda (make_annot pattern_id Sorts.Relevant) + (EConstr.Unsafe.to_constr rdxt) (EConstr.Unsafe.to_constr cl))) in tclTHEN cvtac' rwtac gl @@ -470,7 +473,7 @@ let rwprocess_rule dir rule gl = let t = if red = 1 then Tacred.hnf_constr env sigma t0 else Reductionops.whd_betaiotazeta sigma t0 in - ppdebug(lazy Pp.(str"rewrule="++pr_constr_pat (EConstr.Unsafe.to_constr t))); + ppdebug(lazy Pp.(str"rewrule="++pr_constr_pat env sigma (EConstr.Unsafe.to_constr t))); match EConstr.kind sigma t with | Prod (_, xt, at) -> let sigma = Evd.create_evar_defs sigma in @@ -529,8 +532,8 @@ let rwprocess_rule dir rule gl = sigma, (d, r', lhs, rhs) :: rs | _ -> if red = 0 then loop d sigma r t rs 1 - else errorstrm Pp.(str "not a rewritable relation: " ++ pr_constr_pat (EConstr.Unsafe.to_constr t) - ++ spc() ++ str "in rule " ++ pr_constr_pat (EConstr.Unsafe.to_constr (snd rule))) + else errorstrm Pp.(str "not a rewritable relation: " ++ pr_constr_pat env sigma (EConstr.Unsafe.to_constr t) + ++ spc() ++ str "in rule " ++ pr_constr_pat env sigma (EConstr.Unsafe.to_constr (snd rule))) in let sigma, r = rule in let t = Retyping.get_type_of env sigma r in @@ -544,9 +547,9 @@ let rwrxtac occ rdx_pat dir rule gl = let find_rule rdx = let rec rwtac = function | [] -> - errorstrm Pp.(str "pattern " ++ pr_constr_pat (EConstr.Unsafe.to_constr rdx) ++ + errorstrm Pp.(str "pattern " ++ pr_constr_pat env (project gl) (EConstr.Unsafe.to_constr rdx) ++ str " does not match " ++ pr_dir_side dir ++ - str " of " ++ pr_constr_pat (EConstr.Unsafe.to_constr (snd rule))) + str " of " ++ pr_constr_pat env (project gl) (EConstr.Unsafe.to_constr (snd rule))) | (d, r, lhs, rhs) :: rs -> try let ise = unify_HO env (Evd.create_evar_defs r_sigma) lhs rdx in @@ -637,7 +640,7 @@ let ssrrewritetac ist rwargs = let unfoldtac occ ko t kt gl = let env = pf_env gl in let cl, c = pf_fill_occ_term gl occ (fst (strip_unfold_term env t kt)) in - let cl' = EConstr.Vars.subst1 (pf_unfoldn [OnlyOccurrences [1], get_evalref (project gl) c] gl c) cl in + let cl' = EConstr.Vars.subst1 (pf_unfoldn [OnlyOccurrences [1], get_evalref env (project gl) c] gl c) cl in let f = if ko = None then CClosure.betaiotazeta else CClosure.betaiota in Proofview.V82.of_tactic (convert_concl (pf_reduce (Reductionops.clos_norm_flags f) gl cl')) gl diff --git a/plugins/ssr/ssrfwd.ml b/plugins/ssr/ssrfwd.ml index 8c1363020a..be9586fdd7 100644 --- a/plugins/ssr/ssrfwd.ml +++ b/plugins/ssr/ssrfwd.ml @@ -13,6 +13,7 @@ open Pp open Names open Constr +open Context open Tacmach open Ssrmatching_plugin.Ssrmatching @@ -49,12 +50,12 @@ let ssrsettac id ((_, (pat, pty)), (_, occ)) gl = let c = EConstr.of_constr c in let cl = EConstr.of_constr cl in if Termops.occur_existential sigma c then errorstrm(str"The pattern"++spc()++ - pr_constr_pat (EConstr.Unsafe.to_constr c)++spc()++str"did not match and has holes."++spc()++ + pr_constr_pat env sigma (EConstr.Unsafe.to_constr c)++spc()++str"did not match and has holes."++spc()++ str"Did you mean pose?") else let c, (gl, cty) = match EConstr.kind sigma c with | Cast(t, DEFAULTcast, ty) -> t, (gl, ty) | _ -> c, pfe_type_of gl c in - let cl' = EConstr.mkLetIn (Name id, c, cty, cl) in + let cl' = EConstr.mkLetIn (make_annot (Name id) Sorts.Relevant, c, cty, cl) in Tacticals.tclTHEN (Proofview.V82.of_tactic (convert_concl cl')) (introid id) gl open Util @@ -162,7 +163,7 @@ let havetac ist let assert_is_conv gl = try Proofview.V82.of_tactic (convert_concl (EConstr.it_mkProd_or_LetIn concl ctx)) gl with _ -> errorstrm (str "Given proof term is not of type " ++ - pr_econstr_env (pf_env gl) (project gl) (EConstr.mkArrow (EConstr.mkVar (Id.of_string "_")) concl)) in + pr_econstr_env (pf_env gl) (project gl) (EConstr.mkArrow (EConstr.mkVar (Id.of_string "_")) Sorts.Relevant concl)) in gl, ty, Tacticals.tclTHEN assert_is_conv (Proofview.V82.of_tactic (Tactics.apply t)), id, itac_c | FwdHave, false, false -> let skols = List.flatten (List.map (function @@ -190,10 +191,10 @@ let havetac ist Proofview.V82.of_tactic (unfold [abstract; abstract_key]) gl)) | _,true,true -> let _, ty, uc = interp_ty gl fixtc cty in let gl = pf_merge_uc uc gl in - gl, EConstr.mkArrow ty concl, hint, itac, clr + gl, EConstr.mkArrow ty Sorts.Relevant concl, hint, itac, clr | _,false,true -> let _, ty, uc = interp_ty gl fixtc cty in let gl = pf_merge_uc uc gl in - gl, EConstr.mkArrow ty concl, hint, id, itac_c + gl, EConstr.mkArrow ty Sorts.Relevant concl, hint, id, itac_c | _, false, false -> let n, cty, uc = interp_ty gl fixtc cty in let gl = pf_merge_uc uc gl in gl, cty, Tacticals.tclTHEN (binderstac n) hint, id, Tacticals.tclTHEN itac_c simpltac @@ -233,7 +234,7 @@ let wlogtac ist (((clr0, pats),_),_) (gens, ((_, ct))) hint suff ghave gl = let gens = List.filter (function _, Some _ -> true | _ -> false) gens in let concl = pf_concl gl in let c = EConstr.mkProp in - let c = if cut_implies_goal then EConstr.mkArrow c concl else c in + let c = if cut_implies_goal then EConstr.mkArrow c Sorts.Relevant concl else c in let gl, args, c = List.fold_right mkabs gens (gl,[],c) in let env, _ = List.fold_left (fun (env, c) _ -> @@ -245,10 +246,10 @@ let wlogtac ist (((clr0, pats),_),_) (gens, ((_, ct))) hint suff ghave gl = let fake_gl = {Evd.it = k; Evd.sigma = sigma} in let _, ct, _, uc = pf_interp_ty ist fake_gl ct in let rec var2rel c g s = match EConstr.kind sigma c, g with - | Prod(Anonymous,_,c), [] -> EConstr.mkProd(Anonymous, EConstr.Vars.subst_vars s ct, c) + | Prod({binder_name=Anonymous} as x,_,c), [] -> EConstr.mkProd(x, EConstr.Vars.subst_vars s ct, c) | Sort _, [] -> EConstr.Vars.subst_vars s ct - | LetIn(Name id as n,b,ty,c), _::g -> EConstr.mkLetIn (n,b,ty,var2rel c g (id::s)) - | Prod(Name id as n,ty,c), _::g -> EConstr.mkProd (n,ty,var2rel c g (id::s)) + | LetIn({binder_name=Name id} as n,b,ty,c), _::g -> EConstr.mkLetIn (n,b,ty,var2rel c g (id::s)) + | Prod({binder_name=Name id} as n,ty,c), _::g -> EConstr.mkProd (n,ty,var2rel c g (id::s)) | _ -> CErrors.anomaly(str"SSR: wlog: var2rel: " ++ pr_econstr_env env sigma c) in let c = var2rel c gens [] in let rec pired c = function diff --git a/plugins/ssr/ssripats.ml b/plugins/ssr/ssripats.ml index a8dfd69240..e9fe1f3e48 100644 --- a/plugins/ssr/ssripats.ml +++ b/plugins/ssr/ssripats.ml @@ -13,6 +13,7 @@ open Ssrmatching_plugin open Util open Names open Constr +open Context open Proofview open Proofview.Notations @@ -393,12 +394,12 @@ let tcltclMK_ABSTRACT_VAR id = Goal.enter begin fun gl -> let sigma, m = Evarutil.new_evar env sigma abstract_ty in sigma, (m, abstract_ty) in let sigma, kont = - let rd = Context.Rel.Declaration.LocalAssum (Name id, abstract_ty) in + let rd = Context.Rel.Declaration.LocalAssum (make_annot (Name id) Sorts.Relevant, abstract_ty) in let sigma, ev = Evarutil.new_evar (EConstr.push_rel rd env) sigma concl in sigma, ev in let term = - EConstr.(mkApp (mkLambda(Name id,abstract_ty,kont),[|abstract_proof|])) in + EConstr.(mkApp (mkLambda(make_annot (Name id) Sorts.Relevant,abstract_ty,kont),[|abstract_proof|])) in let sigma, _ = Typing.type_of env sigma term in sigma, term end in @@ -608,7 +609,7 @@ let with_defective maintac deps clr = Goal.enter begin fun g -> let sigma, concl = Goal.(sigma g, concl g) in let top_id = match EConstr.kind_of_type sigma concl with - | Term.ProdType (Name id, _, _) + | Term.ProdType ({binder_name=Name id}, _, _) when Ssrcommon.is_discharged_id id -> id | _ -> Ssrcommon.top_id in let top_gen = Ssrequality.mkclr clr, Ssrmatching.cpattern_of_id top_id in @@ -683,7 +684,7 @@ let elim_intro_tac ipats ?seed what eqid ssrelim is_rec clr = let name = Ssrcommon.mk_anon_id "K" (Tacmach.New.pf_ids_of_hyps g) in let new_concl = - mkProd (Name name, case_ty, mkArrow refl (Vars.lift 2 concl)) in + mkProd (make_annot (Name name) Sorts.Relevant, case_ty, mkArrow refl Sorts.Relevant (Vars.lift 2 concl)) in let erefl, sigma = mkCoqRefl case_ty case env sigma in Proofview.Unsafe.tclEVARS sigma <*> Tactics.apply_type ~typecheck:true new_concl [case;erefl] @@ -707,7 +708,7 @@ let mkEq dir cl c t n env sigma = eqargs.(Ssrequality.dir_org dir) <- mkRel n; let eq, sigma = mkCoqEq env sigma in let refl, sigma = mkCoqRefl t c env sigma in - mkArrow (mkApp (eq, eqargs)) (Vars.lift 1 cl), refl, sigma + mkArrow (mkApp (eq, eqargs)) Sorts.Relevant (Vars.lift 1 cl), refl, sigma (** in [tac/v: last gens..] the first (last to be run) generalization is "special" in that is it also the main argument of [tac] and is eventually @@ -743,7 +744,7 @@ let tclLAST_GEN ~to_ind ((oclr, occ), t) conclusion = tclINDEPENDENTL begin Ssrcommon.errorstrm Pp.(str "@ can be used with let-ins only") | Context.Named.Declaration.LocalDef (name, b, ty) -> Unsafe.tclEVARS sigma <*> - tclUNIT (true, EConstr.mkLetIn (Name name,b,ty,cl), c, clr) + tclUNIT (true, EConstr.mkLetIn (map_annot Name.mk_name name,b,ty,cl), c, clr) else Unsafe.tclEVARS sigma <*> Ssrcommon.tacMKPROD c cl >>= fun ccl -> @@ -757,7 +758,7 @@ let tclLAST_GEN ~to_ind ((oclr, occ), t) conclusion = tclINDEPENDENTL begin Unsafe.tclEVARS sigma <*> Ssrcommon.tacTYPEOF p >>= fun pty -> (* TODO: check bug: cl0 no lift? *) - let ccl = EConstr.mkProd (Ssrcommon.constr_name sigma c, pty, cl0) in + let ccl = EConstr.mkProd (make_annot (Ssrcommon.constr_name sigma c) Sorts.Relevant, pty, cl0) in tclUNIT (false, ccl, p, clr) else Ssrcommon.errorstrm Pp.(str "generalized term didn't match") diff --git a/plugins/ssr/ssrparser.mlg b/plugins/ssr/ssrparser.mlg index 2a2cd73df2..0ec5f1673a 100644 --- a/plugins/ssr/ssrparser.mlg +++ b/plugins/ssr/ssrparser.mlg @@ -74,11 +74,11 @@ let frozen_lexer = CLexer.get_keyword_state () ;; let tacltop = (5,Notation_gram.E) -let pr_ssrtacarg _ _ prt = prt tacltop +let pr_ssrtacarg env sigma _ _ prt = prt env sigma tacltop } -ARGUMENT EXTEND ssrtacarg TYPED AS tactic PRINTED BY { pr_ssrtacarg } +ARGUMENT EXTEND ssrtacarg TYPED AS tactic PRINTED BY { pr_ssrtacarg env sigma } | [ "YouShouldNotTypeThis" ] -> { CErrors.anomaly (Pp.str "Grammar placeholder match") } END GRAMMAR EXTEND Gram @@ -89,12 +89,12 @@ END { (* Lexically closed tactic for tacticals. *) -let pr_ssrtclarg _ _ prt tac = prt tacltop tac +let pr_ssrtclarg env sigma _ _ prt tac = prt env sigma tacltop tac } ARGUMENT EXTEND ssrtclarg TYPED AS ssrtacarg - PRINTED BY { pr_ssrtclarg } + PRINTED BY { pr_ssrtclarg env sigma } | [ ssrtacarg(tac) ] -> { tac } END @@ -109,7 +109,7 @@ let add_genarg tag pr = let glob ist x = (ist, x) in let subst _ x = x in let interp ist x = Ftactic.return (Geninterp.Val.Dyn (tag, x)) in - let gen_pr _ _ _ = pr in + let gen_pr env sigma _ _ _ = pr env sigma in let () = Genintern.register_intern0 wit glob in let () = Genintern.register_subst0 wit subst in let () = Geninterp.register_interp0 wit interp in @@ -146,7 +146,7 @@ let pr_list = prlist_with_sep let pr_ssrhyp _ _ _ = pr_hyp -let wit_ssrhyprep = add_genarg "ssrhyprep" pr_hyp +let wit_ssrhyprep = add_genarg "ssrhyprep" (fun env sigma -> pr_hyp) let intern_hyp ist (SsrHyp (loc, id) as hyp) = let _ = Tacintern.intern_genarg ist (in_gen (rawwit wit_var) CAst.(make ?loc id)) in @@ -168,7 +168,7 @@ END let pr_hoi = hoik pr_hyp let pr_ssrhoi _ _ _ = pr_hoi -let wit_ssrhoirep = add_genarg "ssrhoirep" pr_hoi +let wit_ssrhoirep = add_genarg "ssrhoirep" (fun env sigma -> pr_hoi) let intern_ssrhoi ist = function | Hyp h -> Hyp (intern_hyp ist h) @@ -212,13 +212,13 @@ END let pr_rwdir = function L2R -> mt() | R2L -> str "-" -let wit_ssrdir = add_genarg "ssrdir" pr_dir +let wit_ssrdir = add_genarg "ssrdir" (fun env sigma -> pr_dir) (** Simpl switch *) let pr_ssrsimpl _ _ _ = pr_simpl -let wit_ssrsimplrep = add_genarg "ssrsimplrep" pr_simpl +let wit_ssrsimplrep = add_genarg "ssrsimplrep" (fun env sigma -> pr_simpl) let test_ssrslashnum b1 b2 strm = match Util.stream_nth 0 strm with @@ -413,7 +413,7 @@ END let pr_mmod = function May -> str "?" | Must -> str "!" | Once -> mt () -let wit_ssrmmod = add_genarg "ssrmmod" pr_mmod +let wit_ssrmmod = add_genarg "ssrmmod" (fun env sigma -> pr_mmod) let ssrmmod = Pcoq.create_generic_entry Pcoq.utactic "ssrmmod" (Genarg.rawwit wit_ssrmmod);; } @@ -643,7 +643,7 @@ and map_block map_id = function | SuffixNum _ as x -> x type ssripatrep = ssripat -let wit_ssripatrep = add_genarg "ssripatrep" pr_ipat +let wit_ssripatrep = add_genarg "ssripatrep" (fun env sigma -> pr_ipat) let pr_ssripat _ _ _ = pr_ipat let pr_ssripats _ _ _ = pr_ipats @@ -950,13 +950,13 @@ END { -let pr_ssrintrosarg _ _ prt (tac, ipats) = - prt tacltop tac ++ pr_intros spc ipats +let pr_ssrintrosarg env sigma _ _ prt (tac, ipats) = + prt env sigma tacltop tac ++ pr_intros spc ipats } ARGUMENT EXTEND ssrintrosarg TYPED AS (tactic * ssrintros) - PRINTED BY { pr_ssrintrosarg } + PRINTED BY { pr_ssrintrosarg env sigma } | [ "YouShouldNotTypeThis" ssrtacarg(arg) ssrintros_ne(ipats) ] -> { arg, ipats } END @@ -1007,22 +1007,22 @@ GRAMMAR EXTEND Gram { -let pr_ortacs prt = +let pr_ortacs env sigma prt = let rec pr_rec = function | [None] -> spc() ++ str "|" ++ spc() | None :: tacs -> spc() ++ str "|" ++ pr_rec tacs - | Some tac :: tacs -> spc() ++ str "| " ++ prt tacltop tac ++ pr_rec tacs + | Some tac :: tacs -> spc() ++ str "| " ++ prt env sigma tacltop tac ++ pr_rec tacs | [] -> mt() in function | [None] -> spc() | None :: tacs -> pr_rec tacs - | Some tac :: tacs -> prt tacltop tac ++ pr_rec tacs + | Some tac :: tacs -> prt env sigma tacltop tac ++ pr_rec tacs | [] -> mt() -let pr_ssrortacs _ _ = pr_ortacs +let pr_ssrortacs env sigma _ _ = pr_ortacs env sigma } -ARGUMENT EXTEND ssrortacs TYPED AS tactic option list PRINTED BY { pr_ssrortacs } +ARGUMENT EXTEND ssrortacs TYPED AS tactic option list PRINTED BY { pr_ssrortacs env sigma } | [ ssrtacarg(tac) "|" ssrortacs(tacs) ] -> { Some tac :: tacs } | [ ssrtacarg(tac) "|" ] -> { [Some tac; None] } | [ ssrtacarg(tac) ] -> { [Some tac] } @@ -1032,34 +1032,34 @@ END { -let pr_hintarg prt = function - | true, tacs -> hv 0 (str "[ " ++ pr_ortacs prt tacs ++ str " ]") - | false, [Some tac] -> prt tacltop tac +let pr_hintarg env sigma prt = function + | true, tacs -> hv 0 (str "[ " ++ pr_ortacs env sigma prt tacs ++ str " ]") + | false, [Some tac] -> prt env sigma tacltop tac | _, _ -> mt() -let pr_ssrhintarg _ _ = pr_hintarg +let pr_ssrhintarg env sigma _ _ = pr_hintarg env sigma } -ARGUMENT EXTEND ssrhintarg TYPED AS (bool * ssrortacs) PRINTED BY { pr_ssrhintarg } +ARGUMENT EXTEND ssrhintarg TYPED AS (bool * ssrortacs) PRINTED BY { pr_ssrhintarg env sigma } | [ "[" "]" ] -> { nullhint } | [ "[" ssrortacs(tacs) "]" ] -> { mk_orhint tacs } | [ ssrtacarg(arg) ] -> { mk_hint arg } END -ARGUMENT EXTEND ssrortacarg TYPED AS ssrhintarg PRINTED BY { pr_ssrhintarg } +ARGUMENT EXTEND ssrortacarg TYPED AS ssrhintarg PRINTED BY { pr_ssrhintarg env sigma } | [ "[" ssrortacs(tacs) "]" ] -> { mk_orhint tacs } END { -let pr_hint prt arg = - if arg = nohint then mt() else str "by " ++ pr_hintarg prt arg -let pr_ssrhint _ _ = pr_hint +let pr_hint env sigma prt arg = + if arg = nohint then mt() else str "by " ++ pr_hintarg env sigma prt arg +let pr_ssrhint env sigma _ _ = pr_hint env sigma } -ARGUMENT EXTEND ssrhint TYPED AS ssrhintarg PRINTED BY { pr_ssrhint } +ARGUMENT EXTEND ssrhint TYPED AS ssrhintarg PRINTED BY { pr_ssrhint env sigma } | [ ] -> { nohint } END (** The "in" pseudo-tactical *) @@ -1117,7 +1117,7 @@ let pr_clseq = function | InHypsSeq -> str " |-" | InAllHyps -> str "* |-" -let wit_ssrclseq = add_genarg "ssrclseq" pr_clseq +let wit_ssrclseq = add_genarg "ssrclseq" (fun env sigma -> pr_clseq) let pr_clausehyps = pr_list pr_spc pr_wgen let pr_ssrclausehyps _ _ _ = pr_clausehyps @@ -1220,7 +1220,7 @@ let pr_fwdkind = function | FwdHint (s,_) -> str (s ^ " ") | _ -> str " :=" ++ spc () let pr_fwdfmt (fk, _ : ssrfwdfmt) = pr_fwdkind fk -let wit_ssrfwdfmt = add_genarg "ssrfwdfmt" pr_fwdfmt +let wit_ssrfwdfmt = add_genarg "ssrfwdfmt" (fun env sigma -> pr_fwdfmt) (* type ssrfwd = ssrfwdfmt * ssrterm *) @@ -1283,11 +1283,11 @@ END { -let pr_ssrbvar prc _ _ v = prc v +let pr_ssrbvar env sigma prc _ _ v = prc env sigma v } -ARGUMENT EXTEND ssrbvar TYPED AS constr PRINTED BY { pr_ssrbvar } +ARGUMENT EXTEND ssrbvar TYPED AS constr PRINTED BY { pr_ssrbvar env sigma } | [ ident(id) ] -> { mkCVar ~loc id } | [ "_" ] -> { mkCHole (Some loc) } END @@ -1299,11 +1299,11 @@ let bvar_lname = let open CAst in function CAst.make ?loc:qid.CAst.loc @@ Name (qualid_basename qid) | { loc = loc } -> CAst.make ?loc Anonymous -let pr_ssrbinder prc _ _ (_, c) = prc c +let pr_ssrbinder env sigma prc _ _ (_, c) = prc env sigma c } -ARGUMENT EXTEND ssrbinder TYPED AS (ssrfwdfmt * constr) PRINTED BY { pr_ssrbinder } +ARGUMENT EXTEND ssrbinder TYPED AS (ssrfwdfmt * constr) PRINTED BY { pr_ssrbinder env sigma } | [ ssrbvar(bv) ] -> { let { CAst.loc=xloc } as x = bvar_lname bv in (FwdPose, [BFvar]), @@ -1474,11 +1474,11 @@ END { -let pr_ssrhavefwd _ _ prt (fwd, hint) = pr_fwd fwd ++ pr_hint prt hint +let pr_ssrhavefwd env sigma _ _ prt (fwd, hint) = pr_fwd fwd ++ pr_hint env sigma prt hint } -ARGUMENT EXTEND ssrhavefwd TYPED AS (ssrfwd * ssrhint) PRINTED BY { pr_ssrhavefwd } +ARGUMENT EXTEND ssrhavefwd TYPED AS (ssrfwd * ssrhint) PRINTED BY { pr_ssrhavefwd env sigma } | [ ":" ast_closure_lterm(t) ssrhint(hint) ] -> { mkFwdHint ":" t, hint } | [ ":" ast_closure_lterm(t) ":=" ast_closure_lterm(c) ] -> { mkFwdCast FwdHave ~loc t ~c, nohint } | [ ":" ast_closure_lterm(t) ":=" ] -> { mkFwdHintNoTC ":" t, nohint } @@ -1503,14 +1503,14 @@ let binder_to_intro_id = CAst.(List.map (function | (FwdPose, [BFdef]), { v = CLetIn ({v=Anonymous},_,_,_) } -> [IPatAnon (One None)] | _ -> anomaly "ssrbinder is not a binder")) -let pr_ssrhavefwdwbinders _ _ prt (tr,((hpats, (fwd, hint)))) = - pr_hpats hpats ++ pr_fwd fwd ++ pr_hint prt hint +let pr_ssrhavefwdwbinders env sigma _ _ prt (tr,((hpats, (fwd, hint)))) = + pr_hpats hpats ++ pr_fwd fwd ++ pr_hint env sigma prt hint } ARGUMENT EXTEND ssrhavefwdwbinders TYPED AS (bool * (ssrhpats * (ssrfwd * ssrhint))) - PRINTED BY { pr_ssrhavefwdwbinders } + PRINTED BY { pr_ssrhavefwdwbinders env sigma } | [ ssrhpats_wtransp(trpats) ssrbinder_list(bs) ssrhavefwd(fwd) ] -> { let tr, pats = trpats in let ((clr, pats), binders), simpl = pats in @@ -1522,14 +1522,14 @@ END { -let pr_ssrdoarg prc _ prt (((n, m), tac), clauses) = - pr_index n ++ pr_mmod m ++ pr_hintarg prt tac ++ pr_clauses clauses +let pr_ssrdoarg env sigma prc _ prt (((n, m), tac), clauses) = + pr_index n ++ pr_mmod m ++ pr_hintarg env sigma prt tac ++ pr_clauses clauses } ARGUMENT EXTEND ssrdoarg TYPED AS (((ssrindex * ssrmmod) * ssrhintarg) * ssrclauses) - PRINTED BY { pr_ssrdoarg } + PRINTED BY { pr_ssrdoarg env sigma } | [ "YouShouldNotTypeThis" ] -> { anomaly "Grammar placeholder match" } END @@ -1537,22 +1537,22 @@ END (* type ssrseqarg = ssrindex * (ssrtacarg * ssrtac option) *) -let pr_seqtacarg prt = function +let pr_seqtacarg env sigma prt = function | (is_first, []), _ -> str (if is_first then "first" else "last") | tac, Some dtac -> - hv 0 (pr_hintarg prt tac ++ spc() ++ str "|| " ++ prt tacltop dtac) - | tac, _ -> pr_hintarg prt tac + hv 0 (pr_hintarg env sigma prt tac ++ spc() ++ str "|| " ++ prt env sigma tacltop dtac) + | tac, _ -> pr_hintarg env sigma prt tac -let pr_ssrseqarg _ _ prt = function - | ArgArg 0, tac -> pr_seqtacarg prt tac - | i, tac -> pr_index i ++ str " " ++ pr_seqtacarg prt tac +let pr_ssrseqarg env sigma _ _ prt = function + | ArgArg 0, tac -> pr_seqtacarg env sigma prt tac + | i, tac -> pr_index i ++ str " " ++ pr_seqtacarg env sigma prt tac } (* We must parse the index separately to resolve the conflict with *) (* an unindexed tactic. *) ARGUMENT EXTEND ssrseqarg TYPED AS (ssrindex * (ssrhintarg * tactic option)) - PRINTED BY { pr_ssrseqarg } + PRINTED BY { pr_ssrseqarg env sigma } | [ "YouShouldNotTypeThis" ] -> { anomaly "Grammar placeholder match" } END @@ -2278,7 +2278,7 @@ let pr_rwkind = function | RWdef -> str "/" | RWeq -> mt () -let wit_ssrrwkind = add_genarg "ssrrwkind" pr_rwkind +let wit_ssrrwkind = add_genarg "ssrrwkind" (fun env sigma -> pr_rwkind) let pr_rule = function | RWred s, _ -> pr_simpl s @@ -2520,13 +2520,13 @@ END { -let pr_ssrsufffwdwbinders _ _ prt (hpats, (fwd, hint)) = - pr_hpats hpats ++ pr_fwd fwd ++ pr_hint prt hint +let pr_ssrsufffwdwbinders env sigma _ _ prt (hpats, (fwd, hint)) = + pr_hpats hpats ++ pr_fwd fwd ++ pr_hint env sigma prt hint } ARGUMENT EXTEND ssrsufffwd - TYPED AS (ssrhpats * (ssrfwd * ssrhint)) PRINTED BY { pr_ssrsufffwdwbinders } + TYPED AS (ssrhpats * (ssrfwd * ssrhint)) PRINTED BY { pr_ssrsufffwdwbinders env sigma } | [ ssrhpats(pats) ssrbinder_list(bs) ":" ast_closure_lterm(t) ssrhint(hint) ] -> { let ((clr, pats), binders), simpl = pats in let allbs = intro_id_to_binder binders @ bs in diff --git a/plugins/ssr/ssrparser.mli b/plugins/ssr/ssrparser.mli index 7844050272..4a872be6a5 100644 --- a/plugins/ssr/ssrparser.mli +++ b/plugins/ssr/ssrparser.mli @@ -14,13 +14,15 @@ open Ltac_plugin val ssrtacarg : Tacexpr.raw_tactic_expr Pcoq.Entry.t val wit_ssrtacarg : (Tacexpr.raw_tactic_expr, Tacexpr.glob_tactic_expr, Geninterp.Val.t) Genarg.genarg_type -val pr_ssrtacarg : 'a -> 'b -> (Notation_gram.tolerability -> 'c) -> 'c +val pr_ssrtacarg : Environ.env -> Evd.evar_map -> 'a -> 'b -> + (Environ.env -> Evd.evar_map -> Notation_gram.tolerability -> 'c) -> 'c val ssrtclarg : Tacexpr.raw_tactic_expr Pcoq.Entry.t val wit_ssrtclarg : (Tacexpr.raw_tactic_expr, Tacexpr.glob_tactic_expr, Geninterp.Val.t) Genarg.genarg_type -val pr_ssrtclarg : 'a -> 'b -> (Notation_gram.tolerability -> 'c -> 'd) -> 'c -> 'd +val pr_ssrtclarg : Environ.env -> Evd.evar_map -> 'a -> 'b -> + (Environ.env -> Evd.evar_map -> Notation_gram.tolerability -> 'c -> 'd) -> 'c -> 'd -val add_genarg : string -> ('a -> Pp.t) -> 'a Genarg.uniform_genarg_type +val add_genarg : string -> (Environ.env -> Evd.evar_map -> 'a -> Pp.t) -> 'a Genarg.uniform_genarg_type (* Parsing witnesses, needed to serialize ssreflect syntax *) open Ssrmatching_plugin diff --git a/plugins/ssr/ssrprinters.ml b/plugins/ssr/ssrprinters.ml index 38f5b7d107..5d8c94e49b 100644 --- a/plugins/ssr/ssrprinters.ml +++ b/plugins/ssr/ssrprinters.ml @@ -57,11 +57,17 @@ let pr_guarded guard prc c = let s = Format.flush_str_formatter () ^ "$" in if guard s (skip_wschars s 0) then pr_paren prc c else prc c -let prl_constr_expr = Ppconstr.pr_lconstr_expr +let prl_constr_expr = + let env = Global.env () in + let sigma = Evd.from_env env in + Ppconstr.pr_lconstr_expr env sigma let pr_glob_constr c = Printer.pr_glob_constr_env (Global.env ()) c let prl_glob_constr c = Printer.pr_lglob_constr_env (Global.env ()) c let pr_glob_constr_and_expr = function - | _, Some c -> Ppconstr.pr_constr_expr c + | _, Some c -> + let env = Global.env () in + let sigma = Evd.from_env env in + Ppconstr.pr_constr_expr env sigma c | c, None -> pr_glob_constr c let pr_term (k, c) = pr_guarded (guard_term k) pr_glob_constr_and_expr c @@ -91,7 +97,10 @@ let pr_simpl = function (* New terms *) -let pr_ast_closure_term { body } = Ppconstr.pr_constr_expr body +let pr_ast_closure_term { body } = + let env = Global.env () in + let sigma = Evd.from_env env in + Ppconstr.pr_constr_expr env sigma body let pr_view2 = pr_list mt (fun c -> str "/" ++ pr_ast_closure_term c) diff --git a/plugins/ssr/ssrtacticals.ml b/plugins/ssr/ssrtacticals.ml index f12f9fac0f..bbe7bde78b 100644 --- a/plugins/ssr/ssrtacticals.ml +++ b/plugins/ssr/ssrtacticals.ml @@ -12,6 +12,7 @@ open Names open Constr +open Context open Termops open Tacmach @@ -102,10 +103,10 @@ let endclausestac id_map clseq gl_id cl0 gl = forced && ids = [] && (not hide_goal || dc' = [] && c_hidden) in let rec unmark c = match EConstr.kind (project gl) c with | Var id when hidden_clseq clseq && id = gl_id -> cl0 - | Prod (Name id, t, c') when List.mem_assoc id id_map -> - EConstr.mkProd (Name (orig_id id), unmark t, unmark c') - | LetIn (Name id, v, t, c') when List.mem_assoc id id_map -> - EConstr.mkLetIn (Name (orig_id id), unmark v, unmark t, unmark c') + | Prod ({binder_name=Name id} as na, t, c') when List.mem_assoc id id_map -> + EConstr.mkProd ({na with binder_name=Name (orig_id id)}, unmark t, unmark c') + | LetIn ({binder_name=Name id} as na, v, t, c') when List.mem_assoc id id_map -> + EConstr.mkLetIn ({na with binder_name=Name (orig_id id)}, unmark v, unmark t, unmark c') | _ -> EConstr.map (project gl) unmark c in let utac hyp = Proofview.V82.of_tactic diff --git a/plugins/ssr/ssrvernac.mlg b/plugins/ssr/ssrvernac.mlg index 2e1554d496..d3f89147fa 100644 --- a/plugins/ssr/ssrvernac.mlg +++ b/plugins/ssr/ssrvernac.mlg @@ -198,13 +198,13 @@ type raw_glob_search_about_item = | RGlobSearchSubPattern of constr_expr | RGlobSearchString of Loc.t * string * string option -let pr_search_item = function +let pr_search_item env sigma = function | RGlobSearchString (_,s,_) -> str s - | RGlobSearchSubPattern p -> pr_constr_expr p + | RGlobSearchSubPattern p -> pr_constr_expr env sigma p let wit_ssr_searchitem = add_genarg "ssr_searchitem" pr_search_item -let pr_ssr_search_item _ _ _ = pr_search_item +let pr_ssr_search_item env sigma _ _ _ = pr_search_item env sigma (* Workaround the notation API that can only print notations *) @@ -316,7 +316,7 @@ let interp_search_notation ?loc tag okey = } ARGUMENT EXTEND ssr_search_item TYPED AS ssr_searchitem - PRINTED BY { pr_ssr_search_item } + PRINTED BY { pr_ssr_search_item env sigma } | [ string(s) ] -> { RGlobSearchString (loc,s,None) } | [ string(s) "%" preident(key) ] -> { RGlobSearchString (loc,s,Some key) } | [ constr_pattern(p) ] -> { RGlobSearchSubPattern p } @@ -324,14 +324,14 @@ END { -let pr_ssr_search_arg _ _ _ = - let pr_item (b, p) = str (if b then "-" else "") ++ pr_search_item p in +let pr_ssr_search_arg env sigma _ _ _ = + let pr_item (b, p) = str (if b then "-" else "") ++ pr_search_item env sigma p in pr_list spc pr_item } ARGUMENT EXTEND ssr_search_arg TYPED AS (bool * ssr_searchitem) list - PRINTED BY { pr_ssr_search_arg } + PRINTED BY { pr_ssr_search_arg env sigma } | [ "-" ssr_search_item(p) ssr_search_arg(a) ] -> { (false, p) :: a } | [ ssr_search_item(p) ssr_search_arg(a) ] -> { (true, p) :: a } | [ ] -> { [] } @@ -432,7 +432,7 @@ let interp_search_arg arg = let pr_modloc (b, m) = if b then str "-" ++ pr_qualid m else pr_qualid m -let wit_ssrmodloc = add_genarg "ssrmodloc" pr_modloc +let wit_ssrmodloc = add_genarg "ssrmodloc" (fun env sigma -> pr_modloc) let pr_ssr_modlocs _ _ _ ml = if ml = [] then str "" else spc () ++ str "in " ++ pr_list spc pr_modloc ml @@ -491,24 +491,23 @@ END { -let pr_raw_ssrhintref prc _ _ = let open CAst in function +let pr_raw_ssrhintref env sigma prc _ _ = let open CAst in function | { v = CAppExpl ((None, r,x), args) } when isCHoles args -> - prc (CAst.make @@ CRef (r,x)) ++ str "|" ++ int (List.length args) - | { v = CApp ((_, { v = CRef _ }), _) } as c -> prc c + prc env sigma (CAst.make @@ CRef (r,x)) ++ str "|" ++ int (List.length args) + | { v = CApp ((_, { v = CRef _ }), _) } as c -> prc env sigma c | { v = CApp ((_, c), args) } when isCxHoles args -> - prc c ++ str "|" ++ int (List.length args) - | c -> prc c + prc env sigma c ++ str "|" ++ int (List.length args) + | c -> prc env sigma c -let pr_rawhintref c = - let _, env = Pfedit.get_current_context () in +let pr_rawhintref env sigma c = match DAst.get c with | GApp (f, args) when isRHoles args -> pr_glob_constr_env env f ++ str "|" ++ int (List.length args) | _ -> pr_glob_constr_env env c -let pr_glob_ssrhintref _ _ _ (c, _) = pr_rawhintref c +let pr_glob_ssrhintref env sigma _ _ _ (c, _) = pr_rawhintref env sigma c -let pr_ssrhintref prc _ _ = prc +let pr_ssrhintref env sigma prc _ _ = prc env sigma let mkhintref ?loc c n = match c.CAst.v with | CRef (r,x) -> CAst.make ?loc @@ CAppExpl ((None, r, x), mkCHoles ?loc n) @@ -518,9 +517,9 @@ let mkhintref ?loc c n = match c.CAst.v with ARGUMENT EXTEND ssrhintref TYPED AS constr - PRINTED BY { pr_ssrhintref } - RAW_PRINTED BY { pr_raw_ssrhintref } - GLOB_PRINTED BY { pr_glob_ssrhintref } + PRINTED BY { pr_ssrhintref env sigma } + RAW_PRINTED BY { pr_raw_ssrhintref env sigma } + GLOB_PRINTED BY { pr_glob_ssrhintref env sigma } | [ constr(c) ] -> { c } | [ constr(c) "|" natural(n) ] -> { mkhintref ~loc c n } END @@ -559,19 +558,22 @@ END { -let print_view_hints kind l = +let print_view_hints env sigma kind l = let pp_viewname = str "Hint View" ++ pr_viewpos (Some kind) ++ str " " in - let pp_hints = pr_list spc pr_rawhintref l in + let pp_hints = pr_list spc (pr_rawhintref env sigma) l in Feedback.msg_info (pp_viewname ++ hov 0 pp_hints ++ Pp.cut ()) } VERNAC COMMAND EXTEND PrintView CLASSIFIED AS QUERY | [ "Print" "Hint" "View" ssrviewpos(i) ] -> - { match i with - | Some k -> print_view_hints k (Ssrview.AdaptorDb.get k) + { + let sigma, env = Pfedit.get_current_context () in + match i with + | Some k -> + print_view_hints env sigma k (Ssrview.AdaptorDb.get k) | None -> - List.iter (fun k -> print_view_hints k (Ssrview.AdaptorDb.get k)) + List.iter (fun k -> print_view_hints env sigma k (Ssrview.AdaptorDb.get k)) [ Ssrview.AdaptorDb.Forward; Ssrview.AdaptorDb.Backward; Ssrview.AdaptorDb.Equivalence ] diff --git a/plugins/ssr/ssrview.ml b/plugins/ssr/ssrview.ml index 2794696017..537fd7d7b4 100644 --- a/plugins/ssr/ssrview.ml +++ b/plugins/ssr/ssrview.ml @@ -10,6 +10,7 @@ open Util open Names +open Context open Ltac_plugin @@ -95,7 +96,7 @@ let vsBOOTSTRAP = Goal.enter_one ~__LOC__ begin fun gl -> let concl = Goal.concl gl in let id = (* We keep the orig name for checks in "in" tcl *) match EConstr.kind_of_type (Goal.sigma gl) concl with - | Term.ProdType(Name.Name id, _, _) + | Term.ProdType({binder_name=Name.Name id}, _, _) when Ssrcommon.is_discharged_id id -> id | _ -> mk_anon_id "view_subject" (Tacmach.New.pf_ids_of_hyps gl) in let view = EConstr.mkVar id in diff --git a/plugins/ssrmatching/ssrmatching.ml b/plugins/ssrmatching/ssrmatching.ml index fb99b87108..5eb106cc26 100644 --- a/plugins/ssrmatching/ssrmatching.ml +++ b/plugins/ssrmatching/ssrmatching.ml @@ -16,6 +16,7 @@ open Pp open Genarg open Stdarg open Term +open Context module CoqConstr = Constr open CoqConstr open Vars @@ -96,14 +97,20 @@ let prl_glob_constr c = pr_lglob_constr_env (Global.env ()) c let pr_glob_constr c = pr_glob_constr_env (Global.env ()) c let prl_constr_expr = pr_lconstr_expr let pr_constr_expr = pr_constr_expr -let prl_glob_constr_and_expr = function - | _, Some c -> prl_constr_expr c +let prl_glob_constr_and_expr env sigma = function + | _, Some c -> prl_constr_expr env sigma c | c, None -> prl_glob_constr c -let pr_glob_constr_and_expr = function - | _, Some c -> pr_constr_expr c +let pr_glob_constr_and_expr env sigma = function + | _, Some c -> pr_constr_expr env sigma c | c, None -> pr_glob_constr c -let pr_term (k, c, _) = pr_guarded (guard_term k) pr_glob_constr_and_expr c -let prl_term (k, c, _) = pr_guarded (guard_term k) prl_glob_constr_and_expr c +let pr_term (k, c, _) = + let env = Global.env () in + let sigma = Evd.from_env env in + pr_guarded (guard_term k) (pr_glob_constr_and_expr env sigma) c +let prl_term (k, c, _) = + let env = Global.env () in + let sigma = Evd.from_env env in + pr_guarded (guard_term k) (prl_glob_constr_and_expr env sigma) c (** Adding a new uninterpreted generic argument type *) let add_genarg tag pr = @@ -112,7 +119,7 @@ let add_genarg tag pr = let glob ist x = (ist, x) in let subst _ x = x in let interp ist x = Ftactic.return (Geninterp.Val.Dyn (tag, x)) in - let gen_pr _ _ _ = pr in + let gen_pr env sigma _ _ _ = pr env sigma in let () = Genintern.register_intern0 wit glob in let () = Genintern.register_subst0 wit subst in let () = Geninterp.register_interp0 wit interp in @@ -361,10 +368,9 @@ let isRigid c = match kind c with | _ -> false let hole_var = mkVar (Id.of_string "_") -let pr_constr_pat c0 = +let pr_constr_pat env sigma c0 = let rec wipe_evar c = if isEvar c then hole_var else map wipe_evar c in - let sigma, env = Pfedit.get_current_context () in pr_constr_env env sigma (wipe_evar c0) (* Turn (new) evars into metas *) @@ -383,7 +389,7 @@ let evars_for_FO ~hack env sigma0 (ise0:evar_map) c0 = | Context.Named.Declaration.LocalDef (x, b, t) -> d, mkNamedLetIn x (put b) (put t) c | Context.Named.Declaration.LocalAssum (x, t) -> - mkVar x :: d, mkNamedProd x (put t) c in + mkVar x.binder_name :: d, mkNamedProd x (put t) c in let a, t = Context.Named.fold_inside abs_dc ~init:([], (put @@ EConstr.Unsafe.to_constr evi.evar_concl)) @@ -416,7 +422,7 @@ let mk_tpattern ?p_origin ?(hack=false) env sigma0 (ise, t) ok dir p = (match p_origin with None -> CErrors.user_err Pp.(str "indeterminate pattern") | Some (dir, rule) -> errorstrm (str "indeterminate " ++ pr_dir_side dir - ++ str " in " ++ pr_constr_pat rule)) + ++ str " in " ++ pr_constr_pat env ise rule)) | LetIn (_, v, _, b) -> if b <> mkRel 1 then KpatLet, f, a else KpatFlex, v, a | Lambda _ -> KpatLam, f, a @@ -548,7 +554,7 @@ let match_upats_FO upats env sigma0 ise orig_c = if skip || not (closed0 c') then () else try let _ = match u.up_k with | KpatFlex -> - let kludge v = mkLambda (Anonymous, mkProp, v) in + let kludge v = mkLambda (make_annot Anonymous Sorts.Relevant, mkProp, v) in unif_FO env ise (kludge u.up_FO) (kludge c') | KpatLet -> let kludge vla = @@ -636,8 +642,8 @@ let assert_done r = let assert_done_multires r = match !r with | None -> CErrors.anomaly (str"do_once never called.") - | Some (n, xs) -> - r := Some (n+1,xs); + | Some (e, n, xs) -> + r := Some (e, n+1,xs); try List.nth xs n with Failure _ -> raise NoMatch type subst = Environ.env -> constr -> constr -> int -> constr @@ -683,14 +689,15 @@ let mk_tpattern_matcher ?(all_instances=false) | _ -> false) | _ -> unif_EQ env sigma u.up_f in let p2t p = mkApp(p.up_f,p.up_a) in -let source () = match upats_origin, upats with +let source env = match upats_origin, upats with | None, [p] -> (if fixed_upat ise p then str"term " else str"partial term ") ++ - pr_constr_pat (p2t p) ++ spc() + pr_constr_pat env ise (p2t p) ++ spc() | Some (dir,rule), [p] -> str"The " ++ pr_dir_side dir ++ str" of " ++ - pr_constr_pat rule ++ fnl() ++ ws 4 ++ pr_constr_pat (p2t p) ++ fnl() + pr_constr_pat env ise rule ++ fnl() ++ ws 4 ++ + pr_constr_pat env ise (p2t p) ++ fnl() | Some (dir,rule), _ -> str"The " ++ pr_dir_side dir ++ str" of " ++ - pr_constr_pat rule ++ spc() + pr_constr_pat env ise rule ++ spc() | _, [] | None, _::_::_ -> CErrors.anomaly (str"mk_tpattern_matcher with no upats_origin.") in let on_instance, instances = @@ -720,23 +727,23 @@ let rec uniquize = function if not all_instances then match_upats_FO upats env sigma0 ise c; failed_because_of_TC:=match_upats_HO ~on_instance upats env sigma0 ise c; raise NoMatch - with FoundUnif sigma_u -> 0,[sigma_u] + with FoundUnif sigma_u -> env,0,[sigma_u] | (NoMatch|NoProgress) when all_instances && instances () <> [] -> - 0, uniquize (instances ()) + env, 0, uniquize (instances ()) | NoMatch when (not raise_NoMatch) -> if !failed_because_of_TC then - errorstrm (source ()++strbrk"matches but type classes inference fails") + errorstrm (source env++strbrk"matches but type classes inference fails") else - errorstrm (source () ++ str "does not match any subterm of the goal") + errorstrm (source env ++ str "does not match any subterm of the goal") | NoProgress when (not raise_NoMatch) -> let dir = match upats_origin with Some (d,_) -> d | _ -> CErrors.anomaly (str"mk_tpattern_matcher with no upats_origin.") in - errorstrm (str"all matches of "++source()++ + errorstrm (str"all matches of "++source env++ str"are equal to the " ++ pr_dir_side (inv_dir dir)) | NoProgress -> raise NoMatch); let sigma, _, ({up_f = pf; up_a = pa} as u) = if all_instances then assert_done_multires upat_that_matched - else List.hd (snd(assert_done upat_that_matched)) in + else List.hd (pi3(assert_done upat_that_matched)) in (* pp(lazy(str"sigma@tmatch=" ++ pr_evar_map None sigma)); *) if !skip_occ then ((*ignore(k env u.up_t 0);*) c) else let match_EQ = match_EQ env sigma u in @@ -765,18 +772,18 @@ let rec uniquize = function mkApp (f', Array.map_left (subst_loop acc) a) in subst_loop (env,h) c) : find_P), ((fun () -> - let sigma, uc, ({up_f = pf; up_a = pa} as u) = + let env, (sigma, uc, ({up_f = pf; up_a = pa} as u)) = match !upat_that_matched with - | Some (_,x) -> List.hd x | None when raise_NoMatch -> raise NoMatch + | Some (env,_,x) -> env,List.hd x | None when raise_NoMatch -> raise NoMatch | None -> CErrors.anomaly (str"companion function never called.") in let p' = mkApp (pf, pa) in if max_occ <= !nocc then p', u.up_dir, (sigma, uc, u.up_t) else errorstrm (str"Only " ++ int !nocc ++ str" < " ++ int max_occ ++ str(String.plural !nocc " occurrence") ++ match upats_origin with - | None -> str" of" ++ spc() ++ pr_constr_pat p' + | None -> str" of" ++ spc() ++ pr_constr_pat env sigma p' | Some (dir,rule) -> str" of the " ++ pr_dir_side dir ++ fnl() ++ - ws 4 ++ pr_constr_pat p' ++ fnl () ++ - str"of " ++ pr_constr_pat rule)) : conclude) + ws 4 ++ pr_constr_pat env sigma p' ++ fnl () ++ + str"of " ++ pr_constr_pat env sigma rule)) : conclude) type ('ident, 'term) ssrpattern = | T of 'term @@ -815,11 +822,11 @@ let pr_pattern_aux pr_constr = function pr_constr e ++ str " in " ++ pr_constr x ++ str " in " ++ pr_constr t | E_As_X_In_T (e,x,t) -> pr_constr e ++ str " as " ++ pr_constr x ++ str " in " ++ pr_constr t -let pp_pattern (sigma, p) = - pr_pattern_aux (fun t -> pr_constr_pat (EConstr.Unsafe.to_constr (pi3 (nf_open_term sigma sigma (EConstr.of_constr t))))) p +let pp_pattern env (sigma, p) = + pr_pattern_aux (fun t -> pr_constr_pat env sigma (EConstr.Unsafe.to_constr (pi3 (nf_open_term sigma sigma (EConstr.of_constr t))))) p let pr_cpattern = pr_term -let wit_rpatternty = add_genarg "rpatternty" pr_pattern +let wit_rpatternty = add_genarg "rpatternty" (fun env sigma -> pr_pattern) let glob_ssrterm gs = function | k, (_, Some c), None -> @@ -1246,8 +1253,10 @@ let fill_occ_term env cl occ sigma0 (sigma, t) = if sigma' != sigma0 then raise NoMatch else cl, (Evd.merge_universe_context sigma' uc, t') with _ -> - errorstrm (str "partial term " ++ pr_constr_pat (EConstr.Unsafe.to_constr t) - ++ str " does not match any subterm of the goal") + errorstrm (str "partial term " ++ + pr_constr_pat env sigma + (EConstr.to_constr ~abort_on_undefined_evars:false sigma t) ++ + str " does not match any subterm of the goal") let pf_fill_occ_term gl occ t = let sigma0 = project gl and env = pf_env gl and concl = pf_concl gl in @@ -1286,7 +1295,7 @@ let ssrpatterntac _ist arg gl = let t = EConstr.of_constr t in let concl_x = EConstr.of_constr concl_x in let gl, tty = pf_type_of gl t in - let concl = EConstr.mkLetIn (Name (Id.of_string "selected"), t, tty, concl_x) in + let concl = EConstr.mkLetIn (make_annot (Name (Id.of_string "selected")) Sorts.Relevant, t, tty, concl_x) in Proofview.V82.of_tactic (convert_concl concl DEFAULTcast) gl (* Register "ssrpattern" tactic *) diff --git a/plugins/ssrmatching/ssrmatching.mli b/plugins/ssrmatching/ssrmatching.mli index ff2c900130..1143bcc813 100644 --- a/plugins/ssrmatching/ssrmatching.mli +++ b/plugins/ssrmatching/ssrmatching.mli @@ -46,7 +46,7 @@ type ('ident, 'term) ssrpattern = | E_As_X_In_T of 'term * 'ident * 'term type pattern = evar_map * (constr, constr) ssrpattern -val pp_pattern : pattern -> Pp.t +val pp_pattern : env -> pattern -> Pp.t (** Extracts the redex and applies to it the substitution part of the pattern. @raise Anomaly if called on [In_T] or [In_X_In_T] *) @@ -222,7 +222,7 @@ val loc_of_cpattern : cpattern -> Loc.t option val id_of_pattern : pattern -> Names.Id.t option val is_wildcard : cpattern -> bool val cpattern_of_id : Names.Id.t -> cpattern -val pr_constr_pat : constr -> Pp.t +val pr_constr_pat : env -> evar_map -> constr -> Pp.t val pf_merge_uc : UState.t -> goal Evd.sigma -> goal Evd.sigma val pf_unsafe_merge_uc : UState.t -> goal Evd.sigma -> goal Evd.sigma diff --git a/plugins/syntax/g_numeral.mlg b/plugins/syntax/g_numeral.mlg index 13e0bcbd47..73a2b99434 100644 --- a/plugins/syntax/g_numeral.mlg +++ b/plugins/syntax/g_numeral.mlg @@ -37,5 +37,6 @@ END VERNAC COMMAND EXTEND NumeralNotation CLASSIFIED AS SIDEFF | #[ locality = Attributes.locality; ] [ "Numeral" "Notation" reference(ty) reference(f) reference(g) ":" ident(sc) numnotoption(o) ] -> - { vernac_numeral_notation (Locality.make_module_locality locality) ty f g (Id.to_string sc) o } + { let (sigma, env) = Pfedit.get_current_context () in + vernac_numeral_notation env sigma (Locality.make_module_locality locality) ty f g (Id.to_string sc) o } END diff --git a/plugins/syntax/g_string.mlg b/plugins/syntax/g_string.mlg index 1e06cd8ddb..171e0e213d 100644 --- a/plugins/syntax/g_string.mlg +++ b/plugins/syntax/g_string.mlg @@ -21,5 +21,6 @@ open Stdarg VERNAC COMMAND EXTEND StringNotation CLASSIFIED AS SIDEFF | #[ locality = Attributes.locality; ] [ "String" "Notation" reference(ty) reference(f) reference(g) ":" ident(sc) ] -> - { vernac_string_notation (Locality.make_module_locality locality) ty f g (Id.to_string sc) } + { let (sigma, env) = Pfedit.get_current_context () in + vernac_string_notation env sigma (Locality.make_module_locality locality) ty f g (Id.to_string sc) } END diff --git a/plugins/syntax/numeral.ml b/plugins/syntax/numeral.ml index 0c6d2ac0d1..525056e5f1 100644 --- a/plugins/syntax/numeral.ml +++ b/plugins/syntax/numeral.ml @@ -77,8 +77,7 @@ let locate_int63 () = Some (mkRefC q_int63) else None -let has_type f ty = - let (sigma, env) = Pfedit.get_current_context () in +let has_type env sigma f ty = let c = mkCastC (mkRefC f, Glob_term.CastConv ty) in try let _ = Constrintern.interp_constr env sigma c in true with Pretype_errors.PretypeError _ -> false @@ -95,7 +94,7 @@ let type_error_of g ty = str " to Decimal.int or (option Decimal.int)." ++ fnl () ++ str "Instead of Decimal.int, the types Decimal.uint or Z or Int63.int could be used (you may need to require BinNums or Decimal or Int63 first).") -let vernac_numeral_notation local ty f g scope opts = +let vernac_numeral_notation env sigma local ty f g scope opts = let int_ty = locate_int () in let z_pos_ty = locate_z () in let int63_ty = locate_int63 () in @@ -112,35 +111,35 @@ let vernac_numeral_notation local ty f g scope opts = (* Check the type of f *) let to_kind = match int_ty with - | Some (int_ty, cint, _) when has_type f (arrow cint cty) -> Int int_ty, Direct - | Some (int_ty, cint, _) when has_type f (arrow cint (opt cty)) -> Int int_ty, Option - | Some (int_ty, _, cuint) when has_type f (arrow cuint cty) -> UInt int_ty.uint, Direct - | Some (int_ty, _, cuint) when has_type f (arrow cuint (opt cty)) -> UInt int_ty.uint, Option + | Some (int_ty, cint, _) when has_type env sigma f (arrow cint cty) -> Int int_ty, Direct + | Some (int_ty, cint, _) when has_type env sigma f (arrow cint (opt cty)) -> Int int_ty, Option + | Some (int_ty, _, cuint) when has_type env sigma f (arrow cuint cty) -> UInt int_ty.uint, Direct + | Some (int_ty, _, cuint) when has_type env sigma f (arrow cuint (opt cty)) -> UInt int_ty.uint, Option | _ -> match z_pos_ty with - | Some (z_pos_ty, cZ) when has_type f (arrow cZ cty) -> Z z_pos_ty, Direct - | Some (z_pos_ty, cZ) when has_type f (arrow cZ (opt cty)) -> Z z_pos_ty, Option + | Some (z_pos_ty, cZ) when has_type env sigma f (arrow cZ cty) -> Z z_pos_ty, Direct + | Some (z_pos_ty, cZ) when has_type env sigma f (arrow cZ (opt cty)) -> Z z_pos_ty, Option | _ -> match int63_ty with - | Some cint63 when has_type f (arrow cint63 cty) -> Int63, Direct - | Some cint63 when has_type f (arrow cint63 (opt cty)) -> Int63, Option + | Some cint63 when has_type env sigma f (arrow cint63 cty) -> Int63, Direct + | Some cint63 when has_type env sigma f (arrow cint63 (opt cty)) -> Int63, Option | _ -> type_error_to f ty in (* Check the type of g *) let of_kind = match int_ty with - | Some (int_ty, cint, _) when has_type g (arrow cty cint) -> Int int_ty, Direct - | Some (int_ty, cint, _) when has_type g (arrow cty (opt cint)) -> Int int_ty, Option - | Some (int_ty, _, cuint) when has_type g (arrow cty cuint) -> UInt int_ty.uint, Direct - | Some (int_ty, _, cuint) when has_type g (arrow cty (opt cuint)) -> UInt int_ty.uint, Option + | Some (int_ty, cint, _) when has_type env sigma g (arrow cty cint) -> Int int_ty, Direct + | Some (int_ty, cint, _) when has_type env sigma g (arrow cty (opt cint)) -> Int int_ty, Option + | Some (int_ty, _, cuint) when has_type env sigma g (arrow cty cuint) -> UInt int_ty.uint, Direct + | Some (int_ty, _, cuint) when has_type env sigma g (arrow cty (opt cuint)) -> UInt int_ty.uint, Option | _ -> match z_pos_ty with - | Some (z_pos_ty, cZ) when has_type g (arrow cty cZ) -> Z z_pos_ty, Direct - | Some (z_pos_ty, cZ) when has_type g (arrow cty (opt cZ)) -> Z z_pos_ty, Option + | Some (z_pos_ty, cZ) when has_type env sigma g (arrow cty cZ) -> Z z_pos_ty, Direct + | Some (z_pos_ty, cZ) when has_type env sigma g (arrow cty (opt cZ)) -> Z z_pos_ty, Option | _ -> match int63_ty with - | Some cint63 when has_type g (arrow cty cint63) -> Int63, Direct - | Some cint63 when has_type g (arrow cty (opt cint63)) -> Int63, Option + | Some cint63 when has_type env sigma g (arrow cty cint63) -> Int63, Direct + | Some cint63 when has_type env sigma g (arrow cty (opt cint63)) -> Int63, Option | _ -> type_error_of g ty in let o = { to_kind; to_ty; of_kind; of_ty; diff --git a/plugins/syntax/numeral.mli b/plugins/syntax/numeral.mli index f96b8321f8..b14ed18497 100644 --- a/plugins/syntax/numeral.mli +++ b/plugins/syntax/numeral.mli @@ -14,4 +14,6 @@ open Notation (** * Numeral notation *) -val vernac_numeral_notation : locality_flag -> qualid -> qualid -> qualid -> Notation_term.scope_name -> numnot_option -> unit +val vernac_numeral_notation : Environ.env -> Evd.evar_map -> locality_flag -> + qualid -> qualid -> qualid -> + Notation_term.scope_name -> numnot_option -> unit diff --git a/plugins/syntax/string_notation.ml b/plugins/syntax/string_notation.ml index 12ee4c6eda..5fae696d58 100644 --- a/plugins/syntax/string_notation.ml +++ b/plugins/syntax/string_notation.ml @@ -32,8 +32,7 @@ let q_option () = qualid_of_ref "core.option.type" let q_list () = qualid_of_ref "core.list.type" let q_byte () = qualid_of_ref "core.byte.type" -let has_type f ty = - let (sigma, env) = Pfedit.get_current_context () in +let has_type env sigma f ty = let c = mkCastC (mkRefC f, Glob_term.CastConv ty) in try let _ = Constrintern.interp_constr env sigma c in true with Pretype_errors.PretypeError _ -> false @@ -48,7 +47,7 @@ let type_error_of g ty = (pr_qualid g ++ str " should go from " ++ pr_qualid ty ++ str " to Byte.byte or (option Byte.byte) or (list Byte.byte) or (option (list Byte.byte)).") -let vernac_string_notation local ty f g scope = +let vernac_string_notation env sigma local ty f g scope = let app x y = mkAppC (x,[y]) in let cref q = mkRefC q in let cbyte = cref (q_byte ()) in @@ -66,18 +65,18 @@ let vernac_string_notation local ty f g scope = let constructors = get_constructors tyc in (* Check the type of f *) let to_kind = - if has_type f (arrow clist_byte cty) then ListByte, Direct - else if has_type f (arrow clist_byte (opt cty)) then ListByte, Option - else if has_type f (arrow cbyte cty) then Byte, Direct - else if has_type f (arrow cbyte (opt cty)) then Byte, Option + if has_type env sigma f (arrow clist_byte cty) then ListByte, Direct + else if has_type env sigma f (arrow clist_byte (opt cty)) then ListByte, Option + else if has_type env sigma f (arrow cbyte cty) then Byte, Direct + else if has_type env sigma f (arrow cbyte (opt cty)) then Byte, Option else type_error_to f ty in (* Check the type of g *) let of_kind = - if has_type g (arrow cty clist_byte) then ListByte, Direct - else if has_type g (arrow cty (opt clist_byte)) then ListByte, Option - else if has_type g (arrow cty cbyte) then Byte, Direct - else if has_type g (arrow cty (opt cbyte)) then Byte, Option + if has_type env sigma g (arrow cty clist_byte) then ListByte, Direct + else if has_type env sigma g (arrow cty (opt clist_byte)) then ListByte, Option + else if has_type env sigma g (arrow cty cbyte) then Byte, Direct + else if has_type env sigma g (arrow cty (opt cbyte)) then Byte, Option else type_error_of g ty in let o = { to_kind = to_kind; diff --git a/plugins/syntax/string_notation.mli b/plugins/syntax/string_notation.mli index 9a0174abf2..e81de603d9 100644 --- a/plugins/syntax/string_notation.mli +++ b/plugins/syntax/string_notation.mli @@ -13,4 +13,6 @@ open Vernacexpr (** * String notation *) -val vernac_string_notation : locality_flag -> qualid -> qualid -> qualid -> Notation_term.scope_name -> unit +val vernac_string_notation : Environ.env -> Evd.evar_map -> locality_flag -> + qualid -> qualid -> qualid -> + Notation_term.scope_name -> unit diff --git a/pretyping/arguments_renaming.ml b/pretyping/arguments_renaming.ml index 08df9a2460..3b3de33d8e 100644 --- a/pretyping/arguments_renaming.ml +++ b/pretyping/arguments_renaming.ml @@ -13,6 +13,7 @@ open Names open Globnames open Term open Constr +open Context open Environ open Util open Libobject @@ -72,7 +73,7 @@ let arguments_names r = GlobRef.Map.find r !name_table let rename_type ty ref = let name_override old_name override = match override with - | Name _ as x -> x + | Name _ as x -> {old_name with binder_name=x} | Anonymous -> old_name in let rec rename_type_aux c = function | [] -> c diff --git a/pretyping/cases.ml b/pretyping/cases.ml index 069ba9572a..e22368d5e5 100644 --- a/pretyping/cases.ml +++ b/pretyping/cases.ml @@ -16,6 +16,7 @@ open Util open Names open Nameops open Constr +open Context open Termops open Environ open EConstr @@ -472,7 +473,8 @@ let push_current_pattern ~program_mode sigma (cur,ty) eqn = let hypnaming = if program_mode then ProgramNaming else KeepUserNameAndRenameExistingButSectionNames in match eqn.patterns with | pat::pats -> - let _,rhs_env = push_rel ~hypnaming sigma (LocalDef (alias_of_pat pat,cur,ty)) eqn.rhs.rhs_env in + let r = Sorts.Relevant in (* TODO relevance *) + let _,rhs_env = push_rel ~hypnaming sigma (LocalDef (make_annot (alias_of_pat pat) r,cur,ty)) eqn.rhs.rhs_env in { eqn with rhs = { eqn.rhs with rhs_env = rhs_env }; patterns = pats } @@ -762,7 +764,10 @@ let get_names avoid env sigma sign eqns = (fun (l,avoid) d na -> let na = merge_name - (fun (LocalAssum (na,t) | LocalDef (na,_,t)) -> Name (next_name_away (named_hd env sigma t na) avoid)) + (fun decl -> + let na = get_name decl in + let t = get_type decl in + Name (next_name_away (named_hd env sigma t na) avoid)) d na in (na::l,Id.Set.add (Name.get_id na) avoid)) @@ -782,10 +787,10 @@ let recover_and_adjust_alias_names (_,avoid) names sign = let rec aux = function | [],[] -> [] - | x::names, LocalAssum (_,t)::sign -> - (x, LocalAssum (alias_of_pat x,t)) :: aux (names,sign) + | x::names, LocalAssum (x',t)::sign -> + (x, LocalAssum ({x' with binder_name=alias_of_pat x},t)) :: aux (names,sign) | names, (LocalDef (na,_,_) as decl)::sign -> - (DAst.make @@ PatVar na, decl) :: aux (names,sign) + (DAst.make @@ PatVar na.binder_name, decl) :: aux (names,sign) | _ -> assert false in List.split (aux (names,sign)) @@ -1247,7 +1252,7 @@ let rec generalize_problem names sigma pb = function let pb',deps = generalize_problem names sigma pb l in let d = map_constr (lift i) (lookup_rel i !!(pb.env)) in begin match d with - | LocalDef (Anonymous,_,_) -> pb', deps + | LocalDef ({binder_name=Anonymous},_,_) -> pb', deps | _ -> (* for better rendering *) let d = RelDecl.map_type (fun c -> whd_betaiota sigma c) d in @@ -1436,16 +1441,15 @@ let compile ~program_mode sigma pb = brvals pb.tomatch pb.pred deps cstrs in let brvals = Array.map (fun (sign,body) -> it_mkLambda_or_LetIn body sign) brvals in - let (pred,typ) = + let (pred,typ) = find_predicate pb.caseloc pb.env sigma - pred current indt (names,dep) tomatch in - let ci = make_case_info !!(pb.env) (fst mind) pb.casestyle in + pred current indt (names,dep) tomatch + in + let rci = Typing.check_allowed_sort !!(pb.env) sigma mind current pred in + let ci = make_case_info !!(pb.env) (fst mind) rci pb.casestyle in let pred = nf_betaiota !!(pb.env) sigma pred in - let case = - make_case_or_project !!(pb.env) sigma indf ci pred current brvals - in + let case = make_case_or_project !!(pb.env) sigma indf ci pred current brvals in let sigma, _ = Typing.type_of !!(pb.env) sigma pred in - Typing.check_allowed_sort !!(pb.env) sigma mind current pred; sigma, { uj_val = applist (case, inst); uj_type = prod_applist sigma typ inst } @@ -1460,7 +1464,7 @@ let compile ~program_mode sigma pb = let hypnaming = if program_mode then ProgramNaming else KeepUserNameAndRenameExistingButSectionNames in let pb = { pb with - env = snd (push_rel ~hypnaming sigma (LocalDef (na,current,ty)) env); + env = snd (push_rel ~hypnaming sigma (LocalDef (annotR na,current,ty)) env); tomatch = tomatch; pred = lift_predicate 1 pred tomatch; history = pop_history pb.history; @@ -1511,7 +1515,8 @@ let compile ~program_mode sigma pb = and compile_alias initial sigma pb (na,orig,(expanded,expanded_typ)) rest = let hypnaming = if program_mode then ProgramNaming else KeepUserNameAndRenameExistingButSectionNames in let f c t = - let alias = LocalDef (na,c,t) in + let r = Retyping.relevance_of_type !!(pb.env) sigma t in + let alias = LocalDef (make_annot na r,c,t) in let pb = { pb with env = snd (push_rel ~hypnaming sigma alias pb.env); @@ -1524,7 +1529,7 @@ let compile ~program_mode sigma pb = if isRel sigma c || isVar sigma c || count_occurrences sigma (mkRel 1) j.uj_val <= 1 then subst1 c j.uj_val else - mkLetIn (na,c,t,j.uj_val); + mkLetIn (make_annot na r,c,t,j.uj_val); uj_type = subst1 c j.uj_type } in (* spiwack: when an alias appears on a deep branch, its non-expanded form is automatically a variable of the same name. We avoid @@ -1812,7 +1817,7 @@ let build_inversion_problem ~program_mode loc env sigma tms t = List.rev_append patl patl',acc_sign,acc | (t, NotInd (bo,typ)) :: tms -> let pat,acc = make_patvar t acc in - let d = LocalAssum (alias_of_pat pat,typ) in + let d = LocalAssum (annotR (alias_of_pat pat),typ) in let patl,acc_sign,acc = aux (n+1) (snd (push_rel ~hypnaming:KeepUserNameAndRenameExistingButSectionNames sigma d env)) (d::acc_sign) tms acc in pat::patl,acc_sign,acc in let avoid0 = GlobEnv.vars_of_env env in @@ -1913,9 +1918,11 @@ let extract_arity_signature ?(dolift=true) env0 tomatchl tmsign = match tm with | NotInd (bo,typ) -> (match t with - | None -> let sign = match bo with - | None -> [LocalAssum (na, lift n typ)] - | Some b -> [LocalDef (na, lift n b, lift n typ)] in sign + | None -> + let r = Sorts.Relevant in (* TODO relevance *) + let sign = match bo with + | None -> [LocalAssum (make_annot na r, lift n typ)] + | Some b -> [LocalDef (make_annot na r, lift n b, lift n typ)] in sign | Some {CAst.loc} -> user_err ?loc (str"Unexpected type annotation for a term of non inductive type.")) @@ -1923,7 +1930,7 @@ let extract_arity_signature ?(dolift=true) env0 tomatchl tmsign = let indf' = if dolift then lift_inductive_family n indf else indf in let ((ind,u),_) = dest_ind_family indf' in let nrealargs_ctxt = inductive_nrealdecls_env env0 ind in - let arsign = fst (get_arity env0 indf') in + let arsign, inds = get_arity env0 indf' in let arsign = List.map (fun d -> map_rel_decl EConstr.of_constr d) arsign in let realnal = match t with @@ -1935,8 +1942,9 @@ let extract_arity_signature ?(dolift=true) env0 tomatchl tmsign = List.rev realnal | None -> List.make nrealargs_ctxt Anonymous in + let r = Sorts.relevance_of_sort_family inds in let t = EConstr.of_constr (build_dependent_inductive env0 indf') in - LocalAssum (na, t) :: List.map2 RelDecl.set_name realnal arsign in + LocalAssum (make_annot na r, t) :: List.map2 RelDecl.set_name realnal arsign in let rec buildrec n = function | [],[] -> [] | (_,tm)::ltm, (_,x)::tmsign -> @@ -2143,9 +2151,10 @@ let constr_of_pat env sigma arsign pat avoid = | Anonymous -> let previd, id = prime avoid (Name (Id.of_string "wildcard")) in Name id, Id.Set.add id avoid - in - (sigma, (DAst.make ?loc @@ PatVar name), [LocalAssum (name, ty)] @ realargs, mkRel 1, ty, - (List.map (fun x -> mkRel 1) realargs), 1, avoid) + in + let r = Sorts.Relevant in (* TODO relevance *) + (sigma, (DAst.make ?loc @@ PatVar name), [LocalAssum (make_annot name r, 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 let IndType (indf, _) = @@ -2184,9 +2193,11 @@ let constr_of_pat env sigma arsign pat avoid = match alias with Anonymous -> sigma, pat', sign, app, apptype, realargs, n, avoid - | Name id -> - let sign = LocalAssum (alias, lift m ty) :: sign in - let avoid = Id.Set.add id avoid in + | Name id -> + let _, inds = get_arity env indf in + let r = Sorts.relevance_of_sort_family inds in + let sign = LocalAssum (make_annot alias r, lift m ty) :: sign in + let avoid = Id.Set.add id avoid in let sigma, sign, i, avoid = try let env = EConstr.push_rel_context sign env in @@ -2196,11 +2207,12 @@ let constr_of_pat env sigma arsign pat avoid = (mkRel 1) (* alias *) (lift 1 app) (* aliased term *) in - let neq = eq_id avoid id in - sigma, LocalDef (Name neq, mkRel 0, eq_t) :: sign, 2, Id.Set.add neq avoid + let neq = eq_id avoid id in + (* if we ever allow using a SProp-typed coq_eq_ind this relevance will be wrong *) + sigma, LocalDef (nameR neq, mkRel 0, eq_t) :: sign, 2, Id.Set.add neq avoid with Evarconv.UnableToUnify _ -> sigma, sign, 1, avoid in - (* Mark the equality as a hole *) + (* Mark the equality as a hole *) sigma, pat', sign, lift i app, lift i apptype, realargs, n + i, avoid in let sigma, pat', sign, patc, patty, args, z, avoid = typ env sigma (RelDecl.get_type (List.hd arsign), List.tl arsign) pat avoid in @@ -2222,18 +2234,18 @@ match EConstr.kind sigma t with let rels_of_patsign sigma = List.map (fun decl -> match decl with - | LocalDef (na,t',t) when is_topvar sigma t' -> LocalAssum (na,t) + | LocalDef (na,t',t) when is_topvar sigma t' -> LocalAssum (na,t) | _ -> decl) let vars_of_ctx sigma ctx = let _, y = List.fold_right (fun decl (prev, vars) -> match decl with - | LocalDef (na,t',t) when is_topvar sigma t' -> + | LocalDef (na,t',t) when is_topvar sigma t' -> prev, (DAst.make @@ GApp ( (DAst.make @@ GRef (delayed_force coq_eq_refl_ref, None)), - [hole na; DAst.make @@ GVar prev])) :: vars + [hole na.binder_name; DAst.make @@ GVar prev])) :: vars | _ -> match RelDecl.get_name decl with Anonymous -> invalid_arg "vars_of_ctx" @@ -2343,12 +2355,13 @@ let constrs_of_pats typing_fun env sigma eqns tomatchs sign neqs arity = let args = List.rev args in substl args (liftn signlen (succ nargs) arity) in - let rhs_rels', tycon = + let r = Sorts.Relevant in (* TODO relevance *) + let rhs_rels', tycon = let neqs_rels, arity = match ineqs with | None -> [], arity | Some ineqs -> - [LocalAssum (Anonymous, ineqs)], lift 1 arity + [LocalAssum (make_annot Anonymous r, ineqs)], lift 1 arity in let eqs_rels, arity = decompose_prod_n_assum sigma neqs arity in eqs_rels @ neqs_rels @ rhs_rels', arity @@ -2359,7 +2372,7 @@ let constrs_of_pats typing_fun env sigma eqns tomatchs sign neqs arity = and btype = it_mkProd_or_LetIn j.uj_type rhs_rels' in let sigma, _btype = Typing.type_of !!env sigma bbody in 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_decl = LocalDef (make_annot (Name branch_name) r, lift !i bbody, lift !i btype) in let branch = let bref = DAst.make @@ GVar branch_name in match vars_of_ctx sigma rhs_rels with @@ -2407,9 +2420,10 @@ let abstract_tomatch env sigma tomatchs tycon = | _ -> let tycon = Option.map (fun t -> subst_term sigma (lift 1 c) (lift 1 t)) tycon in - let name = next_ident_away (Id.of_string "filtered_var") names in + let name = next_ident_away (Id.of_string "filtered_var") names in + let r = Sorts.Relevant in (* TODO relevance *) (mkRel 1, lift_tomatch_type (succ lenctx) t) :: lift_ctx 1 prev, - LocalDef (Name name, lift lenctx c, lift lenctx $ type_of_tomatch t) :: ctx, + LocalDef (make_annot (Name name) r, lift lenctx c, lift lenctx $ type_of_tomatch t) :: ctx, Id.Set.add name names, tycon) ([], [], Id.Set.empty, tycon) tomatchs in List.rev prev, ctx, tycon @@ -2471,8 +2485,8 @@ let build_dependent_signature env sigma avoid tomatchs arsign = make_prime avoid name in (sigma, env, succ nargeqs, - (LocalAssum (Name (eq_id avoid previd), eq)) :: argeqs, - refl_arg :: refl_args, + (LocalAssum (make_annot (Name (eq_id avoid previd)) Sorts.Relevant, eq)) :: argeqs, + refl_arg :: refl_args, pred slift, RelDecl.set_name (Name id) decl :: argsign')) (sigma, env, neqs, [], [], slift, []) args argsign @@ -2486,8 +2500,8 @@ let build_dependent_signature env sigma avoid tomatchs arsign = in let sigma, refl_eq = mk_JMeq_refl sigma ty tm in let previd, id = make_prime avoid appn in - (sigma, (LocalAssum (Name (eq_id avoid previd), eq) :: argeqs) :: eqs, - succ nargeqs, + (sigma, (LocalAssum (make_annot (Name (eq_id avoid previd)) Sorts.Relevant, eq) :: argeqs) :: eqs, + succ nargeqs, refl_eq :: refl_args, pred slift, ((RelDecl.set_name (Name id) app_decl :: argsign') :: arsigns)) @@ -2503,8 +2517,9 @@ let build_dependent_signature env sigma avoid tomatchs arsign = (mkRel slift) (lift nar tm) in let sigma, refl = mk_eq_refl sigma tomatch_ty tm in + let na = make_annot (Name (eq_id avoid previd)) Sorts.Relevant in (sigma, - [LocalAssum (Name (eq_id avoid previd), eq)] :: eqs, succ neqs, + [LocalAssum (na, eq)] :: eqs, succ neqs, refl :: refl_args, pred slift, (arsign' :: []) :: arsigns)) (sigma, [], 0, [], nar, []) tomatchs arsign @@ -2580,11 +2595,12 @@ let compile_program_cases ?loc style (typing_function, sigma) tycon env (* We push the initial terms to match and push their alias to rhs' envs *) (* names of aliases will be recovered from patterns (hence Anonymous here) *) - let out_tmt na = function NotInd (None,t) -> LocalAssum (na,t) - | NotInd (Some b, t) -> LocalDef (na,b,t) - | IsInd (typ,_,_) -> LocalAssum (na,typ) in + (* TODO relevance *) + let out_tmt na = function NotInd (None,t) -> LocalAssum (make_annot na Sorts.Relevant,t) + | NotInd (Some b, t) -> LocalDef (make_annot na Sorts.Relevant,b,t) + | IsInd (typ,_,_) -> LocalAssum (make_annot na Sorts.Relevant,typ) in let typs = List.map2 (fun (na,_) (tm,tmt) -> (tm,out_tmt na tmt)) nal tomatchs in - + let typs = List.map (fun (c,d) -> (c,extract_inductive_data !!env sigma d,d)) typs in @@ -2654,10 +2670,11 @@ let compile_cases ?loc ~program_mode style (typing_fun, sigma) tycon env (predop (* names of aliases will be recovered from patterns (hence Anonymous *) (* here) *) + (* TODO relevance *) let out_tmt na = function NotInd (None,t) -> LocalAssum (na,t) | NotInd (Some b,t) -> LocalDef (na,b,t) | IsInd (typ,_,_) -> LocalAssum (na,typ) in - let typs = List.map2 (fun (na,_) (tm,tmt) -> (tm,out_tmt na tmt)) nal tomatchs in + let typs = List.map2 (fun (na,_) (tm,tmt) -> (tm,out_tmt (make_annot na Sorts.Relevant) tmt)) nal tomatchs in let typs = List.map (fun (c,d) -> (c,extract_inductive_data !!env sigma d,d)) typs in diff --git a/pretyping/cbv.ml b/pretyping/cbv.ml index e27fc536eb..c9f18d89be 100644 --- a/pretyping/cbv.ml +++ b/pretyping/cbv.ml @@ -48,7 +48,7 @@ type cbv_value = | VAL of int * constr | STACK of int * cbv_value * cbv_stack | CBN of constr * cbv_value subs - | LAM of int * (Name.t * constr) list * constr * cbv_value subs + | LAM of int * (Name.t Context.binder_annot * constr) list * constr * cbv_value subs | FIXP of fixpoint * cbv_value subs * cbv_value array | COFIXP of cofixpoint * cbv_value subs * cbv_value array | CONSTR of constructor Univ.puniverses * cbv_value array @@ -281,11 +281,11 @@ and reify_value = function (* reduction under binders *) apply_env env @@ List.fold_left (fun c (n,t) -> mkLambda (n, t, c)) b ctxt - | FIXP ((lij,(names,lty,bds)),env,args) -> - let fix = mkFix (lij, (names, lty, bds)) in + | FIXP ((lij,fix),env,args) -> + let fix = mkFix (lij, fix) in mkApp (apply_env env fix, Array.map reify_value args) - | COFIXP ((j,(names,lty,bds)),env,args) -> - let cofix = mkCoFix (j, (names,lty,bds)) in + | COFIXP ((j,cofix),env,args) -> + let cofix = mkCoFix (j, cofix) in mkApp (apply_env env cofix, Array.map reify_value args) | CONSTR (c,args) -> mkApp(mkConstructU c, Array.map reify_value args) @@ -550,7 +550,7 @@ and cbv_norm_value info = function (* reduction under binders *) | FIXP ((lij,(names,lty,bds)),env,args) -> mkApp (mkFix (lij, - (names, + (names, Array.map (cbv_norm_term info env) lty, Array.map (cbv_norm_term info (subs_liftn (Array.length lty) env)) bds)), @@ -558,7 +558,7 @@ and cbv_norm_value info = function (* reduction under binders *) | COFIXP ((j,(names,lty,bds)),env,args) -> mkApp (mkCoFix (j, - (names,Array.map (cbv_norm_term info env) lty, + (names,Array.map (cbv_norm_term info env) lty, Array.map (cbv_norm_term info (subs_liftn (Array.length lty) env)) bds)), Array.map (cbv_norm_value info) args) diff --git a/pretyping/cbv.mli b/pretyping/cbv.mli index 0a1e771921..d6c2ad146e 100644 --- a/pretyping/cbv.mli +++ b/pretyping/cbv.mli @@ -32,7 +32,7 @@ type cbv_value = | VAL of int * constr | STACK of int * cbv_value * cbv_stack | CBN of constr * cbv_value subs - | LAM of int * (Name.t * constr) list * constr * cbv_value subs + | LAM of int * (Name.t Context.binder_annot * constr) list * constr * cbv_value subs | FIXP of fixpoint * cbv_value subs * cbv_value array | COFIXP of cofixpoint * cbv_value subs * cbv_value array | CONSTR of constructor Univ.puniverses * cbv_value array diff --git a/pretyping/classops.ml b/pretyping/classops.ml index 306a76e35e..54a1aa9aa0 100644 --- a/pretyping/classops.ml +++ b/pretyping/classops.ml @@ -179,7 +179,7 @@ let find_class_type sigma t = | Proj (p, c) when not (Projection.unfolded p) -> CL_PROJ (Projection.repr p), EInstance.empty, (c :: args) | Ind (ind_sp,u) -> CL_IND ind_sp, u, args - | Prod (_,_,_) -> CL_FUN, EInstance.empty, [] + | Prod _ -> CL_FUN, EInstance.empty, [] | Sort _ -> CL_SORT, EInstance.empty, [] | _ -> raise Not_found diff --git a/pretyping/coercion.ml b/pretyping/coercion.ml index 0e6aaaa408..82411ba2ef 100644 --- a/pretyping/coercion.ml +++ b/pretyping/coercion.ml @@ -21,6 +21,7 @@ open Util open Names open Term open Constr +open Context open Environ open EConstr open Vars @@ -175,23 +176,23 @@ and coerce ?loc env evdref (x : EConstr.constr) (y : EConstr.constr) try evdref := unify_leq_delay env !evdref hdx hdy; let (n, eqT), restT = dest_prod typ in let (n', eqT'), restT' = dest_prod typ' in - aux (hdx :: tele) (subst1 hdx restT) (subst1 hdy restT') (succ i) co + aux (hdx :: tele) (subst1 hdx restT) (subst1 hdy restT') (succ i) co with UnableToUnify _ -> - let (n, eqT), restT = dest_prod typ in + let (n, eqT), restT = dest_prod typ in let (n', eqT'), restT' = dest_prod typ' in let () = try evdref := unify_leq_delay env !evdref eqT eqT' with UnableToUnify _ -> raise NoSubtacCoercion - in + in (* Disallow equalities on arities *) if Reductionops.is_arity env !evdref eqT then raise NoSubtacCoercion; let restargs = lift_args 1 (List.rev (Array.to_list (Array.sub l (succ i) (len - (succ i))))) in let args = List.rev (restargs @ mkRel 1 :: List.map (lift 1) tele) in - let pred = mkLambda (n, eqT, applist (lift 1 c, args)) in + let pred = mkLambda (n, eqT, applist (lift 1 c, args)) in let eq = papp evdref coq_eq_ind [| eqT; hdx; hdy |] in - let evar = make_existential ?loc n env evdref eq in + let evar = make_existential ?loc n.binder_name env evdref eq in let eq_app x = papp evdref coq_eq_rect [| eqT; hdx; pred; x; hdy; evar|] in @@ -216,9 +217,12 @@ and coerce ?loc env evdref (x : EConstr.constr) (y : EConstr.constr) | _ -> subco ()) | Prod (name, a, b), Prod (name', a', b') -> let name' = - Name (Namegen.next_ident_away Namegen.default_dependent_ident (Termops.vars_of_env env)) - in - let env' = push_rel (LocalAssum (name', a')) env in + {name' with + binder_name = + Name (Namegen.next_ident_away + Namegen.default_dependent_ident (Termops.vars_of_env env))} + in + let env' = push_rel (LocalAssum (name', a')) env in let c1 = coerce_unify env' (lift 1 a') (lift 1 a) in (* env, x : a' |- c1 : lift 1 a' > lift 1 a *) let coec1 = app_opt env' evdref c1 (mkRel 1) in @@ -230,7 +234,7 @@ and coerce ?loc env evdref (x : EConstr.constr) (y : EConstr.constr) | _, _ -> Some (fun f -> - mkLambda (name', a', + mkLambda (name', a', app_opt env' evdref c2 (mkApp (lift 1 f, [| coec1 |]))))) @@ -253,11 +257,11 @@ and coerce ?loc env evdref (x : EConstr.constr) (y : EConstr.constr) let c1 = coerce_unify env a a' in let remove_head a c = match EConstr.kind !evdref c with - | Lambda (n, t, t') -> c, t' + | Lambda (n, t, t') -> c, t' | Evar (k, args) -> let (evs, t) = Evardefine.define_evar_as_lambda env !evdref (k,args) in evdref := evs; - let (n, dom, rng) = destLambda !evdref t in + let (n, dom, rng) = destLambda !evdref t in if isEvar !evdref dom then let (domk, args) = destEvar !evdref dom in evdref := define domk a !evdref; @@ -265,8 +269,12 @@ and coerce ?loc env evdref (x : EConstr.constr) (y : EConstr.constr) t, rng | _ -> raise NoSubtacCoercion in - let (pb, b), (pb', b') = remove_head a pb, remove_head a' pb' in - let env' = push_rel (LocalAssum (Name Namegen.default_dependent_ident, a)) env in + let (pb, b), (pb', b') = remove_head a pb, remove_head a' pb' in + let ra = Retyping.relevance_of_type env !evdref a in + let env' = push_rel + (LocalAssum (make_annot (Name Namegen.default_dependent_ident) ra, a)) + env + in let c2 = coerce_unify env' b b' in match c1, c2 with | None, None -> None @@ -396,9 +404,9 @@ let apply_coercion env sigma p hj typ_cl = let inh_app_fun_core ~program_mode env evd j = let t = whd_all env evd j.uj_type in match EConstr.kind evd t with - | Prod (_,_,_) -> (evd,j) + | Prod _ -> (evd,j) | Evar ev -> - let (evd',t) = Evardefine.define_evar_as_product evd ev in + let (evd',t) = Evardefine.define_evar_as_product env evd ev in (evd',{ uj_val = j.uj_val; uj_type = t }) | _ -> try let t,p = @@ -505,11 +513,11 @@ let rec inh_conv_coerce_to_fail ?loc env evd ?(flags=default_flags_of env) rigid (* has type forall (x:u1), u2 (with v' recursively obtained) *) (* Note: we retype the term because template polymorphism may have *) (* weakened its type *) - let name = match name with + let name = map_annot (function | Anonymous -> Name Namegen.default_dependent_ident - | _ -> name in + | na -> na) name in let open Context.Rel.Declaration in - let env1 = push_rel (LocalAssum (name,u1)) env in + let env1 = push_rel (LocalAssum (name,u1)) env in let (evd', v1) = inh_conv_coerce_to_fail ?loc env1 evd rigidonly (Some (mkRel 1)) (lift 1 u1) (lift 1 t1) in @@ -519,7 +527,7 @@ let rec inh_conv_coerce_to_fail ?loc env evd ?(flags=default_flags_of env) rigid | None -> subst_term evd' v1 t2 | Some v2 -> Retyping.get_type_of env1 evd' v2 in let (evd'',v2') = inh_conv_coerce_to_fail ?loc env1 evd' rigidonly v2 t2 u2 in - (evd'', Option.map (fun v2' -> mkLambda (name, u1, v2')) v2') + (evd'', Option.map (fun v2' -> mkLambda (name, u1, v2')) v2') | _ -> raise (NoCoercionNoUnifier (best_failed_evd,e)) (* Look for cj' obtained from cj by inserting coercions, s.t. cj'.typ = t *) diff --git a/pretyping/constr_matching.ml b/pretyping/constr_matching.ml index 94257fedd7..6bfbb9a9c0 100644 --- a/pretyping/constr_matching.ml +++ b/pretyping/constr_matching.ml @@ -14,9 +14,9 @@ open CErrors open Util open Names open Constr +open Context open Globnames open Termops -open Term open EConstr open Vars open Pattern @@ -70,7 +70,7 @@ let constrain sigma n (ids, m) ((names,seen as names_seen), terms as subst) = (names_seen, Id.Map.add n (ids, m) terms) let add_binders na1 na2 binding_vars ((names,seen), terms as subst) = - match na1, na2 with + match na1, na2.binder_name with | Name id1, Name id2 when Id.Set.mem id1 binding_vars -> if Id.Map.mem id1 names then let () = Glob_ops.warn_variable_collision id1 in @@ -94,7 +94,7 @@ let rec build_lambda sigma vars ctx m = match vars with let (na, t, suf) = match suf with | [] -> assert false | (_, id, t) :: suf -> - (Name id, t, suf) + (map_annot Name.mk_name id, t, suf) in (* Check that the abstraction is legal by generating a transitive closure of its dependencies. *) @@ -178,11 +178,12 @@ let make_renaming ids = function | _ -> dummy_constr let push_binder na1 na2 t ctx = - let id2 = match na2 with - | Name id2 -> id2 - | Anonymous -> - let avoid = Id.Set.of_list (List.map pi2 ctx) in - Namegen.next_ident_away Namegen.default_non_dependent_ident avoid in + let id2 = map_annot (function + | Name id2 -> id2 + | Anonymous -> + let avoid = Id.Set.of_list (List.map (fun (_,id,_) -> id.binder_name) ctx) in + Namegen.next_ident_away Namegen.default_non_dependent_ident avoid) na2 + in (na1, id2, t) :: ctx (* This is an optimization of the main pattern-matching which shares @@ -278,14 +279,8 @@ let matches_core env sigma allow_bound_rels | PRel n1, Rel n2 when Int.equal n1 n2 -> subst | PSort ps, Sort s -> - - let open Glob_term in - begin match ps, ESorts.kind sigma s with - | GProp, Prop -> subst - | GSet, Set -> subst - | GType _, Type _ -> subst - | _ -> raise PatternMatchingFailure - end + if Sorts.family_equal ps (Sorts.family (ESorts.kind sigma s)) + then subst else raise PatternMatchingFailure | PApp (p, [||]), _ -> sorec ctx env subst p t @@ -341,19 +336,19 @@ let matches_core env sigma allow_bound_rels sorec ctx env subst c1 c2 | PProd (na1,c1,d1), Prod(na2,c2,d2) -> - sorec (push_binder na1 na2 c2 ctx) (EConstr.push_rel (LocalAssum (na2,c2)) env) + sorec (push_binder na1 na2 c2 ctx) (EConstr.push_rel (LocalAssum (na2,c2)) env) (add_binders na1 na2 binding_vars (sorec ctx env subst c1 c2)) d1 d2 | PLambda (na1,c1,d1), Lambda(na2,c2,d2) -> - sorec (push_binder na1 na2 c2 ctx) (EConstr.push_rel (LocalAssum (na2,c2)) env) + sorec (push_binder na1 na2 c2 ctx) (EConstr.push_rel (LocalAssum (na2,c2)) env) (add_binders na1 na2 binding_vars (sorec ctx env subst c1 c2)) d1 d2 | PLetIn (na1,c1,Some t1,d1), LetIn(na2,c2,t2,d2) -> - sorec (push_binder na1 na2 t2 ctx) (EConstr.push_rel (LocalDef (na2,c2,t2)) env) + sorec (push_binder na1 na2 t2 ctx) (EConstr.push_rel (LocalDef (na2,c2,t2)) env) (add_binders na1 na2 binding_vars (sorec ctx env (sorec ctx env subst c1 c2) t1 t2)) d1 d2 | PLetIn (na1,c1,None,d1), LetIn(na2,c2,t2,d2) -> - sorec (push_binder na1 na2 t2 ctx) (EConstr.push_rel (LocalDef (na2,c2,t2)) env) + sorec (push_binder na1 na2 t2 ctx) (EConstr.push_rel (LocalDef (na2,c2,t2)) env) (add_binders na1 na2 binding_vars (sorec ctx env subst c1 c2)) d1 d2 | PIf (a1,b1,b1'), Case (ci,_,a2,[|b2;b2'|]) -> diff --git a/pretyping/detyping.ml b/pretyping/detyping.ml index 99cd89cc2a..ac7c3d30d5 100644 --- a/pretyping/detyping.ml +++ b/pretyping/detyping.ml @@ -13,6 +13,7 @@ open CErrors open Util open Names open Constr +open Context open Term open EConstr open Vars @@ -40,9 +41,12 @@ let print_evar_arguments = ref false let add_name na b t (nenv, env) = let open Context.Rel.Declaration in + (* Is this just a dummy? Be careful, printing doesn't always give us + a correct env. *) + let r = Sorts.Relevant in add_name na nenv, push_rel (match b with - | None -> LocalAssum (na,t) - | Some b -> LocalDef (na,b,t) + | None -> LocalAssum (make_annot na r,t) + | Some b -> LocalDef (make_annot na r,b,t) ) env @@ -202,11 +206,11 @@ let computable sigma p k = let lookup_name_as_displayed env sigma t s = let rec lookup avoid n c = match EConstr.kind sigma c with | Prod (name,_,c') -> - (match compute_displayed_name_in sigma RenamingForGoal avoid name c' with + (match compute_displayed_name_in sigma RenamingForGoal avoid name.binder_name c' with | (Name id,avoid') -> if Id.equal id s then Some n else lookup avoid' (n+1) c' | (Anonymous,avoid') -> lookup avoid' (n+1) (pop c')) | LetIn (name,_,_,c') -> - (match compute_displayed_name_in sigma RenamingForGoal avoid name c' with + (match compute_displayed_name_in sigma RenamingForGoal avoid name.binder_name c' with | (Name id,avoid') -> if Id.equal id s then Some n else lookup avoid' (n+1) c' | (Anonymous,avoid') -> lookup avoid' (n+1) (pop c')) | Cast (c,_,_) -> lookup avoid n c @@ -216,7 +220,7 @@ let lookup_name_as_displayed env sigma t s = let lookup_index_as_renamed env sigma t n = let rec lookup n d c = match EConstr.kind sigma c with | Prod (name,_,c') -> - (match compute_displayed_name_in sigma RenamingForGoal Id.Set.empty name c' with + (match compute_displayed_name_in sigma RenamingForGoal Id.Set.empty name.binder_name c' with (Name _,_) -> lookup n (d+1) c' | (Anonymous,_) -> if Int.equal n 0 then @@ -226,7 +230,7 @@ let lookup_index_as_renamed env sigma t n = else lookup (n-1) (d+1) c') | LetIn (name,_,_,c') -> - (match compute_displayed_name_in sigma RenamingForGoal Id.Set.empty name c' with + (match compute_displayed_name_in sigma RenamingForGoal Id.Set.empty name.binder_name c' with | (Name _,_) -> lookup n (d+1) c' | (Anonymous,_) -> if Int.equal n 0 then @@ -342,9 +346,9 @@ let rec decomp_branch tags nal b (avoid,env as e) sigma c = | b::tags -> let na,c,f,body,t = match EConstr.kind sigma (strip_outer_cast sigma c), b with - | Lambda (na,t,c),false -> na,c,compute_displayed_let_name_in,None,Some t - | LetIn (na,b,t,c),true -> - na,c,compute_displayed_name_in,Some b,Some t + | Lambda (na,t,c),false -> na.binder_name,c,compute_displayed_let_name_in,None,Some t + | LetIn (na,b,t,c),true -> + na.binder_name,c,compute_displayed_name_in,Some b,Some t | _, false -> Name default_dependent_ident,(applist (lift 1 c, [mkRel 1])), compute_displayed_name_in,None,None @@ -490,19 +494,16 @@ let rec share_names detype 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') -> - let na = match (na,na') with - Name _, _ -> na - | _, Name _ -> na' - | _ -> na in + let na = Nameops.Name.pick_annot na na' in let t' = detype avoid env sigma t in - let id = next_name_away na avoid in + let id = next_name_away na.binder_name avoid in let avoid = Id.Set.add id avoid and env = add_name (Name id) None t env in share_names detype (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 avoid env sigma t' in let b' = detype avoid env sigma b in - let id = next_name_away na avoid in + let id = next_name_away na.binder_name avoid in let avoid = Id.Set. add id avoid and env = add_name (Name id) (Some b) t' env in share_names detype 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 *) @@ -511,7 +512,7 @@ let rec share_names detype n l avoid env sigma c t = (* If it is an open proof: we cheat and eta-expand *) | _, Prod (na',t',c') when n > 0 -> let t'' = detype avoid env sigma t' in - let id = next_name_away na' avoid in + let id = next_name_away na'.binder_name avoid in let avoid = Id.Set.add id avoid and env = add_name (Name id) None t' env in let appc = mkApp (lift 1 c,[|mkRel 1|]) in share_names detype (n-1) ((Name id,Explicit,None,t'')::l) avoid env sigma appc c' @@ -549,7 +550,7 @@ let detype_fix detype avoid env sigma (vn,_ as nvn) (names,tys,bodies) = let def_avoid, def_env, lfi = Array.fold_left2 (fun (avoid, env, l) na ty -> - let id = next_name_away na avoid in + let id = next_name_away na.binder_name avoid in (Id.Set.add id avoid, add_name (Name id) None ty env, id::l)) (avoid, env, []) names tys in let n = Array.length tys in @@ -565,7 +566,7 @@ let detype_cofix detype avoid env sigma n (names,tys,bodies) = let def_avoid, def_env, lfi = Array.fold_left2 (fun (avoid, env, l) na ty -> - let id = next_name_away na avoid in + let id = next_name_away na.binder_name avoid in (Id.Set.add id avoid, add_name (Name id) None ty env, id::l)) (avoid, env, []) names tys in let ntys = Array.length tys in @@ -597,6 +598,7 @@ let detype_universe sigma u = Univ.Universe.map fn u let detype_sort sigma = function + | SProp -> GSProp | Prop -> GProp | Set -> GSet | Type u -> @@ -702,9 +704,9 @@ and detype_r d flags avoid env sigma t = match decl with | LocalDef _ -> true | LocalAssum (id,_) -> - try let n = List.index Name.equal (Name id) (fst env) in + try let n = List.index Name.equal (Name id.binder_name) (fst env) in isRelN sigma n c - with Not_found -> isVarId sigma id c + with Not_found -> isVarId sigma id.binder_name c in let id,l = try @@ -765,11 +767,11 @@ and detype_eqn d (lax,isgoal as flags) avoid env sigma constr construct_nargs br [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 + let pat,new_avoid,new_env,new_ids = make_pat x.binder_name avoid env b None t ids in buildrec new_ids (pat::patlist) new_avoid new_env l b | LetIn (x,b,t,b'), true::l -> - let pat,new_avoid,new_env,new_ids = make_pat x avoid env b' (Some b) t ids in + let pat,new_avoid,new_env,new_ids = make_pat x.binder_name avoid env b' (Some b) t ids in buildrec new_ids (pat::patlist) new_avoid new_env l b' | Cast (c,_,_), l -> (* Oui, il y a parfois des cast *) @@ -791,7 +793,7 @@ and detype_eqn d (lax,isgoal as flags) avoid env sigma constr construct_nargs br in buildrec Id.Set.empty [] avoid env construct_nargs branch -and detype_binder d (lax,isgoal as flags) bk avoid env sigma na body ty c = +and detype_binder d (lax,isgoal as flags) bk avoid env sigma {binder_name=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 @@ -827,7 +829,7 @@ let detype_rel_context d ?(lax=false) where avoid env sigma sign = (RenamingElsewhereFor (fst env,c)) avoid na c in let b = match decl with | LocalAssum _ -> None - | LocalDef (_,b,_) -> Some b + | LocalDef (_,b,_) -> Some b 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 @@ -864,7 +866,7 @@ let detype_closed_glob ?lax isgoal avoid env sigma t = (* spiwack: I'm not sure it is the right thing to do, but I'm computing the detyping environment like [Printer.pr_constr_under_binders_env] does. *) - let assums = List.map (fun id -> LocalAssum (Name id,(* dummy *) mkProp)) b in + let assums = List.map (fun id -> LocalAssum (make_annot (Name id) Sorts.Relevant,(* dummy *) mkProp)) b in let env = push_rel_context assums env in DAst.get (detype Now ?lax isgoal avoid env sigma c) (* if [id] is bound to a [closed_glob_constr]. *) diff --git a/pretyping/evarconv.ml b/pretyping/evarconv.ml index 8e273fb4a8..28a97bb91a 100644 --- a/pretyping/evarconv.ml +++ b/pretyping/evarconv.ml @@ -15,6 +15,7 @@ open Constr open Termops open Environ open EConstr +open Context open Vars open Reduction open Reductionops @@ -78,8 +79,8 @@ let impossible_default_case env = let coq_unit_judge = let open Environ in let make_judge c t = make_judge (EConstr.of_constr c) (EConstr.of_constr t) in - let na1 = Name (Id.of_string "A") in - let na2 = Name (Id.of_string "H") in + let na1 = make_annot (Name (Id.of_string "A")) Sorts.Relevant in + let na2 = make_annot (Name (Id.of_string "H")) Sorts.Relevant in fun env -> match impossible_default_case env with | Some (id, type_of_id, ctx) -> @@ -87,7 +88,7 @@ let coq_unit_judge = | None -> (* In case the constants id/ID are not defined *) Environ.make_judge (mkLambda (na1,mkProp,mkLambda(na2,mkRel 1,mkRel 1))) - (mkProd (na1,mkProp,mkArrow (mkRel 1) (mkRel 2))), + (mkProd (na1,mkProp,mkArrow (mkRel 1) Sorts.Relevant (mkRel 2))), Univ.ContextSet.empty let unfold_projection env evd ts p c = @@ -251,8 +252,8 @@ let check_conv_record env sigma (t1,sk1) (t2,sk2) = let canon_s,sk2_effective = try match EConstr.kind sigma t2 with - Prod (_,a,b) -> (* assert (l2=[]); *) - let _, a, b = destProd sigma t2 in + Prod (_,a,b) -> (* assert (l2=[]); *) + let _, a, b = destProd sigma t2 in if noccurn sigma 1 b then lookup_canonical_conversion (proji, Prod_cs), (Stack.append_app [|a;pop b|] Stack.empty) @@ -815,10 +816,10 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) flags env evd pbty (fun i -> let b = nf_evar i b1 in let t = nf_evar i t1 in - let na = Nameops.Name.pick na1 na2 in + let na = Nameops.Name.pick_annot na1 na2 in evar_conv_x flags (push_rel (RelDecl.LocalDef (na,b,t)) env) i pbty c'1 c'2); (fun i -> exact_ise_stack2 env i (evar_conv_x flags) sk1 sk2)] - and f2 i = + and f2 i = let out1 = whd_betaiota_deltazeta_for_iota_state flags.open_ts env i csts1 (v1,sk1) and out2 = whd_betaiota_deltazeta_for_iota_state flags.open_ts env i csts2 (v2,sk2) in evar_eqappr_x flags env i pbty out1 out2 @@ -930,7 +931,7 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) flags env evd pbty [(fun i -> evar_conv_x flags env i CONV c1 c2); (fun i -> let c = nf_evar i c1 in - let na = Nameops.Name.pick na1 na2 in + let na = Nameops.Name.pick_annot na1 na2 in evar_conv_x flags (push_rel (RelDecl.LocalAssum (na,c)) env) i CONV c'1 c'2); (* When in modulo_betaiota = false case, lambda's are not reduced *) (fun i -> exact_ise_stack2 env i (evar_conv_x flags) sk1 sk2)] @@ -988,12 +989,12 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) flags env evd pbty UnifFailure (evd,UnifUnivInconsistency p) | e when CErrors.noncritical e -> UnifFailure (evd,NotSameHead)) - | Prod (n1,c1,c'1), Prod (n2,c2,c'2) when app_empty -> + | Prod (n1,c1,c'1), Prod (n2,c2,c'2) when app_empty -> ise_and evd [(fun i -> evar_conv_x flags env i CONV c1 c2); (fun i -> let c = nf_evar i c1 in - let na = Nameops.Name.pick n1 n2 in + let na = Nameops.Name.pick_annot n1 n2 in evar_conv_x flags (push_rel (RelDecl.LocalAssum (na,c)) env) i pbty c'1 c'2)] | Rel x1, Rel x2 -> @@ -1027,7 +1028,7 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) flags env evd pbty | _, Construct u -> eta_constructor flags env evd sk2 u sk1 term1 - | Fix ((li1, i1),(_,tys1,bds1 as recdef1)), Fix ((li2, i2),(_,tys2,bds2)) -> (* Partially applied fixs *) + | Fix ((li1, i1),(_,tys1,bds1 as recdef1)), Fix ((li2, i2),(_,tys2,bds2)) -> (* Partially applied fixs *) if Int.equal i1 i2 && Array.equal Int.equal li1 li2 then ise_and evd [ (fun i -> ise_array2 i (fun i' -> evar_conv_x flags env i' CONV) tys1 tys2); @@ -1035,7 +1036,7 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) flags env evd pbty (fun i -> exact_ise_stack2 env i (evar_conv_x flags) sk1 sk2)] else UnifFailure (evd, NotSameHead) - | CoFix (i1,(_,tys1,bds1 as recdef1)), CoFix (i2,(_,tys2,bds2)) -> + | CoFix (i1,(_,tys1,bds1 as recdef1)), CoFix (i2,(_,tys2,bds2)) -> if Int.equal i1 i2 then ise_and evd [(fun i -> ise_array2 i @@ -1352,7 +1353,7 @@ let second_order_matching flags env_rhs evd (evk,args) (test,argoccs) rhs = make_subst (ctxt',l,occsl) end | decl'::ctxt', c::l, occs::occsl -> - let id = NamedDecl.get_id decl' in + let id = NamedDecl.get_annot decl' in let t = NamedDecl.get_type decl' in let evs = ref [] in let c = nf_evar evd c in @@ -1369,7 +1370,7 @@ let second_order_matching flags env_rhs evd (evk,args) (test,argoccs) rhs = let c = nf_evar evd c in if !debug_ho_unification then Feedback.msg_debug Pp.(str"set holes for: " ++ - prc env_rhs evd (mkVar id) ++ spc () ++ + prc env_rhs evd (mkVar id.binder_name) ++ spc () ++ prc env_rhs evd c ++ str" in " ++ prc env_rhs evd rhs); let occ = ref 1 in @@ -1381,7 +1382,7 @@ let second_order_matching flags env_rhs evd (evk,args) (test,argoccs) rhs = incr occ; match occs with | AtOccurrences occs -> - if Locusops.is_selected oc occs then evd, mkVar id + if Locusops.is_selected oc occs then evd, mkVar id.binder_name else evd, inst | Unspecified prefer_abstraction -> let evd, evty = set_holes env_rhs evd cty subst in @@ -1436,6 +1437,7 @@ let second_order_matching flags env_rhs evd (evk,args) (test,argoccs) rhs = let rec abstract_free_holes evd = function | (id,idty,c,cty,evsref,_,_)::l -> + let id = id.binder_name in let c = nf_evar evd c in if !debug_ho_unification then Feedback.msg_debug Pp.(str"abstracting: " ++ diff --git a/pretyping/evardefine.ml b/pretyping/evardefine.ml index a62427834d..a51cb22c20 100644 --- a/pretyping/evardefine.ml +++ b/pretyping/evardefine.ml @@ -13,6 +13,7 @@ open Util open Pp open Names open Constr +open Context open Termops open EConstr open Vars @@ -72,7 +73,7 @@ let idx = Namegen.default_dependent_ident (* Refining an evar to a product *) -let define_pure_evar_as_product evd evk = +let define_pure_evar_as_product env evd evk = let open Context.Named.Declaration in let evi = Evd.find_undefined evd evk in let evenv = evar_env evi in @@ -84,11 +85,12 @@ let define_pure_evar_as_product evd evk = let evd1,(dom,u1) = new_type_evar evenv evd univ_flexible_alg ~src ~filter:(evar_filter evi) in + let rdom = Sorts.Relevant in (* TODO relevance *) let evd2,rng = - let newenv = push_named (LocalAssum (id, dom)) evenv in + let newenv = push_named (LocalAssum (make_annot id rdom, dom)) evenv in let src = subterm_source evk ~where:Codomain evksrc in let filter = Filter.extend 1 (evar_filter evi) in - if Sorts.is_prop (ESorts.kind evd1 s) then + if Environ.is_impredicative_sort env (ESorts.kind evd1 s) then (* Impredicative product, conclusion must fall in [Prop]. *) new_evar newenv evd1 concl ~src ~filter else @@ -97,17 +99,17 @@ let define_pure_evar_as_product evd evk = new_type_evar newenv evd1 status ~src ~filter in let prods = Univ.sup (univ_of_sort u1) (univ_of_sort srng) in - let evd3 = Evd.set_leq_sort evenv evd3 (Type prods) (ESorts.kind evd1 s) in + let evd3 = Evd.set_leq_sort evenv evd3 (Sorts.sort_of_univ prods) (ESorts.kind evd1 s) in evd3, rng in - let prod = mkProd (Name id, dom, subst_var id rng) in + let prod = mkProd (make_annot (Name id) rdom, dom, subst_var id rng) in let evd3 = Evd.define evk prod evd2 in evd3,prod (* Refine an applied evar to a product and returns its instantiation *) -let define_evar_as_product evd (evk,args) = - let evd,prod = define_pure_evar_as_product evd evk in +let define_evar_as_product env evd (evk,args) = + let evd,prod = define_pure_evar_as_product env evd evk in (* Quick way to compute the instantiation of evk with args *) let na,dom,rng = destProd evd prod in let evdom = mkEvar (fst (destEvar evd dom), args) in @@ -131,17 +133,19 @@ let define_pure_evar_as_lambda env evd evk = let typ = Reductionops.whd_all evenv evd (evar_concl evi) in let evd1,(na,dom,rng) = match EConstr.kind evd typ with | Prod (na,dom,rng) -> (evd,(na,dom,rng)) - | Evar ev' -> let evd,typ = define_evar_as_product evd ev' in evd,destProd evd typ + | Evar ev' -> let evd,typ = define_evar_as_product env evd ev' in evd,destProd evd typ | _ -> error_not_product env evd typ in let avoid = Environ.ids_of_named_context_val evi.evar_hyps in let id = - next_name_away_with_default_using_types "x" na avoid (Reductionops.whd_evar evd dom) in + map_annot (fun na -> next_name_away_with_default_using_types "x" na avoid + (Reductionops.whd_evar evd dom)) na + in let newenv = push_named (LocalAssum (id, dom)) evenv in let filter = Filter.extend 1 (evar_filter evi) in let src = subterm_source evk ~where:Body (evar_source evk evd1) in let abstract_arguments = Abstraction.abstract_last evi.evar_abstract_arguments in - let evd2,body = new_evar newenv evd1 ~src (subst1 (mkVar id) rng) ~filter ~abstract_arguments in - let lam = mkLambda (Name id, dom, subst_var id body) in + let evd2,body = new_evar newenv evd1 ~src (subst1 (mkVar id.binder_name) rng) ~filter ~abstract_arguments in + let lam = mkLambda (map_annot Name.mk_name id, dom, subst_var id.binder_name body) in Evd.define evk lam evd2, lam let define_evar_as_lambda env evd (evk,args) = @@ -164,13 +168,12 @@ let rec evar_absorb_arguments env evd (evk,args as ev) = function (* Refining an evar to a sort *) let define_evar_as_sort env evd (ev,args) = - let evd, u = new_univ_variable univ_rigid evd in + let evd, s = new_sort_variable univ_rigid evd in let evi = Evd.find_undefined evd ev in - let s = Type u in let concl = Reductionops.whd_all (evar_env evi) evd evi.evar_concl in let sort = destSort evd concl in let evd' = Evd.define ev (mkSort s) evd in - Evd.set_leq_sort env evd' (Type (Univ.super u)) (ESorts.kind evd' sort), s + Evd.set_leq_sort env evd' (Sorts.super s) (ESorts.kind evd' sort), s (* Propagation of constraints through application and abstraction: Given a type constraint on a functional term, returns the type @@ -181,21 +184,22 @@ let split_tycon ?loc env evd tycon = let rec real_split evd c = let t = Reductionops.whd_all env evd c in match EConstr.kind evd t with - | Prod (na,dom,rng) -> evd, (na, dom, rng) + | Prod (na,dom,rng) -> evd, (na, dom, rng) | Evar ev (* ev is undefined because of whd_all *) -> - let (evd',prod) = define_evar_as_product evd ev in - let (_,dom,rng) = destProd evd prod in - evd',(Anonymous, dom, rng) - | App (c,args) when isEvar evd c -> - let (evd',lam) = define_evar_as_lambda env evd (destEvar evd c) in + let (evd',prod) = define_evar_as_product env evd ev in + let (na,dom,rng) = destProd evd prod in + let anon = {na with binder_name = Anonymous} in + evd',(anon, dom, rng) + | App (c,args) when isEvar evd c -> + let (evd',lam) = define_evar_as_lambda env evd (destEvar evd c) in real_split evd' (mkApp (lam,args)) | _ -> error_not_product ?loc env evd c in match tycon with - | None -> evd,(Anonymous,None,None) + | None -> evd,(make_annot Anonymous Relevant,None,None) | Some c -> - let evd', (n, dom, rng) = real_split evd c in - evd', (n, mk_tycon dom, mk_tycon rng) + let evd', (n, dom, rng) = real_split evd c in + evd', (n, mk_tycon dom, mk_tycon rng) let valcon_of_tycon x = x let lift_tycon n = Option.map (lift n) diff --git a/pretyping/evardefine.mli b/pretyping/evardefine.mli index cd23f9c601..8ff113196b 100644 --- a/pretyping/evardefine.mli +++ b/pretyping/evardefine.mli @@ -33,12 +33,12 @@ val evar_absorb_arguments : env -> evar_map -> existential -> constr list -> val split_tycon : ?loc:Loc.t -> env -> evar_map -> type_constraint -> - evar_map * (Name.t * type_constraint * type_constraint) + evar_map * (Name.t Context.binder_annot * type_constraint * type_constraint) val valcon_of_tycon : type_constraint -> val_constraint val lift_tycon : int -> type_constraint -> type_constraint -val define_evar_as_product : evar_map -> existential -> evar_map * types +val define_evar_as_product : env -> evar_map -> existential -> evar_map * types val define_evar_as_lambda : env -> evar_map -> existential -> evar_map * types val define_evar_as_sort : env -> evar_map -> existential -> evar_map * Sorts.t diff --git a/pretyping/evarsolve.ml b/pretyping/evarsolve.ml index e5f2207333..a4a078bfa0 100644 --- a/pretyping/evarsolve.ml +++ b/pretyping/evarsolve.ml @@ -12,6 +12,7 @@ open Sorts open Util open CErrors open Names +open Context open Constr open Environ open Termops @@ -193,9 +194,9 @@ let recheck_applications unify flags env evdref t = let rec aux i ty = if i < Array.length argsty then match EConstr.kind !evdref (whd_all env !evdref ty) with - | Prod (na, dom, codom) -> + | Prod (na, dom, codom) -> (match unify flags TypeUnification env !evdref Reduction.CUMUL argsty.(i) dom with - | Success evd -> evdref := evd; + | Success evd -> evdref := evd; aux (succ i) (subst1 args.(i) codom) | UnifFailure (evd, reason) -> Pretype_errors.error_cannot_unify env evd ~reason (argsty.(i), dom)) @@ -353,7 +354,7 @@ let compute_rel_aliases var_aliases rels sigma = (fun decl (n,aliases) -> (n-1, match decl with - | LocalDef (_,t,u) -> + | LocalDef (_,t,u) -> (match EConstr.kind sigma t with | Var id' -> let aliases_of_n = @@ -640,7 +641,7 @@ let make_projectable_subst aliases sigma evi args = List.fold_right_i (fun i decl (args,all,cstrs,revmap) -> match decl,args with - | LocalAssum (id,c), a::rest -> + | LocalAssum ({binder_name=id},c), a::rest -> let revmap = Id.Map.add id i revmap in let cstrs = let a',args = decompose_app_vect sigma a in @@ -651,7 +652,7 @@ let make_projectable_subst aliases sigma evi args = | _ -> cstrs in let all = Int.Map.add i [a,normalize_alias_opt sigma aliases a,id] all in (rest,all,cstrs,revmap) - | LocalDef (id,c,_), a::rest -> + | LocalDef ({binder_name=id},c,_), a::rest -> let revmap = Id.Map.add id i revmap in (match EConstr.kind sigma c with | Var id' -> @@ -727,7 +728,7 @@ let materialize_evar define_fun env evd k (evk1,args1) ty_in_env = let (sign2,filter2,inst2_in_env,inst2_in_sign,_,evd,_) = List.fold_right (fun d (sign,filter,inst_in_env,inst_in_sign,env,evd,avoid) -> let LocalAssum (na,t_in_env) | LocalDef (na,_,t_in_env) = d in - let id = next_name_away na avoid in + let id = map_annot (fun na -> next_name_away na avoid) na in let evd,t_in_sign = let s = Retyping.get_sort_of env evd t_in_env in let evd,ty_t_in_sign = refresh_universes @@ -743,7 +744,7 @@ let materialize_evar define_fun env evd k (evk1,args1) ty_in_env = (push_named_context_val d' sign, Filter.extend 1 filter, (mkRel 1)::(List.map (lift 1) inst_in_env), (mkRel 1)::(List.map (lift 1) inst_in_sign), - push_rel d env,evd,Id.Set.add id avoid)) + push_rel d env,evd,Id.Set.add id.binder_name avoid)) rel_sign (sign1,filter1,Array.to_list args1,inst_in_sign,env1,evd,avoid) in diff --git a/pretyping/find_subterm.ml b/pretyping/find_subterm.ml index d150f8e1cb..7019cdf046 100644 --- a/pretyping/find_subterm.ml +++ b/pretyping/find_subterm.ml @@ -70,7 +70,7 @@ let map_named_declaration_with_hyploc f hyploc acc decl = in match decl,hyploc with | LocalAssum (id,_), InHypValueOnly -> - error_occurrences_error (IncorrectInValueOccurrence id) + error_occurrences_error (IncorrectInValueOccurrence id.Context.binder_name) | LocalAssum (id,typ), _ -> let acc,typ = f acc typ in acc, LocalAssum (id,typ) | LocalDef (id,body,typ), InHypTypeOnly -> diff --git a/pretyping/globEnv.ml b/pretyping/globEnv.ml index d6b204561e..cd82b1993b 100644 --- a/pretyping/globEnv.ml +++ b/pretyping/globEnv.ml @@ -92,7 +92,7 @@ let push_rec_types ~hypnaming sigma (lna,typarray) env = let open Context.Rel.Declaration in let ctxt = Array.map2_i (fun i na t -> Context.Rel.Declaration.LocalAssum (na, lift i t)) lna typarray in let env,ctx = Array.fold_left_map (fun e assum -> let (d,e) = push_rel sigma assum e ~hypnaming in (e,d)) env ctxt in - Array.map get_name ctx, env + Array.map get_annot ctx, env let new_evar env sigma ?src ?naming typ = let open Context.Named.Declaration in diff --git a/pretyping/globEnv.mli b/pretyping/globEnv.mli index 63f72e60bd..65ae495135 100644 --- a/pretyping/globEnv.mli +++ b/pretyping/globEnv.mli @@ -50,7 +50,7 @@ val vars_of_env : t -> Id.Set.t val push_rel : hypnaming:naming_mode -> evar_map -> rel_declaration -> t -> rel_declaration * t val push_rel_context : hypnaming:naming_mode -> ?force_names:bool -> evar_map -> rel_context -> t -> rel_context * t -val push_rec_types : hypnaming:naming_mode -> evar_map -> Name.t array * constr array -> t -> Name.t array * t +val push_rec_types : hypnaming:naming_mode -> evar_map -> Name.t Context.binder_annot array * constr array -> t -> Name.t Context.binder_annot array * t (** Declare an evar using renaming information *) diff --git a/pretyping/glob_ops.ml b/pretyping/glob_ops.ml index affed5389f..74432cc010 100644 --- a/pretyping/glob_ops.ml +++ b/pretyping/glob_ops.ml @@ -47,11 +47,18 @@ let map_glob_decl_left_to_right f (na,k,obd,ty) = let glob_sort_eq g1 g2 = let open Glob_term in match g1, g2 with -| GProp, GProp -> true +| GSProp, GSProp +| GProp, GProp | GSet, GSet -> true | GType l1, GType l2 -> List.equal (Option.equal (fun (x,m) (y,n) -> Libnames.qualid_eq x y && Int.equal m n)) l1 l2 -| _ -> false +| (GSProp|GProp|GSet|GType _), _ -> false + +let glob_sort_family = let open Sorts in function +| GSProp -> InSProp +| GProp -> InProp +| GSet -> InSet +| GType _ -> InType let binding_kind_eq bk1 bk2 = match bk1, bk2 with | Decl_kinds.Explicit, Decl_kinds.Explicit -> true diff --git a/pretyping/glob_ops.mli b/pretyping/glob_ops.mli index c189a3bcb2..2f0ac76235 100644 --- a/pretyping/glob_ops.mli +++ b/pretyping/glob_ops.mli @@ -15,6 +15,8 @@ open Glob_term val glob_sort_eq : Glob_term.glob_sort -> Glob_term.glob_sort -> bool +val glob_sort_family : 'a glob_sort_gen -> Sorts.family + val cases_pattern_eq : 'a cases_pattern_g -> 'a cases_pattern_g -> bool val alias_of_pat : 'a cases_pattern_g -> Name.t diff --git a/pretyping/glob_term.ml b/pretyping/glob_term.ml index 8670c1d964..c57cf88cc6 100644 --- a/pretyping/glob_term.ml +++ b/pretyping/glob_term.ml @@ -24,6 +24,7 @@ type existential_name = Id.t (** Sorts *) type 'a glob_sort_gen = + | GSProp (** representation of [SProp] literal *) | GProp (** representation of [Prop] literal *) | GSet (** representation of [Set] literal *) | GType of 'a (** representation of [Type] literal *) diff --git a/pretyping/indrec.ml b/pretyping/indrec.ml index bd321d5886..4f940fa16a 100644 --- a/pretyping/indrec.ml +++ b/pretyping/indrec.ml @@ -21,6 +21,7 @@ open Globnames open Nameops open Term open Constr +open Context open Vars open Namegen open Declarations @@ -43,8 +44,8 @@ exception RecursionSchemeError of env * recursion_scheme_error let named_hd env t na = named_hd env (Evd.from_env env) (EConstr.of_constr t) na let name_assumption env = function -| LocalAssum (na,t) -> LocalAssum (named_hd env t na, t) -| LocalDef (na,c,t) -> LocalDef (named_hd env c na, c, t) +| LocalAssum (na,t) -> LocalAssum (map_annot (named_hd env t) na, t) +| LocalDef (na,c,t) -> LocalDef (map_annot (named_hd env c) na, c, t) let mkLambda_or_LetIn_name env d b = mkLambda_or_LetIn (name_assumption env d) b let mkProd_or_LetIn_name env d b = mkProd_or_LetIn (name_assumption env d) b @@ -54,7 +55,7 @@ let it_mkProd_or_LetIn_name env b l = List.fold_left (fun c d -> mkProd_or_LetIn let it_mkLambda_or_LetIn_name env b l = List.fold_left (fun c d -> mkLambda_or_LetIn_name env d c) b l let make_prod_dep dep env = if dep then mkProd_name env else mkProd -let mkLambda_string s t c = mkLambda (Name (Id.of_string s), t, c) +let mkLambda_string s r t c = mkLambda (make_annot (Name (Id.of_string s)) r, t, c) (*******************************************) @@ -79,6 +80,7 @@ let mis_make_case_com dep env sigma (ind, u as pind) (mib,mip as specif) kind = let indf = make_ind_family(pind, Context.Rel.to_extended_list mkRel 0 lnamespar) in let constrs = get_constructors env indf in let projs = get_projections env ind in + let relevance = Sorts.relevance_of_sort_family kind in let () = if Option.is_empty projs then check_privacy_block mib in let () = @@ -98,11 +100,13 @@ let mis_make_case_com dep env sigma (ind, u as pind) (mib,mip as specif) kind = let nbprod = k+1 in let indf' = lift_inductive_family nbprod indf in - let arsign,_ = get_arity env indf' in + let arsign,sort = get_arity env indf' in + let r = Sorts.relevance_of_sort_family sort in let depind = build_dependent_inductive env indf' in - let deparsign = LocalAssum (Anonymous,depind)::arsign in + let deparsign = LocalAssum (make_annot Anonymous r,depind)::arsign in - let ci = make_case_info env (fst pind) RegularStyle in + let rci = relevance in + let ci = make_case_info env (fst pind) rci RegularStyle in let pbody = appvect (mkRel (ndepar + nbprod), @@ -111,7 +115,7 @@ let mis_make_case_com dep env sigma (ind, u as pind) (mib,mip as specif) kind = let p = it_mkLambda_or_LetIn_name env' ((if dep then mkLambda_name env' else mkLambda) - (Anonymous,depind,pbody)) + (make_annot Anonymous r,depind,pbody)) arsign in let obj = @@ -132,16 +136,16 @@ let mis_make_case_com dep env sigma (ind, u as pind) (mib,mip as specif) kind = else let cs = lift_constructor (k+1) constrs.(k) in let t = build_branch_type env sigma dep (mkRel (k+1)) cs in - mkLambda_string "f" t - (add_branch (push_rel (LocalAssum (Anonymous, t)) env) (k+1)) + mkLambda_string "f" relevance t + (add_branch (push_rel (LocalAssum (make_annot Anonymous relevance, t)) env) (k+1)) in let (sigma, s) = Evd.fresh_sort_in_family ~rigid:Evd.univ_flexible_alg sigma kind in let typP = make_arity env' sigma dep indf s in let typP = EConstr.Unsafe.to_constr typP in let c = it_mkLambda_or_LetIn_name env - (mkLambda_string "P" typP - (add_branch (push_rel (LocalAssum (Anonymous,typP)) env') 0)) lnamespar + (mkLambda_string "P" Sorts.Relevant typP + (add_branch (push_rel (LocalAssum (make_annot Anonymous Sorts.Relevant,typP)) env') 0)) lnamespar in (sigma, c) @@ -171,12 +175,12 @@ let type_rec_branch is_rec dep env sigma (vargs,depPvect,decP) tyi cs recargs = let p' = EConstr.Unsafe.to_constr p' in let largs = List.map EConstr.Unsafe.to_constr largs in match kind p' with - | Prod (n,t,c) -> - let d = LocalAssum (n,t) in - make_prod env (n,t,prec (push_rel d env) (i+1) (d::sign) c) - | LetIn (n,b,t,c) when List.is_empty largs -> - let d = LocalDef (n,b,t) in - mkLetIn (n,b,t,prec (push_rel d env) (i+1) (d::sign) c) + | Prod (n,t,c) -> + let d = LocalAssum (n,t) in + make_prod env (n,t,prec (push_rel d env) (i+1) (d::sign) c) + | LetIn (n,b,t,c) when List.is_empty largs -> + let d = LocalDef (n,b,t) in + mkLetIn (n,b,t,prec (push_rel d env) (i+1) (d::sign) c) | Ind (_,_) -> let realargs = List.skipn nparams largs in let base = applist (lift i pk,realargs) in @@ -208,23 +212,24 @@ let type_rec_branch is_rec dep env sigma (vargs,depPvect,decP) tyi cs recargs = (match optionpos with | None -> make_prod env - (n,t, - process_constr (push_rel (LocalAssum (n,t)) env) (i+1) c_0 rest + (n,t, + process_constr (push_rel (LocalAssum (n,t)) env) (i+1) c_0 rest (nhyps-1) (i::li)) | Some(dep',p) -> let nP = lift (i+1+decP) p in let env' = push_rel (LocalAssum (n,t)) env in - let t_0 = process_pos env' dep' nP (lift 1 t) in + let t_0 = process_pos env' dep' nP (lift 1 t) in + let r_0 = Retyping.relevance_of_type env' sigma (EConstr.of_constr t_0) in make_prod_dep (dep || dep') env (n,t, - mkArrow t_0 + mkArrow t_0 r_0 (process_constr - (push_rel (LocalAssum (Anonymous,t_0)) env') + (push_rel (LocalAssum (make_annot Anonymous n.binder_relevance,t_0)) env') (i+2) (lift 1 c_0) rest (nhyps-1) (i::li)))) | LetIn (n,b,t,c_0) -> - mkLetIn (n,b,t, + mkLetIn (n,b,t, process_constr - (push_rel (LocalDef (n,b,t)) env) + (push_rel (LocalDef (n,b,t)) env) (i+1) c_0 recargs (nhyps-1) li) | _ -> assert false else @@ -250,12 +255,12 @@ let make_rec_branch_arg env sigma (nparrec,fvect,decF) f cstr recargs = let p' = EConstr.Unsafe.to_constr p' in let largs = List.map EConstr.Unsafe.to_constr largs in match kind p' with - | Prod (n,t,c) -> - let d = LocalAssum (n,t) in - mkLambda_name env (n,t,prec (push_rel d env) (i+1) (d::hyps) c) - | LetIn (n,b,t,c) when List.is_empty largs -> - let d = LocalDef (n,b,t) in - mkLetIn (n,b,t,prec (push_rel d env) (i+1) (d::hyps) c) + | Prod (n,t,c) -> + let d = LocalAssum (n,t) in + mkLambda_name env (n,t,prec (push_rel d env) (i+1) (d::hyps) c) + | LetIn (n,b,t,c) when List.is_empty largs -> + let d = LocalDef (n,b,t) in + mkLetIn (n,b,t,prec (push_rel d env) (i+1) (d::hyps) c) | Ind _ -> let realargs = List.skipn nparrec largs and arg = appvect (mkRel (i+1), Context.Rel.to_extended_vect mkRel 0 hyps) in @@ -280,7 +285,7 @@ let make_rec_branch_arg env sigma (nparrec,fvect,decF) f cstr recargs = (match optionpos with | None -> mkLambda_name env - (n,t,process_constr (push_rel d env) (i+1) + (n,t,process_constr (push_rel d env) (i+1) (EConstr.Unsafe.to_constr (whd_beta Evd.empty (EConstr.of_constr (applist (lift 1 f, [(mkRel 1)]))))) (cprest,rest)) | Some(_,f_0) -> @@ -288,12 +293,12 @@ let make_rec_branch_arg env sigma (nparrec,fvect,decF) f cstr recargs = let env' = push_rel d env in let arg = process_pos env' nF (lift 1 t) in mkLambda_name env - (n,t,process_constr env' (i+1) + (n,t,process_constr env' (i+1) (EConstr.Unsafe.to_constr (whd_beta Evd.empty (EConstr.of_constr (applist (lift 1 f, [(mkRel 1); arg]))))) (cprest,rest))) | (LocalDef (n,c,t) as d)::cprest, rest -> mkLetIn - (n,c,t, + (n,c,t, process_constr (push_rel d env) (i+1) (lift 1 f) (cprest,rest)) | [],[] -> f @@ -329,25 +334,26 @@ let mis_make_indrec env sigma ?(force_mutual=false) listdepkind mib u = let recargpar = recargparn [] (nparams-nparrec) in let make_one_rec p = let makefix nbconstruct = - let rec mrec i ln ltyp ldef = function - | ((indi,u),mibi,mipi,dep,_)::rest -> - let tyi = snd indi in - let nctyi = - Array.length mipi.mind_consnames in (* nb constructeurs du type*) + let rec mrec i ln lrelevance ltyp ldef = function + | ((indi,u),mibi,mipi,dep,target_sort)::rest -> + let tyi = snd indi in + let nctyi = + Array.length mipi.mind_consnames in (* nb constructeurs du type*) - (* arity in the context of the fixpoint, i.e. + (* arity in the context of the fixpoint, i.e. P1..P_nrec f1..f_nbconstruct *) - let args = Context.Rel.to_extended_list mkRel (nrec+nbconstruct) lnamesparrec in - let indf = make_ind_family((indi,u),args) in + let args = Context.Rel.to_extended_list mkRel (nrec+nbconstruct) lnamesparrec in + let indf = make_ind_family((indi,u),args) in - let arsign,_ = get_arity env indf in - let depind = build_dependent_inductive env indf in - let deparsign = LocalAssum (Anonymous,depind)::arsign in + let arsign,s = get_arity env indf in + let r = Sorts.relevance_of_sort_family s in + let depind = build_dependent_inductive env indf in + let deparsign = LocalAssum (make_annot Anonymous r,depind)::arsign in - let nonrecpar = Context.Rel.length lnonparrec in - let larsign = Context.Rel.length deparsign in - let ndepar = larsign - nonrecpar in - let dect = larsign+nrec+nbconstruct in + let nonrecpar = Context.Rel.length lnonparrec in + let larsign = Context.Rel.length deparsign in + let ndepar = larsign - nonrecpar in + let dect = larsign+nrec+nbconstruct in (* constructors in context of the Cases expr, i.e. P1..P_nrec f1..f_nbconstruct F_1..F_nrec a_1..a_nar x:I *) @@ -375,9 +381,10 @@ let mis_make_indrec env sigma ?(force_mutual=false) listdepkind mib u = (* Predicate in the context of the case *) - let depind' = build_dependent_inductive env indf' in - let arsign',_ = get_arity env indf' in - let deparsign' = LocalAssum (Anonymous,depind')::arsign' in + let depind' = build_dependent_inductive env indf' in + let arsign',s = get_arity env indf' in + let r = Sorts.relevance_of_sort_family s in + let deparsign' = LocalAssum (make_annot Anonymous r,depind')::arsign' in let pargs = let nrpar = Context.Rel.to_extended_list mkRel (2*ndepar) lnonparrec @@ -388,13 +395,15 @@ let mis_make_indrec env sigma ?(force_mutual=false) listdepkind mib u = in (* body of i-th component of the mutual fixpoint *) + let target_relevance = Sorts.relevance_of_sort_family target_sort in let deftyi = - let ci = make_case_info env indi RegularStyle in + let rci = target_relevance in + let ci = make_case_info env indi rci RegularStyle in let concl = applist (mkRel (dect+j+ndepar),pargs) in let pred = it_mkLambda_or_LetIn_name env ((if dep then mkLambda_name env else mkLambda) - (Anonymous,depind',concl)) + (make_annot Anonymous r,depind',concl)) arsign' in let obj = @@ -416,20 +425,21 @@ let mis_make_indrec env sigma ?(force_mutual=false) listdepkind mib u = in it_mkProd_or_LetIn_name env concl deparsign - in - mrec (i+nctyi) (Context.Rel.nhyps arsign ::ln) (typtyi::ltyp) + in + mrec (i+nctyi) (Context.Rel.nhyps arsign ::ln) (target_relevance::lrelevance) (typtyi::ltyp) (deftyi::ldef) rest | [] -> let fixn = Array.of_list (List.rev ln) in let fixtyi = Array.of_list (List.rev ltyp) in let fixdef = Array.of_list (List.rev ldef) in - let names = Array.make nrec (Name(Id.of_string "F")) in - mkFix ((fixn,p),(names,fixtyi,fixdef)) + let lrelevance = CArray.rev_of_list lrelevance in + let names = Array.map (fun r -> make_annot (Name(Id.of_string "F")) r) lrelevance in + mkFix ((fixn,p),(names,fixtyi,fixdef)) in - mrec 0 [] [] [] + mrec 0 [] [] [] [] in let rec make_branch env i = function - | ((indi,u),mibi,mipi,dep,_)::rest -> + | ((indi,u),mibi,mipi,dep,sfam)::rest -> let tyi = snd indi in let nconstr = Array.length mipi.mind_consnames in let rec onerec env j = @@ -443,9 +453,10 @@ let mis_make_indrec env sigma ?(force_mutual=false) listdepkind mib u = let p_0 = type_rec_branch true dep env !evdref (vargs,depPvec,i+j) tyi cs recarg - in - mkLambda_string "f" p_0 - (onerec (push_rel (LocalAssum (Anonymous,p_0)) env) (j+1)) + in + let r_0 = Sorts.relevance_of_sort_family sfam in + mkLambda_string "f" r_0 p_0 + (onerec (push_rel (LocalAssum (make_annot Anonymous r_0,p_0)) env) (j+1)) in onerec env 0 | [] -> makefix i listdepkind @@ -458,9 +469,9 @@ let mis_make_indrec env sigma ?(force_mutual=false) listdepkind mib u = evdref := sigma; res in let typP = make_arity env !evdref dep indf s in - let typP = EConstr.Unsafe.to_constr typP in - mkLambda_string "P" typP - (put_arity (push_rel (LocalAssum (Anonymous,typP)) env) (i+1) rest) + let typP = EConstr.Unsafe.to_constr typP in + mkLambda_string "P" Sorts.Relevant typP + (put_arity (push_rel (LocalAssum (anonR,typP)) env) (i+1) rest) | [] -> make_branch env 0 listdepkind in @@ -530,7 +541,7 @@ let weaken_sort_scheme env evd set sort npars term ty = mkLambda (n, t', mkApp(term,Termops.rel_vect 0 (npars+1))) else let c',term' = drec (np-1) c in - mkProd (n, t, c'), mkLambda (n, t, term') + mkProd (n, t, c'), mkLambda (n, t, term') | LetIn (n,b,t,c) -> let c',term' = drec np c in mkLetIn (n,b,t,c'), mkLetIn (n,b,t,term') | _ -> anomaly ~label:"weaken_sort_scheme" (Pp.str "wrong elimination type.") @@ -588,6 +599,7 @@ let build_induction_scheme env sigma pind dep kind = (*s Eliminations. *) let elimination_suffix = function + | InSProp -> "_sind" | InProp -> "_ind" | InSet -> "_rec" | InType -> "_rect" diff --git a/pretyping/inductiveops.ml b/pretyping/inductiveops.ml index d937456bcb..678aebfbe6 100644 --- a/pretyping/inductiveops.ml +++ b/pretyping/inductiveops.ml @@ -15,6 +15,7 @@ open Univ open Term open Constr open Vars +open Context open Termops open Declarations open Declareops @@ -60,6 +61,8 @@ let lift_inductive_family n = liftn_inductive_family n 1 let substnl_ind_family l n = map_ind_family (substnl l n) +let relevance_of_inductive_family env ((ind,_),_ : inductive_family) = + Inductive.relevance_of_inductive env ind type inductive_type = IndType of inductive_family * EConstr.constr list @@ -75,6 +78,9 @@ let lift_inductive_type n = liftn_inductive_type n 1 let substnl_ind_type l n = map_inductive_type (EConstr.Vars.substnl l n) +let relevance_of_inductive_type env (IndType (indf, _)) = + relevance_of_inductive_family env indf + let mkAppliedInd (IndType ((ind,params), realargs)) = let open EConstr in let ind = on_snd EInstance.make ind in @@ -276,7 +282,7 @@ let has_dependent_elim mib = | NotRecord | FakeRecord -> true (* Annotation for cases *) -let make_case_info env ind style = +let make_case_info env ind r style = let (mib,mip) = Inductive.lookup_mind_specif env ind in let ind_tags = Context.Rel.to_tags (List.firstn mip.mind_nrealdecls mip.mind_arity_ctxt) in @@ -289,6 +295,7 @@ let make_case_info env ind style = ci_npar = mib.mind_nparams; ci_cstr_ndecls = mip.mind_consnrealdecls; ci_cstr_nargs = mip.mind_consnrealargs; + ci_relevance = r; ci_pp_info = print_info } (*s Useful functions *) @@ -419,12 +426,14 @@ let build_dependent_inductive env ((ind, params) as indf) = (* builds the arity of an elimination predicate in sort [s] *) let make_arity_signature env sigma dep indf = - let (arsign,_) = get_arity env indf in + let (arsign,s) = get_arity env indf in + let r = Sorts.relevance_of_sort_family s in + let anon = make_annot Anonymous r in let arsign = List.map (fun d -> Termops.map_rel_decl EConstr.of_constr d) arsign in if dep then (* We need names everywhere *) Namegen.name_context env sigma - ((LocalAssum (Anonymous,EConstr.of_constr (build_dependent_inductive env indf)))::arsign) + ((LocalAssum (anon,EConstr.of_constr (build_dependent_inductive env indf)))::arsign) (* Costly: would be better to name once for all at definition time *) else (* No need to enforce names *) @@ -457,7 +466,9 @@ let compute_projections env (kn, i as ind) = let x = match mib.mind_record with | NotRecord | FakeRecord -> anomaly Pp.(str "Trying to build primitive projections for a non-primitive record") - | PrimRecord info-> Name (pi1 (info.(i))) + | PrimRecord info -> + let id, _, _, _ = info.(i) in + make_annot (Name id) mib.mind_packets.(i).mind_relevance in let pkt = mib.mind_packets.(i) in let { mind_nparams = nparamargs; mind_params_ctxt = params } = mib in @@ -491,7 +502,7 @@ let compute_projections env (kn, i as ind) = let subst = c1 :: subst in (proj_arg, j+1, pbs, subst) | LocalAssum (na,t) -> - match na with + match na.binder_name with | Name id -> let lab = Label.of_id id in let kn = Projection.Repr.make ind ~proj_npars:mib.mind_nparams ~proj_arg lab in @@ -601,7 +612,7 @@ let is_predicate_explicitly_dep env sigma pred arsign = From Coq > 8.2, using or not the effective dependency of the predicate is parametrable! *) - begin match na with + begin match na.binder_name with | Anonymous -> false | Name _ -> true end @@ -643,9 +654,10 @@ let type_case_branches_with_names env sigma indspec p c = (* Type of Case predicates *) let arity_of_case_predicate env (ind,params) dep k = - let arsign,_ = get_arity env (ind,params) in + let arsign,s = get_arity env (ind,params) in + let r = Sorts.relevance_of_sort_family s in let mind = build_dependent_inductive env (ind,params) in - let concl = if dep then mkArrow mind (mkSort k) else mkSort k in + let concl = if dep then mkArrow mind r (mkSort k) else mkSort k in Term.it_mkProd_or_LetIn concl arsign (***********************************************) @@ -720,7 +732,7 @@ let control_only_guard env sigma c = match kind c with | CoFix (_,(_,_,_) as cofix) -> Inductive.check_cofix e cofix - | Fix (_,(_,_,_) as fix) -> + | Fix fix -> Inductive.check_fix e fix | _ -> () in diff --git a/pretyping/inductiveops.mli b/pretyping/inductiveops.mli index 5a4257e175..c74bbfe98b 100644 --- a/pretyping/inductiveops.mli +++ b/pretyping/inductiveops.mli @@ -38,6 +38,8 @@ val lift_inductive_family : int -> inductive_family -> inductive_family val substnl_ind_family : constr list -> int -> inductive_family -> inductive_family +val relevance_of_inductive_family : env -> inductive_family -> Sorts.relevance + (** An inductive type with its parameters and real arguments *) type inductive_type = IndType of inductive_family * EConstr.constr list val make_ind_type : inductive_family * EConstr.constr list -> inductive_type @@ -47,6 +49,8 @@ val liftn_inductive_type : int -> int -> inductive_type -> inductive_type val lift_inductive_type : int -> inductive_type -> inductive_type val substnl_ind_type : EConstr.constr list -> int -> inductive_type -> inductive_type +val relevance_of_inductive_type : env -> inductive_type -> Sorts.relevance + val mkAppliedInd : inductive_type -> EConstr.constr val mis_is_recursive_subset : int list -> wf_paths -> bool val mis_is_recursive : @@ -176,7 +180,7 @@ val type_case_branches_with_names : env -> evar_map -> pinductive * EConstr.constr list -> constr -> constr -> types array * types (** Annotation for cases *) -val make_case_info : env -> inductive -> case_style -> case_info +val make_case_info : env -> inductive -> Sorts.relevance -> case_style -> case_info (** Make a case or substitute projections if the inductive type is a record with primitive projections. diff --git a/pretyping/inferCumulativity.ml b/pretyping/inferCumulativity.ml index bf8a38a353..fefc15dfb2 100644 --- a/pretyping/inferCumulativity.ml +++ b/pretyping/inferCumulativity.ml @@ -201,7 +201,7 @@ let infer_inductive env mie = Array.fold_left (fun variances u -> LMap.add u Variance.Irrelevant variances) LMap.empty uarray in - let env = Typeops.check_context env params in + let env, params = Typeops.check_context env params in let variances = List.fold_left (fun variances entry -> let variances = infer_arity_constructor true env variances entry.mind_entry_arity diff --git a/pretyping/nativenorm.ml b/pretyping/nativenorm.ml index 77ae09ee6f..0b2d760ca8 100644 --- a/pretyping/nativenorm.ml +++ b/pretyping/nativenorm.ml @@ -10,6 +10,7 @@ open CErrors open Term open Constr +open Context open Vars open Environ open Reduction @@ -89,10 +90,12 @@ let invert_tag cst tag reloc_tbl = with Find_at j -> (j+1) let decompose_prod env t = - let (name,dom,codom as res) = destProd (whd_all env t) in - match name with - | Anonymous -> (Name (Id.of_string "x"),dom,codom) - | _ -> res + let (name,dom,codom) = destProd (whd_all env t) in + let name = map_annot (function + | Anonymous -> Name (Id.of_string "x") + | na -> na) name + in + (name,dom,codom) let app_type env c = let t = whd_all env c in @@ -194,7 +197,7 @@ let rec nf_val env sigma v typ = | Vaccu accu -> nf_accu env sigma accu | Vfun f -> let lvl = nb_rel env in - let name,dom,codom = + let name,dom,codom = try decompose_prod env typ with DestKO -> CErrors.anomaly @@ -275,11 +278,13 @@ and nf_atom env sigma atom = | Asort s -> mkSort s | Avar id -> mkVar id | Aprod(n,dom,codom) -> - let dom = nf_type env sigma dom in - let vn = mk_rel_accu (nb_rel env) in - let env = push_rel (LocalAssum (n,dom)) env in - let codom = nf_type env sigma (codom vn) in - mkProd(n,dom,codom) + let dom, sdom = nf_type_sort env sigma dom in + let rdom = Sorts.relevance_of_sort sdom in + let n = make_annot n rdom in + let vn = mk_rel_accu (nb_rel env) in + let env = push_rel (LocalAssum (n,dom)) env in + let codom = nf_type env sigma (codom vn) in + mkProd(n,dom,codom) | Ameta (mv,_) -> mkMeta mv | Aproj (p, c) -> let c = nf_accu env sigma c in @@ -325,28 +330,34 @@ and nf_atom_type env sigma atom = let ci = ans.asw_ci in mkCase(ci, p, a, branchs), tcase | Afix(tt,ft,rp,s) -> - let tt = Array.map (fun t -> nf_type env sigma t) tt in - let name = Array.map (fun _ -> (Name (Id.of_string "Ffix"))) tt in + let tt = Array.map (fun t -> nf_type_sort env sigma t) tt in + let tt = Array.map fst tt and rt = Array.map snd tt in + let name = Name (Id.of_string "Ffix") in + let names = Array.map (fun s -> make_annot name (Sorts.relevance_of_sort s)) rt in let lvl = nb_rel env in let nbfix = Array.length ft in let fargs = mk_rels_accu lvl (Array.length ft) in - (* Third argument of the tuple is ignored by push_rec_types *) - let env = push_rec_types (name,tt,[||]) env in + (* Body argument of the tuple is ignored by push_rec_types *) + let env = push_rec_types (names,tt,[||]) env in (* We lift here because the types of arguments (in tt) will be evaluated in an environment where the fixpoints have been pushed *) let norm_body i v = nf_val env sigma (napply v fargs) (lift nbfix tt.(i)) in let ft = Array.mapi norm_body ft in - mkFix((rp,s),(name,tt,ft)), tt.(s) + mkFix((rp,s),(names,tt,ft)), tt.(s) | Acofix(tt,ft,s,_) | Acofixe(tt,ft,s,_) -> - let tt = Array.map (nf_type env sigma) tt in - let name = Array.map (fun _ -> (Name (Id.of_string "Fcofix"))) tt in + let tt = Array.map (fun t -> nf_type_sort env sigma t) tt in + let tt = Array.map fst tt and rt = Array.map snd tt in + let name = Name (Id.of_string "Fcofix") in let lvl = nb_rel env in + let names = Array.map (fun s -> make_annot name (Sorts.relevance_of_sort s)) rt in let fargs = mk_rels_accu lvl (Array.length ft) in - let env = push_rec_types (name,tt,[||]) env in + let env = push_rec_types (names,tt,[||]) env in let ft = Array.mapi (fun i v -> nf_val env sigma (napply v fargs) tt.(i)) ft in - mkCoFix(s,(name,tt,ft)), tt.(s) + mkCoFix(s,(names,tt,ft)), tt.(s) | Aprod(n,dom,codom) -> let dom,s1 = nf_type_sort env sigma dom in + let r1 = Sorts.relevance_of_sort s1 in + let n = make_annot n r1 in let vn = mk_rel_accu (nb_rel env) in let env = push_rel (LocalAssum (n,dom)) env in let codom,s2 = nf_type_sort env sigma (codom vn) in @@ -390,6 +401,8 @@ and nf_predicate env sigma ind mip params v pT = let rargs = Array.init n (fun i -> mkRel (n-i)) in let params = if Int.equal n 0 then params else Array.map (lift n) params in let dom = mkApp(mkIndU ind,Array.append params rargs) in + let r = Inductive.relevance_of_inductive env (fst ind) in + let name = make_annot name r in let body = nf_type (push_rel (LocalAssum (name,dom)) env) sigma vb in mkLambda(name,dom,body) | _ -> nf_type env sigma v diff --git a/pretyping/pattern.ml b/pretyping/pattern.ml index 2ca7f21e8d..d1c0a4ea2a 100644 --- a/pretyping/pattern.ml +++ b/pretyping/pattern.ml @@ -32,7 +32,7 @@ type constr_pattern = | PLambda of Name.t * constr_pattern * constr_pattern | PProd of Name.t * constr_pattern * constr_pattern | PLetIn of Name.t * constr_pattern * constr_pattern option * constr_pattern - | PSort of Glob_term.glob_sort + | PSort of Sorts.family | PMeta of patvar option | PIf of constr_pattern * constr_pattern * constr_pattern | PCase of case_info_pattern * constr_pattern * constr_pattern * diff --git a/pretyping/patternops.ml b/pretyping/patternops.ml index 6803ea7d9b..4e3c77cb1a 100644 --- a/pretyping/patternops.ml +++ b/pretyping/patternops.ml @@ -13,8 +13,8 @@ open Util open Names open Globnames open Nameops -open Term open Constr +open Context open Glob_term open Pp open Mod_subst @@ -46,7 +46,7 @@ let rec constr_pattern_eq p1 p2 = match p1, p2 with | PLetIn (v1, b1, t1, c1), PLetIn (v2, b2, t2, c2) -> Name.equal v1 v2 && constr_pattern_eq b1 b2 && Option.equal constr_pattern_eq t1 t2 && constr_pattern_eq c1 c2 -| PSort s1, PSort s2 -> Glob_ops.glob_sort_eq s1 s2 +| PSort s1, PSort s2 -> Sorts.family_equal s1 s2 | PMeta m1, PMeta m2 -> Option.equal Id.equal m1 m2 | PIf (t1, l1, r1), PIf (t2, l2, r2) -> constr_pattern_eq t1 t2 && constr_pattern_eq l1 l2 && constr_pattern_eq r1 r2 @@ -153,16 +153,17 @@ let pattern_of_constr env sigma t = | Rel n -> PRel n | Meta n -> PMeta (Some (Id.of_string ("META" ^ string_of_int n))) | Var id -> PVar id - | Sort Prop -> PSort GProp - | Sort Set -> PSort GSet - | Sort (Type _) -> PSort (GType []) + | Sort s -> PSort (Sorts.family s) | Cast (c,_,_) -> pattern_of_constr env c - | LetIn (na,c,t,b) -> PLetIn (na,pattern_of_constr env c,Some (pattern_of_constr env t), - pattern_of_constr (push_rel (LocalDef (na,c,t)) env) b) - | Prod (na,c,b) -> PProd (na,pattern_of_constr env c, - pattern_of_constr (push_rel (LocalAssum (na, c)) env) b) - | Lambda (na,c,b) -> PLambda (na,pattern_of_constr env c, - pattern_of_constr (push_rel (LocalAssum (na, c)) env) b) + | LetIn (na,c,t,b) -> PLetIn (na.binder_name, + pattern_of_constr env c,Some (pattern_of_constr env t), + pattern_of_constr (push_rel (LocalDef (na,c,t)) env) b) + | Prod (na,c,b) -> PProd (na.binder_name, + pattern_of_constr env c, + pattern_of_constr (push_rel (LocalAssum (na, c)) env) b) + | Lambda (na,c,b) -> PLambda (na.binder_name, + pattern_of_constr env c, + pattern_of_constr (push_rel (LocalAssum (na, c)) env) b) | App (f,a) -> (match match kind f with @@ -206,12 +207,12 @@ let pattern_of_constr env sigma t = | Fix (lni,(lna,tl,bl)) -> let push env na2 c2 = push_rel (LocalAssum (na2,c2)) env in let env' = Array.fold_left2 push env lna tl in - PFix (lni,(lna,Array.map (pattern_of_constr env) tl, + PFix (lni,(Array.map binder_name lna,Array.map (pattern_of_constr env) tl, Array.map (pattern_of_constr env') bl)) | CoFix (ln,(lna,tl,bl)) -> let push env na2 c2 = push_rel (LocalAssum (na2,c2)) env in let env' = Array.fold_left2 push env lna tl in - PCoFix (ln,(lna,Array.map (pattern_of_constr env) tl, + PCoFix (ln,(Array.map binder_name lna,Array.map (pattern_of_constr env) tl, Array.map (pattern_of_constr env') bl)) | Int i -> PInt i in pattern_of_constr env t @@ -411,8 +412,7 @@ let rec pat_of_raw metas vars = DAst.with_loc_val (fun ?loc -> function PLetIn (na, pat_of_raw metas vars c1, Option.map (pat_of_raw metas vars) t, pat_of_raw metas (na::vars) c2) - | GSort s -> - PSort s + | GSort gs -> PSort (Glob_ops.glob_sort_family gs) | GHole _ -> PMeta None | GCast (c,_) -> diff --git a/pretyping/pretype_errors.ml b/pretyping/pretype_errors.ml index dc6607557d..35a7036af4 100644 --- a/pretyping/pretype_errors.ml +++ b/pretyping/pretype_errors.ml @@ -60,6 +60,7 @@ type pretype_error = | CannotUnifyOccurrences of subterm_unification_error | UnsatisfiableConstraints of (Evar.t * Evar_kinds.t) option * Evar.Set.t option + | DisallowedSProp exception PretypeError of env * Evd.evar_map * pretype_error @@ -107,9 +108,9 @@ let error_ill_typed_rec_body ?loc env sigma i na jl tys = raise_type_error ?loc (env, sigma, IllTypedRecBody (i, na, jl, tys)) -let error_elim_arity ?loc env sigma pi s c j a = +let error_elim_arity ?loc env sigma pi c j a = raise_type_error ?loc - (env, sigma, ElimArity (pi, s, c, j, a)) + (env, sigma, ElimArity (pi, c, j, a)) let error_not_a_type ?loc env sigma j = raise_type_error ?loc (env, sigma, NotAType j) @@ -171,6 +172,9 @@ let error_var_not_found ?loc env sigma s = let error_evar_not_found ?loc env sigma id = raise_pretype_error ?loc (env, sigma, EvarNotFound id) +let error_disallowed_sprop env sigma = + raise (PretypeError (env, sigma, DisallowedSProp)) + (*s Typeclass errors *) let unsatisfiable_constraints env evd ev comp = diff --git a/pretyping/pretype_errors.mli b/pretyping/pretype_errors.mli index a0d459fe6b..a9e2b0ea8f 100644 --- a/pretyping/pretype_errors.mli +++ b/pretyping/pretype_errors.mli @@ -67,6 +67,7 @@ type pretype_error = | UnsatisfiableConstraints of (Evar.t * Evar_kinds.t) option * Evar.Set.t option (** unresolvable evar, connex component *) + | DisallowedSProp exception PretypeError of env * Evd.evar_map * pretype_error @@ -101,12 +102,12 @@ val error_number_branches : val error_ill_typed_rec_body : ?loc:Loc.t -> env -> Evd.evar_map -> - int -> Name.t array -> unsafe_judgment array -> types array -> 'b + int -> Name.t Context.binder_annot array -> unsafe_judgment array -> types array -> 'b val error_elim_arity : ?loc:Loc.t -> env -> Evd.evar_map -> - pinductive -> Sorts.family list -> constr -> - unsafe_judgment -> (Sorts.family * Sorts.family * arity_error) option -> 'b + pinductive -> constr -> + unsafe_judgment -> (Sorts.family list * Sorts.family * Sorts.family * arity_error) option -> 'b val error_not_a_type : ?loc:Loc.t -> env -> Evd.evar_map -> unsafe_judgment -> 'b @@ -158,6 +159,8 @@ val error_var_not_found : ?loc:Loc.t -> env -> Evd.evar_map -> Id.t -> 'b val error_evar_not_found : ?loc:Loc.t -> env -> Evd.evar_map -> Id.t -> 'b +val error_disallowed_sprop : env -> Evd.evar_map -> 'a + (** {6 Typeclass errors } *) val unsatisfiable_constraints : env -> Evd.evar_map -> Evar.t option -> diff --git a/pretyping/pretyping.ml b/pretyping/pretyping.ml index 9612932439..8e9a2e114b 100644 --- a/pretyping/pretyping.ml +++ b/pretyping/pretyping.ml @@ -29,7 +29,7 @@ open Util open Names open Evd open Constr -open Term +open Context open Termops open Environ open EConstr @@ -399,11 +399,13 @@ let pretype_id pretype k0 loc env sigma id = (* Main pretyping function *) let interp_known_glob_level ?loc evd = function + | GSProp -> Univ.Level.sprop | GProp -> Univ.Level.prop | GSet -> Univ.Level.set | GType s -> interp_known_level_info ?loc evd s let interp_glob_level ?loc evd : glob_level -> _ = function + | GSProp -> evd, Univ.Level.sprop | GProp -> evd, Univ.Level.prop | GSet -> evd, Univ.Level.set | GType s -> interp_level_info ?loc evd s @@ -448,11 +450,12 @@ let pretype_ref ?loc sigma env ref us = let judge_of_Type ?loc evd s = let evd, s = interp_universe ?loc evd s in let judge = - { uj_val = mkSort (Type s); uj_type = mkSort (Type (Univ.super s)) } + { uj_val = mkType s; uj_type = mkType (Univ.super s) } in evd, judge let pretype_sort ?loc sigma = function + | GSProp -> sigma, judge_of_sprop | GProp -> sigma, judge_of_prop | GSet -> sigma, judge_of_set | GType s -> judge_of_Type ?loc sigma s @@ -473,8 +476,8 @@ let mark_obligation_evar sigma k evc = let rec pretype ~program_mode k0 resolve_tc (tycon : type_constraint) (env : GlobEnv.t) (sigma : evar_map) t = let inh_conv_coerce_to_tycon ?loc = inh_conv_coerce_to_tycon ?loc ~program_mode resolve_tc in - let pretype_type = pretype_type k0 resolve_tc in - let pretype = pretype k0 resolve_tc in + let pretype_type = pretype_type ~program_mode k0 resolve_tc in + let pretype = pretype ~program_mode k0 resolve_tc in let open Context.Rel.Declaration in let loc = t.CAst.loc in match DAst.get t with @@ -483,7 +486,7 @@ let rec pretype ~program_mode k0 resolve_tc (tycon : type_constraint) (env : Glo inh_conv_coerce_to_tycon ?loc env sigma t_ref tycon | GVar id -> - let sigma, t_id = pretype_id (fun e r t -> pretype ~program_mode tycon e r t) k0 loc env sigma id in + let sigma, t_id = pretype_id (fun e r t -> pretype tycon e r t) k0 loc env sigma id in inh_conv_coerce_to_tycon ?loc env sigma t_id tycon | GEvar (id, inst) -> @@ -535,21 +538,23 @@ let rec pretype ~program_mode k0 resolve_tc (tycon : type_constraint) (env : Glo let rec type_bl env sigma ctxt = function | [] -> sigma, ctxt | (na,bk,None,ty)::bl -> - let sigma, ty' = pretype_type ~program_mode empty_valcon env sigma ty in - let dcl = LocalAssum (na, ty'.utj_val) in + let sigma, ty' = pretype_type empty_valcon env sigma ty in + let rty' = Sorts.relevance_of_sort ty'.utj_type in + let dcl = LocalAssum (make_annot na rty', ty'.utj_val) in let dcl', env = push_rel ~hypnaming sigma dcl env in type_bl env sigma (Context.Rel.add dcl' ctxt) bl | (na,bk,Some bd,ty)::bl -> - let sigma, ty' = pretype_type ~program_mode empty_valcon env sigma ty in - let sigma, bd' = pretype ~program_mode (mk_tycon ty'.utj_val) env sigma bd in - let dcl = LocalDef (na, bd'.uj_val, ty'.utj_val) in + let sigma, ty' = pretype_type empty_valcon env sigma ty in + let rty' = Sorts.relevance_of_sort ty'.utj_type in + let sigma, bd' = pretype (mk_tycon ty'.utj_val) env sigma bd in + let dcl = LocalDef (make_annot na rty', bd'.uj_val, ty'.utj_val) in let dcl', env = push_rel ~hypnaming sigma dcl env in type_bl env sigma (Context.Rel.add dcl' ctxt) bl in let sigma, ctxtv = Array.fold_left_map (fun sigma -> type_bl env sigma Context.Rel.empty) sigma bl in let sigma, larj = Array.fold_left2_map (fun sigma e ar -> - pretype_type ~program_mode empty_valcon (snd (push_rel_context ~hypnaming sigma e env)) sigma ar) + pretype_type empty_valcon (snd (push_rel_context ~hypnaming sigma e env)) sigma ar) sigma ctxtv lar in let lara = Array.map (fun a -> a.utj_val) larj in let ftys = Array.map2 (fun e a -> it_mkProd_or_LetIn a e) ctxtv lara in @@ -568,6 +573,10 @@ let rec pretype ~program_mode k0 resolve_tc (tycon : type_constraint) (env : Glo end | None -> sigma in + let names = Array.map2 (fun na t -> + make_annot na (Retyping.relevance_of_type !!(env) sigma t)) + names ftys + in (* Note: bodies are not used by push_rec_types, so [||] is safe *) let names,newenv = push_rec_types ~hypnaming sigma (names,ftys) env in let sigma, vdefj = @@ -579,7 +588,7 @@ let rec pretype ~program_mode k0 resolve_tc (tycon : type_constraint) (env : Glo decompose_prod_n_assum sigma (Context.Rel.length ctxt) (lift nbfix ftys.(i)) in let ctxt,nenv = push_rel_context ~hypnaming sigma ctxt newenv in - let sigma, j = pretype ~program_mode (mk_tycon ty) nenv sigma def in + let sigma, j = pretype (mk_tycon ty) nenv sigma def in sigma, { uj_val = it_mkLambda_or_LetIn j.uj_val ctxt; uj_type = it_mkProd_or_LetIn j.uj_type ctxt }) sigma ctxtv vdef in @@ -602,10 +611,10 @@ let rec pretype ~program_mode k0 resolve_tc (tycon : type_constraint) (env : Glo | None -> List.map_i (fun i _ -> i) 0 ctxtv.(i)) vn) in - let fixdecls = (names,ftys,fdefs) in + let fixdecls = (names,ftys,fdefs) in let indexes = esearch_guard ?loc !!env sigma possible_indexes fixdecls in make_judge (mkFix ((indexes,i),fixdecls)) ftys.(i) - | GCoFix i -> + | GCoFix i -> let fixdecls = (names,ftys,fdefs) in let cofix = (i, fixdecls) in (try check_cofix !!env (i, nf_fix sigma fixdecls) @@ -622,7 +631,7 @@ let rec pretype ~program_mode k0 resolve_tc (tycon : type_constraint) (env : Glo inh_conv_coerce_to_tycon ?loc env sigma j tycon | GApp (f,args) -> - let sigma, fj = pretype ~program_mode empty_tycon env sigma f in + let sigma, fj = pretype empty_tycon env sigma f in let floc = loc_of_glob_constr f in let length = List.length args in let candargs = @@ -665,7 +674,7 @@ let rec pretype ~program_mode k0 resolve_tc (tycon : type_constraint) (env : Glo match EConstr.kind sigma resty with | Prod (na,c1,c2) -> let tycon = Some c1 in - let sigma, hj = pretype ~program_mode tycon env sigma c in + let sigma, hj = pretype tycon env sigma c in let sigma, candargs, ujval = match candargs with | [] -> sigma, [], j_val hj @@ -677,12 +686,12 @@ let rec pretype ~program_mode k0 resolve_tc (tycon : type_constraint) (env : Glo sigma, args, nf_evar sigma (j_val hj) end in - let sigma, ujval = adjust_evar_source sigma na ujval in - let value, typ = app_f n (j_val resj) ujval, subst1 ujval c2 in + let sigma, ujval = adjust_evar_source sigma na.binder_name ujval in + let value, typ = app_f n (j_val resj) ujval, subst1 ujval c2 in let j = { uj_val = value; uj_type = typ } in apply_rec env sigma (n+1) j candargs rest | _ -> - let sigma, hj = pretype ~program_mode empty_tycon env sigma c in + let sigma, hj = pretype empty_tycon env sigma c in error_cant_apply_not_functional ?loc:(Loc.merge_opt floc argloc) !!env sigma resj [|hj|] in @@ -712,26 +721,28 @@ let rec pretype ~program_mode k0 resolve_tc (tycon : type_constraint) (env : Glo in let sigma, (name',dom,rng) = split_tycon ?loc !!env sigma tycon' in let dom_valcon = valcon_of_tycon dom in - let sigma, j = pretype_type ~program_mode dom_valcon env sigma c1 in + let sigma, j = pretype_type dom_valcon env sigma c1 in + let name = {binder_name=name; binder_relevance=Sorts.relevance_of_sort j.utj_type} in let var = LocalAssum (name, j.utj_val) in let hypnaming = if program_mode then ProgramNaming else KeepUserNameAndRenameExistingButSectionNames in let var',env' = push_rel ~hypnaming sigma var env in - let sigma, j' = pretype ~program_mode rng env' sigma c2 in + let sigma, j' = pretype rng env' sigma c2 in let name = get_name var' in - let resj = judge_of_abstraction !!env (orelse_name name name') j j' in + let resj = judge_of_abstraction !!env (orelse_name name name'.binder_name) j j' in inh_conv_coerce_to_tycon ?loc env sigma resj tycon | GProd(name,bk,c1,c2) -> - let sigma, j = pretype_type ~program_mode empty_valcon env sigma c1 in + let sigma, j = pretype_type empty_valcon env sigma c1 in let hypnaming = if program_mode then ProgramNaming else KeepUserNameAndRenameExistingButSectionNames in let sigma, name, j' = match name with | Anonymous -> - let sigma, j = pretype_type ~program_mode empty_valcon env sigma c2 in + let sigma, j = pretype_type empty_valcon env sigma c2 in sigma, name, { j with utj_val = lift 1 j.utj_val } | Name _ -> - let var = LocalAssum (name, j.utj_val) in + let r = Sorts.relevance_of_sort j.utj_type in + let var = LocalAssum (make_annot name r, j.utj_val) in let var, env' = push_rel ~hypnaming sigma var env in - let sigma, c2_j = pretype_type ~program_mode empty_valcon env' sigma c2 in + let sigma, c2_j = pretype_type empty_valcon env' sigma c2 in sigma, get_name var, c2_j in let resj = @@ -747,24 +758,25 @@ let rec pretype ~program_mode k0 resolve_tc (tycon : type_constraint) (env : Glo let sigma, tycon1 = match t with | Some t -> - let sigma, t_j = pretype_type ~program_mode empty_valcon env sigma t in + let sigma, t_j = pretype_type empty_valcon env sigma t in sigma, mk_tycon t_j.utj_val | None -> sigma, empty_tycon in - let sigma, j = pretype ~program_mode tycon1 env sigma c1 in + let sigma, j = pretype tycon1 env sigma c1 in let sigma, t = Evarsolve.refresh_universes ~onlyalg:true ~status:Evd.univ_flexible (Some false) !!env sigma j.uj_type in - let var = LocalDef (name, j.uj_val, t) in + let r = Retyping.relevance_of_term !!env sigma j.uj_val in + let var = LocalDef (make_annot name r, j.uj_val, t) in let tycon = lift_tycon 1 tycon in let hypnaming = if program_mode then ProgramNaming else KeepUserNameAndRenameExistingButSectionNames in let var, env = push_rel ~hypnaming sigma var env in - let sigma, j' = pretype ~program_mode tycon env sigma c2 in + let sigma, j' = pretype tycon env sigma c2 in let name = get_name var in - sigma, { uj_val = mkLetIn (name, j.uj_val, t, j'.uj_val) ; + sigma, { uj_val = mkLetIn (make_annot name r, j.uj_val, t, j'.uj_val) ; uj_type = subst1 j.uj_val j'.uj_type } | GLetTuple (nal,(na,po),c,d) -> - let sigma, cj = pretype ~program_mode empty_tycon env sigma c in + let sigma, cj = pretype empty_tycon env sigma c in let (IndType (indf,realargs)) = try find_rectype !!env sigma cj.uj_type with Not_found -> @@ -788,10 +800,11 @@ let rec pretype ~program_mode k0 resolve_tc (tycon : type_constraint) (env : Glo | Some ps -> let rec aux n k names l = match names, l with - | na :: names, (LocalAssum (_,t) :: l) -> + | na :: names, (LocalAssum (na', t) :: l) -> let t = EConstr.of_constr t in let proj = Projection.make ps.(cs.cs_nargs - k) true in - LocalDef (na, lift (cs.cs_nargs - n) (mkProj (proj, cj.uj_val)), t) + LocalDef ({na' with binder_name = na}, + lift (cs.cs_nargs - n) (mkProj (proj, cj.uj_val)), t) :: aux (n+1) (k + 1) names l | na :: names, (decl :: l) -> set_name na decl :: aux (n+1) k names l @@ -801,27 +814,27 @@ let rec pretype ~program_mode k0 resolve_tc (tycon : type_constraint) (env : Glo let fsign = Context.Rel.map (whd_betaiota sigma) fsign in let hypnaming = if program_mode then ProgramNaming else KeepUserNameAndRenameExistingButSectionNames in let fsign,env_f = push_rel_context ~hypnaming sigma fsign env in - let obj ind p v f = + let obj ind rci p v f = if not record then - let f = it_mkLambda_or_LetIn f fsign in - let ci = make_case_info !!env (fst ind) LetStyle in - mkCase (ci, p, cj.uj_val,[|f|]) + let f = it_mkLambda_or_LetIn f fsign in + let ci = make_case_info !!env (fst ind) rci LetStyle in + mkCase (ci, p, cj.uj_val,[|f|]) else it_mkLambda_or_LetIn f fsign in (* Make dependencies from arity signature impossible *) - let arsgn = - let arsgn,_ = get_arity !!env indf in - List.map (set_name Anonymous) arsgn + let arsgn, indr = + let arsgn,s = get_arity !!env indf in + List.map (set_name Anonymous) arsgn, Sorts.relevance_of_sort_family s in let indt = build_dependent_inductive !!env indf in - let psign = LocalAssum (na, indt) :: arsgn in (* For locating names in [po] *) + let psign = LocalAssum (make_annot na indr, indt) :: arsgn in (* For locating names in [po] *) let psign = List.map (fun d -> map_rel_decl EConstr.of_constr d) psign in let predenv = Cases.make_return_predicate_ltac_lvar env sigma na c cj.uj_val in let nar = List.length arsgn in let psign',env_p = push_rel_context ~hypnaming ~force_names:true sigma psign predenv in (match po with | Some p -> - let sigma, pj = pretype_type ~program_mode empty_valcon env_p sigma p in + let sigma, pj = pretype_type empty_valcon env_p sigma p in let ccl = nf_evar sigma pj.utj_val in let p = it_mkLambda_or_LetIn ccl psign' in let inst = @@ -829,17 +842,17 @@ let rec pretype ~program_mode k0 resolve_tc (tycon : type_constraint) (env : Glo @[EConstr.of_constr (build_dependent_constructor cs)] in let lp = lift cs.cs_nargs p in let fty = hnf_lam_applist !!env sigma lp inst in - let sigma, fj = pretype ~program_mode (mk_tycon fty) env_f sigma d in + let sigma, fj = pretype (mk_tycon fty) env_f sigma d in let v = let ind,_ = dest_ind_family indf in - Typing.check_allowed_sort !!env sigma ind cj.uj_val p; - obj ind p cj.uj_val fj.uj_val - in + let rci = Typing.check_allowed_sort !!env sigma ind cj.uj_val p in + obj ind rci p cj.uj_val fj.uj_val + in sigma, { uj_val = v; uj_type = (substl (realargs@[cj.uj_val]) ccl) } | None -> let tycon = lift_tycon cs.cs_nargs tycon in - let sigma, fj = pretype ~program_mode tycon env_f sigma d in + let sigma, fj = pretype tycon env_f sigma d in let ccl = nf_evar sigma fj.uj_type in let ccl = if noccur_between sigma 1 cs.cs_nargs ccl then @@ -851,12 +864,12 @@ let rec pretype ~program_mode k0 resolve_tc (tycon : type_constraint) (env : Glo let p = it_mkLambda_or_LetIn (lift (nar+1) ccl) psign' in let v = let ind,_ = dest_ind_family indf in - Typing.check_allowed_sort !!env sigma ind cj.uj_val p; - obj ind p cj.uj_val fj.uj_val + let rci = Typing.check_allowed_sort !!env sigma ind cj.uj_val p in + obj ind rci p cj.uj_val fj.uj_val in sigma, { uj_val = v; uj_type = ccl }) | GIf (c,(na,po),b1,b2) -> - let sigma, cj = pretype ~program_mode empty_tycon env sigma c in + let sigma, cj = pretype empty_tycon env sigma c in let (IndType (indf,realargs)) = try find_rectype !!env sigma cj.uj_type with Not_found -> @@ -867,21 +880,21 @@ let rec pretype ~program_mode k0 resolve_tc (tycon : type_constraint) (env : Glo user_err ?loc (str "If is only for inductive types with two constructors."); - let arsgn = - let arsgn,_ = get_arity !!env indf in + let arsgn, indr = + let arsgn,s = get_arity !!env indf in (* Make dependencies from arity signature impossible *) - List.map (set_name Anonymous) arsgn + List.map (set_name Anonymous) arsgn, Sorts.relevance_of_sort_family s in let nar = List.length arsgn in let indt = build_dependent_inductive !!env indf in - let psign = LocalAssum (na, indt) :: arsgn in (* For locating names in [po] *) + let psign = LocalAssum (make_annot na indr, indt) :: arsgn in (* For locating names in [po] *) let psign = List.map (fun d -> map_rel_decl EConstr.of_constr d) psign in let predenv = Cases.make_return_predicate_ltac_lvar env sigma na c cj.uj_val in let hypnaming = if program_mode then ProgramNaming else KeepUserNameAndRenameExistingButSectionNames in let psign,env_p = push_rel_context ~hypnaming sigma psign predenv in let sigma, pred, p = match po with | Some p -> - let sigma, pj = pretype_type ~program_mode empty_valcon env_p sigma p in + let sigma, pj = pretype_type empty_valcon env_p sigma p in let ccl = nf_evar sigma pj.utj_val in let pred = it_mkLambda_or_LetIn ccl psign in let typ = lift (- nar) (beta_applist sigma (pred,[cj.uj_val])) in @@ -904,38 +917,38 @@ let rec pretype ~program_mode k0 resolve_tc (tycon : type_constraint) (env : Glo List.map (set_name Anonymous) cs_args in let _,env_c = push_rel_context ~hypnaming sigma csgn env in - let sigma, bj = pretype ~program_mode (mk_tycon pi) env_c sigma b in + let sigma, bj = pretype (mk_tycon pi) env_c sigma b in sigma, it_mkLambda_or_LetIn bj.uj_val cs_args in let sigma, b1 = f sigma cstrs.(0) b1 in let sigma, b2 = f sigma cstrs.(1) b2 in let v = let ind,_ = dest_ind_family indf in - let ci = make_case_info !!env (fst ind) IfStyle in let pred = nf_evar sigma pred in - Typing.check_allowed_sort !!env sigma ind cj.uj_val pred; - mkCase (ci, pred, cj.uj_val, [|b1;b2|]) + let rci = Typing.check_allowed_sort !!env sigma ind cj.uj_val pred in + let ci = make_case_info !!env (fst ind) rci IfStyle in + mkCase (ci, pred, cj.uj_val, [|b1;b2|]) in let cj = { uj_val = v; uj_type = p } in inh_conv_coerce_to_tycon ?loc env sigma cj tycon | GCases (sty,po,tml,eqns) -> - Cases.compile_cases ?loc ~program_mode sty (pretype ~program_mode, sigma) tycon env (po,tml,eqns) + Cases.compile_cases ?loc ~program_mode sty (pretype, sigma) tycon env (po,tml,eqns) | GCast (c,k) -> let sigma, cj = match k with | CastCoerce -> - let sigma, cj = pretype ~program_mode empty_tycon env sigma c in + let sigma, cj = pretype empty_tycon env sigma c in Coercion.inh_coerce_to_base ?loc ~program_mode !!env sigma cj | CastConv t | CastVM t | CastNative t -> let k = (match k with CastVM _ -> VMcast | CastNative _ -> NATIVEcast | _ -> DEFAULTcast) in - let sigma, tj = pretype_type ~program_mode empty_valcon env sigma t in + let sigma, tj = pretype_type empty_valcon env sigma t in let sigma, tval = Evarsolve.refresh_universes ~onlyalg:true ~status:Evd.univ_flexible (Some false) !!env sigma tj.utj_val in let tval = nf_evar sigma tval in let (sigma, cj), tval = match k with | VMcast -> - let sigma, cj = pretype ~program_mode empty_tycon env sigma c in + let sigma, cj = pretype empty_tycon env sigma c in let cty = nf_evar sigma cj.uj_type and tval = nf_evar sigma tval in if not (occur_existential sigma cty || occur_existential sigma tval) then match Reductionops.vm_infer_conv !!env sigma cty tval with @@ -946,7 +959,7 @@ let rec pretype ~program_mode k0 resolve_tc (tycon : type_constraint) (env : Glo else user_err ?loc (str "Cannot check cast with vm: " ++ str "unresolved arguments remain.") | NATIVEcast -> - let sigma, cj = pretype ~program_mode empty_tycon env sigma c in + let sigma, cj = pretype empty_tycon env sigma c in let cty = nf_evar sigma cj.uj_type and tval = nf_evar sigma tval in begin match Nativenorm.native_infer_conv !!env sigma cty tval with @@ -956,7 +969,7 @@ let rec pretype ~program_mode k0 resolve_tc (tycon : type_constraint) (env : Glo (ConversionFailed (!!env,cty,tval)) end | _ -> - pretype ~program_mode (mk_tycon tval) env sigma c, tval + pretype (mk_tycon tval) env sigma c, tval in let v = mkCast (cj.uj_val, k, tval) in sigma, { uj_val = v; uj_type = tval } diff --git a/pretyping/pretyping.mllib b/pretyping/pretyping.mllib index d0359b43f4..34a6cecc95 100644 --- a/pretyping/pretyping.mllib +++ b/pretyping/pretyping.mllib @@ -5,10 +5,10 @@ Pretype_errors Reductionops Inductiveops InferCumulativity -Vnorm Arguments_renaming -Nativenorm Retyping +Vnorm +Nativenorm Cbv Find_subterm Evardefine diff --git a/pretyping/reductionops.ml b/pretyping/reductionops.ml index 98ca329117..71fbfe8716 100644 --- a/pretyping/reductionops.ml +++ b/pretyping/reductionops.ml @@ -12,6 +12,7 @@ open CErrors open Util open Names open Constr +open Context open Termops open Univ open Evd @@ -479,10 +480,10 @@ struct | App (i,a,j) -> let le = j - i + 1 in App (0,Array.map f (Array.sub a i le), le-1) - | Case (info,ty,br,alt) -> Case (info, f ty, Array.map f br, alt) - | Fix ((r,(na,ty,bo)),arg,alt) -> - Fix ((r,(na,Array.map f ty, Array.map f bo)),map f arg,alt) - | Cst (cst,curr,remains,params,alt) -> + | Case (info,ty,br,alt) -> Case (info, f ty, Array.map f br, alt) + | Fix ((r,(na,ty,bo)),arg,alt) -> + Fix ((r,(na,Array.map f ty, Array.map f bo)),map f arg,alt) + | Cst (cst,curr,remains,params,alt) -> Cst (cst,curr,remains,map f params,alt) | Primitive (p,c,args,kargs,cst_l) -> Primitive(p,c, map f args, kargs, cst_l) @@ -775,7 +776,7 @@ let contract_cofix ?env sigma ?reference (bodynum,(names,types,bodies as typedbo | Some e -> match reference with | None -> bd - | Some r -> magicaly_constant_of_fixbody e sigma r bd names.(ind) in + | Some r -> magicaly_constant_of_fixbody e sigma r bd names.(ind).binder_name in let closure = List.init nbodies make_Fi in substl closure bodies.(bodynum) @@ -817,7 +818,7 @@ let contract_fix ?env sigma ?reference ((recindices,bodynum),(names,types,bodies | Some e -> match reference with | None -> bd - | Some r -> magicaly_constant_of_fixbody e sigma r bd names.(ind) in + | Some r -> magicaly_constant_of_fixbody e sigma r bd names.(ind).binder_name in let closure = List.init nbodies make_Fi in substl closure bodies.(bodynum) @@ -1062,7 +1063,7 @@ let rec whd_state_gen ?csts ~refold ~tactic_mode flags env sigma = | Some _ when CClosure.RedFlags.red_set flags CClosure.RedFlags.fBETA -> apply_subst (fun _ -> whrec) [] sigma refold cst_l x stack | None when CClosure.RedFlags.red_set flags CClosure.RedFlags.fETA -> - let env' = push_rel (LocalAssum (na, t)) env in + let env' = push_rel (LocalAssum (na, t)) env in let whrec' = whd_state_gen ~refold ~tactic_mode flags env' sigma in (match EConstr.kind sigma (Stack.zip ~refold sigma (fst (whrec' (c, Stack.empty)))) with | App (f,cl) -> @@ -1520,7 +1521,9 @@ let plain_instance sigma s c = match EConstr.kind sigma g with | App _ -> let l' = Array.Fun1.Smart.map lift 1 l' in - mkLetIn (Name default_plain_instance_ident,g,t,mkApp(mkRel 1, l')) + let r = Sorts.Relevant in (* TODO fix relevance *) + let na = make_annot (Name default_plain_instance_ident) r in + mkLetIn (na,g,t,mkApp(mkRel 1, l')) | _ -> mkApp (g,l') with Not_found -> mkApp (f,l')) | _ -> mkApp (irec n f,l')) @@ -1623,11 +1626,11 @@ let splay_prod_assum env sigma = let t = whd_allnolet env sigma c in match EConstr.kind sigma t with | Prod (x,t,c) -> - prodec_rec (push_rel (LocalAssum (x,t)) env) - (Context.Rel.add (LocalAssum (x,t)) l) c + prodec_rec (push_rel (LocalAssum (x,t)) env) + (Context.Rel.add (LocalAssum (x,t)) l) c | LetIn (x,b,t,c) -> - prodec_rec (push_rel (LocalDef (x,b,t)) env) - (Context.Rel.add (LocalDef (x,b,t)) l) c + prodec_rec (push_rel (LocalDef (x,b,t)) env) + (Context.Rel.add (LocalDef (x,b,t)) l) c | Cast (c,_,_) -> prodec_rec env l c | _ -> let t' = whd_all env sigma t in @@ -1648,8 +1651,8 @@ let splay_prod_n env sigma n = let rec decrec env m ln c = if Int.equal m 0 then (ln,c) else match EConstr.kind sigma (whd_all env sigma c) with | Prod (n,a,c0) -> - decrec (push_rel (LocalAssum (n,a)) env) - (m-1) (Context.Rel.add (LocalAssum (n,a)) ln) c0 + decrec (push_rel (LocalAssum (n,a)) env) + (m-1) (Context.Rel.add (LocalAssum (n,a)) ln) c0 | _ -> invalid_arg "splay_prod_n" in decrec env n Context.Rel.empty @@ -1658,8 +1661,8 @@ let splay_lam_n env sigma n = let rec decrec env m ln c = if Int.equal m 0 then (ln,c) else match EConstr.kind sigma (whd_all env sigma c) with | Lambda (n,a,c0) -> - decrec (push_rel (LocalAssum (n,a)) env) - (m-1) (Context.Rel.add (LocalAssum (n,a)) ln) c0 + decrec (push_rel (LocalAssum (n,a)) env) + (m-1) (Context.Rel.add (LocalAssum (n,a)) ln) c0 | _ -> invalid_arg "splay_lam_n" in decrec env n Context.Rel.empty diff --git a/pretyping/reductionops.mli b/pretyping/reductionops.mli index fae0b23b83..5938d9b367 100644 --- a/pretyping/reductionops.mli +++ b/pretyping/reductionops.mli @@ -235,9 +235,9 @@ val hnf_lam_app : env -> evar_map -> constr -> constr -> constr val hnf_lam_appvect : env -> evar_map -> constr -> constr array -> constr val hnf_lam_applist : env -> evar_map -> constr -> constr list -> constr -val splay_prod : env -> evar_map -> constr -> (Name.t * constr) list * constr -val splay_lam : env -> evar_map -> constr -> (Name.t * constr) list * constr -val splay_arity : env -> evar_map -> constr -> (Name.t * constr) list * ESorts.t +val splay_prod : env -> evar_map -> constr -> (Name.t Context.binder_annot * constr) list * constr +val splay_lam : env -> evar_map -> constr -> (Name.t Context.binder_annot * constr) list * constr +val splay_arity : env -> evar_map -> constr -> (Name.t Context.binder_annot * constr) list * ESorts.t val sort_of_arity : env -> evar_map -> constr -> ESorts.t val splay_prod_n : env -> evar_map -> int -> constr -> rel_context * constr val splay_lam_n : env -> evar_map -> int -> constr -> rel_context * constr diff --git a/pretyping/retyping.ml b/pretyping/retyping.ml index a76a203e37..20120f4182 100644 --- a/pretyping/retyping.ml +++ b/pretyping/retyping.ml @@ -13,6 +13,7 @@ open CErrors open Util open Term open Constr +open Context open Inductive open Inductiveops open Names @@ -79,7 +80,8 @@ let rec subst_type env sigma typ = function let sort_of_atomic_type env sigma ft args = let rec concl_of_arity env n ar args = match EConstr.kind sigma (whd_all env sigma ar), args with - | Prod (na, t, b), h::l -> concl_of_arity (push_rel (LocalDef (na, lift n h, t)) env) (n + 1) b l + | Prod (na, t, b), h::l -> + concl_of_arity (push_rel (LocalDef (na, lift n h, t)) env) (n + 1) b l | Sort s, [] -> ESorts.kind sigma s | _ -> retype_error NotASort in concl_of_arity env 0 ft (Array.to_list args) @@ -150,8 +152,8 @@ let retype ?(polyprop=true) sigma = | Cast (c,_, s) when isSort sigma s -> destSort sigma s | Sort s -> begin match ESorts.kind sigma s with - | Prop | Set -> Sorts.type1 - | Type u -> Type (Univ.super u) + | SProp | Prop | Set -> Sorts.type1 + | Type u -> Sorts.sort_of_univ (Univ.super u) end | Prod (name,t,c2) -> let dom = sort_of env t in @@ -188,7 +190,7 @@ let get_sort_family_of ?(truncation_style=false) ?(polyprop=true) env sigma t = | Cast (c,_, s) when isSort sigma s -> Sorts.family (destSort sigma s) | Sort _ -> InType | Prod (name,t,c2) -> - let s2 = sort_family_of (push_rel (LocalAssum (name,t)) env) c2 in + let s2 = sort_family_of (push_rel (LocalAssum (name,t)) env) c2 in if not (is_impredicative_set env) && s2 == InSet && sort_family_of env t == InType then InType else s2 | App(f,args) when Termops.is_template_polymorphic_ind env sigma f -> @@ -256,3 +258,41 @@ let expand_projection env sigma pr c args = in mkApp (mkConstU (Projection.constant pr,u), Array.of_list (ind_args @ (c :: args))) + +let relevance_of_term env sigma c = + if Environ.sprop_allowed env then + let rec aux rels c = + match kind sigma c with + | Rel n -> Retypeops.relevance_of_rel_extra env rels n + | Var x -> Retypeops.relevance_of_var env x + | Sort _ -> Sorts.Relevant + | Cast (c, _, _) -> aux rels c + | Prod ({binder_relevance=r}, _, codom) -> + aux (r::rels) codom + | Lambda ({binder_relevance=r}, _, bdy) -> + aux (r::rels) bdy + | LetIn ({binder_relevance=r}, _, _, bdy) -> + aux (r::rels) bdy + | App (c, _) -> aux rels c + | Const (c,_) -> Retypeops.relevance_of_constant env c + | Ind _ -> Sorts.Relevant + | Construct (c,_) -> Retypeops.relevance_of_constructor env c + | Case (ci, _, _, _) -> ci.ci_relevance + | Fix ((_,i),(lna,_,_)) -> (lna.(i)).binder_relevance + | CoFix (i,(lna,_,_)) -> (lna.(i)).binder_relevance + | Proj (p, _) -> Retypeops.relevance_of_projection env p + | Int _ -> Sorts.Relevant + + | Meta _ | Evar _ -> Sorts.Relevant + + in + aux [] c + else Sorts.Relevant + +let relevance_of_type env sigma t = + let s = get_sort_family_of env sigma t in + Sorts.relevance_of_sort_family s + +let relevance_of_sort s = Sorts.relevance_of_sort (EConstr.Unsafe.to_sorts s) + +let relevance_of_sort_family f = Sorts.relevance_of_sort_family f diff --git a/pretyping/retyping.mli b/pretyping/retyping.mli index 2aff0c7775..252bfb1a84 100644 --- a/pretyping/retyping.mli +++ b/pretyping/retyping.mli @@ -53,3 +53,8 @@ val sorts_of_context : env -> evar_map -> rel_context -> Sorts.t list val expand_projection : env -> evar_map -> Names.Projection.t -> constr -> constr list -> constr val print_retype_error : retype_error -> Pp.t + +val relevance_of_term : env -> evar_map -> constr -> Sorts.relevance +val relevance_of_type : env -> evar_map -> types -> Sorts.relevance +val relevance_of_sort : ESorts.t -> Sorts.relevance +val relevance_of_sort_family : Sorts.family -> Sorts.relevance diff --git a/pretyping/tacred.ml b/pretyping/tacred.ml index 5db571433a..bcc20a41b4 100644 --- a/pretyping/tacred.ml +++ b/pretyping/tacred.ml @@ -13,6 +13,7 @@ open CErrors open Util open Names open Constr +open Context open Libnames open Globnames open Termops @@ -229,7 +230,8 @@ let check_fix_reversibility sigma labs args ((lv,i),(_,tys,bds)) = (* Heuristic to look if global names are associated to other components of a mutual fixpoint *) -let invert_name labs l na0 env sigma ref = function +let invert_name labs l {binder_name=na0} env sigma ref na = + match na.binder_name with | Name id -> let minfxargs = List.length l in begin match na0 with @@ -249,7 +251,7 @@ let invert_name labs l na0 env sigma ref = function | Some c -> let labs',ccl = decompose_lam sigma c in let _, l' = whd_betalet_stack sigma ccl in - let labs' = List.map snd labs' in + let labs' = List.map snd labs' in (* ppedrot: there used to be generic equality on terms here *) let eq_constr c1 c2 = EConstr.eq_constr sigma c1 c2 in if List.equal eq_constr labs' labs && @@ -269,7 +271,7 @@ let compute_consteval_direct env sigma ref = match EConstr.kind sigma c' with | Lambda (id,t,g) when List.is_empty l && not onlyproj -> let open Context.Rel.Declaration in - srec (push_rel (LocalAssum (id,t)) env) (n+1) (t::labs) onlyproj g + srec (push_rel (LocalAssum (id,t)) env) (n+1) (t::labs) onlyproj g | Fix fix when not onlyproj -> (try check_fix_reversibility sigma labs l fix with Elimconst -> NotAnElimination) @@ -289,7 +291,7 @@ let compute_consteval_mutual_fix env sigma ref = match EConstr.kind sigma c' with | Lambda (na,t,g) when List.is_empty l -> let open Context.Rel.Declaration in - srec (push_rel (LocalAssum (na,t)) env) (minarg+1) (t::labs) ref g + srec (push_rel (LocalAssum (na,t)) env) (minarg+1) (t::labs) ref g | Fix ((lv,i),(names,_,_)) -> (* Last known constant wrapping Fix is ref = [labs](Fix l) *) (match compute_consteval_direct env sigma ref with @@ -374,7 +376,8 @@ let make_elim_fun (names,(nbfix,lv,n)) u largs = List.fold_left_i (fun q (* j = n+1-q *) c (ij,tij) -> let subst = List.map (Vars.lift (-q)) (List.firstn (n-ij) la) in let tij' = Vars.substl (List.rev subst) tij in - mkLambda (x,tij',c)) 1 body (List.rev lv) + let x = make_annot x Sorts.Relevant in (* TODO relevance *) + mkLambda (x,tij',c)) 1 body (List.rev lv) in Some (minargs,g) (* [f] is convertible to [Fix(recindices,bodynum),bodyvect)]: @@ -384,7 +387,8 @@ let dummy = mkProp let vfx = Id.of_string "_expanded_fix_" let vfun = Id.of_string "_eliminator_function_" let venv = let open Context.Named.Declaration in - val_of_named_context [LocalAssum (vfx, dummy); LocalAssum (vfun, dummy)] + val_of_named_context [LocalAssum (make_annot vfx Sorts.Relevant, dummy); + LocalAssum (make_annot vfun Sorts.Relevant, dummy)] (* Mark every occurrence of substituted vars (associated to a function) as a problem variable: an evar that can be instantiated either by @@ -513,7 +517,7 @@ let reduce_mind_case_use_function func env sigma mia = let minargs = List.length mia.mcargs in fun i -> if Int.equal i bodynum then Some (minargs,func) - else match names.(i) with + else match names.(i).binder_name with | Anonymous -> None | Name id -> (* In case of a call to another component of a block of @@ -627,12 +631,12 @@ let whd_nothing_for_iota env sigma s = | Rel n -> let open Context.Rel.Declaration in (match lookup_rel n env with - | LocalDef (_,body,_) -> whrec (lift n body, stack) + | LocalDef (_,body,_) -> whrec (lift n body, stack) | _ -> s) | Var id -> let open Context.Named.Declaration in (match lookup_named id env with - | LocalDef (_,body,_) -> whrec (body, stack) + | LocalDef (_,body,_) -> whrec (body, stack) | _ -> s) | Evar ev -> s | Meta ev -> @@ -838,10 +842,10 @@ let try_red_product env sigma c = | Cast (c,_,_) -> redrec env c | Prod (x,a,b) -> let open Context.Rel.Declaration in - mkProd (x, a, redrec (push_rel (LocalAssum (x, a)) env) b) + mkProd (x, a, redrec (push_rel (LocalAssum (x, a)) env) b) | LetIn (x,a,b,t) -> redrec env (Vars.subst1 a t) | Case (ci,p,d,lf) -> simpfun (mkCase (ci,p,redrec env d,lf)) - | Proj (p, c) -> + | Proj (p, c) -> let c' = match EConstr.kind sigma c with | Construct _ -> c @@ -1150,6 +1154,7 @@ let compute = cbv_betadeltaiota let abstract_scheme env sigma (locc,a) (c, sigma) = let ta = Retyping.get_type_of env sigma a in let na = named_hd env sigma ta Anonymous in + let na = make_annot na Sorts.Relevant in (* TODO relevance *) if occur_meta sigma ta then user_err Pp.(str "Cannot find a type for the generalisation."); if occur_meta sigma a then mkLambda (na,ta,c), sigma @@ -1192,7 +1197,7 @@ let reduce_to_ind_gen allow_product env sigma t = | Prod (n,ty,t') -> let open Context.Rel.Declaration in if allow_product then - elimrec (push_rel (LocalAssum (n,ty)) env) t' ((LocalAssum (n,ty))::l) + elimrec (push_rel (LocalAssum (n,ty)) env) t' ((LocalAssum (n,ty))::l) else user_err (str"Not an inductive definition.") | _ -> @@ -1270,7 +1275,7 @@ let reduce_to_ref_gen allow_product env sigma ref t = | Prod (n,ty,t') -> if allow_product then let open Context.Rel.Declaration in - elimrec (push_rel (LocalAssum (n,t)) env) t' ((LocalAssum (n,ty))::l) + elimrec (push_rel (LocalAssum (n,ty)) env) t' ((LocalAssum (n,ty))::l) else error_cannot_recognize ref | _ -> diff --git a/pretyping/typing.ml b/pretyping/typing.ml index ea6e52e1f8..89f72c874b 100644 --- a/pretyping/typing.ml +++ b/pretyping/typing.ml @@ -15,6 +15,7 @@ open CErrors open Util open Term open Constr +open Context open Environ open EConstr open Vars @@ -65,7 +66,7 @@ let judge_of_applied_inductive_knowing_parameters env sigma funj ind argjv = match EConstr.kind sigma (whd_all env sigma typ) with | Prod (_,c1,c2) -> sigma, (c1,c2) | Evar ev -> - let (sigma,t) = Evardefine.define_evar_as_product sigma ev in + let (sigma,t) = Evardefine.define_evar_as_product env sigma ev in let (_,c1,c2) = destProd sigma t in sigma, (c1,c2) | _ -> @@ -90,7 +91,7 @@ let judge_of_apply env sigma funj argjv = match EConstr.kind sigma (whd_all env sigma typ) with | Prod (_,c1,c2) -> sigma, (c1,c2) | Evar ev -> - let (sigma,t) = Evardefine.define_evar_as_product sigma ev in + let (sigma,t) = Evardefine.define_evar_as_product env sigma ev in let (_,c1,c2) = destProd sigma t in sigma, (c1,c2) | _ -> @@ -122,7 +123,7 @@ let max_sort l = let is_correct_arity env sigma c pj ind specif params = let arsign = make_arity_signature env sigma true (make_ind_family (ind,params)) in let allowed_sorts = elim_sorts specif in - let error () = Pretype_errors.error_elim_arity env sigma ind allowed_sorts c pj None in + let error () = Pretype_errors.error_elim_arity env sigma ind c pj None in let rec srec env sigma pt ar = let pt' = whd_all env sigma pt in match EConstr.kind sigma pt', ar with @@ -136,11 +137,11 @@ let is_correct_arity env sigma c pj ind specif params = let s = ESorts.kind sigma s in if not (Sorts.List.mem (Sorts.family s) allowed_sorts) then error () - else sigma + else sigma, s | Evar (ev,_), [] -> let sigma, s = Evd.fresh_sort_in_family sigma (max_sort allowed_sorts) in let sigma = Evd.define ev (mkSort s) sigma in - sigma + sigma, s | _, (LocalDef _ as d)::ar' -> srec (push_rel d env) sigma (lift 1 pt') ar' | _ -> @@ -165,20 +166,20 @@ let type_case_branches env sigma (ind,largs) pj c = let (params,realargs) = List.chop nparams largs in let p = pj.uj_val in let params = List.map EConstr.Unsafe.to_constr params in - let sigma = is_correct_arity env sigma c pj ind specif params in + let sigma, ps = is_correct_arity env sigma c pj ind specif params in let lc = build_branches_type ind specif params (EConstr.to_constr ~abort_on_undefined_evars:false sigma p) in let lc = Array.map EConstr.of_constr lc in let n = (snd specif).Declarations.mind_nrealdecls in let ty = whd_betaiota sigma (lambda_applist_assum sigma (n+1) p (realargs@[c])) in - sigma, (lc, ty) + sigma, (lc, ty, Sorts.relevance_of_sort ps) let judge_of_case env sigma ci pj cj lfj = let ((ind, u), spec) = try find_mrectype env sigma cj.uj_type with Not_found -> error_case_not_inductive env sigma cj in let indspec = ((ind, EInstance.kind sigma u), spec) in - let _ = check_case_info env (fst indspec) ci in - let sigma, (bty,rslty) = type_case_branches env sigma indspec pj cj.uj_val in + let sigma, (bty,rslty,rci) = type_case_branches env sigma indspec pj cj.uj_val in + let () = check_case_info env (fst indspec) rci ci in let sigma = check_branch_types env sigma (fst indspec) cj (lfj,bty) in sigma, { uj_val = mkCase (ci, pj.uj_val, cj.uj_val, Array.map j_val lfj); uj_type = rslty } @@ -203,11 +204,13 @@ let check_allowed_sort env sigma ind c p = let _, s = splay_prod env sigma pj.uj_type in let ksort = match EConstr.kind sigma s with | Sort s -> Sorts.family (ESorts.kind sigma s) - | _ -> error_elim_arity env sigma ind sorts c pj None in + | _ -> error_elim_arity env sigma ind c pj None in if not (List.exists ((==) ksort) sorts) then let s = inductive_sort_family (snd specif) in - error_elim_arity env sigma ind sorts c pj - (Some(ksort,s,Type_errors.error_elim_explain ksort s)) + error_elim_arity env sigma ind c pj + (Some(sorts,ksort,s,Type_errors.error_elim_explain ksort s)) + else + Sorts.relevance_of_sort_family ksort let judge_of_cast env sigma cj k tj = let expected_type = tj.utj_val in @@ -230,6 +233,10 @@ let check_cofix env sigma pcofix = (* The typing machine with universes and existential variables. *) +let judge_of_sprop = + { uj_val = EConstr.mkSProp; + uj_type = EConstr.type1 } + let judge_of_prop = { uj_val = EConstr.mkProp; uj_type = EConstr.mkSort Sorts.type1 } @@ -262,16 +269,19 @@ let judge_of_projection env sigma p cj = uj_type = ty} let judge_of_abstraction env name var j = - { uj_val = mkLambda (name, var.utj_val, j.uj_val); - uj_type = mkProd (name, var.utj_val, j.uj_type) } + let r = Sorts.relevance_of_sort var.utj_type in + { uj_val = mkLambda (make_annot name r, var.utj_val, j.uj_val); + uj_type = mkProd (make_annot name r, var.utj_val, j.uj_type) } let judge_of_product env name t1 t2 = + let r = Sorts.relevance_of_sort t1.utj_type in let s = sort_of_product env t1.utj_type t2.utj_type in - { uj_val = mkProd (name, t1.utj_val, t2.utj_val); + { uj_val = mkProd (make_annot name r, t1.utj_val, t2.utj_val); uj_type = mkSort s } let judge_of_letin env name defj typj j = - { uj_val = mkLetIn (name, defj.uj_val, typj.utj_val, j.uj_val) ; + let r = Sorts.relevance_of_sort typj.utj_type in + { uj_val = mkLetIn (make_annot name r, defj.uj_val, typj.utj_val, j.uj_val) ; uj_type = subst1 defj.uj_val j.uj_type } let check_hyps_inclusion env sigma f x hyps = @@ -349,7 +359,7 @@ let rec execute env sigma cstr = | Fix ((vn,i as vni),recdef) -> let sigma, (_,tys,_ as recdef') = execute_recdef env sigma recdef in - let fix = (vni,recdef') in + let fix = (vni,recdef') in check_fix env sigma fix; sigma, make_judge (mkFix fix) tys.(i) @@ -361,6 +371,9 @@ let rec execute env sigma cstr = | Sort s -> begin match ESorts.kind sigma s with + | SProp -> + if Environ.sprop_allowed env then sigma, judge_of_sprop + else error_disallowed_sprop env sigma | Prop -> sigma, judge_of_prop | Set -> sigma, judge_of_set | Type u -> sigma, judge_of_type u @@ -384,26 +397,29 @@ let rec execute env sigma cstr = | Lambda (name,c1,c2) -> let sigma, j = execute env sigma c1 in let sigma, var = type_judgment env sigma j in - let env1 = push_rel (LocalAssum (name, var.utj_val)) env in + let name = check_binder_annot var.utj_type name in + let env1 = push_rel (LocalAssum (name, var.utj_val)) env in let sigma, j' = execute env1 sigma c2 in - sigma, judge_of_abstraction env1 name var j' + sigma, judge_of_abstraction env1 name.binder_name var j' | Prod (name,c1,c2) -> let sigma, j = execute env sigma c1 in let sigma, varj = type_judgment env sigma j in - let env1 = push_rel (LocalAssum (name, varj.utj_val)) env in + let name = check_binder_annot varj.utj_type name in + let env1 = push_rel (LocalAssum (name, varj.utj_val)) env in let sigma, j' = execute env1 sigma c2 in let sigma, varj' = type_judgment env1 sigma j' in - sigma, judge_of_product env name varj varj' + sigma, judge_of_product env name.binder_name varj varj' | LetIn (name,c1,c2,c3) -> let sigma, j1 = execute env sigma c1 in let sigma, j2 = execute env sigma c2 in let sigma, j2 = type_judgment env sigma j2 in let sigma, _ = judge_of_cast env sigma j1 DEFAULTcast j2 in + let name = check_binder_annot j2.utj_type name in let env1 = push_rel (LocalDef (name, j1.uj_val, j2.utj_val)) env in let sigma, j3 = execute env1 sigma c3 in - sigma, judge_of_letin env name j1 j2 j3 + sigma, judge_of_letin env name.binder_name j1 j2 j3 | Cast (c,k,t) -> let sigma, cj = execute env sigma c in diff --git a/pretyping/typing.mli b/pretyping/typing.mli index 1ea16bbf34..f68820429b 100644 --- a/pretyping/typing.mli +++ b/pretyping/typing.mli @@ -39,13 +39,14 @@ val solve_evars : env -> evar_map -> constr -> evar_map * constr (** Raise an error message if incorrect elimination for this inductive (first constr is term to match, second is return predicate) *) val check_allowed_sort : env -> evar_map -> pinductive -> constr -> constr -> - unit + Sorts.relevance (** Raise an error message if bodies have types not unifiable with the expected ones *) val check_type_fixpoint : ?loc:Loc.t -> env -> evar_map -> - Names.Name.t array -> types array -> unsafe_judgment array -> evar_map + Names.Name.t Context.binder_annot array -> types array -> unsafe_judgment array -> evar_map +val judge_of_sprop : unsafe_judgment val judge_of_prop : unsafe_judgment val judge_of_set : unsafe_judgment val judge_of_apply : env -> evar_map -> unsafe_judgment -> unsafe_judgment array -> diff --git a/pretyping/unification.ml b/pretyping/unification.ml index 3de8c381d0..9ba51dcfa9 100644 --- a/pretyping/unification.ml +++ b/pretyping/unification.ml @@ -13,6 +13,7 @@ open Pp open Util open Names open Constr +open Context open Termops open Environ open EConstr @@ -103,13 +104,13 @@ let occur_meta_evd sigma mv c = let abstract_scheme env evd c l lname_typ = let mkLambda_name env (n,a,b) = - mkLambda (named_hd env evd a n, a, b) + mkLambda (map_annot (named_hd env evd a) n, a, b) in List.fold_left2 (fun (t,evd) (locc,a) decl -> - let na = RelDecl.get_name decl in + let na = RelDecl.get_annot decl in let ta = RelDecl.get_type decl in - let na = match EConstr.kind evd a with Var id -> Name id | _ -> na in + let na = match EConstr.kind evd a with Var id -> {na with binder_name=Name id} | _ -> na in (* [occur_meta ta] test removed for support of eelim/ecase but consequences are unclear... if occur_meta ta then error "cannot find a type for the generalisation" @@ -117,7 +118,7 @@ let abstract_scheme env evd c l lname_typ = if occur_meta evd a then mkLambda_name env (na,ta,t), evd else let t', evd' = Find_subterm.subst_closed_term_occ env evd locc a t in - mkLambda_name env (na,ta,t'), evd') + mkLambda_name env (na,ta,t'), evd') (c,evd) (List.rev l) lname_typ @@ -561,8 +562,8 @@ let is_rigid_head sigma flags t = | Ind (i,u) -> true | Construct _ | Int _ -> true | Fix _ | CoFix _ -> true - | Rel _ | Var _ | Meta _ | Evar _ | Sort _ | Cast (_, _, _) | Prod (_, _, _) - | Lambda (_, _, _) | LetIn (_, _, _, _) | App (_, _) | Case (_, _, _, _) + | Rel _ | Var _ | Meta _ | Evar _ | Sort _ | Cast (_, _, _) | Prod _ + | Lambda _ | LetIn _ | App (_, _) | Case (_, _, _, _) | Proj (_, _) -> false (* Why aren't Prod, Sort rigid heads ? *) let force_eqs c = @@ -662,7 +663,7 @@ let is_eta_constructor_app env sigma ts f l1 term = let mib = lookup_mind (fst ind) env in (match mib.Declarations.mind_record with | PrimRecord info when mib.Declarations.mind_finite == Declarations.BiFinite && - let (_, projs, _) = info.(i) in + let (_, projs, _, _) = info.(i) in Array.length projs == Array.length l1 - mib.Declarations.mind_nparams -> (* Check that the other term is neutral *) is_neutral env sigma ts term @@ -782,14 +783,14 @@ let rec unify_0_with_initial_metas (sigma,ms,es as subst : subst0) conv_at_top e with e when CErrors.noncritical e -> error_cannot_unify curenv sigma (m,n)) - | Lambda (na,t1,c1), Lambda (_,t2,c2) -> - unirec_rec (push (na,t1) curenvnb) CONV {opt with at_top = true} + | Lambda (na,t1,c1), Lambda (__,t2,c2) -> + unirec_rec (push (na,t1) curenvnb) CONV {opt with at_top = true} (unirec_rec curenvnb CONV {opt with at_top = true; with_types = false} substn t1 t2) c1 c2 - | Prod (na,t1,c1), Prod (_,t2,c2) -> - unirec_rec (push (na,t1) curenvnb) pb {opt with at_top = true} + | Prod (na,t1,c1), Prod (_,t2,c2) -> + unirec_rec (push (na,t1) curenvnb) pb {opt with at_top = true} (unirec_rec curenvnb CONV {opt with at_top = true; with_types = false} substn t1 t2) c1 c2 - | LetIn (_,a,_,c), _ -> unirec_rec curenvnb pb opt substn (subst1 a c) cN - | _, LetIn (_,a,_,c) -> unirec_rec curenvnb pb opt substn cM (subst1 a c) + | LetIn (_,a,_,c), _ -> unirec_rec curenvnb pb opt substn (subst1 a c) cN + | _, LetIn (_,a,_,c) -> unirec_rec curenvnb pb opt substn cM (subst1 a c) (* Fast path for projections. *) | Proj (p1,c1), Proj (p2,c2) when Constant.equal @@ -800,11 +801,11 @@ let rec unify_0_with_initial_metas (sigma,ms,es as subst : subst0) conv_at_top e unify_not_same_head curenvnb pb opt substn cM cN) (* eta-expansion *) - | Lambda (na,t1,c1), _ when flags.modulo_eta -> - unirec_rec (push (na,t1) curenvnb) CONV {opt with at_top = true} substn + | Lambda (na,t1,c1), _ when flags.modulo_eta -> + unirec_rec (push (na,t1) curenvnb) CONV {opt with at_top = true} substn c1 (mkApp (lift 1 cN,[|mkRel 1|])) - | _, Lambda (na,t2,c2) when flags.modulo_eta -> - unirec_rec (push (na,t2) curenvnb) CONV {opt with at_top = true} substn + | _, Lambda (na,t2,c2) when flags.modulo_eta -> + unirec_rec (push (na,t2) curenvnb) CONV {opt with at_top = true} substn (mkApp (lift 1 cM,[|mkRel 1|])) c2 (* For records *) @@ -1775,7 +1776,7 @@ let w_unify_to_subterm env evd ?(flags=default_unify_flags ()) (op,cl) = matchrec c with ex when precatchable_exception ex -> iter_fail matchrec lf) - | LetIn(_,c1,_,c2) -> + | LetIn(_,c1,_,c2) -> (try matchrec c1 with ex when precatchable_exception ex -> @@ -1783,13 +1784,13 @@ let w_unify_to_subterm env evd ?(flags=default_unify_flags ()) (op,cl) = | Proj (p,c) -> matchrec c - | Fix(_,(_,types,terms)) -> + | Fix(_,(_,types,terms)) -> (try iter_fail matchrec types with ex when precatchable_exception ex -> iter_fail matchrec terms) - | CoFix(_,(_,types,terms)) -> + | CoFix(_,(_,types,terms)) -> (try iter_fail matchrec types with ex when precatchable_exception ex -> @@ -1860,13 +1861,13 @@ let w_unify_to_subterm_all env evd ?(flags=default_unify_flags ()) (op,cl) = | Proj (p,c) -> matchrec c - | LetIn(_,c1,_,c2) -> + | LetIn(_,c1,_,c2) -> bind (matchrec c1) (matchrec c2) - | Fix(_,(_,types,terms)) -> + | Fix(_,(_,types,terms)) -> bind (bind_iter matchrec types) (bind_iter matchrec terms) - | CoFix(_,(_,types,terms)) -> + | CoFix(_,(_,types,terms)) -> bind (bind_iter matchrec types) (bind_iter matchrec terms) | Prod (_,t,c) -> diff --git a/pretyping/vnorm.ml b/pretyping/vnorm.ml index ff528bd2cf..62e9e477f7 100644 --- a/pretyping/vnorm.ml +++ b/pretyping/vnorm.ml @@ -13,6 +13,7 @@ open Names open Declarations open Term open Constr +open Context open Vars open Environ open Inductive @@ -31,10 +32,12 @@ module NamedDecl = Context.Named.Declaration let crazy_type = mkSet let decompose_prod env t = - let (name,dom,codom as res) = destProd (whd_all env t) in - match name with - | Anonymous -> (Name (Id.of_string "x"), dom, codom) - | Name _ -> res + let (name,dom,codom) = destProd (whd_all env t) in + let name = map_annot (function + | Anonymous -> Name (Id.of_string "x") + | Name _ as na -> na) name + in + (name,dom,codom) exception Find_at of int @@ -138,6 +141,8 @@ and nf_whd env sigma whd typ = let dom = nf_vtype env sigma (dom p) in let name = Name (Id.of_string "x") in let vc = reduce_fun (nb_rel env) (codom p) in + let r = Retyping.relevance_of_type env sigma (EConstr.of_constr dom) in + let name = make_annot name r in let codom = nf_vtype (push_rel (LocalAssum (name,dom)) env) sigma vc in mkProd(name,dom,codom) | Vfun f -> nf_fun env sigma f typ @@ -307,6 +312,8 @@ and nf_predicate env sigma ind mip params v pT = let rargs = Array.init n (fun i -> mkRel (n-i)) in let params = if Int.equal n 0 then params else Array.map (lift n) params in let dom = mkApp(mkIndU ind,Array.append params rargs) in + let r = Inductive.relevance_of_inductive env (fst ind) in + let name = make_annot name r in let body = nf_vtype (push_rel (LocalAssum (name,dom)) env) sigma vb in mkLambda(name,dom,body) | _ -> assert false @@ -317,7 +324,7 @@ and nf_args env sigma vargs ?from:(f=0) t = let args = Array.init len (fun i -> - let _,dom,codom = decompose_prod env !t in + let _,dom,codom = decompose_prod env !t in let c = nf_val env sigma (arg vargs (f+i)) dom in t := subst1 c codom; c) in !t,args @@ -328,7 +335,7 @@ and nf_bargs env sigma b ofs t = let args = Array.init len (fun i -> - let _,dom,codom = decompose_prod env !t in + let _,dom,codom = decompose_prod env !t in let c = nf_val env sigma (bfield b (i+ofs)) dom in t := subst1 c codom; c) in args @@ -353,14 +360,17 @@ and nf_fix env sigma f = let vb, vt = reduce_fix k f in let ndef = Array.length vt in let ft = Array.map (fun v -> nf_val env sigma v crazy_type) vt in - let name = Array.init ndef (fun _ -> (Name (Id.of_string "Ffix"))) in - (* Third argument of the tuple is ignored by push_rec_types *) - let env = push_rec_types (name,ft,ft) env in + let name = Name (Id.of_string "Ffix") in + let names = Array.map (fun t -> + make_annot name @@ + Retyping.relevance_of_type env sigma (EConstr.of_constr t)) ft in + (* Body argument of the tuple is ignored by push_rec_types *) + let env = push_rec_types (names,ft,ft) env in (* We lift here because the types of arguments (in tt) will be evaluated in an environment where the fixpoints have been pushed *) let norm_vb v t = nf_fun env sigma v (lift ndef t) in let fb = Util.Array.map2 norm_vb vb ft in - mkFix ((rec_args,init),(name,ft,fb)) + mkFix ((rec_args,init),(names,ft,fb)) and nf_fix_app env sigma f vargs = let fd = nf_fix env sigma f in @@ -373,12 +383,14 @@ and nf_cofix env sigma cf = let init = current_cofix cf in let k = nb_rel env in let vb,vt = reduce_cofix k cf in - let ndef = Array.length vt in let cft = Array.map (fun v -> nf_val env sigma v crazy_type) vt in - let name = Array.init ndef (fun _ -> (Name (Id.of_string "Fcofix"))) in - let env = push_rec_types (name,cft,cft) env in + let name = Name (Id.of_string "Fcofix") in + let names = Array.map (fun t -> + make_annot name @@ + Retyping.relevance_of_type env sigma (EConstr.of_constr t)) cft in + let env = push_rec_types (names,cft,cft) env in let cfb = Util.Array.map2 (fun v t -> nf_val env sigma v t) vb cft in - mkCoFix (init,(name,cft,cfb)) + mkCoFix (init,(names,cft,cfb)) let cbv_vm env sigma c t = if Termops.occur_meta sigma c then diff --git a/printing/genprint.ml b/printing/genprint.ml index fa53a87945..2f0f7f48c9 100644 --- a/printing/genprint.ml +++ b/printing/genprint.ml @@ -24,8 +24,8 @@ type 'a with_level = printer : 'a } type printer_result = -| PrinterBasic of (unit -> Pp.t) -| PrinterNeedsLevel of (Notation_gram.tolerability -> Pp.t) with_level +| PrinterBasic of (Environ.env -> Evd.evar_map -> Pp.t) +| PrinterNeedsLevel of (Environ.env -> Evd.evar_map -> Notation_gram.tolerability -> Pp.t) with_level type printer_fun_with_level = Environ.env -> Evd.evar_map -> Notation_gram.tolerability -> Pp.t @@ -120,8 +120,8 @@ struct | ExtraArg tag -> let name = ArgT.repr tag in let printer = { - raw = (fun _ -> PrinterBasic (fun () -> str "<genarg:" ++ str name ++ str ">")); - glb = (fun _ -> PrinterBasic (fun () -> str "<genarg:" ++ str name ++ str ">")); + raw = (fun _ -> PrinterBasic (fun env sigma -> str "<genarg:" ++ str name ++ str ">")); + glb = (fun _ -> PrinterBasic (fun env sigma -> str "<genarg:" ++ str name ++ str ">")); top = (fun _ -> TopPrinterBasic (fun () -> str "<genarg:" ++ str name ++ str ">")); } in Some printer diff --git a/printing/genprint.mli b/printing/genprint.mli index 1a31025a9a..24b008643b 100644 --- a/printing/genprint.mli +++ b/printing/genprint.mli @@ -18,8 +18,8 @@ type 'a with_level = printer : 'a } type printer_result = -| PrinterBasic of (unit -> Pp.t) -| PrinterNeedsLevel of (Notation_gram.tolerability -> Pp.t) with_level +| PrinterBasic of (Environ.env -> Evd.evar_map -> Pp.t) +| PrinterNeedsLevel of (Environ.env -> Evd.evar_map -> Notation_gram.tolerability -> Pp.t) with_level type printer_fun_with_level = Environ.env -> Evd.evar_map -> Notation_gram.tolerability -> Pp.t diff --git a/printing/ppconstr.ml b/printing/ppconstr.ml index 26202ef4ca..229930142e 100644 --- a/printing/ppconstr.ml +++ b/printing/ppconstr.ml @@ -169,12 +169,14 @@ let tag_var = tag Tag.variable let pr_univ_annot pr x = str "@{" ++ pr x ++ str "}" let pr_glob_sort = let open Glob_term in function + | GSProp -> tag_type (str "SProp") | GProp -> tag_type (str "Prop") | GSet -> tag_type (str "Set") | GType [] -> tag_type (str "Type") | GType u -> hov 0 (tag_type (str "Type") ++ pr_univ_annot pr_univ u) let pr_glob_level = let open Glob_term in function + | GSProp -> tag_type (str "SProp") | GProp -> tag_type (str "Prop") | GSet -> tag_type (str "Set") | GType UUnknown -> tag_type (str "Type") @@ -197,6 +199,8 @@ let tag_var = tag Tag.variable let pr_patvar = pr_id let pr_glob_sort_instance = let open Glob_term in function + | GSProp -> + tag_type (str "SProp") | GProp -> tag_type (str "Prop") | GSet -> @@ -665,10 +669,10 @@ let tag_var = tag Tag.variable (sep() ++ if prec_less prec inherited then strm else surround strm) type term_pr = { - pr_constr_expr : constr_expr -> Pp.t; - pr_lconstr_expr : constr_expr -> Pp.t; - pr_constr_pattern_expr : constr_pattern_expr -> Pp.t; - pr_lconstr_pattern_expr : constr_pattern_expr -> Pp.t + pr_constr_expr : Environ.env -> Evd.evar_map -> constr_expr -> Pp.t; + pr_lconstr_expr : Environ.env -> Evd.evar_map -> constr_expr -> Pp.t; + pr_constr_pattern_expr : Environ.env -> Evd.evar_map -> constr_pattern_expr -> Pp.t; + pr_lconstr_pattern_expr : Environ.env -> Evd.evar_map -> constr_pattern_expr -> Pp.t } let modular_constr_pr = pr @@ -689,18 +693,16 @@ let tag_var = tag Tag.variable Constrextern.extern_glob_constr (Termops.vars_of_env env) r else c - let pr_expr prec c = - let env = Global.env () in - let sigma = Evd.from_env env in + let pr_expr env sigma prec c = pr prec (transf env sigma c) - let pr_simpleconstr = pr_expr lsimpleconstr + let pr_simpleconstr env sigma = pr_expr env sigma lsimpleconstr let default_term_pr = { pr_constr_expr = pr_simpleconstr; - pr_lconstr_expr = pr_expr ltop; + pr_lconstr_expr = (fun env sigma -> pr_expr env sigma ltop); pr_constr_pattern_expr = pr_simpleconstr; - pr_lconstr_pattern_expr = pr_expr ltop + pr_lconstr_pattern_expr = (fun env sigma -> pr_expr env sigma ltop) } let term_pr = ref default_term_pr @@ -717,5 +719,5 @@ let tag_var = tag Tag.variable let pr_record_body = pr_record_body_gen pr - let pr_binders = pr_undelimited_binders spc (pr_expr ltop) + let pr_binders env sigma = pr_undelimited_binders spc (pr_expr env sigma ltop) diff --git a/printing/ppconstr.mli b/printing/ppconstr.mli index 1cb3aa6d7a..db1687a49b 100644 --- a/printing/ppconstr.mli +++ b/printing/ppconstr.mli @@ -41,19 +41,19 @@ val pr_guard_annot : (constr_expr -> Pp.t) -> Pp.t val pr_record_body : (qualid * constr_expr) list -> Pp.t -val pr_binders : local_binder_expr list -> Pp.t -val pr_constr_pattern_expr : constr_pattern_expr -> Pp.t -val pr_lconstr_pattern_expr : constr_pattern_expr -> Pp.t -val pr_constr_expr : constr_expr -> Pp.t -val pr_lconstr_expr : constr_expr -> Pp.t +val pr_binders : Environ.env -> Evd.evar_map -> local_binder_expr list -> Pp.t +val pr_constr_pattern_expr : Environ.env -> Evd.evar_map -> constr_pattern_expr -> Pp.t +val pr_lconstr_pattern_expr : Environ.env -> Evd.evar_map -> constr_pattern_expr -> Pp.t +val pr_constr_expr : Environ.env -> Evd.evar_map -> constr_expr -> Pp.t +val pr_lconstr_expr : Environ.env -> Evd.evar_map -> constr_expr -> Pp.t val pr_cases_pattern_expr : cases_pattern_expr -> Pp.t -val pr_constr_expr_n : tolerability -> constr_expr -> Pp.t +val pr_constr_expr_n : Environ.env -> Evd.evar_map -> tolerability -> constr_expr -> Pp.t type term_pr = { - pr_constr_expr : constr_expr -> Pp.t; - pr_lconstr_expr : constr_expr -> Pp.t; - pr_constr_pattern_expr : constr_pattern_expr -> Pp.t; - pr_lconstr_pattern_expr : constr_pattern_expr -> Pp.t + pr_constr_expr : Environ.env -> Evd.evar_map -> constr_expr -> Pp.t; + pr_lconstr_expr : Environ.env -> Evd.evar_map -> constr_expr -> Pp.t; + pr_constr_pattern_expr : Environ.env -> Evd.evar_map -> constr_pattern_expr -> Pp.t; + pr_lconstr_pattern_expr : Environ.env -> Evd.evar_map -> constr_pattern_expr -> Pp.t } val set_term_pr : term_pr -> unit diff --git a/printing/pputils.ml b/printing/pputils.ml index e6daf9544c..fff6dae1b4 100644 --- a/printing/pputils.ml +++ b/printing/pputils.ml @@ -60,50 +60,52 @@ let pr_or_by_notation f = let open Constrexpr in CAst.with_val (function let hov_if_not_empty n p = if Pp.ismt p then p else hov n p -let rec pr_raw_generic env (GenArg (Rawwit wit, x)) = +let rec pr_raw_generic env sigma (GenArg (Rawwit wit, x)) = match wit with | ListArg wit -> - let map x = pr_raw_generic env (in_gen (rawwit wit) x) in + let map x = pr_raw_generic env sigma (in_gen (rawwit wit) x) in let ans = pr_sequence map x in hov_if_not_empty 0 ans | OptArg wit -> let ans = match x with | None -> mt () - | Some x -> pr_raw_generic env (in_gen (rawwit wit) x) + | Some x -> pr_raw_generic env sigma (in_gen (rawwit wit) x) in hov_if_not_empty 0 ans | PairArg (wit1, wit2) -> let p, q = x in let p = in_gen (rawwit wit1) p in let q = in_gen (rawwit wit2) q in - hov_if_not_empty 0 (pr_sequence (pr_raw_generic env) [p; q]) + hov_if_not_empty 0 (pr_sequence (pr_raw_generic env sigma) [p; q]) | ExtraArg s -> let open Genprint in match generic_raw_print (in_gen (rawwit wit) x) with - | PrinterBasic pp -> pp () - | PrinterNeedsLevel { default_ensure_surrounded; printer } -> printer default_ensure_surrounded + | PrinterBasic pp -> pp env sigma + | PrinterNeedsLevel { default_ensure_surrounded; printer } -> + printer env sigma default_ensure_surrounded -let rec pr_glb_generic env (GenArg (Glbwit wit, x)) = +let rec pr_glb_generic env sigma (GenArg (Glbwit wit, x)) = match wit with | ListArg wit -> - let map x = pr_glb_generic env (in_gen (glbwit wit) x) in + let map x = pr_glb_generic env sigma (in_gen (glbwit wit) x) in let ans = pr_sequence map x in hov_if_not_empty 0 ans | OptArg wit -> let ans = match x with | None -> mt () - | Some x -> pr_glb_generic env (in_gen (glbwit wit) x) + | Some x -> pr_glb_generic env sigma (in_gen (glbwit wit) x) in hov_if_not_empty 0 ans | PairArg (wit1, wit2) -> let p, q = x in let p = in_gen (glbwit wit1) p in let q = in_gen (glbwit wit2) q in - let ans = pr_sequence (pr_glb_generic env) [p; q] in + let ans = pr_sequence (pr_glb_generic env sigma) [p; q] in hov_if_not_empty 0 ans | ExtraArg s -> let open Genprint in match generic_glb_print (in_gen (glbwit wit) x) with - | PrinterBasic pp -> pp () - | PrinterNeedsLevel { default_ensure_surrounded; printer } -> printer default_ensure_surrounded + | PrinterBasic pp -> pp env sigma + | PrinterNeedsLevel { default_ensure_surrounded; printer } -> + printer env sigma default_ensure_surrounded diff --git a/printing/pputils.mli b/printing/pputils.mli index ea554355bc..d0f3e61eac 100644 --- a/printing/pputils.mli +++ b/printing/pputils.mli @@ -20,8 +20,8 @@ val pr_lname : lname -> Pp.t val pr_or_var : ('a -> Pp.t) -> 'a Locus.or_var -> Pp.t val pr_or_by_notation : ('a -> Pp.t) -> 'a Constrexpr.or_by_notation -> Pp.t -val pr_raw_generic : Environ.env -> rlevel generic_argument -> Pp.t -val pr_glb_generic : Environ.env -> glevel generic_argument -> Pp.t +val pr_raw_generic : Environ.env -> Evd.evar_map -> rlevel generic_argument -> Pp.t +val pr_glb_generic : Environ.env -> Evd.evar_map -> glevel generic_argument -> Pp.t (* The comments interface is imperative due to the printer not threading it, this could be solved using a better data diff --git a/printing/prettyp.ml b/printing/prettyp.ml index 797b6faa08..8bf86e9ef6 100644 --- a/printing/prettyp.ml +++ b/printing/prettyp.ml @@ -505,9 +505,9 @@ let gallina_print_named_decl env sigma = let open Context.Named.Declaration in function | LocalAssum (id, typ) -> - print_named_assum env sigma (Id.to_string id) typ + print_named_assum env sigma (Id.to_string id.Context.binder_name) typ | LocalDef (id, body, typ) -> - print_named_def env sigma (Id.to_string id) body typ + print_named_def env sigma (Id.to_string id.Context.binder_name) body typ let assumptions_for_print lna = List.fold_right (fun na env -> add_name na env) lna empty_names_context diff --git a/printing/printer.ml b/printing/printer.ml index bc936975c2..2951d8e5c8 100644 --- a/printing/printer.ml +++ b/printing/printer.ml @@ -13,6 +13,7 @@ open CErrors open Util open Names open Constr +open Context open Environ open Globnames open Evd @@ -77,9 +78,9 @@ let () = _not_ occur in the scope of the binder to be printed are avoided. *) let pr_econstr_n_core goal_concl_style env sigma n t = - pr_constr_expr_n n (extern_constr goal_concl_style env sigma t) + pr_constr_expr_n env sigma n (extern_constr goal_concl_style env sigma t) let pr_econstr_core goal_concl_style env sigma t = - pr_constr_expr (extern_constr goal_concl_style env sigma t) + pr_constr_expr env sigma (extern_constr goal_concl_style env sigma t) let pr_leconstr_core = Proof_diffs.pr_leconstr_core let pr_constr_n_env env sigma n c = pr_econstr_n_core false env sigma n (EConstr.of_constr c) @@ -100,14 +101,14 @@ let pr_constr_under_binders_env_gen pr env sigma (ids,c) = (* Warning: clashes can occur with variables of same name in env but *) (* we also need to preserve the actual names of the patterns *) (* So what to do? *) - let assums = List.map (fun id -> (Name id,(* dummy *) mkProp)) ids in + let assums = List.map (fun id -> (make_annot (Name id) Sorts.Relevant,(* dummy *) mkProp)) ids in pr (Termops.push_rels_assum assums env) sigma c let pr_constr_under_binders_env = pr_constr_under_binders_env_gen pr_econstr_env let pr_lconstr_under_binders_env = pr_constr_under_binders_env_gen pr_leconstr_env let pr_etype_core goal_concl_style env sigma t = - pr_constr_expr (extern_type goal_concl_style env sigma t) + pr_constr_expr env sigma (extern_type goal_concl_style env sigma t) let pr_letype_core = Proof_diffs.pr_letype_core let pr_ltype_env env sigma c = pr_letype_core false env sigma (EConstr.of_constr c) @@ -121,19 +122,19 @@ let pr_ljudge_env env sigma j = (pr_leconstr_env env sigma j.uj_val, pr_leconstr_env env sigma j.uj_type) let pr_lglob_constr_env env c = - pr_lconstr_expr (extern_glob_constr (Termops.vars_of_env env) c) + pr_lconstr_expr env (Evd.from_env env) (extern_glob_constr (Termops.vars_of_env env) c) let pr_glob_constr_env env c = - pr_constr_expr (extern_glob_constr (Termops.vars_of_env env) c) + pr_constr_expr env (Evd.from_env env) (extern_glob_constr (Termops.vars_of_env env) c) let pr_closed_glob_n_env env sigma n c = - pr_constr_expr_n n (extern_closed_glob false env sigma c) + pr_constr_expr_n env sigma n (extern_closed_glob false env sigma c) let pr_closed_glob_env env sigma c = - pr_constr_expr (extern_closed_glob false env sigma c) + pr_constr_expr env sigma (extern_closed_glob false env sigma c) let pr_lconstr_pattern_env env sigma c = - pr_lconstr_pattern_expr (extern_constr_pattern (Termops.names_of_rel_context env) sigma c) + pr_lconstr_pattern_expr env sigma (extern_constr_pattern (Termops.names_of_rel_context env) sigma c) let pr_constr_pattern_env env sigma c = - pr_constr_pattern_expr (extern_constr_pattern (Termops.names_of_rel_context env) sigma c) + pr_constr_pattern_expr env sigma (extern_constr_pattern (Termops.names_of_rel_context env) sigma c) let pr_cases_pattern t = pr_cases_pattern_expr (extern_cases_pattern Names.Id.Set.empty t) @@ -141,7 +142,7 @@ let pr_cases_pattern t = let pr_sort sigma s = pr_glob_sort (extern_sort sigma s) let () = Termops.Internal.set_print_constr - (fun env sigma t -> pr_lconstr_expr (extern_constr ~lax:true false env sigma t)) + (fun env sigma t -> pr_lconstr_expr env sigma (extern_constr ~lax:true false env sigma t)) let pr_in_comment x = str "(* " ++ x ++ str " *)" @@ -290,7 +291,7 @@ let pr_compacted_decl env sigma decl = let pb = if isCast c then surround pb else pb in ids, (str" := " ++ pb ++ cut ()), typ in - let pids = prlist_with_sep pr_comma pr_id ids in + let pids = prlist_with_sep pr_comma (fun id -> pr_id id.binder_name) ids in let pt = pr_ltype_env env sigma typ in let ptyp = (str" : " ++ pt) in hov 0 (pids ++ pbody ++ ptyp) @@ -334,7 +335,7 @@ let pr_named_context env sigma ne_context = 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) + pr_binders env sigma (extern_rel_context None env sigma rel_context) let pr_rel_context_of env sigma = pr_rel_context env sigma (rel_context env) diff --git a/printing/printmod.ml b/printing/printmod.ml index 3438063f76..f4986652b3 100644 --- a/printing/printmod.ml +++ b/printing/printmod.ml @@ -10,6 +10,7 @@ open Util open Constr +open Context open Pp open Names open Environ @@ -132,10 +133,10 @@ let get_fields = let rec prodec_rec l subst c = match kind c with | Prod (na,t,c) -> - let id = match na with Name id -> id | Anonymous -> Id.of_string "_" in + let id = match na.binder_name with Name id -> id | Anonymous -> Id.of_string "_" in prodec_rec ((id,true,Vars.substl subst t)::l) (mkVar id::subst) c | LetIn (na,b,_,c) -> - let id = match na with Name id -> id | Anonymous -> Id.of_string "_" in + let id = match na.binder_name with Name id -> id | Anonymous -> Id.of_string "_" in prodec_rec ((id,false,Vars.substl subst b)::l) (mkVar id::subst) c | _ -> List.rev l in diff --git a/printing/proof_diffs.ml b/printing/proof_diffs.ml index 878e9f477b..d620e14a94 100644 --- a/printing/proof_diffs.ml +++ b/printing/proof_diffs.ml @@ -39,6 +39,13 @@ uses strikeout on removed text. open Pp_diff +let term_color = ref true + +let write_color_enabled enabled = + term_color := enabled + +let color_enabled () = !term_color + let diff_option = ref `OFF let read_diffs_option () = match !diff_option with @@ -46,11 +53,18 @@ let read_diffs_option () = match !diff_option with | `ON -> "on" | `REMOVED -> "removed" -let write_diffs_option = function -| "off" -> diff_option := `OFF -| "on" -> diff_option := `ON -| "removed" -> diff_option := `REMOVED -| _ -> CErrors.user_err Pp.(str "Diffs option only accepts the following values: \"off\", \"on\", \"removed\".") +let write_diffs_option opt = + let enable opt = + if not (color_enabled ()) then + CErrors.user_err Pp.(str "Enabling Diffs requires setting the \"-color\" command line argument to \"on\" or \"auto\".") + else + diff_option := opt + in + match opt with + | "off" -> diff_option := `OFF + | "on" -> enable `ON + | "removed" -> enable `REMOVED + | _ -> CErrors.user_err Pp.(str "Diffs option only accepts the following values: \"off\", \"on\", \"removed\".") let () = Goptions.(declare_string_option { @@ -204,14 +218,14 @@ let diff_hyps o_line_idents o_map n_line_idents n_map = List.rev !rv;; -type 'a hyp = (Names.Id.t list * 'a option * 'a) +type 'a hyp = (Names.Id.t Context.binder_annot list * 'a option * 'a) type 'a reified_goal = { name: string; ty: 'a; hyps: 'a hyp list; env : Environ.env; sigma: Evd.evar_map } (* XXX: Port to proofview, one day. *) (* open Proofview *) module CDC = Context.Compacted.Declaration -let to_tuple : Constr.compacted_declaration -> (Names.Id.t list * 'pc option * 'pc) = +let to_tuple : Constr.compacted_declaration -> (Names.Id.t Context.binder_annot list * 'pc option * 'pc) = let open CDC in function | LocalAssum(idl, tm) -> (idl, None, EConstr.of_constr tm) | LocalDef(idl,tdef,tm) -> (idl, Some (EConstr.of_constr tdef), EConstr.of_constr tm);; @@ -233,13 +247,13 @@ let process_goal sigma g : EConstr.t reified_goal = { name; ty; hyps; env; sigma };; let pr_letype_core goal_concl_style env sigma t = - Ppconstr.pr_lconstr_expr (Constrextern.extern_type goal_concl_style env sigma t) + Ppconstr.pr_lconstr_expr env sigma (Constrextern.extern_type goal_concl_style env sigma t) let pp_of_type env sigma ty = pr_letype_core true env sigma ty let pr_leconstr_core goal_concl_style env sigma t = - Ppconstr.pr_lconstr_expr (Constrextern.extern_constr goal_concl_style env sigma t) + Ppconstr.pr_lconstr_expr env sigma (Constrextern.extern_constr goal_concl_style env sigma t) let pr_lconstr_env env sigma c = pr_leconstr_core false env sigma (EConstr.of_constr c) @@ -283,7 +297,7 @@ let goal_info goal sigma = let build_hyp_info env sigma hyp = let (names, body, ty) = hyp in let open Pp in - let idents = List.map (fun x -> Names.Id.to_string x) names in + let idents = List.map (fun x -> Names.Id.to_string x.Context.binder_name) names in line_idents := idents :: !line_idents; let mid = match body with diff --git a/printing/proof_diffs.mli b/printing/proof_diffs.mli index 1ebde3d572..fd10eaa458 100644 --- a/printing/proof_diffs.mli +++ b/printing/proof_diffs.mli @@ -16,6 +16,12 @@ val write_diffs_option : string -> unit (** Returns true if the diffs option is "on" or "removed" *) val show_diffs : unit -> bool +(** controls whether color output is enabled *) +val write_color_enabled : bool -> unit + +(** true indicates that color output is enabled *) +val color_enabled : unit -> bool + open Evd open Environ open Constr diff --git a/proofs/clenv.ml b/proofs/clenv.ml index 9540d3de44..2d2113b636 100644 --- a/proofs/clenv.ml +++ b/proofs/clenv.ml @@ -15,6 +15,7 @@ open Names open Nameops open Termops open Constr +open Context open Namegen open Environ open Evd @@ -69,7 +70,7 @@ let clenv_push_prod cl = | Prod (na,t,u) -> let mv = new_meta () in let dep = not (noccurn (cl_sigma cl) 1 u) in - let na' = if dep then na else Anonymous in + let na' = if dep then na.binder_name else Anonymous in let e' = meta_declare mv t ~name:na' cl.evd in let concl = if dep then subst1 (mkMeta mv) u else u in let def = applist (cl.templval.rebus,[mkMeta mv]) in @@ -103,7 +104,7 @@ let clenv_environments evd bound t = | (n, Prod (na,t1,t2)) -> let mv = new_meta () in let dep = not (noccurn evd 1 t2) in - let na' = if dep then na else Anonymous in + let na' = if dep then na.binder_name else Anonymous in let e' = meta_declare mv t1 ~name:na' e in clrec (e', (mkMeta mv)::metas) (Option.map ((+) (-1)) n) (if dep then (subst1 (mkMeta mv) t2) else t2) @@ -277,7 +278,7 @@ let adjust_meta_source evd mv = function | loc,Evar_kinds.VarInstance id -> let rec match_name c l = match EConstr.kind evd c, l with - | Lambda (Name id,_,c), a::l when EConstr.eq_constr evd a (mkMeta mv) -> Some id + | Lambda ({binder_name=Name id},_,c), a::l when EConstr.eq_constr evd a (mkMeta mv) -> Some id | Lambda (_,_,c), a::l -> match_name c l | _ -> None in (* This is very ad hoc code so that an evar inherits the name of the binder @@ -623,7 +624,7 @@ let make_evar_clause env sigma ?len t = hole_type = t1; hole_deps = dep; (* We fix it later *) - hole_name = na; + hole_name = na.binder_name; } in let t2 = if dep then subst1 ev t2 else t2 in clrec (sigma, hole :: holes) inst (pred n) t2 diff --git a/proofs/proof_global.ml b/proofs/proof_global.ml index a47fa78f4d..6174b75a96 100644 --- a/proofs/proof_global.ml +++ b/proofs/proof_global.ml @@ -19,6 +19,7 @@ open Util open Pp open Names +open Context module NamedDecl = Context.Named.Declaration @@ -198,10 +199,10 @@ let set_used_variables l = let vars_of = Environ.global_vars_set in let aux env entry (ctx, all_safe as orig) = match entry with - | LocalAssum (x,_) -> + | LocalAssum ({binder_name=x},_) -> if Id.Set.mem x all_safe then orig else (ctx, all_safe) - | LocalDef (x,bo, ty) as decl -> + | LocalDef ({binder_name=x},bo, ty) as decl -> if Id.Set.mem x all_safe then orig else let vars = Id.Set.union (vars_of env bo) (vars_of env ty) in if Id.Set.subset vars all_safe diff --git a/proofs/tacmach.ml b/proofs/tacmach.ml index df90354717..8196f5e198 100644 --- a/proofs/tacmach.ml +++ b/proofs/tacmach.ml @@ -172,7 +172,7 @@ module New = struct let env = Proofview.Goal.env gl in let sign = Environ.named_context env in List.map (function LocalAssum (id,x) - | LocalDef (id,_,x) -> id, EConstr.of_constr x) + | LocalDef (id,_,x) -> id.Context.binder_name, EConstr.of_constr x) sign let pf_last_hyp gl = diff --git a/proofs/tacmach.mli b/proofs/tacmach.mli index 213ed7bfda..1454140dd7 100644 --- a/proofs/tacmach.mli +++ b/proofs/tacmach.mli @@ -29,7 +29,7 @@ val pf_concl : Goal.goal sigma -> types val pf_env : Goal.goal sigma -> env val pf_hyps : Goal.goal sigma -> named_context (*i val pf_untyped_hyps : Goal.goal sigma -> (Id.t * constr) list i*) -val pf_hyps_types : Goal.goal sigma -> (Id.t * types) list +val pf_hyps_types : Goal.goal sigma -> (Id.t Context.binder_annot * types) list val pf_nth_hyp_id : Goal.goal sigma -> int -> Id.t val pf_last_hyp : Goal.goal sigma -> named_declaration val pf_ids_of_hyps : Goal.goal sigma -> Id.t list diff --git a/tactics/autorewrite.ml b/tactics/autorewrite.ml index 3b8232d20a..d9c0a26f91 100644 --- a/tactics/autorewrite.ml +++ b/tactics/autorewrite.ml @@ -82,7 +82,7 @@ let print_rewrite_hintdb env sigma bas = str (if h.rew_l2r then "rewrite -> " else "rewrite <- ") ++ Printer.pr_lconstr_env env sigma h.rew_lemma ++ str " of type " ++ Printer.pr_lconstr_env env sigma h.rew_type ++ Option.cata (fun tac -> str " then use tactic " ++ - Pputils.pr_glb_generic (Global.env()) tac) (mt ()) h.rew_tac) + Pputils.pr_glb_generic env sigma tac) (mt ()) h.rew_tac) (find_rewrites bas)) type raw_rew_rule = (constr Univ.in_universe_context_set * bool * Genarg.raw_generic_argument option) CAst.t diff --git a/tactics/btermdn.ml b/tactics/btermdn.ml index 2f2bd8d2bc..06246ef584 100644 --- a/tactics/btermdn.ml +++ b/tactics/btermdn.ml @@ -77,7 +77,7 @@ let constr_val_discr_st sigma ts t = | Construct (cstr_sp,u) -> Label(GRLabel (ConstructRef cstr_sp),l) | Var id when not (TransparentState.is_transparent_variable ts id) -> Label(GRLabel (VarRef id),l) | Prod (n, d, c) -> Label(ProdLabel, [d; c]) - | Lambda (n, d, c) -> + | Lambda (n, d, c) -> if List.is_empty l then Label(LambdaLabel, [d; c] @ l) else Everything diff --git a/tactics/contradiction.ml b/tactics/contradiction.ml index bd95a62532..3ff2e3852d 100644 --- a/tactics/contradiction.ml +++ b/tactics/contradiction.ml @@ -9,6 +9,7 @@ (************************************************************************) open Constr +open Context open EConstr open Hipattern open Tactics @@ -19,10 +20,10 @@ module NamedDecl = Context.Named.Declaration (* Absurd *) -let mk_absurd_proof coq_not t = +let mk_absurd_proof coq_not r t = let id = Namegen.default_dependent_ident in - mkLambda (Names.Name id,mkApp(coq_not,[|t|]), - mkLambda (Names.Name id,t,mkApp (mkRel 2,[|mkRel 1|]))) + mkLambda (make_annot (Names.Name id) Sorts.Relevant,mkApp(coq_not,[|t|]), + mkLambda (make_annot (Names.Name id) r,t,mkApp (mkRel 2,[|mkRel 1|]))) let absurd c = Proofview.Goal.enter begin fun gl -> @@ -31,12 +32,13 @@ let absurd c = let j = Retyping.get_judgment_of env sigma c in let sigma, j = Coercion.inh_coerce_to_sort env sigma j in let t = j.Environ.utj_val in + let r = Sorts.relevance_of_sort j.Environ.utj_type in Proofview.Unsafe.tclEVARS sigma <*> Tacticals.New.pf_constr_of_global (Coqlib.(lib_ref "core.not.type")) >>= fun coqnot -> Tacticals.New.pf_constr_of_global (Coqlib.(lib_ref "core.False.type")) >>= fun coqfalse -> Tacticals.New.tclTHENLIST [ elim_type coqfalse; - Simple.apply (mk_absurd_proof coqnot t) + Simple.apply (mk_absurd_proof coqnot r t) ] end @@ -68,9 +70,9 @@ let contradiction_context = if is_empty_type sigma typ then simplest_elim (mkVar id) else match EConstr.kind sigma typ with - | Prod (na,t,u) when is_empty_type sigma u -> + | Prod (na,t,u) when is_empty_type sigma u -> let is_unit_or_eq = match_with_unit_or_eq_type sigma t in - Tacticals.New.tclORELSE + Tacticals.New.tclORELSE (match is_unit_or_eq with | Some _ -> let hd,args = decompose_app sigma t in diff --git a/tactics/elimschemes.ml b/tactics/elimschemes.ml index 3b69d9922d..1fae4c3d9d 100644 --- a/tactics/elimschemes.ml +++ b/tactics/elimschemes.ml @@ -88,14 +88,27 @@ let ind_scheme_kind_from_type = declare_individual_scheme_object "_ind_nodep" (optimize_non_type_induction_scheme rec_scheme_kind_from_type false InProp) +let sind_scheme_kind_from_type = + declare_individual_scheme_object "_sind_nodep" + (fun _ x -> build_induction_scheme_in_type false InSProp x, Safe_typing.empty_private_constants) + let ind_dep_scheme_kind_from_type = declare_individual_scheme_object "_ind" ~aux:"_ind_from_type" (optimize_non_type_induction_scheme rec_dep_scheme_kind_from_type true InProp) +let sind_dep_scheme_kind_from_type = + declare_individual_scheme_object "_sind" ~aux:"_sind_from_type" + (fun _ x -> build_induction_scheme_in_type true InSProp x, Safe_typing.empty_private_constants) + let ind_scheme_kind_from_prop = declare_individual_scheme_object "_ind" ~aux:"_ind_from_prop" (optimize_non_type_induction_scheme rec_scheme_kind_from_prop false InProp) +let sind_scheme_kind_from_prop = + declare_individual_scheme_object "_sind" ~aux:"_sind_from_prop" + (fun _ x -> build_induction_scheme_in_type false InSProp x, Safe_typing.empty_private_constants) + + (* Case analysis *) let build_case_analysis_scheme_in_type dep sort ind = diff --git a/tactics/elimschemes.mli b/tactics/elimschemes.mli index ece4124b8b..4472792449 100644 --- a/tactics/elimschemes.mli +++ b/tactics/elimschemes.mli @@ -22,11 +22,14 @@ val optimize_non_type_induction_scheme : val rect_scheme_kind_from_prop : individual scheme_kind val ind_scheme_kind_from_prop : individual scheme_kind +val sind_scheme_kind_from_prop : individual scheme_kind val rec_scheme_kind_from_prop : individual scheme_kind val rect_scheme_kind_from_type : individual scheme_kind val rect_dep_scheme_kind_from_type : individual scheme_kind val ind_scheme_kind_from_type : individual scheme_kind val ind_dep_scheme_kind_from_type : individual scheme_kind +val sind_scheme_kind_from_type : individual scheme_kind +val sind_dep_scheme_kind_from_type : individual scheme_kind val rec_scheme_kind_from_type : individual scheme_kind val rec_dep_scheme_kind_from_type : individual scheme_kind diff --git a/tactics/eqdecide.ml b/tactics/eqdecide.ml index 6388aa2c33..e75a61d0c6 100644 --- a/tactics/eqdecide.ml +++ b/tactics/eqdecide.ml @@ -18,6 +18,7 @@ open Util open Names open Namegen open Constr +open Context open EConstr open Declarations open Tactics @@ -74,7 +75,8 @@ let generalize_right mk typ c1 c2 = let env = Proofview.Goal.env gl in Refine.refine ~typecheck:false begin fun sigma -> let na = Name (next_name_away_with_default "x" Anonymous (Termops.vars_of_env env)) in - let newconcl = mkProd (na, typ, mk typ c1 (mkRel 1)) in + let r = Retyping.relevance_of_type env sigma typ in + let newconcl = mkProd (make_annot na r, typ, mk typ c1 (mkRel 1)) in let (sigma, x) = Evarutil.new_evar env sigma ~principal:true newconcl in (sigma, mkApp (x, [|c2|])) end @@ -123,8 +125,8 @@ let mkGenDecideEqGoal rectype ops g = let hypnames = pf_ids_set_of_hyps g in let xname = next_ident_away idx hypnames and yname = next_ident_away idy hypnames in - (mkNamedProd xname rectype - (mkNamedProd yname rectype + (mkNamedProd (make_annot xname Sorts.Relevant) rectype + (mkNamedProd (make_annot yname Sorts.Relevant) rectype (mkDecideEqGoal true ops rectype (mkVar xname) (mkVar yname)))) diff --git a/tactics/eqschemes.ml b/tactics/eqschemes.ml index 3c1115d056..073d66e4aa 100644 --- a/tactics/eqschemes.ml +++ b/tactics/eqschemes.ml @@ -51,6 +51,7 @@ open Util open Names open Term open Constr +open Context open Vars open Declarations open Environ @@ -66,7 +67,7 @@ module RelDecl = Context.Rel.Declaration let hid = Id.of_string "H" let xid = Id.of_string "X" -let default_id_of_sort = function InProp | InSet -> hid | InType -> xid +let default_id_of_sort = function InSProp | InProp | InSet -> hid | InType -> xid let fresh env id = next_global_ident_away id Id.Set.empty let with_context_set ctx (b, ctx') = (b, Univ.ContextSet.union ctx ctx') @@ -80,8 +81,8 @@ let build_dependent_inductive ind (mib,mip) = let named_hd env t na = named_hd env (Evd.from_env env) (EConstr.of_constr t) na let name_assumption env = function -| LocalAssum (na,t) -> LocalAssum (named_hd env t na, t) -| LocalDef (na,c,t) -> LocalDef (named_hd env c na, c, t) +| LocalAssum (na,t) -> LocalAssum (map_annot (named_hd env t) na, t) +| LocalDef (na,c,t) -> LocalDef (map_annot (named_hd env c) na, c, t) let name_context env hyps = snd @@ -202,11 +203,14 @@ let build_sym_scheme env ind = get_sym_eq_data env indu in let cstr n = mkApp (mkConstructUi(indu,1),Context.Rel.to_extended_vect mkRel n mib.mind_params_ctxt) in - let varH = fresh env (default_id_of_sort (snd (mind_arity mip))) in + let inds = snd (mind_arity mip) in + let varH = fresh env (default_id_of_sort inds) in let applied_ind = build_dependent_inductive indu specif in + let indr = Sorts.relevance_of_sort_family inds in let realsign_ind = - name_context env ((LocalAssum (Name varH,applied_ind))::realsign) in - let ci = make_case_info (Global.env()) ind RegularStyle in + name_context env ((LocalAssum (make_annot (Name varH) indr,applied_ind))::realsign) in + let rci = Sorts.Relevant in (* TODO relevance *) + let ci = make_case_info (Global.env()) ind rci RegularStyle in let c = (my_it_mkLambda_or_LetIn paramsctxt (my_it_mkLambda_or_LetIn_name realsign_ind @@ -256,7 +260,9 @@ let build_sym_involutive_scheme env ind = let eq,eqrefl,ctx = get_coq_eq ctx in let sym, ctx, eff = const_of_scheme sym_scheme_kind env ind ctx in let cstr n = mkApp (mkConstructUi (indu,1),Context.Rel.to_extended_vect mkRel n paramsctxt) in - let varH = fresh env (default_id_of_sort (snd (mind_arity mip))) in + let inds = snd (mind_arity mip) in + let indr = Sorts.relevance_of_sort_family inds in + let varH = fresh env (default_id_of_sort inds) in let applied_ind = build_dependent_inductive indu specif in let applied_ind_C = mkApp @@ -264,8 +270,9 @@ let build_sym_involutive_scheme env ind = (Context.Rel.to_extended_vect mkRel (nrealargs+1) mib.mind_params_ctxt) (rel_vect (nrealargs+1) nrealargs)) in let realsign_ind = - name_context env ((LocalAssum (Name varH,applied_ind))::realsign) in - let ci = make_case_info (Global.env()) ind RegularStyle in + name_context env ((LocalAssum (make_annot (Name varH) indr,applied_ind))::realsign) in + let rci = Sorts.Relevant in (* TODO relevance *) + let ci = make_case_info (Global.env()) ind rci RegularStyle in let c = (my_it_mkLambda_or_LetIn paramsctxt (my_it_mkLambda_or_LetIn_name realsign_ind @@ -368,7 +375,9 @@ let build_l2r_rew_scheme dep env ind kind = mkApp (mkConstructUi(indu,1), Array.concat [Context.Rel.to_extended_vect mkRel n paramsctxt1; rel_vect p nrealargs]) in - let varH = fresh env (default_id_of_sort (snd (mind_arity mip))) in + let inds = snd (mind_arity mip) in + let indr = Sorts.relevance_of_sort_family inds in + let varH = fresh env (default_id_of_sort inds) in let varHC = fresh env (Id.of_string "HC") in let varP = fresh env (Id.of_string "P") in let applied_ind = build_dependent_inductive indu specif in @@ -384,9 +393,9 @@ let build_l2r_rew_scheme dep env ind kind = rel_vect 0 nrealargs]) in let realsign_P = lift_rel_context nrealargs realsign in let realsign_ind_P = - name_context env ((LocalAssum (Name varH,applied_ind_P))::realsign_P) in + name_context env ((LocalAssum (make_annot (Name varH) indr,applied_ind_P))::realsign_P) in let realsign_ind_G = - name_context env ((LocalAssum (Name varH,applied_ind_G)):: + name_context env ((LocalAssum (make_annot (Name varH) indr,applied_ind_G)):: lift_rel_context (nrealargs+3) realsign) in let applied_sym_C n = mkApp(sym, @@ -400,8 +409,9 @@ let build_l2r_rew_scheme dep env ind kind = let s, ctx' = UnivGen.fresh_sort_in_family kind in let ctx = Univ.ContextSet.union ctx ctx' in let s = mkSort s in - let ci = make_case_info (Global.env()) ind RegularStyle in - let cieq = make_case_info (Global.env()) (fst (destInd eq)) RegularStyle in + let rci = Sorts.Relevant in (* TODO relevance *) + let ci = make_case_info (Global.env()) ind rci RegularStyle in + let cieq = make_case_info (Global.env()) (fst (destInd eq)) rci RegularStyle in let applied_PC = mkApp (mkVar varP,Array.append (Context.Rel.to_extended_vect mkRel 1 realsign) (if dep then [|cstr (2*nrealargs+1) 1|] else [||])) in @@ -429,14 +439,14 @@ let build_l2r_rew_scheme dep env ind kind = let c = (my_it_mkLambda_or_LetIn paramsctxt (my_it_mkLambda_or_LetIn_name realsign - (mkNamedLambda varP + (mkNamedLambda (make_annot varP indr) (my_it_mkProd_or_LetIn (if dep then realsign_ind_P else realsign_P) s) - (mkNamedLambda varHC applied_PC - (mkNamedLambda varH (lift 2 applied_ind) + (mkNamedLambda (make_annot varHC indr) applied_PC + (mkNamedLambda (make_annot varH indr) (lift 2 applied_ind) (if dep then (* we need a coercion *) mkCase (cieq, - mkLambda (Name varH,lift 3 applied_ind, - mkLambda (Anonymous, + mkLambda (make_annot (Name varH) indr,lift 3 applied_ind, + mkLambda (make_annot Anonymous indr, mkApp (eq,[|lift 4 applied_ind;applied_sym_sym;mkRel 1|]), applied_PR)), mkApp (sym_involutive, @@ -481,7 +491,9 @@ let build_l2r_forward_rew_scheme dep env ind kind = mkApp (mkConstructUi(indu,1), Array.concat [Context.Rel.to_extended_vect mkRel n paramsctxt1; rel_vect p nrealargs]) in - let varH = fresh env (default_id_of_sort (snd (mind_arity mip))) in + let inds = snd (mind_arity mip) in + let indr = Sorts.relevance_of_sort_family inds in + let varH = fresh env (default_id_of_sort inds) in let varHC = fresh env (Id.of_string "HC") in let varP = fresh env (Id.of_string "P") in let applied_ind = build_dependent_inductive indu specif in @@ -497,13 +509,14 @@ let build_l2r_forward_rew_scheme dep env ind kind = rel_vect (2*nrealargs+1) nrealargs]) in let realsign_P n = lift_rel_context (nrealargs*n+n) realsign in let realsign_ind = - name_context env ((LocalAssum (Name varH,applied_ind))::realsign) in + name_context env ((LocalAssum (make_annot (Name varH) indr,applied_ind))::realsign) in let realsign_ind_P n aP = - name_context env ((LocalAssum (Name varH,aP))::realsign_P n) in + name_context env ((LocalAssum (make_annot (Name varH) indr,aP))::realsign_P n) in let s, ctx' = UnivGen.fresh_sort_in_family kind in let ctx = Univ.ContextSet.union ctx ctx' in let s = mkSort s in - let ci = make_case_info (Global.env()) ind RegularStyle in + let rci = Sorts.Relevant in + let ci = make_case_info (Global.env()) ind rci RegularStyle in let applied_PC = mkApp (mkVar varP,Array.append (rel_vect (nrealargs*2+3) nrealargs) @@ -519,19 +532,19 @@ let build_l2r_forward_rew_scheme dep env ind kind = let c = (my_it_mkLambda_or_LetIn paramsctxt (my_it_mkLambda_or_LetIn_name realsign - (mkNamedLambda varH applied_ind + (mkNamedLambda (make_annot varH indr) applied_ind (mkCase (ci, my_it_mkLambda_or_LetIn_name (lift_rel_context (nrealargs+1) realsign_ind) - (mkNamedProd varP + (mkNamedProd (make_annot varP indr) (my_it_mkProd_or_LetIn (if dep then realsign_ind_P 2 applied_ind_P else realsign_P 2) s) - (mkNamedProd varHC applied_PC applied_PG)), + (mkNamedProd (make_annot varHC indr) applied_PC applied_PG)), (mkVar varH), - [|mkNamedLambda varP + [|mkNamedLambda (make_annot varP indr) (my_it_mkProd_or_LetIn (if dep then realsign_ind_P 1 applied_ind_P' else realsign_P 2) s) - (mkNamedLambda varHC applied_PC' + (mkNamedLambda (make_annot varHC indr) applied_PC' (mkVar varHC))|]))))) in c, UState.of_context_set ctx @@ -572,16 +585,19 @@ let build_r2l_forward_rew_scheme dep env ind kind = let cstr n = mkApp (mkConstructUi(indu,1),Context.Rel.to_extended_vect mkRel n mib.mind_params_ctxt) in let constrargs_cstr = constrargs@[cstr 0] in - let varH = fresh env (default_id_of_sort (snd (mind_arity mip))) in + let inds = snd (mind_arity mip) in + let indr = Sorts.relevance_of_sort_family inds in + let varH = fresh env (default_id_of_sort inds) in let varHC = fresh env (Id.of_string "HC") in let varP = fresh env (Id.of_string "P") in let applied_ind = build_dependent_inductive indu specif in let realsign_ind = - name_context env ((LocalAssum (Name varH,applied_ind))::realsign) in + name_context env ((LocalAssum (make_annot (Name varH) indr,applied_ind))::realsign) in let s, ctx' = UnivGen.fresh_sort_in_family kind in let ctx = Univ.ContextSet.union ctx ctx' in let s = mkSort s in - let ci = make_case_info (Global.env()) ind RegularStyle in + let rci = Sorts.Relevant in (* TODO relevance *) + let ci = make_case_info (Global.env()) ind rci RegularStyle in let applied_PC = applist (mkVar varP,if dep then constrargs_cstr else constrargs) in let applied_PG = @@ -591,18 +607,18 @@ let build_r2l_forward_rew_scheme dep env ind kind = let c = (my_it_mkLambda_or_LetIn paramsctxt (my_it_mkLambda_or_LetIn_name realsign_ind - (mkNamedLambda varP + (mkNamedLambda (make_annot varP indr) (my_it_mkProd_or_LetIn (lift_rel_context (nrealargs+1) (if dep then realsign_ind else realsign)) s) - (mkNamedLambda varHC (lift 1 applied_PG) + (mkNamedLambda (make_annot varHC indr) (lift 1 applied_PG) (mkApp (mkCase (ci, my_it_mkLambda_or_LetIn_name (lift_rel_context (nrealargs+3) realsign_ind) - (mkArrow applied_PG (lift (2*nrealargs+5) applied_PC)), + (mkArrow applied_PG indr (lift (2*nrealargs+5) applied_PC)), mkRel 3 (* varH *), [|mkLambda - (Name varHC, + (make_annot (Name varHC) indr, lift (nrealargs+3) applied_PC, mkRel 1)|]), [|mkVar varHC|])))))) @@ -775,7 +791,10 @@ let build_congr env (eq,refl,ctx) ind = if List.exists is_local_def realsign then error "Inductive equalities with local definitions in arity not supported."; let env_with_arity = push_rel_context arityctxt env in - let ty = RelDecl.get_type (lookup_rel (mip.mind_nrealargs - i + 1) env_with_arity) in + let ty, tyr = + let decl = lookup_rel (mip.mind_nrealargs - i + 1) env_with_arity in + RelDecl.get_type decl, RelDecl.get_relevance decl + in let constrsign,ccl = mip.mind_nf_lc.(0) in let _,constrargs = decompose_app ccl in if not (Int.equal (Context.Rel.length constrsign) (Context.Rel.length mib.mind_params_ctxt)) then @@ -784,15 +803,16 @@ let build_congr env (eq,refl,ctx) ind = let varB = fresh env (Id.of_string "B") in let varH = fresh env (Id.of_string "H") in let varf = fresh env (Id.of_string "f") in - let ci = make_case_info (Global.env()) ind RegularStyle in + let rci = Sorts.Relevant in (* TODO relevance *) + let ci = make_case_info (Global.env()) ind rci RegularStyle in let uni, ctx = Univ.extend_in_context_set (UnivGen.new_global_univ ()) ctx in let ctx = (fst ctx, Univ.enforce_leq uni (univ_of_eq env eq) (snd ctx)) in let c = my_it_mkLambda_or_LetIn paramsctxt - (mkNamedLambda varB (mkSort (Type uni)) - (mkNamedLambda varf (mkArrow (lift 1 ty) (mkVar varB)) + (mkNamedLambda (make_annot varB Sorts.Relevant) (mkType uni) + (mkNamedLambda (make_annot varf Sorts.Relevant) (mkArrow (lift 1 ty) tyr (mkVar varB)) (my_it_mkLambda_or_LetIn_name (lift_rel_context 2 realsign) - (mkNamedLambda varH + (mkNamedLambda (make_annot varH Sorts.Relevant) (applist (mkIndU indu, Context.Rel.to_extended_list mkRel (mip.mind_nrealargs+2) paramsctxt @ @@ -801,7 +821,7 @@ let build_congr env (eq,refl,ctx) ind = my_it_mkLambda_or_LetIn_name (lift_rel_context (mip.mind_nrealargs+3) realsign) (mkLambda - (Anonymous, + (make_annot Anonymous Sorts.Relevant, applist (mkIndU indu, Context.Rel.to_extended_list mkRel (2*mip.mind_nrealdecls+3) diff --git a/tactics/equality.ml b/tactics/equality.ml index 4a1bb37fa4..88ce9868af 100644 --- a/tactics/equality.ml +++ b/tactics/equality.ml @@ -16,6 +16,7 @@ open Names open Nameops open Term open Constr +open Context open Termops open EConstr open Vars @@ -887,7 +888,8 @@ let descend_then env sigma head dirn = let brl = List.map build_branch (List.interval 1 (Array.length mip.mind_consnames)) in - let ci = make_case_info env ind RegularStyle in + let rci = Sorts.Relevant in (* TODO relevance *) + let ci = make_case_info env ind rci RegularStyle in 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 @@ -932,7 +934,8 @@ let build_selector env sigma dirn c ind special default = it_mkLambda_or_LetIn endpt args in let brl = List.map build_branch(List.interval 1 (Array.length mip.mind_consnames)) in - let ci = make_case_info env ind RegularStyle in + let rci = Sorts.Relevant in (* TODO relevance *) + let ci = make_case_info env ind rci RegularStyle in let ans = Inductiveops.make_case_or_project env sigma indf ci p c (Array.of_list brl) in ans @@ -997,7 +1000,7 @@ let discrimination_pf e (t,t1,t2) discriminator lbeq = 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) + (applist (eq_elim, [t;t1;mkNamedLambda (make_annot e Sorts.Relevant) t discriminator;i;t2]), absurd_term) let eq_baseid = Id.of_string "e" @@ -1015,7 +1018,7 @@ 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 (vars_of_env env) in - let e_env = push_named (Context.Named.Declaration.LocalAssum (e,t)) env in + let e_env = push_named (Context.Named.Declaration.LocalAssum (make_annot e Sorts.Relevant,t)) env in let discriminator = try Proofview.tclUNIT @@ -1025,7 +1028,7 @@ let discr_positions env sigma (lbeq,eqn,(t,t1,t2)) eq_clause cpath dirn = 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 pf_ty = mkArrow eqn Sorts.Relevant 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) @@ -1114,7 +1117,7 @@ let make_tuple env sigma (rterm,rty) lind = assert (not (noccurn sigma lind rty)); let sigdata = find_sigma_data env (get_sort_of env sigma rty) in let sigma, a = type_of ~refresh:true env sigma (mkRel lind) in - let na = Context.Rel.Declaration.get_name (lookup_rel lind env) in + let na = Context.Rel.Declaration.get_annot (lookup_rel lind env) in (* We move [lind] to [1] and lift other rels > [lind] by 1 *) let rty = lift (1-lind) (liftn lind (lind+1) rty) in (* Now [lind] is [mkRel 1] and we abstract on (na:a) *) @@ -1374,13 +1377,13 @@ let simplify_args env sigma t = let inject_at_positions env sigma l2r (eq,_,(t,t1,t2)) eq_clause posns tac = let e = next_ident_away eq_baseid (vars_of_env env) in - let e_env = push_named (LocalAssum (e,t)) env in + let e_env = push_named (LocalAssum (make_annot e Sorts.Relevant,t)) env in let evdref = ref sigma in let filter (cpath, t1', t2') = try (* arbitrarily take t1' as the injector default value *) let sigma, (injbody,resty) = build_injector e_env !evdref t1' (mkVar e) cpath in - let injfun = mkNamedLambda e t injbody in + let injfun = mkNamedLambda (make_annot e Sorts.Relevant) t injbody in let sigma,congr = Evd.fresh_global env sigma eq.congr in let pf = applist(congr,[t;resty;injfun;t1;t2]) in let sigma, pf_typ = Typing.type_of env sigma pf in @@ -1565,9 +1568,9 @@ let subst_tuple_term env sigma dep_pair1 dep_pair2 b = (* We build the expected goal *) let abst_B = List.fold_right - (fun (e,t) body -> lambda_create env sigma (t,subst_term sigma e body)) e1_list b in + (fun (e,t) body -> lambda_create env sigma (Sorts.Relevant,t,subst_term sigma e body)) e1_list b in let pred_body = beta_applist sigma (abst_B,proj_list) in - let body = mkApp (lambda_create env sigma (typ,pred_body),[|dep_pair1|]) in + let body = mkApp (lambda_create env sigma (Sorts.Relevant,typ,pred_body),[|dep_pair1|]) in let expected_goal = beta_applist sigma (abst_B,List.map fst e2_list) in (* Simulate now the normalisation treatment made by Logic.mk_refgoals *) let expected_goal = nf_betaiota env sigma expected_goal in diff --git a/tactics/hints.ml b/tactics/hints.ml index c1f6365f5d..85d75f1010 100644 --- a/tactics/hints.ml +++ b/tactics/hints.ml @@ -13,6 +13,7 @@ open Util open CErrors open Names open Constr +open Context open Evd open EConstr open Vars @@ -1275,7 +1276,7 @@ let prepare_hint check (poly,local) env init (sigma,c) = let id = next_ident_away_from default_prepare_hint_ident (fun id -> Id.Set.mem id !vars) in vars := Id.Set.add id !vars; subst := (evar,mkVar id)::!subst; - mkNamedLambda id t (iter (replace_term sigma evar (mkVar id) c)) in + mkNamedLambda (make_annot id Sorts.Relevant) t (iter (replace_term sigma evar (mkVar id) c)) in let c' = iter c in let env = Global.env () in let empty_sigma = Evd.from_env env in @@ -1305,7 +1306,7 @@ let project_hint ~poly pri l2r r = let sigma, p = Evd.fresh_global env sigma p in let c = Reductionops.whd_beta sigma (mkApp (c, Context.Rel.to_extended_vect mkRel 0 sign)) in let c = it_mkLambda_or_LetIn - (mkApp (p,[|mkArrow a (lift 1 b);mkArrow b (lift 1 a);c|])) sign in + (mkApp (p,[|mkArrow a Sorts.Relevant (lift 1 b);mkArrow b Sorts.Relevant (lift 1 a);c|])) sign in let id = Nameops.add_suffix (Nametab.basename_of_global gr) ("_proj_" ^ (if l2r then "l2r" else "r2l")) in @@ -1456,7 +1457,7 @@ let pr_hint env sigma h = match h.obj with | Unfold_nth c -> str"unfold " ++ pr_evaluable_reference c | Extern tac -> - str "(*external*) " ++ Pputils.pr_glb_generic env tac + str "(*external*) " ++ Pputils.pr_glb_generic env sigma tac let pr_id_hint env sigma (id, v) = let pr_pat p = str", pattern " ++ pr_lconstr_pattern_env env sigma p in diff --git a/tactics/hipattern.ml b/tactics/hipattern.ml index 395b4928ce..08131f6309 100644 --- a/tactics/hipattern.ml +++ b/tactics/hipattern.ml @@ -182,10 +182,10 @@ let match_with_disjunction ?(strict=false) ?(onlybinary=false) sigma t = let car = constructors_nrealargs ind in let (mib,mip) = Global.lookup_inductive ind in if Array.for_all (fun ar -> Int.equal ar 1) car - && not (mis_is_recursive (ind,mib,mip)) - && (Int.equal mip.mind_nrealargs 0) + && not (mis_is_recursive (ind,mib,mip)) + && (Int.equal mip.mind_nrealargs 0) then - if strict then + if strict then if test_strict_disjunction (mib, mip) then Some (hdapp,args) else @@ -196,7 +196,7 @@ let match_with_disjunction ?(strict=false) ?(onlybinary=false) sigma t = pi2 (destProd sigma (prod_applist sigma ar args)) in let cargs = Array.map map mip.mind_nf_lc in - Some (hdapp,Array.to_list cargs) + Some (hdapp,Array.to_list cargs) else None | _ -> None in diff --git a/tactics/hipattern.mli b/tactics/hipattern.mli index f04cda1232..741f6713e3 100644 --- a/tactics/hipattern.mli +++ b/tactics/hipattern.mli @@ -86,7 +86,7 @@ val is_equality_type : 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 match_with_forall_term : (Name.t Context.binder_annot * constr * constr) matching_function val is_forall_term : testing_function val match_with_imp_term : (constr * constr) matching_function diff --git a/tactics/inv.ml b/tactics/inv.ml index 2ae37ab471..776148d4cf 100644 --- a/tactics/inv.ml +++ b/tactics/inv.ml @@ -15,6 +15,7 @@ open Names open Term open Termops open Constr +open Context open EConstr open Vars open Namegen @@ -131,7 +132,7 @@ let make_inv_predicate env evd indf realargs id status concl = let eq_term = eqdata.Coqlib.eq in let eq = evd_comb1 (Evd.fresh_global env) evd eq_term in let eqn = applist (eq,[eqnty;lhs;rhs]) in - let eqns = (Anonymous, lift n eqn) :: eqns in + let eqns = (make_annot Anonymous Sorts.Relevant, lift n eqn) :: eqns in let refl_term = eqdata.Coqlib.refl in let refl_term = evd_comb1 (Evd.fresh_global env) evd refl_term in let refl = mkApp (refl_term, [|eqnty; rhs|]) in diff --git a/tactics/leminv.ml b/tactics/leminv.ml index 335f3c74ff..4aa4d13e1e 100644 --- a/tactics/leminv.ml +++ b/tactics/leminv.ml @@ -15,6 +15,7 @@ open Names open Termops open Environ open Constr +open Context open EConstr open Vars open Namegen @@ -120,13 +121,13 @@ let max_prefix_sign lid sign = let rec add_prods_sign env sigma t = match EConstr.kind sigma (whd_all env sigma t) with | Prod (na,c1,b) -> - let id = id_of_name_using_hdchar env sigma t na in + let id = id_of_name_using_hdchar env sigma t na.binder_name in let b'= subst1 (mkVar id) b in - add_prods_sign (push_named (LocalAssum (id,c1)) env) sigma b' + add_prods_sign (push_named (LocalAssum ({na with binder_name=id},c1)) env) sigma b' | LetIn (na,c1,t1,b) -> - let id = id_of_name_using_hdchar env sigma t na in + let id = id_of_name_using_hdchar env sigma t na.binder_name in let b'= subst1 (mkVar id) b in - add_prods_sign (push_named (LocalDef (id,c1,t1)) env) sigma b' + add_prods_sign (push_named (LocalDef ({na with binder_name=id},c1,t1)) env) sigma b' | _ -> (env,t) (* [dep_option] indicates whether the inversion lemma is dependent or not. @@ -149,9 +150,10 @@ let compute_first_inversion_scheme env sigma ind sort dep_option = let pty,goal = if dep_option then let pty = make_arity env sigma true indf sort in + let r = relevance_of_inductive_type env ind in let goal = mkProd - (Anonymous, mkAppliedInd ind, applist(mkVar p,realargs@[mkRel 1])) + (make_annot Anonymous r, mkAppliedInd ind, applist(mkVar p,realargs@[mkRel 1])) in pty,goal else @@ -169,11 +171,11 @@ let compute_first_inversion_scheme env sigma ind sort dep_option = env ~init:([],[]) in let pty = it_mkNamedProd_or_LetIn (mkSort sort) ownsign in - let goal = mkArrow i (applist(mkVar p, List.rev revargs)) in + let goal = mkArrow i Sorts.Relevant (applist(mkVar p, List.rev revargs)) in (pty,goal) in let npty = nf_all env sigma pty in - let extenv = push_named (LocalAssum (p,npty)) env in + let extenv = push_named (LocalAssum (make_annot p Sorts.Relevant,npty)) env in extenv, goal (* [inversion_scheme sign I] @@ -225,7 +227,7 @@ let inversion_scheme ~name ~poly env sigma t sort dep_option inv_op = let h = next_ident_away (Id.of_string "H") !avoid in let ty,inst = Evarutil.generalize_evar_over_rels sigma (e,args) in avoid := Id.Set.add h !avoid; - ownSign := Context.Named.add (LocalAssum (h,ty)) !ownSign; + ownSign := Context.Named.add (LocalAssum (make_annot h Sorts.Relevant,ty)) !ownSign; applist (mkVar h, inst) | _ -> EConstr.map sigma fill_holes c in diff --git a/tactics/ppred.mli b/tactics/ppred.mli index b3a306a36f..be21236f4e 100644 --- a/tactics/ppred.mli +++ b/tactics/ppred.mli @@ -9,6 +9,7 @@ val pr_red_flag : ('a -> Pp.t) -> 'a glob_red_flag -> Pp.t val pr_red_expr : ('a -> Pp.t) * ('a -> Pp.t) * ('b -> Pp.t) * ('c -> Pp.t) -> (string -> Pp.t) -> ('a,'b,'c) red_expr_gen -> Pp.t + [@@ocaml.deprecated "Use pr_red_expr_env instead"] val pr_red_expr_env : Environ.env -> Evd.evar_map -> (Environ.env -> Evd.evar_map -> 'a -> Pp.t) * diff --git a/tactics/tactics.ml b/tactics/tactics.ml index 415225454a..b8308dc49b 100644 --- a/tactics/tactics.ml +++ b/tactics/tactics.ml @@ -14,6 +14,7 @@ open Util open Names open Nameops open Constr +open Context open Termops open Environ open EConstr @@ -137,8 +138,8 @@ let introduction id = in let open Context.Named.Declaration in match EConstr.kind sigma concl with - | Prod (_, t, b) -> unsafe_intro env (LocalAssum (id, t)) b - | LetIn (_, c, t, b) -> unsafe_intro env (LocalDef (id, c, t)) b + | Prod (id0, t, b) -> unsafe_intro env (LocalAssum ({id0 with binder_name=id}, t)) b + | LetIn (id0, c, t, b) -> unsafe_intro env (LocalDef ({id0 with binder_name=id}, c, t)) b | _ -> raise (RefinerError (env, sigma, IntroNeedsProduct)) end @@ -366,8 +367,8 @@ let default_id env sigma decl = match decl with | LocalAssum (name,t) -> let dft = default_id_of_sort (Retyping.get_sort_of env sigma t) in - id_of_name_with_default dft name - | LocalDef (name,b,_) -> id_of_name_using_hdchar env sigma b name + id_of_name_with_default dft name.binder_name + | LocalDef (name,b,_) -> id_of_name_using_hdchar env sigma b name.binder_name (* Non primitive introduction tactics are treated by intro_then_gen There is possibly renaming, with possibly names to avoid and @@ -437,16 +438,17 @@ let internal_cut_gen ?(check=true) dir replace id t = let sigma = Tacmach.New.project gl in let concl = Proofview.Goal.concl gl in let sign = named_context_val env in + let r = Retyping.relevance_of_type env sigma t in let sign',t,concl,sigma = if replace then let nexthyp = get_next_hyp_position env sigma id (named_context_of_val sign) in let sigma,sign',t,concl = clear_hyps2 env sigma (Id.Set.singleton id) sign t concl in - let sign' = insert_decl_in_named_context env sigma (LocalAssum (id,t)) nexthyp sign' in + let sign' = insert_decl_in_named_context env sigma (LocalAssum (make_annot id r,t)) nexthyp sign' in sign',t,concl,sigma else (if check && mem_named_context_val id sign then user_err (str "Variable " ++ Id.print id ++ str " is already declared."); - push_named_context_val (LocalAssum (id,t)) sign,t,concl,sigma) in + push_named_context_val (LocalAssum (make_annot id r,t)) sign,t,concl,sigma) in let nf_t = nf_betaiota env sigma t in Proofview.tclTHEN (Proofview.Unsafe.tclEVARS sigma) @@ -460,7 +462,7 @@ let internal_cut_gen ?(check=true) dir replace id t = let (sigma, ev') = Evarutil.new_evar_from_context sign' sigma ~principal:true 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 + let term = mkLetIn (make_annot (Name id) r, ev, t, EConstr.Vars.subst_var id ev') in (sigma, term) end) end @@ -471,7 +473,7 @@ 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 + let id = find_name b (LocalAssum (make_annot Anonymous Sorts.Relevant,t)) naming gl in Tacticals.New.tclTHENLAST (internal_cut b id t) (tac id) @@ -486,7 +488,7 @@ let assert_before_replacing id = assert_before_gen true (NamingMustBe (CAst.make let assert_after_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 + let id = find_name b (LocalAssum (make_annot Anonymous Sorts.Relevant,t)) naming gl in Tacticals.New.tclTHENFIRST (internal_cut_rev b id t) (tac id) @@ -542,7 +544,7 @@ let mutual_fix f n rest j = Proofview.Goal.enter begin fun gl -> if mem_named_context_val f sign then user_err ~hdr:"Logic.prim_refiner" (str "Name " ++ Id.print f ++ str " already used in the environment"); - mk_sign (push_named_context_val (LocalAssum (f, ar)) sign) oth + mk_sign (push_named_context_val (LocalAssum (make_annot f Sorts.Relevant, ar)) sign) oth in let nenv = reset_with_named_context (mk_sign (named_context_val env) all) env in Refine.refine ~typecheck:false begin fun sigma -> @@ -550,7 +552,8 @@ let mutual_fix f n rest j = Proofview.Goal.enter begin fun gl -> let ids = List.map pi1 all in let evs = List.map (Vars.subst_vars (List.rev ids)) evs in let indxs = Array.of_list (List.map (fun n -> n-1) (List.map pi2 all)) in - let funnames = Array.of_list (List.map (fun i -> Name i) ids) in + (* TODO relevance *) + let funnames = Array.of_list (List.map (fun i -> make_annot (Name i) Sorts.Relevant) ids) in let typarray = Array.of_list (List.map pi3 all) in let bodies = Array.of_list evs in let oterm = mkFix ((indxs,0),(funnames,typarray,bodies)) in @@ -586,14 +589,15 @@ let mutual_cofix f others j = Proofview.Goal.enter begin fun gl -> let open Context.Named.Declaration in if mem_named_context_val f sign then error "Name already used in the environment."; - mk_sign (push_named_context_val (LocalAssum (f, ar)) sign) oth + mk_sign (push_named_context_val (LocalAssum (make_annot f Sorts.Relevant, ar)) sign) oth in let nenv = reset_with_named_context (mk_sign (named_context_val env) all) env in Refine.refine ~typecheck:false begin fun sigma -> let (ids, types) = List.split all in let (sigma, evs) = mk_holes nenv sigma types in let evs = List.map (Vars.subst_vars (List.rev ids)) evs in - let funnames = Array.of_list (List.map (fun i -> Name i) ids) in + (* TODO relevance *) + let funnames = Array.of_list (List.map (fun i -> make_annot (Name i) Sorts.Relevant) ids) in let typarray = Array.of_list types in let bodies = Array.of_list evs in let oterm = mkCoFix (0, (funnames, typarray, bodies)) in @@ -616,7 +620,7 @@ let pf_reduce_decl redfun where decl gl = match decl with | LocalAssum (id,ty) -> if where == InHypValueOnly then - user_err (Id.print id ++ str " has no value."); + user_err (Id.print id.binder_name ++ str " has no value."); LocalAssum (id,redfun' ty) | LocalDef (id,b,ty) -> let b' = if where != InHypTypeOnly then redfun' b else b in @@ -717,7 +721,7 @@ let pf_e_reduce_decl redfun where decl gl = match decl with | LocalAssum (id,ty) -> if where == InHypValueOnly then - user_err (Id.print id ++ str " has no value."); + user_err (Id.print id.binder_name ++ str " has no value."); let (sigma, ty') = redfun sigma ty in (sigma, LocalAssum (id, ty')) | LocalDef (id,b,ty) -> @@ -760,7 +764,7 @@ let e_pf_change_decl (redfun : bool -> e_reduction_function) where decl env sigm match decl with | LocalAssum (id,ty) -> if where == InHypValueOnly then - user_err (Id.print id ++ str " has no value."); + user_err (Id.print id.binder_name ++ str " has no value."); let (sigma, ty') = redfun false env sigma ty in (sigma, LocalAssum (id, ty')) | LocalDef (id,b,ty) -> @@ -947,7 +951,7 @@ let rec intro_then_gen name_flag move_flag force_flag dep_flag tac = let name = find_name false (LocalDef (name,b,t)) name_flag gl in build_intro_tac name move_flag tac | Evar ev when force_flag -> - let sigma, t = Evardefine.define_evar_as_product sigma ev in + let sigma, t = Evardefine.define_evar_as_product env sigma ev in Tacticals.New.tclTHEN (Proofview.Unsafe.tclEVARS sigma) (intro_then_gen name_flag move_flag force_flag dep_flag tac) @@ -1238,27 +1242,29 @@ let cut c = let env = Proofview.Goal.env gl in let sigma = Tacmach.New.project gl in let concl = Proofview.Goal.concl gl in - let is_sort = + let relevance = try - (* Backward compat: ensure that [c] is well-typed. *) + (* Backward compat: ensure that [c] is well-typed. Plus we + need to know the relevance *) let typ = Typing.unsafe_type_of env sigma c in let typ = whd_all env sigma typ in match EConstr.kind sigma typ with - | Sort _ -> true - | _ -> false - with e when Pretype_errors.precatchable_exception e -> false + | Sort s -> Some (Sorts.relevance_of_sort (ESorts.kind sigma s)) + | _ -> None + with e when Pretype_errors.precatchable_exception e -> None in - if is_sort then + match relevance with + | Some r -> let id = next_name_away_with_default "H" Anonymous (Tacmach.New.pf_ids_set_of_hyps gl) in (* Backward compat: normalize [c]. *) let c = if normalize_cut then local_strong whd_betaiota sigma c else c in Refine.refine ~typecheck:false begin fun h -> - let (h, f) = Evarutil.new_evar ~principal:true env h (mkArrow c (Vars.lift 1 concl)) in + let (h, f) = Evarutil.new_evar ~principal:true env h (mkArrow c r (Vars.lift 1 concl)) in let (h, x) = Evarutil.new_evar env h c in - let f = mkLetIn (Name id, x, c, mkApp (Vars.lift 1 f, [|mkRel 1|])) in + let f = mkLetIn (make_annot (Name id) r, x, c, mkApp (Vars.lift 1 f, [|mkRel 1|])) in (h, f) end - else + | None -> Tacticals.New.tclZEROMSG (str "Not a proposition or a type.") end @@ -1823,7 +1829,7 @@ let apply_in_once ?(respect_opaque = false) sidecond_first with_delta let sigma = Tacmach.New.project gl in let t' = Tacmach.New.pf_get_hyp_typ id gl in let innerclause = mk_clenv_from_env env sigma (Some 0) (mkVar id,t') in - let targetid = find_name true (LocalAssum (Anonymous,t')) naming gl in + let targetid = find_name true (LocalAssum (make_annot Anonymous Sorts.Relevant,t')) naming gl in let rec aux idstoclear with_destruct c = Proofview.Goal.enter begin fun gl -> let env = Proofview.Goal.env gl in @@ -1890,7 +1896,7 @@ let cut_and_apply c = let concl = Proofview.Goal.concl gl in let env = Tacmach.New.pf_env gl in Refine.refine ~typecheck:false begin fun sigma -> - let typ = mkProd (Anonymous, c2, concl) in + let typ = mkProd (make_annot Anonymous Sorts.Relevant, c2, concl) in let (sigma, f) = Evarutil.new_evar env sigma typ in let (sigma, x) = Evarutil.new_evar env sigma c1 in (sigma, mkApp (f, [|mkApp (c, [|x|])|])) @@ -2013,12 +2019,12 @@ let clear_body ids = let ctx = named_context env in let map = function | LocalAssum (id,t) as decl -> - let () = if List.mem_f Id.equal id ids then - user_err (str "Hypothesis " ++ Id.print id ++ str " is not a local definition") + let () = if List.mem_f Id.equal id.binder_name ids then + user_err (str "Hypothesis " ++ Id.print id.binder_name ++ str " is not a local definition") in decl | LocalDef (id,_,t) as decl -> - if List.mem_f Id.equal id ids then LocalAssum (id, t) else decl + if List.mem_f Id.equal id.binder_name ids then LocalAssum (id, t) else decl in let ctx = List.map map ctx in let base_env = reset_context env in @@ -2624,7 +2630,8 @@ let letin_tac_gen with_eq (id,depdecls,lastlhyp,ccl,c) ty = let (sigma, refl) = Evd.fresh_global env sigma eqdata.refl in let eq = applist (eq,args) in let refl = applist (refl, [t;mkVar id]) in - let term = mkNamedLetIn id c t (mkLetIn (Name heq, refl, eq, ccl)) in + let term = mkNamedLetIn (make_annot id Sorts.Relevant) c t + (mkLetIn (make_annot (Name heq) Sorts.Relevant, refl, eq, ccl)) in let sigma, _ = Typing.type_of env sigma term in let ans = term, Tacticals.New.tclTHENLIST @@ -2634,7 +2641,7 @@ let letin_tac_gen with_eq (id,depdecls,lastlhyp,ccl,c) ty = in (sigma, ans) | None -> - (sigma, (mkNamedLetIn id c t ccl, Proofview.tclUNIT ())) + (sigma, (mkNamedLetIn (make_annot id Sorts.Relevant) c t ccl, Proofview.tclUNIT ())) in Tacticals.New.tclTHENLIST [ Proofview.Unsafe.tclEVARS sigma; @@ -2669,8 +2676,9 @@ let mk_eq_name env id {CAst.loc;v=ido} = let mkletin_goal env sigma with_eq dep (id,lastlhyp,ccl,c) ty = let open Context.Named.Declaration in let t = match ty with Some t -> t | _ -> typ_of env sigma c in - let decl = if dep then LocalDef (id,c,t) - else LocalAssum (id,t) + let r = Retyping.relevance_of_type env sigma t in + let decl = if dep then LocalDef (make_annot id r,c,t) + else LocalAssum (make_annot id r,t) in match with_eq with | Some (lr,heq) -> @@ -2680,13 +2688,14 @@ let mkletin_goal env sigma with_eq dep (id,lastlhyp,ccl,c) ty = let (sigma, refl) = Evd.fresh_global env sigma eqdata.refl in let eq = applist (eq,args) in let refl = applist (refl, [t;mkVar id]) in - let newenv = insert_before [LocalAssum (heq,eq); decl] lastlhyp env in + let newenv = insert_before [LocalAssum (make_annot heq Sorts.Relevant,eq); decl] lastlhyp env in let (sigma, x) = new_evar newenv sigma ~principal:true ccl in - (sigma, mkNamedLetIn id c t (mkNamedLetIn heq refl eq x)) + (sigma, mkNamedLetIn (make_annot id r) c t + (mkNamedLetIn (make_annot heq Sorts.Relevant) refl eq x)) | None -> let newenv = insert_before [decl] lastlhyp env in let (sigma, x) = new_evar newenv sigma ~principal:true ccl in - (sigma, mkNamedLetIn id c t x) + (sigma, mkNamedLetIn (make_annot id r) c t x) let pose_tac na c = Proofview.Goal.enter begin fun gl -> @@ -2708,11 +2717,13 @@ let pose_tac na c = in Proofview.Unsafe.tclEVARS sigma <*> Refine.refine ~typecheck:false begin fun sigma -> + (* TODO relevance *) + let id = make_annot id Sorts.Relevant in let nhyps = EConstr.push_named_context_val (NamedDecl.LocalDef (id, c, t)) hyps in let (sigma, ev) = Evarutil.new_pure_evar nhyps sigma concl in let inst = Array.map_of_list (fun d -> mkVar (get_id d)) (named_context env) in let body = mkEvar (ev, Array.append [|mkRel 1|] inst) in - (sigma, mkLetIn (Name id, c, t, body)) + (sigma, mkLetIn (map_annot Name.mk_name id, c, t, body)) end end @@ -2806,9 +2817,10 @@ let generalize_goal_gen env sigma ids i ((occs,c,b),na) t cl = let newdecls,_ = decompose_prod_n_assum sigma i (subst_term_gen sigma EConstr.eq_constr_nounivs c dummy_prod) in let cl',sigma' = subst_closed_term_occ env sigma (AtOccs occs) c (it_mkProd_or_LetIn cl newdecls) in let na = generalized_name env sigma c t ids cl' na in + let r = Retyping.relevance_of_type env sigma t in let decl = match b with - | None -> LocalAssum (na,t) - | Some b -> LocalDef (na,b,t) + | None -> LocalAssum (make_annot na r,t) + | Some b -> LocalDef (make_annot na r,b,t) in mkProd_or_LetIn decl cl', sigma' @@ -2948,8 +2960,8 @@ let specialize (c,lbind) ipat = (* If the term is lambda then we put a letin to put avoid interaction between the term and the bindings. *) let c = match EConstr.kind sigma c with - | Lambda(_,_,_) -> - mkLetIn(Name.Anonymous, c, typ_of_c, (mkRel 1)) + | Lambda _ -> + mkLetIn(make_annot Name.Anonymous Sorts.Relevant, c, typ_of_c, (mkRel 1)) | _ -> c in let clause = make_clenv_binding env sigma (c,typ_of_c) lbind in let flags = { (default_unify_flags ()) with resolve_evars = true } in @@ -2973,14 +2985,15 @@ let specialize (c,lbind) ipat = (* nme has not been resolved, let us re-abstract it. Same name but type updated by instanciation of other args. *) let sigma,new_typ_of_t = Typing.type_of clause.env sigma t in + let r = Retyping.relevance_of_type env sigma new_typ_of_t in let liftedargs = List.map liftrel args in (* lifting rels in the accumulator args *) let sigma,hd' = rebuild_lambdas sigma lp' (liftedargs@[mkRel 1 ]) hd l' in (* replace meta variable by the abstracted variable *) let hd'' = subst_term sigma t hd' in (* lambda expansion *) - sigma,mkLambda (nme,new_typ_of_t,hd'') - | Context.Rel.Declaration.LocalAssum(_,_)::lp' , t::l' -> + sigma,mkLambda ({nme with binder_relevance=r},new_typ_of_t,hd'') + | Context.Rel.Declaration.LocalAssum _::lp' , t::l' -> let sigma,hd' = rebuild_lambdas sigma lp' (args@[t]) hd l' in sigma,hd' | _ ,_ -> assert false in @@ -3631,15 +3644,18 @@ let make_abstract_generalize env id typ concl dep ctx body c eqs args refls = let homogeneous = Reductionops.is_conv env sigma ty typ in let sigma, (eq, refl) = mk_term_eq homogeneous (push_rel_context ctx env) sigma ty (mkRel 1) typ (mkVar id) in - sigma, mkProd (Anonymous, eq, lift 1 concl), [| refl |] + sigma, mkProd (make_annot Anonymous Sorts.Relevant, eq, lift 1 concl), [| refl |] else sigma, concl, [||] in (* Abstract by equalities *) let eqs = lift_togethern 1 eqs in (* lift together and past genarg *) - let abseqs = it_mkProd_or_LetIn (lift eqslen abshypeq) (List.map (fun x -> LocalAssum (Anonymous, x)) eqs) in + let abseqs = it_mkProd_or_LetIn (lift eqslen abshypeq) + (List.map (fun x -> LocalAssum (make_annot Anonymous Sorts.Relevant, x)) eqs) + in + let r = Sorts.Relevant in (* TODO relevance *) let decl = match body with - | None -> LocalAssum (Name id, c) - | Some body -> LocalDef (Name id, body, c) + | None -> LocalAssum (make_annot (Name id) r, c) + | Some body -> LocalDef (make_annot (Name id) r, body, c) in (* Abstract by the "generalized" hypothesis. *) let genarg = mkProd_or_LetIn decl abseqs in @@ -3714,10 +3730,10 @@ let abstract_args gl generalize_vars dep id defined f args = eqs are not lifted w.r.t. each other yet. (* will be needed when going to dependent indexes *) *) let aux (prod, ctx, ctxenv, c, args, eqs, refls, nongenvars, vars, env) arg = - let name, ty, arity = + let name, ty_relevance, ty, arity = let rel, c = Reductionops.splay_prod_n env !sigma 1 prod in let decl = List.hd rel in - RelDecl.get_name decl, RelDecl.get_type decl, c + RelDecl.get_name decl, RelDecl.get_relevance decl, RelDecl.get_type decl, c in let argty = Tacmach.New.pf_unsafe_type_of gl arg in let sigma', ty = Evarsolve.refresh_universes (Some true) env !sigma ty in @@ -3731,7 +3747,7 @@ let abstract_args gl generalize_vars dep id defined f args = Id.Set.add id nongenvars, Id.Set.remove id vars, env) | _ -> let name = get_id name in - let decl = LocalAssum (Name name, ty) in + let decl = LocalAssum (make_annot (Name name) ty_relevance, ty) in let ctx = decl :: ctx in let c' = mkApp (lift 1 c, [|mkRel 1|]) in let args = arg :: args in @@ -3869,7 +3885,7 @@ let specialize_eqs id = else let sigma, e = Evarutil.new_evar (push_rel_context ctx env) !evars t in evars := sigma; - aux false (LocalDef (na,e,t) :: ctx) (mkApp (lift 1 acc, [| mkRel 1 |])) b) + aux false (LocalDef (na,e,t) :: ctx) (mkApp (lift 1 acc, [| mkRel 1 |])) b) | t -> acc, in_eqs, ctx, ty in let acc, worked, ctx, ty = aux false [] (mkVar id) ty in @@ -3917,7 +3933,7 @@ let decompose_paramspred_branch_args sigma elimt = | Prod(nme,tpe,elimt') -> let hd_tpe,_ = decompose_app sigma (snd (decompose_prod_assum sigma tpe)) in if not (occur_rel sigma 1 elimt') && isRel sigma hd_tpe - then cut_noccur elimt' (LocalAssum (nme,tpe)::acc2) + then cut_noccur elimt' (LocalAssum (nme,tpe)::acc2) else let acc3,ccl = decompose_prod_assum sigma elimt in acc2 , acc3 , ccl | App(_, _) | Rel _ -> acc2 , [] , elimt | _ -> error_ind_scheme "" in @@ -3999,8 +4015,8 @@ let compute_elim_sig sigma ?elimc elimt = (* 3- Look at last arg: is it the indarg? *) ignore ( match List.hd args_indargs with - | LocalDef (hiname,_,hi) -> error_ind_scheme "" - | LocalAssum (hiname,hi) -> + | LocalDef (hiname,_,hi) -> error_ind_scheme "" + | LocalAssum (hiname,hi) -> let hi_ind, hi_args = decompose_app sigma hi in let hi_is_ind = (* hi est d'un type globalisable *) match EConstr.kind sigma hi_ind with diff --git a/tactics/term_dnet.ml b/tactics/term_dnet.ml index e8a66f1889..2831aec9f6 100644 --- a/tactics/term_dnet.ml +++ b/tactics/term_dnet.ml @@ -316,7 +316,7 @@ struct Term(DCoFix(i,Array.map pat_of_constr ta,Array.map pat_of_constr ca)) | Cast (c,_,_) -> pat_of_constr c | Lambda (_,t,c) -> Term(DLambda (pat_of_constr t, pat_of_constr c)) - | (Prod (_,_,_) | LetIn(_,_,_,_)) -> + | (Prod _ | LetIn _) -> let (ctx,c) = ctx_of_constr (Term DNil) c in Term (DCtx (ctx,c)) | App (f,ca) -> Array.fold_left (fun c a -> Term (DApp (c,a))) diff --git a/test-suite/bugs/closed/bug_3325.v b/test-suite/bugs/closed/bug_3325.v index 36c065ebe8..835b8a7f33 100644 --- a/test-suite/bugs/closed/bug_3325.v +++ b/test-suite/bugs/closed/bug_3325.v @@ -1,13 +1,13 @@ Typeclasses eauto := debug. Set Printing All. -Axiom SProp : Set. -Axiom sp : SProp. +Axiom sProp : Set. +Axiom sp : sProp. (* If we hardcode valueType := nat, it goes through *) Class StateIs := { valueType : Type; - stateIs : valueType -> SProp + stateIs : valueType -> sProp }. Instance NatStateIs : StateIs := { @@ -17,17 +17,17 @@ Instance NatStateIs : StateIs := { Canonical Structure NatStateIs. Class LogicOps F := { land: F -> F }. -Instance : LogicOps SProp. Admitted. +Instance : LogicOps sProp. Admitted. Instance : LogicOps Prop. Admitted. Parameter (n : nat). (* If this is a [Definition], the resolution goes through fine. *) Notation vn := (@stateIs _ n). Definition vn' := (@stateIs _ n). -Definition GOOD : SProp := +Definition GOOD : sProp := @land _ _ vn'. (* This doesn't resolve, if PropLogicOps is defined later than SPropLogicOps *) -Definition BAD : SProp := +Definition BAD : sProp := @land _ _ vn. diff --git a/test-suite/bugs/closed/bug_sprop_13.v b/test-suite/bugs/closed/bug_sprop_13.v new file mode 100644 index 0000000000..ae80c9c51f --- /dev/null +++ b/test-suite/bugs/closed/bug_sprop_13.v @@ -0,0 +1,7 @@ +(* -*- mode: coq; coq-prog-args: ("-allow-sprop") -*- *) +Goal forall (P : SProp), P -> P. +Proof. + intros P H. set (H0 := H). + (* goal is now H0 *) + exact H0. +Qed. diff --git a/test-suite/bugs/closed/bug_sprop_14.v b/test-suite/bugs/closed/bug_sprop_14.v new file mode 100644 index 0000000000..1e6e9b30de --- /dev/null +++ b/test-suite/bugs/closed/bug_sprop_14.v @@ -0,0 +1,26 @@ +(* -*- coq-prog-args: ("-allow-sprop"); -*- *) + +Set Universe Polymorphism. + +Inductive False : SProp :=. + +Axiom ℙ@{} : SProp. + +Definition TYPE@{i} := ℙ -> Type@{i}. +Definition PROP@{} := ℙ -> SProp. + +Definition El@{i} (A : TYPE@{i}) := forall p, A p. +Definition sEl@{} (A : PROP@{}) : SProp := forall p, A p. + +Definition SPropᶠ@{} := fun (p : ℙ) => SProp. + +Definition sProdᶠ@{i} + (A : TYPE@{i}) + (B : forall (p : ℙ), El A -> SProp) : PROP := fun (p : ℙ) => forall x : El A, B p x. + +Definition Falseᶠ : El SPropᶠ := fun p => False. + +Definition EMᶠ : sEl (sProdᶠ SPropᶠ (fun p A => ((sProdᶠ A (fun p _ => Falseᶠ p))) p)). +Proof. +Fail Admitted. +Abort. diff --git a/test-suite/misc/poly-capture-global-univs/src/evilImpl.ml b/test-suite/misc/poly-capture-global-univs/src/evilImpl.ml index f5043db099..adabb7a0a0 100644 --- a/test-suite/misc/poly-capture-global-univs/src/evilImpl.ml +++ b/test-suite/misc/poly-capture-global-univs/src/evilImpl.ml @@ -16,7 +16,7 @@ let evil t f = let fe = Declare.definition_entry ~univs:(Polymorphic_entry ([|Anonymous|], UContext.make (Instance.of_array [|u|],Constraint.empty))) - ~types:(Term.mkArrow tc tu) - (mkLambda (Name.Name (Id.of_string "x"), tc, mkRel 1)) + ~types:(Term.mkArrowR tc tu) + (mkLambda (Context.nameR (Id.of_string "x"), tc, mkRel 1)) in ignore (Declare.declare_constant f (DefinitionEntry fe, k)) diff --git a/test-suite/output/Error_msg_diffs.out b/test-suite/output/Error_msg_diffs.out new file mode 100644 index 0000000000..3e337e892d --- /dev/null +++ b/test-suite/output/Error_msg_diffs.out @@ -0,0 +1,12 @@ +File "stdin", line 32, characters 0-12: +[37;41;1mError:[0m +In environment +T : [33;1mType[0m +p : T[37m ->[0m bool +a : T +t1, t2 : btree T +IH1 : count p (rev_tree t1)[37m =[0m count p t1 +IH2 : count p (rev_tree t2)[37m =[0m count p t2 +Unable to unify "[48;2;91;0;0m([1mif[22m p a [1mthen[22m 1 [1melse[22m 0)[37m +[39m (count p [48;2;170;0;0;4mt1[48;2;91;0;0;24m[37m +[39m count p [48;2;170;0;0;4mt2[48;2;91;0;0;24m)[0m" with + "[48;2;0;91;0m([1mif[22m p a [1mthen[22m 1 [1melse[22m 0)[37m +[39m (count p [48;2;0;141;0;4mt2[48;2;0;91;0;24m[37m +[39m count p [48;2;0;141;0;4mt1[48;2;0;91;0;24m)[0m". + diff --git a/test-suite/output/Error_msg_diffs.v b/test-suite/output/Error_msg_diffs.v new file mode 100644 index 0000000000..11c766b210 --- /dev/null +++ b/test-suite/output/Error_msg_diffs.v @@ -0,0 +1,35 @@ +(* coq-prog-args: ("-color" "on" "-async-proofs" "off") *) +(* Re: -async-proofs off, see https://github.com/coq/coq/issues/9671 *) +(* Shows diffs in an error message for an "Unable to unify" error *) +Require Import Arith List Bool. + +Inductive btree (T : Type) : Type := + Leaf | Node (val : T) (t1 t2 : btree T). + +Arguments Leaf {T}. +Arguments Node {T}. + +Fixpoint rev_tree {T : Type} (t : btree T) : btree T := +match t with +| Leaf => Leaf +| Node x t1 t2 => Node x (rev_tree t2) (rev_tree t1) +end. + +Fixpoint count {T : Type} (p : T -> bool) (t : btree T) : nat := +match t with +| Leaf => 0 +| Node x t1 t2 => + (if p x then 1 else 0) + (count p t1 + count p t2) +end. + +Lemma count_rev_tree {T} (p : T -> bool) t : count p (rev_tree t) = count p t. +Proof. +induction t as [ | a t1 IH1 t2 IH2]. + easy. +simpl. +rewrite IH1. +rewrite IH2. +reflexivity. +rewrite (Nat.add_comm (count p t2)). +easy. +Qed. diff --git a/test-suite/output/RealSyntax.v b/test-suite/output/RealSyntax.v index 15ae66010e..44e8c7a50c 100644 --- a/test-suite/output/RealSyntax.v +++ b/test-suite/output/RealSyntax.v @@ -1,3 +1,3 @@ -Require Import Reals. +Require Import Reals.Rdefinitions. Check 32%R. Check (-31)%R. diff --git a/test-suite/output/Search.out b/test-suite/output/Search.out index f4544a0df3..ffba1d35cc 100644 --- a/test-suite/output/Search.out +++ b/test-suite/output/Search.out @@ -1,59 +1,72 @@ le_n: forall n : nat, n <= n le_0_n: forall n : nat, 0 <= n le_S: forall n m : nat, n <= m -> n <= S m -le_n_S: forall n m : nat, n <= m -> S n <= S m -le_pred: forall n m : nat, n <= m -> Nat.pred n <= Nat.pred m le_S_n: forall n m : nat, S n <= S m -> n <= m -min_l: forall n m : nat, n <= m -> Nat.min n m = n +le_pred: forall n m : nat, n <= m -> Nat.pred n <= Nat.pred m +le_n_S: forall n m : nat, n <= m -> S n <= S m +max_l: forall n m : nat, m <= n -> Nat.max n m = n max_r: forall n m : nat, n <= m -> Nat.max n m = m min_r: forall n m : nat, m <= n -> Nat.min n m = m -max_l: forall n m : nat, m <= n -> Nat.max n m = n +min_l: forall n m : nat, n <= m -> Nat.min n m = n le_ind: forall (n : nat) (P : nat -> Prop), P n -> (forall m : nat, n <= m -> P m -> P (S m)) -> forall n0 : nat, n <= n0 -> P n0 +le_sind: + forall (n : nat) (P : nat -> SProp), + P n -> + (forall m : nat, n <= m -> P m -> P (S m)) -> + forall n0 : nat, n <= n0 -> P n0 false: bool true: bool +eq_true: bool -> Prop is_true: bool -> Prop negb: bool -> bool -eq_true: bool -> Prop -implb: bool -> bool -> bool -orb: bool -> bool -> bool andb: bool -> bool -> bool +orb: bool -> bool -> bool +implb: bool -> bool -> bool xorb: bool -> bool -> bool Nat.even: nat -> bool Nat.odd: nat -> bool BoolSpec: Prop -> Prop -> bool -> Prop -Nat.eqb: nat -> nat -> bool -Nat.testbit: nat -> nat -> bool Nat.ltb: nat -> nat -> bool +Nat.testbit: nat -> nat -> bool +Nat.eqb: nat -> nat -> bool Nat.leb: nat -> nat -> bool Nat.bitwise: (bool -> bool -> bool) -> nat -> nat -> nat -> nat -bool_ind: forall P : bool -> Prop, P true -> P false -> forall b : bool, P b bool_rec: forall P : bool -> Set, P true -> P false -> forall b : bool, P b +eq_true_ind_r: + forall (P : bool -> Prop) (b : bool), P b -> eq_true b -> P true eq_true_rec: forall P : bool -> Set, P true -> forall b : bool, eq_true b -> P b -bool_rect: forall P : bool -> Type, P true -> P false -> forall b : bool, P b -eq_true_rect_r: - forall (P : bool -> Type) (b : bool), P b -> eq_true b -> P true -eq_true_rec_r: - forall (P : bool -> Set) (b : bool), P b -> eq_true b -> P true +bool_ind: forall P : bool -> Prop, P true -> P false -> forall b : bool, P b eq_true_rect: forall P : bool -> Type, P true -> forall b : bool, eq_true b -> P b +eq_true_sind: + forall P : bool -> SProp, P true -> forall b : bool, eq_true b -> P b +bool_rect: forall P : bool -> Type, P true -> P false -> forall b : bool, P b eq_true_ind: forall P : bool -> Prop, P true -> forall b : bool, eq_true b -> P b -eq_true_ind_r: - forall (P : bool -> Prop) (b : bool), P b -> eq_true b -> P true +eq_true_rec_r: + forall (P : bool -> Set) (b : bool), P b -> eq_true b -> P true +eq_true_rect_r: + forall (P : bool -> Type) (b : bool), P b -> eq_true b -> P true +bool_sind: + forall P : bool -> SProp, P true -> P false -> forall b : bool, P b Byte.to_bits: Byte.byte -> bool * (bool * (bool * (bool * (bool * (bool * (bool * bool)))))) Byte.of_bits: bool * (bool * (bool * (bool * (bool * (bool * (bool * bool)))))) -> Byte.byte +andb_prop: forall a b : bool, (a && b)%bool = true -> a = true /\ b = true andb_true_intro: forall b1 b2 : bool, b1 = true /\ b2 = true -> (b1 && b2)%bool = true -andb_prop: forall a b : bool, (a && b)%bool = true -> a = true /\ b = true +BoolSpec_sind: + forall (P Q : Prop) (P0 : bool -> SProp), + (P -> P0 true) -> + (Q -> P0 false) -> forall b : bool, BoolSpec P Q b -> P0 b BoolSpec_ind: forall (P Q : Prop) (P0 : bool -> Prop), (P -> P0 true) -> diff --git a/test-suite/success/cumulativity.v b/test-suite/success/cumulativity.v index 3d97f27b16..31fed98952 100644 --- a/test-suite/success/cumulativity.v +++ b/test-suite/success/cumulativity.v @@ -137,3 +137,12 @@ Module WithIndex. Monomorphic Constraint i < j. Definition bar : eq mkfoo@{i} mkfoo@{j} := eq_refl _. End WithIndex. + +Module CumulApp. + + (* i is covariant here, and we have one parameter *) + Inductive foo@{i} (A : nat) : Type@{i+1} := mkfoo (B : Type@{i}). + + Definition bar@{i j|i<=j} := fun x : foo@{i} 0 => x : foo@{j} 0. + +End CumulApp. diff --git a/test-suite/success/sprop.v b/test-suite/success/sprop.v new file mode 100644 index 0000000000..268c1880d2 --- /dev/null +++ b/test-suite/success/sprop.v @@ -0,0 +1,189 @@ +(* -*- mode: coq; coq-prog-args: ("-allow-sprop") -*- *) + +Set Primitive Projections. +Set Warnings "+non-primitive-record". +Set Warnings "+bad-relevance". + +Check SProp. + +Definition iUnit : SProp := forall A : SProp, A -> A. + +Definition itt : iUnit := fun A a => a. + +Definition iUnit_irr (P : iUnit -> Type) (x y : iUnit) : P x -> P y + := fun v => v. + +Definition iSquash (A:Type) : SProp + := forall P : SProp, (A -> P) -> P. +Definition isquash A : A -> iSquash A + := fun a P f => f a. +Definition iSquash_rect A (P : iSquash A -> SProp) (H : forall x : A, P (isquash A x)) + : forall x : iSquash A, P x + := fun x => x (P x) (H : A -> P x). + +Fail Check (fun A : SProp => A : Type). + +Lemma foo : Prop. +Proof. pose (fun A : SProp => A : Type); exact True. Fail Qed. Abort. + +(* define evar as product *) +Check (fun (f:(_:SProp)) => f _). + +Inductive sBox (A:SProp) : Prop + := sbox : A -> sBox A. + +Definition uBox := sBox iUnit. + +Definition sBox_irr A (x y : sBox A) : x = y. +Proof. + Fail reflexivity. + destruct x as [x], y as [y]. + reflexivity. +Defined. + +(* Primitive record with all fields in SProp has the eta property of SProp so must be SProp. *) +Fail Record rBox (A:SProp) : Prop := rmkbox { runbox : A }. +Section Opt. + Local Unset Primitive Projections. + Record rBox (A:SProp) : Prop := rmkbox { runbox : A }. +End Opt. + +(* Check that defining as an emulated record worked *) +Check runbox. + +(* Check that it doesn't have eta *) +Fail Check (fun (A : SProp) (x : rBox A) => eq_refl : x = @rmkbox _ (@runbox _ x)). + +Inductive sEmpty : SProp := . + +Inductive sUnit : SProp := stt. + +Inductive BIG : SProp := foo | bar. + +Inductive Squash (A:Type) : SProp + := squash : A -> Squash A. + +Definition BIG_flip : BIG -> BIG. +Proof. + intros [|]. exact bar. exact foo. +Defined. + +Inductive pb : Prop := pt | pf. + +Definition pb_big : pb -> BIG. +Proof. + intros [|]. exact foo. exact bar. +Defined. + +Fail Definition big_pb (b:BIG) : pb := + match b return pb with foo => pt | bar => pf end. + +Inductive which_pb : pb -> SProp := +| is_pt : which_pb pt +| is_pf : which_pb pf. + +Fail Definition pb_which b (w:which_pb b) : bool + := match w with + | is_pt => true + | is_pf => false + end. + +(* Non primitive because no arguments, but maybe we should allow it for sprops? *) +Fail Record UnitRecord : SProp := {}. + +Section Opt. + Local Unset Primitive Projections. + Record UnitRecord' : SProp := {}. +End Opt. +Fail Scheme Induction for UnitRecord' Sort Set. + +Record sProd (A B : SProp) : SProp := sPair { sFst : A; sSnd : B }. + +Scheme Induction for sProd Sort Set. + +Unset Primitive Projections. +Record sProd' (A B : SProp) : SProp := sPair' { sFst' : A; sSnd' : B }. +Set Primitive Projections. + +Fail Scheme Induction for sProd' Sort Set. + +Inductive Istrue : bool -> SProp := istrue : Istrue true. + +Definition Istrue_sym (b:bool) := if b then sUnit else sEmpty. +Definition Istrue_to_sym b (i:Istrue b) : Istrue_sym b := match i with istrue => stt end. + +Definition Istrue_rec (P:forall b, Istrue b -> Set) (H:P true istrue) b (i:Istrue b) : P b i. +Proof. + destruct b. + - exact_no_check H. + - apply sEmpty_rec. apply Istrue_to_sym in i. exact i. +Defined. + +Check (fun P v (e:Istrue true) => eq_refl : Istrue_rec P v _ e = v). + +Record Truepack := truepack { trueval :> bool; trueprop : Istrue trueval }. + +Definition Truepack_eta (x : Truepack) (i : Istrue x) : x = truepack x i := @eq_refl Truepack x. + +Class emptyclass : SProp := emptyinstance : forall A:SProp, A. + +(** Sigma in SProp can be done through Squash and relevant sigma. *) +Definition sSigma (A:SProp) (B:A -> SProp) : SProp + := Squash (@sigT (rBox A) (fun x => rBox (B (runbox _ x)))). + +Definition spair (A:SProp) (B:A->SProp) (x:A) (y:B x) : sSigma A B + := squash _ (existT _ (rmkbox _ x) (rmkbox _ y)). + +Definition spr1 (A:SProp) (B:A->SProp) (p:sSigma A B) : A + := let 'squash _ (existT _ x y) := p in runbox _ x. + +Definition spr2 (A:SProp) (B:A->SProp) (p:sSigma A B) : B (spr1 A B p) + := let 'squash _ (existT _ x y) := p return B (spr1 A B p) in runbox _ y. +(* it's SProp so it computes properly *) + +(** Fixpoints on SProp values are only allowed to produce SProp results *) +Inductive sAcc (x:nat) : SProp := sAcc_in : (forall y, y < x -> sAcc y) -> sAcc x. + +Definition sAcc_inv x (s:sAcc x) : forall y, y < x -> sAcc y. +Proof. + destruct s as [H]. exact H. +Defined. + +Section sFix_fail. + Variable P : nat -> Type. + Variable F : forall x:nat, (forall y:nat, y < x -> P y) -> P x. + + Fail Fixpoint sFix (x:nat) (a:sAcc x) {struct a} : P x := + F x (fun (y:nat) (h: y < x) => sFix y (sAcc_inv x a y h)). +End sFix_fail. + +Section sFix. + Variable P : nat -> SProp. + Variable F : forall x:nat, (forall y:nat, y < x -> P y) -> P x. + + Fixpoint sFix (x:nat) (a:sAcc x) {struct a} : P x := + F x (fun (y:nat) (h: y < x) => sFix y (sAcc_inv x a y h)). + +End sFix. + +(** Relevance repairs *) + +Fail Definition fix_relevance : _ -> nat := fun _ : iUnit => 0. + +Require Import ssreflect. + +Goal forall T : SProp, T -> True. +Proof. + move=> T +. + intros X;exact I. +Qed. + +Set Warnings "-bad-relevance". +Definition fix_relevance : _ -> nat := fun _ : iUnit => 0. + +(* relevance isn't fixed when checking P x == P y *) +Fail Definition relevance_unfixed := fun (A:SProp) (P:A -> Prop) x y (v:P x) => v : P y. + +(* but the kernel is fine *) +Definition relevance_unfixed := fun (A:SProp) (P:A -> Prop) x y (v:P x) => + ltac:(exact_no_check v) : P y. diff --git a/test-suite/success/sprop_hcons.v b/test-suite/success/sprop_hcons.v new file mode 100644 index 0000000000..14772dd62b --- /dev/null +++ b/test-suite/success/sprop_hcons.v @@ -0,0 +1,52 @@ +(* -*- coq-prog-args: ("-allow-sprop"); -*- *) + +(* A bug due to bad hashconsing of case info *) + +Inductive sBox (A : SProp) : Type := + sbox : A -> sBox A. + +Definition ubox {A : SProp} (bA : sBox A) : A := + match bA with + sbox _ X => X + end. + +Inductive sle : nat -> nat -> SProp := + sle_0 : forall n, sle 0 n +| sle_S : forall n m : nat, sle n m -> sle (S n) (S m). + +Definition sle_Sn (n : nat) : sle n (S n). +Proof. + induction n; constructor; auto. +Defined. + +Definition sle_trans {n m p} (H : sle n m) (H': sle m p) : sle n p. +Proof. + revert H'. revert p. induction H. + - intros p H'. apply sle_0. + - intros p H'. inversion H'. apply ubox. subst. apply sbox. apply sle_S. apply IHsle;auto. +Defined. + +Lemma sle_Sn_m {n m} : sle n m -> sle n (S m). +Proof. + intros H. destruct n. + - constructor. + - constructor;auto. assert (H1 : sle n (S n)) by apply sle_Sn. + exact (sle_trans H1 H ). +Defined. + +Definition sle_Sn_Sm {n m} : sle (S n) (S m) -> sle n m. +Proof. + intros H. + inversion H. apply ubox. subst. apply sbox. exact H2. +Qed. + + +Notation "g ∘ f" := (sle_trans g f) (at level 40). + +Lemma bazz q0 m (f : sle (S q0) (S m)) : + sbox _ (sle_Sn q0 ∘ f) = sbox _ (sle_Sn_m (sle_Sn_Sm f)). +Proof. + reflexivity. (* used to fail *) + (* NB: exact eq_refl succeeded even with the bug so no guarantee + that this test will continue to test the right thing. *) +Qed. diff --git a/theories/Init/Logic.v b/theories/Init/Logic.v index b607be4f94..1a391ed799 100644 --- a/theories/Init/Logic.v +++ b/theories/Init/Logic.v @@ -402,6 +402,12 @@ Section Logic_lemmas. End equality. + Definition eq_sind_r : + forall (A:Type) (x:A) (P:A -> SProp), P x -> forall y:A, y = x -> P y. + Proof. + intros A x P H y H0. elim eq_sym with (1 := H0); assumption. + Defined. + Definition eq_ind_r : forall (A:Type) (x:A) (P:A -> Prop), P x -> forall y:A, y = x -> P y. intros A x P H y H0. elim eq_sym with (1 := H0); assumption. diff --git a/theories/Logic/StrictProp.v b/theories/Logic/StrictProp.v new file mode 100644 index 0000000000..99ee54e42f --- /dev/null +++ b/theories/Logic/StrictProp.v @@ -0,0 +1,40 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +(** Utilities for SProp users. *) + +Set Universe Polymorphism. +Set Polymorphic Inductive Cumulativity. + +Record Box (A:SProp) : Prop := box { unbox : A }. +Arguments box {_} _. +Arguments unbox {_} _. + +Inductive Squash (A:Type) : SProp := squash : A -> Squash A. +Arguments squash {_} _. + +Inductive sEmpty : SProp :=. + +Inductive sUnit : SProp := stt. +Definition sUnit_rect (P:sUnit -> Type) (v:P stt) (u:sUnit) : P u := v. +Definition sUnit_rec (P:sUnit -> Set) (v:P stt) (u:sUnit) : P u := v. +Definition sUnit_ind (P:sUnit -> Prop) (v:P stt) (u:sUnit) : P u := v. + +Set Primitive Projections. +Record Ssig {A:Type} (P:A->SProp) := Sexists { Spr1 : A; Spr2 : P Spr1 }. +Arguments Sexists {_} _ _ _. +Arguments Spr1 {_ _} _. +Arguments Spr2 {_ _} _. + +Lemma Spr1_inj {A P} {a b : @Ssig A P} (e : Spr1 a = Spr1 b) : a = b. +Proof. + destruct a,b;simpl in e. + destruct e. reflexivity. +Defined. diff --git a/theories/ZArith/BinInt.v b/theories/ZArith/BinInt.v index 8fc3ab56c9..542d169e66 100644 --- a/theories/ZArith/BinInt.v +++ b/theories/ZArith/BinInt.v @@ -1259,6 +1259,30 @@ Proof. f_equal. now rewrite <- add_assoc, add_opp_diag_r, add_0_r. Qed. +(** * [testbit] in terms of comparision. *) + +Lemma testbit_mod_pow2 a n i (H : 0 <= n) + : testbit (a mod 2 ^ n) i = ((i <? n) && testbit a i)%bool. +Proof. + destruct (ltb_spec i n); rewrite + ?mod_pow2_bits_low, ?mod_pow2_bits_high by auto; auto. +Qed. + +Lemma testbit_ones n i (H : 0 <= n) + : testbit (ones n) i = ((0 <=? i) && (i <? n))%bool. +Proof. + destruct (leb_spec 0 i), (ltb_spec i n); cbn; + rewrite ?testbit_neg_r, ?ones_spec_low, ?ones_spec_high by auto; trivial. +Qed. + +Lemma testbit_ones_nonneg n i (Hn : 0 <= n) (Hi: 0 <= i) + : testbit (ones n) i = (i <? n). +Proof. + rewrite testbit_ones by auto. + destruct (leb_spec 0 i); cbn; solve + [ trivial | destruct (proj1 (Z.le_ngt _ _) Hi ltac:(eassumption)) ]. +Qed. + End Z. Bind Scope Z_scope with Z.t Z. diff --git a/tools/TimeFileMaker.py b/tools/TimeFileMaker.py index 8564aeff64..854dd25b75 100644 --- a/tools/TimeFileMaker.py +++ b/tools/TimeFileMaker.py @@ -2,7 +2,8 @@ from __future__ import with_statement from __future__ import division from __future__ import unicode_literals from __future__ import print_function -import os, sys, re +import sys +import re from io import open # This script parses the output of `make TIMED=1` into a dictionary diff --git a/tools/coq_dune.ml b/tools/coq_dune.ml index 98368d76ca..fa8b771a74 100644 --- a/tools/coq_dune.ml +++ b/tools/coq_dune.ml @@ -127,6 +127,7 @@ module Options = struct let all_opts = [ { enabled = false; cmd = "-debug"; } ; { enabled = false; cmd = "-native_compiler"; } + ; { enabled = true; cmd = "-allow-sprop"; } ] let build_coq_flags () = diff --git a/toplevel/coqargs.ml b/toplevel/coqargs.ml index bbccae8edb..d682d3641f 100644 --- a/toplevel/coqargs.ml +++ b/toplevel/coqargs.ml @@ -60,6 +60,8 @@ type t = { indices_matter : bool; enable_VM : bool; native_compiler : native_compiler; + allow_sprop : bool; + cumulative_sprop : bool; stm_flags : Stm.AsyncOpts.stm_opt; debug : bool; @@ -110,6 +112,8 @@ let default = { indices_matter = false; enable_VM = true; native_compiler = default_native; + allow_sprop = false; + cumulative_sprop = false; stm_flags = Stm.AsyncOpts.default_opts; debug = false; @@ -477,6 +481,9 @@ let parse_args ~help ~init arglist : t * string list = |"-filteropts" -> { oval with filter_opts = true } |"-impredicative-set" -> { oval with impredicative_set = Declarations.ImpredicativeSet } + |"-allow-sprop" -> { oval with allow_sprop = true } + |"-disallow-sprop" -> { oval with allow_sprop = false } + |"-sprop-cumulative" -> { oval with cumulative_sprop = true } |"-indices-matter" -> { oval with indices_matter = true } |"-m"|"--memory" -> { oval with memory_stat = true } |"-noinit"|"-nois" -> { oval with load_init = false } diff --git a/toplevel/coqargs.mli b/toplevel/coqargs.mli index b89a88d1f6..97a62e97e4 100644 --- a/toplevel/coqargs.mli +++ b/toplevel/coqargs.mli @@ -35,6 +35,8 @@ type t = { indices_matter : bool; enable_VM : bool; native_compiler : native_compiler; + allow_sprop : bool; + cumulative_sprop : bool; stm_flags : Stm.AsyncOpts.stm_opt; debug : bool; diff --git a/toplevel/coqtop.ml b/toplevel/coqtop.ml index 92ac200bc0..626023737b 100644 --- a/toplevel/coqtop.ml +++ b/toplevel/coqtop.ml @@ -94,9 +94,12 @@ let init_color opts = | Some "" -> false (* No color output *) | Some s -> Topfmt.parse_color_config s; true (* Overwrite all colors *) end - else - false + else begin + Topfmt.default_styles (); false (* textual markers, no color *) + end in + if not term_color then + Proof_diffs.write_color_enabled term_color; if Proof_diffs.show_diffs () && not term_color then (prerr_endline "Error: -diffs requires enabling -color"; exit 1); Topfmt.init_terminal_output ~color:term_color @@ -189,6 +192,8 @@ let init_toplevel ~help ~init custom_init arglist = Global.set_indices_matter opts.indices_matter; Global.set_VM opts.enable_VM; Global.set_native_compiler (match opts.native_compiler with NativeOff -> false | NativeOn _ -> true); + Global.set_allow_sprop opts.allow_sprop; + if opts.cumulative_sprop then Global.make_sprop_cumulative (); (* Allow the user to load an arbitrary state here *) inputstate opts; diff --git a/toplevel/usage.ml b/toplevel/usage.ml index 94ec6bb70d..513374c2af 100644 --- a/toplevel/usage.ml +++ b/toplevel/usage.ml @@ -69,6 +69,8 @@ let print_usage_common co command = \n -noglob do not dump globalizations\ \n -dump-glob f dump globalizations in file f (to be used by coqdoc)\ \n -impredicative-set set sort Set impredicative\ +\n -allow-sprop allow using the proof irrelevant SProp sort\ +\n -sprop-cumulative make sort SProp cumulative with the rest of the hierarchy\ \n -indices-matter levels of indices (and nonuniform parameters) contribute to the level of inductives\ \n -type-in-type disable universe consistency checking\ \n -mangle-names x mangle auto-generated names using prefix x\ diff --git a/vernac/assumptions.ml b/vernac/assumptions.ml index b5cc74b594..445f10ecc1 100644 --- a/vernac/assumptions.ml +++ b/vernac/assumptions.ml @@ -21,6 +21,7 @@ open CErrors open Util open Names open Constr +open Context open Declarations open Mod_subst open Globnames @@ -238,8 +239,9 @@ and traverse_inductive (curr, data, ax2ty) mind obj = Array.fold_left (fun accu oib -> let pspecif = Univ.in_punivs (mib, oib) in let ind_type = Inductive.type_of_inductive global_env pspecif in + let indr = oib.mind_relevance in let ind_name = Name oib.mind_typename in - Context.Rel.add (Context.Rel.Declaration.LocalAssum (ind_name, ind_type)) accu) + Context.Rel.add (Context.Rel.Declaration.LocalAssum (make_annot ind_name indr, ind_type)) accu) Context.Rel.empty mib.mind_packets in (* For each inductive, collects references in their arity and in the type diff --git a/vernac/auto_ind_decl.ml b/vernac/auto_ind_decl.ml index 868a6ed3e9..528829f3a5 100644 --- a/vernac/auto_ind_decl.ml +++ b/vernac/auto_ind_decl.ml @@ -16,6 +16,7 @@ open Util open Pp open Term open Constr +open Context open Vars open Termops open Declarations @@ -144,7 +145,7 @@ let build_beq_scheme mode kn = in (* construct the "fun A B ... N, eqA eqB eqC ... N => fixpoint" part *) let create_input c = - let myArrow u v = mkArrow u (lift 1 v) + let myArrow u v = mkArrow u Sorts.Relevant (lift 1 v) and eqName = function | Name s -> Id.of_string ("eq_"^(Id.to_string s)) | Anonymous -> Id.of_string "eq_A" @@ -161,14 +162,16 @@ let build_beq_scheme mode kn = ( fun a b decl -> (* mkLambda(n,b,a) ) *) (* here I leave the Naming thingy so that the type of the function is more readable for the user *) - mkNamedLambda (eqName (RelDecl.get_name decl)) b a ) + mkNamedLambda (map_annot eqName (RelDecl.get_annot decl)) b a ) c (List.rev eqs_typ) lnamesparrec in List.fold_left (fun a decl ->(* mkLambda(n,t,a)) eq_input rel_list *) - (* Same here , hoping the auto renaming will do something good ;) *) - mkNamedLambda - (match RelDecl.get_name decl with Name s -> s | Anonymous -> Id.of_string "A") - (RelDecl.get_type decl) a) eq_input lnamesparrec + (* Same here , hoping the auto renaming will do something good ;) *) + let x = map_annot + (function Name s -> s | Anonymous -> Id.of_string "A") + (RelDecl.get_annot decl) + in + mkNamedLambda x (RelDecl.get_type decl) a) eq_input lnamesparrec in let make_one_eq cur = let u = Univ.Instance.empty in @@ -251,8 +254,8 @@ let build_beq_scheme mode kn = in (* construct the predicate for the Case part*) let do_predicate rel_list n = - List.fold_left (fun a b -> mkLambda(Anonymous,b,a)) - (mkLambda (Anonymous, + List.fold_left (fun a b -> mkLambda(make_annot Anonymous Sorts.Relevant,b,a)) + (mkLambda (make_annot Anonymous Sorts.Relevant, mkFullInd ind (n+3+(List.length rettyp_l)+nb_ind-1), (bb ()))) (List.rev rettyp_l) in @@ -260,7 +263,8 @@ let build_beq_scheme mode kn = (* do the [| C1 ... => match Y with ... end ... Cn => match Y with ... end |] part *) - let ci = make_case_info env (fst ind) MatchStyle in + let rci = Sorts.Relevant in (* TODO relevance *) + let ci = make_case_info env (fst ind) rci MatchStyle in let constrs n = get_constructors env (make_ind_family (ind, Context.Rel.to_extended_list mkRel (n+nb_ind-1) mib.mind_params_ctxt)) in let constrsi = constrs (3+nparrec) in @@ -296,32 +300,32 @@ let build_beq_scheme mode kn = (Array.sub eqs 1 (nb_cstr_args - 1)) ) in - (List.fold_left (fun a decl -> mkLambda (RelDecl.get_name decl, RelDecl.get_type decl, a)) cc + (List.fold_left (fun a decl -> mkLambda (RelDecl.get_annot decl, RelDecl.get_type decl, a)) cc (constrsj.(j).cs_args) ) else ar2.(j) <- (List.fold_left (fun a decl -> - mkLambda (RelDecl.get_name decl, RelDecl.get_type decl, a)) (ff ()) (constrsj.(j).cs_args) ) - done; + mkLambda (RelDecl.get_annot decl, RelDecl.get_type decl, a)) (ff ()) (constrsj.(j).cs_args) ) + done; - ar.(i) <- (List.fold_left (fun a decl -> mkLambda (RelDecl.get_name decl, RelDecl.get_type decl, a)) + ar.(i) <- (List.fold_left (fun a decl -> mkLambda (RelDecl.get_annot decl, RelDecl.get_type decl, a)) (mkCase (ci,do_predicate rel_list nb_cstr_args, mkVar (Id.of_string "Y") ,ar2)) (constrsi.(i).cs_args)) - done; - mkNamedLambda (Id.of_string "X") (mkFullInd ind (nb_ind-1+1)) ( - mkNamedLambda (Id.of_string "Y") (mkFullInd ind (nb_ind-1+2)) ( + done; + mkNamedLambda (make_annot (Id.of_string "X") Sorts.Relevant) (mkFullInd ind (nb_ind-1+1)) ( + mkNamedLambda (make_annot (Id.of_string "Y") Sorts.Relevant) (mkFullInd ind (nb_ind-1+2)) ( mkCase (ci, do_predicate rel_list 0,mkVar (Id.of_string "X"),ar))), !eff in (* build_beq_scheme *) - let names = Array.make nb_ind Anonymous and + let names = Array.make nb_ind (make_annot Anonymous Sorts.Relevant) and types = Array.make nb_ind mkSet and cores = Array.make nb_ind mkSet in let eff = ref Safe_typing.empty_private_constants in let u = Univ.Instance.empty in for i=0 to (nb_ind-1) do - names.(i) <- Name (Id.of_string (rec_name i)); - types.(i) <- mkArrow (mkFullInd ((kn,i),u) 0) - (mkArrow (mkFullInd ((kn,i),u) 1) (bb ())); + names.(i) <- make_annot (Name (Id.of_string (rec_name i))) Sorts.Relevant; + types.(i) <- mkArrow (mkFullInd ((kn,i),u) 0) Sorts.Relevant + (mkArrow (mkFullInd ((kn,i),u) 1) Sorts.Relevant (bb ())); let c, eff' = make_one_eq i in cores.(i) <- c; eff := Safe_typing.concat_private eff' !eff @@ -562,34 +566,39 @@ let compute_bl_goal ind lnamesparrec nparrec = let x = next_ident_away (Id.of_string "x") avoid and y = next_ident_away (Id.of_string "y") avoid in let bl_typ = List.map (fun (s,seq,_,_) -> - mkNamedProd x (mkVar s) ( - mkNamedProd y (mkVar s) ( + mkNamedProd (make_annot x Sorts.Relevant) (mkVar s) ( + mkNamedProd (make_annot y Sorts.Relevant) (mkVar s) ( mkArrow ( mkApp(eq (),[|bb (); mkApp(mkVar seq,[|mkVar x;mkVar y|]);tt () |])) + Sorts.Relevant ( mkApp(eq (),[|mkVar s;mkVar x;mkVar y|])) )) ) list_id in let bl_input = List.fold_left2 ( fun a (s,_,sbl,_) b -> - mkNamedProd sbl b a + mkNamedProd (make_annot sbl Sorts.Relevant) b a ) c (List.rev list_id) (List.rev bl_typ) in let eqs_typ = List.map (fun (s,_,_,_) -> - mkProd(Anonymous,mkVar s,mkProd(Anonymous,mkVar s,(bb ()))) + mkProd(make_annot Anonymous Sorts.Relevant,mkVar s,mkProd(make_annot Anonymous Sorts.Relevant,mkVar s,(bb ()))) ) list_id in let eq_input = List.fold_left2 ( fun a (s,seq,_,_) b -> - mkNamedProd seq b a + mkNamedProd (make_annot seq Sorts.Relevant) b a ) bl_input (List.rev list_id) (List.rev eqs_typ) in - List.fold_left (fun a decl -> mkNamedProd - (match RelDecl.get_name decl with Name s -> s | Anonymous -> next_ident_away (Id.of_string "A") avoid) - (RelDecl.get_type decl) a) eq_input lnamesparrec + List.fold_left (fun a decl -> + let x = map_annot + (function Name s -> s | Anonymous -> next_ident_away (Id.of_string "A") avoid) + (RelDecl.get_annot decl) + in + mkNamedProd x (RelDecl.get_type decl) a) eq_input lnamesparrec in let n = next_ident_away (Id.of_string "x") avoid and m = next_ident_away (Id.of_string "y") avoid in let u = Univ.Instance.empty in create_input ( - mkNamedProd n (mkFullInd (ind,u) nparrec) ( - mkNamedProd m (mkFullInd (ind,u) (nparrec+1)) ( + mkNamedProd (make_annot n Sorts.Relevant) (mkFullInd (ind,u) nparrec) ( + mkNamedProd (make_annot m Sorts.Relevant) (mkFullInd (ind,u) (nparrec+1)) ( mkArrow (mkApp(eq (),[|bb ();mkApp(eqI,[|mkVar n;mkVar m|]);tt ()|])) + Sorts.Relevant (mkApp(eq (),[|mkFullInd (ind,u) (nparrec+3);mkVar n;mkVar m|])) ))), eff @@ -706,34 +715,40 @@ let compute_lb_goal ind lnamesparrec nparrec = let x = next_ident_away (Id.of_string "x") avoid and y = next_ident_away (Id.of_string "y") avoid in let lb_typ = List.map (fun (s,seq,_,_) -> - mkNamedProd x (mkVar s) ( - mkNamedProd y (mkVar s) ( + mkNamedProd (make_annot x Sorts.Relevant) (mkVar s) ( + mkNamedProd (make_annot y Sorts.Relevant) (mkVar s) ( mkArrow - ( mkApp(eq,[|mkVar s;mkVar x;mkVar y|])) - ( mkApp(eq,[|bb;mkApp(mkVar seq,[|mkVar x;mkVar y|]);tt|])) + ( mkApp(eq,[|mkVar s;mkVar x;mkVar y|])) + Sorts.Relevant + ( mkApp(eq,[|bb;mkApp(mkVar seq,[|mkVar x;mkVar y|]);tt|])) )) ) list_id in let lb_input = List.fold_left2 ( fun a (s,_,_,slb) b -> - mkNamedProd slb b a + mkNamedProd (make_annot slb Sorts.Relevant) b a ) c (List.rev list_id) (List.rev lb_typ) in let eqs_typ = List.map (fun (s,_,_,_) -> - mkProd(Anonymous,mkVar s,mkProd(Anonymous,mkVar s,bb)) + mkProd(make_annot Anonymous Sorts.Relevant,mkVar s, + mkProd(make_annot Anonymous Sorts.Relevant,mkVar s,bb)) ) list_id in let eq_input = List.fold_left2 ( fun a (s,seq,_,_) b -> - mkNamedProd seq b a + mkNamedProd (make_annot seq Sorts.Relevant) b a ) lb_input (List.rev list_id) (List.rev eqs_typ) in - List.fold_left (fun a decl -> mkNamedProd - (match (RelDecl.get_name decl) with Name s -> s | Anonymous -> Id.of_string "A") - (RelDecl.get_type decl) a) eq_input lnamesparrec + List.fold_left (fun a decl -> + let x = map_annot + (function Name s -> s | Anonymous -> Id.of_string "A") + (RelDecl.get_annot decl) + in + mkNamedProd x (RelDecl.get_type decl) a) eq_input lnamesparrec in let n = next_ident_away (Id.of_string "x") avoid and m = next_ident_away (Id.of_string "y") avoid in let u = Univ.Instance.empty in create_input ( - mkNamedProd n (mkFullInd (ind,u) nparrec) ( - mkNamedProd m (mkFullInd (ind,u) (nparrec+1)) ( + mkNamedProd (make_annot n Sorts.Relevant) (mkFullInd (ind,u) nparrec) ( + mkNamedProd (make_annot m Sorts.Relevant) (mkFullInd (ind,u) (nparrec+1)) ( mkArrow (mkApp(eq,[|mkFullInd (ind,u) (nparrec+2);mkVar n;mkVar m|])) + Sorts.Relevant (mkApp(eq,[|bb;mkApp(eqI,[|mkVar n;mkVar m|]);tt|])) ))), eff @@ -835,45 +850,51 @@ let compute_dec_goal ind lnamesparrec nparrec = let x = next_ident_away (Id.of_string "x") avoid and y = next_ident_away (Id.of_string "y") avoid in let lb_typ = List.map (fun (s,seq,_,_) -> - mkNamedProd x (mkVar s) ( - mkNamedProd y (mkVar s) ( + mkNamedProd (make_annot x Sorts.Relevant) (mkVar s) ( + mkNamedProd (make_annot y Sorts.Relevant) (mkVar s) ( mkArrow - ( mkApp(eq,[|mkVar s;mkVar x;mkVar y|])) - ( mkApp(eq,[|bb;mkApp(mkVar seq,[|mkVar x;mkVar y|]);tt|])) + ( mkApp(eq,[|mkVar s;mkVar x;mkVar y|])) + Sorts.Relevant + ( mkApp(eq,[|bb;mkApp(mkVar seq,[|mkVar x;mkVar y|]);tt|])) )) ) list_id in let bl_typ = List.map (fun (s,seq,_,_) -> - mkNamedProd x (mkVar s) ( - mkNamedProd y (mkVar s) ( + mkNamedProd (make_annot x Sorts.Relevant) (mkVar s) ( + mkNamedProd (make_annot y Sorts.Relevant) (mkVar s) ( mkArrow - ( mkApp(eq,[|bb;mkApp(mkVar seq,[|mkVar x;mkVar y|]);tt|])) - ( mkApp(eq,[|mkVar s;mkVar x;mkVar y|])) + ( mkApp(eq,[|bb;mkApp(mkVar seq,[|mkVar x;mkVar y|]);tt|])) + Sorts.Relevant + ( mkApp(eq,[|mkVar s;mkVar x;mkVar y|])) )) ) list_id in let lb_input = List.fold_left2 ( fun a (s,_,_,slb) b -> - mkNamedProd slb b a + mkNamedProd (make_annot slb Sorts.Relevant) b a ) c (List.rev list_id) (List.rev lb_typ) in let bl_input = List.fold_left2 ( fun a (s,_,sbl,_) b -> - mkNamedProd sbl b a + mkNamedProd (make_annot sbl Sorts.Relevant) b a ) lb_input (List.rev list_id) (List.rev bl_typ) in let eqs_typ = List.map (fun (s,_,_,_) -> - mkProd(Anonymous,mkVar s,mkProd(Anonymous,mkVar s,bb)) + mkProd(make_annot Anonymous Sorts.Relevant,mkVar s, + mkProd(make_annot Anonymous Sorts.Relevant,mkVar s,bb)) ) list_id in let eq_input = List.fold_left2 ( fun a (s,seq,_,_) b -> - mkNamedProd seq b a + mkNamedProd (make_annot seq Sorts.Relevant) b a ) bl_input (List.rev list_id) (List.rev eqs_typ) in - List.fold_left (fun a decl -> mkNamedProd - (match RelDecl.get_name decl with Name s -> s | Anonymous -> Id.of_string "A") - (RelDecl.get_type decl) a) eq_input lnamesparrec + List.fold_left (fun a decl -> + let x = map_annot + (function Name s -> s | Anonymous -> Id.of_string "A") + (RelDecl.get_annot decl) + in + mkNamedProd x (RelDecl.get_type decl) a) eq_input lnamesparrec in let n = next_ident_away (Id.of_string "x") avoid and m = next_ident_away (Id.of_string "y") avoid in let eqnm = mkApp(eq,[|mkFullInd ind (2*nparrec+2);mkVar n;mkVar m|]) in create_input ( - mkNamedProd n (mkFullInd ind (2*nparrec)) ( - mkNamedProd m (mkFullInd ind (2*nparrec+1)) ( + mkNamedProd (make_annot n Sorts.Relevant) (mkFullInd ind (2*nparrec)) ( + mkNamedProd (make_annot m Sorts.Relevant) (mkFullInd ind (2*nparrec+1)) ( mkApp(sumbool(),[|eqnm;mkApp (UnivGen.constr_of_monomorphic_global @@ Coqlib.lib_ref "core.not.type",[|eqnm|])|]) ) ) diff --git a/vernac/class.ml b/vernac/class.ml index a6b3242cae..0837beccee 100644 --- a/vernac/class.ml +++ b/vernac/class.ml @@ -14,6 +14,7 @@ open Pp open Names open Term open Constr +open Context open Vars open Termops open Entries @@ -188,14 +189,14 @@ let build_id_coercion idf_opt source poly = let lams,t = decompose_lam_assum c in let val_f = it_mkLambda_or_LetIn - (mkLambda (Name Namegen.default_dependent_ident, + (mkLambda (make_annot (Name Namegen.default_dependent_ident) Sorts.Relevant, applistc vs (Context.Rel.to_extended_list mkRel 0 lams), mkRel 1)) lams in let typ_f = List.fold_left (fun d c -> Term.mkProd_wo_LetIn c d) - (mkProd (Anonymous, applistc vs (Context.Rel.to_extended_list mkRel 0 lams), lift 1 t)) + (mkProd (make_annot Anonymous Sorts.Relevant, applistc vs (Context.Rel.to_extended_list mkRel 0 lams), lift 1 t)) lams in (* juste pour verification *) diff --git a/vernac/classes.ml b/vernac/classes.ml index 4664df3182..1981e24ae4 100644 --- a/vernac/classes.ml +++ b/vernac/classes.ml @@ -352,8 +352,8 @@ let named_of_rel_context l = (fun decl (subst, ctx) -> let id = match RelDecl.get_name decl with Anonymous -> invalid_arg "named_of_rel_context" | Name id -> id in let d = match decl with - | LocalAssum (_,t) -> id, None, substl subst t - | LocalDef (_,b,t) -> id, Some (substl subst b), substl subst t in + | LocalAssum (_,t) -> id, None, substl subst t + | LocalDef (_,b,t) -> id, Some (substl subst b), substl subst t in (mkVar id :: subst, d :: ctx)) l ([], []) in ctx diff --git a/vernac/comAssumption.ml b/vernac/comAssumption.ml index 35d8be5c56..37a33daf8f 100644 --- a/vernac/comAssumption.ml +++ b/vernac/comAssumption.ml @@ -13,6 +13,7 @@ open Util open Vars open Declare open Names +open Context open Globnames open Constrexpr_ops open Constrintern @@ -148,8 +149,9 @@ let do_assumptions ~program_mode kind nl l = (* We intepret all declarations in the same evar_map, i.e. as a telescope. *) let (sigma,_,_),l = List.fold_left_map (fun (sigma,env,ienv) (is_coe,(idl,c)) -> let sigma,(t,imps) = interp_assumption ~program_mode sigma env ienv c in + let r = Retyping.relevance_of_type env sigma t in let env = - EConstr.push_named_context (List.map (fun {CAst.v=id} -> LocalAssum (id,t)) idl) env in + EConstr.push_named_context (List.map (fun {CAst.v=id} -> LocalAssum (make_annot id r,t)) idl) env in let ienv = List.fold_right (fun {CAst.v=id} ienv -> let impls = compute_internalization_data env sigma Variable t imps in Id.Map.add id impls ienv) idl ienv in diff --git a/vernac/comFixpoint.ml b/vernac/comFixpoint.ml index 5229d9e8e8..2f00b41b7c 100644 --- a/vernac/comFixpoint.ml +++ b/vernac/comFixpoint.ml @@ -12,6 +12,7 @@ open Pp open CErrors open Util open Constr +open Context open Vars open Termops open Declare @@ -126,7 +127,9 @@ let interp_fix_context ~program_mode ~cofix env sigma fix = sigma, ((env'', ctx' @ ctx), (impl_env',imps @ imps'), annot) let interp_fix_ccl ~program_mode sigma impls (env,_) fix = - interp_type_evars_impls ~program_mode ~impls env sigma fix.fix_type + let sigma, (c, impl) = interp_type_evars_impls ~program_mode ~impls env sigma fix.fix_type in + let r = Retyping.relevance_of_type env sigma c in + sigma, (c, r, impl) let interp_fix_body ~program_mode env_rec sigma impls (_,ctx) fix ccl = let open EConstr in @@ -137,9 +140,9 @@ let interp_fix_body ~program_mode env_rec sigma impls (_,ctx) fix ccl = let build_fix_type (_,ctx) ccl = EConstr.it_mkProd_or_LetIn ccl ctx -let prepare_recursive_declaration fixnames fixtypes fixdefs = +let prepare_recursive_declaration fixnames fixrs fixtypes fixdefs = let defs = List.map (subst_vars (List.rev fixnames)) fixdefs in - let names = List.map (fun id -> Name id) fixnames in + let names = List.map2 (fun id r -> make_annot (Name id) r) fixnames fixrs in (Array.of_list names, Array.of_list fixtypes, Array.of_list defs) (* Jump over let-bindings. *) @@ -158,7 +161,7 @@ let compute_possible_guardness_evidences (ctx,_,recindex) = List.interval 0 (Context.Rel.nhyps ctx - 1) type recursive_preentry = - Id.t list * constr option list * types list + Id.t list * Sorts.relevance list * constr option list * types list (* Wellfounded definition *) @@ -188,8 +191,8 @@ let interp_recursive ~program_mode ~cofix fixl notations = on_snd List.split3 @@ List.fold_left_map (fun sigma -> interp_fix_context ~program_mode env sigma ~cofix) sigma fixl in let fixctximpenvs, fixctximps = List.split fiximppairs in - let sigma, (fixccls,fixcclimps) = - on_snd List.split @@ + let sigma, (fixccls,fixrs,fixcclimps) = + on_snd List.split3 @@ List.fold_left3_map (interp_fix_ccl ~program_mode) sigma fixctximpenvs fixctxs fixl in let fixtypes = List.map2 build_fix_type fixctxs fixccls in let fixtypes = List.map (fun c -> nf_evar sigma c) fixtypes in @@ -208,8 +211,8 @@ let interp_recursive ~program_mode ~cofix fixl notations = Typing.solve_evars env sigma app with e when CErrors.noncritical e -> sigma, t in - sigma, LocalAssum (id,fixprot) :: env' - else sigma, LocalAssum (id,t) :: env') + sigma, LocalAssum (make_annot id Sorts.Relevant,fixprot) :: env' + else sigma, LocalAssum (make_annot id Sorts.Relevant,t) :: env') (sigma,[]) fixnames fixtypes in let env_rec = push_named_context rec_sign env in @@ -232,19 +235,19 @@ let interp_recursive ~program_mode ~cofix fixl notations = let fixctxs = List.map (fun (_,ctx) -> ctx) fixctxs in (* Build the fix declaration block *) - (env,rec_sign,decl,sigma), (fixnames,fixdefs,fixtypes), List.combine3 fixctxs fiximps fixannots + (env,rec_sign,decl,sigma), (fixnames,fixrs,fixdefs,fixtypes), List.combine3 fixctxs fiximps fixannots -let check_recursive isfix env evd (fixnames,fixdefs,_) = +let check_recursive isfix env evd (fixnames,_,fixdefs,_) = if List.for_all Option.has_some fixdefs then begin let fixdefs = List.map Option.get fixdefs in check_mutuality env evd isfix (List.combine fixnames fixdefs) end -let ground_fixpoint env evd (fixnames,fixdefs,fixtypes) = +let ground_fixpoint env evd (fixnames,fixrs,fixdefs,fixtypes) = check_evars_are_solved ~program_mode:false env evd; let fixdefs = List.map (fun c -> Option.map EConstr.(to_constr evd) c) fixdefs in let fixtypes = List.map EConstr.(to_constr evd) fixtypes in - Evd.evar_universe_context evd, (fixnames,fixdefs,fixtypes) + Evd.evar_universe_context evd, (fixnames,fixrs,fixdefs,fixtypes) let interp_fixpoint ~cofix l ntns = let (env,_,pl,evd),fix,info = interp_recursive ~program_mode:false ~cofix l ntns in @@ -252,7 +255,7 @@ let interp_fixpoint ~cofix l ntns = let uctx,fix = ground_fixpoint env evd fix in (fix,pl,uctx,info) -let declare_fixpoint local poly ((fixnames,fixdefs,fixtypes),pl,ctx,fiximps) indexes ntns = +let declare_fixpoint local poly ((fixnames,fixrs,fixdefs,fixtypes),pl,ctx,fiximps) indexes ntns = if List.exists Option.is_empty fixdefs then (* Some bodies to define by proof *) let thms = @@ -267,7 +270,7 @@ let declare_fixpoint local poly ((fixnames,fixdefs,fixtypes),pl,ctx,fiximps) ind else begin (* We shortcut the proof process *) let fixdefs = List.map Option.get fixdefs in - let fixdecls = prepare_recursive_declaration fixnames fixtypes fixdefs in + let fixdecls = prepare_recursive_declaration fixnames fixrs fixtypes fixdefs in let env = Global.env() in let indexes = search_guard env indexes fixdecls in let fiximps = List.map (fun (n,r,p) -> r) fiximps in @@ -287,7 +290,7 @@ let declare_fixpoint local poly ((fixnames,fixdefs,fixtypes),pl,ctx,fiximps) ind (* Declare notations *) List.iter (Metasyntax.add_notation_interpretation (Global.env())) ntns -let declare_cofixpoint local poly ((fixnames,fixdefs,fixtypes),pl,ctx,fiximps) ntns = +let declare_cofixpoint local poly ((fixnames,fixrs,fixdefs,fixtypes),pl,ctx,fiximps) ntns = if List.exists Option.is_empty fixdefs then (* Some bodies to define by proof *) let thms = @@ -302,7 +305,7 @@ let declare_cofixpoint local poly ((fixnames,fixdefs,fixtypes),pl,ctx,fiximps) n else begin (* We shortcut the proof process *) let fixdefs = List.map Option.get fixdefs in - let fixdecls = prepare_recursive_declaration fixnames fixtypes fixdefs in + let fixdecls = prepare_recursive_declaration fixnames fixrs fixtypes fixdefs in let fixdecls = List.map_i (fun i _ -> mkCoFix (i,fixdecls)) 0 fixnames in let vars = Vars.universes_of_constr (List.hd fixdecls) in let fixdecls = List.map Safe_typing.mk_pure_proof fixdecls in diff --git a/vernac/comFixpoint.mli b/vernac/comFixpoint.mli index 338dfa5ef5..9bcb53697b 100644 --- a/vernac/comFixpoint.mli +++ b/vernac/comFixpoint.mli @@ -51,7 +51,7 @@ val interp_recursive : (* env / signature / univs / evar_map *) (Environ.env * EConstr.named_context * UState.universe_decl * Evd.evar_map) * (* names / defs / types *) - (Id.t list * EConstr.constr option list * EConstr.types list) * + (Id.t list * Sorts.relevance list * EConstr.constr option list * EConstr.types list) * (* ctx per mutual def / implicits / struct annotations *) (EConstr.rel_context * Impargs.manual_explicitation list * int option) list @@ -69,7 +69,7 @@ val extract_cofixpoint_components : structured_fixpoint_expr list * decl_notation list type recursive_preentry = - Id.t list * constr option list * types list + Id.t list * Sorts.relevance list * constr option list * types list val interp_fixpoint : cofix:bool -> diff --git a/vernac/comInductive.ml b/vernac/comInductive.ml index 7fa99b25cb..977e804da2 100644 --- a/vernac/comInductive.ml +++ b/vernac/comInductive.ml @@ -13,6 +13,7 @@ open CErrors open Sorts open Util open Constr +open Context open Environ open Declare open Names @@ -70,9 +71,9 @@ let rec complete_conclusion a cs = CAst.map_with_loc (fun ?loc -> function | c -> c ) -let push_types env idl tl = - List.fold_left2 (fun env id t -> EConstr.push_rel (LocalAssum (Name id,t)) env) - env idl tl +let push_types env idl rl tl = + List.fold_left3 (fun env id r t -> EConstr.push_rel (LocalAssum (make_annot (Name id) r,t)) env) + env idl rl tl type structured_one_inductive_expr = { ind_name : Id.t; @@ -139,9 +140,6 @@ let make_conclusion_flexible sigma = function | None -> sigma) | _ -> sigma) -let is_impredicative env u = - u = Prop || (is_impredicative_set env && u = Set) - let interp_ind_arity env sigma ind = let c = intern_gen IsType env sigma ind.ind_arity in let impls = Implicit_quantifiers.implicits_of_glob_constr ~with_products:true c in @@ -152,7 +150,7 @@ let interp_ind_arity env sigma ind = user_err ?loc:(constr_loc ind.ind_arity) (str "Not an arity") | s -> let concl = if pseudo_poly then Some s else None in - sigma, (t, concl, impls) + sigma, (t, Retyping.relevance_of_sort s, concl, impls) let interp_cstrs env sigma impls mldata arity ind = let cnames,ctyps = List.split ind.ind_lc in @@ -176,14 +174,14 @@ let sign_level env evd sign = in let u = univ_of_sort s in (Univ.sup u lev, push_rel d env)) - sign (Univ.type0m_univ,env)) + sign (Univ.Universe.sprop,env)) let sup_list min = List.fold_left Univ.sup min let extract_level env evd min tys = let sorts = List.map (fun ty -> let ctx, concl = Reduction.dest_prod_assum env ty in - sign_level env evd (LocalAssum (Anonymous, concl) :: ctx)) tys + sign_level env evd (LocalAssum (make_annot Anonymous Sorts.Relevant, concl) :: ctx)) tys in sup_list min sorts let is_flexible_sort evd u = @@ -260,7 +258,7 @@ let solve_constraints_system levels level_bounds = let inductive_levels env evd poly arities inds = let destarities = List.map (fun x -> x, Reduction.dest_arity env x) arities in let levels = List.map (fun (x,(ctx,a)) -> - if a = Prop then None + if Sorts.is_prop a || Sorts.is_sprop a then None else Some (univ_of_sort a)) destarities in let cstrs_levels, min_levels, sizes = @@ -269,7 +267,7 @@ let inductive_levels env evd poly arities inds = let len = List.length tys in let minlev = Sorts.univ_of_sort du in let minlev = - if len > 1 && not (is_impredicative env du) then + if len > 1 && not (is_impredicative_sort env du) then Univ.sup minlev Univ.type0_univ else minlev in @@ -290,7 +288,7 @@ let inductive_levels env evd poly arities inds = in let evd, arities = CList.fold_left3 (fun (evd, arities) cu (arity,(ctx,du)) len -> - if is_impredicative env du then + if is_impredicative_sort env du then (* Any product is allowed here. *) evd, arity :: arities else (* If in a predicative sort, or asked to infer the type, @@ -313,16 +311,16 @@ let inductive_levels env evd poly arities inds = (* "Polymorphic" type constraint and more than one constructor, should not land in Prop. Add constraint only if it would land in Prop directly (no informative arguments as well). *) - Evd.set_leq_sort env evd Set du + Evd.set_leq_sort env evd Sorts.set du else evd in let duu = Sorts.univ_of_sort du in let evd = if not (Univ.is_small_univ duu) && Univ.Universe.equal cu duu then if is_flexible_sort evd duu && not (Evd.check_leq evd Univ.type0_univ duu) then - Evd.set_eq_sort env evd Prop du + Evd.set_eq_sort env evd Sorts.prop du else evd - else Evd.set_eq_sort env evd (Type cu) du + else Evd.set_eq_sort env evd (sort_of_univ cu) du in (evd, arity :: arities)) (evd,[]) (Array.to_list levels') destarities sizes @@ -370,15 +368,15 @@ let interp_mutual_inductive_gen env0 ~template udecl (uparamsl,paramsl,indl) not (* Interpret the arities *) let sigma, arities = List.fold_left_map (fun sigma -> interp_ind_arity env_params sigma) sigma indl in + let arities, relevances, arityconcl, indimpls = List.split4 arities in - let fullarities = List.map (fun (c, _, _) -> EConstr.it_mkProd_or_LetIn c ctx_params) arities in - let env_ar = push_types env_uparams indnames fullarities in + let fullarities = List.map (fun c -> EConstr.it_mkProd_or_LetIn c ctx_params) arities in + let env_ar = push_types env_uparams indnames relevances fullarities in let env_ar_params = EConstr.push_rel_context ctx_params env_ar in (* Compute interpretation metadatas *) - let indimpls = List.map (fun (_, _, impls) -> userimpls @ - lift_implicits (Context.Rel.nhyps ctx_params) impls) arities in - let arities = List.map pi1 arities and arityconcl = List.map pi2 arities in + let indimpls = List.map (fun impls -> userimpls @ + lift_implicits (Context.Rel.nhyps ctx_params) impls) indimpls in let impls = compute_internalization_env env_uparams sigma ~impls (Inductive (params,true)) indnames fullarities indimpls in let ntn_impls = compute_internalization_env env_uparams sigma (Inductive (params,true)) indnames fullarities indimpls in let mldatas = List.map2 (mk_mltype_data sigma env_params params) arities indnames in @@ -407,7 +405,7 @@ let interp_mutual_inductive_gen env0 ~template udecl (uparamsl,paramsl,indl) not let userimpls = useruimpls @ (lift_implicits (Context.Rel.nhyps ctx_uparams) userimpls) in let indimpls = List.map (fun iimpl -> useruimpls @ (lift_implicits (Context.Rel.nhyps ctx_uparams) iimpl)) indimpls in let fullarities = List.map (fun c -> EConstr.it_mkProd_or_LetIn c ctx_uparams) fullarities in - let env_ar = push_types env0 indnames fullarities in + let env_ar = push_types env0 indnames relevances fullarities in let env_ar_params = EConstr.push_rel_context ctx_params env_ar in (* Try further to solve evars, and instantiate them *) diff --git a/vernac/comProgramFixpoint.ml b/vernac/comProgramFixpoint.ml index ae77cf12e5..ad7c65b70c 100644 --- a/vernac/comProgramFixpoint.ml +++ b/vernac/comProgramFixpoint.ml @@ -12,6 +12,7 @@ open Pp open CErrors open Util open Constr +open Context open Entries open Vars open Declare @@ -41,7 +42,7 @@ let well_founded sigma = init_constant sigma (lib_ref "core.wf.well_founded") let mkSubset sigma name typ prop = let open EConstr in let sigma, app_h = Evarutil.new_global sigma (delayed_force build_sigma).typ in - sigma, mkApp (app_h, [| typ; mkLambda (name, typ, prop) |]) + sigma, mkApp (app_h, [| typ; mkLambda (make_annot name Sorts.Relevant, typ, prop) |]) let make_qref s = qualid_of_string s let lt_ref = make_qref "Init.Peano.lt" @@ -58,7 +59,7 @@ let rec telescope sigma l = List.fold_left (fun (sigma, ty, tys, (k, constr)) decl -> let t = RelDecl.get_type decl in - let pred = mkLambda (RelDecl.get_name decl, t, ty) in + let pred = mkLambda (RelDecl.get_annot decl, t, ty) in let sigma, ty = Evarutil.new_global sigma (lib_ref "core.sigT.type") in let sigma, intro = Evarutil.new_global sigma (lib_ref "core.sigT.intro") in let sigty = mkApp (ty, [|t; pred|]) in @@ -73,7 +74,7 @@ let rec telescope sigma l = let sigma, p2 = Evarutil.new_global sigma (lib_ref "core.sigT.proj2") in let proj1 = applist (p1, [t; pred; prev]) in let proj2 = applist (p2, [t; pred; prev]) in - (sigma, lift 1 proj2, LocalDef (get_name decl, proj1, t) :: subst)) + (sigma, lift 1 proj2, LocalDef (get_annot decl, proj1, t) :: subst)) (List.rev tys) tl (sigma, mkRel 1, []) in sigma, ty, (LocalDef (n, last, t) :: subst), constr @@ -98,7 +99,7 @@ let build_wellfounded (recname,pl,n,bl,arityc,body) poly r measure notation = let full_arity = it_mkProd_or_LetIn top_arity binders_rel in let sigma, argtyp, letbinders, make = telescope sigma binders_rel in let argname = Id.of_string "recarg" in - let arg = LocalAssum (Name argname, argtyp) in + let arg = LocalAssum (make_annot (Name argname) Sorts.Relevant, argtyp) in let binders = letbinders @ [arg] in let binders_env = push_rel_context binders_rel env in let sigma, (rel, _) = interp_constr_evars_impls ~program_mode:true env sigma r in @@ -135,7 +136,7 @@ let build_wellfounded (recname,pl,n,bl,arityc,body) poly r measure notation = let argid' = Id.of_string (Id.to_string argname ^ "'") in let wfarg sigma len = let sigma, ss_term = mkSubset sigma (Name argid') argtyp (wf_rel_fun (mkRel 1) (mkRel (len + 1))) in - sigma, LocalAssum (Name argid', ss_term) + sigma, LocalAssum (make_annot (Name argid') Sorts.Relevant, ss_term) in let sigma, intern_bl = let sigma, wfa = wfarg sigma 1 in @@ -143,7 +144,7 @@ let build_wellfounded (recname,pl,n,bl,arityc,body) poly r measure notation = in let _intern_env = push_rel_context intern_bl env in let sigma, proj = Evarutil.new_global sigma (delayed_force build_sigma).Coqlib.proj1 in - let wfargpred = mkLambda (Name argid', argtyp, wf_rel_fun (mkRel 1) (mkRel 3)) in + let wfargpred = mkLambda (make_annot (Name argid') Sorts.Relevant, argtyp, wf_rel_fun (mkRel 1) (mkRel 3)) in let projection = (* in wfarg :: arg :: before *) mkApp (proj, [| argtyp ; wfargpred ; mkRel 1 |]) in @@ -153,22 +154,23 @@ let build_wellfounded (recname,pl,n,bl,arityc,body) poly r measure notation = now intern_arity is in wfarg :: arg *) let sigma, wfa = wfarg sigma 1 in let intern_fun_arity_prod = it_mkProd_or_LetIn intern_arity [wfa] in - let intern_fun_binder = LocalAssum (Name (add_suffix recname "'"), intern_fun_arity_prod) in + let intern_fun_binder = LocalAssum (make_annot (Name (add_suffix recname "'")) Sorts.Relevant, + intern_fun_arity_prod) in let sigma, curry_fun = - let wfpred = mkLambda (Name argid', argtyp, wf_rel_fun (mkRel 1) (mkRel (2 * len + 4))) in + let wfpred = mkLambda (make_annot (Name argid') Sorts.Relevant, argtyp, wf_rel_fun (mkRel 1) (mkRel (2 * len + 4))) in let sigma, intro = Evarutil.new_global sigma (delayed_force build_sigma).Coqlib.intro in let arg = mkApp (intro, [| argtyp; wfpred; lift 1 make; mkRel 1 |]) in let app = mkApp (mkRel (2 * len + 2 (* recproof + orig binders + current binders *)), [| arg |]) in let rcurry = mkApp (rel, [| measure; lift len measure |]) in - let lam = LocalAssum (Name (Id.of_string "recproof"), rcurry) in + let lam = LocalAssum (make_annot (Name (Id.of_string "recproof")) Sorts.Relevant, rcurry) in let body = it_mkLambda_or_LetIn app (lam :: binders_rel) in let ty = it_mkProd_or_LetIn (lift 1 top_arity) (lam :: binders_rel) in - sigma, LocalDef (Name recname, body, ty) + sigma, LocalDef (make_annot (Name recname) Sorts.Relevant, body, ty) in let fun_bl = intern_fun_binder :: [arg] in let lift_lets = lift_rel_context 1 letbinders in let sigma, intern_body = - let ctx = LocalAssum (Name recname, get_type curry_fun) :: binders_rel in + let ctx = LocalAssum (make_annot (Name recname) Sorts.Relevant, get_type curry_fun) :: binders_rel in let (r, l, impls, scopes) = Constrintern.compute_internalization_data env sigma Constrintern.Recursive full_arity impls @@ -180,7 +182,7 @@ let build_wellfounded (recname,pl,n,bl,arityc,body) poly r measure notation = ~impls:newimpls body (lift 1 top_arity) in let intern_body_lam = it_mkLambda_or_LetIn intern_body (curry_fun :: lift_lets @ fun_bl) in - let prop = mkLambda (Name argname, argtyp, top_arity_let) in + let prop = mkLambda (make_annot (Name argname) Sorts.Relevant, argtyp, top_arity_let) in (* XXX: Previous code did parallel evdref update, so possible old weak ordering semantics may bite here. *) let sigma, def = @@ -272,7 +274,7 @@ let do_program_recursive local poly fixkind fixl ntns = (List.length rec_sign) def typ in (id, def, typ, imps, evars) in - let (fixnames,fixdefs,fixtypes) = fix in + let (fixnames,fixrs,fixdefs,fixtypes) = fix in let fiximps = List.map pi2 info in let fixdefs = List.map out_def fixdefs in let defs = List.map4 collect_evars fixnames fixdefs fixtypes fiximps in @@ -281,7 +283,7 @@ let do_program_recursive local poly fixkind fixl ntns = (* XXX: are we allowed to have evars here? *) let fixtypes = List.map (EConstr.to_constr ~abort_on_undefined_evars:false evd) fixtypes in let fixdefs = List.map (EConstr.to_constr ~abort_on_undefined_evars:false evd) fixdefs in - let fixdecls = Array.of_list (List.map (fun x -> Name x) fixnames), + let fixdecls = Array.of_list (List.map2 (fun x r -> make_annot (Name x) r) fixnames fixrs), Array.of_list fixtypes, Array.of_list (List.map (subst_vars (List.rev fixnames)) fixdefs) in diff --git a/vernac/himsg.ml b/vernac/himsg.ml index 2ef2317d86..32754478a5 100644 --- a/vernac/himsg.ml +++ b/vernac/himsg.ml @@ -14,6 +14,7 @@ open Names open Nameops open Namegen open Constr +open Context open Termops open Environ open Pretype_errors @@ -103,9 +104,9 @@ let canonize_constr sigma c = let dn = Name.Anonymous in let rec canonize_binders c = 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) + | Prod (x,t,b) -> mkProd({x with binder_name=dn},t,b) + | Lambda (x,t,b) -> mkLambda({x with binder_name=dn},t,b) + | LetIn (x,u,t,b) -> mkLetIn({x with binder_name=dn},u,t,b) | _ -> EConstr.map sigma canonize_binders c in canonize_binders c @@ -125,7 +126,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_leconstr_env env sigma t1), quote (Printer.pr_leconstr_env env sigma t2)) + Printer.pr_leconstr_env env sigma t1, Printer.pr_leconstr_env env sigma t2 | flags :: rem -> let equal = display_eq ~flags env sigma t1 t2 in if equal then @@ -137,7 +138,7 @@ let rec pr_explicit_aux env sigma t1 t2 = function in let ct2 = Flags.with_options flags (fun () -> extern_constr false env sigma t2) () in - quote (Ppconstr.pr_lconstr_expr ct1), quote (Ppconstr.pr_lconstr_expr ct2) + Ppconstr.pr_lconstr_expr env sigma ct1, Ppconstr.pr_lconstr_expr env sigma ct2 let explicit_flags = let open Constrextern in @@ -148,8 +149,25 @@ let explicit_flags = [print_implicits; print_coercions; print_no_symbol]; (* Then more! *) [print_universes; print_implicits; print_coercions; print_no_symbol] (* and more! *) ] +let with_diffs pm pn = + try + let tokenize_string = Proof_diffs.tokenize_string in + Pp_diff.diff_pp ~tokenize_string pm pn + with Pp_diff.Diff_Failure msg -> + begin + try ignore(Sys.getenv("HIDEDIFFFAILUREMSG")) + with Not_found -> + Feedback.msg_warning Pp.( + hov 0 (str ("Diff failure: " ^ msg) ++ spc () ++ + hov 0 (str "Showing message without diff highlighting" ++ spc () ++ + hov 0 (str "Please report at " ++ str Coq_config.wwwbugtracker ++ str ".")))) + end; + pm, pn + let pr_explicit env sigma t1 t2 = - pr_explicit_aux env sigma t1 t2 explicit_flags + let p1, p2 = pr_explicit_aux env sigma t1 t2 explicit_flags in + let p1, p2 = with_diffs p1 p2 in + quote p1, quote p2 let pr_db env i = try @@ -193,13 +211,13 @@ let rec pr_disjunction pr = function | a::l -> pr a ++ str "," ++ spc () ++ pr_disjunction pr l | [] -> assert false -let explain_elim_arity env sigma ind sorts c pj okinds = +let explain_elim_arity env sigma ind c pj okinds = let open EConstr in let env = make_all_name_different env sigma in let pi = pr_inductive env (fst ind) in let pc = pr_leconstr_env env sigma c in let msg = match okinds with - | Some(kp,ki,explanation) -> + | Some(sorts,kp,ki,explanation) -> let pki = Sorts.pr_sort_family ki in let pkp = Sorts.pr_sort_family kp in let explanation = match explanation with @@ -262,7 +280,7 @@ let explain_ill_formed_branch env sigma c ci actty expty = let explain_generalization env sigma (name,var) j = let pe = pr_ne_context_of (str "In environment") env sigma in let pv = pr_letype_env env sigma var in - let (pc,pt) = pr_ljudge_env (push_rel_assum (name,var) env) sigma j in + let (pc,pt) = pr_ljudge_env (push_rel_assum (make_annot name Sorts.Relevant,var) env) sigma j in pe ++ str "Cannot generalize" ++ brk(1,1) ++ pv ++ spc () ++ str "over" ++ brk(1,1) ++ pc ++ str "," ++ spc () ++ str "it has type" ++ spc () ++ pt ++ @@ -307,7 +325,7 @@ let explain_unification_error env sigma p1 p2 = function | UnifUnivInconsistency p -> if !Constrextern.print_universes then [str "universe inconsistency: " ++ - Univ.explain_universe_inconsistency UnivNames.pr_with_global_universes p] + Univ.explain_universe_inconsistency (Termops.pr_evd_level sigma) p] else [str "universe inconsistency"] | CannotSolveConstraint ((pb,env,t,u),e) -> @@ -414,7 +432,7 @@ let explain_not_product env sigma c = let explain_ill_formed_rec_body env sigma err names i fixenv vdefj = let pr_lconstr_env env sigma c = pr_leconstr_env env sigma c in let prt_name i = - match names.(i) with + match names.(i).binder_name with Name id -> str "Recursive definition of " ++ Id.print id | Anonymous -> str "The " ++ pr_nth i ++ str " definition" in @@ -429,7 +447,7 @@ let explain_ill_formed_rec_body env sigma err names i fixenv vdefj = | RecursionOnIllegalTerm(j,(arg_env, arg),le,lt) -> let arg_env = make_all_name_different arg_env sigma in let called = - match names.(j) with + match names.(j).binder_name with Name id -> Id.print id | Anonymous -> str "the " ++ pr_nth i ++ str " definition" in let pr_db x = quote (pr_db env x) in @@ -449,7 +467,7 @@ let explain_ill_formed_rec_body env sigma err names i fixenv vdefj = | NotEnoughArgumentsForFixCall j -> let called = - match names.(j) with + match names.(j).binder_name with Name id -> Id.print id | Anonymous -> str "the " ++ pr_nth i ++ str " definition" in str "Recursive call to " ++ called ++ str " has not enough arguments" @@ -488,6 +506,8 @@ let explain_ill_formed_rec_body env sigma err names i fixenv vdefj = str "The return clause of the following pattern matching should be" ++ strbrk " a coinductive type:" ++ spc () ++ pr_lconstr_env env sigma c + | FixpointOnIrrelevantInductive -> + strbrk "Fixpoints on proof irrelevant inductive types should produce proof irrelevant values" in prt_name i ++ str " is ill-formed." ++ fnl () ++ pr_ne_context_of (str "In environment") env sigma ++ @@ -710,6 +730,12 @@ let explain_undeclared_universe env sigma l = Termops.pr_evd_level sigma l ++ spc () ++ str "(maybe a bugged tactic)." +let explain_disallowed_sprop () = + Pp.(str "SProp not allowed, you need to use -allow-sprop.") + +let explain_bad_relevance env = + strbrk "Bad relevance (maybe a bugged tactic)." + let explain_type_error env sigma err = let env = make_all_name_different env sigma in match err with @@ -723,8 +749,8 @@ let explain_type_error env sigma err = explain_bad_assumption env sigma c | ReferenceVariables (id,c) -> explain_reference_variables sigma id c - | ElimArity (ind, aritylst, c, pj, okinds) -> - explain_elim_arity env sigma ind aritylst c pj okinds + | ElimArity (ind, c, pj, okinds) -> + explain_elim_arity env sigma ind c pj okinds | CaseNotInductive cj -> explain_case_not_inductive env sigma cj | NumberBranches (cj, n) -> @@ -751,6 +777,8 @@ let explain_type_error env sigma err = explain_unsatisfied_constraints env sigma cst | UndeclaredUniverse l -> explain_undeclared_universe env sigma l + | DisallowedSProp -> explain_disallowed_sprop () + | BadRelevance -> explain_bad_relevance env let pr_position (cl,pos) = let clpos = match cl with @@ -864,6 +892,7 @@ let explain_pretype_error env sigma err = | TypingError t -> explain_type_error env sigma t | CannotUnifyOccurrences (b,c1,c2,e) -> explain_cannot_unify_occurrences env sigma b c1 c2 e | UnsatisfiableConstraints (c,comp) -> explain_unsatisfiable_constraints env sigma c comp + | DisallowedSProp -> explain_disallowed_sprop () (* Module errors *) @@ -1062,16 +1091,18 @@ let explain_unbound_method env sigma cid { CAst.v = id } = str "Unbound method name " ++ Id.print (id) ++ spc () ++ str"of class" ++ spc () ++ pr_global cid ++ str "." -let pr_constr_exprs exprs = +let pr_constr_exprs env sigma exprs = hv 0 (List.fold_right - (fun d pps -> ws 2 ++ Ppconstr.pr_constr_expr d ++ pps) + (fun d pps -> ws 2 ++ Ppconstr.pr_constr_expr env sigma d ++ pps) exprs (mt ())) let explain_mismatched_contexts env c i j = + let sigma = Evd.from_env env in + let pm, pn = with_diffs (pr_rel_context env sigma j) (pr_constr_exprs env sigma i) in str"Mismatched contexts while declaring instance: " ++ brk (1,1) ++ - hov 1 (str"Expected:" ++ brk (1, 1) ++ pr_rel_context env (Evd.from_env env) j) ++ + hov 1 (str"Expected:" ++ brk (1, 1) ++ pm) ++ fnl () ++ brk (1,1) ++ - hov 1 (str"Found:" ++ brk (1, 1) ++ pr_constr_exprs i) + hov 1 (str"Found:" ++ brk (1, 1) ++ pn) let explain_typeclass_error env sigma = function | NotAClass c -> explain_not_a_class env sigma c @@ -1080,10 +1111,11 @@ let explain_typeclass_error env sigma = function (* Refiner errors *) let explain_refiner_bad_type env sigma arg ty conclty = + let pm, pn = with_diffs (pr_lconstr_env env sigma ty) (pr_lconstr_env env sigma conclty) in str "Refiner was given an argument" ++ brk(1,1) ++ pr_lconstr_env env sigma arg ++ spc () ++ - str "of type" ++ brk(1,1) ++ pr_lconstr_env env sigma ty ++ spc () ++ - str "instead of" ++ brk(1,1) ++ pr_lconstr_env env sigma conclty ++ str "." + str "of type" ++ brk(1,1) ++ pm ++ spc () ++ + str "instead of" ++ brk(1,1) ++ pn ++ str "." let explain_refiner_unresolved_bindings l = str "Unable to find an instance for the " ++ @@ -1195,7 +1227,7 @@ let error_large_non_prop_inductive_not_in_type () = str "Large non-propositional inductive types must be in Type." let error_inductive_bad_univs () = - str "Incorrect universe constrains declared for inductive type." + str "Incorrect universe constraints declared for inductive type." (* Recursion schemes errors *) diff --git a/vernac/indschemes.ml b/vernac/indschemes.ml index caafd6ac2f..1e733acc59 100644 --- a/vernac/indschemes.ml +++ b/vernac/indschemes.ml @@ -228,17 +228,20 @@ let declare_one_case_analysis_scheme ind = let kinds_from_prop = [InType,rect_scheme_kind_from_prop; InProp,ind_scheme_kind_from_prop; - InSet,rec_scheme_kind_from_prop] + InSet,rec_scheme_kind_from_prop; + InSProp,sind_scheme_kind_from_prop] let kinds_from_type = [InType,rect_dep_scheme_kind_from_type; InProp,ind_dep_scheme_kind_from_type; - InSet,rec_dep_scheme_kind_from_type] + InSet,rec_dep_scheme_kind_from_type; + InSProp,sind_dep_scheme_kind_from_type] let nondep_kinds_from_type = [InType,rect_scheme_kind_from_type; InProp,ind_scheme_kind_from_type; - InSet,rec_scheme_kind_from_type] + InSet,rec_scheme_kind_from_type; + InSProp,sind_scheme_kind_from_type] let declare_one_induction_scheme ind = let (mib,mip) = Global.lookup_inductive ind in @@ -246,6 +249,9 @@ let declare_one_induction_scheme ind = let from_prop = kind == InProp in let depelim = Inductiveops.has_dependent_elim mib in let kelim = elim_sorts (mib,mip) in + let kelim = if Global.sprop_allowed () then kelim + else List.filter (fun s -> s <> InSProp) kelim + in let elims = List.map_filter (fun (sort,kind) -> if Sorts.List.mem sort kelim then Some kind else None) @@ -347,19 +353,23 @@ requested match sort_of_ind with | InProp -> if isdep then (match z with + | InSProp -> inds ^ "s_dep" | InProp -> inds ^ "_dep" | InSet -> recs ^ "_dep" | InType -> recs ^ "t_dep") else ( match z with + | InSProp -> inds ^ "s" | InProp -> inds | InSet -> recs | InType -> recs ^ "t" ) | _ -> if isdep then (match z with + | InSProp -> inds ^ "s" | InProp -> inds | InSet -> recs | InType -> recs ^ "t" ) else (match z with + | InSProp -> inds ^ "s_nodep" | InProp -> inds ^ "_nodep" | InSet -> recs ^ "_nodep" | InType -> recs ^ "t_nodep") diff --git a/vernac/lemmas.ml b/vernac/lemmas.ml index 77f125e878..0d0732cbb4 100644 --- a/vernac/lemmas.ml +++ b/vernac/lemmas.ml @@ -330,7 +330,7 @@ let initialize_named_context_for_proof () = List.fold_right (fun d signv -> let id = NamedDecl.get_id d in - let d = if variable_opacity id then NamedDecl.LocalAssum (id, NamedDecl.get_type d) else d in + let d = if variable_opacity id then NamedDecl.drop_body d else d in Environ.push_named_context_val d signv) sign Environ.empty_named_context_val let start_proof id ?pl kind sigma ?terminator ?sign ?(compute_guard=[]) ?(hook : declaration_hook option) c = diff --git a/vernac/obligations.ml b/vernac/obligations.ml index 38cdfc2d7a..9aca48f529 100644 --- a/vernac/obligations.ml +++ b/vernac/obligations.ml @@ -13,6 +13,7 @@ open Declare open Term open Constr +open Context open Vars open Names open Evd @@ -124,11 +125,11 @@ let etype_of_evar evs hyps concl = | LocalDef (id,c,_) -> let c', s'', trans'' = subst_evar_constr evs n mkVar c in let c' = subst_vars acc 0 c' in - mkNamedProd_or_LetIn (LocalDef (id, c', t'')) rest, + mkNamedProd_or_LetIn (LocalDef (id, c', t'')) rest, Int.Set.union s'' s', Id.Set.union trans'' trans' - | LocalAssum (id,_) -> - mkNamedProd_or_LetIn (LocalAssum (id, t'')) rest, s', trans') + | LocalAssum (id,_) -> + mkNamedProd_or_LetIn (LocalAssum (id, t'')) rest, s', trans') | [] -> let t', s, trans = subst_evar_constr evs n mkVar concl in subst_vars acc 0 t', s, trans @@ -479,7 +480,7 @@ let declare_definition prg = let rec lam_index n t acc = match Constr.kind t with - | Lambda (Name n', _, _) when Id.equal n n' -> + | Lambda ({binder_name=Name n'}, _, _) when Id.equal n n' -> acc | Lambda (_, _, b) -> lam_index n b (succ acc) @@ -508,11 +509,12 @@ let declare_mutual_definition l = let subs, typ = subst_prog oblsubst x in let env = Global.env () in let sigma = Evd.from_ctx x.prg_ctx in + let r = Retyping.relevance_of_type env sigma (EConstr.of_constr typ) in let term = snd (Reductionops.splay_lam_n env sigma len (EConstr.of_constr subs)) in let typ = snd (Reductionops.splay_prod_n env sigma len (EConstr.of_constr typ)) in let term = EConstr.to_constr sigma term in let typ = EConstr.to_constr sigma typ in - let def = (x.prg_reduce term, x.prg_reduce typ, x.prg_implicits) in + let def = (x.prg_reduce term, r, x.prg_reduce typ, x.prg_implicits) in let oblsubst = List.map (fun (id, (_, c)) -> id, c) oblsubst in def, oblsubst in @@ -522,10 +524,12 @@ let declare_mutual_definition l = (xdef :: defs, xobls @ obls)) l ([], []) in (* let fixdefs = List.map reduce_fix fixdefs in *) - let fixdefs, fixtypes, fiximps = List.split3 defs in + let fixdefs, fixrs, fixtypes, fiximps = List.split4 defs in let fixkind = Option.get first.prg_fixkind in let arrrec, recvec = Array.of_list fixtypes, Array.of_list fixdefs in - let fixdecls = (Array.of_list (List.map (fun x -> Name x.prg_name) l), arrrec, recvec) in + let rvec = Array.of_list fixrs in + let namevec = Array.of_list (List.map (fun x -> Name x.prg_name) l) in + let fixdecls = (Array.map2 make_annot namevec rvec, arrrec, recvec) in let (local,poly,kind) = first.prg_kind in let fixnames = first.prg_deps in let opaque = first.prg_opaque in diff --git a/vernac/ppvernac.ml b/vernac/ppvernac.ml index f705f347a3..506c3f9f49 100644 --- a/vernac/ppvernac.ml +++ b/vernac/ppvernac.ml @@ -33,7 +33,10 @@ open Pputils let pr_constr = pr_constr_expr let pr_lconstr = pr_lconstr_expr - let pr_spc_lconstr = pr_sep_com spc pr_lconstr_expr + let pr_spc_lconstr = + let env = Global.env () in + let sigma = Evd.from_env env in + pr_sep_com spc @@ pr_lconstr_expr env sigma let pr_uconstraint (l, d, r) = pr_glob_level l ++ spc () ++ Univ.pr_constraint_type d ++ spc () ++ @@ -92,7 +95,10 @@ open Pputils | VernacEndSubproof -> str"" | _ -> str"." - let pr_gen t = Pputils.pr_raw_generic (Global.env ()) t + let pr_gen t = + let env = Global.env () in + let sigma = Evd.from_env env in + Pputils.pr_raw_generic env sigma t let sep = fun _ -> spc() let sep_v2 = fun _ -> str"," ++ spc() @@ -142,7 +148,10 @@ open Pputils let pr_search_about (b,c) = (if b then str "-" else mt()) ++ match c with - | SearchSubPattern p -> pr_constr_pattern_expr p + | SearchSubPattern p -> + let env = Global.env () in + let sigma = Evd.from_env env in + pr_constr_pattern_expr env sigma p | SearchString (s,sc) -> qs s ++ pr_opt (fun sc -> str "%" ++ str sc) sc let pr_search a gopt b pr_p = @@ -225,8 +234,10 @@ open Pputils ++ spc() ++ prlist_with_sep spc pr_qualid c | HintsExtern (n,c,tac) -> let pat = match c with None -> mt () | Some pat -> pr_pat pat in + let env = Global.env () in + let sigma = Evd.from_env env in keyword "Extern" ++ spc() ++ int n ++ spc() ++ pat ++ str" =>" ++ - spc() ++ Pputils.pr_raw_generic (Global.env ()) tac + spc() ++ Pputils.pr_raw_generic env sigma tac in hov 2 (keyword "Hint "++ pph ++ opth) @@ -298,7 +309,9 @@ open Pputils pr_opt (fun sc -> str ": " ++ str sc) scopt let pr_binders_arg = - pr_non_empty_arg pr_binders + let env = Global.env () in + let sigma = Evd.from_env env in + pr_non_empty_arg @@ pr_binders env sigma let pr_and_type_binders_arg bl = pr_binders_arg bl @@ -402,25 +415,35 @@ open Pputils hov 1 (str"(" ++ prlist_with_sep sep_v2 pr_syntax_modifier l ++ str")") let pr_rec_definition ((iddecl,ro,bl,type_,def),ntn) = + let env = Global.env () in + let sigma = Evd.from_env env in let pr_pure_lconstr c = Flags.without_option Flags.beautify pr_lconstr c in - let annot = pr_guard_annot pr_lconstr_expr bl ro in + let annot = pr_guard_annot (pr_lconstr_expr env sigma) bl ro in pr_ident_decl iddecl ++ pr_binders_arg bl ++ annot - ++ pr_type_option (fun c -> spc() ++ pr_lconstr_expr c) type_ - ++ pr_opt (fun def -> str":=" ++ brk(1,2) ++ pr_pure_lconstr def) def - ++ prlist (pr_decl_notation pr_constr) ntn + ++ pr_type_option (fun c -> spc() ++ pr_lconstr_expr env sigma c) type_ + ++ pr_opt (fun def -> str":=" ++ brk(1,2) ++ pr_pure_lconstr env sigma def) def + ++ prlist (pr_decl_notation @@ pr_constr env sigma) ntn let pr_statement head (idpl,(bl,c)) = + let env = Global.env () in + let sigma = Evd.from_env env in hov 2 (head ++ spc() ++ pr_ident_decl idpl ++ spc() ++ - (match bl with [] -> mt() | _ -> pr_binders bl ++ spc()) ++ + (match bl with [] -> mt() | _ -> pr_binders env sigma bl ++ spc()) ++ str":" ++ pr_spc_lconstr c) (**************************************) (* Pretty printer for vernac commands *) (**************************************) - let pr_constrarg c = spc () ++ pr_constr c - let pr_lconstrarg c = spc () ++ pr_lconstr c + let pr_constrarg c = + let env = Global.env () in + let sigma = Evd.from_env env in + spc () ++ pr_constr env sigma c + let pr_lconstrarg c = + let env = Global.env () in + let sigma = Evd.from_env env in + spc () ++ pr_lconstr env sigma c let pr_intarg n = spc () ++ int n let pr_oc = function @@ -429,21 +452,23 @@ open Pputils | Some false -> str" :>>" let pr_record_field ((x, pri), ntn) = + let env = Global.env () in + let sigma = Evd.from_env env in let prx = match x with | (oc,AssumExpr (id,t)) -> hov 1 (pr_lname id ++ pr_oc oc ++ spc() ++ - pr_lconstr_expr t) + pr_lconstr_expr env sigma t) | (oc,DefExpr(id,b,opt)) -> (match opt with | Some t -> hov 1 (pr_lname id ++ pr_oc oc ++ spc() ++ - pr_lconstr_expr t ++ str" :=" ++ pr_lconstr b) + pr_lconstr_expr env sigma t ++ str" :=" ++ pr_lconstr env sigma b) | None -> hov 1 (pr_lname id ++ str" :=" ++ spc() ++ - pr_lconstr b)) in + pr_lconstr env sigma b)) in let prpri = match pri with None -> mt() | Some i -> str "| " ++ int i in - prx ++ prpri ++ prlist (pr_decl_notation pr_constr) ntn + prx ++ prpri ++ prlist (pr_decl_notation @@ pr_constr env sigma) ntn let pr_record_decl b c fs = pr_opt pr_lident c ++ (if c = None then str"{" else str" {") ++ @@ -566,6 +591,8 @@ open Pputils let pr_vernac_expr v = let return = tag_vernac v in + let env = Global.env () in + let sigma = Evd.from_env env in match v with | VernacLoad (f,s) -> return ( @@ -700,7 +727,7 @@ open Pputils | None -> mt() | Some r -> keyword "Eval" ++ spc() ++ - Ppred.pr_red_expr (pr_constr, pr_lconstr, pr_smart_global, pr_constr) keyword r ++ + Ppred.pr_red_expr_env env sigma (pr_constr, pr_lconstr, pr_smart_global, pr_constr) keyword r ++ keyword " in" ++ spc() in let pr_def_body = function @@ -709,7 +736,7 @@ open Pputils | None -> mt() | Some ty -> spc() ++ str":" ++ pr_spc_lconstr ty in - (pr_binders_arg bl,ty,Some (pr_reduce red ++ pr_lconstr body)) + (pr_binders_arg bl,ty,Some (pr_reduce red ++ pr_lconstr env sigma body)) | ProveBody (bl,t) -> let typ u = if (fst id).v = Anonymous then (assert (bl = []); u) else (str" :" ++ u) in (pr_binders_arg bl, typ (pr_spc_lconstr t), None) in @@ -746,7 +773,7 @@ open Pputils let n = List.length (List.flatten (List.map fst (List.map snd l))) in let pr_params (c, (xl, t)) = hov 2 (prlist_with_sep sep pr_ident_decl xl ++ spc() ++ - (if c then str":>" else str":" ++ spc() ++ pr_lconstr_expr t)) in + (if c then str":>" else str":" ++ spc() ++ pr_lconstr_expr env sigma t)) in let assumptions = prlist_with_sep spc (fun p -> hov 1 (str "(" ++ pr_params p ++ str ")")) l in return (hov 2 (pr_assumption_token (n > 1) discharge kind ++ pr_non_empty_arg pr_assumption_inline t ++ spc() ++ assumptions)) @@ -771,9 +798,9 @@ open Pputils str key ++ spc() ++ (if coe then str"> " else str"") ++ pr_ident_decl iddecl ++ pr_and_type_binders_arg indpar ++ - pr_opt (fun s -> str":" ++ spc() ++ pr_lconstr_expr s) s ++ + pr_opt (fun s -> str":" ++ spc() ++ pr_lconstr_expr env sigma s) s ++ str" :=") ++ pr_constructor_list k lc ++ - prlist (pr_decl_notation pr_constr) ntn + prlist (pr_decl_notation @@ pr_constr env sigma) ntn in let key = let (_,_,_,k,_),_ = List.hd l in @@ -814,10 +841,10 @@ open Pputils | NoDischarge -> str "" in let pr_onecorec ((iddecl,bl,c,def),ntn) = - pr_ident_decl iddecl ++ spc() ++ pr_binders bl ++ spc() ++ str":" ++ - spc() ++ pr_lconstr_expr c ++ - pr_opt (fun def -> str":=" ++ brk(1,2) ++ pr_lconstr def) def ++ - prlist (pr_decl_notation pr_constr) ntn + pr_ident_decl iddecl ++ spc() ++ pr_binders env sigma bl ++ spc() ++ str":" ++ + spc() ++ pr_lconstr_expr env sigma c ++ + pr_opt (fun def -> str":=" ++ brk(1,2) ++ pr_lconstr env sigma def) def ++ + prlist (pr_decl_notation @@ pr_constr env sigma) ntn in return ( hov 0 (local ++ keyword "CoFixpoint" ++ spc() ++ @@ -897,11 +924,11 @@ open Pputils pr_and_type_binders_arg sup ++ str":" ++ spc () ++ (match bk with Implicit -> str "! " | Explicit -> mt ()) ++ - pr_constr cl ++ pr_hint_info pr_constr_pattern_expr info ++ + pr_constr env sigma cl ++ pr_hint_info (pr_constr_pattern_expr env sigma) info ++ (match props with | Some (true, { v = CRecord l}) -> spc () ++ str":=" ++ spc () ++ str"{" ++ pr_record_body l ++ str "}" | Some (true,_) -> assert false - | Some (false,p) -> spc () ++ str":=" ++ spc () ++ pr_constr p + | Some (false,p) -> spc () ++ str":=" ++ spc () ++ pr_constr env sigma p | None -> mt())) ) @@ -912,7 +939,7 @@ open Pputils pr_and_type_binders_arg sup ++ str":" ++ spc () ++ (match bk with Implicit -> str "! " | Explicit -> mt ()) ++ - pr_constr cl ++ pr_hint_info pr_constr_pattern_expr info) + pr_constr env sigma cl ++ pr_hint_info (pr_constr_pattern_expr env sigma) info) ) | VernacContext l -> @@ -922,8 +949,8 @@ open Pputils ) | VernacExistingInstance insts -> - let pr_inst (id, info) = - pr_qualid id ++ pr_hint_info pr_constr_pattern_expr info + let pr_inst (id, info) = + pr_qualid id ++ pr_hint_info (pr_constr_pattern_expr env sigma) info in return ( hov 1 (keyword "Existing" ++ spc () ++ @@ -938,25 +965,25 @@ open Pputils (* Modules and Module Types *) | VernacDefineModule (export,m,bl,tys,bd) -> - let b = pr_module_binders bl pr_lconstr in + let b = pr_module_binders bl (pr_lconstr env sigma) in return ( hov 2 (keyword "Module" ++ spc() ++ pr_require_token export ++ pr_lident m ++ b ++ - pr_of_module_type pr_lconstr tys ++ + pr_of_module_type (pr_lconstr env sigma) tys ++ (if List.is_empty bd then mt () else str ":= ") ++ prlist_with_sep (fun () -> str " <+") - (pr_module_ast_inl true pr_lconstr) bd) + (pr_module_ast_inl true (pr_lconstr env sigma)) bd) ) | VernacDeclareModule (export,id,bl,m1) -> - let b = pr_module_binders bl pr_lconstr in + let b = pr_module_binders bl (pr_lconstr env sigma) in return ( hov 2 (keyword "Declare Module" ++ spc() ++ pr_require_token export ++ pr_lident id ++ b ++ str " :" ++ - pr_module_ast_inl true pr_lconstr m1) + pr_module_ast_inl true (pr_lconstr env sigma) m1) ) | VernacDeclareModuleType (id,bl,tyl,m) -> - let b = pr_module_binders bl pr_lconstr in - let pr_mt = pr_module_ast_inl true pr_lconstr in + let b = pr_module_binders bl (pr_lconstr env sigma) in + let pr_mt = pr_module_ast_inl true (pr_lconstr env sigma) in return ( hov 2 (keyword "Module Type " ++ pr_lident id ++ b ++ prlist_strict (fun m -> str " <:" ++ pr_mt m) tyl ++ @@ -964,7 +991,7 @@ open Pputils prlist_with_sep (fun () -> str " <+ ") pr_mt m) ) | VernacInclude (mexprs) -> - let pr_m = pr_module_ast_inl false pr_lconstr in + let pr_m = pr_module_ast_inl false (pr_lconstr env sigma) in return ( hov 2 (keyword "Include" ++ spc() ++ prlist_with_sep (fun () -> str " <+ ") pr_m mexprs) @@ -1013,7 +1040,7 @@ open Pputils pr_opt_hintbases dbnames) ) | VernacHints (dbnames,h) -> - return (pr_hints dbnames h pr_constr pr_constr_pattern_expr) + return (pr_hints dbnames h (pr_constr env sigma) (pr_constr_pattern_expr env sigma)) | VernacSyntacticDefinition (id,(ids,c),compat) -> return ( hov 2 @@ -1071,7 +1098,7 @@ open Pputils let n = List.length (List.flatten (List.map fst bl)) in return ( hov 2 (tag_keyword (str"Implicit Type" ++ str (if n > 1 then "s " else " ")) - ++ pr_ne_params_list pr_lconstr_expr (List.map (fun sb -> false,sb) bl)) + ++ pr_ne_params_list (pr_lconstr_expr env sigma) (List.map (fun sb -> false,sb) bl)) ) | VernacGeneralizable g -> return ( @@ -1143,9 +1170,9 @@ open Pputils let pr_mayeval r c = match r with | Some r0 -> hov 2 (keyword "Eval" ++ spc() ++ - Ppred.pr_red_expr (pr_constr,pr_lconstr,pr_smart_global, pr_constr) keyword r0 ++ - spc() ++ keyword "in" ++ spc () ++ pr_lconstr c) - | None -> hov 2 (keyword "Check" ++ spc() ++ pr_lconstr c) + Ppred.pr_red_expr_env env sigma (pr_constr,pr_lconstr,pr_smart_global, pr_constr) keyword r0 ++ + spc() ++ keyword "in" ++ spc () ++ pr_lconstr env sigma c) + | None -> hov 2 (keyword "Check" ++ spc() ++ pr_lconstr env sigma c) in let pr_i = match io with None -> mt () | Some i -> Goal_select.pr_goal_selector i ++ str ": " in @@ -1155,12 +1182,12 @@ open Pputils | VernacDeclareReduction (s,r) -> return ( keyword "Declare Reduction" ++ spc () ++ str s ++ str " := " ++ - Ppred.pr_red_expr (pr_constr,pr_lconstr,pr_smart_global, pr_constr) keyword r + Ppred.pr_red_expr_env env sigma (pr_constr,pr_lconstr,pr_smart_global, pr_constr) keyword r ) | VernacPrint p -> return (pr_printable p) | VernacSearch (sea,g,sea_r) -> - return (pr_search sea g sea_r pr_constr_pattern_expr) + return (pr_search sea g sea_r @@ pr_constr_pattern_expr env sigma) | VernacLocate loc -> let pr_locate =function | LocateAny qid -> pr_smart_global qid @@ -1192,7 +1219,7 @@ open Pputils return ( hov 2 (keyword "Comments" ++ spc() - ++ prlist_with_sep sep (pr_comment pr_constr) l) + ++ prlist_with_sep sep (pr_comment (pr_constr env sigma)) l) ) (* For extension *) @@ -1204,12 +1231,12 @@ open Pputils return (keyword "Proof " ++ spc () ++ keyword "using" ++ spc() ++ pr_using e) | VernacProof (Some te, None) -> - return (keyword "Proof with" ++ spc() ++ Pputils.pr_raw_generic (Global.env ()) te) + return (keyword "Proof with" ++ spc() ++ Pputils.pr_raw_generic env sigma te) | VernacProof (Some te, Some e) -> return ( keyword "Proof" ++ spc () ++ keyword "using" ++ spc() ++ pr_using e ++ spc() ++ - keyword "with" ++ spc() ++ Pputils.pr_raw_generic (Global.env ()) te + keyword "with" ++ spc() ++ Pputils.pr_raw_generic env sigma te ) | VernacProofMode s -> return (keyword "Proof Mode" ++ str s) diff --git a/vernac/record.ml b/vernac/record.ml index 3202c9bed2..23274040b0 100644 --- a/vernac/record.ml +++ b/vernac/record.ml @@ -17,6 +17,7 @@ open Names open Globnames open Nameops open Constr +open Context open Vars open Environ open Declarations @@ -66,6 +67,7 @@ let interp_fields_evars env sigma impls_env nots l = List.fold_left2 (fun (env, sigma, uimpls, params, impls) no ({CAst.loc;v=i}, b, t) -> let sigma, (t', impl) = interp_type_evars_impls ~program_mode:false env sigma ~impls t in + let r = Retyping.relevance_of_type env sigma t' in let sigma, b' = Option.cata (fun x -> on_snd (fun x -> Some (fst x)) @@ interp_casted_constr_evars_impls ~program_mode:false env sigma ~impls x t') (sigma,None) b in @@ -75,8 +77,8 @@ let interp_fields_evars env sigma impls_env nots l = | Name id -> Id.Map.add id (compute_internalization_data env sigma Constrintern.Method t' impl) impls in let d = match b' with - | None -> LocalAssum (i,t') - | Some b' -> LocalDef (i,b',t') + | None -> LocalAssum (make_annot i r,t') + | Some b' -> LocalDef (make_annot i r,b',t') in List.iter (Metasyntax.set_notation_for_interpretation env impls) no; (EConstr.push_rel d env, sigma, impl :: uimpls, d::params, impls)) @@ -90,7 +92,7 @@ let compute_constructor_level evars env l = Univ.sup (univ_of_sort s) univ else univ in (EConstr.push_rel d env, univ)) - l (env, Univ.type0m_univ) + l (env, Univ.Universe.sprop) let binder_of_decl = function | Vernacexpr.AssumExpr(n,t) -> (n,None,t) @@ -144,8 +146,10 @@ let typecheck_params_and_fields finite def poly pl ps records = in let (sigma, template), typs = List.fold_left_map fold (sigma, true) records in let arities = List.map (fun (typ, _) -> EConstr.it_mkProd_or_LetIn typ newps) typs in - let fold accu (id, _, _, _) arity = EConstr.push_rel (LocalAssum (Name id,arity)) accu in - let env_ar = EConstr.push_rel_context newps (List.fold_left2 fold env0 records arities) in + let relevances = List.map (fun (_,s) -> Sorts.relevance_of_sort s) typs in + let fold accu (id, _, _, _) arity r = + EConstr.push_rel (LocalAssum (make_annot (Name id) r,arity)) accu in + let env_ar = EConstr.push_rel_context newps (List.fold_left3 fold env0 records arities relevances) in let assums = List.filter is_local_assum newps in let impls_env = let params = List.map (RelDecl.get_name %> Name.get_id) assums in @@ -163,16 +167,16 @@ let typecheck_params_and_fields finite def poly pl ps records = Pretyping.solve_remaining_evars Pretyping.all_and_fail_flags env_ar sigma in let fold sigma (typ, sort) (_, newfs) = let _, univ = compute_constructor_level sigma env_ar newfs in - if not def && (Sorts.is_prop sort || - (Sorts.is_set sort && is_impredicative_set env0)) then + let univ = if Sorts.is_sprop sort then univ else Univ.Universe.sup univ Univ.type0m_univ in + if not def && is_impredicative_sort env0 sort then sigma, typ else - let sigma = Evd.set_leq_sort env_ar sigma (Type univ) sort in - if Univ.is_small_univ univ && + let sigma = Evd.set_leq_sort env_ar sigma (Sorts.sort_of_univ univ) sort in + if Univ.is_small_univ univ && Option.cata (Evd.is_flexible_level sigma) false (Evd.is_sort_variable sigma sort) then (* We can assume that the level in aritysort is not constrained and clear it, if it is flexible *) - Evd.set_eq_sort env_ar sigma Set sort, EConstr.mkSort (Sorts.sort_of_univ univ) + Evd.set_eq_sort env_ar sigma Sorts.set sort, EConstr.mkSort (Sorts.sort_of_univ univ) else sigma, typ in let (sigma, typs) = List.fold_left2_map fold sigma typs data in @@ -213,12 +217,12 @@ let warning_or_error coe indsp err = strbrk " not defined.") | BadTypedProj (fi,ctx,te) -> match te with - | ElimArity (_,_,_,_,Some (_,_,NonInformativeToInformative)) -> + | ElimArity (_,_,_,Some (_,_,_,NonInformativeToInformative)) -> (Id.print fi ++ strbrk" cannot be defined because it is informative and " ++ Printer.pr_inductive (Global.env()) indsp ++ strbrk " is not.") - | ElimArity (_,_,_,_,Some (_,_,StrongEliminationOnNonSmallType)) -> + | ElimArity (_,_,_,Some (_,_,_,StrongEliminationOnNonSmallType)) -> (Id.print fi ++ strbrk" cannot be defined because it is large and " ++ Printer.pr_inductive (Global.env()) indsp ++ @@ -284,7 +288,7 @@ let declare_projections indsp ctx ?(kind=StructureComponent) binder_name coers f let r = mkIndU (indsp,u) in let rp = applist (r, Context.Rel.to_extended_list mkRel 0 paramdecls) in let paramargs = Context.Rel.to_extended_list mkRel 1 paramdecls in (*def in [[params;x:rp]]*) - let x = Name binder_name in + let x = make_annot (Name binder_name) mip.mind_relevance in let fields = instantiate_possibly_recursive_type (fst indsp) u mib.mind_ntypes paramdecls fields in let lifted_fields = Termops.lift_rel_context 1 fields in let primitive = @@ -316,18 +320,19 @@ let declare_projections indsp ctx ?(kind=StructureComponent) binder_name coers f else let ccl = subst_projection fid subst ti in let body = match decl with - | LocalDef (_,ci,_) -> subst_projection fid subst ci - | LocalAssum _ -> + | LocalDef (_,ci,_) -> subst_projection fid subst ci + | LocalAssum ({binder_relevance=rci},_) -> (* [ccl] is defined in context [params;x:rp] *) (* [ccl'] is defined in context [params;x:rp;x:rp] *) let ccl' = liftn 1 2 ccl in - let p = mkLambda (x, lift 1 rp, ccl') in + let p = mkLambda (x, lift 1 rp, ccl') in let branch = it_mkLambda_or_LetIn (mkRel nfi) lifted_fields in - let ci = Inductiveops.make_case_info env indsp LetStyle in - mkCase (ci, p, mkRel 1, [|branch|]) - in + let ci = Inductiveops.make_case_info env indsp rci LetStyle in + (* Record projections have no is *) + mkCase (ci, p, mkRel 1, [|branch|]) + in let proj = - it_mkLambda_or_LetIn (mkLambda (x,rp,body)) paramdecls in + it_mkLambda_or_LetIn (mkLambda (x,rp,body)) paramdecls in let projtyp = it_mkProd_or_LetIn (mkProd (x,rp,ccl)) paramdecls in try @@ -463,7 +468,9 @@ let declare_class def cum ubinders univs id idbuild paramimpls params arity let binder_name = Namegen.next_ident_away id (Termops.vars_of_env (Global.env())) in let data = match fields with - | [LocalAssum (Name proj_name, field) | LocalDef (Name proj_name, _, field)] when def -> + | [LocalAssum ({binder_name=Name proj_name} as binder, field) + | LocalDef ({binder_name=Name proj_name} as binder, _, field)] when def -> + let binder = {binder with binder_name=Name binder_name} in let class_body = it_mkLambda_or_LetIn field params in let class_type = it_mkProd_or_LetIn arity params in let class_entry = @@ -477,11 +484,11 @@ let declare_class def cum ubinders univs id idbuild paramimpls params arity in let cstu = (cst, inst) in let inst_type = appvectc (mkConstU cstu) - (Termops.rel_vect 0 (List.length params)) in + (Termops.rel_vect 0 (List.length params)) in let proj_type = - it_mkProd_or_LetIn (mkProd(Name binder_name, inst_type, lift 1 field)) params in + it_mkProd_or_LetIn (mkProd(binder, inst_type, lift 1 field)) params in let proj_body = - it_mkLambda_or_LetIn (mkLambda (Name binder_name, inst_type, mkRel 1)) params in + it_mkLambda_or_LetIn (mkLambda (binder, inst_type, mkRel 1)) params in let proj_entry = Declare.definition_entry ~types:proj_type ~univs proj_body in let proj_cst = Declare.declare_constant proj_name (DefinitionEntry proj_entry, IsDefinition Definition) @@ -548,12 +555,13 @@ let declare_class def cum ubinders univs id idbuild paramimpls params arity let add_constant_class env cst = let ty, univs = Typeops.type_of_global_in_context env (ConstRef cst) in + let r = (Environ.lookup_constant cst env).const_relevance in let ctx, arity = decompose_prod_assum ty in let tc = { cl_univs = univs; cl_impl = ConstRef cst; cl_context = (List.map (const None) ctx, ctx); - cl_props = [LocalAssum (Anonymous, arity)]; + cl_props = [LocalAssum (make_annot Anonymous r, arity)]; cl_projs = []; cl_strict = !typeclasses_strict; cl_unique = !typeclasses_unique @@ -570,10 +578,11 @@ let add_inductive_class env ind = let env = push_rel_context ctx env in let inst = Univ.make_abstract_instance univs in let ty = Inductive.type_of_inductive env ((mind, oneind), inst) in + let r = Inductive.relevance_of_inductive env ind in { cl_univs = univs; cl_impl = IndRef ind; cl_context = List.map (const None) ctx, ctx; - cl_props = [LocalAssum (Anonymous, ty)]; + cl_props = [LocalAssum (make_annot Anonymous r, ty)]; cl_projs = []; cl_strict = !typeclasses_strict; cl_unique = !typeclasses_unique } diff --git a/vernac/topfmt.ml b/vernac/topfmt.ml index ed93267665..60b0bdc7e7 100644 --- a/vernac/topfmt.ml +++ b/vernac/topfmt.ml @@ -196,8 +196,8 @@ let init_tag_map styles = let default_styles () = init_tag_map (default_tag_map ()) -let parse_color_config file = - let styles = Terminal.parse file in +let parse_color_config str = + let styles = Terminal.parse str in init_tag_map styles let dump_tags () = CString.Map.bindings !tag_map diff --git a/vernac/vernacentries.ml b/vernac/vernacentries.ml index d227834fcf..4250ddb02c 100644 --- a/vernac/vernacentries.ml +++ b/vernac/vernacentries.ml @@ -144,8 +144,8 @@ let make_cases_aux glob_ref = | [] -> [] | RelDecl.LocalDef _ :: l -> "_" :: rename avoid l | RelDecl.LocalAssum (n, _)::l -> - let n' = Namegen.next_name_away_with_default (Id.to_string Namegen.default_dependent_ident) n avoid in - Id.to_string n' :: rename (Id.Set.add n' avoid) l in + let n' = Namegen.next_name_away_with_default (Id.to_string Namegen.default_dependent_ident) n.Context.binder_name avoid in + Id.to_string n' :: rename (Id.Set.add n' avoid) l in let al' = rename Id.Set.empty al in let consref = ConstructRef (ith_constructor_of_inductive ind (i + 1)) in (Libnames.string_of_qualid (Nametab.shortest_qualid_of_global Id.Set.empty consref) :: al') :: l) @@ -1424,6 +1424,14 @@ let vernac_generalizable ~local = let () = declare_bool_option { optdepr = false; + optname = "allow sprop"; + optkey = ["Allow";"StrictProp"]; + optread = (fun () -> Global.sprop_allowed()); + optwrite = Global.set_allow_sprop } + +let () = + declare_bool_option + { optdepr = false; optname = "silent"; optkey = ["Silent"]; optread = (fun () -> !Flags.quiet); diff --git a/vernac/vernacextend.ml b/vernac/vernacextend.ml index f5cf3401d0..4bfe5c66b5 100644 --- a/vernac/vernacextend.ml +++ b/vernac/vernacextend.ml @@ -235,7 +235,7 @@ type 'a argument_rule = | Arg_rules of 'a Extend.production_rule list type 'a vernac_argument = { - arg_printer : 'a -> Pp.t; + arg_printer : Environ.env -> Evd.evar_map -> 'a -> Pp.t; arg_parsing : 'a argument_rule; } @@ -251,6 +251,6 @@ let vernac_argument_extend ~name arg = e in let pr = arg.arg_printer in - let pr x = Genprint.PrinterBasic (fun () -> pr x) in + let pr x = Genprint.PrinterBasic (fun env sigma -> pr env sigma x) in let () = Genprint.register_vernac_print0 wit pr in (wit, entry) diff --git a/vernac/vernacextend.mli b/vernac/vernacextend.mli index 118907c31b..4d89eaffd9 100644 --- a/vernac/vernacextend.mli +++ b/vernac/vernacextend.mli @@ -109,7 +109,7 @@ type 'a argument_rule = entries instead of ty_user_symbol and thus arguments as roots. *) type 'a vernac_argument = { - arg_printer : 'a -> Pp.t; + arg_printer : Environ.env -> Evd.evar_map -> 'a -> Pp.t; arg_parsing : 'a argument_rule; } |
