diff options
946 files changed, 26886 insertions, 33242 deletions
diff --git a/.bintray.json b/.bintray.json index fb9e55368..8672c2bb9 100644 --- a/.bintray.json +++ b/.bintray.json @@ -6,7 +6,7 @@ }, "version": { - "name": "8.8+alpha" + "name": "8.9+alpha" }, "files": diff --git a/.circleci/config.yml b/.circleci/config.yml index 352ec5a51..cff461295 100644 --- a/.circleci/config.yml +++ b/.circleci/config.yml @@ -8,135 +8,73 @@ defaults: # reference syntax) working_directory: ~/coq docker: - - image: ocaml/opam:ubuntu + - image: $CI_REGISTRY_IMAGE:$CACHEKEY environment: &envvars - # required by some of the targets, e.g. compcert, passed for - # instance to opam to configure the number of parallel jobs - # allowed - NJOBS: 2 - COMPILER: "system" - CAMLP5_VER: "6.14" - NATIVE_COMP: "yes" - - # some useful values - TIMING_PACKAGES: &timing-packages "time python" + CACHEKEY: "bionic_coq-V2018-06-04-V2" + CI_REGISTRY_IMAGE: registry.gitlab.com/coq/coq version: 2 before_script: &before_script - name: Install system packages + name: Setup OPAM Switch command: | echo export TERM=xterm >> ~/.profile source ~/.profile - printenv - if [ -n "${EXTRA_PACKAGES}" ]; then sudo apt-get update -yq && sudo apt-get install -yq --no-install-recommends ${EXTRA_PACKAGES}; fi - -opam-switch: &opam-switch - name: Select opam switch - command: | - source ~/.profile - opam switch ${COMPILER} + echo . ~/.profile >> $BASH_ENV + printenv | sort + opam switch "$COMPILER" opam config list opam list -.opam-boot-template: &opam-boot-template - <<: *params - steps: - - checkout - - run: *before_script - - run: - name: Cache selection - command: | - source ~/.profile - # We can't use environment variables in cache names - # So put it in a file and use the checksum - echo "$COMPILER" > COMPILER - - restore_cache: - keys: - - coq-opam-cache-v1-{{ arch }}-{{ checksum "COMPILER" }}-{{ checksum ".circleci/config.yml" }}- - - coq-opam-cache-v1-{{ arch }}-{{ checksum "COMPILER" }}- # this grabs old cache if checksum doesn't match - - run: - name: Update opam lists - command: | - source ~/.profile - opam repository set-url default https://opam.ocaml.org - opam update - - run: - name: Install opam packages - command: | - source ~/.profile - opam switch -j ${NJOBS} ${COMPILER} - opam install -j ${NJOBS} -y camlp5.${CAMLP5_VER} ocamlfind ${EXTRA_OPAM} - - run: - name: Clean cache - command: | - source ~/.profile - rm -rf ~/.opam/log/ - - save_cache: - key: coq-opam-cache-v1-{{ arch }}-{{ checksum "COMPILER" }}-{{ checksum ".circleci/config.yml" }}- - paths: - - ~/.opam - - persist_to_workspace: - root: &workspace ~/ - paths: - - .opam/ - .build-template: &build-template <<: *params steps: - checkout - run: *before_script - - attach_workspace: &attach_workspace - at: *workspace - - run: *opam-switch + - run: &build-clean + name: Clean + command: | + make clean # ensure that `make clean` works on a fresh clone - run: &build-configure name: Configure command: | - source ~/.profile - ./configure -local -native-compiler ${NATIVE_COMP} -coqide no - run: &build-build name: Build command: | - source ~/.profile make -j ${NJOBS} byte make -j ${NJOBS} make test-suite/misc/universes/all_stdlib.v - persist_to_workspace: - root: *workspace + root: &workspace ~/ paths: - coq/ - environment: *envvars + environment: + <<: *envvars + NATIVE_COMP: "yes" .ci-template: &ci-template <<: *params steps: - run: *before_script - - attach_workspace: *attach_workspace + - attach_workspace: &attach_workspace + at: *workspace + - run: name: Test command: | - source ~/.profile dev/ci/ci-wrapper.sh ${CIRCLE_JOB} - persist_to_workspace: root: *workspace paths: - coq/ - environment: &ci-template-vars - <<: *envvars - EXTRA_PACKAGES: *timing-packages + environment: *envvars # Defines individual jobs, see the workflows section below for job orchestration jobs: - opam-boot: - <<: *opam-boot-template - environment: - <<: *envvars - EXTRA_OPAM: "ocamlgraph ppx_tools_versioned ppx_deriving ocaml-migrate-parsetree" - # Build and prepare test environment build: *build-template @@ -145,24 +83,18 @@ jobs: color: <<: *ci-template - environment: - <<: *ci-template-vars - EXTRA_PACKAGES: *timing-packages compcert: <<: *ci-template coq-dpdgraph: <<: *ci-template - environment: - <<: *ci-template-vars - EXTRA_PACKAGES: "time python autoconf automake" coquelicot: <<: *ci-template - environment: - <<: *ci-template-vars - EXTRA_PACKAGES: "time python autoconf automake" + + cross-crypto: + <<: *ci-template elpi: <<: *ci-template @@ -173,20 +105,17 @@ jobs: geocoq: <<: *ci-template + fcsl-pcm: + <<: *ci-template + fiat-crypto: <<: *ci-template fiat-parsers: <<: *ci-template - environment: - <<: *ci-template-vars - EXTRA_PACKAGES: *timing-packages flocq: <<: *ci-template - environment: - <<: *ci-template-vars - EXTRA_PACKAGES: "time python autoconf automake" math-classes: <<: *ci-template @@ -199,9 +128,6 @@ jobs: hott: <<: *ci-template - environment: - <<: *ci-template-vars - EXTRA_PACKAGES: "time python autoconf automake" iris-lambda-rust: <<: *ci-template @@ -212,11 +138,14 @@ jobs: math-comp: <<: *ci-template + mtac2: + <<: *ci-template + + pidetop: + <<: *ci-template + sf: <<: *ci-template - environment: - <<: *ci-template-vars - EXTRA_PACKAGES: "time python wget" unimath: <<: *ci-template @@ -226,14 +155,11 @@ jobs: workflows: version: 2 + # Run on each push main: jobs: - - opam-boot - - - build: - requires: - - opam-boot + - build - bignums: &req-main requires: @@ -242,19 +168,22 @@ workflows: requires: - build - bignums - - compcert: *req-main - - coq-dpdgraph: *req-main - - coquelicot: *req-main - - elpi: *req-main - - equations: *req-main - - geocoq: *req-main - - fiat-crypto: *req-main - - fiat-parsers: *req-main - - flocq: *req-main + # - compcert: *req-main + # - coq-dpdgraph: *req-main + # - coquelicot: *req-main + # - cross-crypto: *req-main + # - elpi: *req-main + # - equations: *req-main + # - geocoq: *req-main + # - fcsl-pcm: *req-main + # - fiat-crypto: *req-main + # - fiat-parsers: *req-main + # - flocq: *req-main - math-classes: requires: - build - bignums + # - mtac2: *req-main - corn: requires: - build @@ -263,10 +192,11 @@ workflows: requires: - build - corn - - hott: *req-main - - iris-lambda-rust: *req-main - - ltac2: *req-main - - math-comp: *req-main - - sf: *req-main - - unimath: *req-main - - vst: *req-main + # - hott: *req-main + # - iris-lambda-rust: *req-main + # - ltac2: *req-main + # - math-comp: *req-main + # - pidetop: *req-main + # - sf: *req-main + # - unimath: *req-main + # - vst: *req-main diff --git a/.gitattributes b/.gitattributes index e087e1737..a5edcdb5b 100644 --- a/.gitattributes +++ b/.gitattributes @@ -5,48 +5,51 @@ # Because our commit hook automatically does [apply whitespace=fix] we # disable whitespace checking for all files except those where we want # it. Otherwise rogue global configuration and forgotten local -# configuration can break commits. +# configuration can break commits. Note that git cannot fix but can +# detect a blank-at-eof when it comes from removing a chunk of text at +# the end of the file, leaving an extra newline from before that +# chunk, so we disable blank-at-eof. * -whitespace # tabs are allowed in Makefiles. -Makefile* whitespace=trailing-space -tools/CoqMakefile.in whitespace=trailing-space +Makefile* whitespace=blank-at-eol +tools/CoqMakefile.in whitespace=blank-at-eol # in general we don't want tabs. -*.asciidoc whitespace=trailing-space,tab-in-indent -*.bib whitespace=trailing-space,tab-in-indent -*.c whitespace=trailing-space,tab-in-indent -*.css whitespace=trailing-space,tab-in-indent -*.dtd whitespace=trailing-space,tab-in-indent -*.el whitespace=trailing-space,tab-in-indent -*.g whitespace=trailing-space,tab-in-indent -*.h whitespace=trailing-space,tab-in-indent -*.html whitespace=trailing-space,tab-in-indent -*.hva whitespace=trailing-space,tab-in-indent -*.js whitespace=trailing-space,tab-in-indent -*.json whitespace=trailing-space,tab-in-indent -*.lang whitespace=trailing-space,tab-in-indent -*.md whitespace=trailing-space,tab-in-indent -*.merlin whitespace=trailing-space,tab-in-indent -*.ml whitespace=trailing-space,tab-in-indent -*.ml4 whitespace=trailing-space,tab-in-indent -*.mli whitespace=trailing-space,tab-in-indent -*.mll whitespace=trailing-space,tab-in-indent -*.mllib whitespace=trailing-space,tab-in-indent -*.mlp whitespace=trailing-space,tab-in-indent -*.mlpack whitespace=trailing-space,tab-in-indent -*.nsh whitespace=trailing-space,tab-in-indent -*.nsi whitespace=trailing-space,tab-in-indent -*.py whitespace=trailing-space,tab-in-indent -*.rst whitespace=trailing-space,tab-in-indent -*.sh whitespace=trailing-space,tab-in-indent -*.sty whitespace=trailing-space,tab-in-indent -*.tex whitespace=trailing-space,tab-in-indent -*.tokens whitespace=trailing-space,tab-in-indent -*.txt whitespace=trailing-space,tab-in-indent -*.v whitespace=trailing-space,tab-in-indent -*.xml whitespace=trailing-space,tab-in-indent -*.yml whitespace=trailing-space,tab-in-indent +*.asciidoc whitespace=blank-at-eol,tab-in-indent +*.bib whitespace=blank-at-eol,tab-in-indent +*.c whitespace=blank-at-eol,tab-in-indent +*.css whitespace=blank-at-eol,tab-in-indent +*.dtd whitespace=blank-at-eol,tab-in-indent +*.el whitespace=blank-at-eol,tab-in-indent +*.g whitespace=blank-at-eol,tab-in-indent +*.h whitespace=blank-at-eol,tab-in-indent +*.html whitespace=blank-at-eol,tab-in-indent +*.hva whitespace=blank-at-eol,tab-in-indent +*.js whitespace=blank-at-eol,tab-in-indent +*.json whitespace=blank-at-eol,tab-in-indent +*.lang whitespace=blank-at-eol,tab-in-indent +*.md whitespace=blank-at-eol,tab-in-indent +*.merlin whitespace=blank-at-eol,tab-in-indent +*.ml whitespace=blank-at-eol,tab-in-indent +*.ml4 whitespace=blank-at-eol,tab-in-indent +*.mli whitespace=blank-at-eol,tab-in-indent +*.mll whitespace=blank-at-eol,tab-in-indent +*.mllib whitespace=blank-at-eol,tab-in-indent +*.mlp whitespace=blank-at-eol,tab-in-indent +*.mlpack whitespace=blank-at-eol,tab-in-indent +*.nsh whitespace=blank-at-eol,tab-in-indent +*.nsi whitespace=blank-at-eol,tab-in-indent +*.py whitespace=blank-at-eol,tab-in-indent +*.rst whitespace=blank-at-eol,tab-in-indent +*.sh whitespace=blank-at-eol,tab-in-indent +*.sty whitespace=blank-at-eol,tab-in-indent +*.tex whitespace=blank-at-eol,tab-in-indent +*.tokens whitespace=blank-at-eol,tab-in-indent +*.txt whitespace=blank-at-eol,tab-in-indent +*.v whitespace=blank-at-eol,tab-in-indent +*.xml whitespace=blank-at-eol,tab-in-indent +*.yml whitespace=blank-at-eol,tab-in-indent # CR is desired for these Windows files. -*.bat whitespace=cr-at-eol,trailing-space,tab-in-indent +*.bat whitespace=cr-at-eol,blank-at-eol,tab-in-indent diff --git a/.github/CODEOWNERS b/.github/CODEOWNERS index f344c5cf5..9e87d2ca7 100644 --- a/.github/CODEOWNERS +++ b/.github/CODEOWNERS @@ -8,16 +8,25 @@ ########## CI infrastructure ########## -/dev/ci/*.sh @ejgallego +/dev/ci/ @ejgallego # Secondary maintainer @SkySkimmer +/dev/ci/user-overlays/*.sh @ghost +# Trick to avoid getting review requests +# each time someone adds an overlay + +/.circleci/ @SkySkimmer +# Secondary maintainer @ejgallego + /.travis.yml @ejgallego # Secondary maintainer @SkySkimmer /.gitlab-ci.yml @SkySkimmer # Secondary maintainer @ejgallego -/appveyor.yml @maximedenes +/appveyor.yml @maximedenes +/dev/ci/appveyor.* @maximedenes +/dev/ci/*.bat @maximedenes # Secondary maintainer @SkySkimmer /default.nix @Zimmi48 @@ -42,29 +51,39 @@ # each time someone modifies the dev changelog /doc/ @maximedenes -# Secondary maintainer @silene +# Secondary maintainer @silene @Zimmi48 /man/ @silene # Secondary maintainer @maximedenes ########## Coqchk ########## -/checker/ @barras -# Secondary maintainer @maximedenes +/checker/ @ppedrot +/test-suite/coqchk/ @ppedrot +# Secondary maintainers @maximedenes ########## Coq lib ########## /clib/ @ppedrot +/test-suite/unit-tests/clib/ @ppedrot # Secondary maintainer @ejgallego /lib/ @ejgallego # Secondary maintainer @ppedrot +/lib/cWarnings.* @maximedenes +# Secondary maintainer @ejgallego + ########## Proof engine ########## /engine/ @ppedrot # Secondary maintainer @aspiwack +/engine/universes.* @SkySkimmer +/engine/univops.* @SkySkimmer +/engine/uState.* @SkySkimmer +# Secondary maintainer @mattam82 + ########## Grammar macros ########## /grammar/ @ppedrot @@ -73,6 +92,7 @@ ########## CoqIDE ########## /ide/ @ppedrot +/test-suite/ide/ @ppedrot # Secondary maintainer @gares ########## Interpretation ########## @@ -80,19 +100,19 @@ /interp/ @herbelin # Secondary maintainer @ejgallego -########## Interfaces ########## - -/intf/ @letouzey -# Secondary maintainer @ppedrot - ########## Kernel ########## /kernel/ @maximedenes -# Secondary maintainer @barras +# Secondary maintainers @barras @ppedrot /kernel/byterun/ @maximedenes # Secondary maintainer @silene +/kernel/sorts.* @SkySkimmer +/kernel/uGraph.* @SkySkimmer +/kernel/univ.* @SkySkimmer +# Secondary maintainer @mattam82 + ########## Library ########## /library/ @silene @@ -129,7 +149,8 @@ /plugins/ltac/ @ppedrot # Secondary maintainer @herbelin -/plugins/micromega/ @fajb +/plugins/micromega/ @fajb +/test-suite/micromega/ @fajb # Secondary maintainer @bgregoir /plugins/nsatz/ @thery @@ -145,7 +166,8 @@ /plugins/ssrmatching/ @gares # Secondary maintainer @maximedenes -/plugins/ssr/ @gares +/plugins/ssr/ @gares +/test-suite/ssr/ @gares # Secondary maintainer @maximedenes /plugins/syntax/ @ppedrot @@ -173,14 +195,21 @@ ########## STM ########## -/stm/ @gares -# Secondary maintainer @ejgallego +/stm/ @gares +/test-suite/interactive/ @gares +/test-suite/stm/ @gares +/test-suite/vio/ @gares +# Secondary maintainer @ejgallego ########## Tactics ########## /tactics/ @ppedrot # Secondary maintainer @mattam82 +/tactics/class_tactics.* @mattam82 +/test-suite/typeclasses/ @mattam82 +# Secondary maintainer @ppedrot + ########## Standard library ########## /theories/Arith/ @letouzey @@ -259,14 +288,14 @@ ########## Tools ########## -/tools/coqdoc/ @silene +/tools/coqdoc/ @silene +/test-suite/coqdoc/ @silene # Secondary maintainer @mattam82 -/tools/coq_makefile* @gares -# Secondary maintainer @silene - -/tools/CoqMakefile* @gares -# Secondary maintainer @silene +/tools/coq_makefile* @gares +/tools/CoqMakefile* @gares +/test-suite/coq-makefile/ @gares +# Secondary maintainer @silene /tools/coqdep* @ppedrot # Secondary maintainer @maximedenes @@ -274,9 +303,15 @@ /tools/coq_tex* @silene # Secondary maintainer @gares -/tools/coqwc* @silene +/tools/coqwc* @silene +/test-suite/coqwc/ @silene # Secondary maintainer @gares +/tools/TimeFileMaker.py @JasonGross +/tools/make-both-single-timing-files.py @JasonGross +/tools/make-both-time-files.py @JasonGross +/tools/make-one-time-file.py @JasonGross + ########## Toplevel ########## /toplevel/ @ejgallego @@ -290,7 +325,7 @@ ########## Build system ########## /Makefile* @letouzey -# Secondary maintainer @maximdenes +# Secondary maintainer @gares /configure* @letouzey # Secondary maintainer @ejgallego @@ -301,6 +336,27 @@ /dev/build/windows @MSoegtropIMC # Secondary maintainer @maximedenes +# This file belongs to CI +/Makefile.ci @ejgallego +# Secondary maintainer @SkySkimmer + +# This file belongs to the doc +/Makefile.doc @maximedenes +# Secondary maintainer @silene + +########## Test suite ########## + +/test-suite/Makefile @gares +/test-suite/_CoqProject @gares +/test-suite/README.md @gares +# Secondary maintainer @SkySkimmer + +/test-suite/save-logs @SkySkimmer + +/test-suite/complexity/ @herbelin + +/test-suite/unit-tests/src/ @jfehrle +# Secondary maintainer @SkySkimmer ########## Developer tools ########## @@ -321,3 +377,6 @@ /dev/tools/pre-commit @SkySkimmer /dev/tools/sudo-apt-get-update @JasonGross + +/dev/tools/check-owners*.sh @SkySkimmer +# Secondary maintainer @maximedenes diff --git a/.github/PULL_REQUEST_TEMPLATE.md b/.github/PULL_REQUEST_TEMPLATE.md index a9230042a..4a8606a38 100644 --- a/.github/PULL_REQUEST_TEMPLATE.md +++ b/.github/PULL_REQUEST_TEMPLATE.md @@ -10,7 +10,10 @@ Fixes / closes #???? +<!-- If there is a user-visible change in coqc/coqtop/coqchk/coq_makefile behavior and testing is not prohibitively expensive: --> +<!-- (Otherwise, remove this line.) --> +- [ ] Added / updated test-suite <!-- If this is a feature pull request / breaks compatibility: --> <!-- (Otherwise, remove these lines.) --> -- [ ] Corresponding documentation was added / updated. +- [ ] Corresponding documentation was added / updated (including any warning and error messages added / removed / modified). - [ ] Entry added in CHANGES. diff --git a/.gitignore b/.gitignore index 267534365..6adbc9fb2 100644 --- a/.gitignore +++ b/.gitignore @@ -61,6 +61,7 @@ plugins/micromega/csdpcert plugins/micromega/.micromega.ml.generated kernel/byterun/dllcoqrun.so coqdoc.sty +coqdoc.css time-of-build.log time-of-build-pretty.log time-of-build-before.log @@ -87,6 +88,8 @@ test-suite/coqdoc/Coqdoc.* test-suite/coqdoc/index.html test-suite/coqdoc/coqdoc.css test-suite/output/MExtraction.out +test-suite/oUnit-anon.cache +test-suite/unit-tests/**/*.test # documentation @@ -96,21 +99,6 @@ doc/faq/axioms.eps doc/faq/axioms.eps_t doc/faq/axioms.pdf_t doc/faq/axioms.png -doc/refman/.csdp.cache -doc/refman/trace -doc/refman/Reference-Manual.ps -doc/refman/Reference-Manual.html -doc/refman/Reference-Manual.out -doc/refman/Reference-Manual.sh -doc/refman/cover.html -doc/refman/styles.hva -doc/refman/coqide-queries.eps -doc/refman/coqide.eps -doc/refman/euclid.ml -doc/refman/euclid.mli -doc/refman/heapsort.ml -doc/refman/heapsort.mli -doc/refman/html/ doc/stdlib/Library.out doc/stdlib/Library.ps doc/stdlib/Library.coqdoc.tex @@ -136,7 +124,7 @@ tools/coqwc.ml tools/coqdep_lexer.ml tools/ocamllibdep.ml tools/coqdoc/cpretty.ml -ide/xml_lexer.ml +ide/protocol/xml_lexer.ml # .ml4 / .mlp files @@ -177,9 +165,6 @@ dev/myinclude # coqide generated files (when testing) *.crashcoqide -/doc/refman/Reference-Manual.hoptind -/doc/refman/Reference-Manual.optidx -/doc/refman/Reference-Manual.optind user-contrib .*.sw* diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index f0d7463fc..06db0b7b7 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -1,80 +1,80 @@ -image: ocaml/opam:ubuntu - -# this doesn't seem to work -cache: - paths: - - .opamcache +image: "$IMAGE" stages: + - docker - build - test +# some default values variables: - # some default values - NJOBS: "2" - COMPILER: "system" - CAMLP5_VER: "6.14" - - # some useful values - COMPILER_32BIT: "4.02.3+32bit" - - COMPILER_BLEEDING_EDGE: "4.06.0" - CAMLP5_VER_BLEEDING_EDGE: "7.03" - - TIMING_PACKAGES: "time python" - - COQIDE_PACKAGES: "libgtk2.0-dev libgtksourceview2.0-dev" - #COQIDE_PACKAGES_32BIT: "libgtk2.0-dev:i386 libgtksourceview2.0-dev:i386" - COQIDE_OPAM: "lablgtk-extras" - COQIDE_OPAM_BE: "lablgtk.2.18.6 lablgtk-extras.1.6" - COQDOC_PACKAGES: "texlive-latex-base texlive-latex-recommended texlive-latex-extra texlive-math-extra texlive-fonts-recommended texlive-fonts-extra latex-xcolor ghostscript transfig imagemagick tipa python3-pip" - COQDOC_OPAM: "hevea" - SPHINX_PACKAGES: "bs4 sphinx sphinx_rtd_theme pexpect antlr4-python3-runtime sphinxcontrib-bibtex" - + # Format: $IMAGE-V$DATE [Cache is not used as of today but kept here + # for reference] + CACHEKEY: "bionic_coq-V2018-06-04-V2" + IMAGE: "$CI_REGISTRY_IMAGE:$CACHEKEY" + # By default, jobs run in the base switch; override to select another switch + OPAM_SWITCH: "base" + # Used to select special compiler switches such as flambda, 32bits, etc... + OPAM_VARIANT: "" + +docker-boot: + stage: docker + image: docker:stable + services: + - docker:dind + before_script: [] + script: + - docker login -u gitlab-ci-token -p "$CI_JOB_TOKEN" "$CI_REGISTRY" + - cd dev/ci/docker/bionic_coq/ + - if docker pull "$IMAGE"; then echo "Image prebuilt!"; exit 0; fi + - docker build -t "$IMAGE" . + - docker push "$IMAGE" + except: + variables: + - $SKIP_DOCKER == "true" + tags: + - docker before_script: - - ls # figure out if artifacts are around - - printenv -# - if [ "$COMPILER" = "$COMPILER_32BIT" ]; then sudo dpkg --add-architecture i386; fi - - if [ -n "${EXTRA_PACKAGES}" ]; then sudo apt-get update -qq && sudo apt-get install -y -qq ${EXTRA_PACKAGES}; fi - - if [ -n "${PIP_PACKAGES}" ]; then sudo pip3 install ${PIP_PACKAGES}; fi - - # setup cache - - if [ ! "(" -d .opamcache ")" ]; then mv ~/.opam .opamcache; else mv ~/.opam ~/.opam-old; fi - - ln -s $(readlink -f .opamcache) ~/.opam - - # the default repo in this docker image is a local directory - # at the time of 4aaeb8abf it lagged behind the official - # repository such that camlp5 7.01 was not available - - opam repository set-url default https://opam.ocaml.org - - opam update - - opam switch ${COMPILER} + - cat /proc/{cpu,mem}info || true + - ls -a # figure out if artifacts are around + - printenv -0 | sort -z | tr '\0' '\n' + - declare -A switch_table + - switch_table=( ["base"]="$COMPILER" ["edge"]="$COMPILER_EDGE" ) + - opam switch -y "${switch_table[$OPAM_SWITCH]}$OPAM_VARIANT" - eval $(opam config env) - - opam config list - - opam install -j ${NJOBS} -y camlp5.${CAMLP5_VER} ocamlfind num ${EXTRA_OPAM} - - rm -rf ~/.opam/log/ - opam list + - opam config list -# TODO figure out how to build doc for installed coq +################ GITLAB CACHING ###################### +# - use artifacts between jobs # +###################################################### + +# TODO figure out how to build doc for installed Coq .build-template: &build-template stage: build + retry: 1 artifacts: name: "$CI_JOB_NAME" paths: - _install_ci - config/Makefile + - config/coq_config.py - test-suite/misc/universes/all_stdlib.v expire_in: 1 week script: - set -e + - echo 'start:coq.clean' + - make clean # ensure that `make clean` works on a fresh clone + - echo 'end:coq.clean' + - echo 'start:coq.config' - - ./configure -prefix "$(pwd)/_install_ci" ${EXTRA_CONF} + - ./configure -prefix "$(pwd)/_install_ci" ${COQ_EXTRA_CONF}"$COQ_EXTRA_CONF_QUOTE" - echo 'end:coq.config' - echo 'start:coq.build' - - make -j ${NJOBS} byte - - make -j ${NJOBS} + - make -j "$NJOBS" byte + - make -j "$NJOBS" world $EXTRA_TARGET - make test-suite/misc/universes/all_stdlib.v - echo 'end:coq:build' @@ -89,41 +89,66 @@ before_script: .warnings-template: &warnings-template # keep warnings in test stage so we can test things even when warnings occur stage: test - dependencies: [] script: - set -e + - echo 'start:coq.clean' + - make clean # ensure that `make clean` works on a fresh clone + - echo 'end:coq.clean' + - echo 'start:coq.config' - - ./configure -local ${EXTRA_CONF} + - ./configure -local ${COQ_EXTRA_CONF} - echo 'end:coq.config' - echo 'start:coq.build' - - make -j ${NJOBS} coqocaml + - make -j "$NJOBS" coqocaml - echo 'end:coq:build' - set +e variables: &warnings-variables - EXTRA_CONF: "-native-compiler yes -coqide byte -byte-only" - EXTRA_PACKAGES: "$COQIDE_PACKAGES" - EXTRA_OPAM: "$COQIDE_OPAM" + COQ_EXTRA_CONF: "-native-compiler yes -coqide byte -byte-only -warn-error yes" + +# every non build job must set dependencies otherwise all build +# artifacts are used together and we may get some random Coq. To that +# purpose, we add a spurious dependency `not-a-real-job` that must be +# overridden otherwise the CI will fail. +.doc-templare: &doc-template + stage: test + dependencies: + - not-a-real-job + script: + - SPHINXENV='COQBIN="'"$PWD"'/_install_ci/bin/" COQBOOT=no' + - make -j "$NJOBS" SPHINXENV="$SPHINXENV" SPHINX_DEPS= sphinx + - make install-doc-sphinx + artifacts: + name: "$CI_JOB_NAME" + paths: + - _install_ci/share/doc/coq/ + +# set dependencies when using .test-suite-template: &test-suite-template stage: test + dependencies: + - not-a-real-job script: - cd test-suite - make clean # careful with the ending / - BIN=$(readlink -f ../_install_ci/bin)/ - LIB=$(readlink -f ../_install_ci/lib/coq)/ - - make -j ${NJOBS} BIN="$BIN" LIB="$LIB" all + - make -j "$NJOBS" BIN="$BIN" LIB="$LIB" all artifacts: name: "$CI_JOB_NAME.logs" when: on_failure paths: - test-suite/logs +# set dependencies when using .validate-template: &validate-template stage: test + dependencies: + - not-a-real-job script: - cd _install_ci - find lib/coq/ -name '*.vo' -print0 > vofiles @@ -135,179 +160,220 @@ before_script: script: - set -e - echo 'start:coq.test' - - make -f Makefile.ci -j ${NJOBS} ${TEST_TARGET} + - make -f Makefile.ci -j "$NJOBS" ${TEST_TARGET} - echo 'end:coq.test' - set +e dependencies: - - build + - build:base variables: &ci-template-vars TEST_TARGET: "$CI_JOB_NAME" - EXTRA_PACKAGES: "$TIMING_PACKAGES" -build: +.ci-template-flambda: &ci-template-flambda + <<: *ci-template + dependencies: + - build:edge+flambda + variables: + <<: *ci-template-vars + OPAM_SWITCH: "edge" + OPAM_VARIANT: "+flambda" + +.windows-template: &windows-template + stage: test + artifacts: + name: "%CI_JOB_NAME%" + paths: + - dev\nsis\*.exe + - coq-opensource-archive-windows-*.zip + expire_in: 1 week + dependencies: [] + tags: + - windows + before_script: [] + script: + - call dev/ci/gitlab.bat + only: + variables: + - $WINDOWS == "enabled" + +build:base: <<: *build-template variables: - EXTRA_CONF: "-native-compiler yes -coqide opt -with-doc yes" - EXTRA_PACKAGES: "$COQIDE_PACKAGES $COQDOC_PACKAGES" - EXTRA_OPAM: "$COQIDE_OPAM $COQDOC_OPAM" - PIP_PACKAGES: "$SPHINX_PACKAGES" + COQ_EXTRA_CONF: "-native-compiler yes -coqide opt" + # coqdoc for stdlib, until we know how to build it from installed Coq + EXTRA_TARGET: "stdlib" # no coqide for 32bit: libgtk installation problems -build:32bit: +build:base+32bit: + <<: *build-template + variables: + OPAM_VARIANT: "+32bit" + COQ_EXTRA_CONF: "-native-compiler yes" + +build:edge: <<: *build-template variables: - EXTRA_CONF: "-native-compiler yes" - EXTRA_PACKAGES: "gcc-multilib" - COMPILER: "$COMPILER_32BIT" + OPAM_SWITCH: edge + COQ_EXTRA_CONF: "-native-compiler yes -coqide opt" -build:bleeding-edge: +build:edge+flambda: <<: *build-template variables: - EXTRA_CONF: "-native-compiler yes -coqide opt" - COMPILER: "$COMPILER_BLEEDING_EDGE" - CAMLP5_VER: "$CAMLP5_VER_BLEEDING_EDGE" - EXTRA_PACKAGES: "$COQIDE_PACKAGES" - EXTRA_OPAM: "$COQIDE_OPAM_BE" + OPAM_SWITCH: edge + OPAM_VARIANT: "+flambda" + COQ_EXTRA_CONF: "-native-compiler no -coqide opt -flambda-opts " + COQ_EXTRA_CONF_QUOTE: "-O3 -unbox-closures" -warnings: +windows64: + <<: *windows-template + variables: + ARCH: "64" + +windows32: + <<: *windows-template + variables: + ARCH: "32" + +warnings:base: <<: *warnings-template # warnings:32bit: # <<: *warnings-template # variables: # <<: *warnings-variables -# EXTRA_PACKAGES: "$gcc-multilib COQIDE_PACKAGES_32BIT" -# COMPILER: "$COMPILER_32BIT" -warnings:bleeding-edge: +warnings:edge: <<: *warnings-template variables: <<: *warnings-variables - COMPILER: "$COMPILER_BLEEDING_EDGE" - CAMLP5_VER: "$CAMLP5_VER_BLEEDING_EDGE" - EXTRA_OPAM: "$COQIDE_OPAM_BE" + OPAM_SWITCH: edge + +documentation: + <<: *doc-template + dependencies: + - build:base + +test-suite:base: + <<: *test-suite-template + dependencies: + - build:base -test-suite: +test-suite:base+32bit: <<: *test-suite-template dependencies: - - build + - build:base+32bit variables: - EXTRA_PACKAGES: "$TIMING_PACKAGES" + OPAM_VARIANT: "+32bit" -test-suite:32bit: +test-suite:edge: <<: *test-suite-template dependencies: - - build:32bit + - build:edge variables: - COMPILER: "$COMPILER_32BIT" - EXTRA_PACKAGES: "gcc-multilib $TIMING_PACKAGES" + OPAM_SWITCH: edge -test-suite:bleeding-edge: +test-suite:edge+flambda: <<: *test-suite-template dependencies: - - build:bleeding-edge + - build:edge+flambda + variables: + OPAM_SWITCH: edge + OPAM_VARIANT: "+flambda" + +validate:base: + <<: *validate-template + dependencies: + - build:base + +validate:base+32bit: + <<: *validate-template + dependencies: + - build:base+32bit variables: - COMPILER: "$COMPILER_BLEEDING_EDGE" - CAMLP5_VER: "$CAMLP5_VER_BLEEDING_EDGE" - EXTRA_PACKAGES: "$TIMING_PACKAGES" + OPAM_VARIANT: "+32bit" -validate: +validate:edge: <<: *validate-template dependencies: - - build + - build:edge + variables: + OPAM_SWITCH: edge -validate:32bit: +validate:edge+flambda: <<: *validate-template dependencies: - - build:32bit + - build:edge+flambda variables: - COMPILER: "$COMPILER_32BIT" - EXTRA_PACKAGES: "gcc-multilib" + OPAM_SWITCH: edge + OPAM_VARIANT: "+flambda" ci-bignums: <<: *ci-template ci-color: - <<: *ci-template - variables: - <<: *ci-template-vars - EXTRA_PACKAGES: "$TIMING_PACKAGES" + <<: *ci-template-flambda ci-compcert: - <<: *ci-template + <<: *ci-template-flambda ci-coq-dpdgraph: <<: *ci-template - variables: - <<: *ci-template-vars - EXTRA_OPAM: "ocamlgraph" - EXTRA_PACKAGES: "$TIMING_PACKAGES autoconf" ci-coquelicot: <<: *ci-template - variables: - <<: *ci-template-vars - EXTRA_PACKAGES: "$TIMING_PACKAGES autoconf" + +ci-cross-crypto: + <<: *ci-template ci-elpi: <<: *ci-template - variables: - <<: *ci-template-vars - EXTRA_OPAM: "ppx_tools_versioned ppx_deriving ocaml-migrate-parsetree" ci-equations: <<: *ci-template -ci-geocoq: +ci-fcsl-pcm: <<: *ci-template - allow_failure: true -# ci-fiat-crypto: -# <<: *ci-template -# # out of memory error -# allow_failure: true +ci-fiat-crypto: + <<: *ci-template-flambda ci-fiat-parsers: <<: *ci-template - variables: - <<: *ci-template-vars - EXTRA_PACKAGES: "$TIMING_PACKAGES" ci-flocq: <<: *ci-template - variables: - <<: *ci-template-vars - EXTRA_PACKAGES: "$TIMING_PACKAGES autoconf" ci-formal-topology: - <<: *ci-template + <<: *ci-template-flambda + +ci-geocoq: + <<: *ci-template-flambda ci-hott: <<: *ci-template - variables: - <<: *ci-template-vars - EXTRA_PACKAGES: "$TIMING_PACKAGES autoconf" ci-iris-lambda-rust: - <<: *ci-template + <<: *ci-template-flambda ci-ltac2: <<: *ci-template -ci-math-classes: +ci-math-comp: + <<: *ci-template-flambda + +ci-mtac2: <<: *ci-template -ci-math-comp: +ci-pidetop: <<: *ci-template +ci-quickchick: + <<: *ci-template-flambda + ci-sf: <<: *ci-template - variables: - <<: *ci-template-vars - EXTRA_PACKAGES: "$TIMING_PACKAGES wget" ci-unimath: - <<: *ci-template + <<: *ci-template-flambda ci-vst: - <<: *ci-template + <<: *ci-template-flambda @@ -10,8 +10,6 @@ S kernel B kernel S kernel/byterun B kernel/byterun -S intf -B intf S library B library S engine @@ -34,6 +32,8 @@ S vernac B vernac S toplevel B toplevel +S topbin +B topbin S plugins/ltac B plugins/ltac S API diff --git a/.travis.yml b/.travis.yml index 41814e954..86a2aea66 100644 --- a/.travis.yml +++ b/.travis.yml @@ -39,35 +39,41 @@ env: - NJOBS=2 # system is == 4.02.3 - COMPILER="system" - - COMPILER_BE="4.06.0" + - COMPILER_BE="4.06.1" - CAMLP5_VER=".6.14" - - CAMLP5_VER_BE=".7.03" + - CAMLP5_VER_BE=".7.05" - FINDLIB_VER=".1.4.1" - - FINDLIB_VER_BE=".1.7.3" + - FINDLIB_VER_BE=".1.8.0" - LABLGTK="lablgtk.2.18.3 lablgtk-extras.1.6" - LABLGTK_BE="lablgtk.2.18.6 lablgtk-extras.1.6" - NATIVE_COMP="yes" - COQ_DEST="-local" - MAIN_TARGET="world" - # Main test suites - matrix: - - TEST_TARGET="test-suite" COMPILER="4.02.3+32bit" - - TEST_TARGET="validate" TW="travis_wait" - - TEST_TARGET="validate" COMPILER="4.02.3+32bit" TW="travis_wait" - - TEST_TARGET="validate" COMPILER="${COMPILER_BE}+flambda" CAMLP5_VER="${CAMLP5_VER_BE}" NATIVE_COMP="no" EXTRA_CONF="-flambda-opts -O3" EXTRA_OPAM="num" FINDLIB_VER="${FINDLIB_VER_BE}" matrix: include: - if: NOT (type = pull_request) env: + - TEST_TARGET="test-suite" COMPILER="4.02.3+32bit" EXTRA_OPAM="ounit" + - if: NOT (type = pull_request) + env: + - TEST_TARGET="validate" TW="travis_wait" + - if: NOT (type = pull_request) + env: + - TEST_TARGET="validate" COMPILER="4.02.3+32bit" TW="travis_wait" + - if: NOT (type = pull_request) + env: + - TEST_TARGET="validate" COMPILER="${COMPILER_BE}+flambda" CAMLP5_VER="${CAMLP5_VER_BE}" NATIVE_COMP="no" EXTRA_CONF="-flambda-opts -O3" FINDLIB_VER="${FINDLIB_VER_BE}" + - if: NOT (type = pull_request) + env: - TEST_TARGET="ci-bignums" - if: NOT (type = pull_request) env: - TEST_TARGET="ci-color" - if: NOT (type = pull_request) env: - - TEST_TARGET="ci-compcert" + - TEST_TARGET="ci-compcert" EXTRA_OPAM="menhir" - if: NOT (type = pull_request) env: - TEST_TARGET="ci-coq-dpdgraph" EXTRA_OPAM="ocamlgraph" @@ -76,18 +82,15 @@ matrix: - TEST_TARGET="ci-coquelicot" - if: NOT (type = pull_request) env: + - TEST_TARGET="ci-elpi" EXTRA_OPAM="elpi" # ppx_tools_versioned requires a specific version findlib - FINDLIB_VER="" - - TEST_TARGET="ci-elpi" EXTRA_OPAM="ppx_tools_versioned ppx_deriving ocaml-migrate-parsetree" - if: NOT (type = pull_request) env: - TEST_TARGET="ci-equations" - if: NOT (type = pull_request) env: - - TEST_TARGET="ci-geocoq" - - if: NOT (type = pull_request) - env: - - TEST_TARGET="ci-fiat-crypto" + - TEST_TARGET="ci-fcsl-pcm" - if: NOT (type = pull_request) env: - TEST_TARGET="ci-fiat-parsers" @@ -96,31 +99,22 @@ matrix: - TEST_TARGET="ci-flocq" - if: NOT (type = pull_request) env: - - TEST_TARGET="ci-formal-topology" - - if: NOT (type = pull_request) - env: - TEST_TARGET="ci-hott" - if: NOT (type = pull_request) env: - - TEST_TARGET="ci-iris-lambda-rust" - - if: NOT (type = pull_request) - env: - TEST_TARGET="ci-ltac2" - if: NOT (type = pull_request) env: - TEST_TARGET="ci-math-classes" - if: NOT (type = pull_request) env: - - TEST_TARGET="ci-math-comp" + - TEST_TARGET="ci-mtac2" - if: NOT (type = pull_request) env: - - TEST_TARGET="ci-sf" - - if: NOT (type = pull_request) - env: - - TEST_TARGET="ci-unimath" + - TEST_TARGET="ci-pidetop" - if: NOT (type = pull_request) env: - - TEST_TARGET="ci-vst" + - TEST_TARGET="ci-sf" - env: - TEST_TARGET="lint" @@ -134,10 +128,11 @@ matrix: - dev/lint-repository.sh # Full Coq test-suite with two compilers - - env: + - if: NOT (type = pull_request) + env: - TEST_TARGET="test-suite" - EXTRA_CONF="-coqide opt -with-doc yes" - - EXTRA_OPAM="hevea ${LABLGTK}" + - EXTRA_OPAM="${LABLGTK} ounit" before_install: &sphinx-install - sudo pip3 install bs4 sphinx sphinx_rtd_theme pexpect antlr4-python3-runtime sphinxcontrib-bibtex addons: @@ -157,20 +152,19 @@ matrix: - texlive-fonts-extra - latex-xcolor - ghostscript - - transfig - - imagemagick - tipa - python3 - python3-pip - python3-setuptools - - env: + - if: NOT (type = pull_request) + env: - TEST_TARGET="test-suite" - COMPILER="${COMPILER_BE}" - FINDLIB_VER="${FINDLIB_VER_BE}" - CAMLP5_VER="${CAMLP5_VER_BE}" - EXTRA_CONF="-coqide opt -with-doc yes" - - EXTRA_OPAM="num hevea ${LABLGTK_BE}" + - EXTRA_OPAM="${LABLGTK_BE} ounit" before_install: *sphinx-install addons: apt: @@ -179,14 +173,15 @@ matrix: packages: *extra-packages # Full test-suite with flambda - - env: + - if: NOT (type = pull_request) + env: - TEST_TARGET="test-suite" - COMPILER="${COMPILER_BE}+flambda" - FINDLIB_VER="${FINDLIB_VER_BE}" - CAMLP5_VER="${CAMLP5_VER_BE}" - NATIVE_COMP="no" - EXTRA_CONF="-coqide opt -with-doc yes -flambda-opts -O3" - - EXTRA_OPAM="num hevea ${LABLGTK_BE}" + - EXTRA_OPAM="${LABLGTK_BE} ounit" before_install: *sphinx-install addons: apt: @@ -195,12 +190,11 @@ matrix: packages: *extra-packages # Ocaml warnings with two compilers - - env: + - if: NOT (type = pull_request) + env: - MAIN_TARGET="coqocaml" - EXTRA_CONF="-byte-only -coqide byte -warn-error yes" - - EXTRA_OPAM="hevea ${LABLGTK}" - # dummy target - - BUILD_TARGET="clean" + - EXTRA_OPAM="${LABLGTK}" addons: apt: sources: @@ -211,15 +205,14 @@ matrix: - libgtk2.0-dev - libgtksourceview2.0-dev - - env: + - if: NOT (type = pull_request) + env: - MAIN_TARGET="coqocaml" - COMPILER="${COMPILER_BE}" - FINDLIB_VER="${FINDLIB_VER_BE}" - CAMLP5_VER="${CAMLP5_VER_BE}" - EXTRA_CONF="-byte-only -coqide byte -warn-error yes" - - EXTRA_OPAM="num hevea ${LABLGTK_BE}" - # dummy target - - BUILD_TARGET="clean" + - EXTRA_OPAM="${LABLGTK_BE}" addons: apt: sources: @@ -233,8 +226,10 @@ matrix: - CAMLP5_VER=".6.17" - NATIVE_COMP="no" - COQ_DEST="-local" + - EXTRA_OPAM="ounit" before_install: - brew update + - brew unlink python - brew install opam gnu-time - if: NOT (type = pull_request) @@ -274,14 +269,19 @@ install: - if [ "${TRAVIS_OS_NAME}" == "linux" ]; then travis_retry ./dev/tools/sudo-apt-get-update.sh -q; fi - if [ "${TRAVIS_OS_NAME}" == "linux" ]; then sudo apt-get install -y opam aspcud gcc-multilib; fi - opam init -j ${NJOBS} --compiler=${COMPILER} -n -y +- opam switch "$COMPILER" && opam update - eval $(opam config env) - opam config list -- opam install -j ${NJOBS} -y camlp5${CAMLP5_VER} ocamlfind${FINDLIB_VER} ${EXTRA_OPAM} +- opam install -j ${NJOBS} -y num ocamlfind${FINDLIB_VER} jbuilder camlp5${CAMLP5_VER} ${EXTRA_OPAM} - opam list script: - set -e +- echo 'Testing make clean...' && echo -en 'travis_fold:start:coq.clean\\r' +- make clean # ensure that `make clean` works on a fresh clone +- echo -en 'travis_fold:end:coq.clean\\r' + - echo 'Configuring Coq...' && echo -en 'travis_fold:start:coq.config\\r' - ./configure ${COQ_DEST} -native-compiler ${NATIVE_COMP} ${EXTRA_CONF} - echo -en 'travis_fold:end:coq.config\\r' @@ -1,22 +1,92 @@ Changes from 8.8.2 to 8.9+beta1 =============================== +Tactics + +- Added toplevel goal selector ! which expects a single focused goal. + Use with Set Default Goal Selector to force focusing before tactics + are called. + +- The undocumented "nameless" forms `fix N`, `cofix` that were + deprecated in 8.8 have been removed from LTAC's syntax; please use + `fix ident N/cofix ident` to explicitely name the (co)fixpoint + hypothesis to be introduced. + +- Introduction tactics "intro"/"intros" on a goal which is an + existential variable now force a refinement of the goal into a + dependent product rather than failing. + +- Support for fix/cofix added in Ltac "match" and "lazymatch". + +- Ltac backtraces now include trace information about tactics + called by OCaml-defined tactics. + +- Option "Ltac Debug" now applies also to terms built using Ltac functions. + +- Deprecated the Implicit Tactic family of commands. + +- The `simple apply` tactic now respects the `Opaque` flag when called from + Ltac (`auto` still does not respect it). + Tools - Coq_makefile lets one override or extend the following variables from the command line: COQFLAGS, COQCHKFLAGS, COQDOCFLAGS. + COQFLAGS is now entirely separate from COQLIBS, so in custom Makefiles + $(COQFLAGS) should be replaced by $(COQFLAGS) $(COQLIBS). Vernacular Commands - Removed deprecated commands Arguments Scope and Implicit Arguments (not the option). Use the Arguments command instead. +- Nested proofs may be enabled through the option `Nested Proofs Allowed`. + By default, they are disabled and produce an error. The deprecation + warning which used to occur when using nested proofs has been removed. + +Coq binaries and process model + +- Before 8.9, Coq distributed a single `coqtop` binary and a set of + dynamically loadable plugins that used to take over the main loop + for tasks such as IDE language server or parallel proof checking. + + These plugins have been turned into full-fledged binaries so each + different process has associated a particular binary now, in + particular `coqidetop` is the CoqIDE language server, and + `coq{proof,tactic,query}worker` are in charge of task-specific and + parallel proof checking. + +Changes from 8.8.0 to 8.8.1 +=========================== + +Kernel + +- Fix a critical bug with cofixpoints and vm_compute/native_compute (#7333). + +Notations + +- Fixed unexpected collision between only-parsing and only-printing + notations (issue #7462). + +Changes from 8.8+beta1 to 8.8.0 +=============================== + +Tools + +- Asynchronous proof delegation policy was fixed. Since version 8.7 + Coq was ignoring previous runs and the -async-proofs-delegation-threshold + option did not have the expected behavior. Tactic language -- Support for fix/cofix added in Ltac "match" and "lazymatch". +- The undocumented "nameless" forms `fix N`, `cofix` have been + deprecated; please use `fix ident N /cofix ident` to explicitely + name the (co)fixpoint hypothesis to be introduced. -- Ltac backtraces now contain include trace information about tactics - called by OCaml-defined tactics. +Documentation + +- The reference manual is now fully ported to Sphinx. + +Other small deprecations and bug fixes. Changes from 8.7.2 to 8.8+beta1 =============================== @@ -60,7 +130,7 @@ Tactics profiling, and "Set NativeCompute Profile Filename" customizes the profile filename. - The tactic "omega" is now aware of the bodies of context variables - such as "x := 5 : Z" (see BZ#148). This could be disabled via + such as "x := 5 : Z" (see #1362). This could be disabled via Unset Omega UseLocalDefs. - The tactic "romega" is also aware now of the bodies of context variables. - The tactic "zify" resp. "omega with N" is now aware of N.pred. @@ -84,6 +154,7 @@ Tactics of the execution. - `vm_compute` now supports existential variables. - Calls to `shelve` and `give_up` within calls to tactic `refine` now working. +- Deprecated tactic `appcontext` was removed. Focusing @@ -187,6 +258,7 @@ Options + `Refolding Reduction` + `Standard Proposition Elimination` + + `Dependent Propositions Elimination` + `Discriminate Introduction` + `Shrink Abstract` + `Tactic Pattern Unification` @@ -194,6 +266,7 @@ Options + `Injection L2R Pattern Order` + `Record Elimination Schemes` + `Match Strict` + + `Tactic Compat Context` + `Typeclasses Legacy Resolution` + `Typeclasses Module Eta` + `Typeclass Resolution After Apply` @@ -242,7 +315,7 @@ Improvements around some error messages. Many bug fixes including two important ones: -- BZ#5730: CoqIDE becomes unresponsive on file open. +- Bug #5730: CoqIDE becomes unresponsive on file open. - coq_makefile: make sure compile flags for Coq and coq_makefile are in sync (in particular, make sure the `-safe-string` option is used to compile plugins). @@ -292,7 +365,7 @@ Tactics which behave like the corresponding variants with no "e" but turn unresolved implicit arguments into existential variables, on the shelf, rather than failing. -- Tactic injection has become more powerful (closes BZ#4890) and its +- Tactic injection has become more powerful (closes bug #4890) and its documentation has been updated. - New variants of the `first` and `solve` tacticals that do not rely on parsing rules, meant to define tactic notations. @@ -338,7 +411,7 @@ Standard Library file ChoiceFacts.v. - New lemmas about iff and about orders on positive and Z. - New lemmas on powerRZ. -- Strengthened statement of JMeq_eq_dep (closes BZ#4912). +- Strengthened statement of JMeq_eq_dep (closes bug #4912). - The BigN, BigZ, BigZ libraries are no longer part of the Coq standard library, they are now provided by a separate repository https://github.com/coq/bignums @@ -413,12 +486,12 @@ XML Protocol and internal changes See dev/doc/changes.txt -Many bugfixes including BZ#1859, BZ#2884, BZ#3613, BZ#3943, BZ#3994, -BZ#4250, BZ#4709, BZ#4720, BZ#4824, BZ#4844, BZ#4911, BZ#5026, BZ#5233, -BZ#5275, BZ#5315, BZ#5336, BZ#5360, BZ#5390, BZ#5414, BZ#5417, BZ#5420, -BZ#5439, BZ#5449, BZ#5475, BZ#5476, BZ#5482, BZ#5501, BZ#5507, BZ#5520, -BZ#5523, BZ#5524, BZ#5553, BZ#5577, BZ#5578, BZ#5589, BZ#5597, BZ#5598, -BZ#5607, BZ#5618, BZ#5619, BZ#5620, BZ#5641, BZ#5648, BZ#5651, BZ#5671. +Many bugfixes including #1859, #2884, #3613, #3943, #3994, +#4250, #4709, #4720, #4824, #4844, #4911, #5026, #5233, +#5275, #5315, #5336, #5360, #5390, #5414, #5417, #5420, +#5439, #5449, #5475, #5476, #5482, #5501, #5507, #5520, +#5523, #5524, #5553, #5577, #5578, #5589, #5597, #5598, +#5607, #5618, #5619, #5620, #5641, #5648, #5651, #5671. Many bugfixes on OS X and Windows (now the test-suite passes on these platforms too). @@ -2594,7 +2667,7 @@ Tactics a registered setoid equality before starting to reduce in H. This is unlikely to break any script. Should this happen nonetheless, one can insert manually some "unfold ... in H" before rewriting. -- Fixed various bugs about (setoid) rewrite ... in ... (in particular BZ#1101) +- Fixed various bugs about (setoid) rewrite ... in ... (in particular bug #5941) - "rewrite ... in" now accepts a clause as place where to rewrite instead of juste a simple hypothesis name. For instance: rewrite H in H1,H2 |- * means rewrite H in H1; rewrite H in H2; rewrite H @@ -3171,11 +3244,11 @@ Incompatibilities Bugs - Improved localisation of errors in Syntactic Definitions -- Induction principle creation failure in presence of let-in fixed (BZ#238) -- Inversion bugs fixed (BZ#212 and BZ#220) -- Omega bug related to Set fixed (BZ#180) -- Type-checking inefficiency of nested destructuring let-in fixed (BZ#216) -- Improved handling of let-in during holes resolution phase (BZ#239) +- Induction principle creation failure in presence of let-in fixed (#1459) +- Inversion bugs fixed (#1427 and #1437) +- Omega bug related to Set fixed (#1384) +- Type-checking inefficiency of nested destructuring let-in fixed (#1435) +- Improved handling of let-in during holes resolution phase (#1460) Efficiency @@ -3188,18 +3261,18 @@ Changes from V7.3 to V7.3.1 Bug fixes - Corrupted Field tactic and Match Context tactic construction fixed - - Checking of names already existing in Assert added (BZ#182) - - Invalid argument bug in Exact tactic solved (BZ#183) - - Colliding bound names bug fixed (BZ#202) - - Wrong non-recursivity test for Record fixed (BZ#189) - - Out of memory/seg fault bug related to parametric inductive fixed (BZ#195) + - Checking of names already existing in Assert added (#1386) + - Invalid argument bug in Exact tactic solved (#1387) + - Colliding bound names bug fixed (#1412) + - Wrong non-recursivity test for Record fixed (#1394) + - Out of memory/seg fault bug related to parametric inductive fixed (#1404) - Setoid_replace/Setoid_rewrite bug wrt "==" fixed Misc - Ocaml version >= 3.06 is needed to compile Coq from sources - Simplification of fresh names creation strategy for Assert, Pose and - LetTac (BZ#192) + LetTac (#1402) Changes from V7.2 to V7.3 ========================= diff --git a/CONTRIBUTING.md b/CONTRIBUTING.md index 1a3c99369..2dffd2019 100644 --- a/CONTRIBUTING.md +++ b/CONTRIBUTING.md @@ -22,15 +22,30 @@ If you want to minimize your bug (or help minimize someone else's) for more extr If you want to contribute a bug fix or feature yourself, pull requests on the [GitHub repository](https://github.com/coq/coq) are the way to contribute directly to the Coq implementation. We recommend you create a fork of the repository on GitHub and push your changes to a new "topic branch" in that fork. From there you can follow the [GitHub pull request documentation](https://help.github.com/articles/about-pull-requests/) to get your changes reviewed and pulled into the Coq source repository. -Documentation for getting started with the Coq sources is located in various files in [`dev/doc`](/dev/doc) (for example, [debugging.md](/dev/doc/debugging.md)). For further help with the Coq sources, feel free to join the [Coq Gitter chat](https://gitter.im/coq/coq) and ask questions. +Documentation for getting started with the Coq sources is located in various +files in [`dev/doc`](dev/doc) (for example, [debugging.md](dev/doc/debugging.md)). +For further help with the Coq sources, feel free to join +the [Coq Gitter chat](https://gitter.im/coq/coq) and ask questions. Please make pull requests against the `master` branch. -If it's your first significant contribution to Coq (significant means: more than fixing a typo), your pull request should include a commit adding your name to the [`CREDITS`](/CREDITS) file (possibly with the name of your institution / employer if relevant to your contribution, an ORCID if you have one —you may log into https://orcid.org/ using your institutional account to get one—, and the year of your contribution). +If it's your first significant contribution to Coq (significant means: more +than fixing a typo), your pull request should include a commit adding your name +to the [`CREDITS`](CREDITS) file (possibly with the name of your +institution / employer if relevant to your contribution, an ORCID if you have +one —you may log into https://orcid.org/ using your institutional account to +get one—, and the year of your contribution). -It's helpful to run the Coq test suite with `make test-suite` before submitting your change. Travis CI runs this test suite and a much larger one including external Coq developments on every pull request, but these results take significantly longer to come back (on the order of a few hours). Running the test suite locally will take somewhere around 10-15 minutes. Refer to [`dev/ci/README.md`](/dev/ci/README.md#information-for-developers) for more information on Travis CI tests. +It's helpful to run the Coq test suite with `make test-suite` before submitting +your change. Our CI runs this test suite and lots of other tests, including +building external Coq developments, on every pull request, but these results +take significantly longer to come back (on the order of a few hours). Running +the test suite locally will take somewhere around 10-15 minutes. Refer to +[`dev/ci/README.md`](dev/ci/README.md#information-for-developers) for more +information on CI tests, including how to run them on your private branches. -If your pull request fixes a bug, please consider adding a regression test as well. See [`test-suite/README.md`](/test-suite/README.md) for how to do so. +If your pull request fixes a bug, please consider adding a regression test as +well. See [`test-suite/README.md`](test-suite/README.md) for how to do so. Don't be alarmed if the pull request process takes some time. It can take a few days to get feedback, approval on the final changes, and then a merge. Coq doesn't release new versions very frequently so it can take a few months for your change to land in a released version. That said, you can start using the latest Coq `master` branch to take advantage of all the new features, improvements, and fixes. @@ -42,7 +57,8 @@ Here are a few tags Coq developers may add to your PR and what they mean. In gen - [needs: fixing](https://github.com/coq/coq/pulls?q=is%3Aopen+is%3Apr+label%3A%22needs%3A+fixing%22) indicates the PR needs a fix, as discussed in the comments. - [needs: benchmarking](https://github.com/coq/coq/pulls?q=is%3Aopen+is%3Apr+label%3A%22needs%3A+benchmarking%22) and [needs: testing](https://github.com/coq/coq/pulls?q=is%3Aopen+is%3Apr+label%3A%22needs%3A+testing%22) indicate the PR needs testing beyond what the test suite can handle. For example, performance benchmarking is currently performed with a different infrastructure. Unless some followup is specifically requested you aren't expected to do this additional testing. -To learn more about the merging process, you can read the [merging documentation for Coq maintainers](/dev/doc/MERGING.md). +To learn more about the merging process, you can read the +[merging documentation for Coq maintainers](dev/doc/MERGING.md). ## Documentation @@ -54,6 +70,20 @@ The sources for the [Coq reference manual](https://coq.inria.fr/distrib/current/ You may also contribute to the informal documentation available in [Cocorico](https://github.com/coq/coq/wiki) (the Coq wiki), and the [Coq FAQ](https://github.com/coq/coq/wiki/The-Coq-FAQ). Both of these are editable by anyone with a GitHub account. +## Following the development + +If you want to follow the development activity around Coq, you are encouraged +to subscribe to the [Coqdev mailing list](https://sympa.inria.fr/sympa/info/coqdev). +This mailing list has reasonably low traffic. + +You may also choose to use GitHub feature to +["watch" this repository](https://github.com/coq/coq/subscription), but be +advised that this means receiving a very large number of notifications. +GitHub gives [some advice](https://blog.github.com/2017-07-18-managing-large-numbers-of-github-notifications/#prioritize-the-notifications-you-receive) +on how to configure your e-mail client to filter these notifications. +A possible alternative is to deactivate e-mail notifications and manage your +GitHub web notifications using a tool such as [Octobox](http://octobox.io/). + ## Contributing outside this repository There are many useful ways to contribute to the Coq ecosystem that don't involve the Coq repository. @@ -128,6 +128,8 @@ of the Coq Proof assistant during the indicated time: Matej Košík (INRIA, 2015-2017) Pierre Letouzey (LRI, 2000-2004, PPS, 2005-2008, INRIA-PPS then IRIF, 2009-now) + Yishuai Li (ORCID: https://orcid.org/0000-0002-5728-5903 + U. Penn, 2018) Patrick Loiseleur (Paris Sud, 1997-1999) Evgeny Makarov (INRIA, 2007) Gregory Malecha (Harvard University 2013-2015, @@ -148,6 +150,7 @@ of the Coq Proof assistant during the indicated time: Pierre-Marie Pédrot (INRIA-PPS, 2011-2015, INRIA-Ascola, 2015-2016, University of Ljubljana, 2016-2017, MPI-SWS, 2017-2018) + Clément Pit-Claudel (MIT, 2015-2018) Matthias Puech (INRIA-Bologna, 2008-2011) Yann Régis-Gianas (INRIA-PPS then IRIF, 2009-now) Clément Renard (INRIA, 2001-2004) diff --git a/INSTALL.doc b/INSTALL.doc index b71115bfa..13e6440d0 100644 --- a/INSTALL.doc +++ b/INSTALL.doc @@ -4,13 +4,13 @@ The Coq documentation includes - A Reference Manual -- A Tutorial - A document presenting the Coq standard library -- A list of questions/answers in the FAQ style -The sources of the documents are mainly made of LaTeX code from which -user-readable PostScript or PDF files, or a user-browsable bunch of -html files are generated. +The reference manual is written is reStructuredText and compiled +using Sphinx (see `doc/sphinx/README.rst`) to learn more. + +The documentation for the standard library is generated from +the `.v` source files using coqdoc. Prerequisite ------------ @@ -20,12 +20,7 @@ To produce all the documents, the following tools are needed: - latex (latex2e) - pdflatex - dvips - - bibtex - makeindex - - fig2dev (transfig) - - convert (ImageMagick) - - hevea - - hacha - Python 3 - Sphinx 1.6.5 (http://www.sphinx-doc.org/en/stable/) - sphinx_rtd_theme @@ -34,17 +29,26 @@ To produce all the documents, the following tools are needed: - Antlr4 runtime for Python 3 -Under Debian based operating systems (Debian, Ubuntu, ...) a -working set of packages for compiling the documentation for Coq is: +Under recent Debian based operating systems (Debian 10 "Buster", +Ubuntu 18.04, ...) a working set of packages for compiling the +documentation for Coq is: + + texlive-latex-extra texlive-fonts-recommended python3-sphinx + python3-pexpect python3-sphinx-rtd-theme python3-bs4 + python3-sphinxcontrib.bibtex python3-pip + +Then, install the Python3 Antlr4 package: - texlive texlive-latex-extra texlive-math-extra texlive-fonts-extra - texlive-humanities texlive-pictures latex-xcolor hevea transfig - imagemagick - python3 python-pip3 + pip3 install antlr4-python3-runtime -To install the Python packages required to build the user manual, run: - pip3 install sphinx sphinx_rtd_theme beautifulsoup4 antlr4-python3-runtime pexpect +Nix users should get the correct development environment to build the +HTML documentation from Coq's `default.nix`. [Note Nix setup doesn't +include the LaTeX packages needed to build the full documentation.] +If you are in an older/different distribution you can install the +Python packages required to build the user manual using python3-pip: + + pip3 install sphinx sphinx_rtd_theme beautifulsoup4 antlr4-python3-runtime pexpect sphinxcontrib-bibtex Compilation ----------- @@ -66,17 +70,8 @@ Alternatively, you can use some specific targets: make doc-html to produce all html documents - make refman - to produce all formats of the reference manual - - make tutorial - to produce all formats of the tutorial - - make rectutorial - to produce all formats of the tutorial on recursive types - - make faq - to produce all formats of the FAQ + make sphinx + to produce the HTML version of the reference manual make stdlib to produce all formats of the Coq standard library @@ -93,7 +88,4 @@ To install all produced documents, do: make DOCDIR=/some/directory/for/documentation install-doc -DOCDIR defauts to /usr/share/doc/coq - - - +DOCDIR defaults to /usr/share/doc/coq @@ -1,15 +1,27 @@ # TODO: Generate automatically with Dune description = "The Coq Proof Assistant Plugin API" -version = "8.8" +version = "8.9" directory = "" requires = "camlp5" +package "grammar" ( + + description = "Coq Camlp5 Grammar Extensions for Plugins" + version = "8.9" + + requires = "camlp5.gramlib" + directory = "grammar" + + archive(byte) = "grammar.cma" + archive(native) = "grammar.cmxa" +) + package "config" ( description = "Coq Configuration Variables" - version = "8.8" + version = "8.9" directory = "config" @@ -17,7 +29,7 @@ package "config" ( package "clib" ( description = "Base General Coq Library" - version = "8.8" + version = "8.9" directory = "clib" requires = "num, str, unix, threads" @@ -29,7 +41,7 @@ package "clib" ( package "lib" ( description = "Base Coq-Specific Library" - version = "8.8" + version = "8.9" directory = "lib" @@ -43,7 +55,7 @@ package "lib" ( package "vm" ( description = "Coq VM" - version = "8.8" + version = "8.9" directory = "kernel/byterun" @@ -57,15 +69,12 @@ package "vm" ( # We currently prefer static linking of the VM. archive(byte) = "libcoqrun.a" linkopts(byte) = "-custom" - - linkopts(native) = "-cclib -lcoqrun" - ) package "kernel" ( description = "Coq's Kernel" - version = "8.8" + version = "8.9" directory = "kernel" @@ -79,7 +88,7 @@ package "kernel" ( package "library" ( description = "Coq Libraries (vo) support" - version = "8.8" + version = "8.9" requires = "coq.kernel" @@ -90,23 +99,10 @@ package "library" ( ) -package "intf" ( - - description = "Coq Public Data Types" - version = "8.8" - - requires = "coq.library" - - directory = "intf" - - archive(byte) = "intf.cma" - archive(native) = "intf.cmxa" -) - package "engine" ( description = "Coq Tactic Engine" - version = "8.8" + version = "8.9" requires = "coq.library" directory = "engine" @@ -119,7 +115,7 @@ package "engine" ( package "pretyping" ( description = "Coq Pretyper" - version = "8.8" + version = "8.9" requires = "coq.engine" directory = "pretyping" @@ -132,7 +128,7 @@ package "pretyping" ( package "interp" ( description = "Coq Term Interpretation" - version = "8.8" + version = "8.9" requires = "coq.pretyping" directory = "interp" @@ -142,22 +138,10 @@ package "interp" ( ) -package "grammar" ( - - description = "Coq Base Grammar" - version = "8.8" - - requires = "coq.interp" - directory = "grammar" - - archive(byte) = "grammar.cma" - archive(native) = "grammar.cmxa" -) - package "proofs" ( description = "Coq Proof Engine" - version = "8.8" + version = "8.9" requires = "coq.interp" directory = "proofs" @@ -170,7 +154,7 @@ package "proofs" ( package "parsing" ( description = "Coq Parsing Engine" - version = "8.8" + version = "8.9" requires = "camlp5.gramlib, coq.proofs" directory = "parsing" @@ -183,7 +167,7 @@ package "parsing" ( package "printing" ( description = "Coq Printing Engine" - version = "8.8" + version = "8.9" requires = "coq.parsing" directory = "printing" @@ -196,7 +180,7 @@ package "printing" ( package "tactics" ( description = "Coq Basic Tactics" - version = "8.8" + version = "8.9" requires = "coq.printing" directory = "tactics" @@ -209,7 +193,7 @@ package "tactics" ( package "vernac" ( description = "Coq Vernacular Interpreter" - version = "8.8" + version = "8.9" requires = "coq.tactics" directory = "vernac" @@ -222,7 +206,7 @@ package "vernac" ( package "stm" ( description = "Coq State Transactional Machine" - version = "8.8" + version = "8.9" requires = "coq.vernac" directory = "stm" @@ -235,7 +219,7 @@ package "stm" ( package "toplevel" ( description = "Coq Toplevel" - version = "8.8" + version = "8.9" requires = "coq.stm" directory = "toplevel" @@ -248,7 +232,7 @@ package "toplevel" ( package "idetop" ( description = "Coq IDE Libraries" - version = "8.8" + version = "8.9" requires = "coq.toplevel" directory = "ide" @@ -262,7 +246,7 @@ package "idetop" ( package "ide" ( description = "Coq IDE Libraries" - version = "8.8" + version = "8.9" # XXX Add GTK requires = "coq.toplevel" @@ -276,14 +260,14 @@ package "ide" ( package "plugins" ( description = "Coq built-in plugins" - version = "8.8" + version = "8.9" directory = "plugins" package "ltac" ( description = "Coq LTAC Plugin" - version = "8.8" + version = "8.9" requires = "coq.stm" directory = "ltac" @@ -296,7 +280,7 @@ package "plugins" ( package "tauto" ( description = "Coq tauto plugin" - version = "8.8" + version = "8.9" requires = "coq.plugins.ltac" directory = "ltac" @@ -308,7 +292,7 @@ package "plugins" ( package "omega" ( description = "Coq omega plugin" - version = "8.8" + version = "8.9" requires = "coq.plugins.ltac" directory = "omega" @@ -320,7 +304,7 @@ package "plugins" ( package "romega" ( description = "Coq romega plugin" - version = "8.8" + version = "8.9" requires = "coq.plugins.omega" directory = "romega" @@ -332,7 +316,7 @@ package "plugins" ( package "micromega" ( description = "Coq micromega plugin" - version = "8.8" + version = "8.9" requires = "num,coq.plugins.ltac" directory = "micromega" @@ -344,7 +328,7 @@ package "plugins" ( package "quote" ( description = "Coq quote plugin" - version = "8.8" + version = "8.9" requires = "coq.plugins.ltac" directory = "quote" @@ -356,7 +340,7 @@ package "plugins" ( package "newring" ( description = "Coq newring plugin" - version = "8.8" + version = "8.9" requires = "coq.plugins.quote" directory = "setoid_ring" @@ -368,7 +352,7 @@ package "plugins" ( package "fourier" ( description = "Coq fourier plugin" - version = "8.8" + version = "8.9" requires = "coq.plugins.ltac" directory = "fourier" @@ -380,7 +364,7 @@ package "plugins" ( package "extraction" ( description = "Coq extraction plugin" - version = "8.8" + version = "8.9" requires = "coq.plugins.ltac" directory = "extraction" @@ -392,7 +376,7 @@ package "plugins" ( package "cc" ( description = "Coq cc plugin" - version = "8.8" + version = "8.9" requires = "coq.plugins.ltac" directory = "cc" @@ -404,7 +388,7 @@ package "plugins" ( package "ground" ( description = "Coq ground plugin" - version = "8.8" + version = "8.9" requires = "coq.plugins.ltac" directory = "firstorder" @@ -416,7 +400,7 @@ package "plugins" ( package "rtauto" ( description = "Coq rtauto plugin" - version = "8.8" + version = "8.9" requires = "coq.plugins.ltac" directory = "rtauto" @@ -428,7 +412,7 @@ package "plugins" ( package "btauto" ( description = "Coq btauto plugin" - version = "8.8" + version = "8.9" requires = "coq.plugins.ltac" directory = "btauto" @@ -440,7 +424,7 @@ package "plugins" ( package "recdef" ( description = "Coq recdef plugin" - version = "8.8" + version = "8.9" requires = "coq.plugins.extraction" directory = "funind" @@ -452,7 +436,7 @@ package "plugins" ( package "nsatz" ( description = "Coq nsatz plugin" - version = "8.8" + version = "8.9" requires = "num,coq.plugins.ltac" directory = "nsatz" @@ -464,7 +448,7 @@ package "plugins" ( package "natsyntax" ( description = "Coq natsyntax plugin" - version = "8.8" + version = "8.9" requires = "" directory = "syntax" @@ -476,7 +460,7 @@ package "plugins" ( package "zsyntax" ( description = "Coq zsyntax plugin" - version = "8.8" + version = "8.9" requires = "" directory = "syntax" @@ -488,7 +472,7 @@ package "plugins" ( package "rsyntax" ( description = "Coq rsyntax plugin" - version = "8.8" + version = "8.9" requires = "" directory = "syntax" @@ -500,7 +484,7 @@ package "plugins" ( package "int31syntax" ( description = "Coq int31syntax plugin" - version = "8.8" + version = "8.9" requires = "" directory = "syntax" @@ -512,7 +496,7 @@ package "plugins" ( package "asciisyntax" ( description = "Coq asciisyntax plugin" - version = "8.8" + version = "8.9" requires = "" directory = "syntax" @@ -524,7 +508,7 @@ package "plugins" ( package "stringsyntax" ( description = "Coq stringsyntax plugin" - version = "8.8" + version = "8.9" requires = "coq.plugins.asciisyntax" directory = "syntax" @@ -536,7 +520,7 @@ package "plugins" ( package "derive" ( description = "Coq derive plugin" - version = "8.8" + version = "8.9" requires = "" directory = "derive" @@ -548,7 +532,7 @@ package "plugins" ( package "ssrmatching" ( description = "Coq ssrmatching plugin" - version = "8.8" + version = "8.9" requires = "coq.plugins.ltac" directory = "ssrmatching" @@ -560,7 +544,7 @@ package "plugins" ( package "ssreflect" ( description = "Coq ssreflect plugin" - version = "8.8" + version = "8.9" requires = "coq.plugins.ssrmatching" directory = "ssr" @@ -58,7 +58,7 @@ FIND_SKIP_DIRS:='(' \ -name '_build_ci' -o \ -name '_install_ci' -o \ -name 'user-contrib' -o \ - -name 'coq-makefile' -o \ + -name 'test-suite' -o \ -name '.opamcache' -o \ -name '.coq-native' \ ')' -prune -o @@ -78,6 +78,7 @@ export MLLIBFILES := $(call find, '*.mllib') export MLPACKFILES := $(call find, '*.mlpack') export ML4FILES := $(call find, '*.ml4') export CFILES := $(call findindir, 'kernel/byterun', '*.c') +export MERLINFILES := $(call find, '.merlin') # NB: The lists of currently existing .ml and .mli files will change # before and after a build or a make clean. Hence we do not export @@ -137,40 +138,6 @@ Then, you may want to consider whether you want to restore the autosaves) #run. endif -# Check that every compiled file around has a known source file. -# This should help preventing weird compilation failures caused by leftover -# compiled files after deleting or moving some source files. - -EXISTINGVO:=$(call find, '*.vo') -KNOWNVO:=$(patsubst %.v,%.vo,$(call find, '*.v')) -ALIENVO:=$(filter-out $(KNOWNVO),$(EXISTINGVO)) - -EXISTINGOBJS:=$(call find, '*.cm[oxia]' -o -name '*.cmxa') -KNOWNML:=$(EXISTINGML) $(GENMLFILES) $(GENML4FILES) $(MLPACKFILES:.mlpack=.ml) \ - $(patsubst %.mlp,%.ml,$(wildcard grammar/*.mlp)) -KNOWNOBJS:=$(KNOWNML:.ml=.cmo) $(KNOWNML:.ml=.cmx) $(KNOWNML:.ml=.cmi) \ - $(MLIFILES:.mli=.cmi) \ - $(MLLIBFILES:.mllib=.cma) $(MLLIBFILES:.mllib=.cmxa) grammar/grammar.cma -ALIENOBJS:=$(filter-out $(KNOWNOBJS),$(EXISTINGOBJS)) - -ifeq (,$(findstring clean,$(MAKECMDGOALS))) # Skip this for 'make clean' and alii -ifndef ACCEPT_ALIEN_VO -ifdef ALIENVO -$(error Leftover compiled Coq files without known sources: $(ALIENVO); \ -remove them first, for instance via 'make voclean' or 'make alienclean' \ -(or skip this check via 'make ACCEPT_ALIEN_VO=1')) -endif -endif - -ifndef ACCEPT_ALIEN_OBJ -ifdef ALIENOBJS -$(error Leftover compiled OCaml files without known sources: $(ALIENOBJS); \ -remove them first, for instance via 'make clean' or 'make alienclean' \ -(or skip this check via 'make ACCEPT_ALIEN_OBJ=1')) -endif -endif -endif - # Apart from clean and tags, everything will be done in a sub-call to make # on Makefile.build. This way, we avoid doing here the -include of .d : # since they trigger some compilations, we do not want them for a mere clean. @@ -186,7 +153,7 @@ endif MAKE_OPTS := --warn-undefined-variable --no-builtin-rules -submake: +submake: alienclean $(MAKE) $(MAKE_OPTS) -f Makefile.build $(MAKECMDGOALS) noconfig: @@ -214,12 +181,11 @@ cruftclean: ml4clean indepclean: rm -f $(GENFILES) - rm -f $(COQTOPBYTE) $(CHICKENBYTE) + rm -f $(COQTOPBYTE) $(CHICKENBYTE) $(TOPBYTE) find . \( -name '*~' -o -name '*.cm[ioat]' -o -name '*.cmti' \) -delete rm -f */*.pp[iox] plugins/*/*.pp[iox] rm -rf $(SOURCEDOCDIR) rm -f toplevel/mltop.byteml toplevel/mltop.optml - rm -f test-suite/check.log rm -f glob.dump rm -f config/revision.ml revision rm -f plugins/micromega/.micromega.ml.generated @@ -235,11 +201,8 @@ docclean: doc/stdlib/*Library.coqdoc.tex doc/stdlib/library.files \ doc/stdlib/library.files.ls doc/stdlib/FullLibrary.tex rm -f doc/*/*.ps doc/*/*.pdf doc/*/*.eps doc/*/*.pdf_t doc/*/*.eps_t - rm -rf doc/refman/html doc/stdlib/html doc/tutorial/tutorial.v.html - rm -f doc/refman/euclid.ml doc/refman/euclid.mli - rm -f doc/refman/heapsort.ml doc/refman/heapsort.mli + rm -rf doc/stdlib/html doc/tutorial/tutorial.v.html rm -f doc/common/version.tex - rm -f doc/refman/styles.hva doc/refman/cover.html doc/refman/Reference-Manual.html rm -f doc/coq.tex rm -rf doc/sphinx/_build @@ -248,7 +211,7 @@ archclean: clean-ide optclean voclean rm -f $(ALLSTDLIB).* optclean: - rm -f $(COQTOPEXE) $(CHICKEN) + rm -f $(COQTOPEXE) $(CHICKEN) $(TOPBIN) rm -f $(TOOLS) $(PRIVATEBINARIES) $(CSDPCERT) find . -name '*.cmx' -o -name '*.cmx[as]' -o -name '*.[soa]' -o -name '*.so' | xargs rm -f @@ -286,6 +249,22 @@ devdocclean: rm -f $(OCAMLDOCDIR)/ocamldoc.sty $(OCAMLDOCDIR)/coq.tex rm -f $(OCAMLDOCDIR)/html/*.html +# Ensure that every compiled file around has a known source file. +# This should help preventing weird compilation failures caused by leftover +# compiled files after deleting or moving some source files. + +EXISTINGVO:=$(call find, '*.vo') +KNOWNVO:=$(patsubst %.v,%.vo,$(call find, '*.v')) +ALIENVO:=$(filter-out $(KNOWNVO),$(EXISTINGVO)) + +EXISTINGOBJS:=$(call find, '*.cm[oxia]' -o -name '*.cmxa') +KNOWNML:=$(EXISTINGML) $(GENMLFILES) $(GENML4FILES) $(MLPACKFILES:.mlpack=.ml) \ + $(patsubst %.mlp,%.ml,$(wildcard grammar/*.mlp)) +KNOWNOBJS:=$(KNOWNML:.ml=.cmo) $(KNOWNML:.ml=.cmx) $(KNOWNML:.ml=.cmi) \ + $(MLIFILES:.mli=.cmi) \ + $(MLLIBFILES:.mllib=.cma) $(MLLIBFILES:.mllib=.cmxa) grammar/grammar.cma +ALIENOBJS:=$(filter-out $(KNOWNOBJS),$(EXISTINGOBJS)) + alienclean: rm -f $(ALIENOBJS) $(ALIENVO) diff --git a/Makefile.build b/Makefile.build index ffe605757..b85418243 100644 --- a/Makefile.build +++ b/Makefile.build @@ -89,6 +89,7 @@ byte: coqbyte coqide-byte pluginsbyte printers MLFILES := $(MLSTATICFILES) $(GENMLFILES) $(ML4FILES:.ml4=.ml) include Makefile.common +include Makefile.vofiles include Makefile.doc ## provides the 'documentation' rule include Makefile.checker include Makefile.ide ## provides the 'coqide' rule @@ -205,7 +206,7 @@ OCAMLOPT := $(OCAMLFIND) opt $(CAMLFLAGS) BYTEFLAGS=$(CAMLDEBUG) $(USERFLAGS) OPTFLAGS=$(CAMLDEBUGOPT) $(CAMLTIMEPROF) $(USERFLAGS) $(FLAMBDA_FLAGS) -DEPFLAGS=$(LOCALINCLUDES)$(if $(filter plugins/%,$@),, -I ide -I ide/utils) +DEPFLAGS=$(LOCALINCLUDES)$(if $(filter plugins/%,$@),, -I ide -I ide/protocol) # On MacOS, the binaries are signed, except our private ones ifeq ($(shell which codesign > /dev/null 2>&1 && echo $(ARCH)),Darwin) @@ -240,6 +241,10 @@ $(OCAMLOPT) $(MLINCLUDES) $(OPTFLAGS) $(LINKMETADATA) -o $@ -linkpkg $(1) $^ && $(OCAMLC) $(MLINCLUDES) $(BYTEFLAGS) $(CUSTOM) -o $@ -linkpkg $(1) $^) endef +define ocamlbyte +$(OCAMLC) $(MLINCLUDES) $(BYTEFLAGS) $(CUSTOM) -o $@ -linkpkg $(1) $^ +endef + # Camlp5 settings CAMLP5DEPS:=grammar/grammar.cma @@ -382,29 +387,33 @@ grammar/%.cmi: grammar/%.mli .PHONY: coqbinaries coqbyte -coqbinaries: $(COQTOPEXE) $(CHICKEN) $(CSDPCERT) $(FAKEIDE) +coqbinaries: $(TOPBIN) $(CHICKEN) $(CSDPCERT) $(FAKEIDE) +coqbyte: $(TOPBYTE) $(CHICKENBYTE) -coqbyte: $(COQTOPBYTE) $(CHICKENBYTE) - -COQTOP_OPT=toplevel/coqtop_opt_bin.ml -COQTOP_BYTE=toplevel/coqtop_byte_bin.ml +# Special rule for coqtop +$(COQTOPEXE): $(TOPBIN:.opt=.$(BEST)) + cp $< $@ -ifeq ($(BEST),opt) -$(COQTOPEXE): $(LINKCMX) $(LIBCOQRUN) $(TOPLOOPCMA:.cma=.cmxs) $(COQTOP_OPT) +bin/%.opt$(EXE): topbin/%_bin.ml $(LINKCMX) $(LIBCOQRUN) $(SHOW)'COQMKTOP -o $@' - $(HIDE)$(OCAMLOPT) -linkall -linkpkg -I vernac -I toplevel \ - -I kernel/byterun/ -cclib -lcoqrun \ + $(HIDE)$(OCAMLOPT) -linkall -linkpkg $(MLINCLUDES) \ $(SYSMOD) -package camlp5.gramlib \ - $(LINKCMX) $(OPTFLAGS) $(LINKMETADATA) $(COQTOP_OPT) -o $@ + $(LINKCMX) $(OPTFLAGS) $(LINKMETADATA) $< -o $@ $(STRIP) $@ $(CODESIGN) $@ -else -$(COQTOPEXE): $(COQTOPBYTE) - cp $< $@ -endif +bin/%.byte$(EXE): topbin/%_bin.ml $(LINKCMO) $(LIBCOQRUN) + $(SHOW)'COQMKTOP -o $@' + $(HIDE)$(OCAMLC) -linkall -linkpkg $(MLINCLUDES) \ + -I kernel/byterun/ -cclib -lcoqrun $(VMBYTEFLAGS) \ + $(SYSMOD) -package camlp5.gramlib \ + $(LINKCMO) $(BYTEFLAGS) $< -o $@ + +COQTOP_BYTE=topbin/coqtop_byte_bin.ml + +# Special rule for coqtop.byte # VMBYTEFLAGS will either contain -custom of the right -dllpath for the VM -$(COQTOPBYTE): $(LINKCMO) $(LIBCOQRUN) $(TOPLOOPCMA) $(COQTOP_BYTE) +$(COQTOPBYTE): $(LINKCMO) $(LIBCOQRUN) $(COQTOP_BYTE) $(SHOW)'COQMKTOP -o $@' $(HIDE)$(OCAMLC) -linkall -linkpkg -I lib -I vernac -I toplevel \ -I kernel/byterun/ -cclib -lcoqrun $(VMBYTEFLAGS) \ @@ -418,6 +427,10 @@ $(COQC): $(call bestobj, $(COQCCMO)) $(SHOW)'OCAMLBEST -o $@' $(HIDE)$(call bestocaml, $(SYSMOD)) +$(COQCBYTE): $(COQCCMO) + $(SHOW)'OCAMLC -o $@' + $(HIDE)$(call ocamlbyte, $(SYSMOD)) + ########################################################################### # other tools ########################################################################### @@ -455,10 +468,18 @@ $(COQDEPBOOT): $(call bestobj, $(COQDEPBOOTSRC)) $(SHOW)'OCAMLBEST -o $@' $(HIDE)$(call bestocaml, -I tools -package unix) +$(COQDEPBOOTBYTE): $(COQDEPBOOTSRC) + $(SHOW)'OCAMLC -o $@' + $(HIDE)$(call ocamlbyte, -I tools -package unix) + $(OCAMLLIBDEP): $(call bestobj, tools/ocamllibdep.cmo) $(SHOW)'OCAMLBEST -o $@' $(HIDE)$(call bestocaml, -I tools -package unix) +$(OCAMLLIBDEPBYTE): tools/ocamllibdep.cmo + $(SHOW)'OCAMLBEST -o $@' + $(HIDE)$(call ocamlbyte, -I tools -package unix) + # The full coqdep (unused by this build, but distributed by make install) COQDEPCMO:=clib/clib.cma lib/lib.cma tools/coqdep_lexer.cmo \ @@ -468,24 +489,44 @@ $(COQDEP): $(call bestobj, $(COQDEPCMO)) $(SHOW)'OCAMLBEST -o $@' $(HIDE)$(call bestocaml, $(SYSMOD)) +$(COQDEPBYTE): $(COQDEPCMO) + $(SHOW)'OCAMLC -o $@' + $(HIDE)$(call ocamlbyte, $(SYSMOD)) + $(GALLINA): $(call bestobj, tools/gallina_lexer.cmo tools/gallina.cmo) $(SHOW)'OCAMLBEST -o $@' $(HIDE)$(call bestocaml,) +$(GALLINABYTE): tools/gallina_lexer.cmo tools/gallina.cmo + $(SHOW)'OCAMLC -o $@' + $(HIDE)$(call ocamlbyte,) + COQMAKEFILECMO:=clib/clib.cma lib/lib.cma tools/coq_makefile.cmo $(COQMAKEFILE): $(call bestobj,$(COQMAKEFILECMO)) $(SHOW)'OCAMLBEST -o $@' - $(HIDE)$(call bestocaml, -package str,unix,threads) + $(HIDE)$(call bestocaml, -package str) + +$(COQMAKEFILEBYTE): $(COQMAKEFILECMO) + $(SHOW)'OCAMLC -o $@' + $(HIDE)$(call ocamlbyte, -package str,unix,threads) $(COQTEX): $(call bestobj, tools/coq_tex.cmo) $(SHOW)'OCAMLBEST -o $@' $(HIDE)$(call bestocaml, -package str) +$(COQTEXBYTE): tools/coq_tex.cmo + $(SHOW)'OCAMLC -o $@' + $(HIDE)$(call ocamlbyte, -package str) + $(COQWC): $(call bestobj, tools/coqwc.cmo) $(SHOW)'OCAMLBEST -o $@' $(HIDE)$(call bestocaml, -package str) +$(COQWCBYTE): tools/coqwc.cmo + $(SHOW)'OCAMLC -o $@' + $(HIDE)$(call ocamlbyte, -package str) + COQDOCCMO:=clib/clib.cma lib/lib.cma $(addprefix tools/coqdoc/, \ cdglobals.cmo alpha.cmo index.cmo tokens.cmo output.cmo cpretty.cmo main.cmo ) @@ -493,28 +534,45 @@ $(COQDOC): $(call bestobj, $(COQDOCCMO)) $(SHOW)'OCAMLBEST -o $@' $(HIDE)$(call bestocaml, -package str,unix) -$(COQWORKMGR): $(call bestobj, clib/clib.cma lib/lib.cma stm/spawned.cmo stm/coqworkmgrApi.cmo tools/coqworkmgr.cmo) +$(COQDOCBYTE): $(COQDOCCMO) + $(SHOW)'OCAMLC -o $@' + $(HIDE)$(call ocamlbyte, -package str,unix) + +COQWORKMGRCMO:=clib/clib.cma lib/lib.cma stm/spawned.cmo stm/coqworkmgrApi.cmo tools/coqworkmgr.cmo + +$(COQWORKMGR): $(call bestobj, $(COQWORKMGRCMO)) $(SHOW)'OCAMLBEST -o $@' $(HIDE)$(call bestocaml, $(SYSMOD)) +$(COQWORKMGRBYTE): $(COQWORKMGRCMO) + $(SHOW)'OCAMLC -o $@' + $(HIDE)$(call ocamlbyte, $(SYSMOD)) + # fake_ide : for debugging or test-suite purpose, a fake ide simulating -# a connection to coqtop -ideslave +# a connection to coqidetop -FAKEIDECMO:=clib/clib.cma lib/lib.cma ide/document.cmo \ - ide/serialize.cmo ide/xml_lexer.cmo ide/xml_parser.cmo \ - ide/xml_printer.cmo ide/richpp.cmo ide/xmlprotocol.cmo \ - tools/fake_ide.cmo +FAKEIDECMO:=clib/clib.cma lib/lib.cma ide/protocol/ideprotocol.cma ide/document.cmo tools/fake_ide.cmo -$(FAKEIDE): $(call bestobj, $(FAKEIDECMO)) | $(IDETOPLOOPCMA:.cma=$(BESTDYN)) +$(FAKEIDE): $(call bestobj, $(FAKEIDECMO)) | $(IDETOP) $(SHOW)'OCAMLBEST -o $@' - $(HIDE)$(call bestocaml, -I ide -package str,unix,threads) + $(HIDE)$(call bestocaml, -I ide -I ide/protocol -package str -package dynlink) + +$(FAKEIDEBYTE): $(FAKEIDECMO) | $(IDETOPBYTE) + $(SHOW)'OCAMLC -o $@' + $(HIDE)$(call ocamlbyte, -I ide -package str,unix,threads) # votour: a small vo explorer (based on the checker) -bin/votour: $(call bestobj, clib/cObj.cmo checker/analyze.cmo checker/values.cmo checker/votour.cmo) +VOTOURCMO:=clib/cObj.cmo checker/analyze.cmo checker/values.cmo checker/votour.cmo + +bin/votour: $(call bestobj, $(VOTOURCMO)) $(SHOW)'OCAMLBEST -o $@' $(HIDE)$(call bestocaml, -I checker) +bin/votour.byte: $(VOTOURCMO) + $(SHOW)'OCAMLC -o $@' + $(HIDE)$(call ocamlbyte, -I checker) + ########################################################################### # Csdp to micromega special targets ########################################################################### @@ -527,6 +585,10 @@ $(CSDPCERT): $(call bestobj, $(CSDPCERTCMO)) $(SHOW)'OCAMLBEST -o $@' $(HIDE)$(call bestocaml, -package num,unix) +$(CSDPCERTBYTE): $(CSDPCERTCMO) + $(SHOW)'OCAMLC -o $@' + $(HIDE)$(call ocamlbyte, -package num,unix) + ########################################################################### # tests ########################################################################### @@ -571,6 +633,11 @@ kernel/kernel.cma: kernel/kernel.mllib $(SHOW)'OCAMLC -a -o $@' $(HIDE)$(OCAMLC) $(MLINCLUDES) $(BYTEFLAGS) $(VMBYTEFLAGS) -a -o $@ $(filter-out %.mllib, $^) +# Specific rule for kernel.cmxa as to adjoin -cclib -lcoqrun +kernel/kernel.cmxa: kernel/kernel.mllib + $(SHOW)'OCAMLOPT -a -o $@' + $(HIDE)$(OCAMLOPT) $(MLINCLUDES) $(OPTFLAGS) -I kernel/byterun/ -cclib -lcoqrun -a -o $@ $(filter-out %.mllib, $^) + %.cma: %.mllib $(SHOW)'OCAMLC -a -o $@' $(HIDE)$(OCAMLC) $(MLINCLUDES) $(BYTEFLAGS) -a -o $@ $(filter-out %.mllib, $^) @@ -589,7 +656,7 @@ kernel/kernel.cma: kernel/kernel.mllib $(SHOW)'OCAMLOPT -pack -o $@' $(HIDE)$(OCAMLOPT) $(MLINCLUDES) $(OPTFLAGS) -pack -o $@ $(filter-out %.mlpack, $^) -COND_IDEFLAGS=$(if $(filter tools/fake_ide% tools/coq_makefile%,$<), -I ide,) +COND_IDEFLAGS=$(if $(filter tools/fake_ide% tools/coq_makefile%,$<), -I ide -I ide/protocol,) COND_PRINTERFLAGS=$(if $(filter dev/%,$<), -I dev,) COND_BYTEFLAGS= \ diff --git a/Makefile.checker b/Makefile.checker index 172c64af3..0ec565d61 100644 --- a/Makefile.checker +++ b/Makefile.checker @@ -34,6 +34,20 @@ CHECKMLLIBFILE := checker/.mllibfiles CHECKERDEPS := $(addsuffix .d, $(CHECKMLDFILE) $(CHECKMLLIBFILE)) -include $(CHECKERDEPS) +# Copied files +checker/esubst.mli: kernel/esubst.mli + cp -a $< $@ + sed -i.bak '1i(* AUTOGENERATED FILE: DO NOT EDIT *)\n\n\n\n\n\n\n\n' $@ && rm $@.bak +checker/esubst.ml: kernel/esubst.ml + cp -a $< $@ + sed -i.bak '1i(* AUTOGENERATED FILE: DO NOT EDIT *)\n\n\n\n\n\n\n\n' $@ && rm $@.bak +checker/names.mli: kernel/names.mli + cp -a $< $@ + sed -i.bak '1i(* AUTOGENERATED FILE: DO NOT EDIT *)\n\n\n\n\n\n\n\n' $@ && rm $@.bak +checker/names.ml: kernel/names.ml + cp -a $< $@ + sed -i.bak '1i(* AUTOGENERATED FILE: DO NOT EDIT *)\n\n\n\n\n\n\n\n' $@ && rm $@.bak + ifeq ($(BEST),opt) $(CHICKEN): checker/check.cmxa checker/main.mli checker/main.ml $(SHOW)'OCAMLOPT -o $@' @@ -57,13 +71,18 @@ checker/check.cmxa: checker/check.mllib | md5chk $(SHOW)'OCAMLOPT -a -o $@' $(HIDE)$(OCAMLOPT) $(CHKLIBS) $(OPTFLAGS) -a -o $@ $(filter-out %.mllib, $^) -$(CHECKMLDFILE).d: $(filter checker/%, $(MLFILES) $(MLIFILES)) +CHECKGENFILES:=$(addprefix checker/, names.mli names.ml esubst.mli esubst.ml) + +CHECKMLFILES:=$(filter checker/%, $(MLFILES) $(MLIFILES)) $(CHECKGENFILES) \ + $(filter dev/checker_%, $(MLFILES) $(MLIFILES)) + +$(CHECKMLDFILE).d: $(filter checker/%, $(MLFILES) $(MLIFILES) $(CHECKGENFILES)) $(SHOW)'OCAMLDEP checker/MLFILES checker/MLIFILES' - $(HIDE)$(OCAMLFIND) ocamldep -slash $(CHKLIBS) $(filter checker/%, $(MLFILES) $(MLIFILES)) $(TOTARGET) + $(HIDE)$(OCAMLFIND) ocamldep -slash $(CHKLIBS) $(CHECKMLFILES) $(TOTARGET) -$(CHECKMLLIBFILE).d: $(filter checker/%, $(MLLIBFILES) $(MLPACKFILES)) | $(OCAMLLIBDEP) +$(CHECKMLLIBFILE).d: $(filter checker/%, $(MLLIBFILES) $(MLPACKFILES) $(CHECKGENFILES)) | $(OCAMLLIBDEP) $(SHOW)'OCAMLLIBDEP checker/MLLIBFILES checker/MLPACKFILES' - $(HIDE)$(OCAMLLIBDEP) $(CHKLIBS) $(filter checker/%, $(MLLIBFILES) $(MLPACKFILES)) $(TOTARGET) + $(HIDE)$(OCAMLLIBDEP) $(CHKLIBS) $(filter checker/%, $(MLLIBFILES) $(MLPACKFILES) $(CHECKGENFILES)) $(TOTARGET) checker/%.cmi: checker/%.mli $(SHOW)'OCAMLC $<' @@ -77,6 +96,14 @@ checker/%.cmx: checker/%.ml $(SHOW)'OCAMLOPT $<' $(HIDE)$(OCAMLOPT) $(CHKLIBS) $(OPTFLAGS) -c $< +dev/checker_%.cmo: dev/checker_%.ml + $(SHOW)'OCAMLC $<' + $(HIDE)$(OCAMLC) $(CHKLIBS) $(BYTEFLAGS) -I dev/ -c $< + +dev/checker_%.cmi: dev/checker_%.mli + $(SHOW)'OCAMLC $<' + $(HIDE)$(OCAMLC) $(CHKLIBS) $(BYTEFLAGS) -I dev/ -c $< + md5chk: $(SHOW)'MD5SUM cic.mli' $(HIDE)if grep -q "^MD5 $$($(OCAML) tools/md5sum.ml checker/cic.mli)$$" checker/values.ml; \ diff --git a/Makefile.ci b/Makefile.ci index 3c26bf964..7f63157fa 100644 --- a/Makefile.ci +++ b/Makefile.ci @@ -15,8 +15,11 @@ CI_TARGETS=ci-bignums \ ci-coquelicot \ ci-corn \ ci-cpdt \ + ci-cross-crypto \ ci-elpi \ + ci-ext-lib \ ci-equations \ + ci-fcsl-pcm \ ci-fiat-crypto \ ci-fiat-parsers \ ci-flocq \ @@ -27,7 +30,9 @@ CI_TARGETS=ci-bignums \ ci-ltac2 \ ci-math-classes \ ci-math-comp \ - ci-metacoq \ + ci-mtac2 \ + ci-pidetop \ + ci-quickchick \ ci-sf \ ci-tlc \ ci-unimath \ @@ -35,20 +40,26 @@ CI_TARGETS=ci-bignums \ .PHONY: ci-all $(CI_TARGETS) +ci-help: + echo '*** Coq CI system, please specify a target to build.' + false + +ci-all: $(CI_TARGETS) + ci-color: ci-bignums ci-math-classes: ci-bignums ci-corn: ci-math-classes +ci-quickchick: ci-ext-lib + ci-formal-topology: ci-corn # Generic rule, we use make to ease travis integration with mixed rules $(CI_TARGETS): ci-%: +./dev/ci/ci-wrapper.sh $* -ci-all: $(CI_TARGETS) - # For emacs: # Local Variables: # mode: makefile diff --git a/Makefile.common b/Makefile.common index 9a30e2a4c..5b1def40a 100644 --- a/Makefile.common +++ b/Makefile.common @@ -14,17 +14,28 @@ # Executables ########################################################################### -COQTOPBYTE:=bin/coqtop.byte$(EXE) +TOPBIN:=$(addsuffix .opt$(EXE), $(addprefix bin/, coqtop coqproofworker coqtacticworker coqqueryworker)) +TOPBYTE:=$(TOPBIN:.opt$(EXE)=.byte$(EXE)) + COQTOPEXE:=bin/coqtop$(EXE) +COQTOPBYTE:=bin/coqtop.byte$(EXE) COQDEP:=bin/coqdep$(EXE) +COQDEPBYTE:=bin/coqdep.byte$(EXE) COQMAKEFILE:=bin/coq_makefile$(EXE) +COQMAKEFILEBYTE:=bin/coq_makefile.byte$(EXE) GALLINA:=bin/gallina$(EXE) +GALLINABYTE:=bin/gallina.byte$(EXE) COQTEX:=bin/coq-tex$(EXE) +COQTEXBYTE:=bin/coq-tex.byte$(EXE) COQWC:=bin/coqwc$(EXE) +COQWCBYTE:=bin/coqwc.byte$(EXE) COQDOC:=bin/coqdoc$(EXE) +COQDOCBYTE:=bin/coqdoc.byte$(EXE) COQC:=bin/coqc$(EXE) +COQCBYTE:=bin/coqc.byte$(EXE) COQWORKMGR:=bin/coqworkmgr$(EXE) +COQWORKMGRBYTE:=bin/coqworkmgr.byte$(EXE) COQMAKE_ONE_TIME_FILE:=tools/make-one-time-file.py COQTIME_FILE_MAKER:=tools/TimeFileMaker.py COQMAKE_BOTH_TIME_FILES:=tools/make-both-time-files.py @@ -36,12 +47,16 @@ TOOLS_HELPERS:=tools/CoqMakefile.in $(COQMAKE_ONE_TIME_FILE) $(COQTIME_FILE_MAKE $(COQMAKE_BOTH_TIME_FILES) $(COQMAKE_BOTH_SINGLE_TIMING_FILES) COQDEPBOOT:=bin/coqdep_boot$(EXE) +COQDEPBOOTBYTE:=bin/coqdep_boot.byte$(EXE) OCAMLLIBDEP:=bin/ocamllibdep$(EXE) +OCAMLLIBDEPBYTE:=bin/ocamllibdep.byte$(EXE) FAKEIDE:=bin/fake_ide$(EXE) +FAKEIDEBYTE:=bin/fake_ide.byte$(EXE) PRIVATEBINARIES:=$(FAKEIDE) $(OCAMLLIBDEP) $(COQDEPBOOT) CSDPCERT:=plugins/micromega/csdpcert$(EXE) +CSDPCERTBYTE:=plugins/micromega/csdpcert.byte$(EXE) ########################################################################### # Object and Source files @@ -75,7 +90,7 @@ INSTALLSH:=./install.sh MKDIR:=install -d CORESRCDIRS:=\ - config clib lib kernel intf kernel/byterun library \ + config clib lib kernel kernel/byterun library \ engine pretyping interp proofs parsing printing \ tactics vernac stm toplevel @@ -102,19 +117,13 @@ BYTERUN:=$(addprefix kernel/byterun/, \ # respecting this order is useful for developers that want to load or link # the libraries directly -CORECMA:=clib/clib.cma lib/lib.cma kernel/kernel.cma intf/intf.cma library/library.cma \ +CORECMA:=clib/clib.cma lib/lib.cma kernel/kernel.cma library/library.cma \ engine/engine.cma pretyping/pretyping.cma interp/interp.cma proofs/proofs.cma \ parsing/parsing.cma printing/printing.cma tactics/tactics.cma vernac/vernac.cma \ - stm/stm.cma toplevel/toplevel.cma - -TOPLOOPCMA:=stm/proofworkertop.cma stm/tacworkertop.cma stm/queryworkertop.cma + stm/stm.cma toplevel/toplevel.cma GRAMMARCMA:=grammar/grammar.cma -# modules known by the toplevel of Coq - -OBJSMOD:=$(shell cat $(CORECMA:.cma=.mllib)) - ########################################################################### # plugins object files ########################################################################### @@ -163,40 +172,8 @@ PLUGINSOPT:=$(PLUGINSCMO:.cmo=.cmxs) LINKCMO:=$(CORECMA) $(STATICPLUGINS) LINKCMX:=$(CORECMA:.cma=.cmxa) $(STATICPLUGINS:.cmo=.cmx) -########################################################################### -# vo files -########################################################################### - -THEORIESVO := $(patsubst %.v,%.vo,$(shell find theories -type f -name "*.v")) -PLUGINSVO := $(patsubst %.v,%.vo,$(shell find plugins -type f -name "*.v")) -ALLVO := $(THEORIESVO) $(PLUGINSVO) -VFILES := $(ALLVO:.vo=.v) - -## More specific targets - -THEORIESLIGHTVO:= \ - $(filter theories/Init/% theories/Logic/% theories/Unicode/% theories/Arith/%, $(THEORIESVO)) - ALLSTDLIB := test-suite/misc/universes/all_stdlib -# convert a (stdlib) filename into a module name: -# remove .vo, replace theories and plugins by Coq, and replace slashes by dots -vo_to_mod = $(subst /,.,$(patsubst theories/%,Coq.%,$(patsubst plugins/%,Coq.%,$(1:.vo=)))) - -ALLMODS:=$(call vo_to_mod,$(ALLVO)) - - -# Converting a stdlib filename into native compiler filenames -# Used for install targets -vo_to_cm = $(foreach vo,$(1),$(dir $(vo)).coq-native/$(subst /,_,$(patsubst theories/%,NCoq_%,$(patsubst plugins/%,NCoq_%,$(vo:.vo=.cm*))))) - -vo_to_obj = $(foreach vo,$(1),$(dir $(vo)).coq-native/$(subst /,_,$(patsubst theories/%,NCoq_%,$(patsubst plugins/%,NCoq_%,$(vo:.vo=.o))))) - -GLOBFILES:=$(ALLVO:.vo=.glob) -LIBFILES:=$(ALLVO) $(call vo_to_cm,$(ALLVO)) \ - $(call vo_to_obj,$(ALLVO)) \ - $(VFILES) $(GLOBFILES) - # For emacs: # Local Variables: # mode: makefile diff --git a/Makefile.dev b/Makefile.dev index 0461fe072..8f7d21694 100644 --- a/Makefile.dev +++ b/Makefile.dev @@ -17,7 +17,7 @@ .PHONY: devel printers -DEBUGPRINTERS:=dev/top_printers.cmo dev/vm_printers.cmo +DEBUGPRINTERS:=dev/top_printers.cmo dev/vm_printers.cmo dev/checker_printers.cmo devel: printers printers: $(CORECMA) $(DEBUGPRINTERS) dev/camlp5.dbg diff --git a/Makefile.doc b/Makefile.doc index fc791ce1c..dde3a37b7 100644 --- a/Makefile.doc +++ b/Makefile.doc @@ -10,10 +10,7 @@ # Makefile for the Coq documentation -# To compile documentation, you need the following tools: -# Dvi: latex (latex2e), bibtex, makeindex -# Pdf: pdflatex -# Html: hevea (http://hevea.inria.fr) >= 1.05 +# Read INSTALL.doc to learn about the dependencies # The main entry point : @@ -28,25 +25,13 @@ doc-no: ###################################################################### LATEX:=latex -BIBTEX:=BIBINPUTS=.: bibtex -min-crossrefs=10 MAKEINDEX:=makeindex PDFLATEX:=pdflatex DVIPS:=dvips -FIG2DEV:=fig2dev -CONVERT:=convert -HEVEA:=hevea -HACHA:=hacha -HEVEAOPTS:=-fix -exec xxdate.exe -HEVEALIB:=/usr/local/lib/hevea:/usr/lib/hevea HTMLSTYLE:=coqremote -export TEXINPUTS:=$(HEVEALIB): -ifdef COQDOC_NOBOOT -COQTEXOPTS:=-n 72 -sl -small -else -COQTEXOPTS:=-boot -n 72 -sl -small -endif # Sphinx-related variables +SPHINXENV:=COQBIN="$(CURDIR)/bin/" SPHINXOPTS= -j4 SPHINXBUILD= sphinx-build SPHINXBUILDDIR= doc/sphinx/_build @@ -56,58 +41,33 @@ ALLSPHINXOPTS= -d $(SPHINXBUILDDIR)/doctrees $(SPHINXOPTS) DOCCOMMON:=doc/common/version.tex doc/common/title.tex doc/common/macros.tex -REFMANCOQTEXFILES:=$(addprefix doc/refman/, \ - RefMan-gal.v.tex \ - RefMan-oth.v.tex RefMan-ltac.v.tex \ - RefMan-pro.v.tex \ - Universes.v.tex) - -REFMANTEXFILES:=$(addprefix doc/refman/, \ - headers.sty Reference-Manual.tex \ - RefMan-uti.tex) \ - $(REFMANCOQTEXFILES) \ - -REFMANEPSFILES:=doc/refman/coqide.eps doc/refman/coqide-queries.eps - -REFMANFILES:=$(REFMANTEXFILES) $(DOCCOMMON) $(REFMANEPSFILES) doc/refman/biblio.bib - -REFMANPNGFILES:=$(REFMANEPSFILES:.eps=.png) - - ###################################################################### ### General rules ###################################################################### -.PHONY: doc sphinxdoc-html doc-pdf doc-ps refman refman-quick tutorial -.PHONY: stdlib full-stdlib rectutorial refman-html-dir +.PHONY: doc doc-html doc-pdf doc-ps +.PHONY: stdlib full-stdlib -INDEXURLS:=doc/refman/html/index_urls.txt +doc: sphinx stdlib -doc: sphinx refman tutorial rectutorial stdlib $(INDEXURLS) +ifndef QUICK +SPHINX_DEPS := coq +endif -sphinx: coq +sphinx: $(SPHINX_DEPS) $(SHOW)'SPHINXBUILD doc/sphinx' - $(HIDE)COQBIN="$(PWD)/bin" $(SPHINXBUILD) -b html $(ALLSPHINXOPTS) doc/sphinx $(SPHINXBUILDDIR)/html + $(HIDE)$(SPHINXENV) $(SPHINXBUILD) -W -b html $(ALLSPHINXOPTS) doc/sphinx $(SPHINXBUILDDIR)/html @echo @echo "Build finished. The HTML pages are in $(SPHINXBUILDDIR)/html." doc-html:\ - doc/tutorial/Tutorial.v.html doc/refman/html/index.html \ - doc/stdlib/html/index.html doc/RecTutorial/RecTutorial.html + doc/stdlib/html/index.html sphinx doc-pdf:\ - doc/tutorial/Tutorial.v.pdf doc/refman/Reference-Manual.pdf \ - doc/stdlib/Library.pdf doc/RecTutorial/RecTutorial.pdf + doc/stdlib/Library.pdf doc-ps:\ - doc/tutorial/Tutorial.v.ps doc/refman/Reference-Manual.ps \ - doc/stdlib/Library.ps doc/RecTutorial/RecTutorial.ps - -refman: \ - doc/refman/html/index.html doc/refman/Reference-Manual.ps doc/refman/Reference-Manual.pdf - -tutorial: \ - doc/tutorial/Tutorial.v.html doc/tutorial/Tutorial.v.ps doc/tutorial/Tutorial.v.pdf + doc/stdlib/Library.ps stdlib: \ doc/stdlib/html/index.html doc/stdlib/Library.ps doc/stdlib/Library.pdf @@ -115,45 +75,13 @@ stdlib: \ full-stdlib: \ doc/stdlib/html/index.html doc/stdlib/FullLibrary.ps doc/stdlib/FullLibrary.pdf -rectutorial: doc/RecTutorial/RecTutorial.html \ - doc/RecTutorial/RecTutorial.ps doc/RecTutorial/RecTutorial.pdf - ###################################################################### ### Implicit rules ###################################################################### -ifdef QUICK -%.v.tex: %.tex - $(COQTEX) $(COQTEXOPTS) $< -else -%.v.tex: %.tex $(COQTEX) $(COQTOPEXE) $(ALLVO) - $(COQTEX) $(COQTEXOPTS) $< -endif - %.ps: %.dvi (cd `dirname $<`; $(DVIPS) -q -o `basename $@` `basename $<`) -%.png: %.fig - $(FIG2DEV) -L png -m 2 $< $@ - -%.pdf: %.fig - $(FIG2DEV) -L pdftex $< $@ - $(FIG2DEV) -L pdftex_t -p `basename $@` $< $@_t - -%.eps: %.fig - $(FIG2DEV) -L pstex $< $@ - $(FIG2DEV) -L pstex_t -p `basename $@` $< $@_t - -%.eps: %.png - $(CONVERT) $< $@ - -###################################################################### -# Macros for filtering outputs -###################################################################### - -HIDEBIBTEXINFO=| grep -v "^A level-1 auxiliary file" -SHOWMAKEINDEXERROR=egrep '^!! Input index error|^\*\* Input style error|^ --' - ###################################################################### # Common ###################################################################### @@ -164,99 +92,6 @@ doc/common/version.tex: config/Makefile printf '\\newcommand{\\coqversion}{$(VERSION)}' > doc/common/version.tex ###################################################################### -# Reference Manual -###################################################################### - - -### Reference Manual (printable format) - -# The second LATEX compilation is necessary otherwise the pages of the index -# are not correct (don't know why...) - BB -doc/refman/Reference-Manual.dvi: $(REFMANFILES) doc/refman/Reference-Manual.tex - @(cd doc/refman;\ - $(LATEX) -interaction=batchmode Reference-Manual;\ - $(BIBTEX) -terse Reference-Manual $(HIDEBIBTEXINFO);\ - $(LATEX) -interaction=batchmode Reference-Manual > /dev/null;\ - $(MAKEINDEX) -q Reference-Manual;\ - $(SHOWMAKEINDEXERROR) Reference-Manual.ilg;\ - $(MAKEINDEX) -q Reference-Manual.tacidx -o Reference-Manual.tacind;\ - $(SHOWMAKEINDEXERROR) Reference-Manual.ilg;\ - $(MAKEINDEX) -q Reference-Manual.comidx -o Reference-Manual.comind;\ - $(SHOWMAKEINDEXERROR) Reference-Manual.ilg;\ - $(MAKEINDEX) -q Reference-Manual.optidx -o Reference-Manual.optind;\ - $(SHOWMAKEINDEXERROR) Reference-Manual.ilg;\ - $(MAKEINDEX) -q Reference-Manual.erridx -o Reference-Manual.errind;\ - $(SHOWMAKEINDEXERROR) Reference-Manual.ilg;\ - $(LATEX) -interaction=batchmode Reference-Manual > /dev/null;\ - $(LATEX) -interaction=batchmode Reference-Manual > /dev/null;\ - ../tools/show_latex_messages -no-overfull Reference-Manual.log) - -doc/refman/Reference-Manual.pdf: doc/refman/Reference-Manual.dvi $(REFMANPNGFILES) - (cd doc/refman;\ - $(PDFLATEX) -interaction=batchmode Reference-Manual.tex;\ - ../tools/show_latex_messages -no-overfull Reference-Manual.log) - -### Reference Manual (browsable format) - -doc/refman/Reference-Manual.html: doc/refman/styles.hva doc/refman/headers.hva doc/refman/Reference-Manual.dvi # to ensure bbl file - (cd doc/refman; BIBINPUTS=.: $(HEVEA) $(HEVEAOPTS) ./styles.hva ./Reference-Manual.tex) - -doc/refman/cover.html: doc/common/styles/html/$(HTMLSTYLE)/cover.html - sed -e "s/COQVERSION/$(VERSION)/g" $< > $@ - -doc/refman/styles.hva: doc/common/styles/html/$(HTMLSTYLE)/styles.hva - $(INSTALLLIB) $< doc/refman - -INDEXES:= doc/refman/html/command-index.html doc/refman/html/tactic-index.html - -refman-html-dir $(INDEXES): doc/refman/html/index.html ; - -doc/refman/html/index.html: doc/refman/Reference-Manual.html $(REFMANPNGFILES) \ - doc/refman/cover.html doc/refman/styles.hva doc/refman/index.html - - rm -rf doc/refman/html - $(MKDIR) doc/refman/html - $(INSTALLLIB) $(REFMANPNGFILES) doc/refman/html - (cd doc/refman/html; $(HACHA) -nolinks -tocbis -o toc.html ../styles.hva ../Reference-Manual.html) - $(INSTALLLIB) doc/refman/cover.html doc/refman/html/index.html - @touch $(INDEXES) - (cd doc/common/styles/html/$(HTMLSTYLE);\ - for f in `find . -name \*.css`; do \ - $(MKDIR) $$(dirname ../../../../refman/html/$$f);\ - $(INSTALLLIB) $$f ../../../../refman/html/$$f;\ - done) - -refman-quick: - (cd doc/refman;\ - $(PDFLATEX) -interaction=batchmode Reference-Manual.tex;\ - ../tools/show_latex_messages -no-overfull Reference-Manual.log && \ - $(HEVEA) $(HEVEAOPTS) ./Reference-Manual.tex) - -###################################################################### -# Index file for CoqIDE -###################################################################### - -$(INDEXURLS): $(INDEXES) - cat $< | grep li-indexenv | grep href= | sed -e 's@.*>\([^<]*\)</span>.*, <a href="\([^"]*\)">.*@\1,\2@' > $@ - - -###################################################################### -# Tutorial -###################################################################### - -doc/tutorial/Tutorial.v.dvi: $(DOCCOMMON) doc/tutorial/Tutorial.v.tex - (cd doc/tutorial;\ - $(LATEX) -interaction=batchmode Tutorial.v;\ - ../tools/show_latex_messages Tutorial.v.log) - -doc/tutorial/Tutorial.v.pdf: $(DOCCOMMON) doc/tutorial/Tutorial.v.tex - (cd doc/tutorial;\ - $(PDFLATEX) -interaction=batchmode Tutorial.v.tex;\ - ../tools/show_latex_messages Tutorial.v.log) - -doc/tutorial/Tutorial.v.html: $(DOCCOMMON) doc/tutorial/Tutorial.v.tex - (cd doc/tutorial; $(HEVEA) $(HEVEAOPTS) Tutorial.v) - -###################################################################### # Standard library ###################################################################### @@ -330,63 +165,28 @@ doc/stdlib/FullLibrary.pdf: $(DOCCOMMON) doc/stdlib/FullLibrary.coqdoc.tex doc/s ../tools/show_latex_messages -no-overfull FullLibrary.log) ###################################################################### -# Tutorial on inductive types -###################################################################### - -doc/RecTutorial/RecTutorial.dvi: doc/common/version.tex doc/common/title.tex doc/RecTutorial/RecTutorial.tex - (cd doc/RecTutorial;\ - $(LATEX) -interaction=batchmode RecTutorial;\ - $(BIBTEX) -terse RecTutorial;\ - $(LATEX) -interaction=batchmode RecTutorial > /dev/null;\ - $(LATEX) -interaction=batchmode RecTutorial > /dev/null;\ - ../tools/show_latex_messages RecTutorial.log) - -doc/RecTutorial/RecTutorial.pdf: doc/common/version.tex doc/common/title.tex doc/RecTutorial/RecTutorial.dvi - (cd doc/RecTutorial;\ - $(PDFLATEX) -interaction=batchmode RecTutorial.tex;\ - ../tools/show_latex_messages RecTutorial.log) - -doc/RecTutorial/RecTutorial.html: doc/RecTutorial/RecTutorial.tex - (cd doc/RecTutorial; $(HEVEA) $(HEVEAOPTS) RecTutorial) - -###################################################################### # Install all documentation files ###################################################################### .PHONY: install-doc install-doc-meta install-doc-html install-doc-printable \ - install-doc-index-urls install-doc-sphinx + install-doc-sphinx install-doc-stdlib-html -install-doc: install-doc-meta install-doc-html install-doc-printable \ - install-doc-index-urls install-doc-sphinx +install-doc: install-doc-meta install-doc-html install-doc-printable install-doc-meta: $(MKDIR) $(FULLDOCDIR) $(INSTALLLIB) doc/LICENSE $(FULLDOCDIR)/LICENSE.doc -install-doc-html: - $(MKDIR) $(addprefix $(FULLDOCDIR)/html/, refman stdlib) - (for f in `cd doc/refman/html; find . -type f`; do \ - $(MKDIR) $$(dirname $(FULLDOCDIR)/html/refman/$$f);\ - $(INSTALLLIB) doc/refman/html/$$f $(FULLDOCDIR)/html/refman/$$f;\ - done) +install-doc-html: install-doc-stdlib-html install-doc-sphinx + +install-doc-stdlib-html: + $(MKDIR) $(FULLDOCDIR)/html/stdlib $(INSTALLLIB) doc/stdlib/html/* $(FULLDOCDIR)/html/stdlib - $(INSTALLLIB) doc/RecTutorial/RecTutorial.html $(FULLDOCDIR)/html/RecTutorial.html - $(INSTALLLIB) doc/tutorial/Tutorial.v.html $(FULLDOCDIR)/html/Tutorial.html install-doc-printable: $(MKDIR) $(FULLDOCDIR)/ps $(FULLDOCDIR)/pdf - $(INSTALLLIB) doc/refman/Reference-Manual.pdf \ - doc/stdlib/Library.pdf $(FULLDOCDIR)/pdf - $(INSTALLLIB) doc/refman/Reference-Manual.ps \ - doc/stdlib/Library.ps $(FULLDOCDIR)/ps - $(INSTALLLIB) doc/tutorial/Tutorial.v.pdf $(FULLDOCDIR)/pdf/Tutorial.pdf - $(INSTALLLIB) doc/RecTutorial/RecTutorial.pdf $(FULLDOCDIR)/pdf/RecTutorial.pdf - $(INSTALLLIB) doc/tutorial/Tutorial.v.ps $(FULLDOCDIR)/ps/Tutorial.ps - $(INSTALLLIB) doc/RecTutorial/RecTutorial.ps $(FULLDOCDIR)/ps/RecTutorial.ps - -install-doc-index-urls: - $(MKDIR) $(FULLDATADIR) - $(INSTALLLIB) $(INDEXURLS) $(FULLDATADIR) + $(INSTALLLIB) doc/stdlib/Library.pdf $(FULLDOCDIR)/pdf + $(INSTALLLIB) doc/stdlib/Library.ps $(FULLDOCDIR)/ps install-doc-sphinx: $(MKDIR) $(FULLDOCDIR)/sphinx @@ -472,13 +272,6 @@ $(OCAMLDOCDIR)/%.pdf: $(OCAMLDOCDIR)/%.tex $(HIDE)(cd $(OCAMLDOCDIR) ; pdflatex -interaction=batchmode $*.tex && pdflatex -interaction=batchmode $*.tex) $(HIDE)(cd doc/tools/; ./show_latex_messages -no-overfull ../../$(OCAMLDOCDIR)/$*.log) -########################################################################### -# local web server -########################################################################### - -serve-refman-8080: refman - cd doc/refman/html; python3 -m http.server 8080 - # For emacs: # Local Variables: # mode: makefile diff --git a/Makefile.ide b/Makefile.ide index ac4ba75d4..6bb0f62f3 100644 --- a/Makefile.ide +++ b/Makefile.ide @@ -36,16 +36,18 @@ COQIDEINAPP:=$(COQIDEAPP)/Contents/MacOS/coqide # Note : for just building bin/coqide, we could only consider # config, lib, ide and ide/utils. But the coqidetop plugin (the -# one that will be loaded by coqtop -ideslave) refers to some +# one that will be loaded by coqidetop) refers to some # core modules of coq, for instance printing/*. -IDESRCDIRS:= $(CORESRCDIRS) ide ide/utils +IDESRCDIRS:= $(CORESRCDIRS) ide ide/protocol COQIDEFLAGS=$(addprefix -I , $(IDESRCDIRS)) $(COQIDEINCLUDES) -IDEDEPS:=clib/clib.cma lib/lib.cma +IDEDEPS:=clib/clib.cma lib/lib.cma ide/protocol/ideprotocol.cma IDECMA:=ide/ide.cma -IDETOPLOOPCMA=ide/coqidetop.cma +IDETOPEXE=bin/coqidetop$(EXE) +IDETOP=bin/coqidetop.opt$(EXE) +IDETOPBYTE=bin/coqidetop.byte$(EXE) LINKIDE:=$(IDEDEPS) $(IDECDEPS) $(IDECMA) ide/coqide_main.mli ide/coqide_main.ml LINKIDEOPT:=$(IDEOPTCDEPS) $(patsubst %.cma,%.cmxa,$(IDEDEPS:.cmo=.cmx)) $(IDECMA:.cma=.cmxa) ide/coqide_main.mli ide/coqide_main.ml @@ -88,15 +90,15 @@ endif coqide-files: $(IDEFILES) -ide-byteloop: $(IDETOPLOOPCMA) -ide-optloop: $(IDETOPLOOPCMA:.cma=.cmxs) -ide-toploop: ide-$(BEST)loop +ide-byteloop: $(IDETOPBYTE) +ide-optloop: $(IDETOP) +ide-toploop: $(IDETOPEXE) ifeq ($(HASCOQIDE),opt) $(COQIDE): $(LINKIDEOPT) $(SHOW)'OCAMLOPT -o $@' - $(HIDE)$(OCAMLOPT) $(COQIDEFLAGS) $(OPTFLAGS) -o $@ unix.cmxa threads.cmxa lablgtk.cmxa \ - lablgtksourceview2.cmxa str.cmxa $(IDEFLAGS:.cma=.cmxa) $^ + $(HIDE)$(OCAMLOPT) $(COQIDEFLAGS) $(OPTFLAGS) -o $@ \ + -linkpkg -package str,unix,dynlink,threads,lablgtk2.sourceview2 $(IDEFLAGS:.cma=.cmxa) $^ $(STRIP) $@ else $(COQIDE): $(COQIDEBYTE) @@ -105,8 +107,8 @@ endif $(COQIDEBYTE): $(LINKIDE) $(SHOW)'OCAMLC -o $@' - $(HIDE)$(OCAMLC) $(COQIDEFLAGS) $(BYTEFLAGS) -o $@ unix.cma threads.cma lablgtk.cma \ - lablgtksourceview2.cma str.cma $(IDEFLAGS) $(IDECDEPSFLAGS) $^ + $(HIDE)$(OCAMLC) $(COQIDEFLAGS) $(BYTEFLAGS) -o $@ \ + -linkpkg -package str,unix,dynlink,threads,lablgtk2.sourceview2 $(IDEFLAGS) $(IDECDEPSFLAGS) $^ ide/coqide_main.ml: ide/coqide_main.ml4 config/Makefile # no camlp5deps here $(SHOW)'CAMLP5O $<' @@ -135,6 +137,28 @@ ide/ideutils.cmx: ide/ideutils.ml $(SHOW)'OCAMLOPT $<' $(HIDE)$(filter-out -safe-string,$(OCAMLOPT)) $(COQIDEFLAGS) $(filter-out -safe-string,$(OPTFLAGS)) -c $< +IDETOPCMA:=ide/ide_common.cma +IDETOPCMX:=$(IDETOPCMA:.cma=.cmxa) + +# Special rule for coqidetop +$(IDETOPEXE): $(IDETOP:.opt=.$(BEST)) + cp $< $@ + +$(IDETOP): ide/idetop.ml $(LINKCMX) $(LIBCOQRUN) $(IDETOPCMX) + $(SHOW)'COQMKTOP -o $@' + $(HIDE)$(OCAMLOPT) -linkall -linkpkg $(MLINCLUDES) -I ide -I ide/protocol/ \ + $(SYSMOD) -package camlp5.gramlib \ + $(LINKCMX) $(IDETOPCMX) $(OPTFLAGS) $(LINKMETADATA) $< -o $@ + $(STRIP) $@ + $(CODESIGN) $@ + +$(IDETOPBYTE): ide/idetop.ml $(LINKCMO) $(LIBCOQRUN) $(IDETOPCMA) + $(SHOW)'COQMKTOP -o $@' + $(HIDE)$(OCAMLC) -linkall -linkpkg $(MLINCLUDES) -I ide -I ide/protocol/ \ + -I kernel/byterun/ -cclib -lcoqrun $(VMBYTEFLAGS) \ + $(SYSMOD) -package camlp5.gramlib \ + $(LINKCMO) $(IDETOPCMA) $(BYTEFLAGS) $< -o $@ + #################### ## Install targets #################### @@ -164,13 +188,11 @@ install-ide-bin: install-ide-toploop: ifeq ($(BEST),opt) - $(MKDIR) $(FULLCOQLIB)/toploop/ - $(INSTALLBIN) $(IDETOPLOOPCMA:.cma=.cmxs) $(FULLCOQLIB)/toploop/ + $(INSTALLBIN) $(IDETOPEXE) $(IDETOP) $(FULLBINDIR) endif install-ide-toploop-byte: ifneq ($(BEST),opt) - $(MKDIR) $(FULLCOQLIB)/toploop/ - $(INSTALLBIN) $(IDETOPLOOPCMA) $(FULLCOQLIB)/toploop/ + $(INSTALLBIN) $(IDETOPEXE) $(IDETOPBYTE) $(FULLBINDIR) endif install-ide-devfiles: @@ -206,8 +228,7 @@ $(COQIDEAPP)/Contents: $(COQIDEINAPP): ide/macos_prehook.cmx $(LINKIDEOPT) | $(COQIDEAPP)/Contents $(SHOW)'OCAMLOPT -o $@' $(HIDE)$(OCAMLOPT) $(COQIDEFLAGS) $(OPTFLAGS) -o $@ \ - unix.cmxa lablgtk.cmxa lablgtksourceview2.cmxa str.cmxa \ - threads.cmxa $(IDEFLAGS:.cma=.cmxa) $^ + -linkpkg -package str,unix,dynlink,threads,lablgtk2.sourceview2 $(IDEFLAGS:.cma=.cmxa) $^ $(STRIP) $@ $(COQIDEAPP)/Contents/Resources/share: $(COQIDEAPP)/Contents diff --git a/Makefile.install b/Makefile.install index 02695287b..010e35d42 100644 --- a/Makefile.install +++ b/Makefile.install @@ -58,7 +58,7 @@ FULLDOCDIR=$(DOCDIR) endif .PHONY: install-coq install-binaries install-byte install-opt -.PHONY: install-tools install-library install-devfiles +.PHONY: install-tools install-library install-devfiles install-merlin .PHONY: install-coq-info install-coq-manpages install-emacs install-latex .PHONY: install-meta @@ -70,17 +70,11 @@ endif install-binaries: install-tools $(MKDIR) $(FULLBINDIR) - $(INSTALLBIN) $(COQC) $(COQTOPEXE) $(CHICKEN) $(FULLBINDIR) - $(MKDIR) $(FULLCOQLIB)/toploop -ifeq ($(BEST),opt) - $(INSTALLBIN) $(TOPLOOPCMA:.cma=.cmxs) $(FULLCOQLIB)/toploop/ -endif + $(INSTALLBIN) $(COQC) $(CHICKEN) $(COQTOPEXE) $(TOPBIN) $(FULLBINDIR) install-byte: install-coqide-byte $(MKDIR) $(FULLBINDIR) - $(INSTALLBIN) $(COQTOPBYTE) $(FULLBINDIR) - $(MKDIR) $(FULLCOQLIB)/toploop - $(INSTALLBIN) $(TOPLOOPCMA) $(FULLCOQLIB)/toploop/ + $(INSTALLBIN) $(TOPBYTE) $(FULLBINDIR) $(INSTALLSH) $(FULLCOQLIB) $(LINKCMO) $(PLUGINS) ifndef CUSTOM $(INSTALLLIB) $(DLLCOQRUN) $(FULLCOQLIB) @@ -88,7 +82,7 @@ endif install-tools: $(MKDIR) $(FULLBINDIR) - # recopie des fichiers de style pour coqide + # copy style files for coqide $(MKDIR) $(FULLCOQLIB)/tools/coqdoc $(INSTALLLIB) tools/coqdoc/coqdoc.css tools/coqdoc/coqdoc.sty $(FULLCOQLIB)/tools/coqdoc $(INSTALLBIN) $(TOOLS) $(FULLBINDIR) @@ -103,7 +97,9 @@ INSTALLCMI = $(sort \ $(foreach lib,$(CORECMA), $(addsuffix .cmi,$($(lib:.cma=_MLLIB_DEPENDENCIES))))) \ $(PLUGINS:.cmo=.cmi) -INSTALLCMX = $(sort $(filter-out checker/% ide/% tools/% dev/% configure.cmx, $(MLFILES:.ml=.cmx))) +INSTALLCMX = $(sort $(filter-out checker/% ide/% tools/% dev/% \ + configure.cmx toplevel/coqtop_byte_bin.cmx plugins/extraction/big.cmx, \ + $(MLFILES:.ml=.cmx))) install-devfiles: $(MKDIR) $(FULLBINDIR) @@ -118,6 +114,9 @@ ifeq ($(BEST),opt) $(INSTALLSH) $(FULLCOQLIB) $(LINKCMX) $(CORECMA:.cma=.a) $(STATICPLUGINS:.cma=.a) endif +install-merlin: + $(INSTALLSH) $(FULLCOQLIB) $(wildcard $(INSTALLCMX:.cmx=.cmt) $(INSTALLCMI:.cmi=.cmti) $(MLIFILES) $(MLFILES) $(MERLINFILES)) + install-library: $(MKDIR) $(FULLCOQLIB) $(INSTALLSH) $(FULLCOQLIB) $(LIBFILES) diff --git a/Makefile.vofiles b/Makefile.vofiles new file mode 100644 index 000000000..d0ae31733 --- /dev/null +++ b/Makefile.vofiles @@ -0,0 +1,43 @@ + +# This file calls [find] and as such is not suitable for inclusion in +# the test suite Makefile, unlike Makefile.common. + +########################################################################### +# vo files +########################################################################### + +THEORIESVO := $(patsubst %.v,%.vo,$(shell find theories -type f -name "*.v")) +PLUGINSVO := $(patsubst %.v,%.vo,$(shell find plugins -type f -name "*.v")) +ALLVO := $(THEORIESVO) $(PLUGINSVO) +VFILES := $(ALLVO:.vo=.v) + +## More specific targets + +THEORIESLIGHTVO:= \ + $(filter theories/Init/% theories/Logic/% theories/Unicode/% theories/Arith/%, $(THEORIESVO)) + +# convert a (stdlib) filename into a module name: +# remove .vo, replace theories and plugins by Coq, and replace slashes by dots +vo_to_mod = $(subst /,.,$(patsubst theories/%,Coq.%,$(patsubst plugins/%,Coq.%,$(1:.vo=)))) + +ALLMODS:=$(call vo_to_mod,$(ALLVO)) + + +# Converting a stdlib filename into native compiler filenames +# Used for install targets +vo_to_cm = $(foreach vo,$(1),$(dir $(vo)).coq-native/$(subst /,_,$(patsubst theories/%,NCoq_%,$(patsubst plugins/%,NCoq_%,$(vo:.vo=.cm*))))) + +vo_to_obj = $(foreach vo,$(1),$(dir $(vo)).coq-native/$(subst /,_,$(patsubst theories/%,NCoq_%,$(patsubst plugins/%,NCoq_%,$(vo:.vo=.o))))) + +GLOBFILES:=$(ALLVO:.vo=.glob) +ifdef NATIVECOMPUTE +NATIVEFILES := $(call vo_to_cm,$(ALLVO)) $(call vo_to_obj,$(ALLVO)) +else +NATIVEFILES := +endif +LIBFILES:=$(ALLVO) $(NATIVEFILES) $(VFILES) $(GLOBFILES) + +# For emacs: +# Local Variables: +# mode: makefile +# End: @@ -1,5 +1,6 @@ # Coq +[](https://gitlab.com/coq/coq/commits/master) [](https://travis-ci.org/coq/coq/builds) [](https://ci.appveyor.com/project/coq/coq/branch/master) [](https://circleci.com/gh/coq/workflows/coq/tree/master) @@ -13,11 +14,11 @@ environment for semi-interactive development of machine-checked proofs. ## Installation Download the pre-built packages of the [latest release](https://github.com/coq/coq/releases/latest) for Windows and MacOS; read the [help page](https://coq.inria.fr/opam/www/using.html) on how to install Coq with OPAM; -or refer to the [`INSTALL` file](/INSTALL) for the procedure to install from source. +or refer to the [`INSTALL` file](INSTALL) for the procedure to install from source. ## Documentation -The sources of the documentation can be found in directory [`doc`](/doc). The +The sources of the documentation can be found in directory [`doc`](doc). The documentation of the last released version is available on the Coq web site at [coq.inria.fr/documentation](http://coq.inria.fr/documentation). See also [Cocorico](https://github.com/coq/coq/wiki) (the Coq wiki), @@ -25,7 +26,7 @@ and the [Coq FAQ](https://github.com/coq/coq/wiki/The-Coq-FAQ), for additional user-contributed documentation. ## Changes -There is a file named [`CHANGES`](/CHANGES) that explains the differences and the +There is a file named [`CHANGES`](CHANGES) that explains the differences and the incompatibilities since last versions. If you upgrade Coq, please read it carefully. diff --git a/appveyor.yml b/appveyor.yml index 44a93d15d..cd3b88d00 100644 --- a/appveyor.yml +++ b/appveyor.yml @@ -10,10 +10,6 @@ image: environment: CYGMIRROR: http://ftp.inf.tu-dresden.de/software/windows/cygwin32 matrix: - - USEOPAM: false - ARCH: 32 - - USEOPAM: false - ARCH: 64 - USEOPAM: true ARCH: 64 @@ -21,11 +17,3 @@ build_script: - cmd: 'call %APPVEYOR_BUILD_FOLDER%\dev\ci\appveyor.bat' test: off - -artifacts: - - path: 'dev\nsis\*.exe' - name: installer - - - path: 'coq-opensource-archive-*.zip' - name: opensource-archive - diff --git a/checker/cic.mli b/checker/cic.mli index 42629ced2..27e2a479f 100644 --- a/checker/cic.mli +++ b/checker/cic.mli @@ -104,7 +104,7 @@ type constr = | Case of case_info * constr * constr * constr array | Fix of constr pfixpoint | CoFix of constr pcofixpoint - | Proj of projection * constr + | Proj of Projection.t * constr type existential = constr pexistential type rec_declaration = constr prec_declaration @@ -241,7 +241,7 @@ type constant_body = { const_type : constr; const_body_code : to_patch_substituted; const_universes : constant_universes; - const_proj : projection_body option; + const_proj : bool; const_inline_code : bool; const_typing_flags : typing_flags; } diff --git a/checker/closure.ml b/checker/closure.ml index 184af0e13..b9ae4daa8 100644 --- a/checker/closure.ml +++ b/checker/closure.ml @@ -135,22 +135,16 @@ let betaiotazeta = mkflags [fBETA;fIOTA;fZETA] * instantiations (cbv or lazy) are. *) -type 'a tableKey = - | ConstKey of 'a - | VarKey of Id.t - | RelKey of int - type table_key = Constant.t puniverses tableKey + +let eq_pconstant_key (c,u) (c',u') = + eq_constant_key c c' && Univ.Instance.equal u u' + module KeyHash = struct type t = table_key - let equal k1 k2 = match k1, k2 with - | ConstKey (c1,u1), ConstKey (c2,u2) -> Constant.UserOrd.equal c1 c2 - && Univ.Instance.equal u1 u2 - | VarKey id1, VarKey id2 -> Id.equal id1 id2 - | RelKey i1, RelKey i2 -> Int.equal i1 i2 - | (ConstKey _ | VarKey _ | RelKey _), _ -> false + let equal = Names.eq_table_key eq_pconstant_key open Hashset.Combine @@ -201,8 +195,6 @@ let defined_rels flags env = let mind_equiv_infos info = mind_equiv info.i_env -let eq_table_key = KeyHash.equal - let create mk_cl flgs env = { i_flags = flgs; i_repr = mk_cl; @@ -251,7 +243,7 @@ and fterm = | FInd of pinductive | FConstruct of pconstructor | FApp of fconstr * fconstr array - | FProj of projection * fconstr + | FProj of Projection.t * fconstr | 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 *) @@ -281,7 +273,7 @@ let update v1 (no,t) = type stack_member = | Zapp of fconstr array | ZcaseT of case_info * constr * constr array * fconstr subs - | Zproj of int * int * projection + | Zproj of int * int * Projection.t | Zfix of fconstr * stack | Zshift of int | Zupdate of fconstr @@ -762,7 +754,7 @@ let rec knr info m stk = | (_,args,s) -> (m,args@s)) | FCoFix _ when red_set info.i_flags fIOTA -> (match strip_update_shift_app m stk with - (_, args, (((ZcaseT _)::_) as stk')) -> + (_, args, (((ZcaseT _|Zproj _)::_) as stk')) -> let (fxe,fxbd) = contract_fix_vect m.term in knit info fxe fxbd (args@stk') | (_,args,s) -> (m,args@s)) diff --git a/checker/closure.mli b/checker/closure.mli index f68c0468a..49b07f730 100644 --- a/checker/closure.mli +++ b/checker/closure.mli @@ -58,10 +58,6 @@ val betaiotazeta : reds val betadeltaiotanolet : reds (***********************************************************************) -type 'a tableKey = - | ConstKey of 'a - | VarKey of Id.t - | RelKey of int type table_key = Constant.t puniverses tableKey @@ -87,7 +83,7 @@ type fterm = | FInd of pinductive | FConstruct of pconstructor | FApp of fconstr * fconstr array - | FProj of projection * fconstr + | FProj of Projection.t * fconstr | 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 *) @@ -107,7 +103,7 @@ type fterm = type stack_member = | Zapp of fconstr array | ZcaseT of case_info * constr * constr array * fconstr subs - | Zproj of int * int * projection + | Zproj of int * int * Projection.t | Zfix of fconstr * stack | Zshift of int | Zupdate of fconstr @@ -162,7 +158,6 @@ val unfold_reference : clos_infos -> table_key -> fconstr option (* [mind_equiv] checks whether two inductive types are intentionally equal *) val mind_equiv_infos : clos_infos -> inductive -> inductive -> bool -val eq_table_key : table_key -> table_key -> bool (************************************************************************) (*i This is for lazy debug *) diff --git a/checker/declarations.ml b/checker/declarations.ml index 2fe930dca..e1d2cf6d1 100644 --- a/checker/declarations.ml +++ b/checker/declarations.ml @@ -231,7 +231,7 @@ let rec map_kn f f' c = in let p' = func p in let ct' = func ct in - let l' = Array.smartmap func l in + let l' = Array.Smart.map func l in if (ci.ci_ind==ci_ind && p'==p && l'==l && ct'==ct)then c else @@ -260,21 +260,21 @@ let rec map_kn f f' c = else LetIn (na, b', t', ct') | App (ct,l) -> let ct' = func ct in - let l' = Array.smartmap func l in + let l' = Array.Smart.map func l in if (ct'== ct && l'==l) then c else App (ct',l') | Evar (e,l) -> - let l' = Array.smartmap func l in + let l' = Array.Smart.map func l in if (l'==l) then c else Evar (e,l') | Fix (ln,(lna,tl,bl)) -> - let tl' = Array.smartmap func tl in - let bl' = Array.smartmap func bl in + let tl' = Array.Smart.map func tl in + let bl' = Array.Smart.map func bl in if (bl == bl'&& tl == tl') then c else Fix (ln,(lna,tl',bl')) | CoFix(ln,(lna,tl,bl)) -> - let tl' = Array.smartmap func tl in - let bl' = Array.smartmap func bl in + let tl' = Array.Smart.map func tl in + let bl' = Array.Smart.map func bl in if (bl == bl'&& tl == tl') then c else CoFix (ln,(lna,tl',bl')) | _ -> c @@ -480,7 +480,7 @@ let dest_subterms p = let (_,cstrs) = Rtree.dest_node p in Array.map (fun t -> Array.to_list (snd (Rtree.dest_node t))) cstrs -let subst_wf_paths sub p = Rtree.smartmap (subst_recarg sub) p +let subst_wf_paths sub p = Rtree.Smart.map (subst_recarg sub) p let eq_recarg r1 r2 = match r1, r2 with | Norec, Norec -> true @@ -513,7 +513,7 @@ let subst_decl_arity f g sub ar = let subst_rel_declaration sub = Term.map_rel_decl (subst_mps sub) -let subst_rel_context sub = List.smartmap (subst_rel_declaration sub) +let subst_rel_context sub = List.Smart.map (subst_rel_declaration sub) let constant_is_polymorphic cb = match cb.const_universes with @@ -544,10 +544,10 @@ let subst_mind_packet sub mbp = mind_consnrealdecls = mbp.mind_consnrealdecls; mind_consnrealargs = mbp.mind_consnrealargs; mind_typename = mbp.mind_typename; - mind_nf_lc = Array.smartmap (subst_mps sub) mbp.mind_nf_lc; + mind_nf_lc = Array.Smart.map (subst_mps sub) mbp.mind_nf_lc; mind_arity_ctxt = subst_rel_context sub mbp.mind_arity_ctxt; mind_arity = subst_ind_arity sub mbp.mind_arity; - mind_user_lc = Array.smartmap (subst_mps sub) mbp.mind_user_lc; + mind_user_lc = Array.Smart.map (subst_mps sub) mbp.mind_user_lc; mind_nrealargs = mbp.mind_nrealargs; mind_nrealdecls = mbp.mind_nrealdecls; mind_kelim = mbp.mind_kelim; @@ -560,7 +560,7 @@ let subst_mind_packet sub mbp = let subst_mind sub mib = { mib with mind_params_ctxt = map_rel_context (subst_mps sub) mib.mind_params_ctxt; - mind_packets = Array.smartmap (subst_mind_packet sub) mib.mind_packets } + mind_packets = Array.Smart.map (subst_mind_packet sub) mib.mind_packets } (* Modules *) @@ -599,7 +599,7 @@ and subst_body : 'a. (_ -> 'a -> 'a) -> _ -> 'a generic_module_body -> 'a generi mod_mp = subst_mp sub mb.mod_mp; mod_expr = subst_impl sub mb.mod_expr; mod_type = subst_signature sub mb.mod_type; - mod_type_alg = Option.smartmap (subst_expression sub) mb.mod_type_alg } + mod_type_alg = Option.Smart.map (subst_expression sub) mb.mod_type_alg } and subst_module sub mb = subst_body (fun sub e -> implem_map (subst_signature sub) (subst_expression sub) e) sub mb diff --git a/checker/environ.ml b/checker/environ.ml index bbd043c8e..809150cea 100644 --- a/checker/environ.ml +++ b/checker/environ.ml @@ -7,6 +7,7 @@ open Declarations type globals = { env_constants : constant_body Cmap_env.t; + env_projections : projection_body Cmap_env.t; env_inductives : mutual_inductive_body Mindmap_env.t; env_inductives_eq : KerName.t KNmap.t; env_modules : module_body MPmap.t; @@ -34,6 +35,7 @@ let empty_oracle = { let empty_env = { env_globals = { env_constants = Cmap_env.empty; + env_projections = Cmap_env.empty; env_inductives = Mindmap_env.empty; env_inductives_eq = KNmap.empty; env_modules = MPmap.empty; @@ -165,12 +167,10 @@ let evaluable_constant cst env = with Not_found | NotEvaluableConst _ -> false let is_projection cst env = - not (Option.is_empty (lookup_constant cst env).const_proj) + (lookup_constant cst env).const_proj let lookup_projection p env = - match (lookup_constant (Projection.constant p) env).const_proj with - | Some pb -> pb - | None -> anomaly ("lookup_projection: constant is not a projection.") + Cmap_env.find (Projection.constant p) env.env_globals.env_projections (* Mutual Inductives *) let scrape_mind env kn= @@ -194,6 +194,13 @@ let add_mind kn mib env = Printf.ksprintf anomaly ("Inductive %s is already defined.") (MutInd.to_string kn); let new_inds = Mindmap_env.add kn mib env.env_globals.env_inductives in + let new_projections = match mib.mind_record with + | None | Some None -> env.env_globals.env_projections + | Some (Some (id, kns, pbs)) -> + Array.fold_left2 (fun projs kn pb -> + Cmap_env.add kn pb projs) + env.env_globals.env_projections kns pbs + in let kn1,kn2 = MutInd.user kn, MutInd.canonical kn in let new_inds_eq = if KerName.equal kn1 kn2 then env.env_globals.env_inductives_eq @@ -201,8 +208,9 @@ let add_mind kn mib env = KNmap.add kn1 kn2 env.env_globals.env_inductives_eq in let new_globals = { env.env_globals with - env_inductives = new_inds; - env_inductives_eq = new_inds_eq} in + env_inductives = new_inds; + env_projections = new_projections; + env_inductives_eq = new_inds_eq} in { env with env_globals = new_globals } diff --git a/checker/environ.mli b/checker/environ.mli index 36e0ea027..4a7597249 100644 --- a/checker/environ.mli +++ b/checker/environ.mli @@ -5,6 +5,7 @@ open Cic type globals = { env_constants : constant_body Cmap_env.t; + env_projections : projection_body Cmap_env.t; env_inductives : mutual_inductive_body Mindmap_env.t; env_inductives_eq : KerName.t KNmap.t; env_modules : module_body MPmap.t; @@ -58,7 +59,7 @@ val constant_value : env -> Constant.t puniverses -> constr val evaluable_constant : Constant.t -> env -> bool val is_projection : Constant.t -> env -> bool -val lookup_projection : projection -> env -> projection_body +val lookup_projection : Projection.t -> env -> projection_body (* Inductives *) val mind_equiv : env -> inductive -> inductive -> bool diff --git a/checker/indtypes.ml b/checker/indtypes.ml index f403834f5..916934a81 100644 --- a/checker/indtypes.ml +++ b/checker/indtypes.ml @@ -598,16 +598,18 @@ let check_subtyping cumi paramsctxt env inds = let check_inductive env kn mib = Flags.if_verbose Feedback.msg_notice (str " checking ind: " ++ MutInd.print kn); (* check mind_constraints: should be consistent with env *) - let ind_ctx = + let env0 = match mib.mind_universes with - | Monomorphic_ind _ -> Univ.UContext.empty (** Already in the global environment *) - | Polymorphic_ind auctx -> Univ.AUContext.repr auctx + | Monomorphic_ind _ -> env + | Polymorphic_ind auctx -> + let uctx = Univ.AUContext.repr auctx in + Environ.push_context uctx env | Cumulative_ind cumi -> - Univ.AUContext.repr (Univ.ACumulativityInfo.univ_context cumi) + let uctx = Univ.AUContext.repr (Univ.ACumulativityInfo.univ_context cumi) in + Environ.push_context uctx env in - let env = Environ.push_context ind_ctx env in (** Locally set the oracle for further typechecking *) - let env0 = Environ.set_oracle env mib.mind_typing_flags.conv_oracle in + let env0 = Environ.set_oracle env0 mib.mind_typing_flags.conv_oracle in (* check mind_record : TODO ? check #constructor = 1 ? *) (* check mind_finite : always OK *) (* check mind_ntypes *) diff --git a/checker/mod_checking.ml b/checker/mod_checking.ml index 7685863ea..ca9581167 100644 --- a/checker/mod_checking.ml +++ b/checker/mod_checking.ml @@ -47,13 +47,8 @@ let check_constant_declaration env kn cb = let () = match body_of_constant cb with | Some bd -> - (match cb.const_proj with - | None -> let j = infer envty bd in - conv_leq envty j ty - | Some pb -> - let env' = add_constant kn cb env' in - let j = infer env' bd in - conv_leq envty j ty) + let j = infer envty bd in + conv_leq envty j ty | None -> () in let env = diff --git a/checker/reduction.ml b/checker/reduction.ml index 97255dd49..4e508dc77 100644 --- a/checker/reduction.ml +++ b/checker/reduction.ml @@ -8,6 +8,7 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) +open Names open CErrors open Util open Cic @@ -54,7 +55,7 @@ let compare_stack_shape stk1 stk2 = type lft_constr_stack_elt = Zlapp of (lift * fconstr) array - | Zlproj of Names.projection * lift + | Zlproj of Names.Projection.t * lift | Zlfix of (lift * fconstr) * lft_constr_stack | Zlcase of case_info * lift * fconstr * fconstr array and lft_constr_stack = lft_constr_stack_elt list @@ -142,7 +143,7 @@ let compare_stacks f fmind lft1 stk1 lft2 stk2 = | (Zlfix(fx1,a1),Zlfix(fx2,a2)) -> f fx1 fx2; cmp_rec a1 a2 | (Zlproj (c1,l1),Zlproj (c2,l2)) -> - if not (Names.eq_con_chk + if not (Names.Constant.UserOrd.equal (Names.Projection.constant c1) (Names.Projection.constant c2)) then raise NotConvertible @@ -297,6 +298,11 @@ let oracle_order infos l2r k1 k2 = if Int.equal n1 n2 then l2r else n1 < n2 +let eq_table_key univ = + Names.eq_table_key (fun (c1,u1) (c2,u2) -> + Constant.UserOrd.equal c1 c2 && + Univ.Instance.check_eq univ u1 u2) + (* Conversion between [lft1]term1 and [lft2]term2 *) let rec ccnv univ cv_pb infos lft1 lft2 term1 term2 = eqappr univ cv_pb infos (lft1, (term1,[])) (lft2, (term2,[])) @@ -343,7 +349,7 @@ and eqappr univ cv_pb infos (lft1,st1) (lft2,st2) = (* 2 constants, 2 local defined vars or 2 defined rels *) | (FFlex fl1, FFlex fl2) -> (try (* try first intensional equality *) - if eq_table_key fl1 fl2 + if eq_table_key univ fl1 fl2 then convert_stacks univ infos lft1 lft2 v1 v2 else raise NotConvertible with NotConvertible -> diff --git a/checker/subtyping.ml b/checker/subtyping.ml index ee73eb1ab..5c672d04a 100644 --- a/checker/subtyping.ml +++ b/checker/subtyping.ml @@ -224,7 +224,7 @@ let check_inductive env mp1 l info1 mib2 spec2 subst1 subst2= | Some None, Some None -> true | Some (Some (id1,p1,pb1)), Some (Some (id2,p2,pb2)) -> Id.equal id1 id2 && - Array.for_all2 eq_con_chk p1 p2 && + Array.for_all2 Constant.UserOrd.equal p1 p2 && Array.for_all2 eq_projection_body pb1 pb2 | _, _ -> false in @@ -303,7 +303,18 @@ let check_constant env mp1 l info1 cb2 spec2 subst1 subst2 = | Constant cb1 -> let cb1 = subst_const_body subst1 cb1 in let cb2 = subst_const_body subst2 cb2 in - (*Start by checking types*) + (*Start by checking universes *) + let env = + match cb1.const_universes, cb2.const_universes with + | Monomorphic_const _, Monomorphic_const _ -> env + | Polymorphic_const auctx1, Polymorphic_const auctx2 -> + check_polymorphic_instance error env auctx1 auctx2 + | Monomorphic_const _, Polymorphic_const _ -> + error () + | Polymorphic_const _, Monomorphic_const _ -> + error () + in + (* Now check types *) let typ1 = cb1.const_type in let typ2 = cb2.const_type in check_type env typ1 typ2; diff --git a/checker/term.ml b/checker/term.ml index 19034a57d..509634bdb 100644 --- a/checker/term.ml +++ b/checker/term.ml @@ -243,7 +243,7 @@ let map_rel_decl f = function LocalDef (n, body', typ') let map_rel_context f = - List.smartmap (map_rel_decl f) + List.Smart.map (map_rel_decl f) let extended_rel_list n hyps = let rec reln l p = function @@ -390,7 +390,7 @@ let compare_constr f t1 t2 = f h1 h2 && List.for_all2 f l1 l2 else false | Evar (e1,l1), Evar (e2,l2) -> Int.equal e1 e2 && Array.equal f l1 l2 - | Const c1, Const c2 -> eq_puniverses eq_con_chk c1 c2 + | Const c1, Const c2 -> eq_puniverses Constant.UserOrd.equal c1 c2 | Ind c1, Ind c2 -> eq_puniverses eq_ind_chk c1 c2 | Construct ((c1,i1),u1), Construct ((c2,i2),u2) -> Int.equal i1 i2 && eq_ind_chk c1 c2 && Univ.Instance.equal u1 u2 diff --git a/checker/univ.ml b/checker/univ.ml index fc0764077..15673736f 100644 --- a/checker/univ.ml +++ b/checker/univ.ml @@ -142,7 +142,13 @@ end (** Level sets and maps *) module LMap = HMap.Make (Level) -module LSet = LMap.Set +module LSet = struct + include LMap.Set + + let pr s = + str"{" ++ prlist_with_sep spc Level.pr (elements s) ++ str"}" + +end type 'a universe_map = 'a LMap.t @@ -308,7 +314,7 @@ struct let for_all = List.for_all - let smartmap = List.smartmap + let smart_map = List.Smart.map end @@ -905,12 +911,12 @@ struct let is_empty x = Int.equal (Array.length x) 0 let subst_fn fn t = - let t' = CArray.smartmap fn t in + let t' = CArray.Smart.map fn t in if t' == t then t else t' let subst s t = let t' = - CArray.smartmap (fun x -> try LMap.find x s with Not_found -> x) t + CArray.Smart.map (fun x -> try LMap.find x s with Not_found -> x) t in if t' == t then t else t' let pr = @@ -946,11 +952,11 @@ let subst_instance_level s l = | _ -> l let subst_instance_instance s i = - Array.smartmap (fun l -> subst_instance_level s l) i + Array.Smart.map (fun l -> subst_instance_level s l) i let subst_instance_universe s u = let f x = Universe.Expr.map (fun u -> subst_instance_level s u) x in - let u' = Universe.smartmap f u in + let u' = Universe.smart_map f u in if u == u' then u else Universe.sort u' @@ -1091,7 +1097,7 @@ let subst_univs_level_level subst l = let subst_univs_level_universe subst u = let f x = Universe.Expr.map (fun u -> subst_univs_level_level subst u) x in - let u' = Universe.smartmap f u in + let u' = Universe.smart_map f u in if u == u' then u else Universe.sort u' diff --git a/checker/univ.mli b/checker/univ.mli index 935f0a2b8..6cd3b3638 100644 --- a/checker/univ.mli +++ b/checker/univ.mli @@ -49,6 +49,7 @@ sig val make : Level.t -> t (** Create a universe representing the given level. *) + val pr : t -> Pp.t end type universe = Universe.t @@ -140,7 +141,14 @@ val check_constraints : constraints -> universes -> bool (** Polymorphic maps from universe levels to 'a *) module LMap : CSig.MapS with type key = universe_level -module LSet : CSig.SetS with type elt = universe_level +module LSet : +sig + include CSig.SetS with type elt = Level.t + + val pr : t -> Pp.t + (** Pretty-printing *) +end + type 'a universe_map = 'a LMap.t (** {6 Substitution} *) @@ -216,6 +224,8 @@ sig val instantiate : Instance.t -> t -> Constraint.t val repr : t -> UContext.t + val pr : (Level.t -> Pp.t) -> t -> Pp.t + end type abstract_universe_context = AUContext.t diff --git a/checker/values.ml b/checker/values.ml index 160653d9b..f7ab95fe2 100644 --- a/checker/values.ml +++ b/checker/values.ml @@ -15,7 +15,7 @@ To ensure this file is up-to-date, 'make' now compares the md5 of cic.mli with a copy we maintain here: -MD5 2c3436106636784886f122c8ab578098 checker/cic.mli +MD5 92de14d7bf9134532e8a0cff5618bd50 checker/cic.mli *) @@ -240,7 +240,7 @@ let v_cb = v_tuple "constant_body" v_constr; Any; v_const_univs; - Opt v_projbody; + v_bool; v_bool; v_typing_flags|] diff --git a/clib/cArray.ml b/clib/cArray.ml index 5eb20bc16..b26dae729 100644 --- a/clib/cArray.ml +++ b/clib/cArray.ml @@ -50,7 +50,9 @@ sig val map_of_list : ('a -> 'b) -> 'a list -> 'b array val chop : int -> 'a array -> 'a array * 'a array val smartmap : ('a -> 'a) -> 'a array -> 'a array + [@@ocaml.deprecated "Same as [Smart.map]"] val smartfoldmap : ('r -> 'a -> 'r * 'a) -> 'r -> 'a array -> 'r * 'a array + [@@ocaml.deprecated "Same as [Smart.fold_left_map]"] val map2 : ('a -> 'b -> 'c) -> 'a array -> 'b array -> 'c array val map2_i : (int -> 'a -> 'b -> 'c) -> 'a array -> 'b array -> 'c array val map3 : @@ -62,13 +64,35 @@ sig val fold_left2_map : ('a -> 'b -> 'c -> 'a * 'd) -> 'a -> 'b array -> 'c array -> 'a * 'd array val fold_right2_map : ('a -> 'b -> 'c -> 'd * 'c) -> 'a array -> 'b array -> 'c -> 'd array * 'c val fold_map : ('a -> 'b -> 'a * 'c) -> 'a -> 'b array -> 'a * 'c array + [@@ocaml.deprecated "Same as [fold_left_map]"] val fold_map' : ('a -> 'c -> 'b * 'c) -> 'a array -> 'c -> 'b array * 'c + [@@ocaml.deprecated "Same as [fold_right_map]"] val fold_map2' : ('a -> 'b -> 'c -> 'd * 'c) -> 'a array -> 'b array -> 'c -> 'd array * 'c + [@@ocaml.deprecated "Same as [fold_right2_map]"] val distinct : 'a array -> bool val rev_of_list : 'a list -> 'a array val rev_to_list : 'a array -> 'a list val filter_with : bool list -> 'a array -> 'a array + module Smart : + sig + val map : ('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 + end + module Fun1 : + sig + val map : ('r -> 'a -> 'b) -> 'r -> 'a array -> 'b array + val smartmap : ('r -> 'a -> 'a) -> 'r -> 'a array -> 'a array + [@@ocaml.deprecated "Same as [Fun1.Smart.map]"] + val iter : ('r -> 'a -> unit) -> 'r -> 'a array -> unit + val iter2 : ('r -> 'a -> 'b -> unit) -> 'r -> 'a array -> 'b array -> unit + module Smart : + sig + val map : ('r -> 'a -> 'a) -> 'r -> 'a array -> 'a array + end + end end include Array @@ -323,72 +347,6 @@ let chop n v = if n > vlen then failwith "Array.chop"; (Array.sub v 0 n, Array.sub v n (vlen-n)) -(* If none of the elements is changed by f we return ar itself. - The while loop looks for the first such an element. - If found, we break here and the new array is produced, - but f is not re-applied to elements that are already checked *) -let smartmap 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 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 v in - if v != v' then Array.unsafe_set ans !i v'; - incr i - done; - ans - end else ar - -(** Same as [smartmap] but threads a state meanwhile *) -let smartfoldmap f accu (ar : 'a array) = - let len = Array.length ar in - let i = ref 0 in - let break = ref true in - let r = ref accu in - (** This variable is never accessed unset *) - let temp = ref None in - while !break && (!i < len) do - let v = Array.unsafe_get ar !i in - let (accu, v') = f !r v in - r := accu; - if v == v' then incr i - else begin - break := false; - temp := Some v'; - end - done; - if !i < len then begin - 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 ar !i in - let (accu, v') = f !r v in - r := accu; - if v != v' then Array.unsafe_set ans !i v'; - incr i - done; - !r, ans - end else !r, ar - let map2 f v1 v2 = let len1 = Array.length v1 in let len2 = Array.length v2 in @@ -505,29 +463,53 @@ let rev_to_list a = let filter_with filter v = Array.of_list (CList.filter_with filter (Array.to_list v)) -module Fun1 = +module Smart = struct - let map f arg v = match v with - | [| |] -> [| |] - | _ -> - let len = Array.length v in - let x0 = Array.unsafe_get v 0 in - let ans = Array.make len (f arg x0) in - for i = 1 to pred len do - let x = Array.unsafe_get v i in - Array.unsafe_set ans i (f arg x) + (* If none of the elements is changed by f we return ar itself. + The while loop looks for the first such an element. + If found, we break here and the new array is produced, + but f is not re-applied to elements that are already checked *) + let map 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 v in + if v == v' then incr i + else begin + break := false; + temp := Some v'; + end done; - ans + 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 v in + if v != v' then Array.unsafe_set ans !i v'; + incr i + done; + ans + end else ar - let smartmap f arg (ar : 'a array) = + let map2 f aux_ar ar = let len = Array.length ar in + let aux_len = Array.length aux_ar in + let () = if not (Int.equal len aux_len) then invalid_arg "Array.Smart.map2" 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 arg v in + let w = Array.unsafe_get aux_ar !i in + let v' = f w v in if v == v' then incr i else begin break := false; @@ -542,13 +524,105 @@ struct incr i; while !i < len do let v = Array.unsafe_get ans !i in - let v' = f arg v in + let w = Array.unsafe_get aux_ar !i in + let v' = f w v in if v != v' then Array.unsafe_set ans !i v'; incr i done; ans end else ar + (** Same as [Smart.map] but threads a state meanwhile *) + let fold_left_map f accu (ar : 'a array) = + let len = Array.length ar in + let i = ref 0 in + let break = ref true in + let r = ref accu in + (** This variable is never accessed unset *) + let temp = ref None in + while !break && (!i < len) do + let v = Array.unsafe_get ar !i in + let (accu, v') = f !r v in + r := accu; + if v == v' then incr i + else begin + break := false; + temp := Some v'; + end + done; + if !i < len then begin + 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 ar !i in + let (accu, v') = f !r v in + r := accu; + if v != v' then Array.unsafe_set ans !i v'; + incr i + done; + !r, ans + end else !r, ar + + (** Same as [Smart.map2] but threads a state meanwhile *) + let fold_left2_map f accu aux_ar ar = + let len = Array.length ar in + let aux_len = Array.length aux_ar in + let () = if not (Int.equal len aux_len) then invalid_arg "Array.Smart.fold_left2_map" in + let i = ref 0 in + let break = ref true in + let r = ref accu in + (** This variable is never accessed unset *) + let temp = ref None in + while !break && (!i < len) do + let v = Array.unsafe_get ar !i in + let w = Array.unsafe_get aux_ar !i in + let (accu, v') = f !r w v in + r := accu; + if v == v' then incr i + else begin + break := false; + temp := Some v'; + end + done; + if !i < len then begin + 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 ar !i in + let w = Array.unsafe_get aux_ar !i in + let (accu, v') = f !r w v in + r := accu; + if v != v' then Array.unsafe_set ans !i v'; + incr i + done; + !r, ans + end else !r, ar + +end + +(* Deprecated aliases *) +let smartmap = Smart.map +let smartfoldmap = Smart.fold_left_map + +module Fun1 = +struct + + let map f arg v = match v with + | [| |] -> [| |] + | _ -> + let len = Array.length v in + let x0 = Array.unsafe_get v 0 in + let ans = Array.make len (f arg x0) in + for i = 1 to pred len do + let x = Array.unsafe_get v i in + Array.unsafe_set ans i (f arg x) + done; + ans + let iter f arg v = let len = Array.length v in for i = 0 to pred len do @@ -556,4 +630,50 @@ struct f arg x done + let iter2 f arg v1 v2 = + let len1 = Array.length v1 in + let len2 = Array.length v2 in + let () = if not (Int.equal len2 len1) then invalid_arg "Array.Fun1.iter2" in + for i = 0 to pred len1 do + let x1 = uget v1 i in + let x2 = uget v2 i in + f arg x1 x2 + done + + module Smart = + struct + + let map f arg (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 arg 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 arg v in + if v != v' then Array.unsafe_set ans !i v'; + incr i + done; + ans + end else ar + + end + + let smartmap = Smart.map + end diff --git a/clib/cArray.mli b/clib/cArray.mli index f4f60f8aa..8bf33f82f 100644 --- a/clib/cArray.mli +++ b/clib/cArray.mli @@ -83,13 +83,14 @@ sig Raise [Failure "Array.chop"] if [i] is not a valid index. *) val smartmap : ('a -> 'a) -> 'a array -> 'a array - (** [smartmap f a] behaves as [map f a] but returns [a] instead of a copy when - [f x == x] for all [x] in [a]. *) + [@@ocaml.deprecated "Same as [Smart.map]"] val smartfoldmap : ('r -> 'a -> 'r * 'a) -> 'r -> 'a array -> 'r * 'a array - (** Same as [smartmap] but threads an additional state left-to-right. *) + [@@ocaml.deprecated "Same as [Smart.fold_left_map]"] val map2 : ('a -> 'b -> 'c) -> 'a array -> 'b array -> 'c array + (** See also [Smart.map2] *) + 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 @@ -102,26 +103,26 @@ sig val fold_left_map : ('a -> 'b -> 'a * 'c) -> 'a -> 'b array -> 'a * 'c array (** [fold_left_map f e_0 [|l_1...l_n|] = e_n,[|k_1...k_n|]] - where [(e_i,k_i)=f e_{i-1} l_i] *) + where [(e_i,k_i)=f e_{i-1} l_i]; see also [Smart.fold_left_map] *) val fold_right_map : ('a -> 'c -> 'b * 'c) -> 'a array -> 'c -> 'b array * 'c (** Same, folding on the right *) val fold_left2_map : ('a -> 'b -> 'c -> 'a * 'd) -> 'a -> 'b array -> 'c array -> 'a * 'd array - (** Same with two arrays, folding on the left *) + (** Same with two arrays, folding on the left; see also [Smart.fold_left2_map] *) val fold_right2_map : ('a -> 'b -> 'c -> 'd * 'c) -> 'a array -> 'b array -> 'c -> 'd array * 'c (** Same with two arrays, folding on the left *) val fold_map : ('a -> 'b -> 'a * 'c) -> 'a -> 'b array -> 'a * 'c array - (** @deprecated Same as [fold_left_map] *) + [@@ocaml.deprecated "Same as [fold_left_map]"] val fold_map' : ('a -> 'c -> 'b * 'c) -> 'a array -> 'c -> 'b array * 'c - (** @deprecated Same as [fold_right_map] *) + [@@ocaml.deprecated "Same as [fold_right_map]"] val fold_map2' : ('a -> 'b -> 'c -> 'd * 'c) -> 'a array -> 'b array -> 'c -> 'd array * 'c - (** @deprecated Same as [fold_right2_map] *) + [@@ocaml.deprecated "Same as [fold_right2_map]"] val distinct : 'a array -> bool (** Return [true] if every element of the array is unique (for default @@ -137,23 +138,57 @@ sig (** [filter_with b a] selects elements of [a] whose corresponding element in [b] is [true]. Raise [Invalid_argument _] when sizes differ. *) + module Smart : + sig + val map : ('a -> 'a) -> 'a array -> 'a array + (** [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 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. *) + + val fold_left_map : ('a -> 'b -> 'a * 'b) -> 'a -> 'b array -> 'a * 'b array + (** [Smart.fold_left_mapf a b] behaves as [fold_left_map] but + returns [b] as second component instead of a copy of [b] when + the output array is pointwise the same as the input array [b] *) + + val fold_left2_map : ('a -> 'b -> 'c -> 'a * 'c) -> 'a -> 'b array -> 'c array -> 'a * 'c array + (** [Smart.fold_left2_map f a b c] behaves as [fold_left2_map] but + returns [c] as second component instead of a copy of [c] when + the output array is pointwise the same as the input array [c] *) + + end + (** The functions defined in this module are optimized specializations + of the main ones, when the returned array is of same type as one of + the original array. *) + + module Fun1 : + sig + val map : ('r -> 'a -> 'b) -> 'r -> 'a array -> 'b array + (** [Fun1.map f x v = map (f x) v] *) + + val smartmap : ('r -> 'a -> 'a) -> 'r -> 'a array -> 'a array + [@@ocaml.deprecated "Same as [Fun1.Smart.map]"] + + val iter : ('r -> 'a -> unit) -> 'r -> 'a array -> unit + (** [Fun1.iter f x v = iter (f x) v] *) + + val iter2 : ('r -> 'a -> 'b -> unit) -> 'r -> 'a array -> 'b array -> unit + (** [Fun1.iter2 f x v1 v2 = iter (f x) v1 v2] *) + + module Smart : + sig + val map : ('r -> 'a -> 'a) -> 'r -> 'a array -> 'a array + (** [Fun1.Smart.map f x v = Smart.map (f x) v] *) + end + + end + (** The functions defined in this module are the same as the main ones, except + that they are all higher-order, and their function arguments have an + additional parameter. This allows us to prevent closure creation in critical + cases. *) + end include ExtS - -module Fun1 : -sig - val map : ('r -> 'a -> 'b) -> 'r -> 'a array -> 'b array - (** [Fun1.map f x v = map (f x) v] *) - - val smartmap : ('r -> 'a -> 'a) -> 'r -> 'a array -> 'a array - (** [Fun1.smartmap f x v = smartmap (f x) v] *) - - val iter : ('r -> 'a -> unit) -> 'r -> 'a array -> unit - (** [Fun1.iter f x v = iter (f x) v] *) - -end -(** The functions defined in this module are the same as the main ones, except - that they are all higher-order, and their function arguments have an - additional parameter. This allows us to prevent closure creation in critical - cases. *) diff --git a/clib/cList.ml b/clib/cList.ml index 80bb18477..2b627f745 100644 --- a/clib/cList.ml +++ b/clib/cList.ml @@ -19,26 +19,33 @@ sig val compare : 'a cmp -> 'a list cmp val equal : 'a eq -> 'a list eq val is_empty : 'a list -> bool - val init : int -> (int -> 'a) -> 'a list val mem_f : 'a eq -> 'a -> 'a list -> bool - val add_set : 'a eq -> 'a -> 'a list -> 'a list - val eq_set : 'a eq -> 'a list -> 'a list -> bool - val intersect : 'a eq -> 'a list -> 'a list -> 'a list - val union : 'a eq -> 'a list -> 'a list -> 'a list - val unionq : 'a list -> 'a list -> 'a list - val subtract : 'a eq -> 'a list -> 'a list -> 'a list - val subtractq : 'a list -> 'a list -> 'a list + val for_all_i : (int -> 'a -> bool) -> int -> 'a list -> bool + val for_all2eq : ('a -> 'b -> bool) -> 'a list -> 'b list -> bool + val prefix_of : 'a eq -> 'a list -> 'a list -> bool val interval : int -> int -> int list val make : int -> 'a -> 'a list + val addn : int -> 'a -> 'a list -> 'a list + val init : int -> (int -> 'a) -> 'a list + val append : 'a list -> 'a list -> 'a list + val concat : 'a list list -> 'a list + val flatten : 'a list list -> 'a list val assign : 'a list -> int -> 'a -> 'a list - val distinct : 'a list -> bool - val distinct_f : 'a cmp -> 'a list -> bool - val duplicates : 'a eq -> 'a list -> 'a list + val filter : ('a -> bool) -> 'a list -> 'a list val filter2 : ('a -> 'b -> bool) -> 'a list -> 'b list -> 'a list * 'b list + val filteri : + (int -> 'a -> bool) -> 'a list -> 'a list + val filter_with : bool list -> 'a list -> 'a list + val smartfilter : ('a -> bool) -> 'a list -> 'a list + [@@ocaml.deprecated "Same as [filter]"] val map_filter : ('a -> 'b option) -> 'a list -> 'b list val map_filter_i : (int -> 'a -> 'b option) -> 'a list -> 'b list - val filter_with : bool list -> 'a list -> 'a list + val partitioni : + (int -> 'a -> bool) -> 'a list -> 'a list * 'a list + val map : ('a -> 'b) -> 'a list -> 'b list + val map2 : ('a -> 'b -> 'c) -> 'a list -> 'b list -> 'c list val smartmap : ('a -> 'a) -> 'a list -> 'a list + [@@ocaml.deprecated "Same as [Smart.map]"] val map_left : ('a -> 'b) -> 'a list -> 'b list val map_i : (int -> 'a -> 'b) -> int -> 'a list -> 'b list val map2_i : @@ -47,17 +54,13 @@ sig ('a -> 'b -> 'c -> 'd) -> 'a list -> 'b list -> 'c list -> 'd list val map4 : ('a -> 'b -> 'c -> 'd -> 'e) -> 'a list -> 'b list -> 'c list -> 'd list -> 'e list - val filteri : - (int -> 'a -> bool) -> 'a list -> 'a list - val partitioni : - (int -> 'a -> bool) -> 'a list -> 'a list * 'a list val map_of_array : ('a -> 'b) -> 'a array -> 'b list - val smartfilter : ('a -> bool) -> 'a list -> 'a list + val map_append : ('a -> 'b list) -> 'a list -> 'b list + val map_append2 : ('a -> 'b -> 'c list) -> 'a list -> 'b list -> 'c list val extend : bool list -> 'a -> 'a list -> 'a list val count : ('a -> bool) -> 'a list -> int val index : 'a eq -> 'a -> 'a list -> int val index0 : 'a eq -> 'a -> 'a list -> int - val iteri : (int -> 'a -> unit) -> 'a list -> unit val fold_left_until : ('c -> 'a -> 'c CSig.until) -> 'c -> 'a list -> 'c val fold_right_i : (int -> 'a -> 'b -> 'b) -> int -> 'a list -> 'b -> 'b val fold_left_i : (int -> 'a -> 'b -> 'a) -> int -> 'a -> 'b list -> 'a @@ -65,55 +68,70 @@ sig ('a -> 'b -> 'b list -> 'a) -> 'b list -> 'a -> 'a val fold_left3 : ('a -> 'b -> 'c -> 'd -> 'a) -> 'a -> 'b list -> 'c list -> 'd list -> 'a val fold_left2_set : exn -> ('a -> 'b -> 'c -> 'b list -> 'c list -> 'a) -> 'a -> 'b list -> 'c list -> 'a - val for_all_i : (int -> 'a -> bool) -> int -> 'a list -> bool + val fold_left_map : ('a -> 'b -> 'a * 'c) -> 'a -> 'b list -> 'a * 'c list + val fold_right_map : ('b -> 'a -> 'c * 'a) -> 'b list -> 'a -> 'c list * 'a + val fold_left2_map : ('a -> 'b -> 'c -> 'a * 'd) -> 'a -> 'b list -> 'c list -> 'a * 'd list + val fold_right2_map : ('b -> 'c -> 'a -> 'd * 'a) -> 'b list -> 'c list -> 'a -> 'd list * 'a + val fold_left3_map : ('a -> 'b -> 'c -> 'd -> 'a * 'e) -> 'a -> 'b list -> 'c list -> 'd list -> 'a * 'e list + val fold_left4_map : ('a -> 'b -> 'c -> 'd -> 'e -> 'a * 'r) -> 'a -> 'b list -> 'c list -> 'd list -> 'e list -> 'a * 'r list + val fold_map : ('a -> 'b -> 'a * 'c) -> 'a -> 'b list -> 'a * 'c list + [@@ocaml.deprecated "Same as [fold_left_map]"] + val fold_map' : ('b -> 'a -> 'c * 'a) -> 'b list -> 'a -> 'c list * 'a + [@@ocaml.deprecated "Same as [fold_right_map]"] val except : 'a eq -> 'a -> 'a list -> 'a list val remove : 'a eq -> 'a -> 'a list -> 'a list val remove_first : ('a -> bool) -> 'a list -> 'a list val extract_first : ('a -> bool) -> 'a list -> 'a list * 'a - val insert : ('a -> 'a -> bool) -> 'a -> 'a list -> 'a list - val for_all2eq : ('a -> 'b -> bool) -> 'a list -> 'b list -> bool - val sep_last : 'a list -> 'a * 'a list val find_map : ('a -> 'b option) -> 'a list -> 'b - val uniquize : 'a list -> 'a list - val sort_uniquize : 'a cmp -> 'a list -> 'a list - val merge_uniq : ('a -> 'a -> int) -> 'a list -> 'a list -> 'a list - val subset : 'a list -> 'a list -> bool - val chop : int -> 'a list -> 'a list * 'a list exception IndexOutOfRange val goto : int -> 'a list -> 'a list * 'a list val split_when : ('a -> bool) -> 'a list -> 'a list * 'a list - val split3 : ('a * 'b * 'c) list -> 'a list * 'b list * 'c list - val firstn : int -> 'a list -> 'a list + val sep_last : 'a list -> 'a * 'a list + val drop_last : 'a list -> 'a list val last : 'a list -> 'a val lastn : int -> 'a list -> 'a list + val chop : int -> 'a list -> 'a list * 'a list + val firstn : int -> 'a list -> 'a list val skipn : int -> 'a list -> 'a list val skipn_at_least : int -> 'a list -> 'a list - val addn : int -> 'a -> 'a list -> 'a list - val prefix_of : 'a eq -> 'a list -> 'a list -> bool val drop_prefix : 'a eq -> 'a list -> 'a list -> 'a list - val drop_last : 'a list -> 'a list - val map_append : ('a -> 'b list) -> 'a list -> 'b list - val map_append2 : ('a -> 'b -> 'c list) -> 'a list -> 'b list -> 'c list + val insert : ('a -> 'a -> bool) -> 'a -> 'a list -> 'a list val share_tails : 'a list -> 'a list -> 'a list * 'a list * 'a list - val fold_left_map : ('a -> 'b -> 'a * 'c) -> 'a -> 'b list -> 'a * 'c list - val fold_right_map : ('b -> 'a -> 'c * 'a) -> 'b list -> 'a -> 'c list * 'a - val fold_left2_map : ('a -> 'b -> 'c -> 'a * 'd) -> 'a -> 'b list -> 'c list -> 'a * 'd list - val fold_right2_map : ('b -> 'c -> 'a -> 'd * 'a) -> 'b list -> 'c list -> 'a -> 'd list * 'a - val fold_left3_map : ('a -> 'b -> 'c -> 'd -> 'a * 'e) -> 'a -> 'b list -> 'c list -> 'd list -> 'a * 'e list - val fold_left4_map : ('a -> 'b -> 'c -> 'd -> 'e -> 'a * 'r) -> 'a -> 'b list -> 'c list -> 'd list -> 'e list -> 'a * 'r list - val fold_map : ('a -> 'b -> 'a * 'c) -> 'a -> 'b list -> 'a * 'c list - val fold_map' : ('b -> 'a -> 'c * 'a) -> 'b list -> 'a -> 'c list * 'a val map_assoc : ('a -> 'b) -> ('c * 'a) list -> ('c * 'b) list val assoc_f : 'a eq -> 'a -> ('a * 'b) list -> 'b val remove_assoc_f : 'a eq -> 'a -> ('a * 'b) list -> ('a * 'b) list val mem_assoc_f : 'a eq -> 'a -> ('a * 'b) list -> bool + val factorize_left : 'a eq -> ('a * 'b) list -> ('a * 'b list) list + 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 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 + val subset : 'a list -> 'a list -> bool + val merge_set : 'a cmp -> 'a list -> 'a list -> 'a list + val intersect : 'a eq -> 'a list -> 'a list -> 'a list + val union : 'a eq -> 'a list -> 'a list -> 'a list + val unionq : 'a list -> 'a list -> 'a list + val subtract : 'a eq -> 'a list -> 'a list -> 'a list + val subtractq : 'a list -> 'a list -> 'a list + val merge_uniq : ('a -> 'a -> int) -> 'a list -> 'a list -> 'a list + [@@ocaml.deprecated "Same as [merge_set]"] + val distinct : 'a list -> bool + val distinct_f : 'a cmp -> 'a list -> bool + val duplicates : 'a eq -> 'a list -> 'a list + val uniquize : 'a list -> 'a list + val sort_uniquize : 'a cmp -> 'a list -> 'a list val cartesian : ('a -> 'b -> 'c) -> 'a list -> 'b list -> 'c list val cartesians : ('a -> 'b -> 'b) -> 'b -> 'a list list -> 'b list val combinations : 'a list list -> 'a list list - val combine3 : 'a list -> 'b list -> 'c list -> ('a * 'b * 'c) list val cartesians_filter : ('a -> 'b -> 'b option) -> 'b -> 'a list list -> 'b list - val factorize_left : 'a eq -> ('a * 'b) list -> ('a * 'b list) list + + module Smart : + sig + val map : ('a -> 'a) -> 'a list -> 'a list + end module type MonoS = sig type elt @@ -139,71 +157,71 @@ type 'a cell = { external cast : 'a cell -> 'a list = "%identity" -let rec map_loop f p = function -| [] -> () -| x :: l -> - let c = { head = f x; tail = [] } in - p.tail <- cast c; - map_loop f c l +(** Extensions and redefinitions of OCaml Stdlib *) -let map f = function -| [] -> [] -| x :: l -> - let c = { head = f x; tail = [] } in - map_loop f c l; - cast c +(** {6 Equality, testing} *) -let rec map2_loop f p l1 l2 = match l1, l2 with -| [], [] -> () -| x :: l1, y :: l2 -> - let c = { head = f x y; tail = [] } in - p.tail <- cast c; - map2_loop f c l1 l2 -| _ -> invalid_arg "List.map2" +let rec compare cmp l1 l2 = + if l1 == l2 then 0 else + match l1,l2 with + | [], [] -> 0 + | _::_, [] -> 1 + | [], _::_ -> -1 + | x1::l1, x2::l2 -> + match cmp x1 x2 with + | 0 -> compare cmp l1 l2 + | c -> c -let map2 f l1 l2 = match l1, l2 with -| [], [] -> [] -| x :: l1, y :: l2 -> - let c = { head = f x y; tail = [] } in - map2_loop f c l1 l2; - cast c -| _ -> invalid_arg "List.map2" +let rec equal cmp l1 l2 = + l1 == l2 || + match l1, l2 with + | [], [] -> true + | x1 :: l1, x2 :: l2 -> cmp x1 x2 && equal cmp l1 l2 + | _ -> false -let rec map_of_array_loop f p a i l = - if Int.equal i l then () - else - let c = { head = f (Array.unsafe_get a i); tail = [] } in - p.tail <- cast c; - map_of_array_loop f c a (i + 1) l +let is_empty = function + | [] -> true + | _ -> false -let map_of_array f a = - let l = Array.length a in - if Int.equal l 0 then [] - else - let c = { head = f (Array.unsafe_get a 0); tail = [] } in - map_of_array_loop f c a 1 l; - cast c +let mem_f cmp x l = + List.exists (cmp x) l -let rec append_loop p tl = function -| [] -> p.tail <- tl -| x :: l -> - let c = { head = x; tail = [] } in - p.tail <- cast c; - append_loop c tl l +let for_all_i p = + let rec for_all_p i = function + | [] -> true + | a::l -> p i a && for_all_p (i+1) l + in + for_all_p -let append l1 l2 = match l1 with -| [] -> l2 -| x :: l -> - let c = { head = x; tail = [] } in - append_loop c l2 l; - cast c +let for_all2eq f l1 l2 = + try List.for_all2 f l1 l2 with Invalid_argument _ -> false -let rec copy p = function -| [] -> p -| x :: l -> - let c = { head = x; tail = [] } in - p.tail <- cast c; - copy c l +let prefix_of cmp prefl l = + let rec prefrec = function + | (h1::t1, h2::t2) -> cmp h1 h2 && prefrec (t1,t2) + | ([], _) -> true + | _ -> false + in + prefrec (prefl,l) + +(** {6 Creating lists} *) + +let interval n m = + let rec interval_n (l,m) = + if n > m then l else interval_n (m::l, pred m) + in + interval_n ([], m) + +let addn n v = + let rec aux n l = + if Int.equal n 0 then l + else aux (pred n) (v :: l) + in + if n < 0 then invalid_arg "List.addn" + else aux n + +let make n v = + addn n v [] let rec init_loop len f p i = if Int.equal i len then () @@ -220,9 +238,30 @@ let init len f = init_loop len f c 1; cast c +let rec append_loop p tl = function + | [] -> p.tail <- tl + | x :: l -> + let c = { head = x; tail = [] } in + p.tail <- cast c; + append_loop c tl l + +let append l1 l2 = match l1 with + | [] -> l2 + | x :: l -> + let c = { head = x; tail = [] } in + append_loop c l2 l; + cast c + +let rec copy p = function + | [] -> p + | x :: l -> + let c = { head = x; tail = [] } in + p.tail <- cast c; + copy c l + let rec concat_loop p = function -| [] -> () -| x :: l -> concat_loop (copy p x) l + | [] -> () + | x :: l -> concat_loop (copy p x) l let concat l = let dummy = { head = Obj.magic 0; tail = [] } in @@ -231,230 +270,308 @@ let concat l = let flatten = concat -let rec split_loop p q = function -| [] -> () -| (x, y) :: l -> - let cl = { head = x; tail = [] } in - let cr = { head = y; tail = [] } in - p.tail <- cast cl; - q.tail <- cast cr; - split_loop cl cr l - -let split = function -| [] -> [], [] -| (x, y) :: l -> - let cl = { head = x; tail = [] } in - let cr = { head = y; tail = [] } in - split_loop cl cr l; - (cast cl, cast cr) +(** {6 Lists as arrays} *) -let rec combine_loop p l1 l2 = match l1, l2 with -| [], [] -> () -| x :: l1, y :: l2 -> - let c = { head = (x, y); tail = [] } in - p.tail <- cast c; - combine_loop c l1 l2 -| _ -> invalid_arg "List.combine" +let assign l n e = + let rec assrec stk l i = match l, i with + | (h :: t, 0) -> List.rev_append stk (e :: t) + | (h :: t, n) -> assrec (h :: stk) t (pred n) + | ([], _) -> failwith "List.assign" + in + assrec [] l n -let combine l1 l2 = match l1, l2 with -| [], [] -> [] -| x :: l1, y :: l2 -> - let c = { head = (x, y); tail = [] } in - combine_loop c l1 l2; - cast c -| _ -> invalid_arg "List.combine" +(** {6 Filtering} *) let rec filter_loop f p = function -| [] -> () -| x :: l -> - if f x then - let c = { head = x; tail = [] } in - let () = p.tail <- cast c in - filter_loop f c l - else - filter_loop f p l + | [] -> () + | x :: l' as l -> + let b = f x in + filter_loop f p l'; + if b then if p.tail == l' then p.tail <- l else p.tail <- x :: p.tail -let filter f l = - let c = { head = Obj.magic 0; tail = [] } in - filter_loop f c l; - c.tail +let rec filter f = function + | [] -> [] + | x :: l' as l -> + if f x then + let c = { head = x; tail = [] } in + filter_loop f c l'; + if c.tail == l' then l else cast c + else + filter f l' -(** FIXME: Already present in OCaml 4.00 *) +let rec filter2_loop f p q l1 l2 = match l1, l2 with + | [], [] -> () + | x :: l1', y :: l2' -> + let b = f x y in + filter2_loop f p q l1' l2'; + if b then + if p.tail == l1' then begin + p.tail <- l1; + q.tail <- l2 + end + else begin + p.tail <- x :: p.tail; + q.tail <- y :: q.tail + end + | _ -> invalid_arg "List.filter2" + +let rec filter2 f l1 l2 = match l1, l2 with + | [], [] -> ([],[]) + | x1 :: l1', x2 :: l2' -> + let b = f x1 x2 in + if b then + let c1 = { head = x1; tail = [] } in + let c2 = { head = x2; tail = [] } in + filter2_loop f c1 c2 l1' l2'; + if c1.tail == l1' then (l1, l2) else (cast c1, cast c2) + else + filter2 f l1' l2' + | _ -> invalid_arg "List.filter2" -let rec map_i_loop f i p = function -| [] -> () -| x :: l -> - let c = { head = f i x; tail = [] } in - p.tail <- cast c; - map_i_loop f (succ i) c l +let filteri p = + let rec filter_i_rec i = function + | [] -> [] + | x :: l -> let l' = filter_i_rec (succ i) l in if p i x then x :: l' else l' + in + filter_i_rec 0 -let map_i f i = function -| [] -> [] -| x :: l -> - let c = { head = f i x; tail = [] } in - map_i_loop f (succ i) c l; - cast c +let smartfilter = filter (* Alias *) -(** Extensions of OCaml Stdlib *) +let rec filter_with_loop filter p l = match filter, l with + | [], [] -> () + | b :: filter, x :: l' -> + filter_with_loop filter p l'; + if b then if p.tail == l' then p.tail <- l else p.tail <- x :: p.tail + | _ -> invalid_arg "List.filter_with" -let rec compare cmp l1 l2 = - if l1 == l2 then 0 else - match l1,l2 with - [], [] -> 0 - | _::_, [] -> 1 - | [], _::_ -> -1 - | x1::l1, x2::l2 -> - (match cmp x1 x2 with - | 0 -> compare cmp l1 l2 - | c -> c) +let rec filter_with filter l = match filter, l with + | [], [] -> [] + | b :: filter, x :: l' -> + if b then + let c = { head = x; tail = [] } in + filter_with_loop filter c l'; + if c.tail == l' then l else cast c + else filter_with filter l' + | _ -> invalid_arg "List.filter_with" -let rec equal cmp l1 l2 = - l1 == l2 || - match l1, l2 with - | [], [] -> true - | x1 :: l1, x2 :: l2 -> - cmp x1 x2 && equal cmp l1 l2 - | _ -> false +let rec map_filter_loop f p = function + | [] -> () + | x :: l -> + match f x with + | None -> map_filter_loop f p l + | Some y -> + let c = { head = y; tail = [] } in + p.tail <- cast c; + map_filter_loop f c l -let is_empty = function -| [] -> true -| _ -> false +let rec map_filter f = function + | [] -> [] + | x :: l' -> + match f x with + | None -> map_filter f l' + | Some y -> + let c = { head = y; tail = [] } in + map_filter_loop f c l'; + cast c -let mem_f cmp x l = List.exists (cmp x) l +let rec map_filter_i_loop f i p = function + | [] -> () + | x :: l -> + match f i x with + | None -> map_filter_i_loop f (succ i) p l + | Some y -> + let c = { head = y; tail = [] } in + p.tail <- cast c; + map_filter_i_loop f (succ i) c l -let intersect cmp l1 l2 = - filter (fun x -> mem_f cmp x l2) l1 +let rec map_filter_i_loop' f i = function + | [] -> [] + | x :: l' -> + match f i x with + | None -> map_filter_i_loop' f (succ i) l' + | Some y -> + let c = { head = y; tail = [] } in + map_filter_i_loop f (succ i) c l'; + cast c -let union cmp l1 l2 = - let rec urec = function - | [] -> l2 - | a::l -> if mem_f cmp a l2 then urec l else a::urec l +let map_filter_i f l = + map_filter_i_loop' f 0 l + +let partitioni p = + let rec aux i = function + | [] -> [], [] + | x :: l -> + let (l1, l2) = aux (succ i) l in + if p i x then (x :: l1, l2) + else (l1, x :: l2) in - urec l1 + aux 0 -let subtract cmp l1 l2 = - if is_empty l2 then l1 - else List.filter (fun x -> not (mem_f cmp x l2)) l1 +(** {6 Applying functorially} *) -let unionq l1 l2 = union (==) l1 l2 -let subtractq l1 l2 = subtract (==) l1 l2 +let rec map_loop f p = function + | [] -> () + | x :: l -> + let c = { head = f x; tail = [] } in + p.tail <- cast c; + map_loop f c l -let interval n m = - let rec interval_n (l,m) = - if n > m then l else interval_n (m::l, pred m) - in - interval_n ([], m) +let map f = function + | [] -> [] + | x :: l -> + let c = { head = f x; tail = [] } in + map_loop f c l; + cast c -let addn n v = - let rec aux n l = - if Int.equal n 0 then l - else aux (pred n) (v :: l) - in - if n < 0 then invalid_arg "List.addn" - else aux n +let rec map2_loop f p l1 l2 = match l1, l2 with + | [], [] -> () + | x :: l1, y :: l2 -> + let c = { head = f x y; tail = [] } in + p.tail <- cast c; + map2_loop f c l1 l2 + | _ -> invalid_arg "List.map2" -let make n v = addn n v [] +let map2 f l1 l2 = match l1, l2 with + | [], [] -> [] + | x :: l1, y :: l2 -> + let c = { head = f x y; tail = [] } in + map2_loop f c l1 l2; + cast c + | _ -> invalid_arg "List.map2" -let assign l n e = - let rec assrec stk l i = match l, i with - | ((h::t), 0) -> List.rev_append stk (e :: t) - | ((h::t), n) -> assrec (h :: stk) t (pred n) - | ([], _) -> failwith "List.assign" - in - assrec [] l n +(** Like OCaml [List.mapi] but tail-recursive *) -let rec smartmap f l = match l with - [] -> l - | h::tl -> - let h' = f h and tl' = smartmap f tl in - if h'==h && tl'==tl then l - else h'::tl' +let rec map_i_loop f i p = function + | [] -> () + | x :: l -> + let c = { head = f i x; tail = [] } in + p.tail <- cast c; + map_i_loop f (succ i) c l + +let map_i f i = function + | [] -> [] + | x :: l -> + let c = { head = f i x; tail = [] } in + map_i_loop f (succ i) c l; + cast c let map_left = map let map2_i f i l1 l2 = let rec map_i i = function | ([], []) -> [] - | ((h1::t1), (h2::t2)) -> let v = f i h1 h2 in v :: map_i (succ i) (t1,t2) + | (h1 :: t1, h2 :: t2) -> let v = f i h1 h2 in v :: map_i (succ i) (t1,t2) | (_, _) -> invalid_arg "map2_i" in map_i i (l1,l2) -let map3 f l1 l2 l3 = - let rec map = function - | ([], [], []) -> [] - | ((h1::t1), (h2::t2), (h3::t3)) -> let v = f h1 h2 h3 in v::map (t1,t2,t3) - | (_, _, _) -> invalid_arg "map3" - in - map (l1,l2,l3) +let rec map3_loop f p l1 l2 l3 = match l1, l2, l3 with + | [], [], [] -> () + | x :: l1, y :: l2, z :: l3 -> + let c = { head = f x y z; tail = [] } in + p.tail <- cast c; + map3_loop f c l1 l2 l3 + | _ -> invalid_arg "List.map3" -let map4 f l1 l2 l3 l4 = - let rec map = function - | ([], [], [], []) -> [] - | ((h1::t1), (h2::t2), (h3::t3), (h4::t4)) -> let v = f h1 h2 h3 h4 in v::map (t1,t2,t3,t4) - | (_, _, _, _) -> invalid_arg "map4" - in - map (l1,l2,l3,l4) +let map3 f l1 l2 l3 = match l1, l2, l3 with + | [], [], [] -> [] + | x :: l1, y :: l2, z :: l3 -> + let c = { head = f x y z; tail = [] } in + map3_loop f c l1 l2 l3; + cast c + | _ -> invalid_arg "List.map3" + +let rec map4_loop f p l1 l2 l3 l4 = match l1, l2, l3, l4 with + | [], [], [], [] -> () + | x :: l1, y :: l2, z :: l3, t :: l4 -> + let c = { head = f x y z t; tail = [] } in + p.tail <- cast c; + map4_loop f c l1 l2 l3 l4 + | _ -> invalid_arg "List.map4" + +let map4 f l1 l2 l3 l4 = match l1, l2, l3, l4 with + | [], [], [], [] -> [] + | x :: l1, y :: l2, z :: l3, t :: l4 -> + let c = { head = f x y z t; tail = [] } in + map4_loop f c l1 l2 l3 l4; + cast c + | _ -> invalid_arg "List.map4" + +let rec map_of_array_loop f p a i l = + if Int.equal i l then () + else + let c = { head = f (Array.unsafe_get a i); tail = [] } in + p.tail <- cast c; + map_of_array_loop f c a (i + 1) l -let rec smartfilter f l = match l with - [] -> l - | h::tl -> - let tl' = smartfilter f tl in - if f h then - if tl' == tl then l - else h :: tl' - else tl' +let map_of_array f a = + let l = Array.length a in + if Int.equal l 0 then [] + else + let c = { head = f (Array.unsafe_get a 0); tail = [] } in + map_of_array_loop f c a 1 l; + cast c + +let map_append f l = flatten (map f l) + +let map_append2 f l1 l2 = flatten (map2 f l1 l2) let rec extend l a l' = match l,l' with - | true::l, b::l' -> b :: extend l a l' - | false::l, l' -> a :: extend l a l' + | true :: l, b :: l' -> b :: extend l a l' + | false :: l, l' -> a :: extend l a l' | [], [] -> [] | _ -> invalid_arg "extend" let count f l = let rec aux acc = function | [] -> acc - | h :: t -> if f h then aux (acc + 1) t else aux acc t in + | h :: t -> if f h then aux (acc + 1) t else aux acc t + in aux 0 l +(** {6 Finding position} *) + let rec index_f f x l n = match l with -| [] -> raise Not_found -| y :: l -> if f x y then n else index_f f x l (succ n) + | [] -> raise Not_found + | y :: l -> if f x y then n else index_f f x l (succ n) let index f x l = index_f f x l 1 let index0 f x l = index_f f x l 0 +(** {6 Folding} *) + let fold_left_until f accu s = let rec aux accu = function | [] -> accu - | x :: xs -> match f accu x with CSig.Stop x -> x | CSig.Cont i -> aux i xs in + | x :: xs -> match f accu x with CSig.Stop x -> x | CSig.Cont i -> aux i xs + in aux accu s let fold_right_i f i l = let rec it_f i l a = match l with | [] -> a - | b::l -> f (i-1) b (it_f (i-1) l a) + | b :: l -> f (i-1) b (it_f (i-1) l a) in it_f (List.length l + i) l let fold_left_i f = let rec it_list_f i a = function | [] -> a - | b::l -> it_list_f (i+1) (f i a b) l + | b :: l -> it_list_f (i+1) (f i a b) l in it_list_f let rec fold_left3 f accu l1 l2 l3 = match (l1, l2, l3) with - ([], [], []) -> accu - | (a1::l1, a2::l2, a3::l3) -> fold_left3 f (f accu a1 a2 a3) l1 l2 l3 + | ([], [], []) -> accu + | (a1 :: l1, a2 :: l2, a3 :: l3) -> fold_left3 f (f accu a1 a2 a3) l1 l2 l3 | (_, _, _) -> invalid_arg "List.fold_left3" let rec fold_left4 f accu l1 l2 l3 l4 = match (l1, l2, l3, l4) with - ([], [], [], []) -> accu - | (a1::l1, a2::l2, a3::l3, a4::l4) -> fold_left4 f (f accu a1 a2 a3 a4) l1 l2 l3 l4 + | ([], [], [], []) -> accu + | (a1 :: l1, a2 :: l2, a3 :: l3, a4 :: l4) -> fold_left4 f (f accu a1 a2 a3 a4) l1 l2 l3 l4 | (_,_, _, _) -> invalid_arg "List.fold_left4" (* [fold_right_and_left f [a1;...;an] hd = @@ -472,214 +589,103 @@ let rec fold_left4 f accu l1 l2 l3 l4 = let fold_right_and_left f l hd = let rec aux tl = function | [] -> hd - | a::l -> let hd = aux (a::tl) l in f hd a tl - in aux [] l + | a :: l -> let hd = aux (a :: tl) l in f hd a tl + in + aux [] l (* Match sets as lists according to a matching function, also folding a side effect *) let rec fold_left2_set e f x l1 l2 = match l1 with - | a1::l1 -> - let rec find seen = function - | [] -> raise e - | a2::l2 -> - try fold_left2_set e f (f x a1 a2 l1 l2) l1 (List.rev_append seen l2) - with e' when e' = e -> find (a2::seen) l2 in - find [] l2 + | a1 :: l1 -> + let rec find seen = function + | [] -> raise e + | a2 :: l2 -> + try fold_left2_set e f (f x a1 a2 l1 l2) l1 (List.rev_append seen l2) + with e' when e' = e -> find (a2 :: seen) l2 in + find [] l2 | [] -> - if l2 = [] then x else raise e + if l2 = [] then x else raise e -let iteri f l = fold_left_i (fun i _ x -> f i x) 0 () l +(* Poor man's monadic map *) +let rec fold_left_map f e = function + | [] -> (e,[]) + | h :: t -> + let e',h' = f e h in + let e'',t' = fold_left_map f e' t in + e'',h' :: t' -let for_all_i p = - let rec for_all_p i = function - | [] -> true - | a::l -> p i a && for_all_p (i+1) l +let fold_map = fold_left_map + +(* (* tail-recursive version of the above function *) +let fold_left_map f e l = + let g (e,b') h = + let (e',h') = f e h in + (e',h'::b') in - for_all_p + let (e',lrev) = List.fold_left g (e,[]) l in + (e',List.rev lrev) +*) + +(* The same, based on fold_right, with the effect accumulated on the right *) +let fold_right_map f l e = + List.fold_right (fun x (l,e) -> let (y,e) = f x e in (y::l,e)) l ([],e) + +let fold_map' = fold_right_map + +let on_snd f (x,y) = (x,f y) + +let fold_left2_map f e l l' = + on_snd List.rev @@ + List.fold_left2 (fun (e,l) x x' -> + let (e,y) = f e x x' in + (e, y::l) + ) (e, []) l l' + +let fold_right2_map f l l' e = + List.fold_right2 (fun x x' (l,e) -> let (y,e) = f x x' e in (y::l,e)) l l' ([],e) + +let fold_left3_map f e l l' l'' = + on_snd List.rev @@ + fold_left3 (fun (e,l) x x' x'' -> let (e,y) = f e x x' x'' in (e,y::l)) (e,[]) l l' l'' + +let fold_left4_map f e l1 l2 l3 l4 = + on_snd List.rev @@ + fold_left4 (fun (e,l) x1 x2 x3 x4 -> let (e,y) = f e x1 x2 x3 x4 in (e,y::l)) (e,[]) l1 l2 l3 l4 + +(** {6 Splitting} *) -let except cmp x l = List.filter (fun y -> not (cmp x y)) l +let except cmp x l = + List.filter (fun y -> not (cmp x y)) l let remove = except (* Alias *) let rec remove_first p = function - | b::l when p b -> l - | b::l -> b::remove_first p l + | b :: l when p b -> l + | b :: l -> b :: remove_first p l | [] -> raise Not_found let extract_first p li = let rec loop rev_left = function | [] -> raise Not_found - | x::right -> + | x :: right -> if p x then List.rev_append rev_left right, x else loop (x :: rev_left) right - in loop [] li + in + loop [] li let insert p v l = let rec insrec = function | [] -> [v] - | h::tl -> if p v h then v::h::tl else h::insrec tl + | h :: tl -> if p v h then v :: h :: tl else h :: insrec tl in insrec l -let add_set cmp x l = if mem_f cmp x l then l else x :: l - -(** List equality up to permutation (but considering multiple occurrences) *) - -let eq_set cmp l1 l2 = - let rec aux l1 = function - | [] -> is_empty l1 - | a::l2 -> aux (remove_first (cmp a) l1) l2 in - try aux l1 l2 with Not_found -> false - -let for_all2eq f l1 l2 = - try List.for_all2 f l1 l2 with Invalid_argument _ -> false - -let filteri p = - let rec filter_i_rec i = function - | [] -> [] - | x::l -> let l' = filter_i_rec (succ i) l in if p i x then x::l' else l' - in - filter_i_rec 0 - -let partitioni p = - let rec aux i = function - | [] -> [], [] - | x :: l -> - let (l1, l2) = aux (succ i) l in - if p i x then (x :: l1, l2) - else (l1, x :: l2) - in aux 0 - -let rec sep_last = function - | [] -> failwith "sep_last" - | hd::[] -> (hd,[]) - | hd::tl -> let (l,tl) = sep_last tl in (l,hd::tl) - let rec find_map f = function -| [] -> raise Not_found -| x :: l -> - match f x with - | None -> find_map f l - | Some y -> y - -(* FIXME: we should avoid relying on the generic hash function, - just as we'd better avoid Pervasives.compare *) - -let uniquize l = - let visited = Hashtbl.create 23 in - let rec aux acc changed = function - | h::t -> if Hashtbl.mem visited h then aux acc true t else - begin - Hashtbl.add visited h h; - aux (h::acc) changed t - end - | [] -> if changed then List.rev acc else l - in aux [] false l - -(** [sort_uniquize] might be an alternative to the hashtbl-based - [uniquize], when the order of the elements is irrelevant *) - -let rec uniquize_sorted cmp = function - | a::b::l when Int.equal (cmp a b) 0 -> uniquize_sorted cmp (a::l) - | a::l -> a::uniquize_sorted cmp l - | [] -> [] - -let sort_uniquize cmp l = uniquize_sorted cmp (List.sort cmp l) - -(* FIXME: again, generic hash function *) - -let distinct l = - let visited = Hashtbl.create 23 in - let rec loop = function - | h::t -> - if Hashtbl.mem visited h then false - else - begin - Hashtbl.add visited h h; - loop t - end - | [] -> true - in loop l - -let distinct_f cmp l = - let rec loop = function - | a::b::_ when Int.equal (cmp a b) 0 -> false - | a::l -> loop l - | [] -> true - in loop (List.sort cmp l) - -let rec merge_uniq cmp l1 l2 = - match l1, l2 with - | [], l2 -> l2 - | l1, [] -> l1 - | h1 :: t1, h2 :: t2 -> - let c = cmp h1 h2 in - if Int.equal c 0 - then h1 :: merge_uniq cmp t1 t2 - else if c <= 0 - then h1 :: merge_uniq cmp t1 l2 - else h2 :: merge_uniq cmp l1 t2 - -let rec duplicates cmp = function - | [] -> [] - | x::l -> - let l' = duplicates cmp l in - if mem_f cmp x l then add_set cmp x l' else l' - -let rec filter2_loop f p q l1 l2 = match l1, l2 with -| [], [] -> () -| x :: l1, y :: l2 -> - if f x y then - let c1 = { head = x; tail = [] } in - let c2 = { head = y; tail = [] } in - let () = p.tail <- cast c1 in - let () = q.tail <- cast c2 in - filter2_loop f c1 c2 l1 l2 - else - filter2_loop f p q l1 l2 -| _ -> invalid_arg "List.filter2" - -let filter2 f l1 l2 = - let c1 = { head = Obj.magic 0; tail = [] } in - let c2 = { head = Obj.magic 0; tail = [] } in - filter2_loop f c1 c2 l1 l2; - (c1.tail, c2.tail) - -let rec map_filter_loop f p = function - | [] -> () + | [] -> raise Not_found | x :: l -> match f x with - | None -> map_filter_loop f p l - | Some y -> - let c = { head = y; tail = [] } in - p.tail <- cast c; - map_filter_loop f c l - -let map_filter f l = - let c = { head = Obj.magic 0; tail = [] } in - map_filter_loop f c l; - c.tail - -let rec map_filter_i_loop f i p = function - | [] -> () - | x :: l -> - match f i x with - | None -> map_filter_i_loop f (succ i) p l - | Some y -> - let c = { head = y; tail = [] } in - p.tail <- cast c; - map_filter_i_loop f (succ i) c l - -let map_filter_i f l = - let c = { head = Obj.magic 0; tail = [] } in - map_filter_i_loop f 0 c l; - c.tail - -let rec filter_with filter l = match filter, l with -| [], [] -> [] -| true :: filter, x :: l -> x :: filter_with filter l -| false :: filter, _ :: l -> filter_with filter l -| _ -> invalid_arg "List.filter_with" + | None -> find_map f l + | Some y -> y (* FIXME: again, generic hash function *) @@ -688,7 +694,7 @@ let subset l1 l2 = List.iter (fun x -> Hashtbl.add t2 x ()) l2; let rec look = function | [] -> true - | x::ll -> try Hashtbl.find t2 x; look ll with Not_found -> false + | x :: ll -> try Hashtbl.find t2 x; look ll with Not_found -> false in look l1 @@ -700,7 +706,7 @@ exception IndexOutOfRange let goto n l = let rec goto i acc = function | tl when Int.equal i 0 -> (acc, tl) - | h::t -> goto (pred i) (h::acc) t + | h :: t -> goto (pred i) (h :: acc) t | [] -> raise IndexOutOfRange in goto n [] l @@ -721,29 +727,36 @@ let chop n l = let split_when p = let rec split_when_loop x y = match y with - | [] -> (List.rev x,[]) - | (a::l) -> if (p a) then (List.rev x,y) else split_when_loop (a::x) l + | [] -> (List.rev x,[]) + | (a :: l) -> if (p a) then (List.rev x,y) else split_when_loop (a :: x) l in split_when_loop [] -let rec split3 = function - | [] -> ([], [], []) - | (x,y,z)::l -> - let (rx, ry, rz) = split3 l in (x::rx, y::ry, z::rz) - let firstn n l = let rec aux acc n l = match n, l with | 0, _ -> List.rev acc - | n, h::t -> aux (h::acc) (pred n) t + | n, h :: t -> aux (h :: acc) (pred n) t | _ -> failwith "firstn" in aux [] n l +let rec sep_last = function + | [] -> failwith "sep_last" + | hd :: [] -> (hd,[]) + | hd :: tl -> let (l,tl) = sep_last tl in (l,hd :: tl) + +(* Drop the last element of a list *) + +let rec drop_last = function + | [] -> failwith "drop_last" + | hd :: [] -> [] + | hd :: tl -> hd :: drop_last tl + let rec last = function | [] -> failwith "List.last" - | [x] -> x - | _ :: l -> last l + | hd :: [] -> hd + | _ :: tl -> last tl let lastn n l = let len = List.length l in @@ -755,96 +768,216 @@ let lastn n l = let rec skipn n l = match n,l with | 0, _ -> l | _, [] -> failwith "List.skipn" - | n, _::l -> skipn (pred n) l + | n, _ :: l -> skipn (pred n) l let skipn_at_least n l = - try skipn n l with Failure _ -> [] - -let prefix_of cmp prefl l = - let rec prefrec = function - | (h1::t1, h2::t2) -> cmp h1 h2 && prefrec (t1,t2) - | ([], _) -> true - | _ -> false - in - prefrec (prefl,l) + try skipn n l with Failure _ when n >= 0 -> [] (** if [l=p++t] then [drop_prefix p l] is [t] else [l] *) let drop_prefix cmp p l = let rec drop_prefix_rec = function - | (h1::tp, h2::tl) when cmp h1 h2 -> drop_prefix_rec (tp,tl) + | (h1 :: tp, h2 :: tl) when cmp h1 h2 -> drop_prefix_rec (tp,tl) | ([], tl) -> tl | _ -> l in drop_prefix_rec (p,l) -let map_append f l = List.flatten (List.map f l) - -let map_append2 f l1 l2 = List.flatten (List.map2 f l1 l2) - let share_tails l1 l2 = let rec shr_rev acc = function - | ((x1::l1), (x2::l2)) when x1 == x2 -> shr_rev (x1::acc) (l1,l2) - | (l1,l2) -> (List.rev l1, List.rev l2, acc) + | (x1 :: l1, x2 :: l2) when x1 == x2 -> shr_rev (x1 :: acc) (l1,l2) + | (l1, l2) -> (List.rev l1, List.rev l2, acc) in shr_rev [] (List.rev l1, List.rev l2) -(* Poor man's monadic map *) -let rec fold_left_map f e = function - | [] -> (e,[]) - | h::t -> - let e',h' = f e h in - let e'',t' = fold_left_map f e' t in - e'',h'::t' +(** {6 Association lists} *) -let fold_map = fold_left_map +let map_assoc f = List.map (fun (x,a) -> (x,f a)) -(* (* tail-recursive version of the above function *) -let fold_map f e l = - let g (e,b') h = - let (e',h') = f e h in - (e',h'::b') +let rec assoc_f f a = function + | (x, e) :: xs -> if f a x then e else assoc_f f a xs + | [] -> raise Not_found + +let remove_assoc_f f a l = + try remove_first (fun (x,_) -> f a x) l with Not_found -> l + +let mem_assoc_f f a l = List.exists (fun (x,_) -> f a x) l + +(** {6 Operations on lists of tuples} *) + +let rec split_loop p q = function + | [] -> () + | (x, y) :: l -> + let cl = { head = x; tail = [] } in + let cr = { head = y; tail = [] } in + p.tail <- cast cl; + q.tail <- cast cr; + split_loop cl cr l + +let split = function + | [] -> [], [] + | (x, y) :: l -> + let cl = { head = x; tail = [] } in + let cr = { head = y; tail = [] } in + split_loop cl cr l; + (cast cl, cast cr) + +let rec combine_loop p l1 l2 = match l1, l2 with + | [], [] -> () + | x :: l1, y :: l2 -> + let c = { head = (x, y); tail = [] } in + p.tail <- cast c; + combine_loop c l1 l2 + | _ -> invalid_arg "List.combine" + +let combine l1 l2 = match l1, l2 with + | [], [] -> [] + | x :: l1, y :: l2 -> + let c = { head = (x, y); tail = [] } in + combine_loop c l1 l2; + cast c + | _ -> invalid_arg "List.combine" + +let rec split3_loop p q r = function + | [] -> () + | (x, y, z) :: l -> + let cp = { head = x; tail = [] } in + let cq = { head = y; tail = [] } in + let cr = { head = z; tail = [] } in + p.tail <- cast cp; + q.tail <- cast cq; + r.tail <- cast cr; + split3_loop cp cq cr l + +let split3 = function + | [] -> [], [], [] + | (x, y, z) :: l -> + let cp = { head = x; tail = [] } in + let cq = { head = y; tail = [] } in + let cr = { head = z; tail = [] } in + split3_loop cp cq cr l; + (cast cp, cast cq, cast cr) + +let rec combine3_loop p l1 l2 l3 = match l1, l2, l3 with + | [], [], [] -> () + | x :: l1, y :: l2, z :: l3 -> + let c = { head = (x, y, z); tail = [] } in + p.tail <- cast c; + combine3_loop c l1 l2 l3 + | _ -> invalid_arg "List.combine3" + +let combine3 l1 l2 l3 = match l1, l2, l3 with + | [], [], [] -> [] + | x :: l1, y :: l2, z :: l3 -> + let c = { head = (x, y, z); tail = [] } in + combine3_loop c l1 l2 l3; + cast c + | _ -> invalid_arg "List.combine3" + +(** {6 Operations on lists seen as sets, preserving uniqueness of elements} *) + +(** Add an element, preserving uniqueness of elements *) + +let add_set cmp x l = + if mem_f cmp x l then l else x :: l + +(** List equality up to permutation (but considering multiple occurrences) *) + +let eq_set cmp l1 l2 = + let rec aux l1 = function + | [] -> is_empty l1 + | a :: l2 -> aux (remove_first (cmp a) l1) l2 in - let (e',lrev) = List.fold_left g (e,[]) l in - (e',List.rev lrev) -*) + try aux l1 l2 with Not_found -> false -(* The same, based on fold_right, with the effect accumulated on the right *) -let fold_right_map f l e = - List.fold_right (fun x (l,e) -> let (y,e) = f x e in (y::l,e)) l ([],e) +let rec merge_set cmp l1 l2 = match l1, l2 with + | [], l2 -> l2 + | l1, [] -> l1 + | h1 :: t1, h2 :: t2 -> + let c = cmp h1 h2 in + if Int.equal c 0 + then h1 :: merge_set cmp t1 t2 + else if c <= 0 + then h1 :: merge_set cmp t1 l2 + else h2 :: merge_set cmp l1 t2 -let fold_map' = fold_right_map +let merge_uniq = merge_set -let on_snd f (x,y) = (x,f y) +let intersect cmp l1 l2 = + filter (fun x -> mem_f cmp x l2) l1 -let fold_left2_map f e l l' = - on_snd List.rev @@ - List.fold_left2 (fun (e,l) x x' -> - let (e,y) = f e x x' in - (e, y::l) - ) (e, []) l l' +let union cmp l1 l2 = + let rec urec = function + | [] -> l2 + | a :: l -> if mem_f cmp a l2 then urec l else a :: urec l + in + urec l1 -let fold_right2_map f l l' e = - List.fold_right2 (fun x x' (l,e) -> let (y,e) = f x x' e in (y::l,e)) l l' ([],e) +let subtract cmp l1 l2 = + if is_empty l2 then l1 + else List.filter (fun x -> not (mem_f cmp x l2)) l1 -let fold_left3_map f e l l' l'' = - on_snd List.rev @@ - fold_left3 (fun (e,l) x x' x'' -> let (e,y) = f e x x' x'' in (e,y::l)) (e,[]) l l' l'' +let unionq l1 l2 = union (==) l1 l2 +let subtractq l1 l2 = subtract (==) l1 l2 -let fold_left4_map f e l1 l2 l3 l4 = - on_snd List.rev @@ - fold_left4 (fun (e,l) x1 x2 x3 x4 -> let (e,y) = f e x1 x2 x3 x4 in (e,y::l)) (e,[]) l1 l2 l3 l4 +(** {6 Uniqueness and duplication} *) -let map_assoc f = List.map (fun (x,a) -> (x,f a)) +(* FIXME: we should avoid relying on the generic hash function, + just as we'd better avoid Pervasives.compare *) -let rec assoc_f f a = function - | (x, e) :: xs -> if f a x then e else assoc_f f a xs - | [] -> raise Not_found +let distinct l = + let visited = Hashtbl.create 23 in + let rec loop = function + | h :: t -> + if Hashtbl.mem visited h then false + else + begin + Hashtbl.add visited h h; + loop t + end + | [] -> true + in + loop l -let remove_assoc_f f a l = - try remove_first (fun (x,_) -> f a x) l with Not_found -> l +let distinct_f cmp l = + let rec loop = function + | a :: b :: _ when Int.equal (cmp a b) 0 -> false + | a :: l -> loop l + | [] -> true + in loop (List.sort cmp l) -let mem_assoc_f f a l = List.exists (fun (x,_) -> f a x) l +(* FIXME: again, generic hash function *) + +let uniquize l = + let visited = Hashtbl.create 23 in + let rec aux acc changed = function + | h :: t -> if Hashtbl.mem visited h then aux acc true t else + begin + Hashtbl.add visited h h; + aux (h :: acc) changed t + end + | [] -> if changed then List.rev acc else l + in + aux [] false l + +(** [sort_uniquize] might be an alternative to the hashtbl-based + [uniquize], when the order of the elements is irrelevant *) + +let rec uniquize_sorted cmp = function + | a :: b :: l when Int.equal (cmp a b) 0 -> uniquize_sorted cmp (a :: l) + | a :: l -> a :: uniquize_sorted cmp l + | [] -> [] + +let sort_uniquize cmp l = + uniquize_sorted cmp (List.sort cmp l) + +let rec duplicates cmp = function + | [] -> [] + | x :: l -> + let l' = duplicates cmp l in + if mem_f cmp x l then add_set cmp x l' else l' + +(** {6 Cartesian product} *) (* A generic cartesian product: for any operator (**), [cartesian (**) [x1;x2] [y1;y2] = [x1**y1; x1**y2; x2**y1; x2**y1]], @@ -861,15 +994,9 @@ let cartesians op init ll = (* combinations [[a;b];[c;d]] gives [[a;c];[a;d];[b;c];[b;d]] *) -let combinations l = cartesians (fun x l -> x::l) [] l +let combinations l = + cartesians (fun x l -> x :: l) [] l -let rec combine3 x y z = - match x, y, z with - | [], [], [] -> [] - | (x :: xs), (y :: ys), (z :: zs) -> - (x, y, z) :: combine3 xs ys zs - | _, _, _ -> invalid_arg "List.combine3" - (* Keep only those products that do not return None *) let cartesian_filter op l1 l2 = @@ -880,20 +1007,35 @@ let cartesian_filter op l1 l2 = let cartesians_filter op init ll = List.fold_right (cartesian_filter op) ll [init] -(* Drop the last element of a list *) - -let rec drop_last = function - | [] -> assert false - | hd :: [] -> [] - | hd :: tl -> hd :: drop_last tl - (* Factorize lists of pairs according to the left argument *) let rec factorize_left cmp = function - | (a,b)::l -> + | (a,b) :: l -> let al,l' = partition (fun (a',_) -> cmp a a') l in - (a,(b::List.map snd al)) :: factorize_left cmp l' + (a,(b :: List.map snd al)) :: factorize_left cmp l' | [] -> [] +module Smart = +struct + + let rec map_loop f p = function + | [] -> () + | x :: l' as l -> + let x' = f x in + map_loop f p l'; + if x' == x && !p == l' then p := l else p := x' :: !p + + let map f = function + | [] -> [] + | x :: l' as l -> + let p = ref [] in + let x' = f x in + map_loop f p l'; + if x' == x && !p == l' then l else x' :: !p + +end + +let smartmap = Smart.map + module type MonoS = sig type elt val equal : elt list -> elt list -> bool diff --git a/clib/cList.mli b/clib/cList.mli index db37050aa..13e069e94 100644 --- a/clib/cList.mli +++ b/clib/cList.mli @@ -18,33 +18,31 @@ module type ExtS = sig include S + (** {6 Equality, testing} *) + val compare : 'a cmp -> 'a list cmp (** Lexicographic order on lists. *) val equal : 'a eq -> 'a list eq - (** Lifts equality to list type. *) + (** Lift equality to list type. *) val is_empty : 'a list -> bool - (** Checks whether a list is empty *) - - val init : int -> (int -> 'a) -> 'a list - (** [init n f] constructs the list [f 0; ... ; f (n - 1)]. *) + (** Check whether a list is empty *) val mem_f : 'a eq -> 'a -> 'a list -> bool - (* Same as [List.mem], for some specific equality *) + (** Same as [List.mem], for some specific equality *) - val add_set : 'a eq -> 'a -> 'a list -> 'a list - (** [add_set x l] adds [x] in [l] if it is not already there, or returns [l] - otherwise. *) + val for_all_i : (int -> 'a -> bool) -> int -> 'a list -> bool + (** Same as [List.for_all] but with an index *) - val eq_set : 'a eq -> 'a list eq - (** Test equality up to permutation (but considering multiple occurrences) *) + val for_all2eq : ('a -> 'b -> bool) -> 'a list -> 'b list -> bool + (** Same as [List.for_all2] but returning [false] when of different length *) - val intersect : 'a eq -> 'a list -> 'a list -> 'a list - val union : 'a eq -> 'a list -> 'a list -> 'a list - val unionq : 'a list -> 'a list -> 'a list - val subtract : 'a eq -> 'a list -> 'a list -> 'a list - val subtractq : 'a list -> 'a list -> 'a list + val prefix_of : 'a eq -> 'a list eq + (** [prefix_of eq l1 l2] returns [true] if [l1] is a prefix of [l2], [false] + otherwise. It uses [eq] to compare elements *) + + (** {6 Creating lists} *) val interval : int -> int -> int list (** [interval i j] creates the list [[i; i + 1; ...; j]], or [[]] when @@ -52,58 +50,107 @@ sig val make : int -> 'a -> 'a list (** [make n x] returns a list made of [n] times [x]. Raise - [Invalid_argument "List.make"] if [n] is negative. *) + [Invalid_argument _] if [n] is negative. *) - val assign : 'a list -> int -> 'a -> 'a list - (** [assign l i x] sets the [i]-th element of [l] to [x], starting from [0]. *) + val addn : int -> 'a -> 'a list -> 'a list + (** [addn n x l] adds [n] times [x] on the left of [l]. *) - val distinct : 'a list -> bool - (** Return [true] if all elements of the list are distinct. *) + val init : int -> (int -> 'a) -> 'a list + (** [init n f] constructs the list [f 0; ... ; f (n - 1)]. Raise + [Invalid_argument _] if [n] is negative *) - val distinct_f : 'a cmp -> 'a list -> bool + val append : 'a list -> 'a list -> 'a list + (** Like OCaml's [List.append] but tail-recursive. *) - val duplicates : 'a eq -> 'a list -> 'a list - (** Return the list of unique elements which appear at least twice. Elements - are kept in the order of their first appearance. *) + val concat : 'a list list -> 'a list + (** Like OCaml's [List.concat] but tail-recursive. *) + + val flatten : 'a list list -> 'a list + (** Synonymous of [concat] *) + + (** {6 Lists as arrays} *) + + val assign : 'a list -> int -> 'a -> 'a list + (** [assign l i x] sets the [i]-th element of [l] to [x], starting + from [0]. Raise [Failure _] if [i] is out of range. *) + + (** {6 Filtering} *) + + val filter : ('a -> bool) -> 'a list -> 'a list + (** Like OCaml [List.filter] but tail-recursive and physically returns + the original list if the predicate holds for all elements. *) val filter2 : ('a -> 'b -> bool) -> 'a list -> 'b list -> 'a list * 'b list + (** Like [List.filter] but with 2 arguments, raise [Invalid_argument _] + if the lists are not of same length. *) + + val filteri : (int -> 'a -> bool) -> 'a list -> 'a list + (** Like [List.filter] but with an index starting from [0] *) + + val filter_with : bool list -> 'a list -> 'a list + (** [filter_with bl l] selects elements of [l] whose corresponding element in + [bl] is [true]. Raise [Invalid_argument _] if sizes differ. *) + + val smartfilter : ('a -> bool) -> 'a list -> 'a list + [@@ocaml.deprecated "Same as [filter]"] + val map_filter : ('a -> 'b option) -> 'a list -> 'b list + (** Like [map] but keeping only non-[None] elements *) + val map_filter_i : (int -> 'a -> 'b option) -> 'a list -> 'b list + (** Like [map_filter] but with an index starting from [0] *) - val filter_with : bool list -> 'a list -> 'a list - (** [filter_with b a] selects elements of [a] whose corresponding element in - [b] is [true]. Raise [Invalid_argument _] when sizes differ. *) + val partitioni : (int -> 'a -> bool) -> 'a list -> 'a list * 'a list + (** Like [List.partition] but with an index starting from [0] *) + + (** {6 Applying functorially} *) + + val map : ('a -> 'b) -> 'a list -> 'b list + (** Like OCaml [List.map] but tail-recursive *) + + val map2 : ('a -> 'b -> 'c) -> 'a list -> 'b list -> 'c list + (** Like OCaml [List.map2] but tail-recursive *) val smartmap : ('a -> 'a) -> 'a list -> 'a list - (** [smartmap f [a1...an] = List.map f [a1...an]] but if for all i - [f ai == ai], then [smartmap f l == l] *) + [@@ocaml.deprecated "Same as [Smart.map]"] val map_left : ('a -> 'b) -> 'a list -> 'b list (** As [map] but ensures the left-to-right order of evaluation. *) val map_i : (int -> 'a -> 'b) -> int -> 'a list -> 'b list - (** As [map] but with the index, which starts from [0]. *) + (** Like OCaml [List.mapi] but tail-recursive. Alternatively, like + [map] but with an index *) val map2_i : (int -> 'a -> 'b -> 'c) -> int -> 'a list -> 'b list -> 'c list + (** Like [map2] but with an index *) + val map3 : ('a -> 'b -> 'c -> 'd) -> 'a list -> 'b list -> 'c list -> 'd list + (** Like [map] but for 3 lists. *) + val map4 : ('a -> 'b -> 'c -> 'd -> 'e) -> 'a list -> 'b list -> 'c list -> 'd list -> 'e list - val filteri : (int -> 'a -> bool) -> 'a list -> 'a list - val partitioni : (int -> 'a -> bool) -> 'a list -> 'a list * 'a list + (** Like [map] but for 4 lists. *) val map_of_array : ('a -> 'b) -> 'a array -> 'b list (** [map_of_array f a] behaves as [List.map f (Array.to_list a)] *) - val smartfilter : ('a -> bool) -> 'a list -> 'a list - (** [smartfilter f [a1...an] = List.filter f [a1...an]] but if for all i - [f ai = true], then [smartfilter f l == l] *) + val map_append : ('a -> 'b list) -> 'a list -> 'b list + (** [map_append f [x1; ...; xn]] returns [f x1 @ ... @ f xn]. *) + + val map_append2 : ('a -> 'b -> 'c list) -> 'a list -> 'b list -> 'c list + (** Like [map_append] but for two lists; raises [Invalid_argument _] + if the two lists do not have the same length. *) val extend : bool list -> 'a -> 'a list -> 'a list -(** [extend l a [a1..an]] assumes that the number of [true] in [l] is [n]; + (** [extend l a [a1..an]] assumes that the number of [true] in [l] is [n]; it extends [a1..an] by inserting [a] at the position of [false] in [l] *) + val count : ('a -> bool) -> 'a list -> int + (** Count the number of elements satisfying a predicate *) + + (** {6 Finding position} *) val index : 'a eq -> 'a -> 'a list -> int (** [index] returns the 1st index of an element in a list (counting from 1). *) @@ -111,29 +158,65 @@ sig val index0 : 'a eq -> 'a -> 'a list -> int (** [index0] behaves as [index] except that it starts counting at 0. *) - val iteri : (int -> 'a -> unit) -> 'a list -> unit - (** As [iter] but with the index argument (starting from 0). *) + (** {6 Folding} *) val fold_left_until : ('c -> 'a -> 'c CSig.until) -> 'c -> 'a list -> 'c (** acts like [fold_left f acc s] while [f] returns [Cont acc']; it stops returning [c] as soon as [f] returns [Stop c]. *) val fold_right_i : (int -> 'a -> 'b -> 'b) -> int -> 'a list -> 'b -> 'b + (** Like [List.fold_right] but with an index *) + val fold_left_i : (int -> 'a -> 'b -> 'a) -> int -> 'a -> 'b list -> 'a - val fold_right_and_left : - ('a -> 'b -> 'b list -> 'a) -> 'b list -> 'a -> 'a + (** Like [List.fold_left] but with an index *) + + val fold_right_and_left : ('b -> 'a -> 'a list -> 'b) -> 'a list -> 'b -> 'b + (** [fold_right_and_left f [a1;...;an] hd] is + [f (f (... (f (f hd an [an-1;...;a1]) an-1 [an-2;...;a1]) ...) a2 [a1]) a1 []] *) + val fold_left3 : ('a -> 'b -> 'c -> 'd -> 'a) -> 'a -> 'b list -> 'c list -> 'd list -> 'a + (** Like [List.fold_left] but for 3 lists; raise [Invalid_argument _] if + not all lists of the same size *) + val fold_left2_set : exn -> ('a -> 'b -> 'c -> 'b list -> 'c list -> 'a) -> 'a -> 'b list -> 'c list -> 'a (** Fold sets, i.e. lists up to order; the folding function tells when elements match by returning a value and raising the given exception otherwise; sets should have the same size; raise the given exception if no pairing of the two sets is found;; complexity in O(n^2) *) - val fold_left2_set : exn -> ('a -> 'b -> 'c -> 'b list -> 'c list -> 'a) -> 'a -> 'b list -> 'c list -> 'a - val for_all_i : (int -> 'a -> bool) -> int -> 'a list -> bool + val fold_left_map : ('a -> 'b -> 'a * 'c) -> 'a -> 'b list -> 'a * 'c list + (** [fold_left_map f e_0 [a1;...;an]] is [e_n,[k_1...k_n]] + where [(e_i,k_i)] is [f e_{i-1} ai] for each i<=n *) + + val fold_right_map : ('b -> 'a -> 'c * 'a) -> 'b list -> 'a -> 'c list * 'a + (** Same, folding on the right *) + + val fold_left2_map : ('a -> 'b -> 'c -> 'a * 'd) -> 'a -> 'b list -> 'c list -> 'a * 'd list + (** Same with two lists, folding on the left *) + + val fold_right2_map : ('b -> 'c -> 'a -> 'd * 'a) -> 'b list -> 'c list -> 'a -> 'd list * 'a + (** Same with two lists, folding on the right *) + + val fold_left3_map : ('a -> 'b -> 'c -> 'd -> 'a * 'e) -> 'a -> 'b list -> 'c list -> 'd list -> 'a * 'e list + (** Same with three lists, folding on the left *) + + val fold_left4_map : ('a -> 'b -> 'c -> 'd -> 'e -> 'a * 'r) -> 'a -> 'b list -> 'c list -> 'd list -> 'e list -> 'a * 'r list + (** Same with four lists, folding on the left *) + + val fold_map : ('a -> 'b -> 'a * 'c) -> 'a -> 'b list -> 'a * 'c list + [@@ocaml.deprecated "Same as [fold_left_map]"] + + val fold_map' : ('b -> 'a -> 'c * 'a) -> 'b list -> 'a -> 'c list * 'a + [@@ocaml.deprecated "Same as [fold_right_map]"] + + (** {6 Splitting} *) + val except : 'a eq -> 'a -> 'a list -> 'a list + (** [except eq a l] Remove all occurrences of [a] in [l] *) + val remove : 'a eq -> 'a -> 'a list -> 'a list + (** Alias of [except] *) val remove_first : ('a -> bool) -> 'a list -> 'a list (** Remove the first element satisfying a predicate, or raise [Not_found] *) @@ -142,35 +225,10 @@ sig (** Remove and return the first element satisfying a predicate, or raise [Not_found] *) - val insert : ('a -> 'a -> bool) -> 'a -> 'a list -> 'a list - (** Insert at the (first) position so that if the list is ordered wrt to the - total order given as argument, the order is preserved *) - - val for_all2eq : ('a -> 'b -> bool) -> 'a list -> 'b list -> bool - val sep_last : 'a list -> 'a * 'a list - val find_map : ('a -> 'b option) -> 'a list -> 'b (** Returns the first element that is mapped to [Some _]. Raise [Not_found] if there is none. *) - val uniquize : 'a list -> 'a list - (** Return the list of elements without duplicates. - This is the list unchanged if there was none. *) - - val sort_uniquize : 'a cmp -> 'a list -> 'a list - (** Return a sorted and de-duplicated version of a list, - according to some comparison function. *) - - val merge_uniq : 'a cmp -> 'a list -> 'a list -> 'a list - (** Merge two sorted lists and preserves the uniqueness property. *) - - val subset : 'a list -> 'a list -> bool - - val chop : int -> 'a list -> 'a list * 'a list - (** [chop i l] splits [l] into two lists [(l1,l2)] such that - [l1++l2=l] and [l1] has length [i]. It raises [Failure] when [i] - is negative or greater than the length of [l] *) - exception IndexOutOfRange val goto: int -> 'a list -> 'a list * 'a list (** [goto i l] splits [l] into two lists [(l1,l2)] such that @@ -178,86 +236,175 @@ sig [IndexOutOfRange] when [i] is negative or greater than the length of [l]. *) - val split_when : ('a -> bool) -> 'a list -> 'a list * 'a list - val split3 : ('a * 'b * 'c) list -> 'a list * 'b list * 'c list - val firstn : int -> 'a list -> 'a list + (** [split_when p l] splits [l] into two lists [(l1,a::l2)] such that + [l1++(a::l2)=l], [p a=true] and [p b = false] for every element [b] of [l1]. + if there is no such [a], then it returns [(l,[])] instead. *) + + val sep_last : 'a list -> 'a * 'a list + (** [sep_last l] returns [(a,l')] such that [l] is [l'@[a]]. + It raises [Failure _] if the list is empty. *) + + val drop_last : 'a list -> 'a list + (** Remove the last element of the list. It raises [Failure _] if the + list is empty. This is the second part of [sep_last]. *) + val last : 'a list -> 'a + (** Return the last element of the list. It raises [Failure _] if the + list is empty. This is the first part of [sep_last]. *) + val lastn : int -> 'a list -> 'a list + (** [lastn n l] returns the [n] last elements of [l]. It raises + [Failure _] if [n] is less than 0 or larger than the length of [l] *) + + val chop : int -> 'a list -> 'a list * 'a list + (** [chop i l] splits [l] into two lists [(l1,l2)] such that + [l1++l2=l] and [l1] has length [i]. It raises [Failure _] when + [i] is negative or greater than the length of [l]. *) + + val firstn : int -> 'a list -> 'a list + (** [firstn n l] Returns the [n] first elements of [l]. It raises + [Failure _] if [n] negative or too large. This is the first part + of [chop]. *) + val skipn : int -> 'a list -> 'a list + (** [skipn n l] drops the [n] first elements of [l]. It raises + [Failure _] if [n] is less than 0 or larger than the length of [l]. + This is the second part of [chop]. *) + val skipn_at_least : int -> 'a list -> 'a list + (** Same as [skipn] but returns [] if [n] is larger than the list of + the list. *) - val addn : int -> 'a -> 'a list -> 'a list - (** [addn n x l] adds [n] times [x] on the left of [l]. *) + val drop_prefix : 'a eq -> 'a list -> 'a list -> 'a list + (** [drop_prefix eq l1 l] returns [l2] if [l=l1++l2] else return [l]. *) - val prefix_of : 'a eq -> 'a list -> 'a list -> bool - (** [prefix_of l1 l2] returns [true] if [l1] is a prefix of [l2], [false] + val insert : 'a eq -> 'a -> 'a list -> 'a list + (** Insert at the (first) position so that if the list is ordered wrt to the + total order given as argument, the order is preserved *) + + val share_tails : 'a list -> 'a list -> 'a list * 'a list * 'a list + (** [share_tails l1 l2] returns [(l1',l2',l)] such that [l1] is + [l1'@l] and [l2] is [l2'@l] and [l] is maximal amongst all such + decompositions*) + + (** {6 Association lists} *) + + val map_assoc : ('a -> 'b) -> ('c * 'a) list -> ('c * 'b) list + (** Applies a function on the codomain of an association list *) + + val assoc_f : 'a eq -> 'a -> ('a * 'b) list -> 'b + (** Like [List.assoc] but using the equality given as argument *) + + val remove_assoc_f : 'a eq -> 'a -> ('a * 'b) list -> ('a * 'b) list + (** Remove first matching element; unchanged if no such element *) + + val mem_assoc_f : 'a eq -> 'a -> ('a * 'b) list -> bool + (** Like [List.mem_assoc] but using the equality given as argument *) + + val factorize_left : 'a eq -> ('a * 'b) list -> ('a * 'b list) list + (** Create a list of associations from a list of pairs *) + + (** {6 Operations on lists of tuples} *) + + val split : ('a * 'b) list -> 'a list * 'b list + (** Like OCaml's [List.split] but tail-recursive. *) + + val combine : 'a list -> 'b list -> ('a * 'b) list + (** Like OCaml's [List.combine] but tail-recursive. *) + + val split3 : ('a * 'b * 'c) list -> 'a list * 'b list * 'c list + (** Like [split] but for triples *) + + val combine3 : 'a list -> 'b list -> 'c list -> ('a * 'b * 'c) list + (** Like [combine] but for triples *) + + (** {6 Operations on lists seen as sets, preserving uniqueness of elements} *) + + val add_set : 'a eq -> 'a -> 'a list -> 'a list + (** [add_set x l] adds [x] in [l] if it is not already there, or returns [l] otherwise. *) - val drop_prefix : 'a eq -> 'a list -> 'a list -> 'a list - (** [drop_prefix p l] returns [t] if [l=p++t] else return [l]. *) + val eq_set : 'a eq -> 'a list eq + (** Test equality up to permutation. It respects multiple occurrences + and thus works also on multisets. *) - val drop_last : 'a list -> 'a list + val subset : 'a list eq + (** Tell if a list is a subset of another up to permutation. It expects + each element to occur only once. *) - val map_append : ('a -> 'b list) -> 'a list -> 'b list - (** [map_append f [x1; ...; xn]] returns [(f x1)@(f x2)@...@(f xn)]. *) + val merge_set : 'a cmp -> 'a list -> 'a list -> 'a list + (** Merge two sorted lists and preserves the uniqueness property. *) - val map_append2 : ('a -> 'b -> 'c list) -> 'a list -> 'b list -> 'c list - (** As [map_append]. Raises [Invalid_argument _] if the two lists don't have - the same length. *) + val intersect : 'a eq -> 'a list -> 'a list -> 'a list + (** Return the intersection of two lists, assuming and preserving + uniqueness of elements *) - val share_tails : 'a list -> 'a list -> 'a list * 'a list * 'a list + val union : 'a eq -> 'a list -> 'a list -> 'a list + (** Return the union of two lists, assuming and preserving + uniqueness of elements *) - val fold_left_map : ('a -> 'b -> 'a * 'c) -> 'a -> 'b list -> 'a * 'c list - (** [fold_left_map f e_0 [l_1...l_n] = e_n,[k_1...k_n]] - where [(e_i,k_i)=f e_{i-1} l_i] *) + val unionq : 'a list -> 'a list -> 'a list + (** [union] specialized to physical equality *) - val fold_right_map : ('b -> 'a -> 'c * 'a) -> 'b list -> 'a -> 'c list * 'a - (** Same, folding on the right *) + val subtract : 'a eq -> 'a list -> 'a list -> 'a list + (** Remove from the first list all elements from the second list. *) - val fold_left2_map : ('a -> 'b -> 'c -> 'a * 'd) -> 'a -> 'b list -> 'c list -> 'a * 'd list - (** Same with two lists, folding on the left *) + val subtractq : 'a list -> 'a list -> 'a list + (** [subtract] specialized to physical equality *) - val fold_right2_map : ('b -> 'c -> 'a -> 'd * 'a) -> 'b list -> 'c list -> 'a -> 'd list * 'a - (** Same with two lists, folding on the right *) + val merge_uniq : 'a cmp -> 'a list -> 'a list -> 'a list + [@@ocaml.deprecated "Same as [merge_set]"] - val fold_left3_map : ('a -> 'b -> 'c -> 'd -> 'a * 'e) -> 'a -> 'b list -> 'c list -> 'd list -> 'a * 'e list - (** Same with three lists, folding on the left *) + (** {6 Uniqueness and duplication} *) - val fold_left4_map : ('a -> 'b -> 'c -> 'd -> 'e -> 'a * 'r) -> 'a -> 'b list -> 'c list -> 'd list -> 'e list -> 'a * 'r list - (** Same with four lists, folding on the left *) + val distinct : 'a list -> bool + (** Return [true] if all elements of the list are distinct. *) - val fold_map : ('a -> 'b -> 'a * 'c) -> 'a -> 'b list -> 'a * 'c list - (* [@@ocaml.deprecated "Same as [fold_left_map]"] *) - (** @deprecated Same as [fold_left_map] *) + val distinct_f : 'a cmp -> 'a list -> bool + (** Like [distinct] but using the equality given as argument *) - val fold_map' : ('b -> 'a -> 'c * 'a) -> 'b list -> 'a -> 'c list * 'a - (** @deprecated Same as [fold_right_map] *) + val duplicates : 'a eq -> 'a list -> 'a list + (** Return the list of unique elements which appear at least twice. Elements + are kept in the order of their first appearance. *) - val map_assoc : ('a -> 'b) -> ('c * 'a) list -> ('c * 'b) list - val assoc_f : 'a eq -> 'a -> ('a * 'b) list -> 'b - val remove_assoc_f : 'a eq -> 'a -> ('a * 'b) list -> ('a * 'b) list - val mem_assoc_f : 'a eq -> 'a -> ('a * 'b) list -> bool + val uniquize : 'a list -> 'a list + (** Return the list of elements without duplicates. + This is the list unchanged if there was none. *) + + val sort_uniquize : 'a cmp -> 'a list -> 'a list + (** Return a sorted version of a list without duplicates + according to some comparison function. *) + + (** {6 Cartesian product} *) val cartesian : ('a -> 'b -> 'c) -> 'a list -> 'b list -> 'c list - (** A generic cartesian product: for any operator (**), + (** A generic binary cartesian product: for any operator (**), [cartesian (**) [x1;x2] [y1;y2] = [x1**y1; x1**y2; x2**y1; x2**y1]], and so on if there are more elements in the lists. *) val cartesians : ('a -> 'b -> 'b) -> 'b -> 'a list list -> 'b list - (** [cartesians] is an n-ary cartesian product: it iterates - [cartesian] over a list of lists. *) + (** [cartesians op init l] is an n-ary cartesian product: it builds + the list of all [op a1 .. (op an init) ..] for [a1], ..., [an] in + the product of the elements of the lists *) val combinations : 'a list list -> 'a list list - (** combinations [[a;b];[c;d]] returns [[a;c];[a;d];[b;c];[b;d]] *) - - val combine3 : 'a list -> 'b list -> 'c list -> ('a * 'b * 'c) list + (** [combinations l] returns the list of [n_1] * ... * [n_p] tuples + [[a11;...;ap1];...;[a1n_1;...;apn_pd]] whenever [l] is a list + [[a11;..;a1n_1];...;[ap1;apn_p]]; otherwise said, it is + [cartesians (::) [] l] *) val cartesians_filter : ('a -> 'b -> 'b option) -> 'b -> 'a list list -> 'b list - (** Keep only those products that do not return None *) - - val factorize_left : 'a eq -> ('a * 'b) list -> ('a * 'b list) list + (** Like [cartesians op init l] but keep only the tuples for which + [op] returns [Some _] on all the elements of the tuple. *) + + module Smart : + sig + val map : ('a -> 'a) -> 'a list -> 'a list + (** [Smart.map f [a1...an] = List.map f [a1...an]] but if for all i + [f ai == ai], then [Smart.map f l == l] *) + end module type MonoS = sig type elt diff --git a/clib/cMap.ml b/clib/cMap.ml index 373e3f8fd..54a8b2585 100644 --- a/clib/cMap.ml +++ b/clib/cMap.ml @@ -35,8 +35,15 @@ sig val fold_left : (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b val fold_right : (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b val smartmap : ('a -> 'a) -> 'a t -> 'a t + [@@ocaml.deprecated "Same as [Smart.map]"] val smartmapi : (key -> 'a -> 'a) -> 'a t -> 'a t + [@@ocaml.deprecated "Same as [Smart.mapi]"] val height : 'a t -> int + module Smart : + sig + val map : ('a -> 'a) -> 'a t -> 'a t + val mapi : (key -> 'a -> 'a) -> 'a t -> 'a t + end module Unsafe : sig val map : (key -> 'a -> key * 'b) -> 'a t -> 'b t @@ -59,8 +66,15 @@ sig val fold_left : (M.t -> 'a -> 'b -> 'b) -> 'a map -> 'b -> 'b val fold_right : (M.t -> 'a -> 'b -> 'b) -> 'a map -> 'b -> 'b val smartmap : ('a -> 'a) -> 'a map -> 'a map + [@@ocaml.deprecated "Same as [Smart.map]"] val smartmapi : (M.t -> 'a -> 'a) -> 'a map -> 'a map + [@@ocaml.deprecated "Same as [Smart.mapi]"] val height : 'a map -> int + module Smart : + sig + val map : ('a -> 'a) -> 'a map -> 'a map + val mapi : (M.t -> 'a -> 'a) -> 'a map -> 'a map + end module Unsafe : sig val map : (M.t -> 'a -> M.t * 'b) -> 'a map -> 'b map @@ -154,28 +168,36 @@ struct let accu = f k v (fold_right f r accu) in fold_right f l accu - let rec smartmap f (s : 'a map) = match map_prj s with - | MEmpty -> map_inj MEmpty - | MNode (l, k, v, r, h) -> - let l' = smartmap f l in - let r' = smartmap f r in - let v' = f v in - if l == l' && r == r' && v == v' then s - else map_inj (MNode (l', k, v', r', h)) - - let rec smartmapi f (s : 'a map) = match map_prj s with - | MEmpty -> map_inj MEmpty - | MNode (l, k, v, r, h) -> - let l' = smartmapi f l in - let r' = smartmapi f r in - let v' = f k v in - if l == l' && r == r' && v == v' then s - else map_inj (MNode (l', k, v', r', h)) - let height s = match map_prj s with | MEmpty -> 0 | MNode (_, _, _, _, h) -> h + module Smart = + struct + + let rec map f (s : 'a map) = match map_prj s with + | MEmpty -> map_inj MEmpty + | MNode (l, k, v, r, h) -> + let l' = map f l in + let r' = map f r in + let v' = f v in + if l == l' && r == r' && v == v' then s + else map_inj (MNode (l', k, v', r', h)) + + let rec mapi f (s : 'a map) = match map_prj s with + | MEmpty -> map_inj MEmpty + | MNode (l, k, v, r, h) -> + let l' = mapi f l in + let r' = mapi f r in + let v' = f k v in + if l == l' && r == r' && v == v' then s + else map_inj (MNode (l', k, v', r', h)) + + end + + let smartmap = Smart.map + let smartmapi = Smart.mapi + module Unsafe = struct diff --git a/clib/cMap.mli b/clib/cMap.mli index bb0019bb8..127bf23ab 100644 --- a/clib/cMap.mli +++ b/clib/cMap.mli @@ -58,14 +58,23 @@ sig (** Folding keys in decreasing order. *) val smartmap : ('a -> 'a) -> 'a t -> 'a t - (** As [map] but tries to preserve sharing. *) + [@@ocaml.deprecated "Same as [Smart.map]"] val smartmapi : (key -> 'a -> 'a) -> 'a t -> 'a t - (** As [mapi] but tries to preserve sharing. *) + [@@ocaml.deprecated "Same as [Smart.mapi]"] val height : 'a t -> int (** An indication of the logarithmic size of a map *) + module Smart : + sig + val map : ('a -> 'a) -> 'a t -> 'a t + (** As [map] but tries to preserve sharing. *) + + val mapi : (key -> 'a -> 'a) -> 'a t -> 'a t + (** As [mapi] but tries to preserve sharing. *) + end + module Unsafe : sig val map : (key -> 'a -> key * 'b) -> 'a t -> 'b t diff --git a/clib/deque.ml b/clib/deque.ml deleted file mode 100644 index 9d0bbf12a..000000000 --- a/clib/deque.ml +++ /dev/null @@ -1,99 +0,0 @@ -(************************************************************************) -(* * 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) *) -(************************************************************************) - -exception Empty - -type 'a t = { - face : 'a list; - rear : 'a list; - lenf : int; - lenr : int; -} - -let rec split i accu l = match l with -| [] -> - if Int.equal i 0 then (accu, []) else invalid_arg "split" -| t :: q -> - if Int.equal i 0 then (accu, l) - else split (pred i) (t :: accu) q - -let balance q = - let avg = (q.lenf + q.lenr) / 2 in - let dif = q.lenf + q.lenr - avg in - if q.lenf > succ (2 * q.lenr) then - let (ff, fr) = split avg [] q.face in - { face = List.rev ff ; rear = q.rear @ List.rev fr; lenf = avg; lenr = dif } - else if q.lenr > succ (2 * q.lenf) then - let (rf, rr) = split avg [] q.rear in - { face = q.face @ List.rev rr ; rear = List.rev rf; lenf = dif; lenr = avg } - else q - -let empty = { - face = []; - rear = []; - lenf = 0; - lenr = 0; -} - -let lcons x q = - balance { q with lenf = succ q.lenf; face = x :: q.face } - -let lhd q = match q.face with -| [] -> - begin match q.rear with - | [] -> raise Empty - | t :: _ -> t - end -| t :: _ -> t - -let ltl q = match q.face with -| [] -> - begin match q.rear with - | [] -> raise Empty - | t :: _ -> empty - end -| t :: r -> balance { q with lenf = pred q.lenf; face = r } - -let rcons x q = - balance { q with lenr = succ q.lenr; rear = x :: q.rear } - -let rhd q = match q.rear with -| [] -> - begin match q.face with - | [] -> raise Empty - | t :: r -> t - end -| t :: _ -> t - -let rtl q = match q.rear with -| [] -> - begin match q.face with - | [] -> raise Empty - | t :: r -> empty - end -| t :: r -> - balance { q with lenr = pred q.lenr; rear = r } - -let rev q = { - face = q.rear; - rear = q.face; - lenf = q.lenr; - lenr = q.lenf; -} - -let length q = q.lenf + q.lenr - -let is_empty q = Int.equal (length q) 0 - -let filter f q = - let fold (accu, len) x = if f x then (x :: accu, succ len) else (accu, len) in - let (rf, lenf) = List.fold_left fold ([], 0) q.face in - let (rr, lenr) = List.fold_left fold ([], 0) q.rear in - balance { face = List.rev rf; rear = List.rev rr; lenf = lenf; lenr = lenr } diff --git a/clib/deque.mli b/clib/deque.mli deleted file mode 100644 index 1c03c384d..000000000 --- a/clib/deque.mli +++ /dev/null @@ -1,60 +0,0 @@ -(************************************************************************) -(* * 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) *) -(************************************************************************) - -(** * Purely functional, double-ended queues *) - -(** This module implements the banker's deque, from Okasaki. Most operations are - amortized O(1). *) - -type +'a t - -exception Empty - -(** {5 Constructor} *) - -val empty : 'a t - -(** The empty deque. *) - -(** {5 Left-side operations} *) - -val lcons : 'a -> 'a t -> 'a t -(** Pushes an element on the left side of the deque. *) - -val lhd : 'a t -> 'a -(** Returns the leftmost element in the deque. Raises [Empty] when empty. *) - -val ltl : 'a t -> 'a t -(** Returns the left-tail of the deque. Raises [Empty] when empty. *) - -(** {5 Right-side operations} *) - -val rcons : 'a -> 'a t -> 'a t -(** Same as [lcons] but on the right side. *) - -val rhd : 'a t -> 'a -(** Same as [lhd] but on the right side. *) - -val rtl : 'a t -> 'a t -(** Same as [ltl] but on the right side. *) - -(** {5 Operations} *) - -val rev : 'a t -> 'a t -(** Reverse deque. *) - -val length : 'a t -> int -(** Length of a deque. *) - -val is_empty : 'a t -> bool -(** Emptyness of a deque. *) - -val filter : ('a -> bool) -> 'a t -> 'a t -(** Filters the deque *) diff --git a/clib/hMap.ml b/clib/hMap.ml index 37f867c6b..b2cf47430 100644 --- a/clib/hMap.ml +++ b/clib/hMap.ml @@ -383,13 +383,21 @@ struct let m = Map.set k x m in Int.Map.set h m s - let smartmap f s = - let fs m = Map.smartmap f m in - Int.Map.smartmap fs s + module Smart = + struct + + let map f s = + let fs m = Map.Smart.map f m in + Int.Map.Smart.map fs s + + let mapi f s = + let fs m = Map.Smart.mapi f m in + Int.Map.Smart.map fs s + + end - let smartmapi f s = - let fs m = Map.smartmapi f m in - Int.Map.smartmap fs s + let smartmap = Smart.map + let smartmapi = Smart.mapi let height s = Int.Map.height s diff --git a/clib/option.ml b/clib/option.ml index 32fe2fc5f..7a3d5f934 100644 --- a/clib/option.ml +++ b/clib/option.ml @@ -100,12 +100,6 @@ let map f = function | Some y -> Some (f y) | _ -> None -(** [smartmap f x] does the same as [map f x] except that it tries to share - some memory. *) -let smartmap f = function - | Some y as x -> let y' = f y in if y' == y then x else Some y' - | _ -> None - (** [fold_left f a x] is [f a y] if [x] is [Some y], and [a] otherwise. *) let fold_left f a = function | Some y -> f a y @@ -176,6 +170,21 @@ let lift2 f x y = | _,_ -> None +(** {6 Smart operations} *) + +module Smart = +struct + + (** [Smart.map f x] does the same as [map f x] except that it tries to share + some memory. *) + let map f = function + | Some y as x -> let y' = f y in if y' == y then x else Some y' + | _ -> None + +end + +let smartmap = Smart.map + (** {6 Operations with Lists} *) module List = diff --git a/clib/option.mli b/clib/option.mli index 67b42268a..8f82bf090 100644 --- a/clib/option.mli +++ b/clib/option.mli @@ -75,9 +75,8 @@ val iter2 : ('a -> 'b -> unit) -> 'a option -> 'b option -> unit (** [map f x] is [None] if [x] is [None] and [Some (f y)] if [x] is [Some y]. *) val map : ('a -> 'b) -> 'a option -> 'b option -(** [smartmap f x] does the same as [map f x] except that it tries to share - some memory. *) val smartmap : ('a -> 'a) -> 'a option -> 'a option +[@@ocaml.deprecated "Same as [Smart.map]"] (** [fold_left f a x] is [f a y] if [x] is [Some y], and [a] otherwise. *) val fold_left : ('b -> 'a -> 'b) -> 'b -> 'a option -> 'b @@ -98,6 +97,7 @@ val fold_right_map : ('b -> 'a -> 'c * 'a) -> 'b option -> 'a -> 'c option * 'a (** @deprecated Same as [fold_left_map] *) val fold_map : ('a -> 'b -> 'a * 'c) -> 'a -> 'b option -> 'a * 'c option +[@@ocaml.deprecated "Same as [fold_left_map]"] (** [cata f e x] is [e] if [x] is [None] and [f a] if [x] is [Some a] *) val cata : ('a -> 'b) -> 'b -> 'a option -> 'b @@ -122,6 +122,16 @@ val lift_left : ('a -> 'b -> 'c) -> 'a option -> 'b -> 'c option [Some w]. It is [None] otherwise. *) val lift2 : ('a -> 'b -> 'c) -> 'a option -> 'b option -> 'c option +(** {6 Smart operations} *) + +module Smart : +sig + + (** [Smart.map f x] does the same as [map f x] except that it tries to share + some memory. *) + val map : ('a -> 'a) -> 'a option -> 'a option + +end (** {6 Operations with Lists} *) diff --git a/configure.ml b/configure.ml index 6c052b63b..9d959b9af 100644 --- a/configure.ml +++ b/configure.ml @@ -11,21 +11,29 @@ #load "str.cma" open Printf -let coq_version = "8.8+alpha" -let coq_macos_version = "8.7.90" (** "[...] should be a string comprised of +let coq_version = "8.9+alpha" +let coq_macos_version = "8.8.90" (** "[...] should be a string comprised of three non-negative, period-separated integers [...]" *) -let vo_magic = 8791 -let state_magic = 58791 -let distributed_exec = ["coqtop";"coqc";"coqchk";"coqdoc";"coqworkmgr"; -"coqdoc";"coq_makefile";"coq-tex";"gallina";"coqwc";"csdpcert";"coqdep"] +let vo_magic = 8891 +let state_magic = 58891 +let distributed_exec = + ["coqtop.opt"; "coqidetop.opt"; "coqqueryworker.opt"; "coqproofworker.opt"; "coqtacticworker.opt"; + "coqc";"coqchk";"coqdoc";"coqworkmgr";"coq_makefile";"coq-tex";"gallina";"coqwc";"csdpcert";"coqdep"] let verbose = ref false (* for debugging this script *) +let red, yellow, reset = + if Unix.isatty Unix.stdout && Unix.isatty Unix.stderr && Sys.os_type = "Unix" + then "\027[31m", "\027[33m", "\027[0m" + else "", "", "" + (** * Utility functions *) let cfprintf oc = kfprintf (fun oc -> fprintf oc "\n%!") oc let cprintf s = cfprintf stdout s let ceprintf s = cfprintf stderr s -let die msg = ceprintf "%s\nConfiguration script failed!" msg; exit 1 +let die msg = ceprintf "%s%s%s\nConfiguration script failed!" red msg reset; exit 1 + +let warn s = kfprintf (fun oc -> cfprintf oc "%s" reset) stdout ("%sWarning: " ^^ s) yellow let s2i = int_of_string let i2s = string_of_int @@ -109,7 +117,7 @@ let run ?(fatal=true) ?(err=StdErr) prog args = let cmd = String.concat " " (prog::args) in let exn = match e with Failure s -> s | _ -> Printexc.to_string e in let msg = sprintf "Error while running '%s' (%s)" cmd exn in - if fatal then die msg else (cprintf "W: %s" msg; "", []) + if fatal then die msg else (warn "%s" msg; "", []) let tryrun prog args = run ~fatal:false ~err:DevNull prog args @@ -205,7 +213,7 @@ let win_aware_quote_executable str = sprintf "%S" str else let _ = if contains_suspicious_characters str then - cprintf "*Warning* The string %S contains suspicious characters; ocamlfind might fail" str in + warn "The string %S contains suspicious characters; ocamlfind might fail" str in Str.global_replace (Str.regexp "\\\\") "/" str (** * Date *) @@ -414,8 +422,8 @@ let args_options = Arg.align [ " Do not add debugging information in the Coq executables"; "-profiling", arg_set (fun p profile -> { p with profile }), " Add profiling information in the Coq executables"; - "-annotate", Arg.Unit (fun () -> cprintf "*Warning* -annotate is deprecated. Please use -annot or -bin-annot instead."), - " Deprecated. Please use -annot or -bin-annot instead"; + "-annotate", Arg.Unit (fun () -> die "-annotate has been removed. Please use -annot or -bin-annot instead."), + " Removed option. Please use -annot or -bin-annot instead"; "-annot", arg_set (fun p annot -> { p with annot }), " Dumps ml text annotation files while compiling Coq (e.g. for Tuareg)"; "-bin-annot", arg_set (fun p bin_annot -> { p with bin_annot }), @@ -598,7 +606,7 @@ let check_caml_version () = else let () = cprintf "Your version of OCaml is %s." caml_version in if !prefs.force_caml_version then - cprintf "*Warning* Your version of OCaml is outdated." + warn "Your version of OCaml is outdated." else die "You need OCaml 4.02.1 or later." @@ -620,7 +628,7 @@ let check_findlib_version () = else let () = cprintf "Your version of OCamlfind is %s." findlib_version in if !prefs.force_findlib_version then - cprintf "*Warning* Your version of OCamlfind is outdated." + warn "Your version of OCamlfind is outdated." else die "You need OCamlfind 1.4.1 or later." @@ -731,17 +739,17 @@ let camlp5libdir = shorten_camllib fullcamlp5libdir (** * Native compiler *) -let msg_byteonly () = - cprintf "Only the bytecode version of Coq will be available." +let msg_byteonly = + "Only the bytecode version of Coq will be available." let msg_no_ocamlopt () = - cprintf "Cannot find the OCaml native-code compiler."; msg_byteonly () + warn "Cannot find the OCaml native-code compiler.\n%s" msg_byteonly let msg_no_camlp5_cmxa () = - cprintf "Cannot find the native-code library of camlp5."; msg_byteonly () + warn "Cannot find the native-code library of camlp5.\n%s" msg_byteonly let msg_no_dynlink_cmxa () = - cprintf "Cannot find native-code dynlink library."; msg_byteonly (); + warn "Cannot find native-code dynlink library.\n%s" msg_byteonly; cprintf "For building a native-code Coq, you may try to first"; cprintf "compile and install a dummy dynlink.cmxa (see dev/dynlink.ml)"; cprintf "and then run ./configure -natdynlink no" @@ -757,8 +765,7 @@ let check_native () = else let () = if version <> caml_version then - cprintf - "Warning: Native and bytecode compilers do not have the same version!" + warn "Native and bytecode compilers do not have the same version!" in cprintf "You have native-code compilation. Good!" let best_compiler = @@ -813,7 +820,7 @@ let get_source = function (** Is some location a suitable LablGtk2 installation ? *) let check_lablgtkdir ?(fatal=false) src dir = - let yell msg = if fatal then die msg else (cprintf "%s" msg; false) in + 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) @@ -849,7 +856,7 @@ let get_lablgtkdir () = let check_lablgtk_version src dir = match src with | Manual | Stdlib -> - cprintf "Warning: could not check the version of lablgtk2.\nMake sure your version is at least 2.18.3."; + 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 @@ -860,7 +867,11 @@ let check_lablgtk_version src dir = match src with 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 *) - cprintf "Warning: 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; + 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 @@ -1212,7 +1223,7 @@ let write_configml f = let core_src_dirs = [ "config"; "dev"; "lib"; "clib"; "kernel"; "library"; "engine"; "pretyping"; "interp"; "parsing"; "proofs"; - "tactics"; "toplevel"; "printing"; "intf"; + "tactics"; "toplevel"; "printing"; "grammar"; "ide"; "stm"; "vernac" ] in let core_src_dirs = List.fold_left (fun acc core_src_subdir -> acc ^ " \"" ^ core_src_subdir ^ "\";\n") "" @@ -1237,17 +1248,6 @@ let write_configml f = let _ = write_configml "config/coq_config.ml" -(** * Symlinks or copies for the checker *) - -let _ = - let prog, args, prf = - if arch = "win32" then "cp", [], "" - else "ln", ["-s"], "../" in - List.iter (fun file -> - ignore(run "rm" ["-f"; "checker/"^file]); - ignore(run ~fatal:true prog (args @ [prf^"kernel/"^file;"checker/"^file]))) - [ "esubst.ml"; "esubst.mli"; "names.ml"; "names.mli" ] - (** * Build the config/Makefile file *) let write_makefile f = diff --git a/default.nix b/default.nix index 26c6e4b90..91d963604 100644 --- a/default.nix +++ b/default.nix @@ -21,25 +21,25 @@ # Once the build is finished, you will find, in the current directory, # a symlink to where Coq was installed. -{ pkgs ? - (import (fetchTarball - "https://github.com/NixOS/nixpkgs/archive/4345a2cef228a91c1d6d4bf626a0f933eb8cc4f9.tar.gz") - {}) -, ocamlPackages ? pkgs.ocamlPackages +{ pkgs ? (import <nixpkgs> {}) +, ocamlPackages ? pkgs.ocaml-ng.ocamlPackages_4_06 , buildIde ? true , buildDoc ? true , doCheck ? true }: with pkgs; +with stdenv.lib; stdenv.mkDerivation rec { name = "coq"; - buildInputs = (with ocamlPackages; [ + buildInputs = [ # Coq dependencies + hostname + ] ++ (with ocamlPackages; [ ocaml findlib camlp5_strict @@ -61,18 +61,17 @@ stdenv.mkDerivation rec { ] else []) ++ (if doCheck then # Test-suite dependencies - let inherit (stdenv.lib) versionAtLeast optional; in - /* ncurses is required to build an OCaml REPL */ + # ncurses is required to build an OCaml REPL optional (!versionAtLeast ocaml.version "4.07") ncurses ++ [ python rsync which + ocamlPackages.ounit ] else []) ++ (if lib.inNixShell then [ ocamlPackages.merlin ocamlPackages.ocpIndent - ocamlPackages.ocp-index # Dependencies of the merging script jq @@ -90,6 +89,10 @@ stdenv.mkDerivation rec { prefixKey = "-prefix "; + buildFlags = [ "world" ] ++ optional buildDoc "doc-html"; + + installTargets = [ "install" ] ++ optional buildDoc "install-doc-html"; + inherit doCheck; } diff --git a/dev/base_include b/dev/base_include index e76044f41..574bc097e 100644 --- a/dev/base_include +++ b/dev/base_include @@ -15,7 +15,6 @@ #directory "tactics";; #directory "printing";; #directory "grammar";; -#directory "intf";; #directory "stm";; #directory "vernac";; @@ -109,8 +108,6 @@ open Inductiveops open Locusops open Find_subterm open Unification -open Miscops -open Miscops open Nativenorm open Typeclasses open Typeclasses_errors @@ -190,7 +187,7 @@ let qid = Libnames.qualid_of_string;; (* parsing of terms *) let parse_constr = Pcoq.parse_string Pcoq.Constr.constr;; -let parse_vernac = Pcoq.parse_string Pcoq.Vernac_.vernac_control;; +let parse_vernac = Pcoq.parse_string Pvernac.Vernac_.vernac_control;; let parse_tac = Pcoq.parse_string Ltac_plugin.Pltac.tactic;; (* build a term of type glob_constr without type-checking or resolution of @@ -205,7 +202,9 @@ let e s = implicit syntax *) let constr_of_string s = - Constrintern.interp_constr (Global.env()) Evd.empty (parse_constr s);; + let env = Global.env () in + let sigma = Evd.from_env env in + Constrintern.interp_constr env sigma (parse_constr s);; (* get the body of a constant *) @@ -232,7 +231,7 @@ let _ = Flags.in_toplevel := true let _ = Constrextern.set_extern_reference (fun ?loc _ r -> CAst.make ?loc @@ Libnames.Qualid (Nametab.shortest_qualid_of_global Id.Set.empty r));; -let go () = Coqloop.loop ~state:Option.(get !Coqloop.drop_last_doc) +let go () = Coqloop.(loop ~opts:Option.(get !drop_args) ~state:Option.(get !drop_last_doc)) let _ = print_string diff --git a/dev/build/osx/make-macos-dmg.sh b/dev/build/osx/make-macos-dmg.sh index dc33838f1..c450e8157 100755 --- a/dev/build/osx/make-macos-dmg.sh +++ b/dev/build/osx/make-macos-dmg.sh @@ -10,19 +10,19 @@ VERSION=$(sed -n -e '/^let coq_version/ s/^[^"]*"\([^"]*\)"$/\1/p' configure.ml) APP=bin/CoqIDE_${VERSION}.app # Create a .app file with CoqIDE, without signing it -make PRIVATEBINARIES=$APP -j $NJOBS -l2 $APP +make PRIVATEBINARIES="$APP" -j "$NJOBS" -l2 "$APP" # Add Coq to the .app file -make OLDROOT=$OUTDIR COQINSTALLPREFIX=$APP/Contents/Resources/ install-coq install-ide-toploop +make OLDROOT="$OUTDIR" COQINSTALLPREFIX="$APP/Contents/Resources/" install-coq install-ide-toploop # Create the dmg bundle -mkdir -p $DMGDIR -ln -sf /Applications $DMGDIR/Applications -cp -r $APP $DMGDIR +mkdir -p "$DMGDIR" +ln -sf /Applications "$DMGDIR/Applications" +cp -r "$APP" "$DMGDIR" mkdir -p _build # Temporary countermeasure to hdiutil error 5341 # head -c9703424 /dev/urandom > $DMGDIR/.padding -hdiutil create -imagekey zlib-level=9 -volname coq-$VERSION-installer-macos -srcfolder $DMGDIR -ov -format UDZO _build/coq-$VERSION-installer-macos.dmg +hdiutil create -imagekey zlib-level=9 -volname "coq-$VERSION-installer-macos" -srcfolder "$DMGDIR" -ov -format UDZO "_build/coq-$VERSION-installer-macos.dmg" diff --git a/dev/build/windows/configure_profile.sh b/dev/build/windows/configure_profile.sh index 16c972e80..7e606b554 100644 --- a/dev/build/windows/configure_profile.sh +++ b/dev/build/windows/configure_profile.sh @@ -14,30 +14,30 @@ rcfile=~/.bash_profile donefile=~/.bash_profile.upated +# to learn about `exec >> $file`, see https://www.tldp.org/LDP/abs/html/x17974.html +exec >> $rcfile + if [ ! -f $donefile ] ; then - echo >> $rcfile - - if [ "$1" != "" -a "$1" != " " ]; then - echo export http_proxy="http://$1" >> $rcfile - echo export https_proxy="http://$1" >> $rcfile - echo export ftp_proxy="http://$1" >> $rcfile + if [ "$1" != "" ] && [ "$1" != " " ]; then + echo export http_proxy="http://$1" + echo export https_proxy="http://$1" + echo export ftp_proxy="http://$1" fi - - mkdir -p $RESULT_INSTALLDIR_CFMT/bin + + mkdir -p "$RESULT_INSTALLDIR_CFMT/bin" # A tightly controlled path helps to avoid issues # Note: the order is important: first have the cygwin binaries, then the mingw binaries in the path! # Note: /bin is mounted at /usr/bin and /lib at /usr/lib and it is common to use /usr/bin in PATH # See cat /proc/mounts - echo "export PATH=/usr/local/bin:/usr/bin:$RESULT_INSTALLDIR_CFMT/bin:/usr/$TARGET_ARCH/sys-root/mingw/bin:/cygdrive/c/Windows/system32:/cygdrive/c/Windows" >> $rcfile + echo "export PATH=/usr/local/bin:/usr/bin:$RESULT_INSTALLDIR_CFMT/bin:/usr/$TARGET_ARCH/sys-root/mingw/bin:/cygdrive/c/Windows/system32:/cygdrive/c/Windows" # find and xargs complain if the environment is larger than (I think) 8k. # ORIGINAL_PATH (set by cygwin) can be a few k and exceed the limit - echo unset ORIGINAL_PATH >> $rcfile - + echo unset ORIGINAL_PATH # Other installations of OCaml will mess up things - echo unset OCAMLLIB >> $rcfile + echo unset OCAMLLIB touch $donefile fi diff --git a/dev/build/windows/difftar-folder.sh b/dev/build/windows/difftar-folder.sh index cbcf14ec2..3bba451ec 100644 --- a/dev/build/windows/difftar-folder.sh +++ b/dev/build/windows/difftar-folder.sh @@ -42,7 +42,7 @@ fi if [ "$strip" -gt 0 ] ; then # Get the path/name of the first file from teh tar and extract the first $strip path components # This assumes that the first file in the tar file has at least $strip many path components - prefix=$(tar -t -f $tarfile | head -1 | cut -d / -f -$strip)/ + prefix=$(tar -t -f "$tarfile" | head -1 | cut -d / -f -$strip)/ else prefix= fi @@ -60,13 +60,13 @@ mkdir -p "$empty" # Print information (this is ignored by patch) -echo diff/patch file created on $(date) with: -echo difftar-folder.sh $@ -echo TARFILE= $tarfile -echo FOLDER= $folder -echo TARSTRIP= $strip -echo TARPREFIX= $prefix -echo ORIGFOLDER= $orig +echo diff/patch file created on "$(date)" with: +echo difftar-folder.sh "$@" +echo TARFILE= "$tarfile" +echo FOLDER= "$folder" +echo TARSTRIP= "$strip" +echo TARPREFIX= "$prefix" +echo ORIGFOLDER= "$orig" # Make sure tar uses english output (for Mod time differs) export LC_ALL=C @@ -76,14 +76,14 @@ tar --diff -a -f "$tarfile" --strip $strip --directory "$folder" | grep "Mod tim # Substitute ': Mod time differs' with nothing file=${file/: Mod time differs/} # Check if file exists - if [ -f "$folder/$file" ] ; then + if [ -f "$folder/$file" ] ; then # Extract original file tar -x -a -f "$tarfile" --strip $strip --directory "$orig" "$prefix$file" # Compute diff - diff -u "$orig/$file" "$folder/$file" + diff -u "$orig/$file" "$folder/$file" fi done if [ -d "$new" ] ; then - diff -u -r --unidirectional-new-file $empty $new + diff -u -r --unidirectional-new-file "$empty" "$new" fi diff --git a/dev/build/windows/makecoq_mingw.sh b/dev/build/windows/makecoq_mingw.sh index 918900ccb..508dcf5fb 100644 --- a/dev/build/windows/makecoq_mingw.sh +++ b/dev/build/windows/makecoq_mingw.sh @@ -67,7 +67,7 @@ RMDIR_BEFORE_BUILD=1 ###################### ARCHITECTURES ##################### # The OS on which the build of the tool/lib runs -BUILD=`gcc -dumpmachine` +BUILD=$(gcc -dumpmachine) # The OS on which the tool runs # "`find /bin -name "*mingw32-gcc.exe"`" -dumpmachine @@ -132,38 +132,38 @@ CYGWIN_REPO_FOLDER=${CYGWIN_REPO_FOLDER//\//%2f} # Copy files cp "$CYGWIN_LOCAL_CACHE_WFMT/$CYGWIN_REPO_FOLDER/$CYGWINARCH/setup.ini" $TARBALLS cp /etc/setup/installed.db $TARBALLS - + ###################### LOGGING ##################### # The folder which receives log files mkdir -p buildlogs -LOGS=`pwd`/buildlogs +LOGS=$(pwd)/buildlogs # The current log target (first part of the log file name) LOGTARGET=other # Log command output - take log target name from command name (like log1 make => log target is "<module>-make") log1() { - "$@" > $LOGS/$LOGTARGET-$1.log 2> $LOGS/$LOGTARGET-$1.err + "$@" > >(tee "$LOGS/$LOGTARGET-$1.log" | sed -e "s/^/$LOGTARGET-$1.log: /") 2> >(tee "$LOGS/$LOGTARGET-$1.err" | sed -e "s/^/$LOGTARGET-$1.err: /" 1>&2) } # Log command output - take log target name from command name and first argument (like log2 make install => log target is "<module>-make-install") log2() { - "$@" > $LOGS/$LOGTARGET-$1-$2.log 2> $LOGS/$LOGTARGET-$1-$2.err + "$@" > >(tee "$LOGS/$LOGTARGET-$1-$2.log" | sed -e "s/^/$LOGTARGET-$1-$2.log: /") 2> >(tee "$LOGS/$LOGTARGET-$1-$2.err" | sed -e "s/^/$LOGTARGET-$1-$2.err: /" 1>&2) } # Log command output - take log target name from command name and second argument (like log_1_3 ocaml setup.ml -configure => log target is "<module>-ocaml--configure") log_1_3() { - "$@" > $LOGS/$LOGTARGET-$1-$3.log 2> $LOGS/$LOGTARGET-$1-$3.err + "$@" > >(tee "$LOGS/$LOGTARGET-$1-$3.log" | sed -e "s/^/$LOGTARGET-$1-$3.log: /") 2> >(tee "$LOGS/$LOGTARGET-$1-$3.err" | sed -e "s/^/$LOGTARGET-$1-$3.err: /" 1>&2) } # Log command output - log target name is first argument (like logn untar tar xvaf ... => log target is "<module>-untar") logn() { LOGTARGETEX=$1 shift - "$@" > $LOGS/$LOGTARGET-$LOGTARGETEX.log 2> $LOGS/$LOGTARGET-$LOGTARGETEX.err + "$@" > >(tee "$LOGS/$LOGTARGET-$LOGTARGETEX.log" | sed -e "s/^/$LOGTARGET-$LOGTARGETEX.log: /") 2> >(tee "$LOGS/$LOGTARGET-$LOGTARGETEX.err" | sed -e "s/^/$LOGTARGET-$LOGTARGETEX.err: /" 1>&2) } - + ###################### 'UNFIX' SED ##################### # In Cygwin SED used to do CR-LF to LF conversion, but since sed 4.4-1 this was changed @@ -187,7 +187,7 @@ logn() { # - create build folder # - extract source archive # - patch source file if patch exists -# +# # Parameters # $1 file server name including protocol prefix # $2 file name (without extension) @@ -210,68 +210,68 @@ function get_expand_source_tar { else name=$2 fi - + if [ "$#" -ge 6 ] ; then folder=$6 else folder=$name fi - + # Set logging target logtargetold=$LOGTARGET LOGTARGET=$name - + # Get the source archive either from the source cache or online - if [ ! -f $TARBALLS/$name.$3 ] ; then + if [ ! -f "$TARBALLS/$name.$3" ] ; then if [ -f "$SOURCE_LOCAL_CACHE_CFMT/$name.$3" ] ; then - cp "$SOURCE_LOCAL_CACHE_CFMT/$name.$3" $TARBALLS + cp "$SOURCE_LOCAL_CACHE_CFMT/$name.$3" "$TARBALLS" else - wget $1/$2.$3 - if file -i $2.$3 | grep text/html; then - echo Download failed: $1/$2.$3 + wget "$1/$2.$3" + if file -i "$2.$3" | grep text/html; then + echo Download failed: "$1/$2.$3" echo The file wget downloaded is an html file: - cat $2.$3 + cat "$2.$3" exit 1 fi if [ ! "$2.$3" == "$name.$3" ] ; then - mv $2.$3 $name.$3 + mv "$2.$3" "$name.$3" fi - mv $name.$3 $TARBALLS + mv "$name.$3" "$TARBALLS" # Save the source archive in the source cache if [ -d "$SOURCE_LOCAL_CACHE_CFMT" ] ; then - cp $TARBALLS/$name.$3 "$SOURCE_LOCAL_CACHE_CFMT" + cp "$TARBALLS/$name.$3" "$SOURCE_LOCAL_CACHE_CFMT" fi fi fi - + # Remove build directory (clean build) if [ $RMDIR_BEFORE_BUILD -eq 1 ] ; then - rm -f -r $folder + rm -f -r "$folder" fi - + # Create build directory and cd - mkdir -p $folder - cd $folder - + mkdir -p "$folder" + cd "$folder" + # Extract source archive if [ "$3" == "zip" ] ; then - log1 unzip $TARBALLS/$name.$3 + log1 unzip "$TARBALLS/$name.$3" if [ "$strip" == "1" ] ; then # Ok, this is dirty, but it works and it fails if there are name clashes - mv */* . + mv -- */* . else echo "Unzip strip count not supported" return 1 fi else - logn untar tar xvaf $TARBALLS/$name.$3 --strip $strip + logn untar tar xvaf "$TARBALLS/$name.$3" --strip $strip fi - + # Patch if patch file exists - if [ -f $PATCHES/$name.patch ] ; then - log1 patch -p1 -i $PATCHES/$name.patch + if [ -f "$PATCHES/$name.patch" ] ; then + log1 patch -p1 -i "$PATCHES/$name.patch" fi - + # Go back to base folder cd .. @@ -287,7 +287,7 @@ function get_expand_source_tar { # - cd to build folder and extract source archive # - create bin_special subfolder and add it to $PATH # - remember things for build_post -# +# # Parameters # $1 file server name including protocol prefix # $2 file name (without extension) @@ -309,27 +309,27 @@ function build_prep { else name=$2 fi - + # Check if build is already done - if [ ! -f flagfiles/$name.finished ] ; then + if [ ! -f "flagfiles/$name.finished" ] ; then BUILD_PACKAGE_NAME=$name BUILD_OLDPATH=$PATH - BUILD_OLDPWD=`pwd` + BUILD_OLDPWD=$(pwd) LOGTARGET=$name - touch flagfiles/$name.started - - get_expand_source_tar $1 $2 $3 $strip $name - - cd $name - + touch "flagfiles/$name.started" + + get_expand_source_tar "$1" "$2" "$3" "$strip" "$name" + + cd "$name" + # Create a folder and add it to path, where we can put special binaries # The path is restored in build_post mkdir bin_special - PATH=`pwd`/bin_special:$PATH - + PATH=$(pwd)/bin_special:$PATH + return 0 - else + else return 1 fi } @@ -341,9 +341,9 @@ function build_prep { # ------------------------------------------------------------------------------ function build_post { - if [ ! -f flagfiles/$BUILD_PACKAGE_NAME.finished ]; then - cd $BUILD_OLDPWD - touch flagfiles/$BUILD_PACKAGE_NAME.finished + if [ ! -f "flagfiles/$BUILD_PACKAGE_NAME.finished" ]; then + cd "$BUILD_OLDPWD" + touch "flagfiles/$BUILD_PACKAGE_NAME.finished" PATH=$BUILD_OLDPATH LOGTARGET=other fi @@ -366,9 +366,10 @@ function build_post { # ------------------------------------------------------------------------------ function build_conf_make_inst { - if build_prep $1 $2 $3 ; then + if build_prep "$1" "$2" "$3" ; then $4 - logn configure ./configure --build=$BUILD --host=$HOST --target=$TARGET --prefix="$PREFIX" "${@:5}" + logn configure ./configure --build="$BUILD" --host="$HOST" --target="$TARGET" --prefix="$PREFIX" "${@:5}" + # shellcheck disable=SC2086 log1 make $MAKE_OPT log2 make install log2 make clean @@ -387,6 +388,7 @@ function build_conf_make_inst { function install_glob { # Check if any files matching the pattern exist if [ "$(echo $1)" != "$1" ] ; then + # shellcheck disable=SC2086 install -D -t $2 $1 fi } @@ -402,7 +404,7 @@ function install_glob { # ------------------------------------------------------------------------------ function install_rec { - ( cd $1 && find -type f -name "$2" -exec install -D -T $1/{} $3/{} \; ) + ( cd "$1" && find . -type f -name "$2" -exec install -D -T "$1"/{} "$3"/{} \; ) } # ------------------------------------------------------------------------------ @@ -415,7 +417,7 @@ function install_rec { function list_files { if [ ! -e "/build/filelists/$1" ] ; then - ( cd "$PREFIXCOQ" && find -type f | sort > /build/filelists/$1 ) + ( cd "$PREFIXCOQ" && find . -type f | sort > /build/filelists/"$1" ) fi } @@ -443,7 +445,7 @@ function diff_files { # ------------------------------------------------------------------------------ function filter_files { - egrep "$3" "/build/filelists/$2" > "/build/filelists/$1" + grep -E "$3" "/build/filelists/$2" > "/build/filelists/$1" } # ------------------------------------------------------------------------------ @@ -457,7 +459,7 @@ function files_to_nsis { # Split the path in the file list into path and filename and create SetOutPath and File instructions # Note: File /oname cannot be used, because it does not create the paths as SetOutPath does # Note: I didn't check if the redundant SetOutPath instructions have a bad impact on installer size or install time - cat "/build/filelists/$1" | tr '/' '\\' | sed -r 's/^\.(.*)\\([^\\]+)$/SetOutPath $INSTDIR\\\1\nFile ${COQ_SRC_PATH}\\\1\\\2/' > "/build/filelists/$1.nsh" + tr '/' '\\' < "/build/filelists/$1" | sed -r 's/^\.(.*)\\([^\\]+)$/SetOutPath $INSTDIR\\\1\nFile ${COQ_SRC_PATH}\\\1\\\2/' > "/build/filelists/$1.nsh" } @@ -478,19 +480,19 @@ function make_sed { ##### LIBPNG ##### function make_libpng { - build_conf_make_inst http://prdownloads.sourceforge.net/libpng libpng-1.6.18 tar.gz true + build_conf_make_inst http://prdownloads.sourceforge.net/libpng libpng-1.6.34 tar.gz true } ##### PIXMAN ##### function make_pixman { - build_conf_make_inst http://cairographics.org/releases pixman-0.32.8 tar.gz true + build_conf_make_inst http://cairographics.org/releases pixman-0.34.0 tar.gz true } ##### FREETYPE ##### function make_freetype { - build_conf_make_inst http://sourceforge.net/projects/freetype/files/freetype2/2.6.1 freetype-2.6.1 tar.bz2 true + build_conf_make_inst http://sourceforge.net/projects/freetype/files/freetype2/2.9.1 freetype-2.9.1 tar.bz2 true } ##### EXPAT ##### @@ -505,8 +507,8 @@ function make_fontconfig { make_freetype make_expat # CONFIGURE PARAMETERS - # build/install fails without --disable-docs - build_conf_make_inst http://www.freedesktop.org/software/fontconfig/release fontconfig-2.11.94 tar.gz true --disable-docs + # build/install fails without --disable-docs + build_conf_make_inst http://www.freedesktop.org/software/fontconfig/release fontconfig-2.12.93 tar.gz true --disable-docs } ##### ICONV ##### @@ -536,7 +538,7 @@ function make_ncurses { # # CONFIGURE PARAMETERS # --enable-term-driver --enable-sp-funcs is rewuired for mingw (see README.MinGW) - # additional changes + # additional changes # ADD --with-pkg-config # ADD --enable-pc-files # ADD --without-manpages @@ -586,8 +588,7 @@ function make_glib { make_gettext make_libffi make_libpcre - # build_conf_make_inst http://ftp.gnome.org/pub/gnome/sources/glib/2.46 glib-2.46.0 tar.xz true - build_conf_make_inst http://ftp.gnome.org/pub/gnome/sources/glib/2.47 glib-2.47.5 tar.xz true + build_conf_make_inst http://ftp.gnome.org/pub/gnome/sources/glib/2.57 glib-2.57.1 tar.xz true } ##### ATK ##### @@ -595,7 +596,7 @@ function make_glib { function make_atk { make_gettext make_glib - build_conf_make_inst http://ftp.gnome.org/pub/gnome/sources/atk/2.18 atk-2.18.0 tar.xz true + build_conf_make_inst http://ftp.gnome.org/pub/gnome/sources/atk/2.29 atk-2.29.1 tar.xz true } ##### PIXBUF ##### @@ -608,7 +609,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.32 gdk-pixbuf-2.32.1 tar.xz true --with-included-loaders=yes + 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 } ##### CAIRO ##### @@ -619,7 +620,7 @@ function make_cairo { make_glib make_pixman make_fontconfig - build_conf_make_inst http://cairographics.org/releases cairo-1.14.2 tar.xz true + build_conf_make_inst http://cairographics.org/releases rcairo-1.15.13 tar.xz true } ##### PANGO ##### @@ -628,7 +629,7 @@ function make_pango { make_cairo make_glib make_fontconfig - build_conf_make_inst http://ftp.gnome.org/pub/GNOME/sources/pango/1.38 pango-1.38.0 tar.xz true + build_conf_make_inst http://ftp.gnome.org/pub/GNOME/sources/pango/1.42 pango-1.42.1 tar.xz true } ##### GTK2 ##### @@ -645,7 +646,7 @@ function make_gtk2 { make_pango make_gdk-pixbuf make_cairo - build_conf_make_inst http://ftp.gnome.org/pub/gnome/sources/gtk+/2.24 gtk+-2.24.28 tar.xz patch_gtk2 + build_conf_make_inst http://ftp.gnome.org/pub/gnome/sources/gtk+/2.24 gtk+-2.24.32 tar.xz patch_gtk2 fi } @@ -658,11 +659,11 @@ function make_gtk3 { make_gdk-pixbuf make_cairo make_libepoxy - build_conf_make_inst http://ftp.gnome.org/pub/gnome/sources/gtk+/3.16 gtk+-3.16.7 tar.xz true + build_conf_make_inst http://ftp.gnome.org/pub/gnome/sources/gtk+/3.22 gtk+-3.22.30 tar.xz true # make all incl. tests and examples runs through fine - # make install fails with issue with - # + # make install fails with issue with + # # make[5]: Entering directory '/home/soegtrop/GTK/gtk+-3.16.7/demos/gtk-demo' # test -n "" || ../../gtk/gtk-update-icon-cache --ignore-theme-index --force "/usr/x86_64-w64-mingw32/sys-root/mingw/share/icons/hicolor" # gtk-update-icon-cache.exe: Failed to open file /usr/x86_64-w64-mingw32/sys-root/mingw/share/icons/hicolor/.icon-theme.cache : No such file or directory @@ -680,7 +681,8 @@ function make_libxml2 { if build_prep https://git.gnome.org/browse/libxml2/snapshot libxml2-2.9.1 tar.xz ; then # ./autogen.sh --build=$BUILD --host=$HOST --target=$TARGET --prefix="$PREFIX" --disable-shared --without-python # shared library required by gtksourceview - ./autogen.sh --build=$BUILD --host=$HOST --target=$TARGET --prefix="$PREFIX" --without-python + ./autogen.sh --build="$BUILD" --host="$HOST" --target="$TARGET" --prefix="$PREFIX" --without-python + # shellcheck disable=SC2086 log1 make $MAKE_OPT all log2 make install log2 make clean @@ -712,12 +714,12 @@ function make_gtk_sourceview2 { # Install flexdll objects function install_flexdll { - cp flexdll.h /usr/$TARGET_ARCH/sys-root/mingw/include + cp flexdll.h "/usr/$TARGET_ARCH/sys-root/mingw/include" if [ "$TARGET_ARCH" == "i686-w64-mingw32" ]; then - cp flexdll*_mingw.o /usr/$TARGET_ARCH/bin + cp flexdll*_mingw.o "/usr/$TARGET_ARCH/bin" cp flexdll*_mingw.o "$PREFIXOCAML/bin" elif [ "$TARGET_ARCH" == "x86_64-w64-mingw32" ]; then - cp flexdll*_mingw64.o /usr/$TARGET_ARCH/bin + cp flexdll*_mingw64.o "/usr/$TARGET_ARCH/bin" cp flexdll*_mingw64.o "$PREFIXOCAML/bin" else echo "Unknown target architecture" @@ -728,8 +730,8 @@ function install_flexdll { # Install flexlink function install_flexlink { - cp flexlink.exe /usr/$TARGET_ARCH/bin - + cp flexlink.exe "/usr/$TARGET_ARCH/bin" + cp flexlink.exe "$PREFIXOCAML/bin" } @@ -737,7 +739,7 @@ function install_flexlink { # An alternative is to first build an OCaml without shared library support and build flexlink with it function get_flex_dll_link_bin { - if build_prep http://alain.frisch.fr/flexdll flexdll-bin-0.34 zip 1 ; then + if build_prep https://github.com/alainfrisch/flexdll/releases/download/0.37/ flexdll-bin-0.37 zip 1 ; then install_flexdll install_flexlink build_post @@ -747,10 +749,12 @@ function get_flex_dll_link_bin { # Build flexdll and flexlink from sources after building OCaml function make_flex_dll_link { - if build_prep http://alain.frisch.fr/flexdll flexdll-0.34 tar.gz ; then + if build_prep https://github.com/alainfrisch/flexdll/releases/download/0.37/ flexdll-bin-0.37 zip ; then if [ "$TARGET_ARCH" == "i686-w64-mingw32" ]; then + # shellcheck disable=SC2086 log1 make $MAKE_OPT build_mingw flexlink.exe elif [ "$TARGET_ARCH" == "x86_64-w64-mingw32" ]; then + # shellcheck disable=SC2086 log1 make $MAKE_OPT build_mingw64 flexlink.exe else echo "Unknown target architecture" @@ -773,11 +777,11 @@ function make_ln { if [ ! -f flagfiles/myln.finished ] ; then touch flagfiles/myln.started mkdir -p myln - cd myln + ( cd myln cp $PATCHES/ln.c . - $TARGET_ARCH-gcc -DUNICODE -D_UNICODE -DIGNORE_SYMBOLIC -mconsole -o ln.exe ln.c + "$TARGET_ARCH-gcc" -DUNICODE -D_UNICODE -DIGNORE_SYMBOLIC -mconsole -o ln.exe ln.c install -D ln.exe "$PREFIXCOQ/bin/ln.exe" - cd .. + ) touch flagfiles/myln.finished fi } @@ -786,11 +790,10 @@ function make_ln { function make_ocaml { get_flex_dll_link_bin - if build_prep http://caml.inria.fr/pub/distrib/ocaml-4.02 ocaml-4.02.3 tar.gz 1 ; then - # if build_prep http://caml.inria.fr/pub/distrib/ocaml-4.01 ocaml-4.01.0 tar.gz 1 ; then - # See README.win32 - cp config/m-nt.h config/m.h - cp config/s-nt.h config/s.h + if build_prep http://caml.inria.fr/pub/distrib/ocaml-4.06 ocaml-4.06.1 tar.gz 1 ; then + # See README.win32.adoc + cp config/m-nt.h byterun/caml/m.h + cp config/s-nt.h byterun/caml/s.h if [ "$TARGET_ARCH" == "i686-w64-mingw32" ]; then cp config/Makefile.mingw config/Makefile elif [ "$TARGET_ARCH" == "x86_64-w64-mingw32" ]; then @@ -803,14 +806,14 @@ function make_ocaml { # Prefix is fixed in make file - replace it with the real one # TODO: this might not work if PREFIX contains spaces sed -i "s|^PREFIX=.*|PREFIX=$PREFIXOCAML|" config/Makefile - + # We don't want to mess up Coq's directory structure so put the OCaml library in a separate folder # If we refer to the make variable ${PREFIX} below, camlp5 ends up having the wrong path: # D:\bin\coq64_buildtest_abs_ocaml4\bin>ocamlc -where => D:/bin/coq64_buildtest_abs_ocaml4/libocaml # D:\bin\coq64_buildtest_abs_ocaml4\bin>camlp4 -where => ${PREFIX}/libocaml\camlp4 # So we put an explicit path in there sed -i "s|^LIBDIR=.*|LIBDIR=$PREFIXOCAML/libocaml|" config/Makefile - + # Note: ocaml doesn't support -j 8, so don't pass MAKE_OPT # I verified that 4.02.3 still doesn't support parallel build log2 make world -f Makefile.nt @@ -819,16 +822,16 @@ function make_ocaml { log2 make opt.opt -f Makefile.nt log2 make install -f Makefile.nt # TODO log2 make clean -f Makefile.nt Temporarily disabled for ocamlbuild development - + # Move license files and other into into special folder if [ "$INSTALLMODE" == "absolute" ] || [ "$INSTALLMODE" == "relocatable" ]; then mkdir -p "$PREFIXOCAML/license_readme/ocaml" # 4.01 installs these files, 4.02 doesn't. So delete them and copy them from the sources. - rm -f *.txt + rm -f ./*.txt cp LICENSE "$PREFIXOCAML/license_readme/ocaml/License.txt" - cp INSTALL "$PREFIXOCAML/license_readme/ocaml/Install.txt" - cp README "$PREFIXOCAML/license_readme/ocaml/ReadMe.txt" - cp README.win32 "$PREFIXOCAML/license_readme/ocaml/ReadMeWin32.txt" + cp INSTALL.adoc "$PREFIXOCAML/license_readme/ocaml/Install.txt" + cp README.adoc "$PREFIXOCAML/license_readme/ocaml/ReadMe.txt" + cp README.win32.adoc "$PREFIXOCAML/license_readme/ocaml/ReadMeWin32.txt" cp VERSION "$PREFIXOCAML/license_readme/ocaml/Version.txt" cp Changes "$PREFIXOCAML/license_readme/ocaml/Changes.txt" fi @@ -842,23 +845,37 @@ function make_ocaml { function make_ocaml_tools { make_findlib - make_menhir + # make_menhir make_camlp5 } ##### OCAML EXTRA LIBRARIES ##### function make_ocaml_libs { + make_num make_findlib make_lablgtk - make_stdint + # make_stdint +} + +##### Ocaml num library ##### +function make_num { + make_ocaml + # We need this commit due to windows fixed, IMHO this is better than patching v1.1. + if build_prep https://github.com/ocaml/num/archive/ 7dd5e935aaa2b902585b3b2d0e55ad9b2442fff0 zip 1 num-1.1-7d; then + log2 make all + # log2 make test + log2 make install + log2 make clean + build_post + fi } ##### FINDLIB Ocaml library manager ##### function make_findlib { make_ocaml - if build_prep https://opam.ocaml.org/archives ocamlfind.1.5.6+opam tar.gz 1 ; then + if build_prep https://opam.ocaml.org/archives ocamlfind.1.8.0+opam tar.gz 1 ; then logn configure ./configure -bindir "$PREFIXOCAML\\bin" -sitelib "$PREFIXOCAML\\libocaml\\site-lib" -config "$PREFIXOCAML\\etc\\findlib.conf" # Note: findlib doesn't support -j 8, so don't pass MAKE_OPT log2 make all @@ -895,7 +912,7 @@ function make_camlp4 { if ! command camlp4 ; then make_ocaml make_findlib - if build_prep https://github.com/ocaml/camlp4/archive 4.02+6 tar.gz 1 camlp4-4.02+6 ; then + 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 @@ -912,10 +929,12 @@ function make_camlp4 { function make_camlp5 { make_ocaml make_findlib - if build_prep http://camlp5.gforge.inria.fr/distrib/src camlp5-6.14 tgz 1 ; then - logn configure ./configure + + if build_prep https://github.com/camlp5/camlp5/archive rel705 tar.gz 1 camlp5-rel705; 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 @@ -938,21 +957,36 @@ function make_camlp5 { function make_lablgtk { make_ocaml make_findlib - make_camlp4 # required by lablgtk-2.18.3 and lablgtk-2.18.5 + # 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/1479 lablgtk-2.18.3 tar.gz 1 ; then + 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.exe bin_special/pkg-config.exe - logn configure ./configure --build=$BUILD --host=$HOST --target=$TARGET --prefix="$PREFIXOCAML" - + cp "/bin/$TARGET_ARCH-pkg-config.exe" bin_special/pkg-config.exe + logn configure ./configure --build="$BUILD" --host="$HOST" --target="$TARGET" --prefix="$PREFIXOCAML" + # lablgtk shows occasional errors with -j, so don't pass $MAKE_OPT - - # See https://sympa.inria.fr/sympa/arc/caml-list/2015-10/msg00204.html for the make || true + strip - logn make-world-pre make world || true - $TARGET_ARCH-strip.exe --strip-unneeded src/dlllablgtk2.dll - + + # 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 + log2 make install log2 make clean build_post @@ -982,7 +1016,7 @@ function make_stdint { function copy_coq_dll { if [ "$INSTALLMODE" == "absolute" ] || [ "$INSTALLMODE" == "relocatable" ]; then - cp /usr/${ARCH}-w64-mingw32/sys-root/mingw/bin/$1 "$PREFIXCOQ/bin/$1" + cp "/usr/${ARCH}-w64-mingw32/sys-root/mingw/bin/$1" "$PREFIXCOQ/bin/$1" fi } @@ -998,7 +1032,7 @@ function copy_coq_dlls { # 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. # 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 @@ -1022,7 +1056,7 @@ function copy_coq_dlls { copy_coq_dll LIBXML2-2.DLL copy_coq_dll ZLIB1.DLL - # Depends on if GTK is built from sources + # Depends on if GTK is built from sources if [ "$GTK_FROM_SOURCES" == "Y" ]; then copy_coq_dll libiconv-2.dll else @@ -1040,21 +1074,21 @@ function copy_coq_dlls { i686) copy_coq_dll LIBGCC_S_SJLJ-1.DLL ;; *) false ;; esac - + # Win pthread version change copy_coq_dll LIBWINPTHREAD-1.DLL } function copy_coq_objects { # copy objects only from folders which exist in the target lib directory - find . -type d | while read FOLDER ; do + find . -type d | while read -r FOLDER ; do if [ -e "$PREFIXCOQ/lib/$FOLDER" ] ; then - install_glob $FOLDER/'*.cmxa' "$PREFIXCOQ/lib/$FOLDER" - install_glob $FOLDER/'*.cmi' "$PREFIXCOQ/lib/$FOLDER" - install_glob $FOLDER/'*.cma' "$PREFIXCOQ/lib/$FOLDER" - install_glob $FOLDER/'*.cmo' "$PREFIXCOQ/lib/$FOLDER" - install_glob $FOLDER/'*.a' "$PREFIXCOQ/lib/$FOLDER" - install_glob $FOLDER/'*.o' "$PREFIXCOQ/lib/$FOLDER" + install_glob "$FOLDER"/'*.cmxa' "$PREFIXCOQ/lib/$FOLDER" + install_glob "$FOLDER"/'*.cmi' "$PREFIXCOQ/lib/$FOLDER" + install_glob "$FOLDER"/'*.cma' "$PREFIXCOQ/lib/$FOLDER" + install_glob "$FOLDER"/'*.cmo' "$PREFIXCOQ/lib/$FOLDER" + install_glob "$FOLDER"/'*.a' "$PREFIXCOQ/lib/$FOLDER" + install_glob "$FOLDER"/'*.o' "$PREFIXCOQ/lib/$FOLDER" fi done } @@ -1070,7 +1104,7 @@ function copq_coq_gtk { 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_rec "$PREFIX/share/themes/" '*' "$PREFIXCOQ/share/themes" - + # This below item look like a bug in make install if [ -d "$PREFIXCOQ/share/coq/" ] ; then COQSHARE="$PREFIXCOQ/share/coq/" @@ -1109,17 +1143,19 @@ function copy_coq_license { function make_coq { make_ocaml - make_lablgtk + make_num + make_findlib make_camlp5 + make_lablgtk if case $COQ_VERSION in # e.g. git-v8.6 => download from https://github.com/coq/coq/archive/v8.6.zip # e.g. git-trunk => download from https://github.com/coq/coq/archive/trunk.zip - git-*) + git-*) COQ_BUILD_PATH=/build/coq-${COQ_VERSION} - build_prep https://github.com/coq/coq/archive ${COQ_VERSION##git-} zip 1 coq-${COQ_VERSION} + build_prep https://github.com/coq/coq/archive "${COQ_VERSION##git-}" zip 1 "coq-${COQ_VERSION}" ;; - + # e.g. /cygdrive/d/coqgit /*) # Todo: --exclude-vcs-ignores doesn't work because tools/coqdoc/coqdoc.sty is excluded => fix .gitignore @@ -1128,11 +1164,11 @@ function make_coq { tar -zcf $TARBALLS/coq-local.tar.gz --exclude-vcs -C "${COQ_VERSION%/*}" "${COQ_VERSION##*/}" build_prep NEVER-DOWNLOADED coq-local tar.gz ;; - + # e.g. 8.6 => https://coq.inria.fr/distrib/8.6/files/coq-8.6.tar.gz *) COQ_BUILD_PATH=/build/coq-$COQ_VERSION - build_prep https://coq.inria.fr/distrib/V$COQ_VERSION/files coq-$COQ_VERSION tar.gz + build_prep "https://coq.inria.fr/distrib/V$COQ_VERSION/files" "coq-$COQ_VERSION" tar.gz ;; esac then @@ -1146,16 +1182,17 @@ function make_coq { fi # The windows resource compiler binary name is hard coded - sed -i "s/i686-w64-mingw32-windres/$TARGET_ARCH-windres/" Makefile.build + sed -i "s/i686-w64-mingw32-windres/$TARGET_ARCH-windres/" Makefile.build sed -i "s/i686-w64-mingw32-windres/$TARGET_ARCH-windres/" Makefile.ide || true # 8.4x doesn't support parallel make if [[ $COQ_VERSION == 8.4* ]] ; then log1 make else + # shellcheck disable=SC2086 make $MAKE_OPT fi - + if [ "$INSTALLMODE" == "relocatable" ]; then ./configure -with-doc no -prefix "$PREFIXCOQ" -libdir "$PREFIXCOQ/lib" -mandir "$PREFIXCOQ/man" fi @@ -1165,7 +1202,7 @@ function make_coq { if [ "$INSTALLOCAML" == "Y" ]; then copy_coq_objects fi - + copq_coq_gtk copy_coq_license @@ -1173,7 +1210,7 @@ function make_coq { # 1.) find | xargs fails on cygwin, can be fixed by sed -i 's|\| xargs rm -f|-exec rm -fv \{\} \+|' Makefile # 2.) clean of test suites fails with "cannot run complexity tests (no bogomips found)" # make clean - + build_post fi } @@ -1184,7 +1221,7 @@ function make_mingw_make { if build_prep http://ftp.gnu.org/gnu/make make-4.2 tar.bz2 ; then # The config.h.win32 file is fine - don't edit it # We need to copy the mingw gcc here as "gcc" - then the batch file will use it - cp /usr/bin/${ARCH}-w64-mingw32-gcc-6.4.0.exe ./gcc.exe + cp "/usr/bin/${ARCH}-w64-mingw32-gcc-6.4.0.exe" ./gcc.exe # By some magic cygwin bash can run batch files logn build ./build_w32.bat gcc # Copy make to Coq folder @@ -1197,7 +1234,8 @@ function make_mingw_make { function make_binutils { if build_prep http://ftp.gnu.org/gnu/binutils binutils-2.27 tar.gz ; then - logn configure ./configure --build=$BUILD --host=$HOST --target=$TARGET --prefix="$PREFIXCOQ" --program-prefix=$TARGET- + logn configure ./configure --build="$BUILD" --host="$HOST" --target="$TARGET" --prefix="$PREFIXCOQ" --program-prefix="$TARGET-" + # shellcheck disable=SC2086 log1 make $MAKE_OPT log2 make install # log2 make clean @@ -1223,12 +1261,13 @@ function make_gcc { mkdir -p "$PREFIXCOQ/mingw/include" # See https://gcc.gnu.org/install/configure.html - logn configure ./configure --build=$BUILD --host=$HOST --target=$TARGET \ - --prefix="$PREFIXCOQ" --program-prefix=$TARGET- --disable-win32-registry --with-sysroot="$PREFIXCOQ" \ + logn configure ./configure --build="$BUILD" --host="$HOST" --target="$TARGET" \ + --prefix="$PREFIXCOQ" --program-prefix="$TARGET-" --disable-win32-registry --with-sysroot="$PREFIXCOQ" \ --enable-languages=c --disable-nls \ --disable-libsanitizer --disable-libssp --disable-libquadmath --disable-libgomp --disable-libvtv --disable-lto # --disable-decimal-float seems to be required # --with-sysroot="$PREFIX" results in configure error that this is not an absolute path + # shellcheck disable=SC2086 log1 make $MAKE_OPT log2 make install # log2 make clean @@ -1256,21 +1295,22 @@ function get_cygwin_mingw_sources { # Take the 2nd field of the last line => ${SOURCE} = x86_64/release/mingw64-x86_64-gcc/mingw64-x86_64-gcc-5.4.0-2-src.tar.xz # Remove that path part => ${SOURCEFILE} = mingw64-x86_64-gcc-5.4.0-2-src.tar.xz - grep "mingw" /etc/setup/installed.db | sed 's/\.tar\.bz2 [0-1]$//' | sed 's/ /\//' | while read ARCHIVE ; do + grep "mingw" /etc/setup/installed.db | sed 's/\.tar\.bz2 [0-1]$//' | sed 's/ /\//' | while read -r ARCHIVE ; do local ARCHIVEESC=${ARCHIVE//+/\\+} - local SOURCE=`egrep -A 1 "install: ($CYGWINARCH|noarch)/release/[-+_/a-z0-9]*$ARCHIVEESC" $TARBALLS/setup.ini | tail -1 | cut -d " " -f 2` + local SOURCE + SOURCE=$(grep -E -A 1 "install: ($CYGWINARCH|noarch)/release/[-+_/a-z0-9]*$ARCHIVEESC" $TARBALLS/setup.ini | tail -1 | cut -d " " -f 2) local SOURCEFILE=${SOURCE##*/} # Get the source file (either from the source cache or online) - if [ ! -f $TARBALLS/$SOURCEFILE ] ; then + if [ ! -f "$TARBALLS/$SOURCEFILE" ] ; then if [ -f "$SOURCE_LOCAL_CACHE_CFMT/$SOURCEFILE" ] ; then cp "$SOURCE_LOCAL_CACHE_CFMT/$SOURCEFILE" $TARBALLS else wget "$CYGWIN_REPOSITORY/$SOURCE" - mv $SOURCEFILE $TARBALLS + mv "$SOURCEFILE" "$TARBALLS" # Save the source archive in the source cache if [ -d "$SOURCE_LOCAL_CACHE_CFMT" ] ; then - cp $TARBALLS/$SOURCEFILE "$SOURCE_LOCAL_CACHE_CFMT" + cp "$TARBALLS/$SOURCEFILE" "$SOURCE_LOCAL_CACHE_CFMT" fi fi fi @@ -1291,19 +1331,19 @@ function make_coq_installer { # ocaml: ocaml + menhir + camlp5 + findlib # ocaml_coq: as above + coq # ocaml_coq_addons: as above + lib/user-contrib/* - + # Create coq file list as ocaml_coq / ocaml diff_files coq ocaml_coq ocaml - + # Filter out object files - filter_files coq_objects coq '\.(cmxa|cmi|cma|cmo|a|o)$' - + filter_files coq_objects coq '\.(cmxa|cmi|cma|cmo|a|o)$' + # Filter out plugin object files filter_files coq_objects_plugins coq_objects '/lib/plugins/.*\.(cmxa|cmi|cma|cmo|a|o)$' - + # Coq objects objects required for plugin development = coq objects except those for pre installed plugins diff_files coq_plugindev coq_objects coq_objects_plugins - + # Addons (TODO: including objects that could go to the plugindev thing, but # then one would have to make that package depend on this one, so not # implemented yet) @@ -1311,27 +1351,27 @@ function make_coq_installer { # Coq files, except objects needed only for plugin development diff_files coq_base coq coq_plugindev - + # Convert section files to NSIS format files_to_nsis coq_base files_to_nsis coq_addons files_to_nsis coq_plugindev files_to_nsis ocaml - + # Get and extract NSIS Binaries if build_prep http://downloads.sourceforge.net/project/nsis/NSIS%202/2.51 nsis-2.51 zip ; then - NSIS=`pwd`/makensis.exe + NSIS=$(pwd)/makensis.exe chmod u+x "$NSIS" # Change to Coq folder - cd $COQ_BUILD_PATH + cd "$COQ_BUILD_PATH" # Copy patched nsi file cp ../patches/coq_new.nsi dev/nsis cp ../patches/StrRep.nsh dev/nsis cp ../patches/ReplaceInFile.nsh dev/nsis - VERSION=`grep '^VERSION=' config/Makefile | cut -d = -f 2 | tr -d '\r'` + VERSION=$(grep '^VERSION=' config/Makefile | cut -d = -f 2 | tr -d '\r') cd dev/nsis - logn nsis-installer "$NSIS" -DVERSION=$VERSION -DARCH=$ARCH -DCOQ_SRC_PATH="$PREFIXCOQ" -DCOQ_ICON=..\\..\\ide\\coq.ico -DCOQ_ADDONS="$COQ_ADDONS" coq_new.nsi - + logn nsis-installer "$NSIS" -DVERSION="$VERSION" -DARCH="$ARCH" -DCOQ_SRC_PATH="$PREFIXCOQ" -DCOQ_ICON=..\\..\\ide\\coq.ico -DCOQ_ADDONS="$COQ_ADDONS" coq_new.nsi + build_post fi } @@ -1350,7 +1390,7 @@ function make_addon_bignums { function make_addons { for addon in $COQ_ADDONS; do - make_addon_$addon + "make_addon_$addon" done } @@ -1378,4 +1418,3 @@ list_files ocaml_coq_addons if [ "$MAKEINSTALLER" == "Y" ] ; then make_coq_installer fi - diff --git a/dev/build/windows/patches_coq/lablgtk-2.18.3.patch b/dev/build/windows/patches_coq/lablgtk-2.18.3.patch index 0691c1fc8..23c303135 100644 --- a/dev/build/windows/patches_coq/lablgtk-2.18.3.patch +++ b/dev/build/windows/patches_coq/lablgtk-2.18.3.patch @@ -1,6 +1,12 @@ -diff -u -r lablgtk-2.18.3/configure lablgtk-2.18.3.patched/configure ---- lablgtk-2.18.3/configure 2014-10-29 08:51:05.000000000 +0100 -+++ lablgtk-2.18.3.patched/configure 2015-10-29 08:58:08.543985500 +0100 +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 +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 @@ -10,10 +16,8 @@ diff -u -r lablgtk-2.18.3/configure lablgtk-2.18.3.patched/configure { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: Ignoring ocamlfind" >&5 $as_echo "$as_me: WARNING: Ignoring ocamlfind" >&2;} OCAMLFIND=no - -diff -u -r lablgtk-2.18.3/src/glib.mli lablgtk-2.18.3.patched/src/glib.mli ---- lablgtk-2.18.3/src/glib.mli 2014-10-29 08:51:06.000000000 +0100 -+++ lablgtk-2.18.3.patched/src/glib.mli 2016-01-25 09:50:59.884715200 +0100 +--- 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 @@ -22,10 +26,8 @@ diff -u -r lablgtk-2.18.3/src/glib.mli lablgtk-2.18.3.patched/src/glib.mli val add_watch : cond:condition list -> callback:(condition list -> bool) -> ?prio:int -> channel -> id val remove : id -> unit - -diff -u -r lablgtk-2.18.3/src/glib.ml lablgtk-2.18.3.patched/src/glib.ml ---- lablgtk-2.18.3/src/glib.ml 2014-10-29 08:51:06.000000000 +0100 -+++ lablgtk-2.18.3.patched/src/glib.ml 2016-01-25 09:50:59.891715900 +0100 +--- 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 @@ -72,6 +72,8 @@ type id external channel_of_descr : Unix.file_descr -> channel @@ -35,10 +37,22 @@ diff -u -r lablgtk-2.18.3/src/glib.ml lablgtk-2.18.3.patched/src/glib.ml external remove : id -> unit = "ml_g_source_remove" external add_watch : cond:condition list -> callback:(condition list -> bool) -> ?prio:int -> channel -> id - -diff -u -r lablgtk-2.18.3/src/ml_glib.c lablgtk-2.18.3.patched/src/ml_glib.c ---- lablgtk-2.18.3/src/ml_glib.c 2014-10-29 08:51:06.000000000 +0100 -+++ lablgtk-2.18.3.patched/src/ml_glib.c 2016-01-25 09:50:59.898716600 +0100 +--- 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 @@ -25,6 +25,8 @@ #include <string.h> #include <locale.h> diff --git a/dev/build/windows/patches_coq/lablgtk-2.18.6.patch b/dev/build/windows/patches_coq/lablgtk-2.18.6.patch new file mode 100644 index 000000000..23c303135 --- /dev/null +++ b/dev/build/windows/patches_coq/lablgtk-2.18.6.patch @@ -0,0 +1,101 @@ +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 +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 +@@ -72,6 +72,8 @@ + type id + external channel_of_descr : Unix.file_descr -> channel + = "ml_g_io_channel_unix_new" ++ external channel_of_descr_socket : Unix.file_descr -> channel ++ = "ml_g_io_channel_unix_new_socket" + 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 +@@ -25,6 +25,8 @@ + #include <string.h> + #include <locale.h> + #ifdef _WIN32 ++/* to kill a #warning: include winsock2.h before windows.h */ ++#include <winsock2.h> + #include "win32.h" + #include <wtypes.h> + #include <io.h> +@@ -38,6 +40,11 @@ + #include <caml/callback.h> + #include <caml/threads.h> + ++#ifdef _WIN32 ++/* for Socket_val */ ++#include <caml/unixsupport.h> ++#endif ++ + #include "wrappers.h" + #include "ml_glib.h" + #include "glib_tags.h" +@@ -325,14 +332,23 @@ + + #ifndef _WIN32 + ML_1 (g_io_channel_unix_new, Int_val, Val_GIOChannel_noref) ++CAMLprim value ml_g_io_channel_unix_new_socket (value arg1) { ++ return Val_GIOChannel_noref (g_io_channel_unix_new (Int_val (arg1))); ++} + + #else + CAMLprim value ml_g_io_channel_unix_new(value wh) + { + return Val_GIOChannel_noref +- (g_io_channel_unix_new ++ (g_io_channel_win32_new_fd + (_open_osfhandle((long)*(HANDLE*)Data_custom_val(wh), O_BINARY))); + } ++ ++CAMLprim value ml_g_io_channel_unix_new_socket(value wh) ++{ ++ return Val_GIOChannel_noref ++ (g_io_channel_win32_new_socket(Socket_val(wh))); ++} + #endif + + static gboolean ml_g_io_channel_watch(GIOChannel *s, GIOCondition c, diff --git a/dev/checker.dbg b/dev/checker.dbg new file mode 100644 index 000000000..b2323b617 --- /dev/null +++ b/dev/checker.dbg @@ -0,0 +1,6 @@ +load_printer threads.cma +load_printer str.cma +load_printer clib.cma +load_printer dynlink.cma +load_printer lib.cma +load_printer check.cma diff --git a/dev/checker_db b/dev/checker_db new file mode 100644 index 000000000..327e636c5 --- /dev/null +++ b/dev/checker_db @@ -0,0 +1,39 @@ +source checker.dbg + +load_printer checker_printers.cmo + +install_printer Checker_printers.pP + +install_printer Checker_printers.ppfuture + +install_printer Checker_printers.ppid +install_printer Checker_printers.pplab +install_printer Checker_printers.ppmbid +install_printer Checker_printers.ppdir +install_printer Checker_printers.ppmp +install_printer Checker_printers.ppcon +install_printer Checker_printers.ppproj +install_printer Checker_printers.ppkn +install_printer Checker_printers.ppmind +install_printer Checker_printers.ppind + +install_printer Checker_printers.ppbigint + +install_printer Checker_printers.ppintset +install_printer Checker_printers.ppidset + +install_printer Checker_printers.ppidmapgen + +install_printer Checker_printers.ppididmap + +install_printer Checker_printers.ppuni +install_printer Checker_printers.ppuni_level +install_printer Checker_printers.ppuniverse_set +install_printer Checker_printers.ppuniverse_instance +install_printer Checker_printers.ppauniverse_context +install_printer Checker_printers.ppuniverse_context +install_printer Checker_printers.ppconstraints +install_printer Checker_printers.ppuniverse_context_future +install_printer Checker_printers.ppuniverses + +install_printer Checker_printers.pploc diff --git a/dev/checker_printers.ml b/dev/checker_printers.ml new file mode 100644 index 000000000..40ae1a7b0 --- /dev/null +++ b/dev/checker_printers.ml @@ -0,0 +1,73 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +open Pp +open Names +open Univ + +let pp x = Pp.pp_with Format.std_formatter x + +(** Future printer *) + +let ppfuture kx = pp (Future.print (fun _ -> str "_") kx) + +(* name printers *) +let ppid id = pp (Id.print id) +let pplab l = pp (Label.print l) +let ppmbid mbid = pp (str (MBId.debug_to_string mbid)) +let ppdir dir = pp (DirPath.print dir) +let ppmp mp = pp(str (ModPath.debug_to_string mp)) +let ppcon con = pp(Constant.debug_print con) +let ppproj con = pp(Constant.debug_print (Projection.constant con)) +let ppkn kn = pp(str (KerName.to_string kn)) +let ppmind kn = pp(MutInd.debug_print kn) +let ppind (kn,i) = pp(MutInd.debug_print kn ++ str"," ++int i) + +(* term printers *) +let ppbigint n = pp (str (Bigint.to_string n));; + +let prset pr l = str "[" ++ hov 0 (prlist_with_sep spc pr l) ++ str "]" +let ppintset l = pp (prset int (Int.Set.elements l)) +let ppidset l = pp (prset Id.print (Id.Set.elements l)) + +let prset' pr l = str "[" ++ hov 0 (prlist_with_sep pr_comma pr l) ++ str "]" + +let pridmap pr l = + let pr (id,b) = Id.print id ++ str "=>" ++ pr id b in + prset' pr (Id.Map.fold (fun a b l -> (a,b)::l) l []) +let ppidmap pr l = pp (pridmap pr l) + +let pridmapgen l = + let dom = Id.Set.elements (Id.Map.domain l) in + if dom = [] then str "[]" else + str "[domain= " ++ hov 0 (prlist_with_sep spc Id.print dom) ++ str "]" +let ppidmapgen l = pp (pridmapgen l) + +let prididmap = pridmap (fun _ -> Id.print) +let ppididmap = ppidmap (fun _ -> Id.print) + +let pP s = pp (hov 0 s) + +(* proof printers *) +let ppuni u = pp(Universe.pr u) +let ppuni_level u = pp (Level.pr u) + +let ppuniverse_set l = pp (LSet.pr l) +let ppuniverse_instance l = pp (Instance.pr l) +let ppauniverse_context l = pp (AUContext.pr Level.pr l) +let ppuniverse_context l = pp (pr_universe_context Level.pr l) +let ppconstraints c = pp (pr_constraints Level.pr c) +let ppuniverse_context_future c = + let ctx = Future.force c in + ppuniverse_context ctx +let ppuniverses u = pp (Univ.pr_universes u) + +let pploc x = let (l,r) = Loc.unloc x in + print_string"(";print_int l;print_string",";print_int r;print_string")" diff --git a/dev/checker_printers.mli b/dev/checker_printers.mli new file mode 100644 index 000000000..2f9500c5c --- /dev/null +++ b/dev/checker_printers.mli @@ -0,0 +1,54 @@ +(************************************************************************) +(* * 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) *) +(************************************************************************) + +(** Printers for the ocaml toplevel. *) + +val pp : Pp.t -> unit +val pP : Pp.t -> unit (* with surrounding box *) + +val ppfuture : 'a Future.computation -> unit + +val ppid : Names.Id.t -> unit +val pplab : Names.Label.t -> unit +val ppmbid : Names.MBId.t -> unit +val ppdir : Names.DirPath.t -> unit +val ppmp : Names.ModPath.t -> unit +val ppcon : Names.Constant.t -> unit +val ppproj : Names.Projection.t -> unit +val ppkn : Names.KerName.t -> unit +val ppmind : Names.MutInd.t -> unit +val ppind : Names.inductive -> unit + +val ppbigint : Bigint.bigint -> unit + +val ppintset : Int.Set.t -> unit +val ppidset : Names.Id.Set.t -> unit + +val pridmap : (Names.Id.Map.key -> 'a -> Pp.t) -> 'a Names.Id.Map.t -> Pp.t +val ppidmap : (Names.Id.Map.key -> 'a -> Pp.t) -> 'a Names.Id.Map.t -> unit + +val pridmapgen : 'a Names.Id.Map.t -> Pp.t +val ppidmapgen : 'a Names.Id.Map.t -> unit + +val prididmap : Names.Id.t Names.Id.Map.t -> Pp.t +val ppididmap : Names.Id.t Names.Id.Map.t -> unit + +(* Universes *) +val ppuni : Univ.Universe.t -> unit +val ppuni_level : Univ.Level.t -> unit (* raw *) +val ppuniverse_set : Univ.LSet.t -> unit +val ppuniverse_instance : Univ.Instance.t -> unit +val ppauniverse_context : Univ.AUContext.t -> unit +val ppuniverse_context : Univ.UContext.t -> unit +val ppconstraints : Univ.Constraint.t -> unit +val ppuniverse_context_future : Univ.UContext.t Future.computation -> unit +val ppuniverses : Univ.universes -> unit + +val pploc : Loc.t -> unit diff --git a/dev/ci/README.md b/dev/ci/README.md index bb13587e9..665b3768a 100644 --- a/dev/ci/README.md +++ b/dev/ci/README.md @@ -36,9 +36,8 @@ On the condition that: - You do not push, to the branches that we test, commits that haven't been first tested to compile with the corresponding branch(es) of Coq. -- Your development compiles in less than 35 minutes with just two threads. - If this is not the case, consider adding a "lite" target that compiles just - part of it. +- You maintain a reasonable build time for your development, or you provide + a "lite" target that we can use. In case you forget to comply with these last three conditions, we would reach out to you and give you a 30-day grace period during which your development @@ -48,15 +47,16 @@ CI. ### Add your development by submitting a pull request -Add a new `ci-mydev.sh` script to [`dev/ci`](/dev/ci) (have a look at -[`ci-coq-dpdgraph.sh`](/dev/ci/ci-coq-dpdgraph.sh) or -[`ci-fiat-parsers.sh`](/dev/ci/ci-fiat-parsers.sh) for simple examples); +Add a new `ci-mydev.sh` script to [`dev/ci`](.) (have a look at +[`ci-coq-dpdgraph.sh`](ci-coq-dpdgraph.sh) or +[`ci-fiat-parsers.sh`](ci-fiat-parsers.sh) for simple examples); set the corresponding variables in -[`ci-basic-overlay.sh`](/dev/ci/ci-basic-overlay.sh); add the corresponding -target to [`Makefile.ci`](/Makefile.ci); add new jobs to -[`.travis.yml`](/.travis.yml) and [`.gitlab-ci.yml`](/.gitlab-ci.yml) so that -this new target is run. **Do not hesitate to submit an incomplete pull request -if you need help to finish it.** +[`ci-basic-overlay.sh`](ci-basic-overlay.sh); add the corresponding +target to [`Makefile.ci`](../../Makefile.ci); add new jobs to +[`.gitlab-ci.yml`](../../.gitlab-ci.yml), +[`.circleci/config.yml`](../../.circleci/config.yml) and +[`.travis.yml`](../../.travis.yml) so that this new target is run. **Do not +hesitate to submit an incomplete pull request if you need help to finish it.** You may also be interested in having your development tested in our performance benchmark. Currently this is done by providing an OPAM package @@ -71,62 +71,118 @@ When you submit a pull request (PR) on Coq GitHub repository, this will automatically launch a battery of CI tests. The PR will not be integrated unless these tests pass. -Currently, we have two CI platforms: +We are currently running tests on the following platforms: -- Travis is the main CI platform. It tests the compilation of Coq, of the +- GitLab CI is the main CI platform. It tests the compilation of Coq, of the documentation, and of CoqIDE on Linux with several versions of OCaml / camlp5, and with warnings as errors; it runs the test-suite and tests the - compilation of several external developments. It also tests the compilation - of Coq on OS X. + compilation of several external developments. + +- Circle CI runs tests that are redundant with GitLab CI and may be removed + eventually. + +- Travis CI is used to test the compilation of Coq and run the test-suite on + macOS. It also runs a linter that checks whitespace discipline. A + [pre-commit hook](../tools/pre-commit) is automatically installed by + `./configure`. It should allow complying with this discipline without pain. - AppVeyor is used to test the compilation of Coq and run the test-suite on Windows. -You can anticipate the results of these tests prior to submitting your PR -by having them run of your fork of Coq, on GitHub or GitLab. This can be -especially helpful given that our Travis platform is often overloaded and -therefore there can be a significant delay before these tests are actually -run on your PR. To take advantage of this, simply create a Travis account -and link it to your GitHub account, or activate the pipelines on your GitLab -fork. +GitLab CI and Travis CI and AppVeyor support putting `[ci skip]` in a commit +message to bypass CI. Do not use this unless your commit only changes files +that are not compiled (e.g. Markdown files like this one, or files under +[`.github/`](../../.github/)). -You can also run one CI target locally (using `make ci-somedev`). +You can anticipate the results of most of these tests prior to submitting your +PR by running GitLab CI on your private branches. To do so follow these steps: + +1. Log into GitLab CI (the easiest way is to sign in with your GitHub account). +2. Click on "New Project". +3. Choose "CI / CD for external repository" then click on "GitHub". +4. Find your fork of the Coq repository and click on "Connect". +5. If GitLab did not do so automatically, [enable the Container Registry](https://docs.gitlab.com/ee/user/project/container_registry.html#enable-the-container-registry-for-your-project). +6. You are encouraged to go to the CI / CD general settings and increase the + timeout from 1h to 2h for better reliability. -Whenever your PR breaks tested developments, you should either adapt it -so that it doesn't, or provide a branch fixing these developments (or at -least work with the author of the development / other Coq developers to -prepare these fixes). Then, add an overlay in -[`dev/ci/user-overlays`](/dev/ci/user-overlays) (see the README there) -in a separate commit in your PR. +Now everytime you push (including force-push unless you changed the default +GitLab setting) to your fork on GitHub, it will be synchronized on GitLab and +CI will be run. You will receive an e-mail with a report of the failures if +there are some. -The process to merge your PR is then to submit PRs to the external -development repositories, merge the latter first (if the fixes are -backward-compatible), drop the overlay commit and merge the PR on Coq then. +You can also run one CI target locally (using `make ci-somedev`). + +See also [`test-suite/README.md`](../../test-suite/README.md) for information about adding new tests to the test-suite. -See also [`test-suite/README.md`](/test-suite/README.md) for information about adding new tests to the test-suite. +### Breaking changes +When your PR breaks an external project we test in our CI, you must prepare a +patch (or ask someone to prepare a patch) to fix the project: -Travis specific information ---------------------------- +1. Fork the external project, create a new branch, push a commit adapting + the project to your changes. +2. Test your pull request with your adapted version of the external project by + adding an overlay file to your pull request (cf. + [`dev/ci/user-overlays/README.md`](user-overlays/README.md)). +3. Fixes to external libraries (pure Coq projects) *must* be backward + compatible (i.e. they should also work with the development version of Coq, + and the latest stable version). This will allow you to open a PR on the + external project repository to have your changes merged *before* your PR on + Coq can be integrated. -Travis rebuilds all of Coq's executables and stdlib for each job. Coq -is built with `./configure -local`, then used for the job's test. + On the other hand, patches to plugins (projects linking to the Coq ML API) + can very rarely be made backward compatible and plugins we test will + generally have a dedicated branch per Coq version. + You can still open a pull request but the merging will be requested by the + developer who merges the PR on Coq. There are plans to improve this, cf. + [#6724](https://github.com/coq/coq/issues/6724). +Moreover your PR must absolutely update the [`CHANGES`](../../CHANGES) file. -GitLab specific information ---------------------------- +Advanced GitLab CI information +------------------------------ -GitLab is set up to use the "build artifact" feature to avoid -rebuilding Coq. In one job, Coq is built with `./configure -prefix -install` and `make install` is run, then the `install` directory +GitLab CI is set up to use the "build artifact" feature to avoid +rebuilding Coq. In one job, Coq is built with `./configure -prefix _install_ci` +and `make install` is run, then the `_install_ci` directory persists to and is used by the next jobs. Artifacts can also be downloaded from the GitLab repository. Currently, available artifacts are: - the Coq executables and stdlib, in three copies varying in - architecture and Ocaml version used to build Coq. -- the Coq documentation, in two different copies varying in the OCaml - version used to build Coq + architecture and OCaml version used to build Coq. +- the Coq documentation, built only in the `build:base` job. When submitting + a documentation PR, this can help reviewers checking the rendered result. As an exception to the above, jobs testing that compilation triggers -no Ocaml warnings build Coq in parallel with other tests. +no OCaml warnings build Coq in parallel with other tests. + +### GitLab and Windows + +If your repository has access to runners tagged `windows`, setting the +secret variable `WINDOWS` to `enabled` will add jobs building Windows +versions of Coq (32bit and 64bit). + +The Windows jobs are enabled on Coq's repository, where pipelines for +pull requests run. + +### GitLab and Docker + +System and opam packages are installed in a Docker image. The image is +automatically built and uploaded to your GitLab registry, and is +loaded by subsequent jobs. + +**IMPORTANT**: When updating Coq's CI docker image, you must modify +the `CACHEKEY` variable in [`.gitlab-ci.yml`](../../.gitlab-ci.yml), +[`.circleci/config.yml`](../../.circleci/config.yml), +and [`Dockerfile`](docker/bionic_coq/Dockerfile) + +The Docker building job reuses the uploaded image if it is available, +but if you wish to save more time you can skip the job by setting +`SKIP_DOCKER` to `true`. + +This means you will need to change its value when the Docker image +needs to be updated. You can do so for a single pipeline by starting +it through the web interface.. + +See also [`docker/README.md`](docker/README.md). diff --git a/dev/ci/appveyor.sh b/dev/ci/appveyor.sh index 524a55a42..7bf9ad8c9 100644 --- a/dev/ci/appveyor.sh +++ b/dev/ci/appveyor.sh @@ -1,9 +1,15 @@ #!/bin/bash + set -e -x + +APPVEYOR_OPAM_SWITCH=4.06.1+mingw64c + wget https://github.com/fdopen/opam-repository-mingw/releases/download/0.0.0.1/opam64.tar.xz tar -xf opam64.tar.xz bash opam64/install.sh -opam init -a mingw https://github.com/fdopen/opam-repository-mingw.git --comp 4.02.3+mingw64c --switch 4.02.3+mingw64c -eval $(opam config env) -opam install -y ocamlfind camlp5 -cd $APPVEYOR_BUILD_FOLDER && ./configure -local && make && make byte && make -C test-suite all INTERACTIVE= && make validate + +opam init -a mingw https://github.com/fdopen/opam-repository-mingw.git --comp $APPVEYOR_OPAM_SWITCH --switch $APPVEYOR_OPAM_SWITCH +eval "$(opam config env)" +opam install -y num ocamlfind camlp5 ounit + +cd "$APPVEYOR_BUILD_FOLDER" && ./configure -local && make && make byte && make -C test-suite all INTERACTIVE= && make validate diff --git a/dev/ci/ci-basic-overlay.sh b/dev/ci/ci-basic-overlay.sh index 48e01e9e9..87d837b38 100644..100755 --- a/dev/ci/ci-basic-overlay.sh +++ b/dev/ci/ci-basic-overlay.sh @@ -11,6 +11,8 @@ ######################################################################## : "${mathcomp_CI_BRANCH:=master}" : "${mathcomp_CI_GITURL:=https://github.com/math-comp/math-comp.git}" +: "${oddorder_CI_BRANCH:=master}" +: "${oddorder_CI_GITURL:=https://github.com/math-comp/odd-order.git}" ######################################################################## # UniMath @@ -19,13 +21,13 @@ : "${UniMath_CI_GITURL:=https://github.com/UniMath/UniMath.git}" ######################################################################## -# Unicoq + Metacoq +# Unicoq + Mtac2 ######################################################################## : "${unicoq_CI_BRANCH:=master}" : "${unicoq_CI_GITURL:=https://github.com/unicoq/unicoq.git}" -: "${metacoq_CI_BRANCH:=master}" -: "${metacoq_CI_GITURL:=https://github.com/MetaCoq/MetaCoq.git}" +: "${mtac2_CI_BRANCH:=master-sync}" +: "${mtac2_CI_GITURL:=https://github.com/Mtac2/Mtac2.git}" ######################################################################## # Mathclasses + Corn @@ -91,6 +93,12 @@ : "${VST_CI_GITURL:=https://github.com/PrincetonUniversity/VST.git}" ######################################################################## +# cross-crypto +######################################################################## +: "${cross_crypto_CI_BRANCH:=master}" +: "${cross_crypto_CI_GITURL:=https://github.com/mit-plv/cross-crypto.git}" + +######################################################################## # fiat_parsers ######################################################################## : "${fiat_parsers_CI_BRANCH:=master}" @@ -142,7 +150,7 @@ ######################################################################## # Equations ######################################################################## -: "${Equations_CI_BRANCH:=8.8+alpha}" +: "${Equations_CI_BRANCH:=master}" : "${Equations_CI_GITURL:=https://github.com/mattam82/Coq-Equations.git}" ######################################################################## @@ -150,3 +158,27 @@ ######################################################################## : "${Elpi_CI_BRANCH:=coq-master}" : "${Elpi_CI_GITURL:=https://github.com/LPCIC/coq-elpi.git}" + +######################################################################## +# fcsl-pcm +######################################################################## +: "${fcsl_pcm_CI_BRANCH:=master}" +: "${fcsl_pcm_CI_GITURL:=https://github.com/imdea-software/fcsl-pcm.git}" + +######################################################################## +# pidetop +######################################################################## +: "${pidetop_CI_BRANCH:=v8.9}" +: "${pidetop_CI_GITURL:=https://bitbucket.org/coqpide/pidetop.git}" + +######################################################################## +# ext-lib +######################################################################## +: "${ext_lib_CI_BRANCH:=master}" +: "${ext_lib_CI_GITURL:=https://github.com/coq-ext-lib/coq-ext-lib.git}" + +######################################################################## +# quickchick +######################################################################## +: "${quickchick_CI_BRANCH:=master}" +: "${quickchick_CI_GITURL:=https://github.com/QuickChick/QuickChick.git}" diff --git a/dev/ci/ci-bignums.sh b/dev/ci/ci-bignums.sh index c90e516ae..008291967 100755 --- a/dev/ci/ci-bignums.sh +++ b/dev/ci/ci-bignums.sh @@ -6,11 +6,11 @@ ci_dir="$(dirname "$0")" # Let's avoid to source ci-common twice in this case if [ -z "${CI_BUILD_DIR}" ]; then - source ${ci_dir}/ci-common.sh + . "${ci_dir}/ci-common.sh" fi -bignums_CI_DIR=${CI_BUILD_DIR}/Bignums +bignums_CI_DIR="${CI_BUILD_DIR}/Bignums" -git_checkout ${bignums_CI_BRANCH} ${bignums_CI_GITURL} ${bignums_CI_DIR} +git_checkout "${bignums_CI_BRANCH}" "${bignums_CI_GITURL}" "${bignums_CI_DIR}" -( cd ${bignums_CI_DIR} && make && make install) +( cd "${bignums_CI_DIR}" && make && make install) diff --git a/dev/ci/ci-color.sh b/dev/ci/ci-color.sh index 558e8cbb8..8ce5f2418 100755 --- a/dev/ci/ci-color.sh +++ b/dev/ci/ci-color.sh @@ -1,10 +1,10 @@ #!/usr/bin/env bash ci_dir="$(dirname "$0")" -source ${ci_dir}/ci-common.sh +. "${ci_dir}/ci-common.sh" CoLoR_CI_DIR=${CI_BUILD_DIR}/color # Compile CoLoR -git_checkout ${CoLoR_CI_BRANCH} ${CoLoR_CI_GITURL} ${CoLoR_CI_DIR} -( cd ${CoLoR_CI_DIR} && make ) +git_checkout "${CoLoR_CI_BRANCH}" "${CoLoR_CI_GITURL}" "${CoLoR_CI_DIR}" +( cd "${CoLoR_CI_DIR}" && make ) diff --git a/dev/ci/ci-common.sh b/dev/ci/ci-common.sh index d7a356930..85df249d3 100644 --- a/dev/ci/ci-common.sh +++ b/dev/ci/ci-common.sh @@ -8,8 +8,13 @@ export NJOBS if [ -n "${GITLAB_CI}" ]; then + export OCAMLPATH="$PWD/_install_ci/lib:$OCAMLPATH" export COQBIN="$PWD/_install_ci/bin" export CI_BRANCH="$CI_COMMIT_REF_NAME" + if [[ ${CI_BRANCH#pr-} =~ ^[0-9]*$ ]] + then + export CI_PULL_REQUEST="${CI_BRANCH#pr-}" + fi else if [ -n "${TRAVIS}" ]; then @@ -20,8 +25,10 @@ else export CI_PULL_REQUEST="$CIRCLE_PR_NUMBER" export CI_BRANCH="$CIRCLE_BRANCH" else # assume local - export CI_BRANCH="$(git rev-parse --abbrev-ref HEAD)" + CI_BRANCH="$(git rev-parse --abbrev-ref HEAD)" + export CI_BRANCH fi + export OCAMLPATH="$PWD:$OCAMLPATH" export COQBIN="$PWD/bin" fi export PATH="$COQBIN:$PATH" @@ -35,10 +42,10 @@ ls "$COQBIN" CI_BUILD_DIR="$PWD/_build_ci" # shellcheck source=ci-basic-overlay.sh -source "${ci_dir}/ci-basic-overlay.sh" +. "${ci_dir}/ci-basic-overlay.sh" for overlay in "${ci_dir}"/user-overlays/*.sh; do # shellcheck source=/dev/null - source "${overlay}" + . "${overlay}" done mathcomp_CI_DIR="${CI_BUILD_DIR}/math-comp" @@ -66,11 +73,6 @@ git_checkout() echo "${_DEST}: $(git log -1 --format='%s | %H | %cd | %aN')" ) } -checkout_mathcomp() -{ - git_checkout ${mathcomp_CI_BRANCH} ${mathcomp_CI_GITURL} ${1} -} - make() { # +x: add x only if defined @@ -88,19 +90,29 @@ install_ssreflect() { echo 'Installing ssreflect' && echo -en 'travis_fold:start:ssr.install\\r' - checkout_mathcomp "${mathcomp_CI_DIR}" + git_checkout "${mathcomp_CI_BRANCH}" "${mathcomp_CI_GITURL}" "${mathcomp_CI_DIR}" + ( cd "${mathcomp_CI_DIR}/mathcomp" && \ - sed -i.bak '/ssrtest/d' Make && \ - sed -i.bak '/odd_order/d' Make && \ - sed -i.bak '/all\/all.v/d' Make && \ - sed -i.bak '/character/d' Make && \ - sed -i.bak '/real_closed/d' Make && \ - sed -i.bak '/solvable/d' Make && \ - sed -i.bak '/field/d' Make && \ - sed -i.bak '/fingroup/d' Make && \ - sed -i.bak '/algebra/d' Make && \ - make Makefile.coq && make -f Makefile.coq all && make install ) + make Makefile.coq && \ + make -f Makefile.coq ssreflect/all_ssreflect.vo && \ + make -f Makefile.coq install ) echo -en 'travis_fold:end:ssr.install\\r' } + +# this installs just the ssreflect + algebra library of math-comp +install_ssralg() +{ + echo 'Installing ssralg' && echo -en 'travis_fold:start:ssralg.install\\r' + + git_checkout "${mathcomp_CI_BRANCH}" "${mathcomp_CI_GITURL}" "${mathcomp_CI_DIR}" + + ( cd "${mathcomp_CI_DIR}/mathcomp" && \ + make Makefile.coq && \ + make -f Makefile.coq algebra/all_algebra.vo && \ + make -f Makefile.coq install ) + + echo -en 'travis_fold:end:ssralg.install\\r' + +} diff --git a/dev/ci/ci-compcert.sh b/dev/ci/ci-compcert.sh index 6a0ce2aef..8d490591b 100755 --- a/dev/ci/ci-compcert.sh +++ b/dev/ci/ci-compcert.sh @@ -1,11 +1,10 @@ #!/usr/bin/env bash ci_dir="$(dirname "$0")" -source ${ci_dir}/ci-common.sh +. "${ci_dir}/ci-common.sh" -CompCert_CI_DIR=${CI_BUILD_DIR}/CompCert +CompCert_CI_DIR="${CI_BUILD_DIR}/CompCert" -opam install -j "$NJOBS" -y menhir -git_checkout ${CompCert_CI_BRANCH} ${CompCert_CI_GITURL} ${CompCert_CI_DIR} +git_checkout "${CompCert_CI_BRANCH}" "${CompCert_CI_GITURL}" "${CompCert_CI_DIR}" -( cd ${CompCert_CI_DIR} && ./configure -ignore-coq-version x86_32-linux && make && make check-proof ) +( cd "${CompCert_CI_DIR}" && ./configure -ignore-coq-version x86_32-linux && make && make check-proof ) diff --git a/dev/ci/ci-coq-dpdgraph.sh b/dev/ci/ci-coq-dpdgraph.sh index 5d6bd6a36..5d57fce1c 100755 --- a/dev/ci/ci-coq-dpdgraph.sh +++ b/dev/ci/ci-coq-dpdgraph.sh @@ -1,10 +1,10 @@ #!/usr/bin/env bash ci_dir="$(dirname "$0")" -source ${ci_dir}/ci-common.sh +. "${ci_dir}/ci-common.sh" -coq_dpdgraph_CI_DIR=${CI_BUILD_DIR}/coq-dpdgraph +coq_dpdgraph_CI_DIR="${CI_BUILD_DIR}/coq-dpdgraph" -git_checkout ${coq_dpdgraph_CI_BRANCH} ${coq_dpdgraph_CI_GITURL} ${coq_dpdgraph_CI_DIR} +git_checkout "${coq_dpdgraph_CI_BRANCH}" "${coq_dpdgraph_CI_GITURL}" "${coq_dpdgraph_CI_DIR}" -( cd ${coq_dpdgraph_CI_DIR} && autoconf && ./configure && make && make test-suite ) +( cd "${coq_dpdgraph_CI_DIR}" && autoconf && ./configure && make && make test-suite ) diff --git a/dev/ci/ci-coquelicot.sh b/dev/ci/ci-coquelicot.sh index 40eff03b7..d86d61ef6 100755 --- a/dev/ci/ci-coquelicot.sh +++ b/dev/ci/ci-coquelicot.sh @@ -1,12 +1,12 @@ #!/usr/bin/env bash ci_dir="$(dirname "$0")" -source ${ci_dir}/ci-common.sh +. "${ci_dir}/ci-common.sh" -Coquelicot_CI_DIR=${CI_BUILD_DIR}/coquelicot +Coquelicot_CI_DIR="${CI_BUILD_DIR}/coquelicot" install_ssreflect -git_checkout ${Coquelicot_CI_BRANCH} ${Coquelicot_CI_GITURL} ${Coquelicot_CI_DIR} +git_checkout "${Coquelicot_CI_BRANCH}" "${Coquelicot_CI_GITURL}" "${Coquelicot_CI_DIR}" -( cd ${Coquelicot_CI_DIR} && ./autogen.sh && ./configure && ./remake -j${NJOBS} ) +( cd "${Coquelicot_CI_DIR}" && ./autogen.sh && ./configure && ./remake "-j${NJOBS}" ) diff --git a/dev/ci/ci-corn.sh b/dev/ci/ci-corn.sh index 54cad5df4..9298fc70a 100755 --- a/dev/ci/ci-corn.sh +++ b/dev/ci/ci-corn.sh @@ -1,10 +1,10 @@ #!/usr/bin/env bash ci_dir="$(dirname "$0")" -source ${ci_dir}/ci-common.sh +. "${ci_dir}/ci-common.sh" -Corn_CI_DIR=${CI_BUILD_DIR}/corn +Corn_CI_DIR="${CI_BUILD_DIR}/corn" -git_checkout ${Corn_CI_BRANCH} ${Corn_CI_GITURL} ${Corn_CI_DIR} +git_checkout "${Corn_CI_BRANCH}" "${Corn_CI_GITURL}" "${Corn_CI_DIR}" -( cd ${Corn_CI_DIR} && make && make install ) +( cd "${Corn_CI_DIR}" && make && make install ) diff --git a/dev/ci/ci-cpdt.sh b/dev/ci/ci-cpdt.sh index 8b725f6fe..ca759c7b3 100755 --- a/dev/ci/ci-cpdt.sh +++ b/dev/ci/ci-cpdt.sh @@ -1,10 +1,9 @@ #!/usr/bin/env bash ci_dir="$(dirname "$0")" -source ${ci_dir}/ci-common.sh +. "${ci_dir}/ci-common.sh" wget http://adam.chlipala.net/cpdt/cpdt.tgz tar xvfz cpdt.tgz ( cd cpdt && make clean && make ) - diff --git a/dev/ci/ci-cross-crypto.sh b/dev/ci/ci-cross-crypto.sh new file mode 100755 index 000000000..a0d3aa655 --- /dev/null +++ b/dev/ci/ci-cross-crypto.sh @@ -0,0 +1,11 @@ +#!/usr/bin/env bash + +ci_dir="$(dirname "$0")" +. "${ci_dir}/ci-common.sh" + +cross_crypto_CI_DIR="${CI_BUILD_DIR}/cross-crypto" + +git_checkout "${cross_crypto_CI_BRANCH}" "${cross_crypto_CI_GITURL}" "${cross_crypto_CI_DIR}" +( cd "${cross_crypto_CI_DIR}" && git submodule update --init --recursive ) + +( cd "${cross_crypto_CI_DIR}" && make ) diff --git a/dev/ci/ci-elpi.sh b/dev/ci/ci-elpi.sh index c44e0a655..9c58034be 100755 --- a/dev/ci/ci-elpi.sh +++ b/dev/ci/ci-elpi.sh @@ -1,10 +1,10 @@ #!/usr/bin/env bash ci_dir="$(dirname "$0")" -source ${ci_dir}/ci-common.sh +. "${ci_dir}/ci-common.sh" -Elpi_CI_DIR=${CI_BUILD_DIR}/elpi +Elpi_CI_DIR="${CI_BUILD_DIR}/elpi" -git_checkout ${Elpi_CI_BRANCH} ${Elpi_CI_GITURL} ${Elpi_CI_DIR} +git_checkout "${Elpi_CI_BRANCH}" "${Elpi_CI_GITURL}" "${Elpi_CI_DIR}" -( cd ${Elpi_CI_DIR} && make && make install ) +( cd "${Elpi_CI_DIR}" && make && make install ) diff --git a/dev/ci/ci-equations.sh b/dev/ci/ci-equations.sh index 62854afac..98735b4ec 100755 --- a/dev/ci/ci-equations.sh +++ b/dev/ci/ci-equations.sh @@ -1,10 +1,10 @@ #!/usr/bin/env bash ci_dir="$(dirname "$0")" -source ${ci_dir}/ci-common.sh +. "${ci_dir}/ci-common.sh" -Equations_CI_DIR=${CI_BUILD_DIR}/Equations +Equations_CI_DIR="${CI_BUILD_DIR}/Equations" -git_checkout ${Equations_CI_BRANCH} ${Equations_CI_GITURL} ${Equations_CI_DIR} +git_checkout "${Equations_CI_BRANCH}" "${Equations_CI_GITURL}" "${Equations_CI_DIR}" -( cd ${Equations_CI_DIR} && coq_makefile -f _CoqProject -o Makefile && make && make test-suite && make examples && make install) +( cd "${Equations_CI_DIR}" && coq_makefile -f _CoqProject -o Makefile && make && make test-suite && make examples && make install) diff --git a/dev/ci/ci-ext-lib.sh b/dev/ci/ci-ext-lib.sh new file mode 100755 index 000000000..cf212c2fb --- /dev/null +++ b/dev/ci/ci-ext-lib.sh @@ -0,0 +1,16 @@ +#!/usr/bin/env bash + +ci_dir="$(dirname "$0")" + +# This script could be included inside other ones +# Let's avoid to source ci-common twice in this case +if [ -z "${CI_BUILD_DIR}" ]; +then + . "${ci_dir}/ci-common.sh" +fi + +ext_lib_CI_DIR="${CI_BUILD_DIR}/ExtLib" + +git_checkout "${ext_lib_CI_BRANCH}" "${ext_lib_CI_GITURL}" "${ext_lib_CI_DIR}" + +( cd "${ext_lib_CI_DIR}" && make && make install) diff --git a/dev/ci/ci-fcsl-pcm.sh b/dev/ci/ci-fcsl-pcm.sh new file mode 100755 index 000000000..fdc4c729b --- /dev/null +++ b/dev/ci/ci-fcsl-pcm.sh @@ -0,0 +1,12 @@ +#!/usr/bin/env bash + +ci_dir="$(dirname "$0")" +. "${ci_dir}/ci-common.sh" + +fcsl_pcm_CI_DIR="${CI_BUILD_DIR}/fcsl-pcm" + +install_ssreflect + +git_checkout "${fcsl_pcm_CI_BRANCH}" "${fcsl_pcm_CI_GITURL}" "${fcsl_pcm_CI_DIR}" + +( cd "${fcsl_pcm_CI_DIR}" && make ) diff --git a/dev/ci/ci-fiat-crypto.sh b/dev/ci/ci-fiat-crypto.sh index 5ca3ac47f..48a1366ab 100755 --- a/dev/ci/ci-fiat-crypto.sh +++ b/dev/ci/ci-fiat-crypto.sh @@ -1,11 +1,14 @@ #!/usr/bin/env bash ci_dir="$(dirname "$0")" -source ${ci_dir}/ci-common.sh +. "${ci_dir}/ci-common.sh" -fiat_crypto_CI_DIR=${CI_BUILD_DIR}/fiat-crypto +fiat_crypto_CI_DIR="${CI_BUILD_DIR}/fiat-crypto" -git_checkout ${fiat_crypto_CI_BRANCH} ${fiat_crypto_CI_GITURL} ${fiat_crypto_CI_DIR} -( cd ${fiat_crypto_CI_DIR} && git submodule update --init --recursive ) +git_checkout "${fiat_crypto_CI_BRANCH}" "${fiat_crypto_CI_GITURL}" "${fiat_crypto_CI_DIR}" -( cd ${fiat_crypto_CI_DIR} && make lite ) +( cd "${fiat_crypto_CI_DIR}" && git submodule update --init --recursive ) + +fiat_crypto_CI_TARGETS1="printlite lite lite-display" +fiat_crypto_CI_TARGETS2="print-nobigmem nobigmem nonautogenerated-specific nonautogenerated-specific-display" +( cd "${fiat_crypto_CI_DIR}" && make ${fiat_crypto_CI_TARGETS1} && make -j 1 ${fiat_crypto_CI_TARGETS2} ) diff --git a/dev/ci/ci-fiat-parsers.sh b/dev/ci/ci-fiat-parsers.sh index 292331b81..35c228405 100755 --- a/dev/ci/ci-fiat-parsers.sh +++ b/dev/ci/ci-fiat-parsers.sh @@ -1,10 +1,10 @@ #!/usr/bin/env bash ci_dir="$(dirname "$0")" -source ${ci_dir}/ci-common.sh +. "${ci_dir}/ci-common.sh" -fiat_parsers_CI_DIR=${CI_BUILD_DIR}/fiat +fiat_parsers_CI_DIR="${CI_BUILD_DIR}/fiat" -git_checkout ${fiat_parsers_CI_BRANCH} ${fiat_parsers_CI_GITURL} ${fiat_parsers_CI_DIR} +git_checkout "${fiat_parsers_CI_BRANCH}" "${fiat_parsers_CI_GITURL}" "${fiat_parsers_CI_DIR}" -( cd ${fiat_parsers_CI_DIR} && make parsers parsers-examples && make fiat-core ) +( cd "${fiat_parsers_CI_DIR}" && make parsers parsers-examples && make fiat-core ) diff --git a/dev/ci/ci-flocq.sh b/dev/ci/ci-flocq.sh index ec19bd993..8599e4d50 100755 --- a/dev/ci/ci-flocq.sh +++ b/dev/ci/ci-flocq.sh @@ -1,10 +1,10 @@ #!/usr/bin/env bash ci_dir="$(dirname "$0")" -source ${ci_dir}/ci-common.sh +. "${ci_dir}/ci-common.sh" -Flocq_CI_DIR=${CI_BUILD_DIR}/flocq +Flocq_CI_DIR="${CI_BUILD_DIR}/flocq" -git_checkout ${Flocq_CI_BRANCH} ${Flocq_CI_GITURL} ${Flocq_CI_DIR} +git_checkout "${Flocq_CI_BRANCH}" "${Flocq_CI_GITURL}" "${Flocq_CI_DIR}" -( cd ${Flocq_CI_DIR} && ./autogen.sh && ./configure && ./remake -j${NJOBS} ) +( cd "${Flocq_CI_DIR}" && ./autogen.sh && ./configure && ./remake "-j${NJOBS}" ) diff --git a/dev/ci/ci-formal-topology.sh b/dev/ci/ci-formal-topology.sh index 53eb55fc4..118d15150 100755 --- a/dev/ci/ci-formal-topology.sh +++ b/dev/ci/ci-formal-topology.sh @@ -1,10 +1,10 @@ #!/usr/bin/env bash ci_dir="$(dirname "$0")" -source ${ci_dir}/ci-common.sh +. "${ci_dir}/ci-common.sh" -formal_topology_CI_DIR=${CI_BUILD_DIR}/formal-topology +formal_topology_CI_DIR="${CI_BUILD_DIR}/formal-topology" -git_checkout ${formal_topology_CI_BRANCH} ${formal_topology_CI_GITURL} ${formal_topology_CI_DIR} +git_checkout "${formal_topology_CI_BRANCH}" "${formal_topology_CI_GITURL}" "${formal_topology_CI_DIR}" -( cd ${formal_topology_CI_DIR} && make ) +( cd "${formal_topology_CI_DIR}" && make ) diff --git a/dev/ci/ci-geocoq.sh b/dev/ci/ci-geocoq.sh index 8e6448e76..24cd9c427 100755 --- a/dev/ci/ci-geocoq.sh +++ b/dev/ci/ci-geocoq.sh @@ -1,12 +1,12 @@ #!/usr/bin/env bash ci_dir="$(dirname "$0")" -source ${ci_dir}/ci-common.sh +. "${ci_dir}/ci-common.sh" -GeoCoq_CI_DIR=${CI_BUILD_DIR}/GeoCoq +GeoCoq_CI_DIR="${CI_BUILD_DIR}/GeoCoq" -git_checkout ${GeoCoq_CI_BRANCH} ${GeoCoq_CI_GITURL} ${GeoCoq_CI_DIR} +git_checkout "${GeoCoq_CI_BRANCH}" "${GeoCoq_CI_GITURL}" "${GeoCoq_CI_DIR}" -( cd ${GeoCoq_CI_DIR} && \ - ./configure-ci.sh && \ - make ) +install_ssralg + +( cd "${GeoCoq_CI_DIR}" && ./configure.sh && make ) diff --git a/dev/ci/ci-hott.sh b/dev/ci/ci-hott.sh index 693135a4c..6ded97984 100755 --- a/dev/ci/ci-hott.sh +++ b/dev/ci/ci-hott.sh @@ -1,10 +1,10 @@ #!/usr/bin/env bash ci_dir="$(dirname "$0")" -source ${ci_dir}/ci-common.sh +. "${ci_dir}/ci-common.sh" -HoTT_CI_DIR=${CI_BUILD_DIR}/HoTT +HoTT_CI_DIR="${CI_BUILD_DIR}"/HoTT -git_checkout ${HoTT_CI_BRANCH} ${HoTT_CI_GITURL} ${HoTT_CI_DIR} +git_checkout "${HoTT_CI_BRANCH}" "${HoTT_CI_GITURL}" "${HoTT_CI_DIR}" -( cd ${HoTT_CI_DIR} && ./autogen.sh && ./configure && make ) +( cd "${HoTT_CI_DIR}" && ./autogen.sh && ./configure && make ) diff --git a/dev/ci/ci-iris-lambda-rust.sh b/dev/ci/ci-iris-lambda-rust.sh index 267e13359..1af0f634c 100755 --- a/dev/ci/ci-iris-lambda-rust.sh +++ b/dev/ci/ci-iris-lambda-rust.sh @@ -1,41 +1,34 @@ #!/usr/bin/env bash ci_dir="$(dirname "$0")" -source ${ci_dir}/ci-common.sh +. "${ci_dir}/ci-common.sh" -stdpp_CI_DIR=${CI_BUILD_DIR}/coq-stdpp -Iris_CI_DIR=${CI_BUILD_DIR}/iris-coq -lambdaRust_CI_DIR=${CI_BUILD_DIR}/lambdaRust +stdpp_CI_DIR="${CI_BUILD_DIR}/coq-stdpp" +Iris_CI_DIR="${CI_BUILD_DIR}/iris-coq" +lambdaRust_CI_DIR="${CI_BUILD_DIR}/lambdaRust" install_ssreflect -# Add or update the opam repo we need for dependency resolution -opam repo add iris-dev https://gitlab.mpi-sws.org/FP/opam-dev.git -p 0 || opam update iris-dev - # Setup lambdaRust first -git_checkout ${lambdaRust_CI_BRANCH} ${lambdaRust_CI_GITURL} ${lambdaRust_CI_DIR} +git_checkout "${lambdaRust_CI_BRANCH}" "${lambdaRust_CI_GITURL}" "${lambdaRust_CI_DIR}" # Extract required version of Iris -Iris_VERSION=$(cat ${lambdaRust_CI_DIR}/opam | fgrep coq-iris | egrep 'dev\.([0-9.-]+)' -o) -Iris_URL=$(opam show coq-iris.$Iris_VERSION -f upstream-url) -read -a Iris_URL_PARTS <<< $(echo $Iris_URL | tr '#' ' ') +Iris_SHA=$(grep -F coq-iris < "${lambdaRust_CI_DIR}/opam" | sed 's/.*"dev\.[0-9.-]\+\.\([0-9a-z]\+\)".*/\1/') # Setup Iris -git_checkout ${Iris_CI_BRANCH} ${Iris_URL_PARTS[0]} ${Iris_CI_DIR} ${Iris_URL_PARTS[1]} +git_checkout "${Iris_CI_BRANCH}" "${Iris_CI_GITURL}" "${Iris_CI_DIR}" "${Iris_SHA}" # Extract required version of std++ -stdpp_VERSION=$(cat ${Iris_CI_DIR}/opam | fgrep coq-stdpp | egrep 'dev\.([0-9.-]+)' -o) -stdpp_URL=$(opam show coq-stdpp.$stdpp_VERSION -f upstream-url) -read -a stdpp_URL_PARTS <<< $(echo $stdpp_URL | tr '#' ' ') +stdpp_SHA=$(grep -F coq-stdpp < "${Iris_CI_DIR}/opam" | sed 's/.*"dev\.[0-9.-]\+\.\([0-9a-z]\+\)".*/\1/') # Setup std++ -git_checkout ${stdpp_CI_BRANCH} ${stdpp_URL_PARTS[0]} ${stdpp_CI_DIR} ${stdpp_URL_PARTS[1]} +git_checkout "${stdpp_CI_BRANCH}" "${stdpp_CI_GITURL}" "${stdpp_CI_DIR}" "${stdpp_SHA}" # Build std++ -( cd ${stdpp_CI_DIR} && make && make install ) +( cd "${stdpp_CI_DIR}" && make && make install ) # Build and validate (except on Travis, i.e., skip if TRAVIS is non-empty) Iris -( cd ${Iris_CI_DIR} && make && (test -n "${TRAVIS}" || make validate) && make install ) +( cd "${Iris_CI_DIR}" && make && (test -n "${TRAVIS}" || make validate) && make install ) # Build lambdaRust -( cd ${lambdaRust_CI_DIR} && make && make install ) +( cd "${lambdaRust_CI_DIR}" && make && make install ) diff --git a/dev/ci/ci-ltac2.sh b/dev/ci/ci-ltac2.sh index 820ff89ee..5981aaaae 100755 --- a/dev/ci/ci-ltac2.sh +++ b/dev/ci/ci-ltac2.sh @@ -1,10 +1,10 @@ #!/usr/bin/env bash ci_dir="$(dirname "$0")" -source ${ci_dir}/ci-common.sh +. "${ci_dir}/ci-common.sh" -ltac2_CI_DIR=${CI_BUILD_DIR}/ltac2 +ltac2_CI_DIR="${CI_BUILD_DIR}/ltac2" -git_checkout ${ltac2_CI_BRANCH} ${ltac2_CI_GITURL} ${ltac2_CI_DIR} +git_checkout "${ltac2_CI_BRANCH}" "${ltac2_CI_GITURL}" "${ltac2_CI_DIR}" -( cd ${ltac2_CI_DIR} && make && make tests && make install ) +( cd "${ltac2_CI_DIR}" && make && make tests && make install ) diff --git a/dev/ci/ci-math-classes.sh b/dev/ci/ci-math-classes.sh index db4a31e54..6a064b297 100755 --- a/dev/ci/ci-math-classes.sh +++ b/dev/ci/ci-math-classes.sh @@ -1,10 +1,10 @@ #!/usr/bin/env bash ci_dir="$(dirname "$0")" -source ${ci_dir}/ci-common.sh +. "${ci_dir}/ci-common.sh" -math_classes_CI_DIR=${CI_BUILD_DIR}/math-classes +math_classes_CI_DIR="${CI_BUILD_DIR}/math-classes" -git_checkout ${math_classes_CI_BRANCH} ${math_classes_CI_GITURL} ${math_classes_CI_DIR} +git_checkout "${math_classes_CI_BRANCH}" "${math_classes_CI_GITURL}" "${math_classes_CI_DIR}" -( cd ${math_classes_CI_DIR} && make && make install ) +( cd "${math_classes_CI_DIR}" && ./configure.sh && make && make install ) diff --git a/dev/ci/ci-math-comp.sh b/dev/ci/ci-math-comp.sh index 701403f2c..20328baf2 100755 --- a/dev/ci/ci-math-comp.sh +++ b/dev/ci/ci-math-comp.sh @@ -2,14 +2,13 @@ # $0 is not the safest way, but... ci_dir="$(dirname "$0")" -source ${ci_dir}/ci-common.sh +. "${ci_dir}/ci-common.sh" -mathcomp_CI_DIR=${CI_BUILD_DIR}/math-comp +mathcomp_CI_DIR="${CI_BUILD_DIR}/math-comp" +oddorder_CI_DIR="${CI_BUILD_DIR}/odd-order" -checkout_mathcomp ${mathcomp_CI_DIR} +git_checkout "${mathcomp_CI_BRANCH}" "${mathcomp_CI_GITURL}" "${mathcomp_CI_DIR}" +git_checkout "${oddorder_CI_BRANCH}" "${oddorder_CI_GITURL}" "${oddorder_CI_DIR}" -# odd_order takes too much time for travis. -( cd ${mathcomp_CI_DIR}/mathcomp && \ - sed -i.bak '/PFsection/d' Make && \ - sed -i.bak '/stripped_odd_order_theorem/d' Make && \ - make Makefile.coq && make -f Makefile.coq all ) +( cd "${mathcomp_CI_DIR}/mathcomp" && make && make install ) +( cd "${oddorder_CI_DIR}/" && make ) diff --git a/dev/ci/ci-metacoq.sh b/dev/ci/ci-metacoq.sh deleted file mode 100755 index c813b1fe9..000000000 --- a/dev/ci/ci-metacoq.sh +++ /dev/null @@ -1,19 +0,0 @@ -#!/usr/bin/env bash - -ci_dir="$(dirname "$0")" -source ${ci_dir}/ci-common.sh - -unicoq_CI_DIR=${CI_BUILD_DIR}/unicoq -metacoq_CI_DIR=${CI_BUILD_DIR}/MetaCoq - -# Setup UniCoq - -git_checkout ${unicoq_CI_BRANCH} ${unicoq_CI_GITURL} ${unicoq_CI_DIR} - -( cd ${unicoq_CI_DIR} && coq_makefile -f Make -o Makefile && make && make install ) - -# Setup MetaCoq - -git_checkout ${metacoq_CI_BRANCH} ${metacoq_CI_GITURL} ${metacoq_CI_DIR} - -( cd ${metacoq_CI_DIR} && coq_makefile -f _CoqProject -o Makefile && make ) diff --git a/dev/ci/ci-mtac2.sh b/dev/ci/ci-mtac2.sh new file mode 100755 index 000000000..1372acb8e --- /dev/null +++ b/dev/ci/ci-mtac2.sh @@ -0,0 +1,19 @@ +#!/usr/bin/env bash + +ci_dir="$(dirname "$0")" +. "${ci_dir}/ci-common.sh" + +unicoq_CI_DIR=${CI_BUILD_DIR}/unicoq +mtac2_CI_DIR=${CI_BUILD_DIR}/Mtac2 + +# Setup UniCoq + +git_checkout "${unicoq_CI_BRANCH}" "${unicoq_CI_GITURL}" "${unicoq_CI_DIR}" + +( cd "${unicoq_CI_DIR}" && coq_makefile -f Make -o Makefile && make && make install ) + +# Setup MetaCoq + +git_checkout "${mtac2_CI_BRANCH}" "${mtac2_CI_GITURL}" "${mtac2_CI_DIR}" + +( cd "${mtac2_CI_DIR}" && coq_makefile -f _CoqProject -o Makefile && make ) diff --git a/dev/ci/ci-pidetop.sh b/dev/ci/ci-pidetop.sh new file mode 100755 index 000000000..32cba0808 --- /dev/null +++ b/dev/ci/ci-pidetop.sh @@ -0,0 +1,22 @@ +#!/usr/bin/env bash + +# $0 is not the safest way, but... +ci_dir="$(dirname "$0")" +. "${ci_dir}/ci-common.sh" + +pidetop_CI_DIR="${CI_BUILD_DIR}/pidetop" + +git_checkout "${pidetop_CI_BRANCH}" "${pidetop_CI_GITURL}" "${pidetop_CI_DIR}" + +# Travis / Gitlab have different filesystem layout due to use of +# `-local`. We need to improve this divergence but if we use Dune this +# "local" oddity goes away automatically so not bothering... +if [ -d "$COQBIN/../lib/coq" ]; then + COQLIB="$COQBIN/../lib/coq/" +else + COQLIB="$COQBIN/../" +fi + +( cd "${pidetop_CI_DIR}" && jbuilder build @install ) + +echo -en '4\nexit' | "$pidetop_CI_DIR/_build/install/default/bin/pidetop" -coqlib "$COQLIB" -main-channel stdfds diff --git a/dev/ci/ci-quickchick.sh b/dev/ci/ci-quickchick.sh new file mode 100755 index 000000000..fc39e2685 --- /dev/null +++ b/dev/ci/ci-quickchick.sh @@ -0,0 +1,18 @@ +#!/usr/bin/env bash + +ci_dir="$(dirname "$0")" + +# This script could be included inside other ones +# Let's avoid to source ci-common twice in this case +if [ -z "${CI_BUILD_DIR}" ]; +then + . "${ci_dir}/ci-common.sh" +fi + +quickchick_CI_DIR="${CI_BUILD_DIR}/Quickchick" + +install_ssreflect + +git_checkout "${quickchick_CI_BRANCH}" "${quickchick_CI_GITURL}" "${quickchick_CI_DIR}" + +( cd "${quickchick_CI_DIR}" && make && make install) diff --git a/dev/ci/ci-sf.sh b/dev/ci/ci-sf.sh index 4f7e9517f..58bbb7229 100755 --- a/dev/ci/ci-sf.sh +++ b/dev/ci/ci-sf.sh @@ -1,12 +1,12 @@ #!/usr/bin/env bash ci_dir="$(dirname "$0")" -source ${ci_dir}/ci-common.sh +. "${ci_dir}/ci-common.sh" -mkdir -p ${CI_BUILD_DIR} && cd ${CI_BUILD_DIR} -wget -qO- ${sf_lf_CI_TARURL} | tar xvz -wget -qO- ${sf_plf_CI_TARURL} | tar xvz -wget -qO- ${sf_vfa_CI_TARURL} | tar xvz +mkdir -p "${CI_BUILD_DIR}" && cd "${CI_BUILD_DIR}" || exit 1 +wget -qO- "${sf_lf_CI_TARURL}" | tar xvz +wget -qO- "${sf_plf_CI_TARURL}" | tar xvz +wget -qO- "${sf_vfa_CI_TARURL}" | tar xvz sed -i.bak '1i From Coq Require Extraction.' lf/Extraction.v sed -i.bak '1i From Coq Require Extraction.' vfa/Extract.v diff --git a/dev/ci/ci-template.sh b/dev/ci/ci-template.sh index 25da01a82..e77a55304 100755 --- a/dev/ci/ci-template.sh +++ b/dev/ci/ci-template.sh @@ -1,12 +1,12 @@ #!/usr/bin/env bash ci_dir="$(dirname "$0")" -source ${ci_dir}/ci-common.sh +. "${ci_dir}/ci-common.sh" Template_CI_BRANCH=master Template_CI_GITURL=https://github.com/Template/Template -Template_CI_DIR=${CI_BUILD_DIR}/Template +Template_CI_DIR="${CI_BUILD_DIR}/Template" -git_checkout ${Template_CI_BRANCH} ${Template_CI_GITURL} ${Template_CI_DIR} +git_checkout "${Template_CI_BRANCH}" "${Template_CI_GITURL}" "${Template_CI_DIR}" -( cd ${Template_CI_DIR} && make ) +( cd "${Template_CI_DIR}" && make ) diff --git a/dev/ci/ci-tlc.sh b/dev/ci/ci-tlc.sh index 8ecd8c441..31387c8dd 100755 --- a/dev/ci/ci-tlc.sh +++ b/dev/ci/ci-tlc.sh @@ -1,10 +1,10 @@ #!/usr/bin/env bash ci_dir="$(dirname "$0")" -source ${ci_dir}/ci-common.sh +. "${ci_dir}/ci-common.sh" -tlc_CI_DIR=${CI_BUILD_DIR}/tlc +tlc_CI_DIR="${CI_BUILD_DIR}/tlc" -git_checkout ${tlc_CI_BRANCH} ${tlc_CI_GITURL} ${tlc_CI_DIR} +git_checkout "${tlc_CI_BRANCH}" "${tlc_CI_GITURL}" "${tlc_CI_DIR}" -( cd ${tlc_CI_DIR} && make ) +( cd "${tlc_CI_DIR}" && make ) diff --git a/dev/ci/ci-unimath.sh b/dev/ci/ci-unimath.sh index 66b56add7..aa20fe1ff 100755 --- a/dev/ci/ci-unimath.sh +++ b/dev/ci/ci-unimath.sh @@ -1,14 +1,10 @@ #!/usr/bin/env bash ci_dir="$(dirname "$0")" -source ${ci_dir}/ci-common.sh +. "${ci_dir}/ci-common.sh" -UniMath_CI_DIR=${CI_BUILD_DIR}/UniMath +UniMath_CI_DIR="${CI_BUILD_DIR}/UniMath" -git_checkout ${UniMath_CI_BRANCH} ${UniMath_CI_GITURL} ${UniMath_CI_DIR} - -( cd ${UniMath_CI_DIR} && \ - sed -i.bak '/Folds/d' Makefile && \ - sed -i.bak '/HomologicalAlgebra/d' Makefile && \ - make BUILD_COQ=no ) +git_checkout "${UniMath_CI_BRANCH}" "${UniMath_CI_GITURL}" "${UniMath_CI_DIR}" +( cd "${UniMath_CI_DIR}" && make BUILD_COQ=no ) diff --git a/dev/ci/ci-vst.sh b/dev/ci/ci-vst.sh index 5760fbafb..7a097eaab 100755 --- a/dev/ci/ci-vst.sh +++ b/dev/ci/ci-vst.sh @@ -1,13 +1,10 @@ #!/usr/bin/env bash ci_dir="$(dirname "$0")" -source ${ci_dir}/ci-common.sh +. "${ci_dir}/ci-common.sh" -VST_CI_DIR=${CI_BUILD_DIR}/VST +VST_CI_DIR="${CI_BUILD_DIR}/VST" -# opam install -j ${NJOBS} -y menhir -git_checkout ${VST_CI_BRANCH} ${VST_CI_GITURL} ${VST_CI_DIR} +git_checkout "${VST_CI_BRANCH}" "${VST_CI_GITURL}" "${VST_CI_DIR}" -# Targets are: msl veric floyd progs , we remove progs to save time -# Patch to avoid the upper version limit -( cd ${VST_CI_DIR} && make IGNORECOQVERSION=true .loadpath version.vo msl veric floyd ) +( cd "${VST_CI_DIR}" && make IGNORECOQVERSION=true ) diff --git a/dev/ci/docker/README.md b/dev/ci/docker/README.md new file mode 100644 index 000000000..919e2a735 --- /dev/null +++ b/dev/ci/docker/README.md @@ -0,0 +1,36 @@ +## Overall Docker Setup for Coq's CI. + +This directory provides Docker images to be used by Coq's CI. The +images do support Docker autobuild on `hub.docker.com` and Gitlab's +private registry. + +Gitlab CI will build and tag a Docker by default for every job if the +`SKIP_DOCKER` variable is not set to `false`. In Coq's CI, this +variable is usually set to `false` indeed to avoid booting a useless +job. + +## Manual Building + +You can also manually build and push any image: + +- Build the image `docker build -t base:$VERSION .` + +To upload/push to your hub: + +- Create a https://hub.docker.com account. +- Login into your space `docker login --username=$USER` +- Push the image: + + `docker tag base:$VERSION $USER/base:$VERSION` + + `docker push $USER/base:$VERSION` + +## Debugging / Misc + +To open a shell inside an image do `docker run -ti --entrypoint /bin/bash <imageID>` + +Each `RUN` command creates an "layer", thus a Docker build is +incremental and it always help to put things updated more often at the +end. + +## Possible Improvements: + +- Use ARG for customizing versions, centralize variable setup; diff --git a/dev/ci/docker/bionic_coq/Dockerfile b/dev/ci/docker/bionic_coq/Dockerfile new file mode 100644 index 000000000..1a83593f5 --- /dev/null +++ b/dev/ci/docker/bionic_coq/Dockerfile @@ -0,0 +1,54 @@ +# CACHEKEY: "bionic_coq-V2018-06-04-V2" +# ^^ Update when modifying this file. + +FROM ubuntu:bionic +LABEL maintainer="e@x80.org" + +ENV DEBIAN_FRONTEND="noninteractive" + +RUN apt-get update -qq && apt-get install -y -qq m4 wget time gcc-multilib opam \ + libgtk2.0-dev libgtksourceview2.0-dev \ + texlive-latex-extra texlive-fonts-recommended texlive-science \ + python3-sphinx python3-pexpect python3-sphinx-rtd-theme python3-bs4 python3-sphinxcontrib.bibtex python3-pip + +RUN pip3 install antlr4-python3-runtime + +# Basic OPAM setup +ENV NJOBS="2" \ + OPAMROOT=/root/.opamcache \ + OPAMROOTISOK="true" + +# Base opam is the set of base packages required by Coq +ENV COMPILER="4.02.3" + +RUN opam init -a -y -j $NJOBS --compiler="$COMPILER" default https://opam.ocaml.org && eval $(opam config env) && opam update + +# Common OPAM packages. +# `num` does not have a version number as the right version to install varies +# with the compiler version. +ENV BASE_OPAM="num ocamlfind.1.8.0 jbuilder.1.0+beta20 ounit.2.0.8" \ + CI_OPAM="menhir.20180530 elpi.1.0.3 ocamlgraph.1.8.8" + +# BASE switch; CI_OPAM contains Coq's CI dependencies. +ENV CAMLP5_VER="6.14" \ + COQIDE_OPAM="lablgtk.2.18.5 conf-gtksourceview.2" + +RUN opam switch -y -j $NJOBS "$COMPILER" && eval $(opam config env) && \ + opam install -j $NJOBS $BASE_OPAM camlp5.$CAMLP5_VER $COQIDE_OPAM $CI_OPAM + +# base+32bit switch +RUN opam switch -y -j $NJOBS "${COMPILER}+32bit" && eval $(opam config env) && \ + opam install -j $NJOBS $BASE_OPAM camlp5.$CAMLP5_VER + +# EDGE switch +ENV COMPILER_EDGE="4.06.1" \ + CAMLP5_VER_EDGE="7.05" \ + COQIDE_OPAM_EDGE="lablgtk.2.18.6 conf-gtksourceview.2" + +RUN opam switch -y -j $NJOBS $COMPILER_EDGE && eval $(opam config env) && \ + opam install -j $NJOBS $BASE_OPAM camlp5.$CAMLP5_VER_EDGE $COQIDE_OPAM_EDGE + +# EDGE+flambda switch, we install CI_OPAM as to be able to use +# `ci-template-flambda` with everything. +RUN opam switch -y -j $NJOBS "${COMPILER_EDGE}+flambda" && eval $(opam config env) && \ + opam install -j $NJOBS $BASE_OPAM camlp5.$CAMLP5_VER_EDGE $COQIDE_OPAM_EDGE $CI_OPAM diff --git a/dev/ci/gitlab.bat b/dev/ci/gitlab.bat new file mode 100644 index 000000000..70278e6d0 --- /dev/null +++ b/dev/ci/gitlab.bat @@ -0,0 +1,50 @@ +@ECHO OFF + +REM This script builds and signs the Windows packages on Gitlab + +if %ARCH% == 32 ( + SET ARCHLONG=i686 + SET CYGROOT=C:\cygwin + SET SETUP=setup-x86.exe +) + +if %ARCH% == 64 ( + SET ARCHLONG=x86_64 + SET CYGROOT=C:\cygwin64 + SET SETUP=setup-x86_64.exe +) + +powershell -Command "(New-Object Net.WebClient).DownloadFile('http://www.cygwin.com/%SETUP%', '%SETUP%')" +SET CYGCACHE=%CYGROOT%\var\cache\setup +SET CI_PROJECT_DIR_MFMT=%CI_PROJECT_DIR:\=/% +SET CI_PROJECT_DIR_CFMT=%CI_PROJECT_DIR_MFMT:C:/=/cygdrive/c/% +SET DESTCOQ=C:\coq%ARCH%_inst +SET COQREGTESTING=Y +SET PATH=%PATH%;C:\Program Files\7-Zip\;C:\Program Files\Microsoft SDKs\Windows\v7.1\Bin + +if exist %CYGROOT%\build\ rd /s /q %CYGROOT%\build +if exist %DESTCOQ%\ rd /s /q %DESTCOQ% + +call %CI_PROJECT_DIR%\dev\build\windows\MakeCoq_MinGW.bat -threads=1 ^ + -arch=%ARCH% -installer=Y -coqver=%CI_PROJECT_DIR_CFMT% ^ + -destcyg=%CYGROOT% -destcoq=%DESTCOQ% -cygcache=%CYGCACHE% ^ + -addon=bignums -make=N ^ + -setup %CI_PROJECT_DIR%\%SETUP% || GOTO ErrorExit + +copy "%CYGROOT%\build\coq-local\dev\nsis\*.exe" dev\nsis || GOTO ErrorExit +7z a coq-opensource-archive-windows-%ARCHLONG%.zip %CYGROOT%\build\tarballs\* || GOTO ErrorExit + +REM DO NOT echo the signing command below, as this would leak secrets in the logs +IF DEFINED WIN_CERTIFICATE_PATH ( + IF DEFINED WIN_CERTIFICATE_PASSWORD ( + ECHO Signing package + @signtool sign /f %WIN_CERTIFICATE_PATH% /p %WIN_CERTIFICATE_PASSWORD% dev\nsis\*.exe + signtool verify /pa dev\nsis\*.exe + ) +) + +GOTO :EOF + +:ErrorExit + ECHO ERROR %0 failed + EXIT /b 1 diff --git a/dev/ci/user-overlays/00664-herbelin-master+change-for-coq-pr664-compatibility.sh b/dev/ci/user-overlays/00664-herbelin-master+change-for-coq-pr664-compatibility.sh new file mode 100644 index 000000000..9d96b6d4c --- /dev/null +++ b/dev/ci/user-overlays/00664-herbelin-master+change-for-coq-pr664-compatibility.sh @@ -0,0 +1,4 @@ + if [ "$CI_PULL_REQUEST" = "664" ] || [ "$CI_BRANCH" = "trunk+fix-5500-too-weak-test-return-clause" ]; then + fiat_parsers_CI_BRANCH=master+change-for-coq-pr664-compatibility + fiat_parsers_CI_GITURL=https://github.com/herbelin/fiat +fi diff --git a/dev/ci/user-overlays/00669-maximedenes-ssr-merge.sh b/dev/ci/user-overlays/00669-maximedenes-ssr-merge.sh index 7716bcb59..e9ba11414 100644 --- a/dev/ci/user-overlays/00669-maximedenes-ssr-merge.sh +++ b/dev/ci/user-overlays/00669-maximedenes-ssr-merge.sh @@ -1,3 +1,5 @@ +#!/bin/sh + if [ "$CI_PULL_REQUEST" = "669" ] || [ "$CI_BRANCH" = "ssr-merge" ]; then mathcomp_CI_BRANCH=ssr-merge mathcomp_CI_GITURL=https://github.com/maximedenes/math-comp.git diff --git a/dev/ci/user-overlays/06405-maximedenes-rm-local-polymorphic-flag.sh b/dev/ci/user-overlays/06405-maximedenes-rm-local-polymorphic-flag.sh deleted file mode 100644 index c2e367038..000000000 --- a/dev/ci/user-overlays/06405-maximedenes-rm-local-polymorphic-flag.sh +++ /dev/null @@ -1,4 +0,0 @@ -if [ "$CI_PULL_REQUEST" = "6405" ] || [ "$CI_BRANCH" = "rm-local-polymorphic-flag" ]; then - Equations_CI_BRANCH=rm-local-polymorphic-flag - Equations_CI_GITURL=https://github.com/maximedenes/Coq-Equations -fi diff --git a/dev/ci/user-overlays/06454-ejgallego-evar+strict_to_constr.sh b/dev/ci/user-overlays/06454-ejgallego-evar+strict_to_constr.sh new file mode 100644 index 000000000..f4cb71cf1 --- /dev/null +++ b/dev/ci/user-overlays/06454-ejgallego-evar+strict_to_constr.sh @@ -0,0 +1,8 @@ +if [ "$CI_PULL_REQUEST" = "6454" ] || [ "$CI_BRANCH" = "evar+strict_to_constr" ]; then + + # ltac2_CI_BRANCH=econstr+more_fix + # ltac2_CI_GITURL=https://github.com/ejgallego/ltac2 + + Equations_CI_BRANCH=evar+strict_to_constr + Equations_CI_GITURL=https://github.com/ejgallego/Coq-Equations +fi diff --git a/dev/ci/user-overlays/06482-ppedrot-check-poly-effects.sh b/dev/ci/user-overlays/06482-ppedrot-check-poly-effects.sh deleted file mode 100644 index 78789a6fc..000000000 --- a/dev/ci/user-overlays/06482-ppedrot-check-poly-effects.sh +++ /dev/null @@ -1,4 +0,0 @@ -if [ "$TRAVIS_PULL_REQUEST" = "6483" ] || [ "$TRAVIS_BRANCH" = "check-poly-effects" ]; then - HoTT_CI_BRANCH=check-poly-effects - HoTT_CI_GITURL=https://github.com/ppedrot/HoTT.git -fi diff --git a/dev/ci/user-overlays/06493-gares-API-remove-big-file.sh b/dev/ci/user-overlays/06493-gares-API-remove-big-file.sh deleted file mode 100644 index 9677b3525..000000000 --- a/dev/ci/user-overlays/06493-gares-API-remove-big-file.sh +++ /dev/null @@ -1,8 +0,0 @@ -if [ "$CI_PULL_REQUEST" = "6493" ] || [ "$CI_BRANCH" = "API/remove-big-file" ]; then - Equations_CI_BRANCH=API-removal - Equations_CI_GITURL=https://github.com/gares/Coq-Equations.git - coq_dpdgraph_CI_BRANCH=API-removal - coq_dpdgraph_CI_GITURL=https://github.com/gares/coq-dpdgraph.git - ltac2_CI_BRANCH=API-removal - ltac2_CI_GITURL=https://github.com/gares/ltac2.git -fi diff --git a/dev/ci/user-overlays/06511-ejgallego-econstr+more_fix.sh b/dev/ci/user-overlays/06511-ejgallego-econstr+more_fix.sh deleted file mode 100644 index 4b681909d..000000000 --- a/dev/ci/user-overlays/06511-ejgallego-econstr+more_fix.sh +++ /dev/null @@ -1,7 +0,0 @@ - if [ "$CI_PULL_REQUEST" = "6511" ] || [ "$CI_BRANCH" = "econstr+more_fix" ]; then - ltac2_CI_BRANCH=econstr+more_fix - ltac2_CI_GITURL=https://github.com/ejgallego/ltac2 - - Equations_CI_BRANCH=econstr+more_fix - Equations_CI_GITURL=https://github.com/ejgallego/Coq-Equations -fi diff --git a/dev/ci/user-overlays/06535-fix-push-rel-to-named.sh b/dev/ci/user-overlays/06535-fix-push-rel-to-named.sh deleted file mode 100644 index 8a50fb111..000000000 --- a/dev/ci/user-overlays/06535-fix-push-rel-to-named.sh +++ /dev/null @@ -1,4 +0,0 @@ -if [ "$CI_PULL_REQUEST" = "6535" ] || [ "$CI_BRANCH" = "fix-push-rel-to-named" ]; then - Equations_CI_BRANCH=fix-6535 - Equations_CI_GITURL=https://github.com/ppedrot/Coq-Equations -fi diff --git a/dev/ci/user-overlays/06676-gares-proofview-goals-come-with-a-state.sh b/dev/ci/user-overlays/06676-gares-proofview-goals-come-with-a-state.sh deleted file mode 100644 index 2451657d4..000000000 --- a/dev/ci/user-overlays/06676-gares-proofview-goals-come-with-a-state.sh +++ /dev/null @@ -1,6 +0,0 @@ -if [ "$CI_PULL_REQUEST" = "6676" ] || [ "$CI_BRANCH" = "proofview/goal-w-state" ]; then - ltac2_CI_BRANCH=fix-for/6676 - ltac2_CI_GITURL=https://github.com/gares/ltac2.git - Equations_CI_BRANCH=fix-for/6676 - Equations_CI_GITURL=https://github.com/gares/Coq-Equations.git -fi diff --git a/dev/ci/user-overlays/06686-ccnv-no-proj.sh b/dev/ci/user-overlays/06686-ccnv-no-proj.sh deleted file mode 100644 index 3a3ab44e0..000000000 --- a/dev/ci/user-overlays/06686-ccnv-no-proj.sh +++ /dev/null @@ -1,4 +0,0 @@ -if [ "$CI_PULL_REQUEST" = "6686" ] || [ "$CI_BRANCH" = "ccnv-no-proj" ]; then - Equations_CI_BRANCH=ccnv-fixes - Equations_CI_GITURL=https://github.com/SkySkimmer/Coq-Equations -fi diff --git a/dev/ci/user-overlays/06745-ejgallego-located+vernac.sh b/dev/ci/user-overlays/06745-ejgallego-located+vernac.sh deleted file mode 100644 index d1d61fec2..000000000 --- a/dev/ci/user-overlays/06745-ejgallego-located+vernac.sh +++ /dev/null @@ -1,13 +0,0 @@ -if [ "$CI_PULL_REQUEST" = "6745" ] || [ "$CI_BRANCH" = "located+vernac" ]; then - ltac2_CI_BRANCH=located+vernac - ltac2_CI_GITURL=https://github.com/ejgallego/ltac2 - - Equations_CI_BRANCH=located+vernac - Equations_CI_GITURL=https://github.com/ejgallego/Coq-Equations - - fiat_parsers_CI_BRANCH=located+vernac - fiat_parsers_CI_GITURL=https://github.com/ejgallego/fiat - - Elpi_CI_BRANCH=located+vernac - Elpi_CI_GITURL=https://github.com/ejgallego/coq-elpi.git -fi diff --git a/dev/ci/user-overlays/06775-univ-cumul-weak.sh b/dev/ci/user-overlays/06775-univ-cumul-weak.sh deleted file mode 100644 index 8afcbf78a..000000000 --- a/dev/ci/user-overlays/06775-univ-cumul-weak.sh +++ /dev/null @@ -1,4 +0,0 @@ -if [ "$CI_PULL_REQUEST" = "6775" ] || [ "$CI_BRANCH" = "univ-cumul" ]; then - Elpi_CI_BRANCH=coq-master - Elpi_CI_GITURL=https://github.com/SkySkimmer/coq-elpi.git -fi diff --git a/dev/ci/user-overlays/06831-ejgallego-located+vernac_2.sh b/dev/ci/user-overlays/06831-ejgallego-located+vernac_2.sh deleted file mode 100644 index df3e9cef2..000000000 --- a/dev/ci/user-overlays/06831-ejgallego-located+vernac_2.sh +++ /dev/null @@ -1,14 +0,0 @@ -if [ "$CI_PULL_REQUEST" = "6831" ] || [ "$CI_BRANCH" = "located+vernac_2" ]; then - - ltac2_CI_BRANCH=located+vernac_2 - ltac2_CI_GITURL=https://github.com/ejgallego/ltac2 - - Equations_CI_BRANCH=located+vernac_2 - Equations_CI_GITURL=https://github.com/ejgallego/Coq-Equations - - # fiat_parsers_CI_BRANCH=located+vernac - # fiat_parsers_CI_GITURL=https://github.com/ejgallego/fiat - - Elpi_CI_BRANCH=located+vernac_2 - Elpi_CI_GITURL=https://github.com/ejgallego/coq-elpi.git -fi diff --git a/dev/ci/user-overlays/06837-ejgallego-located+libnames.sh b/dev/ci/user-overlays/06837-ejgallego-located+libnames.sh deleted file mode 100644 index a785290e7..000000000 --- a/dev/ci/user-overlays/06837-ejgallego-located+libnames.sh +++ /dev/null @@ -1,15 +0,0 @@ -if [ "$CI_PULL_REQUEST" = "6837" ] || [ "$CI_BRANCH" = "located+libnames" ]; then - - ltac2_CI_BRANCH=located+libnames - ltac2_CI_GITURL=https://github.com/ejgallego/ltac2 - - Equations_CI_BRANCH=located+libnames - Equations_CI_GITURL=https://github.com/ejgallego/Coq-Equations - - Elpi_CI_BRANCH=located+libnames - Elpi_CI_GITURL=https://github.com/ejgallego/coq-elpi.git - - coq_dpdgraph_CI_BRANCH=located+libnames - coq_dpdgraph_CI_GITURL=https://github.com/ejgallego/coq-dpdgraph.git - -fi diff --git a/dev/ci/user-overlays/06859-ejgallego-stm+top.sh b/dev/ci/user-overlays/06859-ejgallego-stm+top.sh new file mode 100644 index 000000000..b22ab3630 --- /dev/null +++ b/dev/ci/user-overlays/06859-ejgallego-stm+top.sh @@ -0,0 +1,9 @@ +#!/bin/sh + +if [ "$CI_PULL_REQUEST" = "6859" ] || [ "$CI_BRANCH" = "stm+top" ] || \ + [ "$CI_PULL_REQUEST" = "7543" ] || [ "$CI_BRANCH" = "ide+split" ] ; then + + pidetop_CI_BRANCH=stm+top + pidetop_CI_GITURL=https://bitbucket.org/ejgallego/pidetop.git + +fi diff --git a/dev/ci/user-overlays/06869-ejgallego-ssr+correct_packing.sh b/dev/ci/user-overlays/06869-ejgallego-ssr+correct_packing.sh deleted file mode 100644 index 5dedca0ca..000000000 --- a/dev/ci/user-overlays/06869-ejgallego-ssr+correct_packing.sh +++ /dev/null @@ -1,12 +0,0 @@ -if [ "$CI_PULL_REQUEST" = "6869" ] || [ "$CI_BRANCH" = "ssr+correct_packing" ]; then - - Equations_CI_BRANCH=ssr+correct_packing - Equations_CI_GITURL=https://github.com/ejgallego/Coq-Equations - - ltac2_CI_BRANCH=ssr+correct_packing - ltac2_CI_GITURL=https://github.com/ejgallego/ltac2 - - Elpi_CI_BRANCH=ssr+correct_packing - Elpi_CI_GITURL=https://github.com/ejgallego/coq-elpi.git - -fi diff --git a/dev/ci/user-overlays/06923-ppedrot-export-options.sh b/dev/ci/user-overlays/06923-ppedrot-export-options.sh deleted file mode 100644 index 333a9e84b..000000000 --- a/dev/ci/user-overlays/06923-ppedrot-export-options.sh +++ /dev/null @@ -1,7 +0,0 @@ -if [ "$CI_PULL_REQUEST" = "6923" ] || [ "$CI_BRANCH" = "export-options" ]; then - ltac2_CI_BRANCH=export-options - ltac2_CI_GITURL=https://github.com/ppedrot/ltac2 - - Equations_CI_BRANCH=export-options - Equations_CI_GITURL=https://github.com/ppedrot/Coq-Equations -fi diff --git a/dev/ci/user-overlays/07099-ppedrot-unification-returns-option.sh b/dev/ci/user-overlays/07099-ppedrot-unification-returns-option.sh new file mode 100644 index 000000000..e6c48d10a --- /dev/null +++ b/dev/ci/user-overlays/07099-ppedrot-unification-returns-option.sh @@ -0,0 +1,4 @@ +if [ "$CI_PULL_REQUEST" = "7099" ] || [ "$CI_BRANCH" = "unification-returns-option" ]; then + Equations_CI_BRANCH=unification-returns-option + Equations_CI_GITURL=https://github.com/ppedrot/Coq-Equations +fi diff --git a/dev/ci/user-overlays/07136-evar-map-econstr.sh b/dev/ci/user-overlays/07136-evar-map-econstr.sh new file mode 100644 index 000000000..06aa62726 --- /dev/null +++ b/dev/ci/user-overlays/07136-evar-map-econstr.sh @@ -0,0 +1,7 @@ +if [ "$CI_PULL_REQUEST" = "7136" ] || [ "$CI_BRANCH" = "evar-map-econstr" ]; then + Equations_CI_BRANCH=8.9+alpha + Equations_CI_GITURL=https://github.com/SkySkimmer/Coq-Equations.git + + Elpi_CI_BRANCH=coq-7136 + Elpi_CI_GITURL=https://github.com/SkySkimmer/coq-elpi.git +fi diff --git a/dev/ci/user-overlays/07152-ejgallego-api+vernac_expr_iso.sh b/dev/ci/user-overlays/07152-ejgallego-api+vernac_expr_iso.sh new file mode 100644 index 000000000..7e554684e --- /dev/null +++ b/dev/ci/user-overlays/07152-ejgallego-api+vernac_expr_iso.sh @@ -0,0 +1,12 @@ +if [ "$CI_PULL_REQUEST" = "7152" ] || [ "$CI_BRANCH" = "api+vernac_expr_iso" ]; then + + # Equations_CI_BRANCH=ssr+correct_packing + # Equations_CI_GITURL=https://github.com/ejgallego/Coq-Equations + + # ltac2_CI_BRANCH=ssr+correct_packing + # ltac2_CI_GITURL=https://github.com/ejgallego/ltac2 + + Elpi_CI_BRANCH=api+vernac_expr_iso + Elpi_CI_GITURL=https://github.com/ejgallego/coq-elpi.git + +fi diff --git a/dev/ci/user-overlays/07196-ejgallego-tactics+push_fix_naming_out.sh b/dev/ci/user-overlays/07196-ejgallego-tactics+push_fix_naming_out.sh new file mode 100644 index 000000000..ea9cd8ee0 --- /dev/null +++ b/dev/ci/user-overlays/07196-ejgallego-tactics+push_fix_naming_out.sh @@ -0,0 +1,21 @@ +if [ "$CI_PULL_REQUEST" = "7196" ] || [ "$CI_BRANCH" = "tactics+push_fix_naming_out" ] || [ "$CI_BRANCH" = "pr-7196" ]; then + + # Needed overlays: https://gitlab.com/coq/coq/pipelines/21244550 + # + # equations + # ltac2 + + # The below developments should instead use a backwards compatible fix. + # + # color + # iris-lambda-rust + # math-classes + # formal-topology + + ltac2_CI_BRANCH=tactics+push_fix_naming_out + ltac2_CI_GITURL=https://github.com/ejgallego/ltac2 + + Equations_CI_BRANCH=tactics+push_fix_naming_out + Equations_CI_GITURL=https://github.com/ejgallego/Coq-Equations + +fi diff --git a/dev/ci/user-overlays/07213-ppedrot-fast-constr-match-no-context.sh b/dev/ci/user-overlays/07213-ppedrot-fast-constr-match-no-context.sh new file mode 100644 index 000000000..517088a24 --- /dev/null +++ b/dev/ci/user-overlays/07213-ppedrot-fast-constr-match-no-context.sh @@ -0,0 +1,6 @@ +if [ "$CI_PULL_REQUEST" = "7213" ] || [ "$CI_BRANCH" = "fast-constr-match-no-context" ]; then + + ltac2_CI_BRANCH=fast-constr-match-no-context + ltac2_CI_GITURL=https://github.com/ppedrot/ltac2 + +fi diff --git a/dev/ci/user-overlays/07495-gares-elpi-test-bug.sh b/dev/ci/user-overlays/07495-gares-elpi-test-bug.sh new file mode 100644 index 000000000..6939ead2b --- /dev/null +++ b/dev/ci/user-overlays/07495-gares-elpi-test-bug.sh @@ -0,0 +1,8 @@ +if [ "$CI_PULL_REQUEST" = "7495" ] || [ "$CI_BRANCH" = "fix-restrict" ]; then + + # this branch contains a commit not present on coq-master that triggers + # the universe restriction bug #7472 + Elpi_CI_BRANCH=overlay-7495 + Elpi_CI_GITURL=https://github.com/LPCIC/coq-elpi.git + +fi diff --git a/dev/ci/user-overlays/07558-ejgallego-vernac+move_parser.sh b/dev/ci/user-overlays/07558-ejgallego-vernac+move_parser.sh new file mode 100644 index 000000000..115f29f1e --- /dev/null +++ b/dev/ci/user-overlays/07558-ejgallego-vernac+move_parser.sh @@ -0,0 +1,14 @@ +if [ "$CI_PULL_REQUEST" = "7558" ] || [ "$CI_BRANCH" = "vernac+move_parser" ]; then + + _OVERLAY_BRANCH=vernac+move_parser + + Equations_CI_BRANCH="$_OVERLAY_BRANCH" + Equations_CI_GITURL=https://github.com/ejgallego/Coq-Equations + + ltac2_CI_BRANCH="$_OVERLAY_BRANCH" + ltac2_CI_GITURL=https://github.com/ejgallego/ltac2 + + mtac2_CI_BRANCH="$_OVERLAY_BRANCH" + mtac2_CI_GITURL=https://github.com/ejgallego/Mtac2 + +fi diff --git a/dev/ci/user-overlays/07677-ejgallego-misctypes+bye2.sh b/dev/ci/user-overlays/07677-ejgallego-misctypes+bye2.sh new file mode 100644 index 000000000..b4f716139 --- /dev/null +++ b/dev/ci/user-overlays/07677-ejgallego-misctypes+bye2.sh @@ -0,0 +1,8 @@ +_OVERLAY_BRANCH=misctypes+bye2 + +if [ "$CI_PULL_REQUEST" = "7677" ] || [ "$CI_BRANCH" = "_OVERLAY_BRANCH" ]; then + + Equations_CI_BRANCH="$_OVERLAY_BRANCH" + Equations_CI_GITURL=https://github.com/ejgallego/Coq-Equations + +fi diff --git a/dev/ci/user-overlays/README.md b/dev/ci/user-overlays/README.md index 9f0377cee..41212568d 100644 --- a/dev/ci/user-overlays/README.md +++ b/dev/ci/user-overlays/README.md @@ -1,16 +1,31 @@ # Add overlays for your pull requests in this directory -An overlay is a file containing very simple logic to test whether we are currently building a specific pull request or git branch (useful so that overlays work on your own fork) and which changes some of the variables whose default can be found in [`ci-basic-overlay.sh`](/dev/ci/ci-basic-overlay.sh). +When your pull request breaks an external project we test in our CI and you +have prepared a branch with the fix, you can add an "overlay" to your pull +request to test it with the adapted version of the external project. -The name of your overlay file should be of the form `five_digit_PR_number-GitHub_handle-branch_name.sh`. +An overlay is a file which defines where to look for the patched version so that +testing is possible. It redefines some variables from +[`ci-basic-overlay.sh`](../ci-basic-overlay.sh): +give the name of your branch using a `_CI_BRANCH` variable and the location of +your fork using a `_CI_GITURL` variable. + +Moreover, the file contains very simple logic to test the pull request number +or branch name and apply it only in this case. + +The name of your overlay file should start with a five-digit pull request +number, followed by a dash, anything (for instance your GitHub nickname +and the branch name), then a `.sh` extension (`[0-9]{5}-[a-zA-Z0-9-_]+.sh`). Example: `00669-maximedenes-ssr-merge.sh` containing ``` +#!/bin/sh + if [ "$CI_PULL_REQUEST" = "669" ] || [ "$CI_BRANCH" = "ssr-merge" ]; then mathcomp_CI_BRANCH=ssr-merge mathcomp_CI_GITURL=https://github.com/maximedenes/math-comp.git fi ``` -(`CI_PULL_REQUEST` and `CI_BRANCH` are set in [`ci-common.sh`](/dev/ci/ci-common.sh)) +(`CI_PULL_REQUEST` and `CI_BRANCH` are set in [`ci-common.sh`](../ci-common.sh)) diff --git a/dev/core.dbg b/dev/core.dbg index 57c136900..972ba701e 100644 --- a/dev/core.dbg +++ b/dev/core.dbg @@ -2,8 +2,8 @@ source camlp5.dbg load_printer threads.cma load_printer str.cma load_printer clib.cma -load_printer lib.cma load_printer dynlink.cma +load_printer lib.cma load_printer kernel.cma load_printer library.cma load_printer engine.cma @@ -16,5 +16,4 @@ load_printer tactics.cma load_printer vernac.cma load_printer stm.cma load_printer toplevel.cma -load_printer intf.cma load_printer ltac_plugin.cmo diff --git a/dev/doc/MERGING.md b/dev/doc/MERGING.md index 3a2df6a81..c0cd9c8cd 100644 --- a/dev/doc/MERGING.md +++ b/dev/doc/MERGING.md @@ -1,17 +1,17 @@ # Merging changes in Coq -This document describes how patches (submitted as pull requests -on the `master` branch) should be -merged into the main repository (https://github.com/coq/coq). +This document describes how patches, submitted as pull requests (PRs) on the +`master` branch, should be merged into the main repository +(https://github.com/coq/coq). ## Code owners -The [CODEOWNERS](/.github/CODEOWNERS) file describes, for each part of the +The [CODEOWNERS](../../.github/CODEOWNERS) file describes, for each part of the system, two owners. One is the principal maintainer of the component, the other is the secondary maintainer. -When a pull request is submitted, GitHub will automatically ask the principal -maintainer for a review. If the pull request touches several parts, all the +When a PR is submitted, GitHub will automatically ask the principal +maintainer for a review. If the PR touches several parts, all the corresponding principal maintainers will be asked for a review. Maintainers are never assigned as reviewer on their own PRs. @@ -43,17 +43,48 @@ A maintainer is expected to be reasonably reactive, but no specific timeframe is given for reviewing. (*) In case a component is touched in a trivial way (adding/removing one file in -a `Makefile`, etc), or by applying a systematic process (global renaming, -deprecationg propagation, etc) that has been reviewed globally, the assignee can +a `Makefile`, etc), or by applying a systematic refactoring process (global +renaming for instance) that has been reviewed globally, the assignee can say in a comment they think a review is not required and proceed with the merge. +### Breaking changes + +If the PR breaks compatibility of some external projects in CI, then fixes to +those external projects should have been prepared (cf. the relevant sub-section +in the [CI README](../ci/README.md#Breaking-changes) and the PR can be tested +with these fixes thanks to ["overlays"](../ci/user-overlays/README.md). + +Moreover the PR must absolutely update the [`CHANGES`](../../CHANGES) file. + +If overlays are missing, ask the author to prepare them and label the PR with +the [needs: overlay](https://github.com/coq/coq/labels/needs%3A%20overlay) label. + +When fixes are ready, there are two cases to consider: + +- For patches that are backward compatible (best scenario), you should get the + external project maintainers to integrate them before merging the PR. +- For patches that are not backward compatible (which is often the case when + patching plugins after an update to the Coq API), you can proceed to merge + the PR and then notify the external project maintainers they can merge the + patch. + ## Merging Once all reviewers approved the PR, the assignee is expected to check that CI completed without relevant failures, and that the PR comes with appropriate documentation and test cases. If not, they should leave a comment on the PR and put the approriate label. Otherwise, they are expected to merge the PR using the -[merge script](/dev/tools/merge-pr.sh). +[merge script](../tools/merge-pr.sh). + +When CI has a few failures which look spurious, restarting the corresponding +jobs is a good way of ensuring this was indeed the case. +To restart a job on Travis, you should connect using your GitHub account; +being part of the Coq organization on GitHub should give you the permission +to do so. +To restart a job on GitLab CI, you should sign into GitLab (this can be done +using a GitHub account); if you are part of the +[Coq organization on GitLab](https://gitlab.com/coq), you should see a "Retry" +button; otherwise, send a request to join the organization. When the PR has conflicts, the assignee can either: - ask the author to rebase the branch, fixing the conflicts @@ -70,7 +101,7 @@ To merge the PR proceed in the following way ``` $ git checkout master $ git pull -$ dev/tools/merge-pr XXXX +$ dev/tools/merge-pr.sh XXXX $ git push upstream ``` where `XXXX` is the number of the PR to be merged and `upstream` is the name @@ -89,29 +120,12 @@ DON'T USE the GitHub interface for merging, since it will prevent the automated backport script from operating properly, generates bad commit messages, and a messy history when there are conflicts. -### What to do if the PR has overlays - -If the PR breaks compatibility of some developments in CI, then the author must -have prepared overlays for these developments (see [`dev/ci/README.md`](/dev/ci/README.md)) -and the PR must absolutely update the `CHANGES` file. - -There are two cases to consider: - -- If the patch is backward compatible (best scenario), then you should get - upstream maintainers to integrate it before merging the PR. -- If the patch is not backward compatible (which is often the case when - patching plugins after an update to the Coq API), then you can proceed to - merge the PR and then notify upstream they can merge the patch. This is a - less preferable scenario because it is probably going to create - spurious CI failures for unrelated PRs. - ### Merge script dependencies The merge script passes option `-S` to `git merge` to ensure merge commits are signed. Consequently, it depends on the GnuPG command utility being -installed and a GPG key being available. Here is a short tutorial to -creating your own GPG key: -<https://ekaia.org/blog/2009/05/10/creating-new-gpgkey/> +installed and a GPG key being available. Here is a short documentation on +how to use GPG, git & GitHub: https://help.github.com/articles/signing-commits-with-gpg/. The script depends on a few other utilities. If you are a Nix user, the simplest way of getting them is to run `nix-shell` first. diff --git a/dev/doc/changes.md b/dev/doc/changes.md index ab78b0956..bb8189efc 100644 --- a/dev/doc/changes.md +++ b/dev/doc/changes.md @@ -1,3 +1,74 @@ +## Changes between Coq 8.8 and Coq 8.9 + +### ML API + +Misctypes + +- Syntax for universe sorts and kinds has been moved from `Misctypes` + to `Glob_term`, as these are turned into kernel terms by + `Pretyping`. + +Proof engine + +- More functions have been changed to use `EConstr`, notably the + functions in `Evd`, and in particular `Evd.define`. + + Note that the core function `EConstr.to_constr` now _enforces_ by + default that the resulting term is ground, that is to say, free of + Evars. This is usually what you want, as open terms should be of + type `EConstr.t` to benefit from the invariants the `EConstr` API is + meant to guarantee. + + In case you'd like to violate this API invariant, you can use the + `abort_on_undefined_evars` flag to `EConstr.to_constr`, but note + that setting this flag to false is deprecated so it is only meant to + be used as to help port pre-EConstr code. + +- A few type alias have been deprecated, in all cases the message + should indicate what the canonical form is. An important change is + the move of `Globnames.global_reference` to `Names.GlobRef.t`. + +- Unification API returns `evar_map option` instead of `bool * evar_map` + with the guarantee that the `evar_map` was unchanged if the boolean + was false. + +ML Libraries used by Coq + +- Introduction of a "Smart" module for collecting "smart*" functions, e.g. + Array.Smart.map. +- Uniformization of some names, e.g. Array.Smart.fold_left_map instead + of Array.smartfoldmap. + +Printer.ml API + +- The mechanism in Printer that allowed dynamically overriding pr_subgoals, + pr_subgoal and pr_goal was removed to simplify the code. It was + earlierly used by PCoq. + +Source code organization + +- We have eliminated / fused some redundant modules and relocated a + few interfaces files. The `intf` folder is gone, and now for example + `Constrexpr` is located in `interp/`, `Vernacexpr` in `vernac/` and + so on. Changes should be compatible, but in a few cases stricter + layering requirements may mean that functions have moved. In all + cases adapting is a matter of changing the module name. + +Vernacular commands + +- The implementation of vernacular commands has been refactored so it + is self-contained now, including the parsing and extension + mechanisms. This involves a couple of non-backward compatible + changes due to layering issues, where some functions have been moved + from `Pcoq` to `Pvernac` and from `Vernacexpr` to modules in + `tactics/`. In all cases adapting is a matter of changing the module + name. + +### Unit testing + + The test suite now allows writing unit tests against OCaml code in the Coq + code base. Those unit tests create a dependency on the OUnit test framework. + ## Changes between Coq 8.7 and Coq 8.8 ### Bug tracker @@ -74,6 +145,11 @@ Declaration of printers for arguments used only in vernac command happen. An alternative is to register the corresponding argument as a value, using "Geninterp.register_val0 wit None". +Types Alias deprecation and type relocation. + +- A few type alias have been deprecated, in all cases the message + should indicate what the canonical form is. + ### STM API The STM API has seen a general overhaul. The main change is the diff --git a/dev/doc/coq-src-description.txt b/dev/doc/coq-src-description.txt index b3d49b7e5..764d48295 100644 --- a/dev/doc/coq-src-description.txt +++ b/dev/doc/coq-src-description.txt @@ -17,12 +17,6 @@ toplevel Special components ------------------ -intf : - - Contains mli-only interfaces, many of them providing a.s.t. - used for dialog bewteen coq components. Ex: Constrexpr.constr_expr - produced by parsing and transformed by interp. - grammar : Camlp5 syntax extensions. The file grammar/grammar.cma is used diff --git a/dev/doc/debugging.md b/dev/doc/debugging.md index fd3cbd1bc..14a1cc693 100644 --- a/dev/doc/debugging.md +++ b/dev/doc/debugging.md @@ -47,7 +47,7 @@ Debugging with ocamldebug from Emacs 7. some hints: - To debug a failure/error/anomaly, add a breakpoint in - Vernac.vernac_com at the with clause of the "try ... interp com + `Vernac.interp_vernac` (in `toplevel/vernac.ml`) at the with clause of the "try ... interp com with ..." block, then go "back" a few steps to find where the failure/error/anomaly has been raised - Alternatively, for an error or an anomaly, add breakpoints in the middle diff --git a/dev/doc/primproj.md b/dev/doc/primproj.md new file mode 100644 index 000000000..ea76aeeab --- /dev/null +++ b/dev/doc/primproj.md @@ -0,0 +1,41 @@ +Primitive Projections +--------------------- + + | Proj of Projection.t * constr + +Projections are always applied to a term, which must be of a record +type (i.e. reducible to an inductive type `I params`). Type-checking, +reduction and conversion are fast (not as fast as they could be yet) +because we don't keep parameters around. As you can see, it's +currently a `constant` that is used here to refer to the projection, +that will change to an abstract `projection` type in the future. +Basically a projection constant records which inductive it is a +projection for, the number of params and the actual position in the +constructor that must be projected. For compatibility reason, we also +define an eta-expanded form (accessible from user syntax `@f`). The +constant_entry of a projection has both informations. Declaring a +record (under `Set Primitive Projections`) will generate such +definitions. The API to declare them is not stable at the moment, but +the inductive type declaration also knows about the projections, i.e. +a record inductive type decl contains an array of terms representing +the projections. This is used to implement eta-conversion for record +types (with at least one field and having all projections definable). +The canonical value being `Build_R (pn x) ... (pn x)`. Unification and +conversion work up to this eta rule. The records can also be universe +polymorphic of course, and we don't need to keep track of the universe +instance for the projections either. Projections are reduced _eagerly_ +everywhere, and introduce a new `Zproj` constructor in the abstract +machines that obeys both the delta (for the constant opacity) and iota +laws (for the actual reduction). Refolding works as well (afaict), but +there is a slight hack there related to universes (not projections). + +For the ML programmer, the biggest change is that pattern-matchings on +kind_of_term require an additional case, that is handled usually +exactly like an `App (Const p) arg`. + +There are slight hacks related to hints is well, to use the primitive +projection form of f when one does `Hint Resolve f`. Usually hint +resolve will typecheck the term, resulting in a partially applied +projection (disallowed), so we allow it to take +`constr_or_global_reference` arguments instead and special-case on +projections. Other tactic extensions might need similar treatment. diff --git a/dev/doc/release-process.md b/dev/doc/release-process.md new file mode 100644 index 000000000..1821a181f --- /dev/null +++ b/dev/doc/release-process.md @@ -0,0 +1,100 @@ +# Release process # + +## As soon as the previous version branched off master ## + +- [ ] Create a new issue to track the release process where you can copy-paste + the present checklist. +- [ ] Change the version name to the next major version and the magic numbers + (see [#7008](https://github.com/coq/coq/pull/7008/files)). +- [ ] Put the corresponding alpha tag using `git tag -s`. + The `VX.X+alpha` tag marks the first commit to be in `master` and not in the + branch of the previous version. +- [ ] Create the `X.X+beta1` milestone if it did not already exist. +- [ ] Decide the release calendar with the team (freeze date, beta date, final + release date) and put this information in the milestone (using the + description and due date fields). + +## About one month before the beta ## + +- [ ] Create the `X.X.0` milestone and set its due date. +- [ ] Send an announcement of the upcoming freeze on Coqdev and ask people to + remove from the beta milestone what they already know won't be ready on time + (possibly postponing to the `X.X.0` milestone for minor bug fixes, + infrastructure and documentation updates). +- [ ] Determine which issues should / must be fixed before the beta, add them + to the beta milestone, possibly with a + ["priority: blocker"](https://github.com/coq/coq/labels/priority%3A%20blocker) + label. Make sure that all these issues are assigned (and that the assignee + provides an ETA). +- [ ] Ping the development coordinator (**@mattam82**) to get him started on + the update to the Credits chapter of the reference manual. + See also [#7058](https://github.com/coq/coq/issues/7058). + The command to get the list of contributors for this version is + `git shortlog -s -n VX.X+alpha..master | cut -f2 | sort -k 2` + (the ordering is approximative as it will misplace people with middle names). + +## On the date of the feature freeze ## + +- [ ] Create the new version branch `vX.X` and + [protect it](https://github.com/coq/coq/settings/branches) + (activate the "Protect this branch", "Require pull request reviews before + merging" and "Restrict who can push to this branch" guards). +- [ ] Remove all remaining unmerged feature PRs from the beta milestone. +- [ ] Start a new project to track PR backporting. The proposed model is to + have a "X.X-only PRs" column for the rare PRs on the stable branch, a + "Request X.X inclusion" column for the PRs that were merged in `master` that + are to be considered for backporting, a "Waiting for CI" column to put the + PRs in the process of being backported, and "Shipped in ..." columns to put + what was backported. (The release manager is the person responsible for + merging PRs that target the version branch and backporting appropriate PRs + that are merged into `master`). + A message to **@coqbot** in the milestone description tells it to + automatically add merged PRs to the "Request X.X inclusion" column. +- [ ] Delay non-blocking issues to the appropriate milestone and ensure + blocking issues are solved. If required to solve some blocking issues, + it is possible to revert some feature PRs in the version branch only. + +## Before the beta release date ## + +- [ ] Ensure the Credits chapter has been updated. +- [ ] Ensure an empty `CompatXX.v` file has been created. +- [ ] Ensure that an appropriate version of the plugins we will distribute with + Coq has been tagged. +- [ ] Have some people test the recently auto-generated Windows and MacOS + packages. +- [ ] Change the version name from alpha to beta1 (see + [#7009](https://github.com/coq/coq/pull/7009/files)). + We generally do not update the magic numbers at this point. +- [ ] Put the `VX.X+beta1` tag using `git tag -s`. + +### These steps are the same for all releases (beta, final, patch-level) ### + +- [ ] Send an e-mail on Coqdev announcing that the tag has been put so that + package managers can start preparing package updates. +- [ ] Draft a release on GitHub. +- [ ] Get **@maximedenes** to sign the Windows and MacOS packages and + upload them on GitHub. +- [ ] Prepare a page of news on the website with the link to the GitHub release + (see [coq/www#63](https://github.com/coq/www/pull/63)). +- [ ] Upload the new version of the reference manual to the website. + *TODO: setup some continuous deployment for this.* +- [ ] Merge the website update, publish the release + and send annoucement e-mails. +- [ ] Ping **@Zimmi48** to publish a new version on Zenodo. + *TODO: automate this.* +- [ ] Close the milestone + +## At the final release time ## + +- [ ] Change the version name to X.X.0 and the magic numbers (see + [#7271](https://github.com/coq/coq/pull/7271/files)). +- [ ] Put the `VX.X.0` tag. + +Repeat the generic process documented above for all releases. + +- [ ] Switch the default version of the reference manual on the website. + +## At the patch-level release time ## + +We generally do not update the magic numbers at this point (see +[`2881a18`](https://github.com/coq/coq/commit/2881a18)). diff --git a/dev/doc/univpoly.txt b/dev/doc/universes.md index ca3d520c7..c276603ed 100644 --- a/dev/doc/univpoly.txt +++ b/dev/doc/universes.md @@ -1,11 +1,11 @@ -Notes on universe polymorphism and primitive projections, M. Sozeau -=================================================================== +Notes on universe polymorphism +------------------------------ -The new implementation of universe polymorphism and primitive -projections introduces a few changes to the API of Coq. First and -foremost, the term language changes, as global references now carry a -universe level substitution: +The implementation of universe polymorphism introduces a few changes +to the API of Coq. First and foremost, the term language changes, as +global references now carry a universe level substitution: +~~~ocaml type 'a puniverses = 'a * Univ.Instance.t type pconstant = constant puniverses type pinductive = inductive puniverses @@ -15,30 +15,31 @@ type constr = ... | Const of puniverses | Ind of pinductive | Constr of pconstructor - | Proj of constant * constr - +~~~ Universes -========= +--------- - Universe instances (an array of levels) gets substituted when +Universe instances (an array of levels) gets substituted when unfolding definitions, are used to typecheck and are unified according -to the rules in the ITP'14 paper on universe polymorphism in Coq. +to the rules in the ITP'14 paper on universe polymorphism in Coq. +~~~ocaml type Level.t = Set | Prop | Level of int * dirpath (* hashconsed *) type Instance.t = Level.t array type Universe.t = Level.t list (* hashconsed *) +~~~ The universe module defines modules and abstract types for levels, universes etc.. Structures are hashconsed (with a hack to take care -of the fact that deserialization breaks sharing). +of the fact that deserialization breaks sharing). - Definitions (constants, inductives) now carry around not only + Definitions (constants, inductives) now carry around not only constraints but also the universes they introduced (a Univ.UContext.t). -There is another kind of contexts [Univ.ContextSet.t], the latter has +There is another kind of contexts `Univ.ContextSet.t`, the latter has a set of universes, while the former has serialized the levels in an -array, and is used for polymorphic objects. Both have "reified" -constraints depending on global and local universes. +array, and is used for polymorphic objects. Both have "reified" +constraints depending on global and local universes. A polymorphic definition is abstract w.r.t. the variables in this context, while a monomorphic one (or template polymorphic) just adds the @@ -46,18 +47,18 @@ universes and constraints to the global universe context when it is put in the environment. No other universes than the global ones and the declared local ones are needed to check a declaration, hence the kernel does not produce any constraints anymore, apart from module -subtyping.... There are hence two conversion functions now: [check_conv] -and [infer_conv]: the former just checks the definition in the current env +subtyping.... There are hence two conversion functions now: `check_conv` +and `infer_conv`: the former just checks the definition in the current env (in which we usually push_universe_context of the associated context), -and [infer_conv] which produces constraints that were not implied by the +and `infer_conv` which produces constraints that were not implied by the ambient constraints. Ideally, that one could be put out of the kernel, -but currently module subtyping needs it. +but currently module subtyping needs it. Inference of universes is now done during refinement, and the evar_map carries the incrementally built universe context, starting from the -global universe constraints (see [Evd.from_env]). [Evd.conversion] is a -wrapper around [infer_conv] that will do the bookkeeping for you, it -uses [evar_conv_x]. There is a universe substitution being built +global universe constraints (see `Evd.from_env`). `Evd.conversion` is a +wrapper around `infer_conv` that will do the bookkeeping for you, it +uses `evar_conv_x`. There is a universe substitution being built incrementally according to the constraints, so one should normalize at the end of a proof (or during a proof) with that substitution just like we normalize evars. There are some nf_* functions in @@ -67,16 +68,16 @@ the universe constraints used in the term. It is heuristic but validity-preserving. No user-introduced universe (i.e. coming from a user-written anonymous Type) gets touched by this, only the fresh universes generated for each global application. Using - +~~~ocaml val pf_constr_of_global : Globnames.global_reference -> (constr -> tactic) -> tactic - +~~~ Is the way to make a constr out of a global reference in the new API. If they constr is polymorphic, it will add the necessary constraints to the evar_map. Even if a constr is not polymorphic, we have to take care of keeping track of its universes. Typically, using: - - mkApp (coq_id_function, [| A; a |]) - +~~~ocaml + mkApp (coq_id_function, [| A; a |]) +~~~ and putting it in a proof term is not enough now. One has to somehow show that A's type is in cumululativity relation with id's type argument, incurring a universe constraint. To do this, one can simply @@ -84,19 +85,19 @@ call Typing.resolve_evars env evdref c which will do some infer_conv to produce the right constraints and put them in the evar_map. Of course in some cases you might know from an invariant that no new constraint would be produced and get rid of it. Anyway the kernel will tell you if you -forgot some. As a temporary way out, [Universes.constr_of_global] allows +forgot some. As a temporary way out, `Universes.constr_of_global` allows you to make a constr from any non-polymorphic constant, but it will fail on polymorphic ones. Other than that, unification (w_unify and evarconv) now take account of universes and produce only well-typed evar_maps. -Some syntactic comparisons like the one used in [change] have to be -adapted to allow identification up-to-universes (when dealing with -polymorphic references), [make_eq_univs_test] is there to help. +Some syntactic comparisons like the one used in `change` have to be +adapted to allow identification up-to-universes (when dealing with +polymorphic references), `make_eq_univs_test` is there to help. In constr, there are actually many new comparison functions to deal with that: - +~~~ocaml (** [equal a b] is true if [a] equals [b] modulo alpha, casts, and application grouping *) val equal : constr -> constr -> bool @@ -105,7 +106,7 @@ val equal : constr -> constr -> bool application grouping and the universe equalities in [u]. *) val eq_constr_univs : constr Univ.check_function -(** [leq_constr_univs u a b] is [true] if [a] is convertible to [b] modulo +(** [leq_constr_univs u a b] is [true] if [a] is convertible to [b] modulo alpha, casts, application grouping and the universe inequalities in [u]. *) val leq_constr_univs : constr Univ.check_function @@ -120,47 +121,47 @@ val leq_constr_universes : constr -> constr -> bool Univ.universe_constrained (** [eq_constr_univs a b] [true, c] if [a] equals [b] modulo alpha, casts, application grouping and ignoring universe instances. *) val eq_constr_nounivs : constr -> constr -> bool - -The [_univs] versions are doing checking of universe constraints -according to a graph, while the [_universes] are producing (non-atomic) +~~~ +The `_univs` versions are doing checking of universe constraints +according to a graph, while the `_universes` are producing (non-atomic) universe constraints. The non-atomic universe constraints include the -[ULub] constructor: when comparing [f (* u1 u2 *) c] and [f (* u1' u2' -*) c] we add ULub constraints on [u1, u1'] and [u2, u2']. These are -treated specially: as unfolding [f] might not result in these +`ULub` constructor: when comparing `f (* u1 u2 *) c` and `f (* u1' u2' +*) c` we add ULub constraints on `u1, u1'` and `u2, u2'`. These are +treated specially: as unfolding `f` might not result in these unifications, we need to keep track of the fact that failure to satisfy them does not mean that the term are actually equal. This is used in -unification but probably not necessary to the average programmer. +unification but probably not necessary to the average programmer. Another issue for ML programmers is that tables of constrs now usually -need to take a [constr Univ.in_universe_context_set] instead, and -properly refresh the universes context when using the constr, e.g. using -Clenv.refresh_undefined_univs clenv or: - +need to take a `constr Univ.in_universe_context_set` instead, and +properly refresh the universes context when using the constr, e.g. using +Clenv.refresh_undefined_univs clenv or: +~~~ocaml (** Get fresh variables for the universe context. Useful to make tactics that manipulate constrs in universe contexts polymorphic. *) -val fresh_universe_context_set_instance : universe_context_set -> +val fresh_universe_context_set_instance : universe_context_set -> universe_level_subst * universe_context_set - -The substitution should be applied to the constr(s) under consideration, +~~~ +The substitution should be applied to the constr(s) under consideration, and the context_set merged with the current evar_map with: - +~~~ocaml val merge_context_set : rigid -> evar_map -> Univ.universe_context_set -> evar_map - -The [rigid] flag here should be [Evd.univ_flexible] most of the +~~~ +The `rigid` flag here should be `Evd.univ_flexible` most of the time. This means the universe levels of polymorphic objects in the -constr might get instantiated instead of generating equality constraints +constr might get instantiated instead of generating equality constraints (Evd.univ_rigid does that). -On this issue, I recommend forcing commands to take [global_reference]s +On this issue, I recommend forcing commands to take `global_reference`s only, the user can declare his specialized terms used as hints as constants and this is cleaner. Alas, backward-compatibility-wise, this is the only solution I found. In the case of global_references -only, it's just a matter of using [Evd.fresh_global] / -[pf_constr_of_global] to let the system take care of universes. +only, it's just a matter of using `Evd.fresh_global` / +`pf_constr_of_global` to let the system take care of universes. The universe graph -================== +------------------ To accomodate universe polymorphic definitions, the graph structure in kernel/univ.ml was modified. The new API forces every universe to be @@ -176,68 +177,14 @@ no universe i can be set lower than Set, so the chain of universes always bottoms down at Prop < Set. Modules -======= +------- One has to think of universes in modules as being globally declared, so when including a module (type) which declares a type i (e.g. through a parameter), we get back a copy of i and not some fresh universe. -Projections -=========== - - | Proj of constant * constr - -Projections are always applied to a term, which must be of a record type -(i.e. reducible to an inductive type [I params]). Type-checking, -reduction and conversion are fast (not as fast as they could be yet) -because we don't keep parameters around. As you can see, it's currently -a [constant] that is used here to refer to the projection, that will -change to an abstract [projection] type in the future. Basically a -projection constant records which inductive it is a projection for, the -number of params and the actual position in the constructor that must be -projected. For compatibility reason, we also define an eta-expanded form -(accessible from user syntax @f). The constant_entry of a projection has -both informations. Declaring a record (under [Set Primitive -Projections]) will generate such definitions. The API to declare them is -not stable at the moment, but the inductive type declaration also knows -about the projections, i.e. a record inductive type decl contains an -array of terms representing the projections. This is used to implement -eta-conversion for record types (with at least one field and having all -projections definable). The canonical value being [Build_R (pn x) -... (pn x)]. Unification and conversion work up to this eta rule. The -records can also be universe polymorphic of course, and we don't need to -keep track of the universe instance for the projections either. -Projections are reduced _eagerly_ everywhere, and introduce a new Zproj -constructor in the abstract machines that obeys both the delta (for the -constant opacity) and iota laws (for the actual reduction). Refolding -works as well (afaict), but there is a slight hack there related to -universes (not projections). - -For the ML programmer, the biggest change is that pattern-matchings on -kind_of_term require an additional case, that is handled usually exactly -like an [App (Const p) arg]. - -There are slight hacks related to hints is well, to use the primitive -projection form of f when one does [Hint Resolve f]. Usually hint -resolve will typecheck the term, resulting in a partially applied -projection (disallowed), so we allow it to take -[constr_or_global_reference] arguments instead and special-case on -projections. Other tactic extensions might need similar treatment. - -WIP -=== - -- [vm_compute] does not deal with universes and projections correctly, -except when it goes to a normal form with no projections or polymorphic -constants left (the most common case). E.g. Ring with Set Universe -Polymorphism and Set Primitive Projections work (at least it did at some -point, I didn't recheck yet). - -- [native_compute] works with universes and projections. - - Incompatibilities -================= +----------------- Old-style universe polymorphic definitions were implemented by taking advantage of the fact that elaboration (i.e., pretyping and unification) @@ -247,33 +194,33 @@ possible, as unification ensures that the substitution is built is entirely well-typed, even w.r.t universes. This means that some terms that type-checked before no longer do, especially projections of the pair: - +~~~coq @fst ?x ?y : prod ?x ?y : Type (max(Datatypes.i, Datatypes.j)). - +~~~ The "template universe polymorphic" variables i and j appear during typing without being refreshed, meaning that they can be lowered (have upper constraints) with user-introduced universes. In most cases this won't work, so ?x and ?y have to be instantiated earlier, either from the type of the actual projected pair term (some t : prod A B) or the -typing constraint. Adding the correct type annotations will always fix +typing constraint. Adding the correct type annotations will always fix this. Unification semantics -===================== +--------------------- In Ltac, matching with: -- a universe polymorphic constant [c] matches any instance of the +- a universe polymorphic constant `c` matches any instance of the constant. -- a variable ?x already bound to a term [t] (non-linear pattern) uses +- a variable ?x already bound to a term `t` (non-linear pattern) uses strict equality of universes (e.g., Type@{i} and Type@{j} are not equal). In tactics: -- [change foo with bar], [pattern foo] will unify all instances of [foo] - (and convert them with [bar]). This might incur unifications of - universes. [change] uses conversion while [pattern] only does +- `change foo with bar`, `pattern foo` will unify all instances of `foo` + (and convert them with `bar`). This might incur unifications of + universes. `change` uses conversion while `pattern` only does syntactic matching up-to unification of universes. -- [apply], [refine] use unification up to universes. +- `apply`, `refine` use unification up to universes. diff --git a/dev/doc/universes.txt b/dev/doc/universes.txt deleted file mode 100644 index a40706e99..000000000 --- a/dev/doc/universes.txt +++ /dev/null @@ -1,26 +0,0 @@ -How to debug universes? - -1. There is a command Print Universes in Coq toplevel - - Print Universes. - prints the graph of universes in the form of constraints - - Print Universes "file". - produces the "file" containing universe constraints in the form - univ1 # univ2 ; - where # can be either > >= or = - - If "file" ends with .gv or .dot, the resulting file will be in - dot format. - - - *) for dot see http://www.research.att.com/sw/tools/graphviz/ - - -2. There is a printing option - - {Set,Unset} Printing Universes. - - which, when set, makes all pretty-printed Type's annotated with the - name of the universe. - diff --git a/dev/ocamldebug-coq.run b/dev/ocamldebug-coq.run index f3e60edea..2bec09de2 100644 --- a/dev/ocamldebug-coq.run +++ b/dev/ocamldebug-coq.run @@ -14,11 +14,19 @@ export CAML_LD_LIBRARY_PATH=$COQTOP/kernel/byterun:$CAML_LD_LIBRARY_PATH -exec $OCAMLDEBUG \ +GUESS_CHECKER= +for arg in "$@"; do + if [ "${arg##*/}" = coqchk.byte ]; then + GUESS_CHECKER=1 + fi +done + +if [ -z "$GUESS_CHECKER" ]; then + exec $OCAMLDEBUG \ -I $CAMLP5LIB -I +threads \ -I $COQTOP \ -I $COQTOP/config -I $COQTOP/printing -I $COQTOP/grammar -I $COQTOP/clib \ - -I $COQTOP/lib -I $COQTOP/intf -I $COQTOP/kernel -I $COQTOP/kernel/byterun \ + -I $COQTOP/lib -I $COQTOP/kernel -I $COQTOP/kernel/byterun \ -I $COQTOP/library -I $COQTOP/engine \ -I $COQTOP/pretyping -I $COQTOP/parsing -I $COQTOP/vernac \ -I $COQTOP/interp -I $COQTOP/proofs -I $COQTOP/tactics -I $COQTOP/stm \ @@ -35,3 +43,11 @@ exec $OCAMLDEBUG \ -I $COQTOP/plugins/xml -I $COQTOP/plugins/ltac \ -I $COQTOP/ide \ "$@" +else + exec $OCAMLDEBUG \ + -I $CAMLP5LIB -I +threads \ + -I $COQTOP \ + -I $COQTOP/config -I $COQTOP/clib \ + -I $COQTOP/lib -I $COQTOP/checker \ + "$@" +fi diff --git a/dev/tools/backport-pr.sh b/dev/tools/backport-pr.sh index e4359f703..5205350a6 100755 --- a/dev/tools/backport-pr.sh +++ b/dev/tools/backport-pr.sh @@ -27,9 +27,9 @@ BRANCH=backport-pr-${PRNUM} RANGE=$(git log master --grep "Merge PR #${PRNUM}" --format="%P" | sed 's/ /../') MESSAGE=$(git log master --grep "Merge PR #${PRNUM}" --format="%s" | sed 's/Merge/Backport/') -if git checkout -b ${BRANCH}; then +if git checkout -b "${BRANCH}"; then - if ! git cherry-pick -x ${RANGE}; then + if ! git cherry-pick -x "${RANGE}"; then echo "Please fix the conflicts, then exit." bash while ! git cherry-pick --continue; do @@ -50,7 +50,7 @@ else fi -if ! git diff --exit-code HEAD ${BRANCH} -- "*.mli"; then +if ! git diff --exit-code HEAD "${BRANCH}" -- "*.mli"; then echo read -p "Some mli files are modified. Bypass? [y/N] " -n 1 -r echo @@ -63,8 +63,8 @@ if [[ "${OPTION}" == "--stop-before-merging" ]]; then exit 0 fi -git merge -S --no-ff ${BRANCH} -m "${MESSAGE}" -git branch -d ${BRANCH} +git merge -S --no-ff "${BRANCH}" -m "${MESSAGE}" +git branch -d "${BRANCH}" # To-Do: # - Support for backporting a PR before it is merged diff --git a/dev/tools/check-owners-pr.sh b/dev/tools/check-owners-pr.sh new file mode 100755 index 000000000..d2910279b --- /dev/null +++ b/dev/tools/check-owners-pr.sh @@ -0,0 +1,32 @@ +#!/usr/bin/env sh + +usage() { + { echo "usage: $0 PR [ARGS]..." + echo "A wrapper around check-owners.sh to check owners for a PR." + echo "Assumes upstream is the canonical Coq repository." + echo "Assumes the PR is against master." + echo + echo " PR: PR number" + echo " ARGS: passed through to check-owners.sh" + } >&2 +} + +case "$1" in + "--help"|"-h") + usage + if [ $# = 1 ]; then exit 0; else exit 1; fi;; + "") + usage + exit 1;; +esac + +PR="$1" +shift + +# this puts both refs in the FETCH_HEAD file but git rev-parse will use the first +git fetch upstream "+refs/pull/$PR/head" master + +head=$(git rev-parse FETCH_HEAD) +base=$(git merge-base upstream/master "$head") + +git diff --name-only -z "$base" "$head" | xargs -0 dev/tools/check-owners.sh "$@" diff --git a/dev/tools/check-owners.sh b/dev/tools/check-owners.sh new file mode 100755 index 000000000..1a97508ab --- /dev/null +++ b/dev/tools/check-owners.sh @@ -0,0 +1,138 @@ +#!/usr/bin/env bash + +# Determine CODEOWNERS of the files given in argument +# For a given commit range: +# git diff --name-only -z COMMIT1 COMMIT2 | xargs -0 dev/tools/check-owners.sh [opts] + +# NB: gitignore files will be messed up if you interrupt the script. +# You should be able to just move the .gitignore.bak files back manually. + +usage() { + { echo "usage: $0 [--show-patterns] [--owner OWNER] [FILE]..." + echo " --show-patterns: instead of printing file names print the matching patterns (more compact)" + echo " --owner: show only files/patterns owned by OWNER (use Nobody to see only non-owned files)" + } >&2 +} + +case "$1" in + "--help"|"-h") + usage + if [ $# = 1 ]; then exit 0; else exit 1; fi +esac + +if ! [ -e .github/CODEOWNERS ]; then + >&2 echo "No CODEOWNERS set up or calling from wrong directory." + exit 1 +fi + +files=() +show_patterns=false + +target_owner="" + +while [[ "$#" -gt 0 ]]; do + case "$1" in + "--show-patterns") + show_patterns=true + shift;; + "--owner") + if [[ "$#" = 1 ]]; then + >&2 echo "Missing argument to --owner" + usage + exit 1 + elif [[ "$target_owner" != "" ]]; then + >&2 echo "Only one --owner allowed" + usage + exit 1 + fi + target_owner="$2" + shift 2;; + *) + files+=("$@") + break;; + esac +done + +# CODEOWNERS uses .gitignore patterns so we want to use git to parse it +# The only available tool for that is git check-ignore +# However it provides no way to use alternate .gitignore files +# so we rename them temporarily + +find . -name .gitignore -print0 | while IFS= read -r -d '' f; do + if [ -e "$f.bak" ]; then + >&2 echo "$f.bak exists!" + exit 1 + else + mv "$f" "$f.bak" + fi +done + +# CODEOWNERS is not quite .gitignore patterns: +# after the pattern is the owner (space separated) +# git would interpret that as a big pattern containing spaces +# so we create a valid .gitignore by removing all but the first field + +while read -r pat _; do + printf '%s\n' "$pat" >> .gitignore +done < .github/CODEOWNERS + +# associative array [file => owner] +declare -A owners + +for f in "${files[@]}"; do + data=$(git check-ignore --verbose --no-index "./$f") + code=$? + + if [[ "$code" = 1 ]] || ! [[ "$data" =~ .gitignore:.* ]] ; then + # no match, or match from non tracked gitignore (eg global gitignore) + if [ "$target_owner" != "" ] && [ "$target_owner" != Nobody ] ; then + owner="" + else + owner="Nobody" + pat="$f" # no patterns for unowned files + fi + else + # data looks like [.gitignore:$line:$pattern $file] + # extract the line to look it up in CODEOWNERS + data=${data#'.gitignore:'} + line=${data%%:*} + + # NB: supports multiple owners + # Does not support secondary owners declared in comment + read -r pat fowners < <(sed "${line}q;d" .github/CODEOWNERS) + + owner="" + if [ "$target_owner" != "" ]; then + for o in $fowners; do # do not quote: multiple owners possible + if [ "$o" = "$target_owner" ]; then + owner="$o" + fi + done + else + owner="$fowners" + fi + fi + + if [ "$owner" != "" ]; then + if $show_patterns; then + owners[$pat]="$owner" + else + owners[$f]="$owner" + fi + fi +done + +for f in "${!owners[@]}"; do + printf '%s: %s\n' "$f" "${owners[$f]}" +done | sort -k 2 -k 1 # group by owner + +# restore gitignore files +rm .gitignore +find . -name .gitignore.bak -print0 | while IFS= read -r -d '' f; do + base=${f%.bak} + if [ -e "$base" ]; then + >&2 echo "$base exists!" + else + mv "$f" "$base" + fi +done diff --git a/dev/tools/coqdev.el b/dev/tools/coqdev.el index 62fdaec80..70a9756e5 100644 --- a/dev/tools/coqdev.el +++ b/dev/tools/coqdev.el @@ -23,7 +23,7 @@ ;; If you load this file from a git repository, checking out an old ;; commit will make it disappear and cause errors for your Emacs -;; startup. To ignore those errors use (require 'coqdev nil t). If you +;; startup. To ignore those errors use (require 'coqdev nil t). If you ;; check out a malicious commit Emacs startup would allow it to run ;; arbitrary code, to avoid this you can copy coqdev.el to any ;; location and adjust the load path accordingly (of course if you run @@ -103,5 +103,48 @@ Note that this function is executed before _Coqproject is read if it exists." 2 (3 . 4) (5 . 6))) (add-to-list 'compilation-error-regexp-alist 'coq-backtrace)) +(defvar bug-reference-bug-regexp) +(defvar bug-reference-url-format) +(defun coqdev-setup-bug-reference-mode () + "Setup `bug-reference-bug-regexp' and `bug-reference-url-format' for Coq. + +This does not enable `bug-reference-mode'." + (let ((dir (coqdev-default-directory))) + (when dir + (setq-local bug-reference-bug-regexp "#\\(?2:[0-9]+\\)") + (setq-local bug-reference-url-format "https://github.com/coq/coq/issues/%s")))) +(add-hook 'hack-local-variables-hook #'coqdev-setup-bug-reference-mode) + +(defun coqdev-sphinx-quote-coq-refman-region (left right &optional offset beg end) + "Add LEFT and RIGHT around the BEG..END. +Leave the point after RIGHT. BEG and END default to the bounds +of the current region. Leave point OFFSET characters after the +left quote (if OFFSET is nil, leave the point after the right +quote)." + (unless beg + (if (region-active-p) + (setq beg (region-beginning) end (region-end)) + (setq beg (point) end nil))) + (save-excursion + (goto-char (or end beg)) + (insert right)) + (save-excursion + (goto-char beg) + (insert left)) + (if (and end (not offset)) ;; Second test handles the ::`` case + (goto-char (+ end (length left) (length right))) + (goto-char (+ beg (or offset (length left)))))) + +(defun coqdev-sphinx-rst-coq-action () + "Insert a Sphinx role template or quote the current region." + (interactive) + (pcase (read-char "Command [gntm:`]?") + (?g (coqdev-sphinx-quote-coq-refman-region ":g:`" "`")) + (?n (coqdev-sphinx-quote-coq-refman-region ":n:`" "`")) + (?t (coqdev-sphinx-quote-coq-refman-region ":token:`" "`")) + (?m (coqdev-sphinx-quote-coq-refman-region ":math:`" "`")) + (?: (coqdev-sphinx-quote-coq-refman-region "::`" "`" 1)) + (?` (coqdev-sphinx-quote-coq-refman-region "``" "``")))) + (provide 'coqdev) ;;; coqdev ends here diff --git a/dev/tools/merge-pr.sh b/dev/tools/merge-pr.sh index ecfdfab94..00d04e6b3 100755 --- a/dev/tools/merge-pr.sh +++ b/dev/tools/merge-pr.sh @@ -4,11 +4,20 @@ set -e set -o pipefail API=https://api.github.com/repos/coq/coq -OFFICIAL_REMOTE_URL="git@github.com:coq/coq" +OFFICIAL_REMOTE_GIT_URL="git@github.com:coq/coq" +OFFICIAL_REMOTE_HTTPS_URL="github.com/coq/coq" -# This script depends (at least) on git and jq. +# This script depends (at least) on git (>= 2.7) and jq. # It should be used like this: dev/tools/merge-pr.sh /PR number/ +# Set SLOW_CONF to have the confirmation output wait for a newline +# E.g. call $ SLOW_CONF= dev/tools/merge-pr.sh /PR number/ +if [ -z ${SLOW_CONF+x} ]; then + QUICK_CONF="-n 1" +else + QUICK_CONF="" +fi + RED="\033[31m" RESET="\033[0m" GREEN="\033[32m" @@ -32,7 +41,7 @@ fi } ask_confirmation() { - read -p "Continue anyway? [y/N] " -n 1 -r + read -p "Continue anyway? [y/N] " $QUICK_CONF -r echo if [[ ! $REPLY =~ ^[Yy]$ ]] then @@ -79,11 +88,15 @@ if [ -z "$REMOTE" ]; then error "please run: git branch --set-upstream-to=THE_REMOTE/$CURRENT_LOCAL_BRANCH" exit 1 fi -REMOTE_URL=$(git remote get-url "$REMOTE" --push) -if [ "$REMOTE_URL" != "$OFFICIAL_REMOTE_URL" -a \ - "$REMOTE_URL" != "$OFFICIAL_REMOTE_URL.git" ]; then +REMOTE_URL=$(git remote get-url "$REMOTE" --all) +if [ "$REMOTE_URL" != "${OFFICIAL_REMOTE_GIT_URL}" ] && \ + [ "$REMOTE_URL" != "${OFFICIAL_REMOTE_GIT_URL}.git" ] && \ + [ "$REMOTE_URL" != "https://${OFFICIAL_REMOTE_HTTPS_URL}" ] && \ + [ "$REMOTE_URL" != "https://${OFFICIAL_REMOTE_HTTPS_URL}.git" ] && \ + [[ "$REMOTE_URL" != "https://"*"@${OFFICIAL_REMOTE_HTTPS_URL}" ]] && \ + [[ "$REMOTE_URL" != "https://"*"@${OFFICIAL_REMOTE_HTTPS_URL}.git" ]] ; then error "remote ${BLUE}$REMOTE${RESET} does not point to the official Coq repo" - error "that is ${BLUE}$OFFICIAL_REMOTE_URL" + error "that is ${BLUE}$OFFICIAL_REMOTE_GIT_URL" error "it points to ${BLUE}$REMOTE_URL${RESET} instead" ask_confirmation fi @@ -107,6 +120,26 @@ if [ "$BASE_BRANCH" != "coq:$CURRENT_LOCAL_BRANCH" ]; then ask_confirmation fi; +# Sanity check: the local branch is up-to-date with upstream + +LOCAL_BRANCH_COMMIT=$(git rev-parse HEAD) +UPSTREAM_COMMIT=$(git rev-parse @{u}) +if [ "$LOCAL_BRANCH_COMMIT" != "$UPSTREAM_COMMIT" ]; then + + # Is it just that the upstream branch is behind? + # It could just be that we merged other PRs and we didn't push yet + + if git merge-base --is-ancestor -- "$UPSTREAM_COMMIT" "$LOCAL_BRANCH_COMMIT"; then + warning "Your branch is ahead of ${REMOTE}." + warning "You should see this warning only if you've just merged another PR and did not push yet." + ask_confirmation + else + error "Local branch is not up-to-date with ${REMOTE}." + error "Pull before merging." + ask_confirmation + fi +fi + # Sanity check: CI failed STATUS=$(curl -s "$API/commits/$COMMIT/status") diff --git a/dev/tools/pre-commit b/dev/tools/pre-commit index a514b8866..ad2f2f93e 100755 --- a/dev/tools/pre-commit +++ b/dev/tools/pre-commit @@ -14,9 +14,9 @@ then # We fix whitespace in the index and in the working tree # separately to preserve non-added changes. - index=$(mktemp "git-fix-ws-index.XXXXX") - fixed_index=$(mktemp "git-fix-ws-index-fixed.XXXXX") - tree=$(mktemp "git-fix-ws-tree.XXXXX") + index=$(mktemp "git-fix-ws-index.XXXXXX") + fixed_index=$(mktemp "git-fix-ws-index-fixed.XXXXXX") + tree=$(mktemp "git-fix-ws-tree.XXXXXX") 1>&2 echo "Patches are saved in '$index', '$fixed_index' and '$tree'." 1>&2 echo "If an error destroys your changes you can recover using them." 1>&2 echo "(The files are cleaned up on success.)" @@ -27,8 +27,8 @@ then # reset work tree and index # NB: untracked files which were not added are untouched - git apply --cached -R "$index" - git apply -R "$tree" + git apply --whitespace=nowarn --cached -R "$index" + git apply --whitespace=nowarn -R "$tree" # Fix index # For end of file newlines we must go through the worktree @@ -45,7 +45,7 @@ then # making git fail. Don't fail now: we fix the worktree first. if [ -s "$fixed_index" ] then - git apply -R "$fixed_index" + git apply --whitespace=nowarn -R "$fixed_index" fi # Fix worktree diff --git a/dev/top_printers.ml b/dev/top_printers.ml index ba0c54407..10a7a4158 100644 --- a/dev/top_printers.ml +++ b/dev/top_printers.ml @@ -162,8 +162,8 @@ let pp_state_t n = pp (Reductionops.pr_state n) (* proof printers *) let pr_evar ev = Pp.int (Evar.repr ev) let ppmetas metas = pp(Termops.pr_metaset metas) -let ppevm evd = pp(Termops.pr_evar_map ~with_univs:!Flags.univ_print (Some 2) evd) -let ppevmall evd = pp(Termops.pr_evar_map ~with_univs:!Flags.univ_print None evd) +let ppevm evd = pp(Termops.pr_evar_map ~with_univs:!Detyping.print_universes (Some 2) evd) +let ppevmall evd = pp(Termops.pr_evar_map ~with_univs:!Detyping.print_universes None evd) let pr_existentialset evars = prlist_with_sep spc pr_evar (Evar.Set.elements evars) let ppexistentialset evars = @@ -181,7 +181,7 @@ let ppproofview p = pp(pr_enum Goal.pr_goal gls ++ fnl () ++ Termops.pr_evar_map (Some 1) sigma) let ppopenconstr (x : Evd.open_constr) = - let (evd,c) = x in pp (Termops.pr_evar_map (Some 2) evd ++ envpp pr_constr_env c) + let (evd,c) = x in pp (Termops.pr_evar_map (Some 2) evd ++ envpp pr_econstr_env c) (* spiwack: deactivated until a replacement is found let pppftreestate p = pp(print_pftreestate p) *) @@ -203,17 +203,17 @@ let pproof p = pp(Proof.pr_proof p) let ppuni u = pp(Universe.pr u) let ppuni_level u = pp (Level.pr u) -let prlev = Universes.pr_with_global_universes +let prlev = UnivNames.pr_with_global_universes let ppuniverse_set l = pp (LSet.pr prlev l) let ppuniverse_instance l = pp (Instance.pr prlev l) let ppuniverse_context l = pp (pr_universe_context prlev l) let ppuniverse_context_set l = pp (pr_universe_context_set prlev l) let ppuniverse_subst l = pp (Univ.pr_universe_subst l) -let ppuniverse_opt_subst l = pp (Universes.pr_universe_opt_subst l) +let ppuniverse_opt_subst l = pp (UnivSubst.pr_universe_opt_subst l) let ppuniverse_level_subst l = pp (Univ.pr_universe_level_subst l) let ppevar_universe_context l = pp (Termops.pr_evar_universe_context l) let ppconstraints c = pp (pr_constraints Level.pr c) -let ppuniverseconstraints c = pp (Universes.Constraints.pr c) +let ppuniverseconstraints c = pp (UnivProblem.Set.pr c) let ppuniverse_context_future c = let ctx = Future.force c in ppuniverse_context ctx @@ -221,7 +221,9 @@ let ppcumulativity_info c = pp (Univ.pr_cumulativity_info Univ.Level.pr c) let ppabstract_cumulativity_info c = pp (Univ.pr_abstract_cumulativity_info Univ.Level.pr c) let ppuniverses u = pp (UGraph.pr_universes Level.pr u) let ppnamedcontextval e = - pp (pr_named_context (Global.env ()) Evd.empty (named_context_of_val e)) + let env = Global.env () in + let sigma = Evd.from_env env in + pp (pr_named_context env sigma (named_context_of_val e)) let ppenv e = pp (str "[" ++ pr_named_context_of e Evd.empty ++ str "]" ++ spc() ++ @@ -230,7 +232,7 @@ let ppenv e = pp let ppenvwithcst e = pp (str "[" ++ pr_named_context_of e Evd.empty ++ str "]" ++ spc() ++ str "[" ++ pr_rel_context e Evd.empty (rel_context e) ++ str "]" ++ spc() ++ - str "{" ++ Cmap_env.fold (fun a _ s -> Constant.print a ++ spc () ++ s) (Obj.magic e).Pre_env.env_globals.Pre_env.env_constants (mt ()) ++ str "}") + str "{" ++ Cmap_env.fold (fun a _ s -> Constant.print a ++ spc () ++ s) (Obj.magic e).env_globals.env_constants (mt ()) ++ str "}") let pptac = (fun x -> pp(Ltac_plugin.Pptactic.pr_glob_tactic (Global.env()) x)) diff --git a/dev/top_printers.mli b/dev/top_printers.mli index dad6dcc1c..63d7d5805 100644 --- a/dev/top_printers.mli +++ b/dev/top_printers.mli @@ -87,7 +87,7 @@ val ppclosedglobconstr : Ltac_pretype.closed_glob_constr -> unit val ppclosedglobconstridmap : Ltac_pretype.closed_glob_constr Names.Id.Map.t -> unit -val ppglobal : Globnames.global_reference -> unit +val ppglobal : Names.GlobRef.t -> unit val ppconst : Names.KerName.t * (Constr.constr, 'a) Environ.punsafe_judgment -> unit @@ -139,11 +139,11 @@ val ppuniverse_instance : Univ.Instance.t -> unit val ppuniverse_context : Univ.UContext.t -> unit val ppuniverse_context_set : Univ.ContextSet.t -> unit val ppuniverse_subst : Univ.universe_subst -> unit -val ppuniverse_opt_subst : Universes.universe_opt_subst -> unit +val ppuniverse_opt_subst : UnivSubst.universe_opt_subst -> unit val ppuniverse_level_subst : Univ.universe_level_subst -> unit val ppevar_universe_context : UState.t -> unit val ppconstraints : Univ.Constraint.t -> unit -val ppuniverseconstraints : Universes.Constraints.t -> unit +val ppuniverseconstraints : UnivProblem.Set.t -> unit val ppuniverse_context_future : Univ.UContext.t Future.computation -> unit val ppcumulativity_info : Univ.CumulativityInfo.t -> unit val ppabstract_cumulativity_info : Univ.ACumulativityInfo.t -> unit diff --git a/dev/vm_printers.ml b/dev/vm_printers.ml index 2ddf927d9..7589e5348 100644 --- a/dev/vm_printers.ml +++ b/dev/vm_printers.ml @@ -1,5 +1,6 @@ open Format open Term +open Constr open Names open Cbytecodes open Cemitcodes @@ -14,7 +15,10 @@ let ppripos (ri,pos) = | Reloc_const _ -> print_string "structured constant\n" | Reloc_getglobal kn -> - print_string ("getglob "^(Constant.to_string kn)^"\n")); + print_string ("getglob "^(Constant.to_string kn)^"\n") + | Reloc_proj_name p -> + print_string ("proj "^(Constant.to_string p)^"\n") + ); print_flush () let print_vfix () = print_string "vfix" diff --git a/doc/LICENSE b/doc/LICENSE index 7ae31b089..c223a4e16 100644 --- a/doc/LICENSE +++ b/doc/LICENSE @@ -2,15 +2,17 @@ The Coq Reference Manual is a collective work from the Coq Development Team whose members are listed in the file CREDITS of the Coq source package. All related documents (the LaTeX and BibTeX sources, the embedded png files, and the PostScript, PDF and html outputs) are -copyright (c) INRIA 1999-2006, with the exception of the Ubuntu font files -(UbuntuMono-Square.ttf and UbuntuMono-B.ttf), derived from UbuntuMono-Regular, -which is Copyright 2010,2011 Canonical Ltd and licensed under the Ubuntu font +copyright (c) INRIA 1999-2006, with the exception of the Ubuntu font +file UbuntuMono-B.ttf, which is +Copyright 2010,2011 Canonical Ltd and licensed under the Ubuntu font license, version 1.0 -(https://www.ubuntu.com/legal/terms-and-policies/font-licence). The material -connected to the Reference Manual may be distributed only subject to the terms -and conditions set forth in the Open Publication License, v1.0 or later (the -latest version is presently available at http://www.opencontent.org/openpub/). -Options A and B are *not* elected. +(https://www.ubuntu.com/legal/terms-and-policies/font-licence), and its +derivative CoqNotations.ttf distributed under the same license. The +material connected to the Reference Manual may be distributed only +subject to the terms and conditions set forth in the Open Publication +License, v1.0 or later (the latest version is presently available at +http://www.opencontent.org/openpub/). Options A and B are *not* +elected. The Coq Tutorial is a work by Gérard Huet, Gilles Kahn and Christine Paulin-Mohring. All documents (the LaTeX source and the PostScript, diff --git a/doc/RecTutorial/RecTutorial.tex b/doc/RecTutorial/RecTutorial.tex deleted file mode 100644 index d0884be0d..000000000 --- a/doc/RecTutorial/RecTutorial.tex +++ /dev/null @@ -1,3690 +0,0 @@ -\documentclass[11pt]{article} -\title{A Tutorial on [Co-]Inductive Types in Coq} -\author{Eduardo Gim\'enez\thanks{Eduardo.Gimenez@inria.fr}, -Pierre Cast\'eran\thanks{Pierre.Casteran@labri.fr}} -\date{May 1998 --- \today} - -\usepackage{multirow} -% \usepackage{aeguill} -% \externaldocument{RefMan-gal.v} -% \externaldocument{RefMan-ext.v} -% \externaldocument{RefMan-tac.v} -% \externaldocument{RefMan-oth} -% \externaldocument{RefMan-tus.v} -% \externaldocument{RefMan-syn.v} -% \externaldocument{Extraction.v} -\input{recmacros} -\input{coqartmacros} -\newcommand{\refmancite}[1]{{}} -% \newcommand{\refmancite}[1]{\cite{coqrefman}} -% \newcommand{\refmancite}[1]{\cite[#1] {]{coqrefman}} - -\usepackage[utf8]{inputenc} -\usepackage[T1]{fontenc} -\usepackage{makeidx} -% \usepackage{multind} -\usepackage{alltt} -\usepackage{verbatim} -\usepackage{amssymb} -\usepackage{amsmath} -\usepackage{theorem} -\usepackage[dvips]{epsfig} -\usepackage{epic} -\usepackage{eepic} -% \usepackage{ecltree} -\usepackage{moreverb} -\usepackage{color} -\usepackage{pifont} -\usepackage{xr} -\usepackage{url} - -\usepackage{alltt} -\renewcommand{\familydefault}{ptm} -\renewcommand{\seriesdefault}{m} -\renewcommand{\shapedefault}{n} -\newtheorem{exercise}{Exercise}[section] -\makeindex -\begin{document} -\maketitle - -\begin{abstract} -This document\footnote{The first versions of this document were entirely written by Eduardo Gimenez. -Pierre Cast\'eran wrote the 2004 and 2006 revisions.} is an introduction to the definition and -use of inductive and co-inductive types in the {\coq} proof environment. It explains how types like natural numbers and infinite streams are defined -in {\coq}, and the kind of proof techniques that can be used to reason -about them (case analysis, induction, inversion of predicates, -co-induction, etc). Each technique is illustrated through an -executable and self-contained {\coq} script. -\end{abstract} -%\RRkeyword{Proof environments, recursive types.} -%\makeRT - -\addtocontents{toc}{\protect \thispagestyle{empty}} -\pagenumbering{arabic} - -\cleardoublepage -\tableofcontents -\clearpage - -\section{About this document} - -This document is an introduction to the definition and use of -inductive and co-inductive types in the {\coq} proof environment. It was born from the -notes written for the course about the version V5.10 of {\coq}, given -by Eduardo Gimenez at -the Ecole Normale Sup\'erieure de Lyon in March 1996. This article is -a revised and improved version of these notes for the version V8.0 of -the system. - - -We assume that the reader has some familiarity with the -proofs-as-programs paradigm of Logic \cite{Coquand:metamathematical} and the generalities -of the {\coq} system \cite{coqrefman}. You would take a greater advantage of -this document if you first read the general tutorial about {\coq} and -{\coq}'s FAQ, both available on \cite{coqsite}. -A text book \cite{coqart}, accompanied with a lot of -examples and exercises \cite{Booksite}, presents a detailed description -of the {\coq} system and its underlying -formalism: the Calculus of Inductive Construction. -Finally, the complete description of {\coq} is given in the reference manual -\cite{coqrefman}. Most of the tactics and commands we describe have -several options, which we do not present exhaustively. -If some script herein uses a non described feature, please refer to -the Reference Manual. - - -If you are familiar with other proof environments -based on type theory and the LCF style ---like PVS, LEGO, Isabelle, -etc--- then you will find not difficulty to guess the unexplained -details. - -The better way to read this document is to start up the {\coq} system, -type by yourself the examples and exercises, and observe the -behavior of the system. All the examples proposed in this tutorial -can be downloaded from the same site as the present document. - - -The tutorial is organised as follows. The next section describes how -inductive types are defined in {\coq}, and introduces some useful ones, -like natural numbers, the empty type, the propositional equality type, -and the logical connectives. Section \ref{CaseAnalysis} explains -definitions by pattern-matching and their connection with the -principle of case analysis. This principle is the most basic -elimination rule associated with inductive or co-inductive types - and follows a -general scheme that we illustrate for some of the types introduced in -Section \ref{Introduction}. Section \ref{CaseTechniques} illustrates -the pragmatics of this principle, showing different proof techniques -based on it. Section \ref{StructuralInduction} introduces definitions -by structural recursion and proofs by induction. -Section~\ref{CaseStudy} presents some elaborate techniques -about dependent case analysis. Finally, Section -\ref{CoInduction} is a brief introduction to co-inductive types ---i.e., types containing infinite objects-- and the principle of -co-induction. - - -Thanks to Bruno Barras, Yves Bertot, Hugo Herbelin, Jean-Fran\c{c}ois Monin -and Michel L\'evy for their help. - -\subsection*{Lexical conventions} -The \texttt{typewriter} font is used to represent text -input by the user, while the \textit{italic} font is used to represent -the text output by the system as answers. - - -Moreover, the mathematical symbols \coqle{}, \coqdiff, \(\exists\), -\(\forall\), \arrow{}, $\rightarrow{}$ \coqor{}, \coqand{}, and \funarrow{} -stand for the character strings \citecoq{<=}, \citecoq{<>}, -\citecoq{exists}, \citecoq{forall}, \citecoq{->}, \citecoq{<-}, -\texttt{\char'134/}, \texttt{/\char'134}, and \citecoq{=>}, -respectively. For instance, the \coq{} statement -%V8 A prendre -% inclusion numero 1 -% traduction numero 1 -\begin{alltt} -\hide{Open Scope nat_scope. Check (}forall A:Type,(exists x : A, forall (y:A), x <> y) -> 2 = 3\hide{).} -\end{alltt} -is written as follows in this tutorial: -%V8 A prendre -% inclusion numero 2 -% traduction numero 2 -\begin{alltt} -\hide{Check (}{\prodsym}A:Type,(\exsym{}x:A, {\prodsym}y:A, x {\coqdiff} y) \arrow{} 2 = 3\hide{).} -\end{alltt} - -When a fragment of \coq{} input text appears in the middle of -regular text, we often place this fragment between double quotes -``\dots.'' These double quotes do not belong to the \coq{} syntax. - -Finally, any -string enclosed between \texttt{(*} and \texttt{*)} is a comment and -is ignored by the \coq{} system. - -\section{Introducing Inductive Types} -\label{Introduction} - -Inductive types are types closed with respect to their introduction -rules. These rules explain the most basic or \textsl{canonical} ways -of constructing an element of the type. In this sense, they -characterize the recursive type. Different rules must be considered as -introducing different objects. In order to fix ideas, let us introduce -in {\coq} the most well-known example of a recursive type: the type of -natural numbers. - -%V8 A prendre -\begin{alltt} -Inductive nat : Set := - | O : nat - | S : nat\arrow{}nat. -\end{alltt} - -The definition of a recursive type has two main parts. First, we -establish what kind of recursive type we will characterize (a set, in -this case). Second, we present the introduction rules that define the -type ({\Z} and {\SUCC}), also called its {\sl constructors}. The constructors -{\Z} and {\SUCC} determine all the elements of this type. In other -words, if $n\mbox{:}\nat$, then $n$ must have been introduced either -by the rule {\Z} or by an application of the rule {\SUCC} to a -previously constructed natural number. In this sense, we can say -that {\nat} is \emph{closed}. On the contrary, the type -$\Set$ is an {\it open} type, since we do not know {\it a priori} all -the possible ways of introducing an object of type \texttt{Set}. - -After entering this command, the constants {\nat}, {\Z} and {\SUCC} are -available in the current context. We can see their types using the -\texttt{Check} command \refmancite{Section \ref{Check}}: - -%V8 A prendre -\begin{alltt} -Check nat. -\it{}nat : Set -\tt{}Check O. -\it{}O : nat -\tt{}Check S. -\it{}S : nat {\arrow} nat -\end{alltt} - -Moreover, {\coq} adds to the context three constants named - $\natind$, $\natrec$ and $\natrect$, which - correspond to different principles of structural induction on -natural numbers that {\coq} infers automatically from the definition. We -will come back to them in Section \ref{StructuralInduction}. - - -In fact, the type of natural numbers as well as several useful -theorems about them are already defined in the basic library of {\coq}, -so there is no need to introduce them. Therefore, let us throw away -our (re)definition of {\nat}, using the command \texttt{Reset}. - -%V8 A prendre -\begin{alltt} -Reset nat. -Print nat. -\it{}Inductive nat : Set := O : nat | S : nat \arrow{} nat -For S: Argument scope is [nat_scope] -\end{alltt} - -Notice that \coq{}'s \emph{interpretation scope} for natural numbers -(called \texttt{nat\_scope}) -allows us to read and write natural numbers in decimal form (see \cite{coqrefman}). For instance, the constructor \texttt{O} can be read or written -as the digit $0$, and the term ``~\texttt{S (S (S O))}~'' as $3$. - -%V8 A prendre -\begin{alltt} -Check O. -\it 0 : nat. -\tt -Check (S (S (S O))). -\it 3 : nat -\end{alltt} - -Let us now take a look to some other -recursive types contained in the standard library of {\coq}. - -\subsection{Lists} -Lists are defined in library \citecoq{List}\footnote{Notice that in versions of -{\coq} -prior to 8.1, the parameter $A$ had sort \citecoq{Set} instead of \citecoq{Type}; -the constant \citecoq{list} was thus of type \citecoq{Set\arrow{} Set}.} - - -\begin{alltt} -Require Import List. -Print list. -\it -Inductive list (A : Type) : Type:= - nil : list A | cons : A {\arrow} list A {\arrow} list A -For nil: Argument A is implicit -For cons: Argument A is implicit -For list: Argument scope is [type_scope] -For nil: Argument scope is [type_scope] -For cons: Argument scopes are [type_scope _ _] -\end{alltt} - -In this definition, \citecoq{A} is a \emph{general parameter}, global -to both constructors. -This kind of definition allows us to build a whole family of -inductive types, indexed over the sort \citecoq{Type}. -This can be observed if we consider the type of identifiers -\citecoq{list}, \citecoq{cons} and \citecoq{nil}. -Notice the notation \citecoq{(A := \dots)} which must be used -when {\coq}'s type inference algorithm cannot infer the implicit -parameter \citecoq{A}. -\begin{alltt} -Check list. -\it list - : Type {\arrow} Type - -\tt Check (nil (A:=nat)). -\it nil - : list nat - -\tt Check (nil (A:= nat {\arrow} nat)). -\it nil - : list (nat {\arrow} nat) - -\tt Check (fun A: Type {\funarrow} (cons (A:=A))). -\it fun A : Type {\funarrow} cons (A:=A) - : {\prodsym} A : Type, A {\arrow} list A {\arrow} list A - -\tt Check (cons 3 (cons 2 nil)). -\it 3 :: 2 :: nil - : list nat - -\tt Check (nat :: bool ::nil). -\it nat :: bool :: nil - : list Set - -\tt Check ((3<=4) :: True ::nil). -\it (3<=4) :: True :: nil - : list Prop - -\tt Check (Prop::Set::nil). -\it Prop::Set::nil - : list Type -\end{alltt} - -\subsection{Vectors.} -\label{vectors} - -Like \texttt{list}, \citecoq{vector} is a polymorphic type: -if $A$ is a type, and $n$ a natural number, ``~\citecoq{vector $A$ $n$}~'' -is the type of vectors of elements of $A$ and size $n$. - - -\begin{alltt} -Require Import Bvector. - -Print vector. -\it -Inductive vector (A : Type) : nat {\arrow} Type := - Vnil : vector A 0 - | Vcons : A {\arrow} {\prodsym} n : nat, vector A n {\arrow} vector A (S n) -For vector: Argument scopes are [type_scope nat_scope] -For Vnil: Argument scope is [type_scope] -For Vcons: Argument scopes are [type_scope _ nat_scope _] -\end{alltt} - - -Remark the difference between the two parameters $A$ and $n$: -The first one is a \textsl{general parameter}, global to all the -introduction rules,while the second one is an \textsl{index}, which is -instantiated differently in the introduction rules. -Such types parameterized by regular -values are called \emph{dependent types}. - -\begin{alltt} -Check (Vnil nat). -\it Vnil nat - : vector nat 0 - -\tt Check (fun (A:Type)(a:A){\funarrow} Vcons _ a _ (Vnil _)). -\it fun (A : Type) (a : A) {\funarrow} Vcons A a 0 (Vnil A) - : {\prodsym} A : Type, A {\arrow} vector A 1 - - -\tt Check (Vcons _ 5 _ (Vcons _ 3 _ (Vnil _))). -\it Vcons nat 5 1 (Vcons nat 3 0 (Vnil nat)) - : vector nat 2 -\end{alltt} - -\subsection{The contradictory proposition.} -Another example of an inductive type is the contradictory proposition. -This type inhabits the universe of propositions, and has no element -at all. -%V8 A prendre -\begin{alltt} -Print False. -\it{} Inductive False : Prop := -\end{alltt} - -\noindent Notice that no constructor is given in this definition. - -\subsection{The tautological proposition.} -Similarly, the -tautological proposition {\True} is defined as an inductive type -with only one element {\I}: - -%V8 A prendre -\begin{alltt} -Print True. -\it{}Inductive True : Prop := I : True -\end{alltt} - -\subsection{Relations as inductive types.} -Some relations can also be introduced in a smart way as an inductive family -of propositions. Let us take as example the order $n \leq m$ on natural -numbers, called \citecoq{le} in {\coq}. - This relation is introduced through -the following definition, quoted from the standard library\footnote{In the interpretation scope -for Peano arithmetic: -\citecoq{nat\_scope}, ``~\citecoq{n <= m}~'' is equivalent to -``~\citecoq{le n m}~'' .}: - - - - -%V8 A prendre -\begin{alltt} -Print le. \it -Inductive le (n:nat) : nat\arrow{}Prop := -| le_n: n {\coqle} n -| le_S: {\prodsym} m, n {\coqle} m \arrow{} n {\coqle} S m. -\end{alltt} - -Notice that in this definition $n$ is a general parameter, -while the second argument of \citecoq{le} is an index (see section -~\ref{vectors}). - This definition -introduces the binary relation $n {\leq} m$ as the family of unary predicates -``\textsl{to be greater or equal than a given $n$}'', parameterized by $n$. - -The introduction rules of this type can be seen as a sort of Prolog -rules for proving that a given integer $n$ is less or equal than another one. -In fact, an object of type $n{\leq} m$ is nothing but a proof -built up using the constructors \textsl{le\_n} and -\textsl{le\_S} of this type. As an example, let us construct -a proof that zero is less or equal than three using {\coq}'s interactive -proof mode. -Such an object can be obtained applying three times the second -introduction rule of \citecoq{le}, to a proof that zero is less or equal -than itself, -which is provided by the first constructor of \citecoq{le}: - -%V8 A prendre -\begin{alltt} -Theorem zero_leq_three: 0 {\coqle} 3. -Proof. -\it{} 1 subgoal - -============================ - 0 {\coqle} 3 - -\tt{}Proof. - constructor 2. - -\it{} 1 subgoal -============================ - 0 {\coqle} 2 - -\tt{} constructor 2. -\it{} 1 subgoal -============================ - 0 {\coqle} 1 - -\tt{} constructor 2 -\it{} 1 subgoal -============================ - 0 {\coqle} 0 - -\tt{} constructor 1. - -\it{}Proof completed -\tt{}Qed. -\end{alltt} - -\noindent When -the current goal is an inductive type, the tactic -``~\citecoq{constructor $i$}~'' \refmancite{Section \ref{constructor}} applies the $i$-th constructor in the -definition of the type. We can take a look at the proof constructed -using the command \texttt{Print}: - -%V8 A prendre -\begin{alltt} -Print Print zero_leq_three. -\it{}zero_leq_three = -zero_leq_three = le_S 0 2 (le_S 0 1 (le_S 0 0 (le_n 0))) - : 0 {\coqle} 3 -\end{alltt} - -When the parameter $i$ is not supplied, the tactic \texttt{constructor} -tries to apply ``~\texttt{constructor $1$}~'', ``~\texttt{constructor $2$}~'',\dots, -``~\texttt{constructor $n$}~'' where $n$ is the number of constructors -of the inductive type (2 in our example) of the conclusion of the goal. -Our little proof can thus be obtained iterating the tactic -\texttt{constructor} until it fails: - -%V8 A prendre -\begin{alltt} -Lemma zero_leq_three': 0 {\coqle} 3. - repeat constructor. -Qed. -\end{alltt} - -Notice that the strict order on \texttt{nat}, called \citecoq{lt} -is not inductively defined: the proposition $n<p$ (notation for \citecoq{lt $n$ $p$}) -is reducible to \citecoq{(S $n$) $\leq$ p}. - -\begin{alltt} -Print lt. -\it -lt = fun n m : nat {\funarrow} S n {\coqle} m - : nat {\arrow} nat {\arrow} Prop -\tt -Lemma zero_lt_three : 0 < 3. -Proof. - repeat constructor. -Qed. - -Print zero_lt_three. -\it zero_lt_three = le_S 1 2 (le_S 1 1 (le_n 1)) - : 0 < 3 -\end{alltt} - - - -\subsection{About general parameters (\coq{} version $\geq$ 8.1)} -\label{parameterstuff} - -Since version $8.1$, it is possible to write more compact inductive definitions -than in earlier versions. - -Consider the following alternative definition of the relation $\leq$ on -type \citecoq{nat}: - -\begin{alltt} -Inductive le'(n:nat):nat -> Prop := - | le'_n : le' n n - | le'_S : forall p, le' (S n) p -> le' n p. - -Hint Constructors le'. -\end{alltt} - -We notice that the type of the second constructor of \citecoq{le'} -has an argument whose type is \citecoq{le' (S n) p}. -This constrasts with earlier versions -of {\coq}, in which a general parameter $a$ of an inductive -type $I$ had to appear only in applications of the form $I\,\dots\,a$. - -Since version $8.1$, if $a$ is a general parameter of an inductive -type $I$, the type of an argument of a constructor of $I$ may be -of the form $I\,\dots\,t_a$ , where $t_a$ is any term. -Notice that the final type of the constructors must be of the form -$I\,\dots\,a$, since these constructors describe how to form -inhabitants of type $I\,\dots\,a$ (this is the role of parameter $a$). - -Another example of this new feature is {\coq}'s definition of accessibility -(see Section~\ref{WellFoundedRecursion}), which has a general parameter -$x$; the constructor for the predicate -``$x$ is accessible'' takes an argument of type ``$y$ is accessible''. - - - -In earlier versions of {\coq}, a relation like \citecoq{le'} would have to be -defined without $n$ being a general parameter. - -\begin{alltt} -Reset le'. - -Inductive le': nat-> nat -> Prop := - | le'_n : forall n, le' n n - | le'_S : forall n p, le' (S n) p -> le' n p. -\end{alltt} - - - - -\subsection{The propositional equality type.} \label{equality} -In {\coq}, the propositional equality between two inhabitants $a$ and -$b$ of -the same type $A$ , -noted $a=b$, is introduced as a family of recursive predicates -``~\textsl{to be equal to $a$}~'', parameterised by both $a$ and its type -$A$. This family of types has only one introduction rule, which -corresponds to reflexivity. -Notice that the syntax ``\citecoq{$a$ = $b$}~'' is an abbreviation -for ``\citecoq{eq $a$ $b$}~'', and that the parameter $A$ is \emph{implicit}, -as it can be infered from $a$. -%V8 A prendre -\begin{alltt} -Print eq. -\it{} Inductive eq (A : Type) (x : A) : A \arrow{} Prop := - eq_refl : x = x -For eq: Argument A is implicit -For eq_refl: Argument A is implicit -For eq: Argument scopes are [type_scope _ _] -For eq_refl: Argument scopes are [type_scope _] -\end{alltt} - -Notice also that the first parameter $A$ of \texttt{eq} has type -\texttt{Type}. The type system of {\coq} allows us to consider equality between -various kinds of terms: elements of a set, proofs, propositions, -types, and so on. -Look at \cite{coqrefman, coqart} to get more details on {\coq}'s type -system, as well as implicit arguments and argument scopes. - - -\begin{alltt} -Lemma eq_3_3 : 2 + 1 = 3. -Proof. - reflexivity. -Qed. - -Lemma eq_proof_proof : eq_refl (2*6) = eq_refl (3*4). -Proof. - reflexivity. -Qed. - -Print eq_proof_proof. -\it eq_proof_proof = -eq_refl (eq_refl (3 * 4)) - : eq_refl (2 * 6) = eq_refl (3 * 4) -\tt - -Lemma eq_lt_le : ( 2 < 4) = (3 {\coqle} 4). -Proof. - reflexivity. -Qed. - -Lemma eq_nat_nat : nat = nat. -Proof. - reflexivity. -Qed. - -Lemma eq_Set_Set : Set = Set. -Proof. - reflexivity. -Qed. -\end{alltt} - -\subsection{Logical connectives.} \label{LogicalConnectives} -The conjunction and disjunction of two propositions are also examples -of recursive types: - -\begin{alltt} -Inductive or (A B : Prop) : Prop := - or_introl : A \arrow{} A {\coqor} B | or_intror : B \arrow{} A {\coqor} B - -Inductive and (A B : Prop) : Prop := - conj : A \arrow{} B \arrow{} A {\coqand} B - -\end{alltt} - -The propositions $A$ and $B$ are general parameters of these -connectives. Choosing different universes for -$A$ and $B$ and for the inductive type itself gives rise to different -type constructors. For example, the type \textsl{sumbool} is a -disjunction but with computational contents. - -\begin{alltt} -Inductive sumbool (A B : Prop) : Set := - left : A \arrow{} \{A\} + \{B\} | right : B \arrow{} \{A\} + \{B\} -\end{alltt} - - - -This type --noted \texttt{\{$A$\}+\{$B$\}} in {\coq}-- can be used in {\coq} -programs as a sort of boolean type, to check whether it is $A$ or $B$ -that is true. The values ``~\citecoq{left $p$}~'' and -``~\citecoq{right $q$}~'' replace the boolean values \textsl{true} and -\textsl{false}, respectively. The advantage of this type over -\textsl{bool} is that it makes available the proofs $p$ of $A$ or $q$ -of $B$, which could be necessary to construct a verification proof -about the program. -For instance, let us consider the certified program \citecoq{le\_lt\_dec} -of the Standard Library. - -\begin{alltt} -Require Import Compare_dec. -Check le_lt_dec. -\it -le_lt_dec - : {\prodsym} n m : nat, \{n {\coqle} m\} + \{m < n\} - -\end{alltt} - -We use \citecoq{le\_lt\_dec} to build a function for computing -the max of two natural numbers: - -\begin{alltt} -Definition max (n p :nat) := match le_lt_dec n p with - | left _ {\funarrow} p - | right _ {\funarrow} n - end. -\end{alltt} - -In the following proof, the case analysis on the term -``~\citecoq{le\_lt\_dec n p}~'' gives us an access to proofs -of $n\leq p$ in the first case, $p<n$ in the other. - -\begin{alltt} -Theorem le_max : {\prodsym} n p, n {\coqle} p {\arrow} max n p = p. -Proof. - intros n p ; unfold max ; case (le_lt_dec n p); simpl. -\it -2 subgoals - - n : nat - p : nat - ============================ - n {\coqle} p {\arrow} n {\coqle} p {\arrow} p = p - -subgoal 2 is: - p < n {\arrow} n {\coqle} p {\arrow} n = p -\tt - trivial. - intros; absurd (p < p); eauto with arith. -Qed. -\end{alltt} - - - Once the program verified, the proofs are -erased by the extraction procedure: - -\begin{alltt} -Extraction max. -\it -(** val max : nat {\arrow} nat {\arrow} nat **) - -let max n p = - match le_lt_dec n p with - | Left {\arrow} p - | Right {\arrow} n -\end{alltt} - -Another example of use of \citecoq{sumbool} is given in Section -\ref{WellFoundedRecursion}: the theorem \citecoq{eq\_nat\_dec} of -library \citecoq{Coq.Arith.Peano\_dec} is used in an euclidean division -algorithm. - -\subsection{The existential quantifier.}\label{ex-def} -The existential quantifier is yet another example of a logical -connective introduced as an inductive type. - -\begin{alltt} -Inductive ex (A : Type) (P : A \arrow{} Prop) : Prop := - ex_intro : {\prodsym} x : A, P x \arrow{} ex P -\end{alltt} - -Notice that {\coq} uses the abreviation ``~\citecoq{\exsym\,$x$:$A$, $B$}~'' -for \linebreak ``~\citecoq{ex (fun $x$:$A$ \funarrow{} $B$)}~''. - - -\noindent The former quantifier inhabits the universe of propositions. -As for the conjunction and disjunction connectives, there is also another -version of existential quantification inhabiting the universes $\Type_i$, -which is written \texttt{sig $P$}. The syntax -``~\citecoq{\{$x$:$A$ | $B$\}}~'' is an abreviation for ``~\citecoq{sig (fun $x$:$A$ {\funarrow} $B$)}~''. - - - -%\paragraph{The logical connectives.} Conjuction and disjuction are -%also introduced as recursive types: -%\begin{alltt} -%Print or. -%\end{alltt} -%begin{alltt} -%Print and. -%\end{alltt} - - -\subsection{Mutually Dependent Definitions} -\label{MutuallyDependent} - -Mutually dependent definitions of recursive types are also allowed in -{\coq}. A typical example of these kind of declaration is the -introduction of the trees of unbounded (but finite) width: -\label{Forest} -\begin{alltt} -Inductive tree(A:Type) : Type := - node : A {\arrow} forest A \arrow{} tree A -with forest (A: Set) : Type := - nochild : forest A | - addchild : tree A \arrow{} forest A \arrow{} forest A. -\end{alltt} -\noindent Yet another example of mutually dependent types are the -predicates \texttt{even} and \texttt{odd} on natural numbers: -\label{Even} -\begin{alltt} -Inductive - even : nat\arrow{}Prop := - evenO : even O | - evenS : {\prodsym} n, odd n \arrow{} even (S n) -with - odd : nat\arrow{}Prop := - oddS : {\prodsym} n, even n \arrow{} odd (S n). -\end{alltt} - -\begin{alltt} -Lemma odd_49 : odd (7 * 7). - simpl; repeat constructor. -Qed. -\end{alltt} - - - -\section{Case Analysis and Pattern-matching} -\label{CaseAnalysis} -\subsection{Non-dependent Case Analysis} -An \textsl{elimination rule} for the type $A$ is some way to use an -object $a:A$ in order to define an object in some type $B$. -A natural elimination rule for an inductive type is \emph{case analysis}. - - -For instance, any value of type {\nat} is built using either \texttt{O} or \texttt{S}. -Thus, a systematic way of building a value of type $B$ from any -value of type {\nat} is to associate to \texttt{O} a constant $t_O:B$ and -to every term of the form ``~\texttt{S $p$}~'' a term $t_S:B$. The following -construction has type $B$: -\begin{alltt} -match \(n\) return \(B\) with O \funarrow \(t\sb{O}\) | S p \funarrow \(t\sb{S}\) end -\end{alltt} - - -In most of the cases, {\coq} is able to infer the type $B$ of the object -defined, so the ``\texttt{return $B$}'' part can be omitted. - -The computing rules associated with this construct are the expected ones -(the notation $t_S\{q/\texttt{p}\}$ stands for the substitution of $p$ by -$q$ in $t_S$ :) - -\begin{eqnarray*} -\texttt{match $O$ return $b$ with O {\funarrow} $t_O$ | S p {\funarrow} $t_S$ end} &\Longrightarrow& t_O\\ -\texttt{match $S\;q$ return $b$ with O {\funarrow} $t_O$ | S p {\funarrow} $t_S$ end} &\Longrightarrow& t_S\{q/\texttt{p}\} -\end{eqnarray*} - - -\subsubsection{Example: the predecessor function.}\label{firstpred} -An example of a definition by case analysis is the function which -computes the predecessor of any given natural number: -\begin{alltt} -Definition pred (n:nat) := match n with - | O {\funarrow} O - | S m {\funarrow} m - end. - -Eval simpl in pred 56. -\it{} = 55 - : nat -\tt -Eval simpl in pred 0. -\it{} = 0 - : nat - -\tt{}Eval simpl in fun p {\funarrow} pred (S p). -\it{} = fun p : nat {\funarrow} p - : nat {\arrow} nat -\end{alltt} - -As in functional programming, tuples and wild-cards can be used in -patterns \refmancite{Section \ref{ExtensionsOfCases}}. Such -definitions are automatically compiled by {\coq} into an expression which -may contain several nested case expressions. For example, the -exclusive \emph{or} on booleans can be defined as follows: -\begin{alltt} -Definition xorb (b1 b2:bool) := - match b1, b2 with - | false, true {\funarrow} true - | true, false {\funarrow} true - | _ , _ {\funarrow} false - end. -\end{alltt} - -This kind of definition is compiled in {\coq} as follows\footnote{{\coq} uses -the conditional ``~\citecoq{if $b$ then $a$ else $b$}~'' as an abreviation to -``~\citecoq{match $b$ with true \funarrow{} $a$ | false \funarrow{} $b$ end}~''.}: - -\begin{alltt} -Print xorb. -xorb = -fun b1 b2 : bool {\funarrow} -if b1 then if b2 then false else true - else if b2 then true else false - : bool {\arrow} bool {\arrow} bool -\end{alltt} - -\subsection{Dependent Case Analysis} -\label{DependentCase} - -For a pattern matching construct of the form -``~\citecoq{match n with \dots end}~'' a more general typing rule -is obtained considering that the type of the whole expression -may also depend on \texttt{n}. - For instance, let us consider some function -$Q:\texttt{nat}\arrow{}\texttt{Type}$, and $n:\citecoq{nat}$. -In order to build a term of type $Q\;n$, we can associate -to the constructor \texttt{O} some term $t_O: Q\;\texttt{O}$ and to -the pattern ``~\texttt{S p}~'' some term $t_S : Q\;(S\;p)$. -Notice that the terms $t_O$ and $t_S$ do not have the same type. - -The syntax of the \emph{dependent case analysis} and its -associated typing rule make precise how the resulting -type depends on the argument of the pattern matching, and -which constraint holds on the branches of the pattern matching: - -\label{Prod-sup-rule} -\[ -\begin{array}[t]{l} -Q: \texttt{nat}{\arrow}\texttt{Type}\quad{t_O}:{{Q\;\texttt{O}}} \quad -\smalljuge{p:\texttt{nat}}{t_p}{{Q\;(\texttt{S}\;p)}} \quad n:\texttt{nat} \\ -\hline -{\texttt{match \(n\) as \(n\sb{0}\) return \(Q\;n\sb{0}\) with | O \funarrow \(t\sb{O}\) | S p \funarrow \(t\sb{S}\) end}}:{{Q\;n}} -\end{array} -\] - - -The interest of this rule of \textsl{dependent} pattern-matching is -that it can also be read as the following logical principle (when $Q$ has type \citecoq{nat\arrow{}Prop} -by \texttt{Prop} in the type of $Q$): in order to prove -that a property $Q$ holds for all $n$, it is sufficient to prove that -$Q$ holds for {\Z} and that for all $p:\nat$, $Q$ holds for -$(\SUCC\;p)$. The former, non-dependent version of case analysis can -be obtained from this latter rule just taking $Q$ as a constant -function on $n$. - -Notice that destructuring $n$ into \citecoq{O} or ``~\citecoq{S p}~'' - doesn't -make appear in the goal the equalities ``~$n=\citecoq{O}$~'' - and ``~$n=\citecoq{S p}$~''. -They are ``internalized'' in the rules above (see section~\ref{inversion}.) - -\subsubsection{Example: strong specification of the predecessor function.} - -In Section~\ref{firstpred}, the predecessor function was defined directly -as a function from \texttt{nat} to \texttt{nat}. It remains to prove -that this function has some desired properties. Another way to proceed -is to, first introduce a specification of what is the predecessor of a -natural number, under the form of a {\coq} type, then build an inhabitant -of this type: in other words, a realization of this specification. This way, the correctness -of this realization is ensured by {\coq}'s type system. - -A reasonable specification for $\pred$ is to say that for all $n$ -there exists another $m$ such that either $m=n=0$, or $(\SUCC\;m)$ -is equal to $n$. The function $\pred$ should be just the way to -compute such an $m$. - -\begin{alltt} -Definition pred_spec (n:nat) := - \{m:nat | n=0{\coqand} m=0 {\coqor} n = S m\}. - -Definition predecessor : {\prodsym} n:nat, pred_spec n. - intro n; case n. -\it{} - n : nat - ============================ - pred_spec 0 - -\tt{} unfold pred_spec;exists 0;auto. -\it{} - ========================================= - {\prodsym} n0 : nat, pred_spec (S n0) -\tt{} - unfold pred_spec; intro n0; exists n0; auto. -Defined. -\end{alltt} - -If we print the term built by {\coq}, its dependent pattern-matching structure can be observed: - -\begin{alltt} -predecessor = fun n : nat {\funarrow} -\textbf{match n as n0 return (pred_spec n0) with} -\textbf{| O {\funarrow}} - exist (fun m : nat {\funarrow} 0 = 0 {\coqand} m = 0 {\coqor} 0 = S m) 0 - (or_introl (0 = 1) - (conj (eq_refl 0) (eq_refl 0))) -\textbf{| S n0 {\funarrow}} - exist (fun m : nat {\funarrow} S n0 = 0 {\coqand} m = 0 {\coqor} S n0 = S m) n0 - (or_intror (S n0 = 0 {\coqand} n0 = 0) (eq_refl (S n0))) -\textbf{end} : {\prodsym} n : nat, \textbf{pred_spec n} -\end{alltt} - - -Notice that there are many variants to the pattern ``~\texttt{intros \dots; case \dots}~''. Look at for tactics -``~\texttt{destruct}~'', ``~\texttt{intro \emph{pattern}}~'', etc. in -the reference manual and/or the book. - -\noindent The command \texttt{Extraction} \refmancite{Section -\ref{ExtractionIdent}} can be used to see the computational -contents associated to the \emph{certified} function \texttt{predecessor}: -\begin{alltt} -Extraction predecessor. -\it -(** val predecessor : nat {\arrow} pred_spec **) - -let predecessor = function - | O {\arrow} O - | S n0 {\arrow} n0 -\end{alltt} - - -\begin{exercise} \label{expand} -Prove the following theorem: -\begin{alltt} -Theorem nat_expand : {\prodsym} n:nat, - n = match n with - | 0 {\funarrow} 0 - | S p {\funarrow} S p - end. -\end{alltt} -\end{exercise} - -\subsection{Some Examples of Case Analysis} -\label{CaseScheme} -The reader will find in the Reference manual all details about -typing case analysis (chapter 4: Calculus of Inductive Constructions, -and chapter 15: Extended Pattern-Matching). - -The following commented examples will show the different situations to consider. - - -%\subsubsection{General Scheme} - -%Case analysis is then the most basic elimination rule that {\coq} -%provides for inductive types. This rule follows a general schema, -%valid for any inductive type $I$. First, if $I$ has type -%``~$\forall\,(z_1:A_1)\ldots(z_r:A_r),S$~'', with $S$ either $\Set$, $\Prop$ or -%$\Type$, then a case expression on $p$ of type ``~$R\;a_1\ldots a_r$~'' -% inhabits ``~$Q\;a_1\ldots a_r\;p$~''. The types of the branches of the case expression -%are obtained from the definition of the type in this way: if the type -%of the $i$-th constructor $c_i$ of $R$ is -%``~$\forall\, (x_1:T_1)\ldots -%(x_n:T_n),(R\;q_1\ldots q_r)$~'', then the $i-th$ branch must have the -%form ``~$c_i\; x_1\; \ldots \;x_n\; \funarrow{}\; t_i$~'' where -%$$(x_1:T_1),\ldots, (x_n:T_n) \vdash t_i : Q\;q_1\ldots q_r)$$ -% for non-dependent case -%analysis, and $$(x_1:T_1)\ldots (x_n:T_n)\vdash t_i :Q\;q_1\ldots -%q_r\;({c}_i\;x_1\;\ldots x_n)$$ for dependent one. In the -%following section, we illustrate this general scheme for different -%recursive types. -%%\textbf{A vérifier} - -\subsubsection{The Empty Type} - -In a definition by case analysis, there is one branch for each -introduction rule of the type. Hence, in a definition by case analysis -on $p:\False$ there are no cases to be considered. In other words, the -rule of (non-dependent) case analysis for the type $\False$ is -(for $s$ in \texttt{Prop}, \texttt{Set} or \texttt{Type}): - -\begin{center} -\snregla {\JM{Q}{s}\;\;\;\;\; - \JM{p}{\False}} - {\JM{\texttt{match $p$ return $Q$ with end}}{Q}} -\end{center} - -As a corollary, if we could construct an object in $\False$, then it -could be possible to define an object in any type. The tactic -\texttt{contradiction} \refmancite{Section \ref{Contradiction}} -corresponds to the application of the elimination rule above. It -searches in the context for an absurd hypothesis (this is, a -hypothesis whose type is $\False$) and then proves the goal by a case -analysis of it. - -\begin{alltt} -Theorem fromFalse : False \arrow{} 0=1. -Proof. - intro H. - contradiction. -Qed. -\end{alltt} - - -In {\coq} the negation is defined as follows : - -\begin{alltt} -Definition not (P:Prop) := P {\arrow} False -\end{alltt} - -The proposition ``~\citecoq{not $A$}~'' is also written ``~$\neg A$~''. - -If $A$ and $B$ are propositions, $a$ is a proof of $A$ and -$H$ is a proof of $\neg A$, -the term ``~\citecoq{match $H\;a$ return $B$ with end}~'' is a proof term of -$B$. -Thus, if your goal is $B$ and you have some hypothesis $H:\neg A$, -the tactic ``~\citecoq{case $H$}~'' generates a new subgoal with -statement $A$, as shown by the following example\footnote{Notice that -$a\coqdiff b$ is just an abreviation for ``~\coqnot a= b~''}. - -\begin{alltt} -Fact Nosense : 0 {\coqdiff} 0 {\arrow} 2 = 3. -Proof. - intro H; case H. -\it -=========================== - 0 = 0 -\tt - reflexivity. -Qed. -\end{alltt} - -The tactic ``~\texttt{absurd $A$}~'' (where $A$ is any proposition), -is based on the same principle, but -generates two subgoals: $A$ and $\neg A$, for solving $B$. - -\subsubsection{The Equality Type} - -Let $A:\Type$, $a$, $b$ of type $A$, and $\pi$ a proof of -$a=b$. Non dependent case analysis of $\pi$ allows us to -associate to any proof of ``~$Q\;a$~'' a proof of ``~$Q\;b$~'', -where $Q:A\arrow{} s$ (where $s\in\{\Prop, \Set, \Type\}$). -The following term is a proof of ``~$Q\;a\, \arrow{}\, Q\;b$~''. - -\begin{alltt} -fun H : Q a {\funarrow} - match \(\pi\) in (_ = y) return Q y with - eq_refl {\funarrow} H - end -\end{alltt} -Notice the header of the \texttt{match} construct. -It expresses how the resulting type ``~\citecoq{Q y}~'' depends on -the \emph{type} of \texttt{p}. -Notice also that in the pattern introduced by the keyword \texttt{in}, -the parameter \texttt{a} in the type ``~\texttt{a = y}~'' must be -implicit, and replaced by a wildcard '\texttt{\_}'. - - -Therefore, case analysis on a proof of the equality $a=b$ -amounts to replacing all the occurrences of the term $b$ with the term -$a$ in the goal to be proven. Let us illustrate this through an -example: the transitivity property of this equality. -\begin{alltt} -Theorem trans : {\prodsym} n m p:nat, n=m \arrow{} m=p \arrow{} n=p. -Proof. - intros n m p eqnm. -\it{} - n : nat - m : nat - p : nat - eqnm : n = m - ============================ - m = p {\arrow} n = p -\tt{} case eqnm. -\it{} - n : nat - m : nat - p : nat - eqnm : n = m - ============================ - n = p {\arrow} n = p -\tt{} trivial. -Qed. -\end{alltt} - -%\noindent The case analysis on the hypothesis $H:n=m$ yields the -%tautological subgoal $n=p\rightarrow n=p$, that is directly proven by -%the tactic \texttt{Trivial}. - -\begin{exercise} -Prove the symmetry property of equality. -\end{exercise} - -Instead of using \texttt{case}, we can use the tactic -\texttt{rewrite} \refmancite{Section \ref{Rewrite}}. If $H$ is a proof -of $a=b$, then -``~\citecoq{rewrite $H$}~'' - performs a case analysis on a proof of $b=a$, obtained by applying a -symmetry theorem to $H$. This application of symmetry allows us to rewrite -the equality from left to right, which looks more natural. An optional -parameter (either \texttt{\arrow{}} or \texttt{$\leftarrow$}) can be used to precise -in which sense the equality must be rewritten. By default, -``~\texttt{rewrite} $H$~'' corresponds to ``~\texttt{rewrite \arrow{}} $H$~'' -\begin{alltt} -Lemma Rw : {\prodsym} x y: nat, y = y * x {\arrow} y * x * x = y. - intros x y e; do 2 rewrite <- e. -\it -1 subgoal - - x : nat - y : nat - e : y = y * x - ============================ - y = y -\tt - reflexivity. -Qed. -\end{alltt} - -Notice that, if $H:a=b$, then the tactic ``~\texttt{rewrite $H$}~'' - replaces \textsl{all} the -occurrences of $a$ by $b$. However, in certain situations we could be -interested in rewriting some of the occurrences, but not all of them. -This can be done using the tactic \texttt{pattern} \refmancite{Section -\ref{Pattern}}. Let us consider yet another example to -illustrate this. - -Let us start with some simple theorems of arithmetic; two of them -are already proven in the Standard Library, the last is left as an exercise. - -\begin{alltt} -\it -mult_1_l - : {\prodsym} n : nat, 1 * n = n - -mult_plus_distr_r - : {\prodsym} n m p : nat, (n + m) * p = n * p + m * p - -mult_distr_S : {\prodsym} n p : nat, n * p + p = (S n)* p. -\end{alltt} - -Let us now prove a simple result: - -\begin{alltt} -Lemma four_n : {\prodsym} n:nat, n+n+n+n = 4*n. -Proof. - intro n;rewrite <- (mult_1_l n). -\it - n : nat - ============================ - 1 * n + 1 * n + 1 * n + 1 * n = 4 * (1 * n) -\end{alltt} - -We can see that the \texttt{rewrite} tactic call replaced \emph{all} -the occurrences of \texttt{n} by the term ``~\citecoq{1 * n}~''. -If we want to do the rewriting ony on the leftmost occurrence of -\texttt{n}, we can mark this occurrence using the \texttt{pattern} -tactic: - - -\begin{alltt} - Undo. - intro n; pattern n at 1. - \it - n : nat - ============================ - (fun n0 : nat {\funarrow} n0 + n + n + n = 4 * n) n -\end{alltt} -Applying the tactic ``~\citecoq{pattern n at 1}~'' allowed us -to explicitly abstract the first occurrence of \texttt{n} from the -goal, putting this goal under the form ``~\citecoq{$Q$ n}~'', -thus pointing to \texttt{rewrite} the particular predicate on $n$ -that we search to prove. - - -\begin{alltt} - rewrite <- mult_1_l. -\it -1 subgoal - - n : nat - ============================ - 1 * n + n + n + n = 4 * n -\tt - repeat rewrite mult_distr_S. -\it - n : nat - ============================ - 4 * n = 4 * n -\tt - trivial. -Qed. -\end{alltt} - -\subsubsection{The Predicate $n {\leq} m$} - - -The last but one instance of the elimination schema that we will illustrate is -case analysis for the predicate $n {\leq} m$: - -Let $n$ and $p$ be terms of type \citecoq{nat}, and $Q$ a predicate -of type $\citecoq{nat}\arrow{}\Prop$. -If $H$ is a proof of ``~\texttt{n {\coqle} p}~'', -$H_0$ a proof of ``~\texttt{$Q$ n}~'' and -$H_S$ a proof of the statement ``~\citecoq{{\prodsym}m:nat, n {\coqle} m {\arrow} Q (S m)}~'', -then the term -\begin{alltt} -match H in (_ {\coqle} q) return (Q q) with - | le_n {\funarrow} H0 - | le_S m Hm {\funarrow} HS m Hm -end -\end{alltt} - is a proof term of ``~\citecoq{$Q$ $p$}~''. - - -The two patterns of this \texttt{match} construct describe -all possible forms of proofs of ``~\citecoq{n {\coqle} m}~'' (notice -again that the general parameter \texttt{n} is implicit in - the ``~\texttt{in \dots}~'' -clause and is absent from the match patterns. - - -Notice that the choice of introducing some of the arguments of the -predicate as being general parameters in its definition has -consequences on the rule of case analysis that is derived. In -particular, the type $Q$ of the object defined by the case expression -only depends on the indexes of the predicate, and not on the general -parameters. In the definition of the predicate $\leq$, the first -argument of this relation is a general parameter of the -definition. Hence, the predicate $Q$ to be proven only depends on the -second argument of the relation. In other words, the integer $n$ is -also a general parameter of the rule of case analysis. - -An example of an application of this rule is the following theorem, -showing that any integer greater or equal than $1$ is the successor of another -natural number: - -\begin{alltt} -Lemma predecessor_of_positive : - {\prodsym} n, 1 {\coqle} n {\arrow} {\exsym} p:nat, n = S p. -Proof. - intros n H;case H. -\it - n : nat - H : 1 {\coqle} n - ============================ - {\exsym} p : nat, 1 = S p -\tt - exists 0; trivial. -\it - - n : nat - H : 1 {\coqle} n - ============================ - {\prodsym} m : nat, 0 {\coqle} m {\arrow} {\exsym} p : nat, S m = S p -\tt - intros m _ . - exists m. - trivial. -Qed. -\end{alltt} - - -\subsubsection{Vectors} - -The \texttt{vector} polymorphic and dependent family of types will -give an idea of the most general scheme of pattern-matching. - -For instance, let us define a function for computing the tail of -any vector. Notice that we shall build a \emph{total} function, -by considering that the tail of an empty vector is this vector itself. -In that sense, it will be slightly different from the \texttt{Vtail} -function of the Standard Library, which is defined only for vectors -of type ``~\citecoq{vector $A$ (S $n$)}~''. - -The header of the function we want to build is the following: - -\begin{verbatim} -Definition Vtail_total - (A : Type) (n : nat) (v : vector A n) : vector A (pred n):= -\end{verbatim} - -Since the branches will not have the same type -(depending on the parameter \texttt{n}), -the body of this function is a dependent pattern matching on -\citecoq{v}. -So we will have : -\begin{verbatim} -match v in (vector _ n0) return (vector A (pred n0)) with -\end{verbatim} - -The first branch deals with the constructor \texttt{Vnil} and must -return a value in ``~\citecoq{vector A (pred 0)}~'', convertible -to ``~\citecoq{vector A 0}~''. So, we propose: -\begin{alltt} -| Vnil {\funarrow} Vnil A -\end{alltt} - -The second branch considers a vector in ``~\citecoq{vector A (S n0)}~'' -of the form -``~\citecoq{Vcons A n0 v0}~'', with ``~\citecoq{v0:vector A n0}~'', -and must return a value of type ``~\citecoq{vector A (pred (S n0))}~'', -which is convertible to ``~\citecoq{vector A n0}~''. -This second branch is thus : -\begin{alltt} -| Vcons _ n0 v0 {\funarrow} v0 -\end{alltt} - -Here is the full definition: - -\begin{alltt} -Definition Vtail_total - (A : Type) (n : nat) (v : vector A n) : vector A (pred n):= -match v in (vector _ n0) return (vector A (pred n0)) with -| Vnil {\funarrow} Vnil A -| Vcons _ n0 v0 {\funarrow} v0 -end. -\end{alltt} - - -\subsection{Case Analysis and Logical Paradoxes} - -In the previous section we have illustrated the general scheme for -generating the rule of case analysis associated to some recursive type -from the definition of the type. However, if the logical soundness is -to be preserved, certain restrictions to this schema are -necessary. This section provides a brief explanation of these -restrictions. - - -\subsubsection{The Positivity Condition} -\label{postypes} - -In order to make sense of recursive types as types closed under their -introduction rules, a constraint has to be imposed on the possible -forms of such rules. This constraint, known as the -\textsl{positivity condition}, is necessary to prevent the user from -naively introducing some recursive types which would open the door to -logical paradoxes. An example of such a dangerous type is the -``inductive type'' \citecoq{Lambda}, whose only constructor is -\citecoq{lambda} of type \citecoq{(Lambda\arrow False)\arrow Lambda}. - Following the pattern -given in Section \ref{CaseScheme}, the rule of (non dependent) case -analysis for \citecoq{Lambda} would be the following: - -\begin{center} -\snregla {\JM{Q}{\Prop}\;\;\;\;\; - \JM{p}{\texttt{Lambda}}\;\;\;\;\; - {h : {\texttt{Lambda}}\arrow\False\; \vdash\; t\,:\,Q}} - {\JM{\citecoq{match $p$ return $Q$ with lambda h {\funarrow} $t$ end}}{Q}} -\end{center} - -In order to avoid paradoxes, it is impossible to construct -the type \citecoq{Lambda} in {\coq}: - -\begin{alltt} -Inductive Lambda : Set := - lambda : (Lambda {\arrow} False) {\arrow} Lambda. -\it -Error: Non strictly positive occurrence of "Lambda" in - "(Lambda {\arrow} False) {\arrow} Lambda" -\end{alltt} - -In order to explain this danger, we -will declare some constants for simulating the construction of -\texttt{Lambda} as an inductive type. - -Let us open some section, and declare two variables, the first one for -\texttt{Lambda}, the other for the constructor \texttt{lambda}. - -\begin{alltt} -Section Paradox. -Variable Lambda : Set. -Variable lambda : (Lambda {\arrow} False) {\arrow}Lambda. -\end{alltt} - -Since \texttt{Lambda} is not a truely inductive type, we can't use -the \texttt{match} construct. Nevertheless, we can simulate it by a -variable \texttt{matchL} such that the term -``~\citecoq{matchL $l$ $Q$ (fun $h$ : Lambda {\arrow} False {\funarrow} $t$)}~'' -should be understood as -``~\citecoq{match $l$ return $Q$ with | lambda h {\funarrow} $t$)}~'' - - -\begin{alltt} -Variable matchL : Lambda {\arrow} - {\prodsym} Q:Prop, ((Lambda {\arrow}False) {\arrow} Q) {\arrow} - Q. -\end{alltt} - ->From these constants, it is possible to define application by case -analysis. Then, through auto-application, the well-known looping term -$(\lambda x.(x\;x)\;\lambda x.(x\;x))$ provides a proof of falsehood. - -\begin{alltt} -Definition application (f x: Lambda) :False := - matchL f False (fun h {\funarrow} h x). - -Definition Delta : Lambda := - lambda (fun x : Lambda {\funarrow} application x x). - -Definition loop : False := application Delta Delta. - -Theorem two_is_three : 2 = 3. -Proof. - elim loop. -Qed. - -End Paradox. -\end{alltt} - -\noindent This example can be seen as a formulation of Russell's -paradox in type theory associating $(\textsl{application}\;x\;x)$ to the -formula $x\not\in x$, and \textsl{Delta} to the set $\{ x \mid -x\not\in x\}$. If \texttt{matchL} would satisfy the reduction rule -associated to case analysis, that is, -$$ \citecoq{matchL (lambda $f$) $Q$ $h$} \Longrightarrow h\;f$$ -then the term \texttt{loop} -would compute into itself. This is not actually surprising, since the -proof of the logical soundness of {\coq} strongly lays on the property -that any well-typed term must terminate. Hence, non-termination is -usually a synonymous of inconsistency. - -%\paragraph{} In this case, the construction of a non-terminating -%program comes from the so-called \textsl{negative occurrence} of -%$\Lambda$ in the type of the constructor $\lambda$. In order to be -%admissible for {\coq}, all the occurrences of the recursive type in its -%own introduction rules must be positive, in the sense on the following -%definition: -% -%\begin{enumerate} -%\item $R$ is positive in $(R\;\vec{t})$; -%\item $R$ is positive in $(x: A)C$ if it does not -%occur in $A$ and $R$ is positive in $C$; -%\item if $P\equiv (\vec{x}:\vec{T})Q$, then $R$ is positive in $(P -%\rightarrow C)$ if $R$ does not occur in $\vec{T}$, $R$ is positive -%in $C$, and either -%\begin{enumerate} -%\item $Q\equiv (R\;\vec{q})$ or -%\item $Q\equiv (J\;\vec{t})$, \label{relax} -% where $J$ is a recursive type, and for any term $t_i$ either : -% \begin{enumerate} -% \item $R$ does not occur in $t_i$, or -% \item $t_i\equiv (z:\vec{Z})(R\;\vec{q})$, $R$ does not occur -% in $\vec{Z}$, $t_i$ instantiates a general -% parameter of $J$, and this parameter is positive in the -% arguments of the constructors of $J$. -% \end{enumerate} -%\end{enumerate} -%\end{enumerate} -%\noindent Those types obtained by erasing option (\ref{relax}) in the -%definition above are called \textsl{strictly positive} types. - - -\subsubsection*{Remark} In this case, the construction of a non-terminating -program comes from the so-called \textsl{negative occurrence} of -\texttt{Lambda} in the argument of the constructor \texttt{lambda}. - -The reader will find in the Reference Manual a complete formal -definition of the notions of \emph{positivity condition} and -\emph{strict positivity} that an inductive definition must satisfy. - - -%In order to be -%admissible for {\coq}, the type $R$ must be positive in the types of the -%arguments of its own introduction rules, in the sense on the following -%definition: - -%\textbf{La définition du manuel de référence est plus complexe: -%la recopier ou donner seulement des exemples? -%} -%\begin{enumerate} -%\item $R$ is positive in $T$ if $R$ does not occur in $T$; -%\item $R$ is positive in $(R\;\vec{t})$ if $R$ does not occur in $\vec{t}$; -%\item $R$ is positive in $(x:A)C$ if it does not -% occur in $A$ and $R$ is positive in $C$; -%\item $R$ is positive in $(J\;\vec{t})$, \label{relax} -% if $J$ is a recursive type, and for any term $t_i$ either : -% \begin{enumerate} -% \item $R$ does not occur in $t_i$, or -% \item $R$ is positive in $t_i$, $t_i$ instantiates a general -% parameter of $J$, and this parameter is positive in the -% arguments of the constructors of $J$. -% \end{enumerate} -%\end{enumerate} - -%\noindent When we can show that $R$ is positive without using the item -%(\ref{relax}) of the definition above, then we say that $R$ is -%\textsl{strictly positive}. - -%\textbf{Changer le discours sur les ordinaux} - -Notice that the positivity condition does not forbid us to -put functional recursive -arguments in the constructors. - -For instance, let us consider the type of infinitely branching trees, -with labels in \texttt{Z}. -\begin{alltt} -Require Import ZArith. - -Inductive itree : Set := -| ileaf : itree -| inode : Z {\arrow} (nat {\arrow} itree) {\arrow} itree. -\end{alltt} - -In this representation, the $i$-th child of a tree -represented by ``~\texttt{inode $z$ $s$}~'' is obtained by applying -the function $s$ to $i$. -The following definitions show how to construct a tree with a single -node, a tree of height 1 and a tree of height 2: - -\begin{alltt} -Definition isingle l := inode l (fun i {\funarrow} ileaf). - -Definition t1 := inode 0 (fun n {\funarrow} isingle (Z.of_nat n)). - -Definition t2 := - inode 0 - (fun n : nat {\funarrow} - inode (Z.of_nat n) - (fun p {\funarrow} isingle (Z.of_nat (n*p)))). -\end{alltt} - - -Let us define a preorder on infinitely branching trees. - In order to compare two non-leaf trees, -it is necessary to compare each of their children - without taking care of the order in which they -appear: - -\begin{alltt} -Inductive itree_le : itree{\arrow} itree {\arrow} Prop := - | le_leaf : {\prodsym} t, itree_le ileaf t - | le_node : {\prodsym} l l' s s', - Z.le l l' {\arrow} - ({\prodsym} i, {\exsym} j:nat, itree_le (s i) (s' j)){\arrow} - itree_le (inode l s) (inode l' s'). - -\end{alltt} - -Notice that a call to the predicate \texttt{itree\_le} appears as -a general parameter of the inductive type \texttt{ex} (see Sect.\ref{ex-def}). -This kind of definition is accepted by {\coq}, but may lead to some -difficulties, since the induction principle automatically -generated by the system -is not the most appropriate (see chapter 14 of~\cite{coqart} for a detailed -explanation). - - -The following definition, obtained by -skolemising the -proposition \linebreak $\forall\, i,\exists\, j,(\texttt{itree\_le}\;(s\;i)\;(s'\;j))$ in -the type of \texttt{itree\_le}, does not present this problem: - - -\begin{alltt} -Inductive itree_le' : itree{\arrow} itree {\arrow} Prop := - | le_leaf' : {\prodsym} t, itree_le' ileaf t - | le_node' : {\prodsym} l l' s s' g, - Z.le l l' {\arrow} - ({\prodsym} i, itree_le' (s i) (s' (g i))) {\arrow} - itree_le' (inode l s) (inode l' s'). - -\end{alltt} -\iffalse -\begin{alltt} -Lemma t1_le'_t2 : itree_le' t1 t2. -Proof. - unfold t1, t2. - constructor 2 with (fun i : nat {\funarrow} 2 * i). - auto with zarith. - unfold isingle; - intro i ; constructor 2 with (fun i :nat {\funarrow} i). - auto with zarith. - constructor . -Qed. -\end{alltt} -\fi - -%In general, strictly positive definitions are preferable to only -%positive ones. The reason is that it is sometimes difficult to derive -%structural induction combinators for the latter ones. Such combinators -%are automatically generated for strictly positive types, but not for -%the only positive ones. Nevertheless, sometimes non-strictly positive -%definitions provide a smarter or shorter way of declaring a recursive -%type. - -Another example is the type of trees - of unbounded width, in which a recursive subterm -\texttt{(ltree A)} instantiates the type of polymorphic lists: - -\begin{alltt} -Require Import List. - -Inductive ltree (A:Set) : Set := - lnode : A {\arrow} list (ltree A) {\arrow} ltree A. -\end{alltt} - -This declaration can be transformed -adding an extra type to the definition, as was done in Section -\ref{MutuallyDependent}. - - -\subsubsection{Impredicative Inductive Types} - -An inductive type $I$ inhabiting a universe $U$ is \textsl{predicative} -if the introduction rules of $I$ do not make a universal -quantification on a universe containing $U$. All the recursive types -previously introduced are examples of predicative types. An example of -an impredicative one is the following type: -%\textsl{exT}, the dependent product -%of a certain set (or proposition) $x$, and a proof of a property $P$ -%about $x$. - -%\begin{alltt} -%Print exT. -%\end{alltt} -%\textbf{ttention, EXT c'est ex!} -%\begin{alltt} -%Check (exists P:Prop, P {\arrow} not P). -%\end{alltt} - -%This type is useful for expressing existential quantification over -%types, like ``there exists a proposition $x$ such that $(P\;x)$'' -%---written $(\textsl{EXT}\; x:Prop \mid (P\;x))$ in {\coq}. However, - -\begin{alltt} -Inductive prop : Prop := - prop_intro : Prop {\arrow} prop. -\end{alltt} - -Notice -that the constructor of this type can be used to inject any -proposition --even itself!-- into the type. - -\begin{alltt} -Check (prop_intro prop).\it -prop_intro prop - : prop -\end{alltt} - -A careless use of such a -self-contained objects may lead to a variant of Burali-Forti's -paradox. The construction of Burali-Forti's paradox is more -complicated than Russel's one, so we will not describe it here, and -point the interested reader to \cite{Bar98,Coq86}. - - -Another example is the second order existential quantifier for propositions: - -\begin{alltt} -Inductive ex_Prop (P : Prop {\arrow} Prop) : Prop := - exP_intro : {\prodsym} X : Prop, P X {\arrow} ex_Prop P. -\end{alltt} - -%\begin{alltt} -%(* -%Check (match prop_inject with (prop_intro p _) {\funarrow} p end). - -%Error: Incorrect elimination of "prop_inject" in the inductive type -% ex -%The elimination predicate ""fun _ : prop {\funarrow} Prop" has type -% "prop {\arrow} Type" -%It should be one of : -% "Prop" - -%Elimination of an inductive object of sort : "Prop" -%is not allowed on a predicate in sort : "Type" -%because non-informative objects may not construct informative ones. - -%*) -%Print prop_inject. - -%(* -%prop_inject = -%prop_inject = prop_intro prop (fun H : prop {\funarrow} H) -% : prop -%*) -%\end{alltt} - -% \textbf{Et par ça? -%} - -Notice that predicativity on sort \citecoq{Set} forbids us to build -the following definitions. - - -\begin{alltt} -Inductive aSet : Set := - aSet_intro: Set {\arrow} aSet. - -\it{}User error: Large non-propositional inductive types must be in Type -\tt -Inductive ex_Set (P : Set {\arrow} Prop) : Set := - exS_intro : {\prodsym} X : Set, P X {\arrow} ex_Set P. - -\it{}User error: Large non-propositional inductive types must be in Type -\end{alltt} - -Nevertheless, one can define types like \citecoq{aSet} and \citecoq{ex\_Set}, as inhabitants of \citecoq{Type}. - -\begin{alltt} -Inductive ex_Set (P : Set {\arrow} Prop) : Type := - exS_intro : {\prodsym} X : Set, P X {\arrow} ex_Set P. -\end{alltt} - -In the following example, the inductive type \texttt{typ} can be defined, -but the term associated with the interactive Definition of -\citecoq{typ\_inject} is incompatible with {\coq}'s hierarchy of universes: - - -\begin{alltt} -Inductive typ : Type := - typ_intro : Type {\arrow} typ. - -Definition typ_inject: typ. - split; exact typ. -\it Proof completed - -\tt{}Defined. -\it Error: Universe Inconsistency. -\tt -Abort. -\end{alltt} - -One possible way of avoiding this new source of paradoxes is to -restrict the kind of eliminations by case analysis that can be done on -impredicative types. In particular, projections on those universes -equal or bigger than the one inhabited by the impredicative type must -be forbidden \cite{Coq86}. A consequence of this restriction is that it -is not possible to define the first projection of the type -``~\citecoq{ex\_Prop $P$}~'': -\begin{alltt} -Check (fun (P:Prop{\arrow}Prop)(p: ex_Prop P) {\funarrow} - match p with exP_intro X HX {\funarrow} X end). -\it -Error: -Incorrect elimination of "p" in the inductive type -"ex_Prop", the return type has sort "Type" while it should be -"Prop" - -Elimination of an inductive object of sort "Prop" -is not allowed on a predicate in sort "Type" -because proofs can be eliminated only to build proofs. -\end{alltt} - -%In order to explain why, let us consider for example the following -%impredicative type \texttt{ALambda}. -%\begin{alltt} -%Inductive ALambda : Set := -% alambda : (A:Set)(A\arrow{}False)\arrow{}ALambda. -% -%Definition Lambda : Set := ALambda. -%Definition lambda : (ALambda\arrow{}False)\arrow{}ALambda := (alambda ALambda). -%Lemma CaseAL : (Q:Prop)ALambda\arrow{}((ALambda\arrow{}False)\arrow{}Q)\arrow{}Q. -%\end{alltt} -% -%This type contains all the elements of the dangerous type $\Lambda$ -%described at the beginning of this section. Try to construct the -%non-ending term $(\Delta\;\Delta)$ as an object of -%\texttt{ALambda}. Why is it not possible? - -\subsubsection{Extraction Constraints} - -There is a final constraint on case analysis that is not motivated by -the potential introduction of paradoxes, but for compatibility reasons -with {\coq}'s extraction mechanism \refmancite{Appendix -\ref{CamlHaskellExtraction}}. This mechanism is based on the -classification of basic types into the universe $\Set$ of sets and the -universe $\Prop$ of propositions. The objects of a type in the -universe $\Set$ are considered as relevant for computation -purposes. The objects of a type in $\Prop$ are considered just as -formalised comments, not necessary for execution. The extraction -mechanism consists in erasing such formal comments in order to obtain -an executable program. Hence, in general, it is not possible to define -an object in a set (that should be kept by the extraction mechanism) -by case analysis of a proof (which will be thrown away). - -Nevertheless, this general rule has an exception which is important in -practice: if the definition proceeds by case analysis on a proof of a -\textsl{singleton proposition} or an empty type (\emph{e.g.} \texttt{False}), - then it is allowed. A singleton -proposition is a non-recursive proposition with a single constructor -$c$, all whose arguments are proofs. For example, the propositional -equality and the conjunction of two propositions are examples of -singleton propositions. - -%From the point of view of the extraction -%mechanism, such types are isomorphic to a type containing a single -%object $c$, so a definition $\Case{x}{c \Rightarrow b}$ is -%directly replaced by $b$ as an extra optimisation. - -\subsubsection{Strong Case Analysis on Proofs} - -One could consider allowing - to define a proposition $Q$ by case -analysis on the proofs of another recursive proposition $R$. As we -will see in Section \ref{Discrimination}, this would enable one to prove that -different introduction rules of $R$ construct different -objects. However, this property would be in contradiction with the principle -of excluded middle of classical logic, because this principle entails -that the proofs of a proposition cannot be distinguished. This -principle is not provable in {\coq}, but it is frequently introduced by -the users as an axiom, for reasoning in classical logic. For this -reason, the definition of propositions by case analysis on proofs is - not allowed in {\coq}. - -\begin{alltt} - -Definition comes_from_the_left (P Q:Prop)(H:P{\coqor}Q): Prop := - match H with - | or_introl p {\funarrow} True - | or_intror q {\funarrow} False - end. -\it -Error: -Incorrect elimination of "H" in the inductive type -"or", the return type has sort "Type" while it should be -"Prop" - -Elimination of an inductive object of sort "Prop" -is not allowed on a predicate in sort "Type" -because proofs can be eliminated only to build proofs. - -\end{alltt} - -On the other hand, if we replace the proposition $P {\coqor} Q$ with -the informative type $\{P\}+\{Q\}$, the elimination is accepted: - -\begin{alltt} -Definition comes_from_the_left_sumbool - (P Q:Prop)(x:\{P\} + \{Q\}): Prop := - match x with - | left p {\funarrow} True - | right q {\funarrow} False - end. -\end{alltt} - - -\subsubsection{Summary of Constraints} - -To end with this section, the following table summarizes which -universe $U_1$ may inhabit an object of type $Q$ defined by case -analysis on $x:R$, depending on the universe $U_2$ inhabited by the -inductive types $R$.\footnote{In the box indexed by $U_1=\citecoq{Type}$ -and $U_2=\citecoq{Set}$, the answer ``yes'' takes into account the -predicativity of sort \citecoq{Set}. If you are working with the -option ``impredicative-set'', you must put in this box the -condition ``if $R$ is predicative''.} - - -\begin{center} -%%% displease hevea less by using * in multirow rather than \LL -\renewcommand{\multirowsetup}{\centering} -%\newlength{\LL} -%\settowidth{\LL}{$x : R : U_2$} -\begin{tabular}{|c|c|c|c|c|} -\hline -\multirow{5}*{$x : R : U_2$} & -\multicolumn{4}{|c|}{$Q : U_1$}\\ -\hline -& &\textsl{Set} & \textsl{Prop} & \textsl{Type}\\ -\cline{2-5} -&\textsl{Set} & yes & yes & yes\\ -\cline{2-5} -&\textsl{Prop} & if $R$ singleton & yes & no\\ -\cline{2-5} -&\textsl{Type} & yes & yes & yes\\ -\hline -\end{tabular} -\end{center} - -\section{Some Proof Techniques Based on Case Analysis} -\label{CaseTechniques} - -In this section we illustrate the use of case analysis as a proof -principle, explaining the proof techniques behind three very useful -{\coq} tactics, called \texttt{discriminate}, \texttt{injection} and -\texttt{inversion}. - -\subsection{Discrimination of introduction rules} -\label{Discrimination} - -In the informal semantics of recursive types described in Section -\ref{Introduction} it was said that each of the introduction rules of a -recursive type is considered as being different from all the others. -It is possible to capture this fact inside the logical system using -the propositional equality. We take as example the following theorem, -stating that \textsl{O} constructs a natural number different -from any of those constructed with \texttt{S}. - -\begin{alltt} -Theorem S_is_not_O : {\prodsym} n, S n {\coqdiff} 0. -\end{alltt} - -In order to prove this theorem, we first define a proposition by case -analysis on natural numbers, so that the proposition is true for {\Z} -and false for any natural number constructed with {\SUCC}. This uses -the empty and singleton type introduced in Sections \ref{Introduction}. - -\begin{alltt} -Definition Is_zero (x:nat):= match x with - | 0 {\funarrow} True - | _ {\funarrow} False - end. -\end{alltt} - -\noindent Then, we prove the following lemma: - -\begin{alltt} -Lemma O_is_zero : {\prodsym} m, m = 0 {\arrow} Is_zero m. -Proof. - intros m H; subst m. -\it{} -================ - Is_zero 0 -\tt{} -simpl;trivial. -Qed. -\end{alltt} - -\noindent Finally, the proof of \texttt{S\_is\_not\_O} follows by the -application of the previous lemma to $S\;n$. - - -\begin{alltt} - - red; intros n Hn. - \it{} - n : nat - Hn : S n = 0 - ============================ - False \tt - - apply O_is_zero with (m := S n). - assumption. -Qed. -\end{alltt} - - -The tactic \texttt{discriminate} \refmancite{Section \ref{Discriminate}} is -a special-purpose tactic for proving disequalities between two -elements of a recursive type introduced by different constructors. It -generalizes the proof method described here for natural numbers to any -[co]-inductive type. This tactic is also capable of proving disequalities -where the difference is not in the constructors at the head of the -terms, but deeper inside them. For example, it can be used to prove -the following theorem: - -\begin{alltt} -Theorem disc2 : {\prodsym} n, S (S n) {\coqdiff} 1. -Proof. - intros n Hn; discriminate. -Qed. -\end{alltt} - -When there is an assumption $H$ in the context stating a false -equality $t_1=t_2$, \texttt{discriminate} solves the goal by first -proving $(t_1\not =t_2)$ and then reasoning by absurdity with respect -to $H$: - -\begin{alltt} -Theorem disc3 : {\prodsym} n, S (S n) = 0 {\arrow} {\prodsym} Q:Prop, Q. -Proof. - intros n Hn Q. - discriminate. -Qed. -\end{alltt} - -\noindent In this case, the proof proceeds by absurdity with respect -to the false equality assumed, whose negation is proved by -discrimination. - -\subsection{Injectiveness of introduction rules} - -Another useful property about recursive types is the -\textsl{injectiveness} of introduction rules, i.e., that whenever two -objects were built using the same introduction rule, then this rule -should have been applied to the same element. This can be stated -formally using the propositional equality: - -\begin{alltt} -Theorem inj : {\prodsym} n m, S n = S m {\arrow} n = m. -Proof. -\end{alltt} - -\noindent This theorem is just a corollary of a lemma about the -predecessor function: - -\begin{alltt} - Lemma inj_pred : {\prodsym} n m, n = m {\arrow} pred n = pred m. - Proof. - intros n m eq_n_m. - rewrite eq_n_m. - trivial. - Qed. -\end{alltt} -\noindent Once this lemma is proven, the theorem follows directly -from it: -\begin{alltt} - intros n m eq_Sn_Sm. - apply inj_pred with (n:= S n) (m := S m); assumption. -Qed. -\end{alltt} - -This proof method is implemented by the tactic \texttt{injection} -\refmancite{Section \ref{injection}}. This tactic is applied to -a term $t$ of type ``~$c\;{t_1}\;\dots\;t_n = c\;t'_1\;\dots\;t'_n$~'', where $c$ is some constructor of -an inductive type. The tactic \texttt{injection} is applied as deep as -possible to derive the equality of all pairs of subterms of $t_i$ and $t'_i$ -placed in the same position. All these equalities are put as antecedents -of the current goal. - - - -Like \texttt{discriminate}, the tactic \citecoq{injection} -can be also applied if $x$ does not -occur in a direct sub-term, but somewhere deeper inside it. Its -application may leave some trivial goals that can be easily solved -using the tactic \texttt{trivial}. - -\begin{alltt} - - Lemma list_inject : {\prodsym} (A:Type)(a b :A)(l l':list A), - a :: b :: l = b :: a :: l' {\arrow} a = b {\coqand} l = l'. -Proof. - intros A a b l l' e. - - -\it - e : a :: b :: l = b :: a :: l' - ============================ - a = b {\coqand} l = l' -\tt - injection e. -\it - ============================ - l = l' {\arrow} b = a {\arrow} a = b {\arrow} a = b {\coqand} l = l' - -\tt{} auto. -Qed. -\end{alltt} - -\subsection{Inversion Techniques}\label{inversion} - -In section \ref{DependentCase}, we motivated the rule of dependent case -analysis as a way of internalizing the informal equalities $n=O$ and -$n=\SUCC\;p$ associated to each case. This internalisation -consisted in instantiating $n$ with the corresponding term in the type -of each branch. However, sometimes it could be better to internalise -these equalities as extra hypotheses --for example, in order to use -the tactics \texttt{rewrite}, \texttt{discriminate} or -\texttt{injection} presented in the previous sections. This is -frequently the case when the element analysed is denoted by a term -which is not a variable, or when it is an object of a particular -instance of a recursive family of types. Consider for example the -following theorem: - -\begin{alltt} -Theorem not_le_Sn_0 : {\prodsym} n:nat, ~ (S n {\coqle} 0). -\end{alltt} - -\noindent Intuitively, this theorem should follow by case analysis on -the hypothesis $H:(S\;n\;\leq\;\Z)$, because no introduction rule allows -to instantiate the arguments of \citecoq{le} with respectively a successor -and zero. However, there -is no way of capturing this with the typing rule for case analysis -presented in section \ref{Introduction}, because it does not take into -account what particular instance of the family the type of $H$ is. -Let us try it: -\begin{alltt} -Proof. - red; intros n H; case H. -\it 2 subgoals - - n : nat - H : S n {\coqle} 0 - ============================ - False - -subgoal 2 is: - {\prodsym} m : nat, S n {\coqle} m {\arrow} False -\tt -Undo. -\end{alltt} - -\noindent What is necessary here is to make available the equalities -``~$\SUCC\;n = \Z$~'' and ``~$\SUCC\;m = \Z$~'' - as extra hypotheses of the -branches, so that the goal can be solved using the -\texttt{Discriminate} tactic. In order to obtain the desired -equalities as hypotheses, let us prove an auxiliary lemma, that our -theorem is a corollary of: - -\begin{alltt} - Lemma not_le_Sn_0_with_constraints : - {\prodsym} n p , S n {\coqle} p {\arrow} p = 0 {\arrow} False. - Proof. - intros n p H; case H . -\it -2 subgoals - - n : nat - p : nat - H : S n {\coqle} p - ============================ - S n = 0 {\arrow} False - -subgoal 2 is: - {\prodsym} m : nat, S n {\coqle} m {\arrow} S m = 0 {\arrow} False -\tt - intros;discriminate. - intros;discriminate. -Qed. -\end{alltt} -\noindent Our main theorem can now be solved by an application of this lemma: -\begin{alltt} -Show. -\it -2 subgoals - - n : nat - p : nat - H : S n {\coqle} p - ============================ - S n = 0 {\arrow} False - -subgoal 2 is: - {\prodsym} m : nat, S n {\coqle} m {\arrow} S m = 0 {\arrow} False -\tt - eapply not_le_Sn_0_with_constraints; eauto. -Qed. -\end{alltt} - - -The general method to address such situations consists in changing the -goal to be proven into an implication, introducing as preconditions -the equalities needed to eliminate the cases that make no -sense. This proof technique is implemented by the tactic -\texttt{inversion} \refmancite{Section \ref{Inversion}}. In order -to prove a goal $G\;\vec{q}$ from an object of type $R\;\vec{t}$, -this tactic automatically generates a lemma $\forall, \vec{x}. -(R\;\vec{x}) \rightarrow \vec{x}=\vec{t}\rightarrow \vec{B}\rightarrow -(G\;\vec{q})$, where the list of propositions $\vec{B}$ correspond to -the subgoals that cannot be directly proven using -\texttt{discriminate}. This lemma can either be saved for later -use, or generated interactively. In this latter case, the subgoals -yielded by the tactic are the hypotheses $\vec{B}$ of the lemma. If the -lemma has been stored, then the tactic \linebreak - ``~\citecoq{inversion \dots using \dots}~'' can be -used to apply it. - -Let us show both techniques on our previous example: - -\subsubsection{Interactive mode} - -\begin{alltt} -Theorem not_le_Sn_0' : {\prodsym} n:nat, ~ (S n {\coqle} 0). -Proof. - red; intros n H ; inversion H. -Qed. -\end{alltt} - - -\subsubsection{Static mode} - -\begin{alltt} - -Derive Inversion le_Sn_0_inv with ({\prodsym} n :nat, S n {\coqle} 0). -Theorem le_Sn_0'' : {\prodsym} n p : nat, ~ S n {\coqle} 0 . -Proof. - intros n p H; - inversion H using le_Sn_0_inv. -Qed. -\end{alltt} - - -In the example above, all the cases are solved using discriminate, so -there remains no subgoal to be proven (i.e. the list $\vec{B}$ is -empty). Let us present a second example, where this list is not empty: - - -\begin{alltt} -TTheorem le_reverse_rules : - {\prodsym} n m:nat, n {\coqle} m {\arrow} - n = m {\coqor} - {\exsym} p, n {\coqle} p {\coqand} m = S p. -Proof. - intros n m H; inversion H. -\it -2 subgoals - - - - - n : nat - m : nat - H : n {\coqle} m - H0 : n = m - ============================ - m = m {\coqor} ({\exsym} p : nat, m {\coqle} p {\coqand} m = S p) - -subgoal 2 is: - n = S m0 {\coqor} ({\exsym} p : nat, n {\coqle} p {\coqand} S m0 = S p) -\tt - left;trivial. - right; exists m0; split; trivial. -\it -Proof completed -\end{alltt} - -This example shows how this tactic can be used to ``reverse'' the -introduction rules of a recursive type, deriving the possible premises -that could lead to prove a given instance of the predicate. This is -why these tactics are called \texttt{inversion} tactics: they go back -from conclusions to premises. - -The hypotheses corresponding to the propositional equalities are not -needed in this example, since the tactic does the necessary rewriting -to solve the subgoals. When the equalities are no longer needed after -the inversion, it is better to use the tactic -\texttt{Inversion\_clear}. This variant of the tactic clears from the -context all the equalities introduced. - -\begin{alltt} -Restart. - intros n m H; inversion_clear H. -\it -\it - - n : nat - m : nat - ============================ - m = m {\coqor} ({\exsym} p : nat, m {\coqle} p {\coqand} m = S p) -\tt - left;trivial. -\it - n : nat - m : nat - m0 : nat - H0 : n {\coqle} m0 - ============================ - n = S m0 {\coqor} ({\exsym} p : nat, n {\coqle} p {\coqand} S m0 = S p) -\tt - right; exists m0; split; trivial. -Qed. -\end{alltt} - - -%This proof technique works in most of the cases, but not always. In -%particular, it could not if the list $\vec{t}$ contains a term $t_j$ -%whose type $T$ depends on a previous term $t_i$, with $i<j$. Remark -%that if this is the case, the propositional equality $x_j=t_j$ is not -%well-typed, since $x_j:T(x_i)$ but $t_j:T(t_i)$, and both types are -%not convertible (otherwise, the problem could be solved using the -%tactic \texttt{Case}). - - - -\begin{exercise} -Consider the following language of arithmetic expression, and -its operational semantics, described by a set of rewriting rules. -%\textbf{J'ai enlevé une règle de commutativité de l'addition qui -%me paraissait bizarre du point de vue de la sémantique opérationnelle} - -\begin{alltt} -Inductive ArithExp : Set := - | Zero : ArithExp - | Succ : ArithExp {\arrow} ArithExp - | Plus : ArithExp {\arrow} ArithExp {\arrow} ArithExp. - -Inductive RewriteRel : ArithExp {\arrow} ArithExp {\arrow} Prop := - | RewSucc : {\prodsym} e1 e2 :ArithExp, - RewriteRel e1 e2 {\arrow} - RewriteRel (Succ e1) (Succ e2) - | RewPlus0 : {\prodsym} e:ArithExp, - RewriteRel (Plus Zero e) e - | RewPlusS : {\prodsym} e1 e2:ArithExp, - RewriteRel e1 e2 {\arrow} - RewriteRel (Plus (Succ e1) e2) - (Succ (Plus e1 e2)). - -\end{alltt} -\begin{enumerate} -\item Prove that \texttt{Zero} cannot be rewritten any further. -\item Prove that an expression of the form ``~$\texttt{Succ}\;e$~'' is always -rewritten -into an expression of the same form. -\end{enumerate} -\end{exercise} - -%Theorem zeroNotCompute : (e:ArithExp)~(RewriteRel Zero e). -%Intro e. -%Red. -%Intro H. -%Inversion_clear H. -%Defined. -%Theorem evalPlus : -% (e1,e2:ArithExp) -% (RewriteRel (Succ e1) e2)\arrow{}(EX e3 : ArithExp | e2=(Succ e3)). -%Intros e1 e2 H. -%Inversion_clear H. -%Exists e3;Reflexivity. -%Qed. - - -\section{Inductive Types and Structural Induction} -\label{StructuralInduction} - -Elements of inductive types are well-founded with -respect to the structural order induced by the constructors of the -type. In addition to case analysis, this extra hypothesis about -well-foundedness justifies a stronger elimination rule for them, called -\textsl{structural induction}. This form of elimination consists in -defining a value ``~$f\;x$~'' from some element $x$ of the inductive type -$I$, assuming that values have been already associated in the same way -to the sub-parts of $x$ of type $I$. - - -Definitions by structural induction are expressed through the -\texttt{Fixpoint} command \refmancite{Section -\ref{Fixpoint}}. This command is quite close to the -\texttt{let-rec} construction of functional programming languages. -For example, the following definition introduces the addition of two -natural numbers (already defined in the Standard Library:) - -\begin{alltt} -Fixpoint plus (n p:nat) \{struct n\} : nat := - match n with - | 0 {\funarrow} p - | S m {\funarrow} S (plus m p) - end. -\end{alltt} - -The definition is by structural induction on the first argument of the -function. This is indicated by the ``~\citecoq{\{struct n\}}~'' -directive in the function's header\footnote{This directive is optional -in the case of a function of a single argument}. - In -order to be accepted, the definition must satisfy a syntactical -condition, called the \textsl{guardedness condition}. Roughly -speaking, this condition constrains the arguments of a recursive call -to be pattern variables, issued from a case analysis of the formal -argument of the function pointed by the \texttt{struct} directive. - In the case of the -function \texttt{plus}, the argument \texttt{m} in the recursive call is a -pattern variable issued from a case analysis of \texttt{n}. Therefore, the -definition is accepted. - -Notice that we could have defined the addition with structural induction -on its second argument: -\begin{alltt} -Fixpoint plus' (n p:nat) \{struct p\} : nat := - match p with - | 0 {\funarrow} n - | S q {\funarrow} S (plus' n q) - end. -\end{alltt} - -%This notation is useful when defining a function whose decreasing -%argument has a dependent type. As an example, consider the following -%recursivly defined proof of the theorem -%$(n,m:\texttt{nat})n<m \rightarrow (S\;n)<(S\;m)$: -%\begin{alltt} -%Fixpoint lt_n_S [n,m:nat;p:(lt n m)] : (lt (S n) (S m)) := -% <[n0:nat](lt (S n) (S n0))> -% Cases p of -% lt_intro1 {\funarrow} (lt_intro1 (S n)) -% | (lt_intro2 m1 p2) {\funarrow} (lt_intro2 (S n) (S m1) (lt_n_S n m1 p2)) -% end. -%\end{alltt} - -%The guardedness condition must be satisfied only by the last argument -%of the enclosed list. For example, the following declaration is an -%alternative way of defining addition: - -%\begin{alltt} -%Reset add. -%Fixpoint add [n:nat] : nat\arrow{}nat := -% Cases n of -% O {\funarrow} [x:nat]x -% | (S m) {\funarrow} [x:nat](add m (S x)) -% end. -%\end{alltt} - -In the following definition of addition, -the second argument of {\tt plus{'}{'}} grows at each -recursive call. However, as the first one always decreases, the -definition is sound. -\begin{alltt} -Fixpoint plus'' (n p:nat) \{struct n\} : nat := - match n with - | 0 {\funarrow} p - | S m {\funarrow} plus'' m (S p) - end. -\end{alltt} - - Moreover, the argument in the recursive call -could be a deeper component of $n$. This is the case in the following -definition of a boolean function determining whether a number is even -or odd: - -\begin{alltt} -Fixpoint even_test (n:nat) : bool := - match n - with 0 {\funarrow} true - | 1 {\funarrow} false - | S (S p) {\funarrow} even_test p - end. -\end{alltt} - -Mutually dependent definitions by structural induction are also -allowed. For example, the previous function \textsl{even} could alternatively -be defined using an auxiliary function \textsl{odd}: - -\begin{alltt} -Reset even_test. - - - -Fixpoint even_test (n:nat) : bool := - match n - with - | 0 {\funarrow} true - | S p {\funarrow} odd_test p - end -with odd_test (n:nat) : bool := - match n - with - | 0 {\funarrow} false - | S p {\funarrow} even_test p - end. -\end{alltt} - -%\begin{exercise} -%Define a function by structural induction that computes the number of -%nodes of a tree structure defined in page \pageref{Forest}. -%\end{exercise} - -Definitions by structural induction are computed - only when they are applied, and the decreasing argument -is a term having a constructor at the head. We can check this using -the \texttt{Eval} command, which computes the normal form of a well -typed term. - -\begin{alltt} -Eval simpl in even_test. -\it - = even_test - : nat {\arrow} bool -\tt -Eval simpl in (fun x : nat {\funarrow} even x). -\it - = fun x : nat {\funarrow} even x - : nat {\arrow} Prop -\tt -Eval simpl in (fun x : nat => plus 5 x). -\it - = fun x : nat {\funarrow} S (S (S (S (S x)))) - -\tt -Eval simpl in (fun x : nat {\funarrow} even_test (plus 5 x)). -\it - = fun x : nat {\funarrow} odd_test x - : nat {\arrow} bool -\tt -Eval simpl in (fun x : nat {\funarrow} even_test (plus x 5)). -\it - = fun x : nat {\funarrow} even_test (x + 5) - : nat {\arrow} bool -\end{alltt} - - -%\begin{exercise} -%Prove that the second definition of even satisfies the following -%theorem: -%\begin{verbatim} -%Theorem unfold_even : -% (x:nat) -% (even x)= (Cases x of -% O {\funarrow} true -% | (S O) {\funarrow} false -% | (S (S m)) {\funarrow} (even m) -% end). -%\end{verbatim} -%\end{exercise} - -\subsection{Proofs by Structural Induction} - -The principle of structural induction can be also used in order to -define proofs, that is, to prove theorems. Let us call an -\textsl{elimination combinator} any function that, given a predicate -$P$, defines a proof of ``~$P\;x$~'' by structural induction on $x$. In -{\coq}, the principle of proof by induction on natural numbers is a -particular case of an elimination combinator. The definition of this -combinator depends on three general parameters: the predicate to be -proven, the base case, and the inductive step: - -\begin{alltt} -Section Principle_of_Induction. -Variable P : nat {\arrow} Prop. -Hypothesis base_case : P 0. -Hypothesis inductive_step : {\prodsym} n:nat, P n {\arrow} P (S n). -Fixpoint nat_ind (n:nat) : (P n) := - match n return P n with - | 0 {\funarrow} base_case - | S m {\funarrow} inductive_step m (nat_ind m) - end. - -End Principle_of_Induction. -\end{alltt} - -As this proof principle is used very often, {\coq} automatically generates it -when an inductive type is introduced. Similar principles -\texttt{nat\_rec} and \texttt{nat\_rect} for defining objects in the -universes $\Set$ and $\Type$ are also automatically generated -\footnote{In fact, whenever possible, {\coq} generates the -principle \texttt{$I$\_rect}, then derives from it the -weaker principles \texttt{$I$\_ind} and \texttt{$I$\_rec}. -If some principle has to be defined by hand, the user may try -to build \texttt{$I$\_rect} (if possible). Thanks to {\coq}'s conversion -rule, this principle can be used directly to build proofs and/or -programs.}. The -command \texttt{Scheme} \refmancite{Section \ref{Scheme}} can be -used to generate an elimination combinator from certain parameters, -like the universe that the defined objects must inhabit, whether the -case analysis in the definitions must be dependent or not, etc. For -example, it can be used to generate an elimination combinator for -reasoning on even natural numbers from the mutually dependent -predicates introduced in page \pageref{Even}. We do not display the -combinators here by lack of space, but you can see them using the -\texttt{Print} command. - -\begin{alltt} -Scheme Even_induction := Minimality for even Sort Prop -with Odd_induction := Minimality for odd Sort Prop. -\end{alltt} - -\begin{alltt} -Theorem even_plus_four : {\prodsym} n:nat, even n {\arrow} even (4+n). -Proof. - intros n H. - elim H using Even_induction with (P0 := fun n {\funarrow} odd (4+n)); - simpl;repeat constructor;assumption. -Qed. -\end{alltt} - -Another example of an elimination combinator is the principle -of double induction on natural numbers, introduced by the following -definition: - -\begin{alltt} -Section Principle_of_Double_Induction. -Variable P : nat {\arrow} nat {\arrow}Prop. -Hypothesis base_case1 : {\prodsym} m:nat, P 0 m. -Hypothesis base_case2 : {\prodsym} n:nat, P (S n) 0. -Hypothesis inductive_step : {\prodsym} n m:nat, P n m {\arrow} - \,\, P (S n) (S m). - -Fixpoint nat_double_ind (n m:nat)\{struct n\} : P n m := - match n, m return P n m with - | 0 , x {\funarrow} base_case1 x - | (S x), 0 {\funarrow} base_case2 x - | (S x), (S y) {\funarrow} inductive_step x y (nat_double_ind x y) - end. -End Principle_of_Double_Induction. -\end{alltt} - -Changing the type of $P$ into $\nat\rightarrow\nat\rightarrow\Type$, -another combinator for constructing -(certified) programs, \texttt{nat\_double\_rect}, can be defined in exactly the same way. -This definition is left as an exercise.\label{natdoublerect} - -\iffalse -\begin{alltt} -Section Principle_of_Double_Recursion. -Variable P : nat {\arrow} nat {\arrow} Type. -Hypothesis base_case1 : {\prodsym} x:nat, P 0 x. -Hypothesis base_case2 : {\prodsym} x:nat, P (S x) 0. -Hypothesis inductive_step : {\prodsym} n m:nat, P n m {\arrow} P (S n) (S m). -Fixpoint nat_double_rect (n m:nat)\{struct n\} : P n m := - match n, m return P n m with - 0 , x {\funarrow} base_case1 x - | (S x), 0 {\funarrow} base_case2 x - | (S x), (S y) {\funarrow} inductive_step x y (nat_double_rect x y) - end. -End Principle_of_Double_Recursion. -\end{alltt} -\fi -For instance the function computing the minimum of two natural -numbers can be defined in the following way: - -\begin{alltt} -Definition min : nat {\arrow} nat {\arrow} nat := - nat_double_rect (fun (x y:nat) {\funarrow} nat) - (fun (x:nat) {\funarrow} 0) - (fun (y:nat) {\funarrow} 0) - (fun (x y r:nat) {\funarrow} S r). -Eval compute in (min 5 8). -\it -= 5 : nat -\end{alltt} - - -%\begin{exercise} -% -%Define the combinator \texttt{nat\_double\_rec}, and apply it -%to give another definition of \citecoq{le\_lt\_dec} (using the theorems -%of the \texttt{Arith} library). -%\end{exercise} - -\subsection{Using Elimination Combinators.} -The tactic \texttt{apply} can be used to apply one of these proof -principles during the development of a proof. - -\begin{alltt} -Lemma not_circular : {\prodsym} n:nat, n {\coqdiff} S n. -Proof. - intro n. - apply nat_ind with (P:= fun n {\funarrow} n {\coqdiff} S n). -\it - - - -2 subgoals - - n : nat - ============================ - 0 {\coqdiff} 1 - - -subgoal 2 is: - {\prodsym} n0 : nat, n0 {\coqdiff} S n0 {\arrow} S n0 {\coqdiff} S (S n0) - -\tt - discriminate. - red; intros n0 Hn0 eqn0Sn0;injection eqn0Sn0;trivial. -Qed. -\end{alltt} - -The tactic \texttt{elim} \refmancite{Section \ref{Elim}} is a -refinement of \texttt{apply}, specially designed for the application -of elimination combinators. If $t$ is an object of an inductive type -$I$, then ``~\citecoq{elim $t$}~'' tries to find an abstraction $P$ of the -current goal $G$ such that $(P\;t)\equiv G$. Then it solves the goal -applying ``~$I\texttt{\_ind}\;P$~'', where $I$\texttt{\_ind} is the -combinator associated to $I$. The different cases of the induction -then appear as subgoals that remain to be solved. -In the previous proof, the tactic call ``~\citecoq{apply nat\_ind with (P:= fun n {\funarrow} n {\coqdiff} S n)}~'' can simply be replaced with ``~\citecoq{elim n}~''. - -The option ``~\citecoq{\texttt{elim} $t$ \texttt{using} $C$}~'' - allows the use of a -derived combinator $C$ instead of the default one. Consider the -following theorem, stating that equality is decidable on natural -numbers: - -\label{iseqpage} -\begin{alltt} -Lemma eq_nat_dec : {\prodsym} n p:nat, \{n=p\}+\{n {\coqdiff} p\}. -Proof. - intros n p. -\end{alltt} - -Let us prove this theorem using the combinator \texttt{nat\_double\_rect} -of section~\ref{natdoublerect}. The example also illustrates how -\texttt{elim} may sometimes fail in finding a suitable abstraction $P$ -of the goal. Note that if ``~\texttt{elim n}~'' - is used directly on the -goal, the result is not the expected one. - -\vspace{12pt} - -%\pagebreak -\begin{alltt} - elim n using nat_double_rect. -\it -4 subgoals - - n : nat - p : nat - ============================ - {\prodsym} x : nat, \{x = p\} + \{x {\coqdiff} p\} - -subgoal 2 is: - nat {\arrow} \{0 = p\} + \{0 {\coqdiff} p\} - -subgoal 3 is: - nat {\arrow} {\prodsym} m : nat, \{m = p\} + \{m {\coqdiff} p\} {\arrow} \{S m = p\} + \{S m {\coqdiff} p\} - -subgoal 4 is: - nat -\end{alltt} - -The four sub-goals obtained do not correspond to the premises that -would be expected for the principle \texttt{nat\_double\_rec}. The -problem comes from the fact that -this principle for eliminating $n$ -has a universally quantified formula as conclusion, which confuses -\texttt{elim} about the right way of abstracting the goal. - -%In effect, let us consider the type of the goal before the call to -%\citecoq{elim}: ``~\citecoq{\{n = p\} + \{n {\coqdiff} p\}}~''. - -%Among all the abstractions that can be built by ``~\citecoq{elim n}~'' -%let us consider this one -%$P=$\citecoq{fun n :nat {\funarrow} fun q : nat {\funarrow} {\{q= p\} + \{q {\coqdiff} p\}}}. -%It is easy to verify that -%$P$ has type \citecoq{nat {\arrow} nat {\arrow} Set}, and that, if some -%$q:\citecoq{nat}$ is given, then $P\;q\;$ matches the current goal. -%Then applying \citecoq{nat\_double\_rec} with $P$ generates -%four goals, corresponding to - - - - -Therefore, -in this case the abstraction must be explicited using the -\texttt{pattern} tactic. Once the right abstraction is provided, the rest of -the proof is immediate: - -\begin{alltt} -Undo. - pattern p,n. -\it - n : nat - p : nat - ============================ - (fun n0 n1 : nat {\funarrow} \{n1 = n0\} + \{n1 {\coqdiff} n0\}) p n -\tt - elim n using nat_double_rec. -\it -3 subgoals - - n : nat - p : nat - ============================ - {\prodsym} x : nat, \{x = 0\} + \{x {\coqdiff} 0\} - -subgoal 2 is: - {\prodsym} x : nat, \{0 = S x\} + \{0 {\coqdiff} S x\} -subgoal 3 is: - {\prodsym} n0 m : nat, \{m = n0\} + \{m {\coqdiff} n0\} {\arrow} \{S m = S n0\} + \{S m {\coqdiff} S n0\} - -\tt - destruct x; auto. - destruct x; auto. - intros n0 m H; case H. - intro eq; rewrite eq ; auto. - intro neg; right; red ; injection 1; auto. -Defined. -\end{alltt} - - -Notice that the tactic ``~\texttt{decide equality}~'' -\refmancite{Section\ref{DecideEquality}} generalises the proof -above to a large class of inductive types. It can be used for proving -a proposition of the form -$\forall\,(x,y:R),\{x=y\}+\{x{\coqdiff}y\}$, where $R$ is an inductive datatype -all whose constructors take informative arguments ---like for example -the type {\nat}: - -\begin{alltt} -Definition eq_nat_dec' : {\prodsym} n p:nat, \{n=p\} + \{n{\coqdiff}p\}. - decide equality. -Defined. -\end{alltt} - -\begin{exercise} -\begin{enumerate} -\item Define a recursive function of name \emph{nat2itree} -that maps any natural number $n$ into an infinitely branching -tree of height $n$. -\item Provide an elimination combinator for these trees. -\item Prove that the relation \citecoq{itree\_le} is a preorder -(i.e. reflexive and transitive). -\end{enumerate} -\end{exercise} - -\begin{exercise} \label{zeroton} -Define the type of lists, and a predicate ``being an ordered list'' -using an inductive family. Then, define the function -$(from\;n)=0::1\;\ldots\; n::\texttt{nil}$ and prove that it always generates an -ordered list. -\end{exercise} - -\begin{exercise} -Prove that \citecoq{le' n p} and \citecoq{n $\leq$ p} are logically equivalent -for all n and p. (\citecoq{le'} is defined in section \ref{parameterstuff}). -\end{exercise} - - -\subsection{Well-founded Recursion} -\label{WellFoundedRecursion} - -Structural induction is a strong elimination rule for inductive types. -This method can be used to define any function whose termination is -a consequence of the well-foundedness of a certain order relation $R$ decreasing -at each recursive call. What makes this principle so strong is the -possibility of reasoning by structural induction on the proof that -certain $R$ is well-founded. In order to illustrate this we have -first to introduce the predicate of accessibility. - -\begin{alltt} -Print Acc. -\it -Inductive Acc (A : Type) (R : A {\arrow} A {\arrow} Prop) (x:A) : Prop := - Acc_intro : ({\prodsym} y : A, R y x {\arrow} Acc R y) {\arrow} Acc R x -For Acc: Argument A is implicit -For Acc_intro: Arguments A, R are implicit - -\dots -\end{alltt} - -\noindent This inductive predicate characterizes those elements $x$ of -$A$ such that any descending $R$-chain $\ldots x_2\;R\;x_1\;R\;x$ -starting from $x$ is finite. A well-founded relation is a relation -such that all the elements of $A$ are accessible. -\emph{Notice the use of parameter $x$ (see Section~\ref{parameterstuff}, page -\pageref{parameterstuff}).} - -Consider now the problem of representing in {\coq} the following ML -function $\textsl{div}(x,y)$ on natural numbers, which computes -$\lceil\frac{x}{y}\rceil$ if $y>0$ and yields $x$ otherwise. - -\begin{verbatim} -let rec div x y = - if x = 0 then 0 - else if y = 0 then x - else (div (x-y) y)+1;; -\end{verbatim} - - -The equality test on natural numbers can be implemented using the -function \textsl{eq\_nat\_dec} that is defined page \pageref{iseqpage}. Giving $x$ and -$y$, this function yields either the value $(\textsl{left}\;p)$ if -there exists a proof $p:x=y$, or the value $(\textsl{right}\;q)$ if -there exists $q:a\not = b$. The subtraction function is already -defined in the library \citecoq{Minus}. - -Hence, direct translation of the ML function \textsl{div} would be: - -\begin{alltt} -Require Import Minus. - -Fixpoint div (x y:nat)\{struct x\}: nat := - if eq_nat_dec x 0 - then 0 - else if eq_nat_dec y 0 - then x - else S (div (x-y) y). - -\it Error: -Recursive definition of div is ill-formed. -In environment -div : nat {\arrow} nat {\arrow} nat -x : nat -y : nat -_ : x {\coqdiff} 0 -_ : y {\coqdiff} 0 - -Recursive call to div has principal argument equal to -"x - y" -instead of a subterm of x -\end{alltt} - - -The program \texttt{div} is rejected by {\coq} because it does not verify -the syntactical condition to ensure termination. In particular, the -argument of the recursive call is not a pattern variable issued from a -case analysis on $x$. -We would have the same problem if we had the directive -``~\citecoq{\{struct y\}}~'' instead of ``~\citecoq{\{struct x\}}~''. -However, we know that this program always -stops. One way to justify its termination is to define it by -structural induction on a proof that $x$ is accessible trough the -relation $<$. Notice that any natural number $x$ is accessible -for this relation. In order to do this, it is first necessary to prove -some auxiliary lemmas, justifying that the first argument of -\texttt{div} decreases at each recursive call. - -\begin{alltt} -Lemma minus_smaller_S : {\prodsym} x y:nat, x - y < S x. -Proof. - intros x y; pattern y, x; - elim x using nat_double_ind. - destruct x0; auto with arith. - simpl; auto with arith. - simpl; auto with arith. -Qed. - - -Lemma minus_smaller_positive : - {\prodsym} x y:nat, x {\coqdiff}0 {\arrow} y {\coqdiff} 0 {\arrow} x - y < x. -Proof. - destruct x; destruct y; - ( simpl;intros; apply minus_smaller || - intros; absurd (0=0); auto). -Qed. -\end{alltt} - -\noindent The last two lemmas are necessary to prove that for any pair -of positive natural numbers $x$ and $y$, if $x$ is accessible with -respect to \citecoq{lt}, then so is $x-y$. - -\begin{alltt} -Definition minus_decrease : {\prodsym} x y:nat, Acc lt x {\arrow} - x {\coqdiff} 0 {\arrow} - y {\coqdiff} 0 {\arrow} - Acc lt (x-y). -Proof. - intros x y H; case H. - intros Hz posz posy. - apply Hz; apply minus_smaller_positive; assumption. -Defined. -\end{alltt} - -Let us take a look at the proof of the lemma \textsl{minus\_decrease}, since -the way in which it has been proven is crucial for what follows. -\begin{alltt} -Print minus_decrease. -\it -minus_decrease = -fun (x y : nat) (H : Acc lt x) {\funarrow} -match H in (Acc _ y0) return (y0 {\coqdiff} 0 {\arrow} y {\coqdiff} 0 {\arrow} Acc lt (y0 - y)) with -| Acc_intro z Hz {\funarrow} - fun (posz : z {\coqdiff} 0) (posy : y {\coqdiff} 0) {\funarrow} - Hz (z - y) (minus_smaller_positive z y posz posy) -end - : {\prodsym} x y : nat, Acc lt x {\arrow} x {\coqdiff} 0 {\arrow} y {\coqdiff} 0 {\arrow} Acc lt (x - y) - -\end{alltt} -\noindent Notice that the function call -$(\texttt{minus\_decrease}\;n\;m\;H)$ -indeed yields an accessibility proof that is \textsl{structurally -smaller} than its argument $H$, because it is (an application of) its -recursive component $Hz$. This enables to justify the following -definition of \textsl{div\_aux}: - -\begin{alltt} -Definition div_aux (x y:nat)(H: Acc lt x):nat. - fix 3. - intros. - refine (if eq_nat_dec x 0 - then 0 - else if eq_nat_dec y 0 - then y - else div_aux (x-y) y _). -\it - div_aux : {\prodsym} x : nat, nat {\arrow} Acc lt x {\arrow} nat - x : nat - y : nat - H : Acc lt x - _ : x {\coqdiff} 0 - _0 : y {\coqdiff} 0 - ============================ - Acc lt (x - y) - -\tt - apply (minus_decrease x y H);auto. -Defined. -\end{alltt} - -The main division function is easily defined, using the theorem -\citecoq{lt\_wf} of the library \citecoq{Wf\_nat}. This theorem asserts that -\citecoq{nat} is well founded w.r.t. \citecoq{lt}, thus any natural number -is accessible. -\begin{alltt} -Definition div x y := div_aux x y (lt_wf x). -\end{alltt} - -Let us explain the proof above. In the definition of \citecoq{div\_aux}, -what decreases is not $x$ but the \textsl{proof} of the accessibility -of $x$. The tactic ``~\texttt{fix 3}~'' is used to indicate that the proof -proceeds by structural induction on the third argument of the theorem ---that is, on the accessibility proof. It also introduces a new -hypothesis in the context, named as the current theorem, and with the -same type as the goal. Then, the proof is refined with an incomplete -proof term, containing a hole \texttt{\_}. This hole corresponds to the proof -of accessibility for $x-y$, and is filled up with the (smaller!) -accessibility proof provided by the function \texttt{minus\_decrease}. - - -\noindent Let us take a look to the term \textsl{div\_aux} defined: - -\pagebreak -\begin{alltt} -Print div_aux. -\it -div_aux = -(fix div_aux (x y : nat) (H : Acc lt x) \{struct H\} : nat := - match eq_nat_dec x 0 with - | left _ {\funarrow} 0 - | right _ {\funarrow} - match eq_nat_dec y 0 with - | left _ {\funarrow} y - | right _0 {\funarrow} div_aux (x - y) y (minus_decrease x y H _ _0) - end - end) - : {\prodsym} x : nat, nat {\arrow} Acc lt x {\arrow} nat - -\end{alltt} - -If the non-informative parts from this proof --that is, the -accessibility proof-- are erased, then we obtain exactly the program -that we were looking for. -\begin{alltt} - -Extraction div. - -\it -let div x y = - div_aux x y -\tt - -Extraction div_aux. - -\it -let rec div_aux x y = - match eq_nat_dec x O with - | Left {\arrow} O - | Right {\arrow} - (match eq_nat_dec y O with - | Left {\arrow} y - | Right {\arrow} div_aux (minus x y) y) -\end{alltt} - -This methodology enables the representation -of any program whose termination can be proved in {\coq}. Once the -expected properties from this program have been verified, the -justification of its termination can be thrown away, keeping just the -desired computational behavior for it. - -\section{A case study in dependent elimination}\label{CaseStudy} - -Dependent types are very expressive, but ignoring some useful -techniques can cause some problems to the beginner. -Let us consider again the type of vectors (see section~\ref{vectors}). -We want to prove a quite trivial property: the only value of type -``~\citecoq{vector A 0}~'' is ``~\citecoq{Vnil $A$}~''. - -Our first naive attempt leads to a \emph{cul-de-sac}. -\begin{alltt} -Lemma vector0_is_vnil : - {\prodsym} (A:Type)(v:vector A 0), v = Vnil A. -Proof. - intros A v;inversion v. -\it -1 subgoal - - A : Set - v : vector A 0 - ============================ - v = Vnil A -\tt -Abort. -\end{alltt} - -Another attempt is to do a case analysis on a vector of any length -$n$, under an explicit hypothesis $n=0$. The tactic -\texttt{discriminate} will help us to get rid of the case -$n=\texttt{S $p$}$. -Unfortunately, even the statement of our lemma is refused! - -\begin{alltt} - Lemma vector0_is_vnil_aux : - {\prodsym} (A:Type)(n:nat)(v:vector A n), n = 0 {\arrow} v = Vnil A. - -\it -Error: In environment -A : Type -n : nat -v : vector A n -e : n = 0 -The term "Vnil A" has type "vector A 0" while it is expected to have type - "vector A n" -\end{alltt} - -In effect, the equality ``~\citecoq{v = Vnil A}~'' is ill-typed and this is -because the type ``~\citecoq{vector A n}~'' is not \emph{convertible} -with ``~\citecoq{vector A 0}~''. - -This problem can be solved if we consider the heterogeneous -equality \citecoq{JMeq} \cite{conor:motive} -which allows us to consider terms of different types, even if this -equality can only be proven for terms in the same type. -The axiom \citecoq{JMeq\_eq}, from the library \citecoq{JMeq} allows us to convert a -heterogeneous equality to a standard one. - -\begin{alltt} -Lemma vector0_is_vnil_aux : - {\prodsym} (A:Type)(n:nat)(v:vector A n), - n= 0 {\arrow} JMeq v (Vnil A). -Proof. - destruct v. - auto. - intro; discriminate. -Qed. -\end{alltt} - -Our property of vectors of null length can be easily proven: - -\begin{alltt} -Lemma vector0_is_vnil : {\prodsym} (A:Type)(v:vector A 0), v = Vnil A. - intros a v;apply JMeq_eq. - apply vector0_is_vnil_aux. - trivial. -Qed. -\end{alltt} - -It is interesting to look at another proof of -\citecoq{vector0\_is\_vnil}, which illustrates a technique developed -and used by various people (consult in the \emph{Coq-club} mailing -list archive the contributions by Yves Bertot, Pierre Letouzey, Laurent Théry, -Jean Duprat, and Nicolas Magaud, Venanzio Capretta and Conor McBride). -This technique is also used for unfolding infinite list definitions -(see chapter13 of~\cite{coqart}). -Notice that this definition does not rely on any axiom (\emph{e.g.} \texttt{JMeq\_eq}). - -We first give a new definition of the identity on vectors. Before that, -we make the use of constructors and selectors lighter thanks to -the implicit arguments feature: - -\begin{alltt} -Implicit Arguments Vcons [A n]. -Implicit Arguments Vnil [A]. -Implicit Arguments Vhead [A n]. -Implicit Arguments Vtail [A n]. - -Definition Vid : {\prodsym} (A : Type)(n:nat), vector A n {\arrow} vector A n. -Proof. - destruct n; intro v. - exact Vnil. - exact (Vcons (Vhead v) (Vtail v)). -Defined. -\end{alltt} - - -Then we prove that \citecoq{Vid} is the identity on vectors: - -\begin{alltt} -Lemma Vid_eq : {\prodsym} (n:nat) (A:Type)(v:vector A n), v=(Vid _ n v). -Proof. - destruct v. - -\it - A : Type - ============================ - Vnil = Vid A 0 Vnil - -subgoal 2 is: - Vcons a v = Vid A (S n) (Vcons a v) -\tt - reflexivity. - reflexivity. -Defined. -\end{alltt} - -Why defining a new identity function on vectors? The following -dialogue shows that \citecoq{Vid} has some interesting computational -properties: - -\begin{alltt} -Eval simpl in (fun (A:Type)(v:vector A 0) {\funarrow} (Vid _ _ v)). -\it = fun (A : Type) (_ : vector A 0) {\funarrow} Vnil - : {\prodsym} A : Type, vector A 0 {\arrow} vector A 0 - -\end{alltt} - -Notice that the plain identity on vectors doesn't convert \citecoq{v} -into \citecoq{Vnil}. -\begin{alltt} -Eval simpl in (fun (A:Type)(v:vector A 0) {\funarrow} v). -\it = fun (A : Type) (v : vector A 0) {\funarrow} v - : {\prodsym} A : Type, vector A 0 {\arrow} vector A 0 -\end{alltt} - -Then we prove easily that any vector of length 0 is \citecoq{Vnil}: - -\begin{alltt} -Theorem zero_nil : {\prodsym} A (v:vector A 0), v = Vnil. -Proof. - intros. - change (Vnil (A:=A)) with (Vid _ 0 v). -\it -1 subgoal - - A : Type - v : vector A 0 - ============================ - v = Vid A 0 v -\tt - apply Vid_eq. -Defined. -\end{alltt} - -A similar result can be proven about vectors of strictly positive -length\footnote{As for \citecoq{Vid} and \citecoq{Vid\_eq}, this definition -is from Jean Duprat.}. - -\begin{alltt} - - -Theorem decomp : - {\prodsym} (A : Type) (n : nat) (v : vector A (S n)), - v = Vcons (Vhead v) (Vtail v). -Proof. - intros. - change (Vcons (Vhead v) (Vtail v)) with (Vid _ (S n) v). -\it - 1 subgoal - - A : Type - n : nat - v : vector A (S n) - ============================ - v = Vid A (S n) v - -\tt{} apply Vid_eq. -Defined. -\end{alltt} - - -Both lemmas: \citecoq{zero\_nil} and \citecoq{decomp}, -can be used to easily derive a double recursion principle -on vectors of same length: - - -\begin{alltt} -Definition vector_double_rect : - {\prodsym} (A:Type) (P: {\prodsym} (n:nat),(vector A n){\arrow}(vector A n) {\arrow} Type), - P 0 Vnil Vnil {\arrow} - ({\prodsym} n (v1 v2 : vector A n) a b, P n v1 v2 {\arrow} - P (S n) (Vcons a v1) (Vcons b v2)) {\arrow} - {\prodsym} n (v1 v2 : vector A n), P n v1 v2. - induction n. - intros; rewrite (zero_nil _ v1); rewrite (zero_nil _ v2). - auto. - intros v1 v2; rewrite (decomp _ _ v1);rewrite (decomp _ _ v2). - apply X0; auto. -Defined. -\end{alltt} - -Notice that, due to the conversion rule of {\coq}'s type system, -this function can be used directly with \citecoq{Prop} or \citecoq{Type} -instead of type (thus it is useless to build -\citecoq{vector\_double\_ind} and \citecoq{vector\_double\_rec}) from scratch. - -We finish this example with showing how to define the bitwise -\emph{or} on boolean vectors of the same length, -and proving a little property about this -operation. - -\begin{alltt} -Definition bitwise_or n v1 v2 : vector bool n := - vector_double_rect - bool - (fun n v1 v2 {\funarrow} vector bool n) - Vnil - (fun n v1 v2 a b r {\funarrow} Vcons (orb a b) r) n v1 v2. -\end{alltt} - -Let us define recursively the $n$-th element of a vector. Notice -that it must be a partial function, in case $n$ is greater or equal -than the length of the vector. Since {\coq} only considers total -functions, the function returns a value in an \emph{option} type. - -\begin{alltt} -Fixpoint vector_nth (A:Type)(n:nat)(p:nat)(v:vector A p) - \{struct v\} - : option A := - match n,v with - _ , Vnil {\funarrow} None - | 0 , Vcons b _ _ {\funarrow} Some b - | S n', Vcons _ p' v' {\funarrow} vector_nth A n' p' v' - end. -Implicit Arguments vector_nth [A p]. -\end{alltt} - -We can now prove --- using the double induction combinator --- -a simple property relying \citecoq{vector\_nth} and \citecoq{bitwise\_or}: - -\begin{alltt} -Lemma nth_bitwise : - {\prodsym} (n:nat) (v1 v2: vector bool n) i a b, - vector_nth i v1 = Some a {\arrow} - vector_nth i v2 = Some b {\arrow} - vector_nth i (bitwise_or _ v1 v2) = Some (orb a b). -Proof. - intros n v1 v2; pattern n,v1,v2. - apply vector_double_rect. - simpl. - destruct i; discriminate 1. - destruct i; simpl;auto. - injection 1; injection 2;intros; subst a; subst b; auto. -Qed. -\end{alltt} - - -\section{Co-inductive Types and Non-ending Constructions} -\label{CoInduction} - -The objects of an inductive type are well-founded with respect to -the constructors of the type. In other words, these objects are built -by applying \emph{a finite number of times} the constructors of the type. -Co-inductive types are obtained by relaxing this condition, -and may contain non-well-founded objects \cite{EG96,EG95a}. An -example of a co-inductive type is the type of infinite -sequences formed with elements of type $A$, also called streams. This -type can be introduced through the following definition: - -\begin{alltt} - CoInductive Stream (A: Type) :Type := - | Cons : A\arrow{}Stream A\arrow{}Stream A. -\end{alltt} - -If we are interested in finite or infinite sequences, we consider the type -of \emph{lazy lists}: - -\begin{alltt} -CoInductive LList (A: Type) : Type := - | LNil : LList A - | LCons : A {\arrow} LList A {\arrow} LList A. -\end{alltt} - - -It is also possible to define co-inductive types for the -trees with infinitely-many branches (see Chapter 13 of~\cite{coqart}). - -Structural induction is the way of expressing that inductive types -only contain well-founded objects. Hence, this elimination principle -is not valid for co-inductive types, and the only elimination rule for -streams is case analysis. This principle can be used, for example, to -define the destructors \textsl{head} and \textsl{tail}. - -\begin{alltt} - Definition head (A:Type)(s : Stream A) := - match s with Cons a s' {\funarrow} a end. - - Definition tail (A : Type)(s : Stream A) := - match s with Cons a s' {\funarrow} s' end. -\end{alltt} - -Infinite objects are defined by means of (non-ending) methods of -construction, like in lazy functional programming languages. Such -methods can be defined using the \texttt{CoFixpoint} command -\refmancite{Section \ref{CoFixpoint}}. For example, the following -definition introduces the infinite list $[a,a,a,\ldots]$: - -\begin{alltt} - CoFixpoint repeat (A:Type)(a:A) : Stream A := - Cons a (repeat a). -\end{alltt} - - -However, not every co-recursive definition is an admissible method of -construction. Similarly to the case of structural induction, the -definition must verify a \textsl{guardedness} condition to be -accepted. This condition states that any recursive call in the -definition must be protected --i.e, be an argument of-- some -constructor, and only an argument of constructors \cite{EG94a}. The -following definitions are examples of valid methods of construction: - -\begin{alltt} -CoFixpoint iterate (A: Type)(f: A {\arrow} A)(a : A) : Stream A:= - Cons a (iterate f (f a)). - -CoFixpoint map - (A B:Type)(f: A {\arrow} B)(s : Stream A) : Stream B:= - match s with Cons a tl {\funarrow} Cons (f a) (map f tl) end. -\end{alltt} - -\begin{exercise} -Define two different methods for constructing the stream which -infinitely alternates the values \citecoq{true} and \citecoq{false}. -\end{exercise} -\begin{exercise} -Using the destructors \texttt{head} and \texttt{tail}, define a function -which takes the n-th element of an infinite stream. -\end{exercise} - -A non-ending method of construction is computed lazily. This means -that its definition is unfolded only when the object that it -introduces is eliminated, that is, when it appears as the argument of -a case expression. We can check this using the command -\texttt{Eval}. - -\begin{alltt} -Eval simpl in (fun (A:Type)(a:A) {\funarrow} repeat a). -\it = fun (A : Type) (a : A) {\funarrow} repeat a - : {\prodsym} A : Type, A {\arrow} Stream A -\tt -Eval simpl in (fun (A:Type)(a:A) {\funarrow} head (repeat a)). -\it = fun (A : Type) (a : A) {\funarrow} a - : {\prodsym} A : Type, A {\arrow} A -\end{alltt} - -%\begin{exercise} -%Prove the following theorem: -%\begin{verbatim} -%Theorem expand_repeat : (a:A)(repeat a)=(Cons a (repeat a)). -%\end{verbatim} -%Hint: Prove first the streams version of the lemma in exercise -%\ref{expand}. -%\end{exercise} - -\subsection{Extensional Properties} - -Case analysis is also a valid proof principle for infinite -objects. However, this principle is not sufficient to prove -\textsl{extensional} properties, that is, properties concerning the -whole infinite object \cite{EG95a}. A typical example of an -extensional property is the predicate expressing that two streams have -the same elements. In many cases, the minimal reflexive relation $a=b$ -that is used as equality for inductive types is too small to capture -equality between streams. Consider for example the streams -$\texttt{iterate}\;f\;(f\;x)$ and -$(\texttt{map}\;f\;(\texttt{iterate}\;f\;x))$. Even though these two streams have -the same elements, no finite expansion of their definitions lead to -equal terms. In other words, in order to deal with extensional -properties, it is necessary to construct infinite proofs. The type of -infinite proofs of equality can be introduced as a co-inductive -predicate, as follows: -\begin{alltt} -CoInductive EqSt (A: Type) : Stream A {\arrow} Stream A {\arrow} Prop := - eqst : {\prodsym} s1 s2: Stream A, - head s1 = head s2 {\arrow} - EqSt (tail s1) (tail s2) {\arrow} - EqSt s1 s2. -\end{alltt} - -It is possible to introduce proof principles for reasoning about -infinite objects as combinators defined through -\texttt{CoFixpoint}. However, oppositely to the case of inductive -types, proof principles associated to co-inductive types are not -elimination but \textsl{introduction} combinators. An example of such -a combinator is Park's principle for proving the equality of two -streams, usually called the \textsl{principle of co-induction}. It -states that two streams are equal if they satisfy a -\textit{bisimulation}. A bisimulation is a binary relation $R$ such -that any pair of streams $s_1$ ad $s_2$ satisfying $R$ have equal -heads, and tails also satisfying $R$. This principle is in fact a -method for constructing an infinite proof: - -\begin{alltt} -Section Parks_Principle. -Variable A : Type. -Variable R : Stream A {\arrow} Stream A {\arrow} Prop. -Hypothesis bisim1 : {\prodsym} s1 s2:Stream A, - R s1 s2 {\arrow} head s1 = head s2. - -Hypothesis bisim2 : {\prodsym} s1 s2:Stream A, - R s1 s2 {\arrow} R (tail s1) (tail s2). - -CoFixpoint park_ppl : - {\prodsym} s1 s2:Stream A, R s1 s2 {\arrow} EqSt s1 s2 := - fun s1 s2 (p : R s1 s2) {\funarrow} - eqst s1 s2 (bisim1 s1 s2 p) - (park_ppl (tail s1) - (tail s2) - (bisim2 s1 s2 p)). -End Parks_Principle. -\end{alltt} - -Let us use the principle of co-induction to prove the extensional -equality mentioned above. -\begin{alltt} -Theorem map_iterate : {\prodsym} (A:Type)(f:A{\arrow}A)(x:A), - EqSt (iterate f (f x)) - (map f (iterate f x)). -Proof. - intros A f x. - apply park_ppl with - (R:= fun s1 s2 {\funarrow} - {\exsym} x: A, s1 = iterate f (f x) {\coqand} - s2 = map f (iterate f x)). - - intros s1 s2 (x0,(eqs1,eqs2)); - rewrite eqs1; rewrite eqs2; reflexivity. - intros s1 s2 (x0,(eqs1,eqs2)). - exists (f x0);split; - [rewrite eqs1|rewrite eqs2]; reflexivity. - exists x;split; reflexivity. -Qed. -\end{alltt} - -The use of Park's principle is sometimes annoying, because it requires -to find an invariant relation and prove that it is indeed a -bisimulation. In many cases, a shorter proof can be obtained trying -to construct an ad-hoc infinite proof, defined by a guarded -declaration. The tactic ``~``\texttt{Cofix $f$}~'' can be used to do -that. Similarly to the tactic \texttt{fix} indicated in Section -\ref{WellFoundedRecursion}, this tactic introduces an extra hypothesis -$f$ into the context, whose type is the same as the current goal. Note -that the applications of $f$ in the proof \textsl{must be guarded}. In -order to prevent us from doing unguarded calls, we can define a tactic -that always apply a constructor before using $f$ \refmancite{Chapter -\ref{WritingTactics}} : - -\begin{alltt} -Ltac infiniteproof f := - cofix f; - constructor; - [clear f| simpl; try (apply f; clear f)]. -\end{alltt} - - -In the example above, this tactic produces a much simpler proof -that the former one: - -\begin{alltt} -Theorem map_iterate' : {\prodsym} ((A:Type)f:A{\arrow}A)(x:A), - EqSt (iterate f (f x)) - (map f (iterate f x)). -Proof. - infiniteproof map_iterate'. - reflexivity. -Qed. -\end{alltt} - -\begin{exercise} -Define a co-inductive type of name $Nat$ that contains non-standard -natural numbers --this is, verifying - -$$\exists m \in \mbox{\texttt{Nat}}, \forall\, n \in \mbox{\texttt{Nat}}, n<m$$. -\end{exercise} - -\begin{exercise} -Prove that the extensional equality of streams is an equivalence relation -using Park's co-induction principle. -\end{exercise} - - -\begin{exercise} -Provide a suitable definition of ``being an ordered list'' for infinite lists -and define a principle for proving that an infinite list is ordered. Apply -this method to the list $[0,1,\ldots ]$. Compare the result with -exercise \ref{zeroton}. -\end{exercise} - -\subsection{About injection, discriminate, and inversion} -Since co-inductive types are closed w.r.t. their constructors, -the techniques shown in Section~\ref{CaseTechniques} work also -with these types. - -Let us consider the type of lazy lists, introduced on page~\pageref{CoInduction}. -The following lemmas are straightforward applications - of \texttt{discriminate} and \citecoq{injection}: - -\begin{alltt} -Lemma Lnil_not_Lcons : {\prodsym} (A:Type)(a:A)(l:LList A), - LNil {\coqdiff} (LCons a l). -Proof. - intros;discriminate. -Qed. - -Lemma injection_demo : {\prodsym} (A:Type)(a b : A)(l l': LList A), - LCons a (LCons b l) = LCons b (LCons a l') {\arrow} - a = b {\coqand} l = l'. -Proof. - intros A a b l l' e; injection e; auto. -Qed. - -\end{alltt} - -In order to show \citecoq{inversion} at work, let us define -two predicates on lazy lists: - -\begin{alltt} -Inductive Finite (A:Type) : LList A {\arrow} Prop := -| Lnil_fin : Finite (LNil (A:=A)) -| Lcons_fin : {\prodsym} a l, Finite l {\arrow} Finite (LCons a l). - -CoInductive Infinite (A:Type) : LList A {\arrow} Prop := -| LCons_inf : {\prodsym} a l, Infinite l {\arrow} Infinite (LCons a l). -\end{alltt} - -\noindent -First, two easy theorems: -\begin{alltt} -Lemma LNil_not_Infinite : {\prodsym} (A:Type), ~ Infinite (LNil (A:=A)). -Proof. - intros A H;inversion H. -Qed. - -Lemma Finite_not_Infinite : {\prodsym} (A:Type)(l:LList A), - Finite l {\arrow} ~ Infinite l. -Proof. - intros A l H; elim H. - apply LNil_not_Infinite. - intros a l0 F0 I0' I1. - case I0'; inversion_clear I1. - trivial. -Qed. -\end{alltt} - - -On the other hand, the next proof uses the \citecoq{cofix} tactic. -Notice the destructuration of \citecoq{l}, which allows us to -apply the constructor \texttt{LCons\_inf}, thus satisfying - the guard condition: -\begin{alltt} -Lemma Not_Finite_Infinite : {\prodsym} (A:Type)(l:LList A), - ~ Finite l {\arrow} Infinite l. -Proof. - cofix H. - destruct l. - intro; - absurd (Finite (LNil (A:=A))); - [auto|constructor]. -\it - - - - -1 subgoal - - H : forall (A : Type) (l : LList A), ~ Finite l -> Infinite l - A : Type - a : A - l : LList A - H0 : ~ Finite (LCons a l) - ============================ - Infinite l -\end{alltt} -At this point, one must not apply \citecoq{H}! . It would be possible -to solve the current goal by an inversion of ``~\citecoq{Finite (LCons a l)}~'', but, since the guard condition would be violated, the user -would get an error message after typing \citecoq{Qed}. -In order to satisfy the guard condition, we apply the constructor of -\citecoq{Infinite}, \emph{then} apply \citecoq{H}. - -\begin{alltt} - constructor. - apply H. - red; intro H1;case H0. - constructor. - trivial. -Qed. -\end{alltt} - - - - -The reader is invited to replay this proof and understand each of its steps. - - -\bibliographystyle{abbrv} -\bibliography{manbiblio,morebib} - -\end{document} - diff --git a/doc/RecTutorial/RecTutorial.v b/doc/RecTutorial/RecTutorial.v deleted file mode 100644 index 4b0ab3125..000000000 --- a/doc/RecTutorial/RecTutorial.v +++ /dev/null @@ -1,1231 +0,0 @@ -Unset Automatic Introduction. - -Check (forall A:Type, (exists x:A, forall (y:A), x <> y) -> 2 = 3). - - - -Inductive nat : Set := - | O : nat - | S : nat->nat. -Check nat. -Check O. -Check S. - -Reset nat. -Print nat. - - -Print le. - -Theorem zero_leq_three: 0 <= 3. - -Proof. - constructor 2. - constructor 2. - constructor 2. - constructor 1. - -Qed. - -Print zero_leq_three. - - -Lemma zero_leq_three': 0 <= 3. - repeat constructor. -Qed. - - -Lemma zero_lt_three : 0 < 3. -Proof. - repeat constructor. -Qed. - -Print zero_lt_three. - -Inductive le'(n:nat):nat -> Prop := - | le'_n : le' n n - | le'_S : forall p, le' (S n) p -> le' n p. - -Hint Constructors le'. - - -Require Import List. - -Print list. - -Check list. - -Check (nil (A:=nat)). - -Check (nil (A:= nat -> nat)). - -Check (fun A: Type => (cons (A:=A))). - -Check (cons 3 (cons 2 nil)). - -Check (nat :: bool ::nil). - -Check ((3<=4) :: True ::nil). - -Check (Prop::Set::nil). - -Require Import Bvector. - -Print Vector.t. - -Check (Vector.nil nat). - -Check (fun (A:Type)(a:A)=> Vector.cons _ a _ (Vector.nil _)). - -Check (Vector.cons _ 5 _ (Vector.cons _ 3 _ (Vector.nil _))). - -Lemma eq_3_3 : 2 + 1 = 3. -Proof. - reflexivity. -Qed. -Print eq_3_3. - -Lemma eq_proof_proof : eq_refl (2*6) = eq_refl (3*4). -Proof. - reflexivity. -Qed. -Print eq_proof_proof. - -Lemma eq_lt_le : ( 2 < 4) = (3 <= 4). -Proof. - reflexivity. -Qed. - -Lemma eq_nat_nat : nat = nat. -Proof. - reflexivity. -Qed. - -Lemma eq_Set_Set : Set = Set. -Proof. - reflexivity. -Qed. - -Lemma eq_Type_Type : Type = Type. -Proof. - reflexivity. -Qed. - - -Check (2 + 1 = 3). - - -Check (Type = Type). - -Goal Type = Type. -reflexivity. -Qed. - - -Print or. - -Print and. - - -Print sumbool. - -Print ex. - -Require Import ZArith. -Require Import Compare_dec. - -Check le_lt_dec. - -Definition max (n p :nat) := match le_lt_dec n p with - | left _ => p - | right _ => n - end. - -Theorem le_max : forall n p, n <= p -> max n p = p. -Proof. - intros n p ; unfold max ; case (le_lt_dec n p); simpl. - trivial. - intros; absurd (p < p); eauto with arith. -Qed. - -Require Extraction. -Extraction max. - - - - - - -Inductive tree(A:Type) : Type := - node : A -> forest A -> tree A -with - forest (A: Type) : Type := - nochild : forest A | - addchild : tree A -> forest A -> forest A. - - - - - -Inductive - even : nat->Prop := - evenO : even O | - evenS : forall n, odd n -> even (S n) -with - odd : nat->Prop := - oddS : forall n, even n -> odd (S n). - -Lemma odd_49 : odd (7 * 7). - simpl; repeat constructor. -Qed. - - - -Definition nat_case := - fun (Q : Type)(g0 : Q)(g1 : nat -> Q)(n:nat) => - match n return Q with - | 0 => g0 - | S p => g1 p - end. - -Eval simpl in (nat_case nat 0 (fun p => p) 34). - -Eval simpl in (fun g0 g1 => nat_case nat g0 g1 34). - -Eval simpl in (fun g0 g1 => nat_case nat g0 g1 0). - - -Definition pred (n:nat) := match n with O => O | S m => m end. - -Eval simpl in pred 56. - -Eval simpl in pred 0. - -Eval simpl in fun p => pred (S p). - - -Definition xorb (b1 b2:bool) := -match b1, b2 with - | false, true => true - | true, false => true - | _ , _ => false -end. - - - Definition pred_spec (n:nat) := {m:nat | n=0 /\ m=0 \/ n = S m}. - - - Definition predecessor : forall n:nat, pred_spec n. - intro n;case n. - unfold pred_spec;exists 0;auto. - unfold pred_spec; intro n0;exists n0; auto. - Defined. - -Print predecessor. - -Extraction predecessor. - -Theorem nat_expand : - forall n:nat, n = match n with 0 => 0 | S p => S p end. - intro n;case n;simpl;auto. -Qed. - -Check (fun p:False => match p return 2=3 with end). - -Theorem fromFalse : False -> 0=1. - intro absurd. - contradiction. -Qed. - -Section equality_elimination. - Variables (A: Type) - (a b : A) - (p : a = b) - (Q : A -> Type). - Check (fun H : Q a => - match p in (eq _ y) return Q y with - eq_refl => H - end). - -End equality_elimination. - - -Theorem trans : forall n m p:nat, n=m -> m=p -> n=p. -Proof. - intros n m p eqnm. - case eqnm. - trivial. -Qed. - -Lemma Rw : forall x y: nat, y = y * x -> y * x * x = y. - intros x y e; do 2 rewrite <- e. - reflexivity. -Qed. - - -Require Import Arith. - -Check mult_1_l. -(* -mult_1_l - : forall n : nat, 1 * n = n -*) - -Check mult_plus_distr_r. -(* -mult_plus_distr_r - : forall n m p : nat, (n + m) * p = n * p + m * p - -*) - -Lemma mult_distr_S : forall n p : nat, n * p + p = (S n)* p. - simpl;auto with arith. -Qed. - -Lemma four_n : forall n:nat, n+n+n+n = 4*n. - intro n;rewrite <- (mult_1_l n). - - Undo. - intro n; pattern n at 1. - - - rewrite <- mult_1_l. - repeat rewrite mult_distr_S. - trivial. -Qed. - - -Section Le_case_analysis. - Variables (n p : nat) - (H : n <= p) - (Q : nat -> Prop) - (H0 : Q n) - (HS : forall m, n <= m -> Q (S m)). - Check ( - match H in (_ <= q) return (Q q) with - | le_n _ => H0 - | le_S _ m Hm => HS m Hm - end - ). - - -End Le_case_analysis. - - -Lemma predecessor_of_positive : forall n, 1 <= n -> exists p:nat, n = S p. -Proof. - intros n H; case H. - exists 0; trivial. - intros m Hm; exists m;trivial. -Qed. - -Definition Vtail_total - (A : Type) (n : nat) (v : Vector.t A n) : Vector.t A (pred n):= -match v in (Vector.t _ n0) return (Vector.t A (pred n0)) with -| Vector.nil _ => Vector.nil A -| Vector.cons _ _ n0 v0 => v0 -end. - -Definition Vtail' (A:Type)(n:nat)(v:Vector.t A n) : Vector.t A (pred n). - intros A n v; case v. - simpl. - exact (Vector.nil A). - simpl. - auto. -Defined. - -(* -Inductive Lambda : Set := - lambda : (Lambda -> False) -> Lambda. - - -Error: Non strictly positive occurrence of "Lambda" in - "(Lambda -> False) -> Lambda" - -*) - -Section Paradox. - Variable Lambda : Set. - Variable lambda : (Lambda -> False) ->Lambda. - - Variable matchL : Lambda -> forall Q:Prop, ((Lambda ->False) -> Q) -> Q. - (* - understand matchL Q l (fun h : Lambda -> False => t) - - as match l return Q with lambda h => t end - *) - - Definition application (f x: Lambda) :False := - matchL f False (fun h => h x). - - Definition Delta : Lambda := lambda (fun x : Lambda => application x x). - - Definition loop : False := application Delta Delta. - - Theorem two_is_three : 2 = 3. - Proof. - elim loop. - Qed. - -End Paradox. - - -Require Import ZArith. - - - -Inductive itree : Set := -| ileaf : itree -| inode : Z-> (nat -> itree) -> itree. - -Definition isingle l := inode l (fun i => ileaf). - -Definition t1 := inode 0 (fun n => isingle (Z.of_nat (2*n))). - -Definition t2 := inode 0 - (fun n : nat => - inode (Z.of_nat n) - (fun p => isingle (Z.of_nat (n*p)))). - - -Inductive itree_le : itree-> itree -> Prop := - | le_leaf : forall t, itree_le ileaf t - | le_node : forall l l' s s', - Z.le l l' -> - (forall i, exists j:nat, itree_le (s i) (s' j)) -> - itree_le (inode l s) (inode l' s'). - - -Theorem itree_le_trans : - forall t t', itree_le t t' -> - forall t'', itree_le t' t'' -> itree_le t t''. - induction t. - constructor 1. - - intros t'; case t'. - inversion 1. - intros z0 i0 H0. - intro t'';case t''. - inversion 1. - intros. - inversion_clear H1. - constructor 2. - inversion_clear H0;eauto with zarith. - inversion_clear H0. - intro i2; case (H4 i2). - intros. - generalize (H i2 _ H0). - intros. - case (H3 x);intros. - generalize (H5 _ H6). - exists x0;auto. -Qed. - - - -Inductive itree_le' : itree-> itree -> Prop := - | le_leaf' : forall t, itree_le' ileaf t - | le_node' : forall l l' s s' g, - Z.le l l' -> - (forall i, itree_le' (s i) (s' (g i))) -> - itree_le' (inode l s) (inode l' s'). - - - - - -Lemma t1_le_t2 : itree_le t1 t2. - unfold t1, t2. - constructor. - auto with zarith. - intro i; exists (2 * i). - unfold isingle. - constructor. - auto with zarith. - exists i;constructor. -Qed. - - - -Lemma t1_le'_t2 : itree_le' t1 t2. - unfold t1, t2. - constructor 2 with (fun i : nat => 2 * i). - auto with zarith. - unfold isingle; - intro i ; constructor 2 with (fun i :nat => i). - auto with zarith. - constructor . -Qed. - - -Require Import List. - -Inductive ltree (A:Set) : Set := - lnode : A -> list (ltree A) -> ltree A. - -Inductive prop : Prop := - prop_intro : Prop -> prop. - -Check (prop_intro prop). - -Inductive ex_Prop (P : Prop -> Prop) : Prop := - exP_intro : forall X : Prop, P X -> ex_Prop P. - -Lemma ex_Prop_inhabitant : ex_Prop (fun P => P -> P). -Proof. - exists (ex_Prop (fun P => P -> P)). - trivial. -Qed. - - - - -(* - -Check (fun (P:Prop->Prop)(p: ex_Prop P) => - match p with exP_intro X HX => X end). -Error: -Incorrect elimination of "p" in the inductive type -"ex_Prop", the return type has sort "Type" while it should be -"Prop" - -Elimination of an inductive object of sort "Prop" -is not allowed on a predicate in sort "Type" -because proofs can be eliminated only to build proofs - -*) - - -Inductive typ : Type := - typ_intro : Type -> typ. - -Definition typ_inject: typ. -split. -Fail exact typ. -(* -Error: Universe Inconsistency. -*) -Abort. -(* - -Inductive aSet : Set := - aSet_intro: Set -> aSet. - - -User error: Large non-propositional inductive types must be in Type - -*) - -Inductive ex_Set (P : Set -> Prop) : Type := - exS_intro : forall X : Set, P X -> ex_Set P. - - -Inductive comes_from_the_left (P Q:Prop): P \/ Q -> Prop := - c1 : forall p, comes_from_the_left P Q (or_introl (A:=P) Q p). - -Goal (comes_from_the_left _ _ (or_introl True I)). -split. -Qed. - -Goal ~(comes_from_the_left _ _ (or_intror True I)). - red;inversion 1. - (* discriminate H0. - *) -Abort. - -Reset comes_from_the_left. - -(* - - - - - - - Definition comes_from_the_left (P Q:Prop)(H:P \/ Q): Prop := - match H with - | or_introl p => True - | or_intror q => False - end. - -Error: -Incorrect elimination of "H" in the inductive type -"or", the return type has sort "Type" while it should be -"Prop" - -Elimination of an inductive object of sort "Prop" -is not allowed on a predicate in sort "Type" -because proofs can be eliminated only to build proofs - -*) - -Definition comes_from_the_left_sumbool - (P Q:Prop)(x:{P}+{Q}): Prop := - match x with - | left p => True - | right q => False - end. - - - - -Close Scope Z_scope. - - - - - -Theorem S_is_not_O : forall n, S n <> 0. - -Definition Is_zero (x:nat):= match x with - | 0 => True - | _ => False - end. - Lemma O_is_zero : forall m, m = 0 -> Is_zero m. - Proof. - intros m H; subst m. - (* - ============================ - Is_zero 0 - *) - simpl;trivial. - Qed. - - red; intros n Hn. - apply O_is_zero with (m := S n). - assumption. -Qed. - -Theorem disc2 : forall n, S (S n) <> 1. -Proof. - intros n Hn; discriminate. -Qed. - - -Theorem disc3 : forall n, S (S n) = 0 -> forall Q:Prop, Q. -Proof. - intros n Hn Q. - discriminate. -Qed. - - - -Theorem inj_succ : forall n m, S n = S m -> n = m. -Proof. - - -Lemma inj_pred : forall n m, n = m -> pred n = pred m. -Proof. - intros n m eq_n_m. - rewrite eq_n_m. - trivial. -Qed. - - intros n m eq_Sn_Sm. - apply inj_pred with (n:= S n) (m := S m); assumption. -Qed. - -Lemma list_inject : forall (A:Type)(a b :A)(l l':list A), - a :: b :: l = b :: a :: l' -> a = b /\ l = l'. -Proof. - intros A a b l l' e. - injection e. - auto. -Qed. - - -Theorem not_le_Sn_0 : forall n:nat, ~ (S n <= 0). -Proof. - red; intros n H. - case H. -Undo. - -Lemma not_le_Sn_0_with_constraints : - forall n p , S n <= p -> p = 0 -> False. -Proof. - intros n p H; case H ; - intros; discriminate. -Qed. - -eapply not_le_Sn_0_with_constraints; eauto. -Qed. - - -Theorem not_le_Sn_0' : forall n:nat, ~ (S n <= 0). -Proof. - red; intros n H ; inversion H. -Qed. - -Derive Inversion le_Sn_0_inv with (forall n :nat, S n <= 0). -Check le_Sn_0_inv. - -Theorem le_Sn_0'' : forall n p : nat, ~ S n <= 0 . -Proof. - intros n p H; - inversion H using le_Sn_0_inv. -Qed. - -Derive Inversion_clear le_Sn_0_inv' with (forall n :nat, S n <= 0). -Check le_Sn_0_inv'. - - -Theorem le_reverse_rules : - forall n m:nat, n <= m -> - n = m \/ - exists p, n <= p /\ m = S p. -Proof. - intros n m H; inversion H. - left;trivial. - right; exists m0; split; trivial. -Restart. - intros n m H; inversion_clear H. - left;trivial. - right; exists m0; split; trivial. -Qed. - -Inductive ArithExp : Set := - Zero : ArithExp - | Succ : ArithExp -> ArithExp - | Plus : ArithExp -> ArithExp -> ArithExp. - -Inductive RewriteRel : ArithExp -> ArithExp -> Prop := - RewSucc : forall e1 e2 :ArithExp, - RewriteRel e1 e2 -> RewriteRel (Succ e1) (Succ e2) - | RewPlus0 : forall e:ArithExp, - RewriteRel (Plus Zero e) e - | RewPlusS : forall e1 e2:ArithExp, - RewriteRel e1 e2 -> - RewriteRel (Plus (Succ e1) e2) (Succ (Plus e1 e2)). - - - -Fixpoint plus (n p:nat) {struct n} : nat := - match n with - | 0 => p - | S m => S (plus m p) - end. - -Fixpoint plus' (n p:nat) {struct p} : nat := - match p with - | 0 => n - | S q => S (plus' n q) - end. - -Fixpoint plus'' (n p:nat) {struct n} : nat := - match n with - | 0 => p - | S m => plus'' m (S p) - end. - - -Fixpoint even_test (n:nat) : bool := - match n - with 0 => true - | 1 => false - | S (S p) => even_test p - end. - - -Reset even_test. - -Fixpoint even_test (n:nat) : bool := - match n - with - | 0 => true - | S p => odd_test p - end -with odd_test (n:nat) : bool := - match n - with - | 0 => false - | S p => even_test p - end. - - - -Eval simpl in even_test. - - - -Eval simpl in (fun x : nat => even_test x). - -Eval simpl in (fun x : nat => plus 5 x). -Eval simpl in (fun x : nat => even_test (plus 5 x)). - -Eval simpl in (fun x : nat => even_test (plus x 5)). - - -Section Principle_of_Induction. -Variable P : nat -> Prop. -Hypothesis base_case : P 0. -Hypothesis inductive_step : forall n:nat, P n -> P (S n). -Fixpoint nat_ind (n:nat) : (P n) := - match n return P n with - | 0 => base_case - | S m => inductive_step m (nat_ind m) - end. - -End Principle_of_Induction. - -Scheme Even_induction := Minimality for even Sort Prop -with Odd_induction := Minimality for odd Sort Prop. - -Theorem even_plus_four : forall n:nat, even n -> even (4+n). -Proof. - intros n H. - elim H using Even_induction with (P0 := fun n => odd (4+n)); - simpl;repeat constructor;assumption. -Qed. - - -Section Principle_of_Double_Induction. -Variable P : nat -> nat ->Prop. -Hypothesis base_case1 : forall x:nat, P 0 x. -Hypothesis base_case2 : forall x:nat, P (S x) 0. -Hypothesis inductive_step : forall n m:nat, P n m -> P (S n) (S m). -Fixpoint nat_double_ind (n m:nat){struct n} : P n m := - match n, m return P n m with - | 0 , x => base_case1 x - | (S x), 0 => base_case2 x - | (S x), (S y) => inductive_step x y (nat_double_ind x y) - end. -End Principle_of_Double_Induction. - -Section Principle_of_Double_Recursion. -Variable P : nat -> nat -> Type. -Hypothesis base_case1 : forall x:nat, P 0 x. -Hypothesis base_case2 : forall x:nat, P (S x) 0. -Hypothesis inductive_step : forall n m:nat, P n m -> P (S n) (S m). -Fixpoint nat_double_rect (n m:nat){struct n} : P n m := - match n, m return P n m with - | 0 , x => base_case1 x - | (S x), 0 => base_case2 x - | (S x), (S y) => inductive_step x y (nat_double_rect x y) - end. -End Principle_of_Double_Recursion. - -Definition min : nat -> nat -> nat := - nat_double_rect (fun (x y:nat) => nat) - (fun (x:nat) => 0) - (fun (y:nat) => 0) - (fun (x y r:nat) => S r). - -Eval compute in (min 5 8). -Eval compute in (min 8 5). - - - -Lemma not_circular : forall n:nat, n <> S n. -Proof. - intro n. - apply nat_ind with (P:= fun n => n <> S n). - discriminate. - red; intros n0 Hn0 eqn0Sn0;injection eqn0Sn0;trivial. -Qed. - -Definition eq_nat_dec : forall n p:nat , {n=p}+{n <> p}. -Proof. - intros n p. - apply nat_double_rect with (P:= fun (n q:nat) => {q=p}+{q <> p}). -Undo. - pattern p,n. - elim n using nat_double_rect. - destruct x; auto. - destruct x; auto. - intros n0 m H; case H. - intro eq; rewrite eq ; auto. - intro neg; right; red ; injection 1; auto. -Defined. - -Definition eq_nat_dec' : forall n p:nat, {n=p}+{n <> p}. - decide equality. -Defined. - - - -Require Import Le. -Lemma le'_le : forall n p, le' n p -> n <= p. -Proof. - induction 1;auto with arith. -Qed. - -Lemma le'_n_Sp : forall n p, le' n p -> le' n (S p). -Proof. - induction 1;auto. -Qed. - -Hint Resolve le'_n_Sp. - - -Lemma le_le' : forall n p, n<=p -> le' n p. -Proof. - induction 1;auto with arith. -Qed. - - -Print Acc. - - -Require Import Minus. - -(* -Fixpoint div (x y:nat){struct x}: nat := - if eq_nat_dec x 0 - then 0 - else if eq_nat_dec y 0 - then x - else S (div (x-y) y). - -Error: -Recursive definition of div is ill-formed. -In environment -div : nat -> nat -> nat -x : nat -y : nat -_ : x <> 0 -_ : y <> 0 - -Recursive call to div has principal argument equal to -"x - y" -instead of a subterm of x - -*) - -Lemma minus_smaller_S: forall x y:nat, x - y < S x. -Proof. - intros x y; pattern y, x; - elim x using nat_double_ind. - destruct x0; auto with arith. - simpl; auto with arith. - simpl; auto with arith. -Qed. - -Lemma minus_smaller_positive : forall x y:nat, x <>0 -> y <> 0 -> - x - y < x. -Proof. - destruct x; destruct y; - ( simpl;intros; apply minus_smaller_S || - intros; absurd (0=0); auto). -Qed. - -Definition minus_decrease : forall x y:nat, Acc lt x -> - x <> 0 -> - y <> 0 -> - Acc lt (x-y). -Proof. - intros x y H; case H. - intros Hz posz posy. - apply Hz; apply minus_smaller_positive; assumption. -Defined. - -Print minus_decrease. - - -Definition div_aux (x y:nat)(H: Acc lt x):nat. - fix 3. - intros. - refine (if eq_nat_dec x 0 - then 0 - else if eq_nat_dec y 0 - then y - else div_aux (x-y) y _). - apply (minus_decrease x y H);assumption. -Defined. - - -Print div_aux. -(* -div_aux = -(fix div_aux (x y : nat) (H : Acc lt x) {struct H} : nat := - match eq_nat_dec x 0 with - | left _ => 0 - | right _ => - match eq_nat_dec y 0 with - | left _ => y - | right _0 => div_aux (x - y) y (minus_decrease x y H _ _0) - end - end) - : forall x : nat, nat -> Acc lt x -> nat -*) - -Require Import Wf_nat. -Definition div x y := div_aux x y (lt_wf x). - -Extraction div. -(* -let div x y = - div_aux x y -*) - -Extraction div_aux. - -(* -let rec div_aux x y = - match eq_nat_dec x O with - | Left -> O - | Right -> - (match eq_nat_dec y O with - | Left -> y - | Right -> div_aux (minus x y) y) -*) - -Lemma vector0_is_vnil : forall (A:Type)(v:Vector.t A 0), v = Vector.nil A. -Proof. - intros A v;inversion v. -Abort. - -(* - Lemma vector0_is_vnil_aux : forall (A:Type)(n:nat)(v:Vector.t A n), - n= 0 -> v = Vector.nil A. - -Toplevel input, characters 40281-40287 -> Lemma vector0_is_vnil_aux : forall (A:Set)(n:nat)(v:Vector.t A n), n= 0 -> v = Vector.nil A. -> ^^^^^^ -Error: In environment -A : Set -n : nat -v : Vector.t A n -e : n = 0 -The term "Vector.nil A" has type "Vector.t A 0" while it is expected to have type - "Vector.t A n" -*) - Require Import JMeq. - - -(* On devrait changer Set en Type ? *) - -Lemma vector0_is_vnil_aux : forall (A:Type)(n:nat)(v:Vector.t A n), - n= 0 -> JMeq v (Vector.nil A). -Proof. - destruct v. - auto. - intro; discriminate. -Qed. - -Lemma vector0_is_vnil : forall (A:Type)(v:Vector.t A 0), v = Vector.nil A. -Proof. - intros a v;apply JMeq_eq. - apply vector0_is_vnil_aux. - trivial. -Qed. - - -Implicit Arguments Vector.cons [A n]. -Implicit Arguments Vector.nil [A]. -Implicit Arguments Vector.hd [A n]. -Implicit Arguments Vector.tl [A n]. - -Definition Vid : forall (A : Type)(n:nat), Vector.t A n -> Vector.t A n. -Proof. - destruct n; intro v. - exact Vector.nil. - exact (Vector.cons (Vector.hd v) (Vector.tl v)). -Defined. - -Eval simpl in (fun (A:Type)(v:Vector.t A 0) => (Vid _ _ v)). - -Eval simpl in (fun (A:Type)(v:Vector.t A 0) => v). - - - -Lemma Vid_eq : forall (n:nat) (A:Type)(v:Vector.t A n), v=(Vid _ n v). -Proof. - destruct v. - reflexivity. - reflexivity. -Defined. - -Theorem zero_nil : forall A (v:Vector.t A 0), v = Vector.nil. -Proof. - intros. - change (Vector.nil (A:=A)) with (Vid _ 0 v). - apply Vid_eq. -Defined. - - -Theorem decomp : - forall (A : Type) (n : nat) (v : Vector.t A (S n)), - v = Vector.cons (Vector.hd v) (Vector.tl v). -Proof. - intros. - change (Vector.cons (Vector.hd v) (Vector.tl v)) with (Vid _ (S n) v). - apply Vid_eq. -Defined. - - - -Definition vector_double_rect : - forall (A:Type) (P: forall (n:nat),(Vector.t A n)->(Vector.t A n) -> Type), - P 0 Vector.nil Vector.nil -> - (forall n (v1 v2 : Vector.t A n) a b, P n v1 v2 -> - P (S n) (Vector.cons a v1) (Vector.cons b v2)) -> - forall n (v1 v2 : Vector.t A n), P n v1 v2. - induction n. - intros; rewrite (zero_nil _ v1); rewrite (zero_nil _ v2). - auto. - intros v1 v2; rewrite (decomp _ _ v1);rewrite (decomp _ _ v2). - apply X0; auto. -Defined. - -Require Import Bool. - -Definition bitwise_or n v1 v2 : Vector.t bool n := - vector_double_rect bool (fun n v1 v2 => Vector.t bool n) - Vector.nil - (fun n v1 v2 a b r => Vector.cons (orb a b) r) n v1 v2. - -Fixpoint vector_nth (A:Type)(n:nat)(p:nat)(v:Vector.t A p){struct v} - : option A := - match n,v with - _ , Vector.nil => None - | 0 , Vector.cons b _ => Some b - | S n', @Vector.cons _ _ p' v' => vector_nth A n' p' v' - end. - -Implicit Arguments vector_nth [A p]. - - -Lemma nth_bitwise : forall (n:nat) (v1 v2: Vector.t bool n) i a b, - vector_nth i v1 = Some a -> - vector_nth i v2 = Some b -> - vector_nth i (bitwise_or _ v1 v2) = Some (orb a b). -Proof. - intros n v1 v2; pattern n,v1,v2. - apply vector_double_rect. - simpl. - destruct i; discriminate 1. - destruct i; simpl;auto. - injection 1; injection 2;intros; subst a; subst b; auto. -Qed. - - Set Implicit Arguments. - - CoInductive Stream (A:Type) : Type := - | Cons : A -> Stream A -> Stream A. - - CoInductive LList (A: Type) : Type := - | LNil : LList A - | LCons : A -> LList A -> LList A. - - - - - - Definition head (A:Type)(s : Stream A) := match s with Cons a s' => a end. - - Definition tail (A : Type)(s : Stream A) := - match s with Cons a s' => s' end. - - CoFixpoint repeat (A:Type)(a:A) : Stream A := Cons a (repeat a). - - CoFixpoint iterate (A: Type)(f: A -> A)(a : A) : Stream A:= - Cons a (iterate f (f a)). - - CoFixpoint map (A B:Type)(f: A -> B)(s : Stream A) : Stream B:= - match s with Cons a tl => Cons (f a) (map f tl) end. - -Eval simpl in (fun (A:Type)(a:A) => repeat a). - -Eval simpl in (fun (A:Type)(a:A) => head (repeat a)). - - -CoInductive EqSt (A: Type) : Stream A -> Stream A -> Prop := - eqst : forall s1 s2: Stream A, - head s1 = head s2 -> - EqSt (tail s1) (tail s2) -> - EqSt s1 s2. - - -Section Parks_Principle. -Variable A : Type. -Variable R : Stream A -> Stream A -> Prop. -Hypothesis bisim1 : forall s1 s2:Stream A, R s1 s2 -> - head s1 = head s2. -Hypothesis bisim2 : forall s1 s2:Stream A, R s1 s2 -> - R (tail s1) (tail s2). - -CoFixpoint park_ppl : forall s1 s2:Stream A, R s1 s2 -> - EqSt s1 s2 := - fun s1 s2 (p : R s1 s2) => - eqst s1 s2 (bisim1 p) - (park_ppl (bisim2 p)). -End Parks_Principle. - - -Theorem map_iterate : forall (A:Type)(f:A->A)(x:A), - EqSt (iterate f (f x)) (map f (iterate f x)). -Proof. - intros A f x. - apply park_ppl with - (R:= fun s1 s2 => exists x: A, - s1 = iterate f (f x) /\ s2 = map f (iterate f x)). - - intros s1 s2 (x0,(eqs1,eqs2));rewrite eqs1;rewrite eqs2;reflexivity. - intros s1 s2 (x0,(eqs1,eqs2)). - exists (f x0);split;[rewrite eqs1|rewrite eqs2]; reflexivity. - exists x;split; reflexivity. -Qed. - -Ltac infiniteproof f := - cofix f; constructor; [clear f| simpl; try (apply f; clear f)]. - - -Theorem map_iterate' : forall (A:Type)(f:A->A)(x:A), - EqSt (iterate f (f x)) (map f (iterate f x)). -infiniteproof map_iterate'. - reflexivity. -Qed. - - -Implicit Arguments LNil [A]. - -Lemma Lnil_not_Lcons : forall (A:Type)(a:A)(l:LList A), - LNil <> (LCons a l). - intros;discriminate. -Qed. - -Lemma injection_demo : forall (A:Type)(a b : A)(l l': LList A), - LCons a (LCons b l) = LCons b (LCons a l') -> - a = b /\ l = l'. -Proof. - intros A a b l l' e; injection e; auto. -Qed. - - -Inductive Finite (A:Type) : LList A -> Prop := -| Lnil_fin : Finite (LNil (A:=A)) -| Lcons_fin : forall a l, Finite l -> Finite (LCons a l). - -CoInductive Infinite (A:Type) : LList A -> Prop := -| LCons_inf : forall a l, Infinite l -> Infinite (LCons a l). - -Lemma LNil_not_Infinite : forall (A:Type), ~ Infinite (LNil (A:=A)). -Proof. - intros A H;inversion H. -Qed. - -Lemma Finite_not_Infinite : forall (A:Type)(l:LList A), - Finite l -> ~ Infinite l. -Proof. - intros A l H; elim H. - apply LNil_not_Infinite. - intros a l0 F0 I0' I1. - case I0'; inversion_clear I1. - trivial. -Qed. - -Lemma Not_Finite_Infinite : forall (A:Type)(l:LList A), - ~ Finite l -> Infinite l. -Proof. - cofix H. - destruct l. - intro; absurd (Finite (LNil (A:=A)));[auto|constructor]. - constructor. - apply H. - red; intro H1;case H0. - constructor. - trivial. -Qed. - - - diff --git a/doc/RecTutorial/coqartmacros.tex b/doc/RecTutorial/coqartmacros.tex deleted file mode 100644 index 72d749269..000000000 --- a/doc/RecTutorial/coqartmacros.tex +++ /dev/null @@ -1,180 +0,0 @@ -\usepackage{url} - -\newcommand{\variantspringer}[1]{#1} -\newcommand{\marginok}[1]{\marginpar{\raggedright OK:#1}} -\newcommand{\tab}{{\null\hskip1cm}} -\newcommand{\Ltac}{\mbox{\emph{$\cal L$}tac}} -\newcommand{\coq}{\mbox{\emph{Coq}}} -\newcommand{\lcf}{\mbox{\emph{LCF}}} -\newcommand{\hol}{\mbox{\emph{HOL}}} -\newcommand{\pvs}{\mbox{\emph{PVS}}} -\newcommand{\isabelle}{\mbox{\emph{Isabelle}}} -\newcommand{\prolog}{\mbox{\emph{Prolog}}} -\newcommand{\goalbar}{\tt{}============================\it} -\newcommand{\gallina}{\mbox{\emph{Gallina}}} -\newcommand{\joker}{\texttt{\_}} -\newcommand{\eprime}{\(\e^{\prime}\)} -\newcommand{\Ztype}{\citecoq{Z}} -\newcommand{\propsort}{\citecoq{Prop}} -\newcommand{\setsort}{\citecoq{Set}} -\newcommand{\typesort}{\citecoq{Type}} -\newcommand{\ocaml}{\mbox{\emph{OCAML}}} -\newcommand{\haskell}{\mbox{\emph{Haskell}}} -\newcommand{\why}{\mbox{\emph{Why}}} -\newcommand{\Pascal}{\mbox{\emph{Pascal}}} - -\newcommand{\ml}{\mbox{\emph{ML}}} - -\newcommand{\scheme}{\mbox{\emph{Scheme}}} -\newcommand{\lisp}{\mbox{\emph{Lisp}}} - -\newcommand{\implarrow}{\mbox{$\Rightarrow$}} -\newcommand{\metavar}[1]{?#1} -\newcommand{\notincoq}[1]{#1} -\newcommand{\coqscope}[1]{\%#1} -\newcommand{\arrow}{\mbox{$\rightarrow$}} -\newcommand{\fleche}{\arrow} -\newcommand{\funarrow}{\mbox{$\Rightarrow$}} -\newcommand{\ltacarrow}{\funarrow} -\newcommand{\coqand}{\mbox{\(\wedge\)}} -\newcommand{\coqor}{\mbox{\(\vee\)}} -\newcommand{\coqnot}{\mbox{\(\neg\)}} -\newcommand{\hide}[1]{} -\newcommand{\hidedots}[1]{...} -\newcommand{\sig}[3]{\texttt{\{}#1\texttt{:}#2 \texttt{|} #3\texttt{\}}} -\renewcommand{\neg}{\sim} -\renewcommand{\marginpar}[1]{} - -\addtocounter{secnumdepth}{1} -\providecommand{\og}{«} -\providecommand{\fg}{»} - - -\newcommand{\hard}{\mbox{\small *}} -\newcommand{\xhard}{\mbox{\small **}} -\newcommand{\xxhard}{\mbox{\small ***}} - -%%% Operateurs, etc. -\newcommand{\impl}{\mbox{$\rightarrow$}} -\newcommand{\appli}[2]{\mbox{\tt{#1 #2}}} -\newcommand{\applis}[1]{\mbox{\texttt{#1}}} -\newcommand{\abst}[3]{\mbox{\tt{fun #1:#2 \funarrow #3}}} -\newcommand{\coqle}{\mbox{$\leq$}} -\newcommand{\coqge}{\mbox{$\geq$}} -\newcommand{\coqdiff}{\mbox{$\neq$}} -\newcommand{\coqiff}{\mbox{$\leftrightarrow$}} -\newcommand{\prodsym}{\mbox{\(\forall\,\)}} -\newcommand{\exsym}{\mbox{\(\exists\,\)}} - -\newcommand{\substsign}{/} -\newcommand{\subst}[3]{\mbox{#1\{#2\substsign{}#3\}}} -\newcommand{\anoabst}[2]{\mbox{\tt[#1]#2}} -\newcommand{\letin}[3]{\mbox{\tt let #1:=#2 in #3}} -\newcommand{\prodep}[3]{\mbox{\tt \(\forall\,\)#1:#2,$\,$#3}} -\newcommand{\prodplus}[2]{\mbox{\tt\(\forall\,\)$\,$#1,$\,$#2}} -\newcommand{\dom}[1]{\textrm{dom}(#1)} % domaine d'un contexte (log function) -\newcommand{\norm}[1]{\textrm{n}(#1)} % forme normale (log function) -\newcommand{\coqZ}[1]{\mbox{\tt{`#1`}}} -\newcommand{\coqnat}[1]{\mbox{\tt{#1}}} -\newcommand{\coqcart}[2]{\mbox{\tt{#1*#2}}} -\newcommand{\alphacong}{\mbox{$\,\cong_{\alpha}\,$}} % alpha-congruence -\newcommand{\betareduc}{\mbox{$\,\rightsquigarrow_{\!\beta}$}\,} % beta reduction -%\newcommand{\betastar}{\mbox{$\,\Rightarrow_{\!\beta}^{*}\,$}} % beta reduction -\newcommand{\deltareduc}{\mbox{$\,\rightsquigarrow_{\!\delta}$}\,} % delta reduction -\newcommand{\dbreduc}{\mbox{$\,\rightsquigarrow_{\!\delta\beta}$}\,} % delta,beta reduction -\newcommand{\ireduc}{\mbox{$\,\rightsquigarrow_{\!\iota}$}\,} % delta,beta reduction - - -% jugement de typage -\newcommand{\these}{\boldsymbol{\large \vdash}} -\newcommand{\disj}{\mbox{$\backslash/$}} -\newcommand{\conj}{\mbox{$/\backslash$}} -%\newcommand{\juge}[3]{\mbox{$#1 \boldsymbol{\vdash} #2 : #3 $}} -\newcommand{\juge}[4]{\mbox{$#1,#2 \these #3 \boldsymbol{:} #4 $}} -\newcommand{\smalljuge}[3]{\mbox{$#1 \these #2 \boldsymbol{:} #3 $}} -\newcommand{\goal}[3]{\mbox{$#1,#2 \these^{\!\!\!?} #3 $}} -\newcommand{\sgoal}[2]{\mbox{$#1\these^{\!\!\!\!?} #2 $}} -\newcommand{\reduc}[5]{\mbox{$#1,#2 \these #3 \rhd_{#4}#5 $}} -\newcommand{\convert}[5]{\mbox{$#1,#2 \these #3 =_{#4}#5 $}} -\newcommand{\convorder}[5]{\mbox{$#1,#2 \these #3\leq _{#4}#5 $}} -\newcommand{\wouff}[2]{\mbox{$\emph{WF}(#1)[#2]$}} - - -%\newcommand{\mthese}{\underset{M}{\vdash}} -\newcommand{\mthese}{\boldsymbol{\vdash}_{\!\!M}} -\newcommand{\type}{\boldsymbol{:}} - -% jugement absolu - -%\newcommand{\ajuge}[2]{\mbox{$ \boldsymbol{\vdash} #1 : #2 $}} -\newcommand{\ajuge}[2]{\mbox{$\these #1 \boldsymbol{:} #2 $}} - -%%% logique minimale -\newcommand{\propzero}{\mbox{$P_0$}} % types de Fzero - -%%% logique propositionnelle classique -\newcommand {\ff}{\boldsymbol{f}} % faux -\newcommand {\vv}{\boldsymbol{t}} % vrai - -\newcommand{\verite}{\mbox{$\cal{B}$}} % {\ff,\vv} -\newcommand{\sequ}[2]{\mbox{$#1 \vdash #2 $}} % sequent -\newcommand{\strip}[1]{#1^o} % enlever les variables d'un contexte - - - -%%% tactiques -\newcommand{\decomp}{\delta} % decomposition -\newcommand{\recomp}{\rho} % recomposition - -%%% divers -\newcommand{\cqfd}{\mbox{\textbf{cqfd}}} -\newcommand{\fail}{\mbox{\textbf{F}}} -\newcommand{\succes}{\mbox{$\blacksquare$}} -%%% Environnements - - -%% Fzero -\newcommand{\con}{\mbox{$\cal C$}} -\newcommand{\var}{\mbox{$\cal V$}} - -\newcommand{\atomzero}{\mbox{${\cal A}_0$}} % types de base de Fzero -\newcommand{\typezero}{\mbox{${\cal T}_0$}} % types de Fzero -\newcommand{\termzero}{\mbox{$\Lambda_0$}} % termes de Fzero -\newcommand{\conzero}{\mbox{$\cal C_0$}} % contextes de Fzero - -\newcommand{\buts}{\mbox{$\cal B$}} % buts - -%%% for drawing terms -% abstraction [x:t]e -\newcommand{\PicAbst}[3]{\begin{bundle}{\bf abst}\chunk{#1}\chunk{#2}\chunk{#3}% - \end{bundle}} - -% the same in de Bruijn form -\newcommand{\PicDbj}[2]{\begin{bundle}{\bf abst}\chunk{#1}\chunk{#2} - \end{bundle}} - - -% applications -\newcommand{\PicAppl}[2]{\begin{bundle}{\bf appl}\chunk{#1}\chunk{#2}% - \end{bundle}} - -% variables -\newcommand{\PicVar}[1]{\begin{bundle}{\bf var}\chunk{#1} - \end{bundle}} - -% constantes -\newcommand{\PicCon}[1]{\begin{bundle}{\bf const}\chunk{#1}\end{bundle}} - -% arrows -\newcommand{\PicImpl}[2]{\begin{bundle}{\impl}\chunk{#1}\chunk{#2}% - \end{bundle}} - - - -%%%% scripts coq -\newcommand{\prompt}{\mbox{\sl Coq $<\;$}} -\newcommand{\natquicksort}{\texttt{nat\_quicksort}} -\newcommand{\citecoq}[1]{\mbox{\texttt{#1}}} -\newcommand{\safeit}{\it} -\newtheorem{remarque}{Remark}[section] -%\newtheorem{definition}{Definition}[chapter] diff --git a/doc/RecTutorial/manbiblio.bib b/doc/RecTutorial/manbiblio.bib deleted file mode 100644 index caee81782..000000000 --- a/doc/RecTutorial/manbiblio.bib +++ /dev/null @@ -1,870 +0,0 @@ - -@STRING{toappear="To appear"} -@STRING{lncs="Lecture Notes in Computer Science"} - -@TECHREPORT{RefManCoq, - AUTHOR = {Bruno~Barras, Samuel~Boutin, - Cristina~Cornes, Judicaël~Courant, Yann~Coscoy, David~Delahaye, - Daniel~de~Rauglaudre, Jean-Christophe~Filliâtre, Eduardo~Giménez, - Hugo~Herbelin, Gérard~Huet, Henri~Laulhère, César~Muñoz, - Chetan~Murthy, Catherine~Parent-Vigouroux, Patrick~Loiseleur, - Christine~Paulin-Mohring, Amokrane~Saïbi, Benjamin~Werner}, - INSTITUTION = {INRIA}, - TITLE = {{The Coq Proof Assistant Reference Manual -- Version V6.2}}, - YEAR = {1998} -} - -@INPROCEEDINGS{Aud91, - AUTHOR = {Ph. Audebaud}, - BOOKTITLE = {Proceedings of the sixth Conf. on Logic in Computer Science.}, - PUBLISHER = {IEEE}, - TITLE = {Partial {Objects} in the {Calculus of Constructions}}, - YEAR = {1991} -} - -@PHDTHESIS{Aud92, - AUTHOR = {Ph. Audebaud}, - SCHOOL = {{Universit\'e} Bordeaux I}, - TITLE = {Extension du Calcul des Constructions par Points fixes}, - YEAR = {1992} -} - -@INPROCEEDINGS{Audebaud92b, - AUTHOR = {Ph. Audebaud}, - BOOKTITLE = {{Proceedings of the 1992 Workshop on Types for Proofs and Programs}}, - EDITOR = {{B. Nordstr\"om and K. Petersson and G. Plotkin}}, - NOTE = {Also Research Report LIP-ENS-Lyon}, - PAGES = {pp 21--34}, - TITLE = {{CC+ : an extension of the Calculus of Constructions with fixpoints}}, - YEAR = {1992} -} - -@INPROCEEDINGS{Augustsson85, - AUTHOR = {L. Augustsson}, - TITLE = {{Compiling Pattern Matching}}, - BOOKTITLE = {Conference Functional Programming and -Computer Architecture}, - YEAR = {1985} -} - -@INPROCEEDINGS{EG94a, - AUTHOR = {E. Gim\'enez}, - EDITORS = {P. Dybjer and B. Nordstr\"om and J. Smith}, - BOOKTITLE = {Workshop on Types for Proofs and Programs}, - PAGES = {39-59}, - SERIES = {LNCS}, - NUMBER = {996}, - TITLE = {{Codifying guarded definitions with recursive schemes}}, - YEAR = {1994}, - PUBLISHER = {Springer-Verlag}, -} - -@INPROCEEDINGS{EG95a, - AUTHOR = {E. Gim\'enez}, - BOOKTITLE = {Workshop on Types for Proofs and Programs}, - SERIES = {LNCS}, - NUMBER = {1158}, - PAGES = {135-152}, - TITLE = {An application of co-Inductive types in Coq: - verification of the Alternating Bit Protocol}, - EDITORS = {S. Berardi and M. Coppo}, - PUBLISHER = {Springer-Verlag}, - YEAR = {1995} -} - -@PhdThesis{EG96, - author = {E. Gim\'enez}, - title = {A Calculus of Infinite Constructions and its - application to the verification of communicating systems}, - school = {Ecole Normale Sup\'erieure de Lyon}, - year = {1996} -} - -@ARTICLE{BaCo85, - AUTHOR = {J.L. Bates and R.L. Constable}, - JOURNAL = {ACM transactions on Programming Languages and Systems}, - TITLE = {Proofs as {Programs}}, - VOLUME = {7}, - YEAR = {1985} -} - -@BOOK{Bar81, - AUTHOR = {H.P. Barendregt}, - PUBLISHER = {North-Holland}, - TITLE = {The Lambda Calculus its Syntax and Semantics}, - YEAR = {1981} -} - -@TECHREPORT{Bar91, - AUTHOR = {H. Barendregt}, - INSTITUTION = {Catholic University Nijmegen}, - NOTE = {In Handbook of Logic in Computer Science, Vol II}, - NUMBER = {91-19}, - TITLE = {Lambda {Calculi with Types}}, - YEAR = {1991} -} - -@BOOK{Bastad92, - EDITOR = {B. Nordstr\"om and K. Petersson and G. Plotkin}, - PUBLISHER = {Available by ftp at site ftp.inria.fr}, - TITLE = {Proceedings of the 1992 Workshop on Types for Proofs and Programs}, - YEAR = {1992} -} - -@BOOK{Bee85, - AUTHOR = {M.J. Beeson}, - PUBLISHER = {Springer-Verlag}, - TITLE = {Foundations of Constructive Mathematics, Metamathematical Studies}, - YEAR = {1985} -} - -@ARTICLE{BeKe92, - AUTHOR = {G. Bellin and J. Ketonen}, - JOURNAL = {Theoretical Computer Science}, - PAGES = {115--142}, - TITLE = {A decision procedure revisited : Notes on direct logic, linear logic and its implementation}, - VOLUME = {95}, - YEAR = {1992} -} - -@BOOK{Bis67, - AUTHOR = {E. Bishop}, - PUBLISHER = {McGraw-Hill}, - TITLE = {Foundations of Constructive Analysis}, - YEAR = {1967} -} - -@BOOK{BoMo79, - AUTHOR = {R.S. Boyer and J.S. Moore}, - KEY = {BoMo79}, - PUBLISHER = {Academic Press}, - SERIES = {ACM Monograph}, - TITLE = {A computational logic}, - YEAR = {1979} -} - -@MASTERSTHESIS{Bou92, - AUTHOR = {S. Boutin}, - MONTH = sep, - SCHOOL = {{Universit\'e Paris 7}}, - TITLE = {Certification d'un compilateur {ML en Coq}}, - YEAR = {1992} -} - -@ARTICLE{Bru72, - AUTHOR = {N.J. de Bruijn}, - JOURNAL = {Indag. Math.}, - TITLE = {{Lambda-Calculus Notation with Nameless Dummies, a Tool for Automatic Formula Manipulation, with Application to the Church-Rosser Theorem}}, - VOLUME = {34}, - YEAR = {1972} -} - -@INCOLLECTION{Bru80, - AUTHOR = {N.J. de Bruijn}, - BOOKTITLE = {to H.B. Curry : Essays on Combinatory Logic, Lambda Calculus and Formalism.}, - EDITOR = {J.P. Seldin and J.R. Hindley}, - PUBLISHER = {Academic Press}, - TITLE = {A survey of the project {Automath}}, - YEAR = {1980} -} - -@TECHREPORT{Leroy90, - AUTHOR = {X. Leroy}, - TITLE = {The {ZINC} experiment: an economical implementation -of the {ML} language}, - INSTITUTION = {INRIA}, - NUMBER = {117}, - YEAR = {1990} -} - -@BOOK{Caml, - AUTHOR = {P. Weis and X. Leroy}, - PUBLISHER = {InterEditions}, - TITLE = {Le langage Caml}, - YEAR = {1993} -} - -@TECHREPORT{CoC89, - AUTHOR = {Projet Formel}, - INSTITUTION = {INRIA}, - NUMBER = {110}, - TITLE = {{The Calculus of Constructions. Documentation and user's guide, Version 4.10}}, - YEAR = {1989} -} - -@INPROCEEDINGS{CoHu85a, - AUTHOR = {Th. Coquand and G. Huet}, - ADDRESS = {Linz}, - BOOKTITLE = {EUROCAL'85}, - PUBLISHER = {Springer-Verlag}, - SERIES = {LNCS}, - TITLE = {{Constructions : A Higher Order Proof System for Mechanizing Mathematics}}, - VOLUME = {203}, - YEAR = {1985} -} - -@Misc{Bar98, - author = {B. Barras}, - title = {A formalisation of - \uppercase{B}urali-\uppercase{F}orti's paradox in Coq}, - howpublished = {Distributed within the bunch of contribution to the - Coq system}, - year = {1998}, - month = {March}, - note = {\texttt{http://pauillac.inria.fr/coq}} -} - - -@INPROCEEDINGS{CoHu85b, - AUTHOR = {Th. Coquand and G. Huet}, - BOOKTITLE = {Logic Colloquium'85}, - EDITOR = {The Paris Logic Group}, - PUBLISHER = {North-Holland}, - TITLE = {{Concepts Math\'ematiques et Informatiques formalis\'es dans le Calcul des Constructions}}, - YEAR = {1987} -} - -@ARTICLE{CoHu86, - AUTHOR = {Th. Coquand and G. Huet}, - JOURNAL = {Information and Computation}, - NUMBER = {2/3}, - TITLE = {The {Calculus of Constructions}}, - VOLUME = {76}, - YEAR = {1988} -} - -@BOOK{Con86, - AUTHOR = {R.L. {Constable et al.}}, - PUBLISHER = {Prentice-Hall}, - TITLE = {{Implementing Mathematics with the Nuprl Proof Development System}}, - YEAR = {1986} -} - -@INPROCEEDINGS{CoPa89, - AUTHOR = {Th. Coquand and C. Paulin-Mohring}, - BOOKTITLE = {Proceedings of Colog'88}, - EDITOR = {P. Martin-L{\"o}f and G. Mints}, - PUBLISHER = {Springer-Verlag}, - SERIES = {LNCS}, - TITLE = {Inductively defined types}, - VOLUME = {417}, - YEAR = {1990} -} - -@PHDTHESIS{Coq85, - AUTHOR = {Th. Coquand}, - MONTH = jan, - SCHOOL = {Universit\'e Paris~7}, - TITLE = {Une Th\'eorie des Constructions}, - YEAR = {1985} -} - -@INPROCEEDINGS{Coq86, - AUTHOR = {Th. Coquand}, - ADDRESS = {Cambridge, MA}, - BOOKTITLE = {Symposium on Logic in Computer Science}, - PUBLISHER = {IEEE Computer Society Press}, - TITLE = {{An Analysis of Girard's Paradox}}, - YEAR = {1986} -} - -@INPROCEEDINGS{Coq90, - AUTHOR = {Th. Coquand}, - BOOKTITLE = {Logic and Computer Science}, - EDITOR = {P. Oddifredi}, - NOTE = {INRIA Research Report 1088, also in~\cite{CoC89}}, - PUBLISHER = {Academic Press}, - TITLE = {{Metamathematical Investigations of a Calculus of Constructions}}, - YEAR = {1990} -} - -@INPROCEEDINGS{Coq92, - AUTHOR = {Th. Coquand}, - BOOKTITLE = {in \cite{Bastad92}}, - TITLE = {{Pattern Matching with Dependent Types}}, - YEAR = {1992}, - crossref = {Bastad92} -} - -@TECHREPORT{COQ93, - AUTHOR = {G. Dowek and A. Felty and H. Herbelin and G. Huet and C. Murthy and C. Parent and C. Paulin-Mohring and B. Werner}, - INSTITUTION = {INRIA}, - MONTH = may, - NUMBER = {154}, - TITLE = {{The Coq Proof Assistant User's Guide Version 5.8}}, - YEAR = {1993} -} - -@INPROCEEDINGS{Coquand93, - AUTHOR = {Th. Coquand}, - BOOKTITLE = {in \cite{Nijmegen93}}, - TITLE = {{Infinite Objects in Type Theory}}, - YEAR = {1993}, - crossref = {Nijmegen93} -} - -@MASTERSTHESIS{Cou94a, - AUTHOR = {J. Courant}, - MONTH = sep, - SCHOOL = {DEA d'Informatique, ENS Lyon}, - TITLE = {Explicitation de preuves par r\'ecurrence implicite}, - YEAR = {1994} -} - -@TECHREPORT{CPar93, - AUTHOR = {C. Parent}, - INSTITUTION = {Ecole {Normale} {Sup\'erieure} de {Lyon}}, - MONTH = oct, - NOTE = {Also in~\cite{Nijmegen93}}, - NUMBER = {93-29}, - TITLE = {Developing certified programs in the system {Coq}- {The} {Program} tactic}, - YEAR = {1993} -} - -@PHDTHESIS{CPar95, - AUTHOR = {C. Parent}, - SCHOOL = {Ecole {Normale} {Sup\'erieure} de {Lyon}}, - TITLE = {{Synth\`ese de preuves de programmes dans le Calcul des Constructions Inductives}}, - YEAR = {1995} -} - -@TECHREPORT{Dow90, - AUTHOR = {G. Dowek}, - INSTITUTION = {INRIA}, - NUMBER = {1283}, - TITLE = {{Naming and Scoping in a Mathematical Vernacular}}, - TYPE = {Research Report}, - YEAR = {1990} -} - -@ARTICLE{Dow91a, - AUTHOR = {G. Dowek}, - JOURNAL = {{Compte Rendu de l'Acad\'emie des Sciences}}, - NOTE = {(The undecidability of Third Order Pattern Matching in Calculi with Dependent Types or Type Constructors)}, - NUMBER = {12}, - PAGES = {951--956}, - TITLE = {{L'Ind\'ecidabilit\'e du Filtrage du Troisi\`eme Ordre dans les Calculs avec Types D\'ependants ou Constructeurs de Types}}, - VOLUME = {I, 312}, - YEAR = {1991} -} - -@INPROCEEDINGS{Dow91b, - AUTHOR = {G. Dowek}, - BOOKTITLE = {Proceedings of Mathematical Foundation of Computer Science}, - NOTE = {Also INRIA Research Report}, - PAGES = {151--160}, - PUBLISHER = {Springer-Verlag}, - SERIES = {LNCS}, - TITLE = {{A Second Order Pattern Matching Algorithm in the Cube of Typed {$\lambda$}-calculi}}, - VOLUME = {520}, - YEAR = {1991} -} - -@PHDTHESIS{Dow91c, - AUTHOR = {G. Dowek}, - MONTH = dec, - SCHOOL = {{Universit\'e Paris 7}}, - TITLE = {{D\'emonstration automatique dans le Calcul des Constructions}}, - YEAR = {1991} -} - -@ARTICLE{dowek93, - AUTHOR = {G. Dowek}, - TITLE = {{A Complete Proof Synthesis Method for the Cube of Type Systems}}, - JOURNAL = {Journal Logic Computation}, - VOLUME = {3}, - NUMBER = {3}, - PAGES = {287--315}, - MONTH = {June}, - YEAR = {1993} -} - -@UNPUBLISHED{Dow92a, - AUTHOR = {G. Dowek}, - NOTE = {To appear in Theoretical Computer Science}, - TITLE = {{The Undecidability of Pattern Matching in Calculi where Primitive Recursive Functions are Representable}}, - YEAR = {1992} -} - -@ARTICLE{Dow94a, - AUTHOR = {G. Dowek}, - JOURNAL = {Annals of Pure and Applied Logic}, - VOLUME = {69}, - PAGES = {135--155}, - TITLE = {Third order matching is decidable}, - YEAR = {1994} -} - -@INPROCEEDINGS{Dow94b, - AUTHOR = {G. Dowek}, - BOOKTITLE = {Proceedings of the second international conference on typed lambda calculus and applications}, - TITLE = {{Lambda-calculus, Combinators and the Comprehension Schema}}, - YEAR = {1995} -} - -@INPROCEEDINGS{Dyb91, - AUTHOR = {P. Dybjer}, - BOOKTITLE = {Logical Frameworks}, - EDITOR = {G. Huet and G. Plotkin}, - PAGES = {59--79}, - PUBLISHER = {Cambridge University Press}, - TITLE = {{Inductive sets and families in {Martin-L{\"o}f's Type Theory} and their set-theoretic semantics : An inversion principle for {Martin-L\"of's} type theory}}, - VOLUME = {14}, - YEAR = {1991} -} - -@ARTICLE{Dyc92, - AUTHOR = {Roy Dyckhoff}, - JOURNAL = {The Journal of Symbolic Logic}, - MONTH = sep, - NUMBER = {3}, - TITLE = {Contraction-free sequent calculi for intuitionistic logic}, - VOLUME = {57}, - YEAR = {1992} -} - -@MASTERSTHESIS{Fil94, - AUTHOR = {J.-C. Filli\^atre}, - MONTH = sep, - SCHOOL = {DEA d'Informatique, ENS Lyon}, - TITLE = {Une proc\'edure de d\'ecision pour le {C}alcul des {P}r\'edicats {D}irect. {E}tude et impl\'ementation dans le syst\`eme {C}oq}, - YEAR = {1994} -} - -@TECHREPORT{Filliatre95, - AUTHOR = {J.-C. Filli\^atre}, - INSTITUTION = {LIP-ENS-Lyon}, - TITLE = {{A decision procedure for Direct Predicate Calculus}}, - TYPE = {Research report}, - NUMBER = {96--25}, - YEAR = {1995} -} - -@UNPUBLISHED{Fle90, - AUTHOR = {E. Fleury}, - MONTH = jul, - NOTE = {Rapport de Stage}, - TITLE = {Implantation des algorithmes de {Floyd et de Dijkstra} dans le {Calcul des Constructions}}, - YEAR = {1990} -} - - -@TechReport{Gim98, - author = {E. Gim\'nez}, - title = {A Tutorial on Recursive Types in Coq}, - institution = {INRIA}, - year = {1998} -} - -@TECHREPORT{HKP97, - author = {G. Huet and G. Kahn and Ch. Paulin-Mohring}, - title = {The {Coq} Proof Assistant - A tutorial, Version 6.1}, - institution = {INRIA}, - type = {rapport technique}, - month = {Août}, - year = {1997}, - note = {Version révisée distribuée avec {Coq}}, - number = {204}, -} - -@INPROCEEDINGS{Gir70, - AUTHOR = {J.-Y. Girard}, - BOOKTITLE = {Proceedings of the 2nd Scandinavian Logic Symposium}, - PUBLISHER = {North-Holland}, - TITLE = {Une extension de l'interpr\'etation de {G\"odel} \`a l'analyse, et son application \`a l'\'elimination des coupures dans l'analyse et la th\'eorie des types}, - YEAR = {1970} -} - -@PHDTHESIS{Gir72, - AUTHOR = {J.-Y. Girard}, - SCHOOL = {Universit\'e Paris~7}, - TITLE = {Interpr\'etation fonctionnelle et \'elimination des coupures de l'arithm\'etique d'ordre sup\'erieur}, - YEAR = {1972} -} - -@BOOK{Gir89, - AUTHOR = {J.-Y. Girard and Y. Lafont and P. Taylor}, - PUBLISHER = {Cambridge University Press}, - SERIES = {Cambridge Tracts in Theoretical Computer Science 7}, - TITLE = {Proofs and Types}, - YEAR = {1989} -} - -@MASTERSTHESIS{Hir94, - AUTHOR = {D. Hirschkoff}, - MONTH = sep, - SCHOOL = {DEA IARFA, Ecole des Ponts et Chauss\'ees, Paris}, - TITLE = {{Ecriture d'une tactique arithm\'etique pour le syst\`eme Coq}}, - YEAR = {1994} -} - -@INCOLLECTION{How80, - AUTHOR = {W.A. Howard}, - BOOKTITLE = {to H.B. Curry : Essays on Combinatory Logic, Lambda Calculus and Formalism.}, - EDITOR = {J.P. Seldin and J.R. Hindley}, - NOTE = {Unpublished 1969 Manuscript}, - PUBLISHER = {Academic Press}, - TITLE = {The Formulae-as-Types Notion of Constructions}, - YEAR = {1980} -} - -@INCOLLECTION{HuetLevy79, - AUTHOR = {G. Huet and J.-J. L\'{e}vy}, - TITLE = {Call by Need Computations in Non-Ambigous -Linear Term Rewriting Systems}, - NOTE = {Also research report 359, INRIA, 1979}, - BOOKTITLE = {Computational Logic, Essays in Honor of -Alan Robinson}, - EDITOR = {J.-L. Lassez and G. Plotkin}, - PUBLISHER = {The MIT press}, - YEAR = {1991} -} - -@INPROCEEDINGS{Hue87, - AUTHOR = {G. Huet}, - BOOKTITLE = {Programming of Future Generation Computers}, - EDITOR = {K. Fuchi and M. Nivat}, - NOTE = {Also in Proceedings of TAPSOFT87, LNCS 249, Springer-Verlag, 1987, pp 276--286}, - PUBLISHER = {Elsevier Science}, - TITLE = {Induction Principles Formalized in the {Calculus of Constructions}}, - YEAR = {1988} -} - -@INPROCEEDINGS{Hue88, - AUTHOR = {G. Huet}, - BOOKTITLE = {A perspective in Theoretical Computer Science. Commemorative Volume for Gift Siromoney}, - EDITOR = {R. Narasimhan}, - NOTE = {Also in~\cite{CoC89}}, - PUBLISHER = {World Scientific Publishing}, - TITLE = {{The Constructive Engine}}, - YEAR = {1989} -} - -@BOOK{Hue89, - EDITOR = {G. Huet}, - PUBLISHER = {Addison-Wesley}, - SERIES = {The UT Year of Programming Series}, - TITLE = {Logical Foundations of Functional Programming}, - YEAR = {1989} -} - -@INPROCEEDINGS{Hue92, - AUTHOR = {G. Huet}, - BOOKTITLE = {Proceedings of 12th FST/TCS Conference, New Delhi}, - PAGES = {229--240}, - PUBLISHER = {Springer Verlag}, - SERIES = {LNCS}, - TITLE = {{The Gallina Specification Language : A case study}}, - VOLUME = {652}, - YEAR = {1992} -} - -@ARTICLE{Hue94, - AUTHOR = {G. Huet}, - JOURNAL = {J. Functional Programming}, - PAGES = {371--394}, - PUBLISHER = {Cambridge University Press}, - TITLE = {Residual theory in $\lambda$-calculus: a formal development}, - VOLUME = {4,3}, - YEAR = {1994} -} - -@ARTICLE{KeWe84, - AUTHOR = {J. Ketonen and R. Weyhrauch}, - JOURNAL = {Theoretical Computer Science}, - PAGES = {297--307}, - TITLE = {A decidable fragment of {P}redicate {C}alculus}, - VOLUME = {32}, - YEAR = {1984} -} - -@BOOK{Kle52, - AUTHOR = {S.C. Kleene}, - PUBLISHER = {North-Holland}, - SERIES = {Bibliotheca Mathematica}, - TITLE = {Introduction to Metamathematics}, - YEAR = {1952} -} - -@BOOK{Kri90, - AUTHOR = {J.-L. Krivine}, - PUBLISHER = {Masson}, - SERIES = {Etudes et recherche en informatique}, - TITLE = {Lambda-calcul {types et mod\`eles}}, - YEAR = {1990} -} - -@ARTICLE{Laville91, - AUTHOR = {A. Laville}, - TITLE = {Comparison of Priority Rules in Pattern -Matching and Term Rewriting}, - JOURNAL = {Journal of Symbolic Computation}, - VOLUME = {11}, - PAGES = {321--347}, - YEAR = {1991} -} - -@BOOK{LE92, - EDITOR = {G. Huet and G. Plotkin}, - PUBLISHER = {Cambridge University Press}, - TITLE = {Logical Environments}, - YEAR = {1992} -} - -@INPROCEEDINGS{LePa94, - AUTHOR = {F. Leclerc and C. Paulin-Mohring}, - BOOKTITLE = {{Types for Proofs and Programs, Types' 93}}, - EDITOR = {H. Barendregt and T. Nipkow}, - PUBLISHER = {Springer-Verlag}, - SERIES = {LNCS}, - TITLE = {{Programming with Streams in Coq. A case study : The Sieve of Eratosthenes}}, - VOLUME = {806}, - YEAR = {1994} -} - -@BOOK{LF91, - EDITOR = {G. Huet and G. Plotkin}, - PUBLISHER = {Cambridge University Press}, - TITLE = {Logical Frameworks}, - YEAR = {1991} -} - -@BOOK{MaL84, - AUTHOR = {{P. Martin-L\"of}}, - PUBLISHER = {Bibliopolis}, - SERIES = {Studies in Proof Theory}, - TITLE = {Intuitionistic Type Theory}, - YEAR = {1984} -} - -@INPROCEEDINGS{manoury94, - AUTHOR = {P. Manoury}, - TITLE = {{A User's Friendly Syntax to Define -Recursive Functions as Typed $\lambda-$Terms}}, - BOOKTITLE = {{Types for Proofs and Programs, TYPES'94}}, - SERIES = {LNCS}, - VOLUME = {996}, - MONTH = jun, - YEAR = {1994} -} - -@ARTICLE{MaSi94, - AUTHOR = {P. Manoury and M. Simonot}, - JOURNAL = {TCS}, - TITLE = {Automatizing termination proof of recursively defined function}, - YEAR = {To appear} -} - -@TECHREPORT{maranget94, - AUTHOR = {L. Maranget}, - INSTITUTION = {INRIA}, - NUMBER = {2385}, - TITLE = {{Two Techniques for Compiling Lazy Pattern Matching}}, - YEAR = {1994} -} - -@INPROCEEDINGS{Moh89a, - AUTHOR = {C. Paulin-Mohring}, - ADDRESS = {Austin}, - BOOKTITLE = {Sixteenth Annual ACM Symposium on Principles of Programming Languages}, - MONTH = jan, - PUBLISHER = {ACM}, - TITLE = {Extracting ${F}_{\omega}$'s programs from proofs in the {Calculus of Constructions}}, - YEAR = {1989} -} - -@PHDTHESIS{Moh89b, - AUTHOR = {C. Paulin-Mohring}, - MONTH = jan, - SCHOOL = {{Universit\'e Paris 7}}, - TITLE = {Extraction de programmes dans le {Calcul des Constructions}}, - YEAR = {1989} -} - -@INPROCEEDINGS{Moh93, - AUTHOR = {C. Paulin-Mohring}, - BOOKTITLE = {Proceedings of the conference Typed Lambda Calculi and Applications}, - EDITOR = {M. Bezem and J.-F. Groote}, - NOTE = {Also LIP research report 92-49, ENS Lyon}, - NUMBER = {664}, - PUBLISHER = {Springer-Verlag}, - SERIES = {LNCS}, - TITLE = {{Inductive Definitions in the System Coq - Rules and Properties}}, - YEAR = {1993} -} - -@MASTERSTHESIS{Mun94, - AUTHOR = {C. Mu\~noz}, - MONTH = sep, - SCHOOL = {DEA d'Informatique Fondamentale, Universit\'e Paris 7}, - TITLE = {D\'emonstration automatique dans la logique propositionnelle intuitionniste}, - YEAR = {1994} -} - -@BOOK{Nijmegen93, - EDITOR = {H. Barendregt and T. Nipkow}, - PUBLISHER = {Springer-Verlag}, - SERIES = {LNCS}, - TITLE = {Types for Proofs and Programs}, - VOLUME = {806}, - YEAR = {1994} -} - -@BOOK{NoPS90, - AUTHOR = {B. {Nordstr\"om} and K. Peterson and J. Smith}, - BOOKTITLE = {Information Processing 83}, - PUBLISHER = {Oxford Science Publications}, - SERIES = {International Series of Monographs on Computer Science}, - TITLE = {Programming in {Martin-L\"of's} Type Theory}, - YEAR = {1990} -} - -@ARTICLE{Nor88, - AUTHOR = {B. {Nordstr\"om}}, - JOURNAL = {BIT}, - TITLE = {Terminating General Recursion}, - VOLUME = {28}, - YEAR = {1988} -} - -@BOOK{Odi90, - EDITOR = {P. Odifreddi}, - PUBLISHER = {Academic Press}, - TITLE = {Logic and Computer Science}, - YEAR = {1990} -} - -@INPROCEEDINGS{PaMS92, - AUTHOR = {M. Parigot and P. Manoury and M. Simonot}, - ADDRESS = {St. Petersburg, Russia}, - BOOKTITLE = {Logic Programming and automated reasoning}, - EDITOR = {A. Voronkov}, - MONTH = jul, - NUMBER = {624}, - PUBLISHER = {Springer-Verlag}, - SERIES = {LNCS}, - TITLE = {{ProPre : A Programming language with proofs}}, - YEAR = {1992} -} - -@ARTICLE{Par92, - AUTHOR = {M. Parigot}, - JOURNAL = {Theoretical Computer Science}, - NUMBER = {2}, - PAGES = {335--356}, - TITLE = {{Recursive Programming with Proofs}}, - VOLUME = {94}, - YEAR = {1992} -} - -@INPROCEEDINGS{Parent95b, - AUTHOR = {C. Parent}, - BOOKTITLE = {{Mathematics of Program Construction'95}}, - PUBLISHER = {Springer-Verlag}, - SERIES = {LNCS}, - TITLE = {{Synthesizing proofs from programs in -the Calculus of Inductive Constructions}}, - VOLUME = {947}, - YEAR = {1995} -} - -@ARTICLE{PaWe92, - AUTHOR = {C. Paulin-Mohring and B. Werner}, - JOURNAL = {Journal of Symbolic Computation}, - PAGES = {607--640}, - TITLE = {{Synthesis of ML programs in the system Coq}}, - VOLUME = {15}, - YEAR = {1993} -} - -@INPROCEEDINGS{Prasad93, - AUTHOR = {K.V. Prasad}, - BOOKTITLE = {{Proceedings of CONCUR'93}}, - PUBLISHER = {Springer-Verlag}, - SERIES = {LNCS}, - TITLE = {{Programming with broadcasts}}, - VOLUME = {715}, - YEAR = {1993} -} - -@INPROCEEDINGS{puel-suarez90, - AUTHOR = {L.Puel and A. Su\'arez}, - BOOKTITLE = {{Conference Lisp and Functional Programming}}, - SERIES = {ACM}, - PUBLISHER = {Springer-Verlag}, - TITLE = {{Compiling Pattern Matching by Term -Decomposition}}, - YEAR = {1990} -} - -@UNPUBLISHED{Rou92, - AUTHOR = {J. Rouyer}, - MONTH = aug, - NOTE = {To appear as a technical report}, - TITLE = {{D\'eveloppement de l'Algorithme d'Unification dans le Calcul des Constructions}}, - YEAR = {1992} -} - -@TECHREPORT{Saibi94, - AUTHOR = {A. Sa\"{\i}bi}, - INSTITUTION = {INRIA}, - MONTH = dec, - NUMBER = {2345}, - TITLE = {{Axiomatization of a lambda-calculus with explicit-substitutions in the Coq System}}, - YEAR = {1994} -} - -@MASTERSTHESIS{saidi94, - AUTHOR = {H. Saidi}, - MONTH = sep, - SCHOOL = {DEA d'Informatique Fondamentale, Universit\'e Paris 7}, - TITLE = {R\'esolution d'\'equations dans le syst\`eme T - de G\"odel}, - YEAR = {1994} -} - -@MASTERSTHESIS{Ter92, - AUTHOR = {D. Terrasse}, - MONTH = sep, - SCHOOL = {IARFA}, - TITLE = {{Traduction de TYPOL en COQ. Application \`a Mini ML}}, - YEAR = {1992} -} - -@TECHREPORT{ThBeKa92, - AUTHOR = {L. Th\'ery and Y. Bertot and G. Kahn}, - INSTITUTION = {INRIA Sophia}, - MONTH = may, - NUMBER = {1684}, - TITLE = {Real theorem provers deserve real user-interfaces}, - TYPE = {Research Report}, - YEAR = {1992} -} - -@BOOK{TrDa89, - AUTHOR = {A.S. Troelstra and D. van Dalen}, - PUBLISHER = {North-Holland}, - SERIES = {Studies in Logic and the foundations of Mathematics, volumes 121 and 123}, - TITLE = {Constructivism in Mathematics, an introduction}, - YEAR = {1988} -} - -@INCOLLECTION{wadler87, - AUTHOR = {P. Wadler}, - TITLE = {Efficient Compilation of Pattern Matching}, - BOOKTITLE = {The Implementation of Functional Programming -Languages}, - EDITOR = {S.L. Peyton Jones}, - PUBLISHER = {Prentice-Hall}, - YEAR = {1987} -} - -@PHDTHESIS{Wer94, - AUTHOR = {B. Werner}, - SCHOOL = {Universit\'e Paris 7}, - TITLE = {Une th\'eorie des constructions inductives}, - TYPE = {Th\`ese de Doctorat}, - YEAR = {1994} -} - - diff --git a/doc/RecTutorial/morebib.bib b/doc/RecTutorial/morebib.bib deleted file mode 100644 index 438f2133d..000000000 --- a/doc/RecTutorial/morebib.bib +++ /dev/null @@ -1,55 +0,0 @@ -@book{coqart, - title = "Interactive Theorem Proving and Program Development. - Coq'Art: The Calculus of Inductive Constructions", - author = {Yves Bertot and Pierre Castéran}, - publisher = "Springer Verlag", - series = "Texts in Theoretical Computer Science. An EATCS series", - year = 2004 -} - -@Article{Coquand:Huet, - author = {Thierry Coquand and Gérard Huet}, - title = {The Calculus of Constructions}, - journal = {Information and Computation}, - year = {1988}, - volume = {76}, -} - -@INcollection{Coquand:metamathematical, - author = "Thierry Coquand", - title = "Metamathematical Investigations on a Calculus of Constructions", - booktitle="Logic and Computer Science", - year = {1990}, - editor="P. Odifreddi", - publisher = "Academic Press", -} - -@Misc{coqrefman, - title = {The {C}oq reference manual}, - author={{C}oq {D}evelopment Team}, - note= {LogiCal Project, \texttt{http://coq.inria.fr/}} - } - -@Misc{coqsite, - author= {{C}oq {D}evelopment Team}, - title = {The \emph{Coq} proof assistant}, - note = {Documentation, system download. {C}ontact: \texttt{http://coq.inria.fr/}} -} - - - -@Misc{Booksite, - author = {Yves Bertot and Pierre Cast\'eran}, - title = {Coq'{A}rt: examples and exercises}, - note = {\url{http://www.labri.fr/Perso/~casteran/CoqArt}} -} - - -@InProceedings{conor:motive, - author ="Conor McBride", - title = "Elimination with a motive", - booktitle = "Types for Proofs and Programs'2000", - volume = 2277, - pages = "197-217", - year = "2002", -} diff --git a/doc/RecTutorial/recmacros.tex b/doc/RecTutorial/recmacros.tex deleted file mode 100644 index 0334553f2..000000000 --- a/doc/RecTutorial/recmacros.tex +++ /dev/null @@ -1,75 +0,0 @@ -%=================================== -% Style of the document -%=================================== -%\newtheorem{example}{Example}[section] -%\newtheorem{exercise}{Exercise}[section] - - -\newcommand{\comentario}[1]{\texttt{#1}} - -%=================================== -% Keywords -%=================================== - -\newcommand{\Prop}{\texttt{Prop}} -\newcommand{\Set}{\texttt{Set}} -\newcommand{\Type}{\texttt{Type}} -\newcommand{\true}{\texttt{true}} -\newcommand{\false}{\texttt{false}} -\newcommand{\Lth}{\texttt{Lth}} - -\newcommand{\Nat}{\texttt{nat}} -\newcommand{\nat}{\texttt{nat}} -\newcommand{\Z} {\texttt{O}} -\newcommand{\SUCC}{\texttt{S}} -\newcommand{\pred}{\texttt{pred}} - -\newcommand{\False}{\texttt{False}} -\newcommand{\True}{\texttt{True}} -\newcommand{\I}{\texttt{I}} - -\newcommand{\natind}{\texttt{nat\_ind}} -\newcommand{\natrec}{\texttt{nat\_rec}} -\newcommand{\natrect}{\texttt{nat\_rect}} - -\newcommand{\eqT}{\texttt{eqT}} -\newcommand{\identityT}{\texttt{identityT}} - -\newcommand{\map}{\texttt{map}} -\newcommand{\iterates}{\texttt{iterates}} - - -%=================================== -% Numbering -%=================================== - - -\newtheorem{definition}{Definition}[section] -\newtheorem{example}{Example}[section] - - -%=================================== -% Judgements -%=================================== - - -\newcommand{\JM}[2]{\ensuremath{#1 : #2}} - -%=================================== -% Expressions -%=================================== - -\newcommand{\Case}[3][]{\ensuremath{#1\textsf{Case}~#2~\textsf of}~#3~\textsf{end}} - -%======================================= - -\newcommand{\snreglados} [3] {\begin{tabular}{c} \ensuremath{#1} \\[2pt] - \ensuremath{#2}\\ \hline \ensuremath{#3} \end{tabular}} - - -\newcommand{\snregla} [2] {\begin{tabular}{c} - \ensuremath{#1}\\ \hline \ensuremath{#2} \end{tabular}} - - -%======================================= - diff --git a/doc/refman/AddRefMan-pre.tex b/doc/refman/AddRefMan-pre.tex deleted file mode 100644 index 856a823de..000000000 --- a/doc/refman/AddRefMan-pre.tex +++ /dev/null @@ -1,63 +0,0 @@ -%\coverpage{Addendum to the Reference Manual}{\ } -%\addcontentsline{toc}{part}{Additional documentation} -%BEGIN LATEX -\setheaders{Presentation of the Addendum} -%END LATEX -\chapter*{Presentation of the Addendum} -%HEVEA\cutname{addendum.html} - -Here you will find several pieces of additional documentation for the -\Coq\ Reference Manual. Each of this chapters is concentrated on a -particular topic, that should interest only a fraction of the \Coq\ -users: that's the reason why they are apart from the Reference -Manual. - -\begin{description} - -\item[Extended pattern-matching] This chapter details the use of - generalized pattern-matching. It is contributed by Cristina Cornes - and Hugo Herbelin. - -\item[Implicit coercions] This chapter details the use of the coercion - mechanism. It is contributed by Amokrane Saïbi. - -%\item[Proof of imperative programs] This chapter explains how to -% prove properties of annotated programs with imperative features. -% It is contributed by Jean-Christophe Filliâtre - -\item[Program extraction] This chapter explains how to extract in practice ML - files from $\FW$ terms. It is contributed by Jean-Christophe - Filliâtre and Pierre Letouzey. - -\item[Program] This chapter explains the use of the \texttt{Program} - vernacular which allows the development of certified - programs in \Coq. It is contributed by Matthieu Sozeau and replaces - the previous \texttt{Program} tactic by Catherine Parent. - -%\item[Natural] This chapter is due to Yann Coscoy. It is the user -% manual of the tools he wrote for printing proofs in natural -% language. At this time, French and English languages are supported. - -\item[omega] \texttt{omega}, written by Pierre Crégut, solves a whole - class of arithmetic problems. - -\item[The {\tt ring} tactic] This is a tactic to do AC rewriting. This - chapter explains how to use it and how it works. - The chapter is contributed by Patrick Loiseleur. - -\item[The {\tt Setoid\_replace} tactic] This is a - tactic to do rewriting on types equipped with specific (only partially - substitutive) equality. The chapter is contributed by Clément Renard. - -\item[Calling external provers] This chapter describes several tactics - which call external provers. - -\end{description} - -\atableofcontents - - -%%% Local Variables: -%%% mode: latex -%%% TeX-master: "Reference-Manual" -%%% End: diff --git a/doc/refman/RefMan-gal.tex b/doc/refman/RefMan-gal.tex deleted file mode 100644 index 41ea0a5dc..000000000 --- a/doc/refman/RefMan-gal.tex +++ /dev/null @@ -1,1737 +0,0 @@ -\chapter{The \gallina{} specification language -\label{Gallina}\index{Gallina}} -%HEVEA\cutname{gallina.html} -\label{BNF-syntax} % Used referred to as a chapter label - -This chapter describes \gallina, the specification language of {\Coq}. -It allows developing mathematical theories and proofs of specifications -of programs. The theories are built from axioms, hypotheses, -parameters, lemmas, theorems and definitions of constants, functions, -predicates and sets. The syntax of logical objects involved in -theories is described in Section~\ref{term}. The language of -commands, called {\em The Vernacular} is described in section -\ref{Vernacular}. - -In {\Coq}, logical objects are typed to ensure their logical -correctness. The rules implemented by the typing algorithm are described in -Chapter \ref{Cic}. - -\subsection*{About the grammars in the manual -\index{BNF metasyntax}} - -Grammars are presented in Backus-Naur form (BNF). Terminal symbols are -set in {\tt typewriter font}. In addition, there are special -notations for regular expressions. - -An expression enclosed in square brackets \zeroone{\ldots} means at -most one occurrence of this expression (this corresponds to an -optional component). - -The notation ``\nelist{\entry}{sep}'' stands for a non empty -sequence of expressions parsed by {\entry} and -separated by the literal ``{\tt sep}''\footnote{This is similar to the -expression ``{\entry} $\{$ {\tt sep} {\entry} $\}$'' in -standard BNF, or ``{\entry}~{$($} {\tt sep} {\entry} {$)$*}'' in -the syntax of regular expressions.}. - -Similarly, the notation ``\nelist{\entry}{}'' stands for a non -empty sequence of expressions parsed by the ``{\entry}'' entry, -without any separator between. - -Finally, the notation ``\sequence{\entry}{\tt sep}'' stands for a -possibly empty sequence of expressions parsed by the ``{\entry}'' entry, -separated by the literal ``{\tt sep}''. - -\section{Lexical conventions -\label{lexical}\index{Lexical conventions}} - -\paragraph{Blanks} -Space, newline and horizontal tabulation are considered as blanks. -Blanks are ignored but they separate tokens. - -\paragraph{Comments} - -Comments in {\Coq} are enclosed between {\tt (*} and {\tt - *)}\index{Comments}, and can be nested. They can contain any -character. However, string literals must be correctly closed. Comments -are treated as blanks. - -\paragraph{Identifiers and access identifiers} - -Identifiers, written {\ident}, are sequences of letters, digits, -\verb!_! and \verb!'!, that do not start with a digit or \verb!'!. -That is, they are recognized by the following lexical class: - -\index{ident@\ident} -\begin{center} -\begin{tabular}{rcl} -{\firstletter} & ::= & {\tt a..z} $\mid$ {\tt A..Z} $\mid$ {\tt \_} -$\mid$ {\tt unicode-letter} -\\ -{\subsequentletter} & ::= & {\tt a..z} $\mid$ {\tt A..Z} $\mid$ {\tt 0..9} -$\mid$ {\tt \_} % $\mid$ {\tt \$} -$\mid$ {\tt '} -$\mid$ {\tt unicode-letter} -$\mid$ {\tt unicode-id-part} \\ -{\ident} & ::= & {\firstletter} \sequencewithoutblank{\subsequentletter}{} -\end{tabular} -\end{center} -All characters are meaningful. In particular, identifiers are -case-sensitive. The entry {\tt unicode-letter} non-exhaustively -includes Latin, Greek, Gothic, Cyrillic, Arabic, Hebrew, Georgian, -Hangul, Hiragana and Katakana characters, CJK ideographs, mathematical -letter-like symbols, hyphens, non-breaking space, {\ldots} The entry -{\tt unicode-id-part} non-exhaustively includes symbols for prime -letters and subscripts. - -Access identifiers, written {\accessident}, are identifiers prefixed -by \verb!.! (dot) without blank. They are used in the syntax of qualified -identifiers. - -\paragraph{Natural numbers and integers} -Numerals are sequences of digits. Integers are numerals optionally preceded by a minus sign. - -\index{num@{\num}} -\index{integer@{\integer}} -\begin{center} -\begin{tabular}{r@{\quad::=\quad}l} -{\digit} & {\tt 0..9} \\ -{\num} & \nelistwithoutblank{\digit}{} \\ -{\integer} & \zeroone{\tt -}{\num} \\ -\end{tabular} -\end{center} - -\paragraph[Strings]{Strings\label{strings} -\index{string@{\qstring}}} -Strings are delimited by \verb!"! (double quote), and enclose a -sequence of any characters different from \verb!"! or the sequence -\verb!""! to denote the double quote character. In grammars, the -entry for quoted strings is {\qstring}. - -\paragraph{Keywords} -The following identifiers are reserved keywords, and cannot be -employed otherwise: -\begin{center} -\begin{tabular}{llllll} -\verb!_! & -\verb!as! & -\verb!at! & -\verb!cofix! & -\verb!else! & -\verb!end! \\ -% -\verb!exists! & -\verb!exists2! & -\verb!fix! & -\verb!for! & -\verb!forall! & -\verb!fun! \\ -% -\verb!if! & -\verb!IF! & -\verb!in! & -\verb!let! & -\verb!match! & -\verb!mod! \\ -% -\verb!Prop! & -\verb!return! & -\verb!Set! & -\verb!then! & -\verb!Type! & -\verb!using! \\ -% -\verb!where! & -\verb!with! & -\end{tabular} -\end{center} - - -\paragraph{Special tokens} -The following sequences of characters are special tokens: -\begin{center} -\begin{tabular}{lllllll} -\verb/!/ & -\verb!%! & -\verb!&! & -\verb!&&! & -\verb!(! & -\verb!()! & -\verb!)! \\ -% -\verb!*! & -\verb!+! & -\verb!++! & -\verb!,! & -\verb!-! & -\verb!->! & -\verb!.! \\ -% -\verb!.(! & -\verb!..! & -\verb!/! & -\verb!/\! & -\verb!:! & -\verb!::! & -\verb!:<! \\ -% -\verb!:=! & -\verb!:>! & -\verb!;! & -\verb!<! & -\verb!<-! & -\verb!<->! & -\verb!<:! \\ -% -\verb!<=! & -\verb!<>! & -\verb!=! & -\verb!=>! & -\verb!=_D! & -\verb!>! & -\verb!>->! \\ -% -\verb!>=! & -\verb!?! & -\verb!?=! & -\verb!@! & -\verb![! & -\verb!\/! & -\verb!]! \\ -% -\verb!^! & -\verb!{! & -\verb!|! & -\verb!|-! & -\verb!||! & -\verb!}! & -\verb!~! \\ -\end{tabular} -\end{center} - -Lexical ambiguities are resolved according to the ``longest match'' -rule: when a sequence of non alphanumerical characters can be decomposed -into several different ways, then the first token is the longest -possible one (among all tokens defined at this moment), and so on. - -\section{Terms \label{term}\index{Terms}} - -\subsection{Syntax of terms} - -Figures \ref{term-syntax} and \ref{term-syntax-aux} describe the basic syntax of -the terms of the {\em Calculus of Inductive Constructions} (also -called \CIC). The formal presentation of {\CIC} is given in Chapter -\ref{Cic}. Extensions of this syntax are given in chapter -\ref{Gallina-extension}. How to customize the syntax is described in Chapter -\ref{Addoc-syntax}. - -\begin{figure}[htbp] -\begin{centerframe} -\begin{tabular}{lcl@{\quad~}r} % warning: page width exceeded with \qquad -{\term} & ::= & - {\tt forall} {\binders} {\tt ,} {\term} &(\ref{products})\\ - & $|$ & {\tt fun} {\binders} {\tt =>} {\term} &(\ref{abstractions})\\ - & $|$ & {\tt fix} {\fixpointbodies} &(\ref{fixpoints})\\ - & $|$ & {\tt cofix} {\cofixpointbodies} &(\ref{fixpoints})\\ - & $|$ & {\tt let} {\ident} \zeroone{\binders} {\typecstr} {\tt :=} {\term} - {\tt in} {\term} &(\ref{let-in})\\ - & $|$ & {\tt let fix} {\fixpointbody} {\tt in} {\term} &(\ref{fixpoints})\\ - & $|$ & {\tt let cofix} {\cofixpointbody} - {\tt in} {\term} &(\ref{fixpoints})\\ - & $|$ & {\tt let} {\tt (} \sequence{\name}{,} {\tt )} \zeroone{\ifitem} - {\tt :=} {\term} - {\tt in} {\term} &(\ref{caseanalysis}, \ref{Mult-match})\\ - & $|$ & {\tt let '} {\pattern} \zeroone{{\tt in} {\term}} {\tt :=} {\term} - \zeroone{\returntype} {\tt in} {\term} & (\ref{caseanalysis}, \ref{Mult-match})\\ - & $|$ & {\tt if} {\term} \zeroone{\ifitem} {\tt then} {\term} - {\tt else} {\term} &(\ref{caseanalysis}, \ref{Mult-match})\\ - & $|$ & {\term} {\tt :} {\term} &(\ref{typecast})\\ - & $|$ & {\term} {\tt <:} {\term} &(\ref{typecast})\\ - & $|$ & {\term} {\tt :>} &(\ref{ProgramSyntax})\\ - & $|$ & {\term} {\tt ->} {\term} &(\ref{products})\\ - & $|$ & {\term} \nelist{\termarg}{}&(\ref{applications})\\ - & $|$ & {\tt @} {\qualid} \sequence{\term}{} - &(\ref{Implicits-explicitation})\\ - & $|$ & {\term} {\tt \%} {\ident} &(\ref{scopechange})\\ - & $|$ & {\tt match} \nelist{\caseitem}{\tt ,} - \zeroone{\returntype} {\tt with} &\\ - && ~~~\zeroone{\zeroone{\tt |} \nelist{\eqn}{|}} {\tt end} - &(\ref{caseanalysis})\\ - & $|$ & {\qualid} &(\ref{qualid})\\ - & $|$ & {\sort} &(\ref{Gallina-sorts})\\ - & $|$ & {\num} &(\ref{numerals})\\ - & $|$ & {\_} &(\ref{hole})\\ - & $|$ & {\tt (} {\term} {\tt )} & \\ - & & &\\ -{\termarg} & ::= & {\term} &\\ - & $|$ & {\tt (} {\ident} {\tt :=} {\term} {\tt )} - &(\ref{Implicits-explicitation})\\ -%% & $|$ & {\tt (} {\num} {\tt :=} {\term} {\tt )} -%% &(\ref{Implicits-explicitation})\\ -&&&\\ -{\binders} & ::= & \nelist{\binder}{} \\ -&&&\\ -{\binder} & ::= & {\name} & (\ref{Binders}) \\ - & $|$ & {\tt (} \nelist{\name}{} {\tt :} {\term} {\tt )} &\\ - & $|$ & {\tt (} {\name} {\typecstr} {\tt :=} {\term} {\tt )} &\\ - & $|$ & {\tt '} {\pattern} &\\ -& & &\\ -{\name} & ::= & {\ident} &\\ - & $|$ & {\tt \_} &\\ -&&&\\ -{\qualid} & ::= & {\ident} & \\ - & $|$ & {\qualid} {\accessident} &\\ - & & &\\ -{\sort} & ::= & {\tt Prop} ~$|$~ {\tt Set} ~$|$~ {\tt Type} & -\end{tabular} -\end{centerframe} -\caption{Syntax of terms} -\label{term-syntax} -\index{term@{\term}} -\index{sort@{\sort}} -\end{figure} - - - -\begin{figure}[htb] -\begin{centerframe} -\begin{tabular}{lcl} -{\fixpointbodies} & ::= & - {\fixpointbody} \\ - & $|$ & {\fixpointbody} {\tt with} \nelist{\fixpointbody}{{\tt with}} - {\tt for} {\ident} \\ -{\cofixpointbodies} & ::= & - {\cofixpointbody} \\ - & $|$ & {\cofixpointbody} {\tt with} \nelist{\cofixpointbody}{{\tt with}} - {\tt for} {\ident} \\ -&&\\ -{\fixpointbody} & ::= & - {\ident} {\binders} \zeroone{\annotation} {\typecstr} - {\tt :=} {\term} \\ -{\cofixpointbody} & ::= & {\ident} \zeroone{\binders} {\typecstr} {\tt :=} {\term} \\ - & &\\ -{\annotation} & ::= & {\tt \{ struct} {\ident} {\tt \}} \\ -&&\\ -{\caseitem} & ::= & {\term} \zeroone{{\tt as} \name} - \zeroone{{\tt in} \qualid \sequence{\pattern}{}} \\ -&&\\ -{\ifitem} & ::= & \zeroone{{\tt as} {\name}} {\returntype} \\ -&&\\ -{\returntype} & ::= & {\tt return} {\term} \\ -&&\\ -{\eqn} & ::= & \nelist{\multpattern}{\tt |} {\tt =>} {\term}\\ -&&\\ -{\multpattern} & ::= & \nelist{\pattern}{\tt ,}\\ -&&\\ -{\pattern} & ::= & {\qualid} \nelist{\pattern}{} \\ - & $|$ & {\tt @} {\qualid} \nelist{\pattern}{} \\ - - & $|$ & {\pattern} {\tt as} {\ident} \\ - & $|$ & {\pattern} {\tt \%} {\ident} \\ - & $|$ & {\qualid} \\ - & $|$ & {\tt \_} \\ - & $|$ & {\num} \\ - & $|$ & {\tt (} \nelist{\orpattern}{,} {\tt )} \\ -\\ -{\orpattern} & ::= & \nelist{\pattern}{\tt |}\\ -\end{tabular} -\end{centerframe} -\caption{Syntax of terms (continued)} -\label{term-syntax-aux} -\end{figure} - - -%%%%%%% - -\subsection{Types} - -{\Coq} terms are typed. {\Coq} types are recognized by the same -syntactic class as {\term}. We denote by {\type} the semantic subclass -of types inside the syntactic class {\term}. -\index{type@{\type}} - - -\subsection{Qualified identifiers and simple identifiers -\label{qualid} -\label{ident}} - -{\em Qualified identifiers} ({\qualid}) denote {\em global constants} -(definitions, lemmas, theorems, remarks or facts), {\em global -variables} (parameters or axioms), {\em inductive -types} or {\em constructors of inductive types}. -{\em Simple identifiers} (or shortly {\ident}) are a -syntactic subset of qualified identifiers. Identifiers may also -denote local {\em variables}, what qualified identifiers do not. - -\subsection{Numerals -\label{numerals}} - -Numerals have no definite semantics in the calculus. They are mere -notations that can be bound to objects through the notation mechanism -(see Chapter~\ref{Addoc-syntax} for details). Initially, numerals are -bound to Peano's representation of natural numbers -(see~\ref{libnats}). - -Note: negative integers are not at the same level as {\num}, for this -would make precedence unnatural. - -\subsection{Sorts -\index{Sorts} -\index{Type@{\Type}} -\index{Set@{\Set}} -\index{Prop@{\Prop}} -\index{Sorts} -\label{Gallina-sorts}} - -There are three sorts \Set, \Prop\ and \Type. -\begin{itemize} -\item \Prop\ is the universe of {\em logical propositions}. -The logical propositions themselves are typing the proofs. -We denote propositions by {\form}. This constitutes a semantic -subclass of the syntactic class {\term}. -\index{form@{\form}} -\item \Set\ is is the universe of {\em program -types} or {\em specifications}. -The specifications themselves are typing the programs. -We denote specifications by {\specif}. This constitutes a semantic -subclass of the syntactic class {\term}. -\index{specif@{\specif}} -\item {\Type} is the type of {\Set} and {\Prop} -\end{itemize} -\noindent More on sorts can be found in Section~\ref{Sorts}. - -\subsection{Binders -\label{Binders} -\index{binders}} - -Various constructions such as {\tt fun}, {\tt forall}, {\tt fix} and -{\tt cofix} {\em bind} variables. A binding is represented by an -identifier. If the binding variable is not used in the expression, the -identifier can be replaced by the symbol {\tt \_}. When the type of a -bound variable cannot be synthesized by the system, it can be -specified with the notation {\tt (}\,{\ident}\,{\tt :}\,{\type}\,{\tt -)}. There is also a notation for a sequence of binding variables -sharing the same type: {\tt (}\,{\ident$_1$}\ldots{\ident$_n$}\,{\tt -:}\,{\type}\,{\tt )}. A binder can also be any pattern prefixed by a quote, -e.g. {\tt '(x,y)}. - -Some constructions allow the binding of a variable to value. This is -called a ``let-binder''. The entry {\binder} of the grammar accepts -either an assumption binder as defined above or a let-binder. -The notation in the -latter case is {\tt (}\,{\ident}\,{\tt :=}\,{\term}\,{\tt )}. In a -let-binder, only one variable can be introduced at the same -time. It is also possible to give the type of the variable as follows: -{\tt (}\,{\ident}\,{\tt :}\,{\term}\,{\tt :=}\,{\term}\,{\tt )}. - -Lists of {\binder} are allowed. In the case of {\tt fun} and {\tt - forall}, it is intended that at least one binder of the list is an -assumption otherwise {\tt fun} and {\tt forall} gets identical. Moreover, -parentheses can be omitted in the case of a single sequence of -bindings sharing the same type (e.g.: {\tt fun~(x~y~z~:~A)~=>~t} can -be shortened in {\tt fun~x~y~z~:~A~=>~t}). - -\subsection{Abstractions -\label{abstractions} -\index{abstractions}} -\index{fun@{{\tt fun \ldots => \ldots}}} - -The expression ``{\tt fun} {\ident} {\tt :} {\type} {\tt =>}~{\term}'' -defines the {\em abstraction} of the variable {\ident}, of type -{\type}, over the term {\term}. It denotes a function of the variable -{\ident} that evaluates to the expression {\term} (e.g. {\tt fun x:$A$ -=> x} denotes the identity function on type $A$). -% The variable {\ident} is called the {\em parameter} of the function -% (we sometimes say the {\em formal parameter}). -The keyword {\tt fun} can be followed by several binders as given in -Section~\ref{Binders}. Functions over several variables are -equivalent to an iteration of one-variable functions. For instance the -expression ``{\tt fun}~{\ident$_{1}$}~{\ldots}~{\ident$_{n}$}~{\tt -:}~\type~{\tt =>}~{\term}'' denotes the same function as ``{\tt -fun}~{\ident$_{1}$}~{\tt :}~\type~{\tt =>}~{\ldots}~{\tt -fun}~{\ident$_{n}$}~{\tt :}~\type~{\tt =>}~{\term}''. If a let-binder -occurs in the list of binders, it is expanded to a let-in definition -(see Section~\ref{let-in}). - -\subsection{Products -\label{products} -\index{products}} -\index{forall@{{\tt forall \ldots, \ldots}}} - -The expression ``{\tt forall}~{\ident}~{\tt :}~{\type}{\tt -,}~{\term}'' denotes the {\em product} of the variable {\ident} of -type {\type}, over the term {\term}. As for abstractions, {\tt forall} -is followed by a binder list, and products over several variables are -equivalent to an iteration of one-variable products. -Note that {\term} is intended to be a type. - -If the variable {\ident} occurs in {\term}, the product is called {\em -dependent product}. The intention behind a dependent product {\tt -forall}~$x$~{\tt :}~{$A$}{\tt ,}~{$B$} is twofold. It denotes either -the universal quantification of the variable $x$ of type $A$ in the -proposition $B$ or the functional dependent product from $A$ to $B$ (a -construction usually written $\Pi_{x:A}.B$ in set theory). - -Non dependent product types have a special notation: ``$A$ {\tt ->} -$B$'' stands for ``{\tt forall \_:}$A${\tt ,}~$B$''. The {\em non dependent -product} is used both to denote the propositional implication and -function types. - -\subsection{Applications -\label{applications} -\index{applications}} - -The expression \term$_0$ \term$_1$ denotes the application of -\term$_0$ to \term$_1$. - -The expression {\tt }\term$_0$ \term$_1$ ... \term$_n${\tt} -denotes the application of the term \term$_0$ to the arguments -\term$_1$ ... then \term$_n$. It is equivalent to {\tt (} {\ldots} -{\tt (} {\term$_0$} {\term$_1$} {\tt )} {\ldots} {\tt )} {\term$_n$} {\tt }: -associativity is to the left. - -The notation {\tt (}\,{\ident}\,{\tt :=}\,{\term}\,{\tt )} for -arguments is used for making explicit the value of implicit arguments -(see Section~\ref{Implicits-explicitation}). - -\subsection{Type cast -\label{typecast} -\index{Cast}} -\index{cast@{{\tt(\ldots: \ldots)}}} - -The expression ``{\term}~{\tt :}~{\type}'' is a type cast -expression. It enforces the type of {\term} to be {\type}. - -``{\term}~{\tt <:}~{\type}'' locally sets up the virtual machine for checking -that {\term} has type {\type}. - -\subsection{Inferable subterms -\label{hole} -\index{\_}} - -Expressions often contain redundant pieces of information. Subterms that -can be automatically inferred by {\Coq} can be replaced by the -symbol ``\_'' and {\Coq} will guess the missing piece of information. - -\subsection{Let-in definitions -\label{let-in} -\index{Let-in definitions} -\index{let-in}} -\index{let@{{\tt let \ldots := \ldots in \ldots}}} - - -{\tt let}~{\ident}~{\tt :=}~{\term$_1$}~{\tt in}~{\term$_2$} denotes -the local binding of \term$_1$ to the variable $\ident$ in -\term$_2$. -There is a syntactic sugar for let-in definition of functions: {\tt -let} {\ident} {\binder$_1$} {\ldots} {\binder$_n$} {\tt :=} {\term$_1$} -{\tt in} {\term$_2$} stands for {\tt let} {\ident} {\tt := fun} -{\binder$_1$} {\ldots} {\binder$_n$} {\tt =>} {\term$_1$} {\tt in} -{\term$_2$}. - -\subsection{Definition by case analysis -\label{caseanalysis} -\index{match@{\tt match\ldots with\ldots end}}} - -Objects of inductive types can be destructurated by a case-analysis -construction called {\em pattern-matching} expression. A -pattern-matching expression is used to analyze the structure of an -inductive objects and to apply specific treatments accordingly. - -This paragraph describes the basic form of pattern-matching. See -Section~\ref{Mult-match} and Chapter~\ref{Mult-match-full} for the -description of the general form. The basic form of pattern-matching is -characterized by a single {\caseitem} expression, a {\multpattern} -restricted to a single {\pattern} and {\pattern} restricted to the -form {\qualid} \nelist{\ident}{}. - -The expression {\tt match} {\term$_0$} {\returntype} {\tt with} -{\pattern$_1$} {\tt =>} {\term$_1$} {\tt $|$} {\ldots} {\tt $|$} -{\pattern$_n$} {\tt =>} {\term$_n$} {\tt end}, denotes a {\em -pattern-matching} over the term {\term$_0$} (expected to be of an -inductive type $I$). The terms {\term$_1$}\ldots{\term$_n$} are the -{\em branches} of the pattern-matching expression. Each of -{\pattern$_i$} has a form \qualid~\nelist{\ident}{} where {\qualid} -must denote a constructor. There should be exactly one branch for -every constructor of $I$. - -The {\returntype} expresses the type returned by the whole {\tt match} -expression. There are several cases. In the {\em non dependent} case, -all branches have the same type, and the {\returntype} is the common -type of branches. In this case, {\returntype} can usually be omitted -as it can be inferred from the type of the branches\footnote{Except if -the inductive type is empty in which case there is no equation that can be -used to infer the return type.}. - -In the {\em dependent} case, there are three subcases. In the first -subcase, the type in each branch may depend on the exact value being -matched in the branch. In this case, the whole pattern-matching itself -depends on the term being matched. This dependency of the term being -matched in the return type is expressed with an ``{\tt as {\ident}}'' -clause where {\ident} is dependent in the return type. -For instance, in the following example: -\begin{coq_example*} -Inductive bool : Type := true : bool | false : bool. -Inductive eq (A:Type) (x:A) : A -> Prop := eq_refl : eq A x x. -Inductive or (A:Prop) (B:Prop) : Prop := -| or_introl : A -> or A B -| or_intror : B -> or A B. -Definition bool_case (b:bool) : or (eq bool b true) (eq bool b false) -:= match b as x return or (eq bool x true) (eq bool x false) with - | true => or_introl (eq bool true true) (eq bool true false) - (eq_refl bool true) - | false => or_intror (eq bool false true) (eq bool false false) - (eq_refl bool false) - end. -\end{coq_example*} -the branches have respective types {\tt or (eq bool true true) (eq -bool true false)} and {\tt or (eq bool false true) (eq bool false -false)} while the whole pattern-matching expression has type {\tt or -(eq bool b true) (eq bool b false)}, the identifier {\tt x} being used -to represent the dependency. Remark that when the term being matched -is a variable, the {\tt as} clause can be omitted and the term being -matched can serve itself as binding name in the return type. For -instance, the following alternative definition is accepted and has the -same meaning as the previous one. -\begin{coq_eval} -Reset bool_case. -\end{coq_eval} -\begin{coq_example*} -Definition bool_case (b:bool) : or (eq bool b true) (eq bool b false) -:= match b return or (eq bool b true) (eq bool b false) with - | true => or_introl (eq bool true true) (eq bool true false) - (eq_refl bool true) - | false => or_intror (eq bool false true) (eq bool false false) - (eq_refl bool false) - end. -\end{coq_example*} - -The second subcase is only relevant for annotated inductive types such -as the equality predicate (see Section~\ref{Equality}), the order -predicate on natural numbers % (see Section~\ref{le}) % undefined reference -or the type of -lists of a given length (see Section~\ref{listn}). In this configuration, -the type of each branch can depend on the type dependencies specific -to the branch and the whole pattern-matching expression has a type -determined by the specific dependencies in the type of the term being -matched. This dependency of the return type in the annotations of the -inductive type is expressed using a - ``in~I~\_~$\ldots$~\_~\pattern$_1$~$\ldots$~\pattern$_n$'' clause, where -\begin{itemize} -\item $I$ is the inductive type of the term being matched; - -\item the {\_}'s are matching the parameters of the inductive type: -the return type is not dependent on them. - -\item the \pattern$_i$'s are matching the annotations of the inductive - type: the return type is dependent on them - -\item in the basic case which we describe below, each \pattern$_i$ is a - name \ident$_i$; see \ref{match-in-patterns} for the general case - -\end{itemize} - -For instance, in the following example: -\begin{coq_example*} -Definition eq_sym (A:Type) (x y:A) (H:eq A x y) : eq A y x := - match H in eq _ _ z return eq A z x with - | eq_refl _ _ => eq_refl A x - end. -\end{coq_example*} -the type of the branch has type {\tt eq~A~x~x} because the third -argument of {\tt eq} is {\tt x} in the type of the pattern {\tt -refl\_equal}. On the contrary, the type of the whole pattern-matching -expression has type {\tt eq~A~y~x} because the third argument of {\tt -eq} is {\tt y} in the type of {\tt H}. This dependency of the case -analysis in the third argument of {\tt eq} is expressed by the -identifier {\tt z} in the return type. - -Finally, the third subcase is a combination of the first and second -subcase. In particular, it only applies to pattern-matching on terms -in a type with annotations. For this third subcase, both -the clauses {\tt as} and {\tt in} are available. - -There are specific notations for case analysis on types with one or -two constructors: ``{\tt if {\ldots} then {\ldots} else {\ldots}}'' -and ``{\tt let (}\nelist{\ldots}{,}{\tt ) := } {\ldots} {\tt in} -{\ldots}'' (see Sections~\ref{if-then-else} and~\ref{Letin}). - -%\SeeAlso Section~\ref{Mult-match} for convenient extensions of pattern-matching. - -\subsection{Recursive functions -\label{fixpoints} -\index{fix@{fix \ident$_i$\{\dots\}}}} - -The expression ``{\tt fix} \ident$_1$ \binder$_1$ {\tt :} {\type$_1$} -\texttt{:=} \term$_1$ {\tt with} {\ldots} {\tt with} \ident$_n$ -\binder$_n$~{\tt :} {\type$_n$} \texttt{:=} \term$_n$ {\tt for} -{\ident$_i$}'' denotes the $i$\nth component of a block of functions -defined by mutual well-founded recursion. It is the local counterpart -of the {\tt Fixpoint} command. See Section~\ref{Fixpoint} for more -details. When $n=1$, the ``{\tt for}~{\ident$_i$}'' clause is omitted. - -The expression ``{\tt cofix} \ident$_1$~\binder$_1$ {\tt :} -{\type$_1$} {\tt with} {\ldots} {\tt with} \ident$_n$ \binder$_n$ {\tt -:} {\type$_n$}~{\tt for} {\ident$_i$}'' denotes the $i$\nth component of -a block of terms defined by a mutual guarded co-recursion. It is the -local counterpart of the {\tt CoFixpoint} command. See -Section~\ref{CoFixpoint} for more details. When $n=1$, the ``{\tt -for}~{\ident$_i$}'' clause is omitted. - -The association of a single fixpoint and a local -definition have a special syntax: ``{\tt let fix}~$f$~{\ldots}~{\tt - :=}~{\ldots}~{\tt in}~{\ldots}'' stands for ``{\tt let}~$f$~{\tt := - fix}~$f$~\ldots~{\tt :=}~{\ldots}~{\tt in}~{\ldots}''. The same - applies for co-fixpoints. - - -\section{The Vernacular -\label{Vernacular}} - -\begin{figure}[tbp] -\begin{centerframe} -\begin{tabular}{lcl} -{\sentence} & ::= & {\assumption} \\ - & $|$ & {\definition} \\ - & $|$ & {\inductive} \\ - & $|$ & {\fixpoint} \\ - & $|$ & {\assertion} {\proof} \\ -&&\\ -%% Assumptions -{\assumption} & ::= & {\assumptionkeyword} {\assums} {\tt .} \\ -&&\\ -{\assumptionkeyword} & $\!\!$ ::= & {\tt Axiom} $|$ {\tt Conjecture} \\ - & $|$ & {\tt Parameter} $|$ {\tt Parameters} \\ - & $|$ & {\tt Variable} $|$ {\tt Variables} \\ - & $|$ & {\tt Hypothesis} $|$ {\tt Hypotheses}\\ -&&\\ -{\assums} & ::= & \nelist{\ident}{} {\tt :} {\term} \\ - & $|$ & \nelist{{\tt (} \nelist{\ident}{} {\tt :} {\term} {\tt )}}{} \\ -&&\\ -%% Definitions -{\definition} & ::= & - \zeroone{\tt Local} {\tt Definition} {\ident} \zeroone{\binders} {\typecstr} {\tt :=} {\term} {\tt .} \\ - & $|$ & {\tt Let} {\ident} \zeroone{\binders} {\typecstr} {\tt :=} {\term} {\tt .} \\ -&&\\ -%% Inductives -{\inductive} & ::= & - {\tt Inductive} \nelist{\inductivebody}{with} {\tt .} \\ - & $|$ & {\tt CoInductive} \nelist{\inductivebody}{with} {\tt .} \\ - & & \\ -{\inductivebody} & ::= & - {\ident} \zeroone{\binders} {\typecstr} {\tt :=} \\ - && ~~\zeroone{\zeroone{\tt |} \nelist{$\!${\ident}$\!$ \zeroone{\binders} {\typecstr}}{|}} \\ - & & \\ %% TODO: where ... -%% Fixpoints -{\fixpoint} & ::= & {\tt Fixpoint} \nelist{\fixpointbody}{with} {\tt .} \\ - & $|$ & {\tt CoFixpoint} \nelist{\cofixpointbody}{with} {\tt .} \\ -&&\\ -%% Lemmas & proofs -{\assertion} & ::= & - {\statkwd} {\ident} \zeroone{\binders} {\tt :} {\term} {\tt .} \\ -&&\\ - {\statkwd} & ::= & {\tt Theorem} $|$ {\tt Lemma} \\ - & $|$ & {\tt Remark} $|$ {\tt Fact}\\ - & $|$ & {\tt Corollary} $|$ {\tt Proposition} \\ - & $|$ & {\tt Definition} $|$ {\tt Example} \\\\ -&&\\ -{\proof} & ::= & {\tt Proof} {\tt .} {\dots} {\tt Qed} {\tt .}\\ - & $|$ & {\tt Proof} {\tt .} {\dots} {\tt Defined} {\tt .}\\ - & $|$ & {\tt Proof} {\tt .} {\dots} {\tt Admitted} {\tt .}\\ -\end{tabular} -\end{centerframe} -\caption{Syntax of sentences} -\label{sentences-syntax} -\end{figure} - -Figure \ref{sentences-syntax} describes {\em The Vernacular} which is the -language of commands of \gallina. A sentence of the vernacular -language, like in many natural languages, begins with a capital letter -and ends with a dot. - -The different kinds of command are described hereafter. They all suppose -that the terms occurring in the sentences are well-typed. - -%% -%% Axioms and Parameters -%% -\subsection{Assumptions -\index{Declarations} -\label{Declarations}} - -Assumptions extend the environment\index{Environment} with axioms, -parameters, hypotheses or variables. An assumption binds an {\ident} -to a {\type}. It is accepted by {\Coq} if and only if this {\type} is -a correct type in the environment preexisting the declaration and if -{\ident} was not previously defined in the same module. This {\type} -is considered to be the type (or specification, or statement) assumed -by {\ident} and we say that {\ident} has type {\type}. - -\subsubsection{{\tt Axiom {\ident} :{\term} .} -\comindex{Axiom} -\label{Axiom}} - -This command links {\term} to the name {\ident} as its specification -in the global context. The fact asserted by {\term} is thus assumed as -a postulate. - -\begin{ErrMsgs} -\item \errindex{{\ident} already exists} -\end{ErrMsgs} - -\begin{Variants} -\item \comindex{Parameter}\comindex{Parameters} - {\tt Parameter {\ident} :{\term}.} \\ - Is equivalent to {\tt Axiom {\ident} : {\term}} - -\item {\tt Parameter {\ident$_1$} {\ldots} {\ident$_n$} {\tt :}{\term}.}\\ - Adds $n$ parameters with specification {\term} - -\item - {\tt Parameter\,% -(\,{\ident$_{1,1}$} {\ldots} {\ident$_{1,k_1}$}\,{\tt :}\,{\term$_1$} {\tt )}\;% -\ldots\;{\tt (}\,{\ident$_{n,1}$}{\ldots}{\ident$_{n,k_n}$}\,{\tt :}\,% -{\term$_n$} {\tt )}.}\\ - Adds $n$ blocks of parameters with different specifications. - -\item {\tt Local Axiom {\ident} : {\term}.}\\ -\comindex{Local Axiom} - Such axioms are never made accessible through their unqualified name by - {\tt Import} and its variants (see \ref{Import}). You have to explicitly - give their fully qualified name to refer to them. - -\item \comindex{Conjecture} - {\tt Conjecture {\ident} :{\term}.}\\ - Is equivalent to {\tt Axiom {\ident} : {\term}}. -\end{Variants} - -\noindent {\bf Remark: } It is possible to replace {\tt Parameter} by -{\tt Parameters}. - - -\subsubsection{{\tt Variable {\ident} :{\term}}. -\comindex{Variable} -\comindex{Variables} -\label{Variable}} - -This command links {\term} to the name {\ident} in the context of the -current section (see Section~\ref{Section} for a description of the section -mechanism). When the current section is closed, name {\ident} will be -unknown and every object using this variable will be explicitly -parametrized (the variable is {\em discharged}). Using the {\tt -Variable} command out of any section is equivalent to using {\tt -Local Parameter}. - -\begin{ErrMsgs} -\item \errindex{{\ident} already exists} -\end{ErrMsgs} - -\begin{Variants} -\item {\tt Variable {\ident$_1$} {\ldots} {\ident$_n$} {\tt :}{\term}.}\\ - Links {\term} to names {\ident$_1$} {\ldots} {\ident$_n$}. -\item - {\tt Variable\,% -(\,{\ident$_{1,1}$} {\ldots} {\ident$_{1,k_1}$}\,{\tt :}\,{\term$_1$} {\tt )}\;% -\ldots\;{\tt (}\,{\ident$_{n,1}$} {\ldots}{\ident$_{n,k_n}$}\,{\tt :}\,% -{\term$_n$} {\tt )}.}\\ - Adds $n$ blocks of variables with different specifications. -\item \comindex{Hypothesis} - \comindex{Hypotheses} - {\tt Hypothesis {\ident} {\tt :}{\term}.} \\ - \texttt{Hypothesis} is a synonymous of \texttt{Variable} -\end{Variants} - -\noindent {\bf Remark: } It is possible to replace {\tt Variable} by -{\tt Variables} and {\tt Hypothesis} by {\tt Hypotheses}. - -It is advised to use the keywords \verb:Axiom: and \verb:Hypothesis: -for logical postulates (i.e. when the assertion {\term} is of sort -\verb:Prop:), and to use the keywords \verb:Parameter: and -\verb:Variable: in other cases (corresponding to the declaration of an -abstract mathematical entity). - -%% -%% Definitions -%% -\subsection{Definitions -\index{Definitions} -\label{Basic-definitions}} - -Definitions extend the environment\index{Environment} with -associations of names to terms. A definition can be seen as a way to -give a meaning to a name or as a way to abbreviate a term. In any -case, the name can later be replaced at any time by its definition. - -The operation of unfolding a name into its definition is called -$\delta$-conversion\index{delta-reduction@$\delta$-reduction} (see -Section~\ref{delta}). A definition is accepted by the system if and -only if the defined term is well-typed in the current context of the -definition and if the name is not already used. The name defined by -the definition is called a {\em constant}\index{Constant} and the term -it refers to is its {\em body}. A definition has a type which is the -type of its body. - -A formal presentation of constants and environments is given in -Section~\ref{Typed-terms}. - -\subsubsection{\tt Definition {\ident} := {\term}. -\label{Definition} -\comindex{Definition}} - -This command binds {\term} to the name {\ident} in the -environment, provided that {\term} is well-typed. - -\begin{ErrMsgs} -\item \errindex{{\ident} already exists} -\end{ErrMsgs} - -\begin{Variants} -\item {\tt Definition} {\ident} {\tt :} {\term$_1$} {\tt :=} {\term$_2$}{\tt .}\\ - It checks that the type of {\term$_2$} is definitionally equal to - {\term$_1$}, and registers {\ident} as being of type {\term$_1$}, - and bound to value {\term$_2$}. -\item {\tt Definition} {\ident} {\binder$_1$} {\ldots} {\binder$_n$} - {\tt :} \term$_1$ {\tt :=} {\term$_2$}{\tt .}\\ - This is equivalent to \\ - {\tt Definition} {\ident} {\tt : forall}% - {\binder$_1$} {\ldots} {\binder$_n$}{\tt ,}\,\term$_1$\,{\tt :=}\,% - {\tt fun}\,{\binder$_1$} {\ldots} {\binder$_n$}\,{\tt =>}\,{\term$_2$}\,% - {\tt .} - -\item {\tt Local Definition {\ident} := {\term}.}\\ -\comindex{Local Definition} - Such definitions are never made accessible through their unqualified name by - {\tt Import} and its variants (see \ref{Import}). You have to explicitly - give their fully qualified name to refer to them. -\item {\tt Example {\ident} := {\term}.}\\ -{\tt Example} {\ident} {\tt :} {\term$_1$} {\tt :=} {\term$_2$}{\tt .}\\ -{\tt Example} {\ident} {\binder$_1$} {\ldots} {\binder$_n$} - {\tt :} {\term$_1$} {\tt :=} {\term$_2$}{\tt .}\\ -\comindex{Example} -These are synonyms of the {\tt Definition} forms. -\end{Variants} - -\begin{ErrMsgs} -\item \errindex{The term {\term} has type {\type} while it is expected to have type {\type}} -\end{ErrMsgs} - -\SeeAlso Sections \ref{Opaque}, \ref{Transparent}, \ref{unfold}. - -\subsubsection{\tt Let {\ident} := {\term}. -\comindex{Let}} - -This command binds the value {\term} to the name {\ident} in the -environment of the current section. The name {\ident} disappears -when the current section is eventually closed, and, all -persistent objects (such as theorems) defined within the -section and depending on {\ident} are prefixed by the let-in definition -{\tt let {\ident} := {\term} in}. Using the {\tt -Let} command out of any section is equivalent to using {\tt -Local Definition}. - -\begin{ErrMsgs} -\item \errindex{{\ident} already exists} -\end{ErrMsgs} - -\begin{Variants} -\item {\tt Let {\ident} : {\term$_1$} := {\term$_2$}.} -\item {\tt Let Fixpoint {\ident} \nelist{\fixpointbody}{with} {\tt .}.} -\item {\tt Let CoFixpoint {\ident} \nelist{\cofixpointbody}{with} {\tt .}.} -\end{Variants} - -\SeeAlso Sections \ref{Section} (section mechanism), \ref{Opaque}, -\ref{Transparent} (opaque/transparent constants), \ref{unfold} (tactic - {\tt unfold}). - -%% -%% Inductive Types -%% -\subsection{Inductive definitions -\index{Inductive definitions} -\label{gal-Inductive-Definitions} -\comindex{Inductive} -\label{Inductive} -\comindex{Variant} -\label{Variant}} - -We gradually explain simple inductive types, simple -annotated inductive types, simple parametric inductive types, -mutually inductive types. We explain also co-inductive types. - -\subsubsection{Simple inductive types} - -The definition of a simple inductive type has the following form: - -\medskip -\begin{tabular}{l} -{\tt Inductive} {\ident} {\tt :} {\sort} {\tt :=} \\ -\begin{tabular}{clcl} - & {\ident$_1$} & {\tt :} & {\type$_1$} \\ - {\tt |} & {\ldots} && \\ - {\tt |} & {\ident$_n$} & {\tt :} & {\type$_n$} \\ -\end{tabular} -\end{tabular} -\medskip - -The name {\ident} is the name of the inductively defined type and -{\sort} is the universes where it lives. -The names {\ident$_1$}, {\ldots}, {\ident$_n$} -are the names of its constructors and {\type$_1$}, {\ldots}, -{\type$_n$} their respective types. The types of the constructors have -to satisfy a {\em positivity condition} (see Section~\ref{Positivity}) -for {\ident}. This condition ensures the soundness of the inductive -definition. If this is the case, the names {\ident}, -{\ident$_1$}, {\ldots}, {\ident$_n$} are added to the environment with -their respective types. Accordingly to the universe where -the inductive type lives ({\it e.g.} its type {\sort}), {\Coq} provides a -number of destructors for {\ident}. Destructors are named -{\ident}{\tt\_ind}, {\ident}{\tt \_rec} or {\ident}{\tt \_rect} which -respectively correspond to elimination principles on {\tt Prop}, {\tt -Set} and {\tt Type}. The type of the destructors expresses structural -induction/recursion principles over objects of {\ident}. We give below -two examples of the use of the {\tt Inductive} definitions. - -The set of natural numbers is defined as: -\begin{coq_example} -Inductive nat : Set := - | O : nat - | S : nat -> nat. -\end{coq_example} - -The type {\tt nat} is defined as the least \verb:Set: containing {\tt - O} and closed by the {\tt S} constructor. The names {\tt nat}, -{\tt O} and {\tt S} are added to the environment. - -Now let us have a look at the elimination principles. They are three -of them: -{\tt nat\_ind}, {\tt nat\_rec} and {\tt nat\_rect}. The type of {\tt - nat\_ind} is: -\begin{coq_example} -Check nat_ind. -\end{coq_example} - -This is the well known structural induction principle over natural -numbers, i.e. the second-order form of Peano's induction principle. -It allows proving some universal property of natural numbers ({\tt -forall n:nat, P n}) by induction on {\tt n}. - -The types of {\tt nat\_rec} and {\tt nat\_rect} are similar, except -that they pertain to {\tt (P:nat->Set)} and {\tt (P:nat->Type)} -respectively . They correspond to primitive induction principles -(allowing dependent types) respectively over sorts \verb:Set: and -\verb:Type:. The constant {\ident}{\tt \_ind} is always provided, -whereas {\ident}{\tt \_rec} and {\ident}{\tt \_rect} can be impossible -to derive (for example, when {\ident} is a proposition). - -\begin{coq_eval} -Reset Initial. -\end{coq_eval} -\begin{Variants} -\item -\begin{coq_example*} -Inductive nat : Set := O | S (_:nat). -\end{coq_example*} -In the case where inductive types have no annotations (next section -gives an example of such annotations), -%the positivity condition implies that -a constructor can be defined by only giving the type of -its arguments. -\end{Variants} - -\subsubsection{Simple annotated inductive types} - -In an annotated inductive types, the universe where the inductive -type is defined is no longer a simple sort, but what is called an -arity, which is a type whose conclusion is a sort. - -As an example of annotated inductive types, let us define the -$even$ predicate: - -\begin{coq_example} -Inductive even : nat -> Prop := - | even_0 : even O - | even_SS : forall n:nat, even n -> even (S (S n)). -\end{coq_example} - -The type {\tt nat->Prop} means that {\tt even} is a unary predicate -(inductively defined) over natural numbers. The type of its two -constructors are the defining clauses of the predicate {\tt even}. The -type of {\tt even\_ind} is: - -\begin{coq_example} -Check even_ind. -\end{coq_example} - -From a mathematical point of view it asserts that the natural numbers -satisfying the predicate {\tt even} are exactly in the smallest set of -naturals satisfying the clauses {\tt even\_0} or {\tt even\_SS}. This -is why, when we want to prove any predicate {\tt P} over elements of -{\tt even}, it is enough to prove it for {\tt O} and to prove that if -any natural number {\tt n} satisfies {\tt P} its double successor {\tt - (S (S n))} satisfies also {\tt P}. This is indeed analogous to the -structural induction principle we got for {\tt nat}. - -\begin{ErrMsgs} -\item \errindex{Non strictly positive occurrence of {\ident} in {\type}} -\item \errindex{The conclusion of {\type} is not valid; it must be -built from {\ident}} -\end{ErrMsgs} - -\subsubsection{Parametrized inductive types} -In the previous example, each constructor introduces a -different instance of the predicate {\tt even}. In some cases, -all the constructors introduces the same generic instance of the -inductive definition, in which case, instead of an annotation, we use -a context of parameters which are binders shared by all the -constructors of the definition. - -% Inductive types may be parameterized. Parameters differ from inductive -% type annotations in the fact that recursive invokations of inductive -% types must always be done with the same values of parameters as its -% specification. - -The general scheme is: -\begin{center} -{\tt Inductive} {\ident} {\binder$_1$}\ldots{\binder$_k$} : {\term} := - {\ident$_1$}: {\term$_1$} | {\ldots} | {\ident$_n$}: \term$_n$ -{\tt .} -\end{center} -Parameters differ from inductive type annotations in the fact that the -conclusion of each type of constructor {\term$_i$} invoke the inductive -type with the same values of parameters as its specification. - - - -A typical example is the definition of polymorphic lists: -\begin{coq_example*} -Inductive list (A:Set) : Set := - | nil : list A - | cons : A -> list A -> list A. -\end{coq_example*} - -Note that in the type of {\tt nil} and {\tt cons}, we write {\tt - (list A)} and not just {\tt list}.\\ The constructors {\tt nil} and -{\tt cons} will have respectively types: - -\begin{coq_example} -Check nil. -Check cons. -\end{coq_example} - -Types of destructors are also quantified with {\tt (A:Set)}. - -\begin{coq_eval} -Reset Initial. -\end{coq_eval} -\begin{Variants} -\item -\begin{coq_example*} -Inductive list (A:Set) : Set := nil | cons (_:A) (_:list A). -\end{coq_example*} -This is an alternative definition of lists where we specify the -arguments of the constructors rather than their full type. -\item -\begin{coq_example*} -Variant sum (A B:Set) : Set := left : A -> sum A B | right : B -> sum A B. -\end{coq_example*} -The {\tt Variant} keyword is identical to the {\tt Inductive} keyword, -except that it disallows recursive definition of types (in particular -lists cannot be defined with the {\tt Variant} keyword). No induction -scheme is generated for this variant, unless the option -{\tt Nonrecursive Elimination Schemes} is set -(see~\ref{set-nonrecursive-elimination-schemes}). -\end{Variants} - -\begin{ErrMsgs} -\item \errindex{The {\num}th argument of {\ident} must be {\ident'} in -{\type}} -\end{ErrMsgs} - -\paragraph{New from \Coq{} V8.1} The condition on parameters for -inductive definitions has been relaxed since \Coq{} V8.1. It is now -possible in the type of a constructor, to invoke recursively the -inductive definition on an argument which is not the parameter itself. - -One can define~: -\begin{coq_example} -Inductive list2 (A:Set) : Set := - | nil2 : list2 A - | cons2 : A -> list2 (A*A) -> list2 A. -\end{coq_example} -\begin{coq_eval} -Reset list2. -\end{coq_eval} -that can also be written by specifying only the type of the arguments: -\begin{coq_example*} -Inductive list2 (A:Set) : Set := nil2 | cons2 (_:A) (_:list2 (A*A)). -\end{coq_example*} -But the following definition will give an error: -\begin{coq_example} -Fail Inductive listw (A:Set) : Set := - | nilw : listw (A*A) - | consw : A -> listw (A*A) -> listw (A*A). -\end{coq_example} -Because the conclusion of the type of constructors should be {\tt - listw A} in both cases. - -A parametrized inductive definition can be defined using -annotations instead of parameters but it will sometimes give a -different (bigger) sort for the inductive definition and will produce -a less convenient rule for case elimination. - -\SeeAlso Sections~\ref{Cic-inductive-definitions} and~\ref{Tac-induction}. - - -\subsubsection{Mutually defined inductive types -\comindex{Inductive} -\label{Mutual-Inductive}} - -The definition of a block of mutually inductive types has the form: - -\medskip -{\tt -\begin{tabular}{l} -Inductive {\ident$_1$} : {\type$_1$} := \\ -\begin{tabular}{clcl} - & {\ident$_1^1$} &:& {\type$_1^1$} \\ - | & {\ldots} && \\ - | & {\ident$_{n_1}^1$} &:& {\type$_{n_1}^1$} -\end{tabular} \\ -with\\ -~{\ldots} \\ -with {\ident$_m$} : {\type$_m$} := \\ -\begin{tabular}{clcl} - & {\ident$_1^m$} &:& {\type$_1^m$} \\ - | & {\ldots} \\ - | & {\ident$_{n_m}^m$} &:& {\type$_{n_m}^m$}. -\end{tabular} -\end{tabular} -} -\medskip - -\noindent It has the same semantics as the above {\tt Inductive} -definition for each \ident$_1$, {\ldots}, \ident$_m$. All names -\ident$_1$, {\ldots}, \ident$_m$ and \ident$_1^1$, \dots, -\ident$_{n_m}^m$ are simultaneously added to the environment. Then -well-typing of constructors can be checked. Each one of the -\ident$_1$, {\ldots}, \ident$_m$ can be used on its own. - -It is also possible to parametrize these inductive definitions. -However, parameters correspond to a local -context in which the whole set of inductive declarations is done. For -this reason, the parameters must be strictly the same for each -inductive types The extended syntax is: - -\medskip -\begin{tabular}{l} -{\tt Inductive} {\ident$_1$} {\params} {\tt :} {\type$_1$} {\tt :=} \\ -\begin{tabular}{clcl} - & {\ident$_1^1$} &{\tt :}& {\type$_1^1$} \\ - {\tt |} & {\ldots} && \\ - {\tt |} & {\ident$_{n_1}^1$} &{\tt :}& {\type$_{n_1}^1$} -\end{tabular} \\ -{\tt with}\\ -~{\ldots} \\ -{\tt with} {\ident$_m$} {\params} {\tt :} {\type$_m$} {\tt :=} \\ -\begin{tabular}{clcl} - & {\ident$_1^m$} &{\tt :}& {\type$_1^m$} \\ - {\tt |} & {\ldots} \\ - {\tt |} & {\ident$_{n_m}^m$} &{\tt :}& {\type$_{n_m}^m$}. -\end{tabular} -\end{tabular} -\medskip - -\Example -The typical example of a mutual inductive data type is the one for -trees and forests. We assume given two types $A$ and $B$ as variables. -It can be declared the following way. - -\begin{coq_eval} -Reset Initial. -\end{coq_eval} -\begin{coq_example*} -Variables A B : Set. -Inductive tree : Set := - node : A -> forest -> tree -with forest : Set := - | leaf : B -> forest - | cons : tree -> forest -> forest. -\end{coq_example*} - -This declaration generates automatically six induction -principles. They are respectively -called {\tt tree\_rec}, {\tt tree\_ind}, {\tt - tree\_rect}, {\tt forest\_rec}, {\tt forest\_ind}, {\tt - forest\_rect}. These ones are not the most general ones but are -just the induction principles corresponding to each inductive part -seen as a single inductive definition. - -To illustrate this point on our example, we give the types of {\tt - tree\_rec} and {\tt forest\_rec}. - -\begin{coq_example} -Check tree_rec. -Check forest_rec. -\end{coq_example} - -Assume we want to parametrize our mutual inductive definitions with -the two type variables $A$ and $B$, the declaration should be done the -following way: - -\begin{coq_eval} -Reset tree. -\end{coq_eval} -\begin{coq_example*} -Inductive tree (A B:Set) : Set := - node : A -> forest A B -> tree A B -with forest (A B:Set) : Set := - | leaf : B -> forest A B - | cons : tree A B -> forest A B -> forest A B. -\end{coq_example*} - -Assume we define an inductive definition inside a section. When the -section is closed, the variables declared in the section and occurring -free in the declaration are added as parameters to the inductive -definition. - -\SeeAlso Section~\ref{Section}. - -\subsubsection{Co-inductive types -\label{CoInductiveTypes} -\comindex{CoInductive}} - -The objects of an inductive type are well-founded with respect to the -constructors of the type. In other words, such objects contain only a -{\it finite} number of constructors. Co-inductive types arise from -relaxing this condition, and admitting types whose objects contain an -infinity of constructors. Infinite objects are introduced by a -non-ending (but effective) process of construction, defined in terms -of the constructors of the type. - -An example of a co-inductive type is the type of infinite sequences of -natural numbers, usually called streams. It can be introduced in \Coq\ -using the \texttt{CoInductive} command: -\begin{coq_example} -CoInductive Stream : Set := - Seq : nat -> Stream -> Stream. -\end{coq_example} - -The syntax of this command is the same as the command \texttt{Inductive} -(see Section~\ref{gal-Inductive-Definitions}). Notice that no -principle of induction is derived from the definition of a -co-inductive type, since such principles only make sense for inductive -ones. For co-inductive ones, the only elimination principle is case -analysis. For example, the usual destructors on streams -\texttt{hd:Stream->nat} and \texttt{tl:Str->Str} can be defined as -follows: -\begin{coq_example} -Definition hd (x:Stream) := let (a,s) := x in a. -Definition tl (x:Stream) := let (a,s) := x in s. -\end{coq_example} - -Definition of co-inductive predicates and blocks of mutually -co-inductive definitions are also allowed. An example of a -co-inductive predicate is the extensional equality on streams: - -\begin{coq_example} -CoInductive EqSt : Stream -> Stream -> Prop := - eqst : - forall s1 s2:Stream, - hd s1 = hd s2 -> EqSt (tl s1) (tl s2) -> EqSt s1 s2. -\end{coq_example} - -In order to prove the extensionally equality of two streams $s_1$ and -$s_2$ we have to construct an infinite proof of equality, that is, -an infinite object of type $(\texttt{EqSt}\;s_1\;s_2)$. We will see -how to introduce infinite objects in Section~\ref{CoFixpoint}. - -%% -%% (Co-)Fixpoints -%% -\subsection{Definition of recursive functions} - -\subsubsection{Definition of functions by recursion over inductive objects} - -This section describes the primitive form of definition by recursion -over inductive objects. See Section~\ref{Function} for more advanced -constructions. The command: -\begin{center} - \texttt{Fixpoint {\ident} {\params} {\tt \{struct} - \ident$_0$ {\tt \}} : type$_0$ := \term$_0$ - \comindex{Fixpoint}\label{Fixpoint}} -\end{center} -allows defining functions by pattern-matching over inductive objects -using a fixed point construction. -The meaning of this declaration is to define {\it ident} a recursive -function with arguments specified by the binders in {\params} such -that {\it ident} applied to arguments corresponding to these binders -has type \type$_0$, and is equivalent to the expression \term$_0$. The -type of the {\ident} is consequently {\tt forall {\params} {\tt,} - \type$_0$} and the value is equivalent to {\tt fun {\params} {\tt - =>} \term$_0$}. - -To be accepted, a {\tt Fixpoint} definition has to satisfy some -syntactical constraints on a special argument called the decreasing -argument. They are needed to ensure that the {\tt Fixpoint} definition -always terminates. The point of the {\tt \{struct \ident {\tt \}}} -annotation is to let the user tell the system which argument decreases -along the recursive calls. For instance, one can define the addition -function as : - -\begin{coq_example} -Fixpoint add (n m:nat) {struct n} : nat := - match n with - | O => m - | S p => S (add p m) - end. -\end{coq_example} - -The {\tt \{struct \ident {\tt \}}} annotation may be left implicit, in -this case the system try successively arguments from left to right -until it finds one that satisfies the decreasing condition. Note that -some fixpoints may have several arguments that fit as decreasing -arguments, and this choice influences the reduction of the -fixpoint. Hence an explicit annotation must be used if the leftmost -decreasing argument is not the desired one. Writing explicit -annotations can also speed up type-checking of large mutual fixpoints. - -The {\tt match} operator matches a value (here \verb:n:) with the -various constructors of its (inductive) type. The remaining arguments -give the respective values to be returned, as functions of the -parameters of the corresponding constructor. Thus here when \verb:n: -equals \verb:O: we return \verb:m:, and when \verb:n: equals -\verb:(S p): we return \verb:(S (add p m)):. - -The {\tt match} operator is formally described -in detail in Section~\ref{Caseexpr}. The system recognizes that in -the inductive call {\tt (add p m)} the first argument actually -decreases because it is a {\em pattern variable} coming from {\tt match - n with}. - -\Example The following definition is not correct and generates an -error message: - -\begin{coq_eval} -Set Printing Depth 50. -\end{coq_eval} -% (********** The following is not correct and should produce **********) -% (********* Error: Recursive call to wrongplus ... **********) -\begin{coq_example} -Fail Fixpoint wrongplus (n m:nat) {struct n} : nat := - match m with - | O => n - | S p => S (wrongplus n p) - end. -\end{coq_example} - -because the declared decreasing argument {\tt n} actually does not -decrease in the recursive call. The function computing the addition -over the second argument should rather be written: - -\begin{coq_example*} -Fixpoint plus (n m:nat) {struct m} : nat := - match m with - | O => n - | S p => S (plus n p) - end. -\end{coq_example*} - -The ordinary match operation on natural numbers can be mimicked in the -following way. -\begin{coq_example*} -Fixpoint nat_match - (C:Set) (f0:C) (fS:nat -> C -> C) (n:nat) {struct n} : C := - match n with - | O => f0 - | S p => fS p (nat_match C f0 fS p) - end. -\end{coq_example*} -The recursive call may not only be on direct subterms of the recursive -variable {\tt n} but also on a deeper subterm and we can directly -write the function {\tt mod2} which gives the remainder modulo 2 of a -natural number. -\begin{coq_example*} -Fixpoint mod2 (n:nat) : nat := - match n with - | O => O - | S p => match p with - | O => S O - | S q => mod2 q - end - end. -\end{coq_example*} -In order to keep the strong normalization property, the fixed point -reduction will only be performed when the argument in position of the -decreasing argument (which type should be in an inductive definition) -starts with a constructor. - -The {\tt Fixpoint} construction enjoys also the {\tt with} extension -to define functions over mutually defined inductive types or more -generally any mutually recursive definitions. - -\begin{Variants} -\item {\tt Fixpoint} {\ident$_1$} {\params$_1$} {\tt :} {\type$_1$} {\tt :=} {\term$_1$}\\ - {\tt with} {\ldots} \\ - {\tt with} {\ident$_m$} {\params$_m$} {\tt :} {\type$_m$} {\tt :=} {\term$_m$}\\ - Allows to define simultaneously {\ident$_1$}, {\ldots}, - {\ident$_m$}. -\end{Variants} - -\Example -The size of trees and forests can be defined the following way: -\begin{coq_eval} -Reset Initial. -Variables A B : Set. -Inductive tree : Set := - node : A -> forest -> tree -with forest : Set := - | leaf : B -> forest - | cons : tree -> forest -> forest. -\end{coq_eval} -\begin{coq_example*} -Fixpoint tree_size (t:tree) : nat := - match t with - | node a f => S (forest_size f) - end - with forest_size (f:forest) : nat := - match f with - | leaf b => 1 - | cons t f' => (tree_size t + forest_size f') - end. -\end{coq_example*} -A generic command {\tt Scheme} is useful to build automatically various -mutual induction principles. It is described in Section~\ref{Scheme}. - -\subsubsection{Definitions of recursive objects in co-inductive types} - -The command: -\begin{center} - \texttt{CoFixpoint {\ident} : \type$_0$ := \term$_0$} - \comindex{CoFixpoint}\label{CoFixpoint} -\end{center} -introduces a method for constructing an infinite object of a -coinduc\-tive type. For example, the stream containing all natural -numbers can be introduced applying the following method to the number -\texttt{O} (see Section~\ref{CoInductiveTypes} for the definition of -{\tt Stream}, {\tt hd} and {\tt tl}): -\begin{coq_eval} -Reset Initial. -CoInductive Stream : Set := - Seq : nat -> Stream -> Stream. -Definition hd (x:Stream) := match x with - | Seq a s => a - end. -Definition tl (x:Stream) := match x with - | Seq a s => s - end. -\end{coq_eval} -\begin{coq_example} -CoFixpoint from (n:nat) : Stream := Seq n (from (S n)). -\end{coq_example} - -Oppositely to recursive ones, there is no decreasing argument in a -co-recursive definition. To be admissible, a method of construction -must provide at least one extra constructor of the infinite object for -each iteration. A syntactical guard condition is imposed on -co-recursive definitions in order to ensure this: each recursive call -in the definition must be protected by at least one constructor, and -only by constructors. That is the case in the former definition, where -the single recursive call of \texttt{from} is guarded by an -application of \texttt{Seq}. On the contrary, the following recursive -function does not satisfy the guard condition: - -\begin{coq_eval} -Set Printing Depth 50. -\end{coq_eval} -% (********** The following is not correct and should produce **********) -% (***************** Error: Unguarded recursive call *******************) -\begin{coq_example} -Fail CoFixpoint filter (p:nat -> bool) (s:Stream) : Stream := - if p (hd s) then Seq (hd s) (filter p (tl s)) else filter p (tl s). -\end{coq_example} - -The elimination of co-recursive definition is done lazily, i.e. the -definition is expanded only when it occurs at the head of an -application which is the argument of a case analysis expression. In -any other context, it is considered as a canonical expression which is -completely evaluated. We can test this using the command -\texttt{Eval}, which computes the normal forms of a term: - -\begin{coq_example} -Eval compute in (from 0). -Eval compute in (hd (from 0)). -Eval compute in (tl (from 0)). -\end{coq_example} - -\begin{Variants} -\item{\tt CoFixpoint {\ident$_1$} {\params} :{\type$_1$} := - {\term$_1$}}\\ As for most constructions, arguments of co-fixpoints - expressions can be introduced before the {\tt :=} sign. -\item{\tt CoFixpoint} {\ident$_1$} {\tt :} {\type$_1$} {\tt :=} {\term$_1$}\\ - {\tt with}\\ - \mbox{}\hspace{0.1cm} {\ldots} \\ - {\tt with} {\ident$_m$} {\tt :} {\type$_m$} {\tt :=} {\term$_m$}\\ -As in the \texttt{Fixpoint} command (see Section~\ref{Fixpoint}), it -is possible to introduce a block of mutually dependent methods. -\end{Variants} - -%% -%% Theorems & Lemmas -%% -\subsection{Assertions and proofs} -\label{Assertions} - -An assertion states a proposition (or a type) of which the proof (or -an inhabitant of the type) is interactively built using tactics. The -interactive proof mode is described in -Chapter~\ref{Proof-handling} and the tactics in Chapter~\ref{Tactics}. -The basic assertion command is: - -\subsubsection{\tt Theorem {\ident} \zeroone{\binders} : {\type}. -\comindex{Theorem}} - -After the statement is asserted, {\Coq} needs a proof. Once a proof of -{\type} under the assumptions represented by {\binders} is given and -validated, the proof is generalized into a proof of {\tt forall - \zeroone{\binders}, {\type}} and the theorem is bound to the name -{\ident} in the environment. - -\begin{ErrMsgs} - -\item \errindex{The term {\form} has type {\ldots} which should be Set, - Prop or Type} - -\item \errindexbis{{\ident} already exists}{already exists} - - The name you provided is already defined. You have then to choose - another name. - -\end{ErrMsgs} - -\begin{Variants} -\item {\tt Lemma {\ident} \zeroone{\binders} : {\type}.}\comindex{Lemma}\\ - {\tt Remark {\ident} \zeroone{\binders} : {\type}.}\comindex{Remark}\\ - {\tt Fact {\ident} \zeroone{\binders} : {\type}.}\comindex{Fact}\\ - {\tt Corollary {\ident} \zeroone{\binders} : {\type}.}\comindex{Corollary}\\ - {\tt Proposition {\ident} \zeroone{\binders} : {\type}.}\comindex{Proposition} - -These commands are synonyms of \texttt{Theorem {\ident} \zeroone{\binders} : {\type}}. - -\item {\tt Theorem \nelist{{\ident} \zeroone{\binders}: {\type}}{with}.} - -This command is useful for theorems that are proved by simultaneous -induction over a mutually inductive assumption, or that assert mutually -dependent statements in some mutual co-inductive type. It is equivalent -to {\tt Fixpoint} or {\tt CoFixpoint} -(see Section~\ref{CoFixpoint}) but using tactics to build the proof of -the statements (or the body of the specification, depending on the -point of view). The inductive or co-inductive types on which the -induction or coinduction has to be done is assumed to be non ambiguous -and is guessed by the system. - -Like in a {\tt Fixpoint} or {\tt CoFixpoint} definition, the induction -hypotheses have to be used on {\em structurally smaller} arguments -(for a {\tt Fixpoint}) or be {\em guarded by a constructor} (for a {\tt - CoFixpoint}). The verification that recursive proof arguments are -correct is done only at the time of registering the lemma in the -environment. To know if the use of induction hypotheses is correct at -some time of the interactive development of a proof, use the command -{\tt Guarded} (see Section~\ref{Guarded}). - -The command can be used also with {\tt Lemma}, -{\tt Remark}, etc. instead of {\tt Theorem}. - -\item {\tt Definition {\ident} \zeroone{\binders} : {\type}.} - -This allows defining a term of type {\type} using the proof editing mode. It -behaves as {\tt Theorem} but is intended to be used in conjunction with - {\tt Defined} (see \ref{Defined}) in order to define a - constant of which the computational behavior is relevant. - -The command can be used also with {\tt Example} instead -of {\tt Definition}. - -\SeeAlso Sections~\ref{Opaque} and~\ref{Transparent} ({\tt Opaque} -and {\tt Transparent}) and~\ref{unfold} (tactic {\tt unfold}). - -\item {\tt Let {\ident} \zeroone{\binders} : {\type}.} - -Like {\tt Definition {\ident} \zeroone{\binders} : {\type}.} except -that the definition is turned into a let-in definition generalized over -the declarations depending on it after closing the current section. - -\item {\tt Fixpoint \nelist{{\ident} {\binders} \zeroone{\annotation} {\typecstr} \zeroone{{\tt :=} {\term}}}{with}.} -\comindex{Fixpoint} - -This generalizes the syntax of {\tt Fixpoint} so that one or more -bodies can be defined interactively using the proof editing mode (when -a body is omitted, its type is mandatory in the syntax). When the -block of proofs is completed, it is intended to be ended by {\tt - Defined}. - -\item {\tt CoFixpoint \nelist{{\ident} \zeroone{\binders} {\typecstr} \zeroone{{\tt :=} {\term}}}{with}.} -\comindex{CoFixpoint} - -This generalizes the syntax of {\tt CoFixpoint} so that one or more bodies -can be defined interactively using the proof editing mode. - -\end{Variants} - -\subsubsection{{\tt Proof.} {\dots} {\tt Qed.} -\comindex{Proof} -\comindex{Qed}} - -A proof starts by the keyword {\tt Proof}. Then {\Coq} enters the -proof editing mode until the proof is completed. The proof editing -mode essentially contains tactics that are described in chapter -\ref{Tactics}. Besides tactics, there are commands to manage the proof -editing mode. They are described in Chapter~\ref{Proof-handling}. When -the proof is completed it should be validated and put in the -environment using the keyword {\tt Qed}. -\medskip - -\ErrMsg -\begin{enumerate} -\item \errindex{{\ident} already exists} -\end{enumerate} - -\begin{Remarks} -\item Several statements can be simultaneously asserted. -\item Not only other assertions but any vernacular command can be given -while in the process of proving a given assertion. In this case, the command is -understood as if it would have been given before the statements still to be -proved. -\item {\tt Proof} is recommended but can currently be omitted. On the -opposite side, {\tt Qed} (or {\tt Defined}, see below) is mandatory to -validate a proof. -\item Proofs ended by {\tt Qed} are declared opaque. Their content - cannot be unfolded (see \ref{Conversion-tactics}), thus realizing - some form of {\em proof-irrelevance}. To be able to unfold a proof, - the proof should be ended by {\tt Defined} (see below). -\end{Remarks} - -\begin{Variants} -\item \comindex{Defined} - {\tt Proof.} {\dots} {\tt Defined.}\\ - Same as {\tt Proof.} {\dots} {\tt Qed.} but the proof is - then declared transparent, which means that its - content can be explicitly used for type-checking and that it - can be unfolded in conversion tactics (see - \ref{Conversion-tactics}, \ref{Opaque}, \ref{Transparent}). -%Not claimed to be part of Gallina... -%\item {\tt Proof.} {\dots} {\tt Save.}\\ -% Same as {\tt Proof.} {\dots} {\tt Qed.} -%\item {\tt Goal} \type {\dots} {\tt Save} \ident \\ -% Same as {\tt Lemma} \ident {\tt :} \type \dots {\tt Save.} -% This is intended to be used in the interactive mode. -\item \comindex{Admitted} - {\tt Proof.} {\dots} {\tt Admitted.}\\ - Turns the current asserted statement into an axiom and exits the - proof mode. -\end{Variants} - -% Local Variables: -% mode: LaTeX -% TeX-master: "Reference-Manual" -% End: - diff --git a/doc/refman/RefMan-ltac.tex b/doc/refman/RefMan-ltac.tex deleted file mode 100644 index 3ed697d8b..000000000 --- a/doc/refman/RefMan-ltac.tex +++ /dev/null @@ -1,1829 +0,0 @@ -\chapter[The tactic language]{The tactic language\label{TacticLanguage}} -%HEVEA\cutname{ltac.html} - -%\geometry{a4paper,body={5in,8in}} - -This chapter gives a compact documentation of Ltac, the tactic -language available in {\Coq}. We start by giving the syntax, and next, -we present the informal semantics. If you want to know more regarding -this language and especially about its foundations, you can refer -to~\cite{Del00}. Chapter~\ref{Tactics-examples} is devoted to giving -examples of use of this language on small but also with non-trivial -problems. - - -\section{Syntax} - -\def\tacexpr{\textrm{\textsl{expr}}} -\def\tacexprlow{\textrm{\textsl{tacexpr$_1$}}} -\def\tacexprinf{\textrm{\textsl{tacexpr$_2$}}} -\def\tacexprpref{\textrm{\textsl{tacexpr$_3$}}} -\def\atom{\textrm{\textsl{atom}}} -%%\def\recclause{\textrm{\textsl{rec\_clause}}} -\def\letclause{\textrm{\textsl{let\_clause}}} -\def\matchrule{\textrm{\textsl{match\_rule}}} -\def\contextrule{\textrm{\textsl{context\_rule}}} -\def\contexthyp{\textrm{\textsl{context\_hyp}}} -\def\tacarg{\nterm{tacarg}} -\def\cpattern{\nterm{cpattern}} -\def\selector{\textrm{\textsl{selector}}} -\def\toplevelselector{\textrm{\textsl{toplevel\_selector}}} - -The syntax of the tactic language is given Figures~\ref{ltac} -and~\ref{ltac-aux}. See Chapter~\ref{BNF-syntax} for a description of -the BNF metasyntax used in these grammar rules. Various already -defined entries will be used in this chapter: entries -{\naturalnumber}, {\integer}, {\ident}, {\qualid}, {\term}, -{\cpattern} and {\atomictac} represent respectively the natural and -integer numbers, the authorized identificators and qualified names, -{\Coq}'s terms and patterns and all the atomic tactics described in -Chapter~\ref{Tactics}. The syntax of {\cpattern} is the same as that -of terms, but it is extended with pattern matching metavariables. In -{\cpattern}, a pattern-matching metavariable is represented with the -syntax {\tt ?id} where {\tt id} is an {\ident}. The notation {\tt \_} -can also be used to denote metavariable whose instance is -irrelevant. In the notation {\tt ?id}, the identifier allows us to -keep instantiations and to make constraints whereas {\tt \_} shows -that we are not interested in what will be matched. On the right hand -side of pattern-matching clauses, the named metavariable are used -without the question mark prefix. There is also a special notation for -second-order pattern-matching problems: in an applicative pattern of -the form {\tt @?id id$_1$ \ldots id$_n$}, the variable {\tt id} -matches any complex expression with (possible) dependencies in the -variables {\tt id$_1$ \ldots id$_n$} and returns a functional term of -the form {\tt fun id$_1$ \ldots id$_n$ => {\term}}. - - -The main entry of the grammar is {\tacexpr}. This language is used in -proof mode but it can also be used in toplevel definitions as shown in -Figure~\ref{ltactop}. - -\begin{Remarks} -\item The infix tacticals ``\dots\ {\tt ||} \dots'', ``\dots\ {\tt +} - \dots'', and ``\dots\ {\tt ;} \dots'' are associative. - -\item In {\tacarg}, there is an overlap between {\qualid} as a -direct tactic argument and {\qualid} as a particular case of -{\term}. The resolution is done by first looking for a reference of -the tactic language and if it fails, for a reference to a term. To -force the resolution as a reference of the tactic language, use the -form {\tt ltac :} {\qualid}. To force the resolution as a reference to -a term, use the syntax {\tt ({\qualid})}. - -\item As shown by the figure, tactical {\tt ||} binds more than the -prefix tacticals {\tt try}, {\tt repeat}, {\tt do} and -{\tt abstract} which themselves bind more than the postfix tactical -``{\tt \dots\ ;[ \dots\ ]}'' which binds more than ``\dots\ {\tt ;} -\dots''. - -For instance -\begin{quote} -{\tt try repeat \tac$_1$ || - \tac$_2$;\tac$_3$;[\tac$_{31}$|\dots|\tac$_{3n}$];\tac$_4$.} -\end{quote} -is understood as -\begin{quote} -{\tt (try (repeat (\tac$_1$ || \tac$_2$)));} \\ -{\tt ((\tac$_3$;[\tac$_{31}$|\dots|\tac$_{3n}$]);\tac$_4$).} -\end{quote} -\end{Remarks} - - -\begin{figure}[htbp] -\begin{centerframe} -\begin{tabular}{lcl} -{\tacexpr} & ::= & - {\tacexpr} {\tt ;} {\tacexpr}\\ -& | & {\tt [>} \nelist{\tacexpr}{|} {\tt ]}\\ -& | & {\tacexpr} {\tt ; [} \nelist{\tacexpr}{|} {\tt ]}\\ -& | & {\tacexprpref}\\ -\\ -{\tacexprpref} & ::= & - {\tt do} {\it (}{\naturalnumber} {\it |} {\ident}{\it )} {\tacexprpref}\\ -& | & {\tt progress} {\tacexprpref}\\ -& | & {\tt repeat} {\tacexprpref}\\ -& | & {\tt try} {\tacexprpref}\\ -& | & {\tt once} {\tacexprpref}\\ -& | & {\tt exactly\_once} {\tacexprpref}\\ -& | & {\tt timeout} {\it (}{\naturalnumber} {\it |} {\ident}{\it )} {\tacexprpref}\\ -& | & {\tt time} \zeroone{\qstring} {\tacexprpref}\\ -& | & {\tt only} {\selector} {\tt :} {\tacexprpref}\\ -& | & {\tacexprinf} \\ -\\ -{\tacexprinf} & ::= & - {\tacexprlow} {\tt ||} {\tacexprpref}\\ -& | & {\tacexprlow} {\tt +} {\tacexprpref}\\ -& | & {\tt tryif} {\tacexprlow} {\tt then} {\tacexprlow} {\tt else} {\tacexprlow}\\ -& | & {\tacexprlow}\\ -\\ -{\tacexprlow} & ::= & -{\tt fun} \nelist{\name}{} {\tt =>} {\atom}\\ -& | & -{\tt let} \zeroone{\tt rec} \nelist{\letclause}{\tt with} {\tt in} -{\atom}\\ -& | & -{\tt match goal with} \nelist{\contextrule}{\tt |} {\tt end}\\ -& | & -{\tt match reverse goal with} \nelist{\contextrule}{\tt |} {\tt end}\\ -& | & -{\tt match} {\tacexpr} {\tt with} \nelist{\matchrule}{\tt |} {\tt end}\\ -& | & -{\tt lazymatch goal with} \nelist{\contextrule}{\tt |} {\tt end}\\ -& | & -{\tt lazymatch reverse goal with} \nelist{\contextrule}{\tt |} {\tt end}\\ -& | & -{\tt lazymatch} {\tacexpr} {\tt with} \nelist{\matchrule}{\tt |} {\tt end}\\ -& | & -{\tt multimatch goal with} \nelist{\contextrule}{\tt |} {\tt end}\\ -& | & -{\tt multimatch reverse goal with} \nelist{\contextrule}{\tt |} {\tt end}\\ -& | & -{\tt multimatch} {\tacexpr} {\tt with} \nelist{\matchrule}{\tt |} {\tt end}\\ -& | & {\tt abstract} {\atom}\\ -& | & {\tt abstract} {\atom} {\tt using} {\ident} \\ -& | & {\tt first [} \nelist{\tacexpr}{\tt |} {\tt ]}\\ -& | & {\tt solve [} \nelist{\tacexpr}{\tt |} {\tt ]}\\ -& | & {\tt idtac} \sequence{\messagetoken}{}\\ -& | & {\tt fail} \zeroone{\naturalnumber} \sequence{\messagetoken}{}\\ -& | & {\tt gfail} \zeroone{\naturalnumber} \sequence{\messagetoken}{}\\ -& | & {\tt fresh} ~|~ {\tt fresh} {\qstring}|~ {\tt fresh} {\qualid}\\ -& | & {\tt context} {\ident} {\tt [} {\term} {\tt ]}\\ -& | & {\tt eval} {\nterm{redexpr}} {\tt in} {\term}\\ -& | & {\tt type of} {\term}\\ -& | & {\tt external} {\qstring} {\qstring} \nelist{\tacarg}{}\\ -& | & {\tt constr :} {\term}\\ -& | & {\tt uconstr :} {\term}\\ -& | & {\tt type\_term} {\term}\\ -& | & {\tt numgoals} \\ -& | & {\tt guard} {\it test}\\ -& | & {\tt assert\_fails} {\tacexprpref}\\ -& | & {\tt assert\_succeds} {\tacexprpref}\\ -& | & \atomictac\\ -& | & {\qualid} \nelist{\tacarg}{}\\ -& | & {\atom} -\end{tabular} -\end{centerframe} -\caption{Syntax of the tactic language} -\label{ltac} -\end{figure} - - - -\begin{figure}[htbp] -\begin{centerframe} -\begin{tabular}{lcl} -{\atom} & ::= & - {\qualid} \\ -& | & ()\\ -& | & {\integer}\\ -& | & {\tt (} {\tacexpr} {\tt )}\\ -\\ -{\messagetoken}\!\!\!\!\!\! & ::= & {\qstring} ~|~ {\ident} ~|~ {\integer} \\ -\\ -\tacarg & ::= & - {\qualid}\\ -& $|$ & {\tt ()} \\ -& $|$ & {\tt ltac :} {\atom}\\ -& $|$ & {\term}\\ -\\ -\letclause & ::= & {\ident} \sequence{\name}{} {\tt :=} {\tacexpr}\\ -\\ -\contextrule & ::= & - \nelist{\contexthyp}{\tt ,} {\tt |-}{\cpattern} {\tt =>} {\tacexpr}\\ -& $|$ & {\tt |-} {\cpattern} {\tt =>} {\tacexpr}\\ -& $|$ & {\tt \_ =>} {\tacexpr}\\ -\\ -\contexthyp & ::= & {\name} {\tt :} {\cpattern}\\ - & $|$ & {\name} {\tt :=} {\cpattern} \zeroone{{\tt :} {\cpattern}}\\ -\\ -\matchrule & ::= & - {\cpattern} {\tt =>} {\tacexpr}\\ -& $|$ & {\tt context} {\zeroone{\ident}} {\tt [} {\cpattern} {\tt ]} - {\tt =>} {\tacexpr}\\ -& $|$ & {\tt \_ =>} {\tacexpr}\\ -\\ -{\it test} & ::= & - {\integer} {\tt \,=\,} {\integer}\\ -& $|$ & {\integer} {\tt \,<\,} {\integer}\\ -& $|$ & {\integer} {\tt <=} {\integer}\\ -& $|$ & {\integer} {\tt \,>\,} {\integer}\\ -& $|$ & {\integer} {\tt >=} {\integer}\\ -\\ -\selector & ::= & - [{\ident}]\\ -& $|$ & {\integer}\\ -& $|$ & \nelist{{\it (}{\integer} {\it |} {\integer} {\tt -} {\integer}{\it )}} - {\tt ,}\\ -\\ -\toplevelselector & ::= & - \selector\\ -& $|$ & {\tt all}\\ -& $|$ & {\tt par} -\end{tabular} -\end{centerframe} -\caption{Syntax of the tactic language (continued)} -\label{ltac-aux} -\end{figure} - -\begin{figure}[ht] -\begin{centerframe} -\begin{tabular}{lcl} -\nterm{top} & ::= & \zeroone{\tt Local} {\tt Ltac} \nelist{\nterm{ltac\_def}} {\tt with} \\ -\\ -\nterm{ltac\_def} & ::= & {\ident} \sequence{\ident}{} {\tt :=} -{\tacexpr}\\ -& $|$ &{\qualid} \sequence{\ident}{} {\tt ::=}{\tacexpr} -\end{tabular} -\end{centerframe} -\caption{Tactic toplevel definitions} -\label{ltactop} -\end{figure} - - -%% -%% Semantics -%% -\section{Semantics} -%\index[tactic]{Tacticals} -\index{Tacticals} -%\label{Tacticals} - -Tactic expressions can only be applied in the context of a proof. The -evaluation yields either a term, an integer or a tactic. Intermediary -results can be terms or integers but the final result must be a tactic -which is then applied to the focused goals. - -There is a special case for {\tt match goal} expressions of which -the clauses evaluate to tactics. Such expressions can only be used as -end result of a tactic expression (never as argument of a non recursive local -definition or of an application). - -The rest of this section explains the semantics of every construction -of Ltac. - - -%% \subsection{Values} - -%% Values are given by Figure~\ref{ltacval}. All these values are tactic values, -%% i.e. to be applied to a goal, except {\tt Fun}, {\tt Rec} and $arg$ values. - -%% \begin{figure}[ht] -%% \noindent{}\framebox[6in][l] -%% {\parbox{6in} -%% {\begin{center} -%% \begin{tabular}{lp{0.1in}l} -%% $vexpr$ & ::= & $vexpr$ {\tt ;} $vexpr$\\ -%% & | & $vexpr$ {\tt ; [} {\it (}$vexpr$ {\tt |}{\it )}$^*$ $vexpr$ {\tt -%% ]}\\ -%% & | & $vatom$\\ -%% \\ -%% $vatom$ & ::= & {\tt Fun} \nelist{\inputfun}{} {\tt ->} {\tacexpr}\\ -%% %& | & {\tt Rec} \recclause\\ -%% & | & -%% {\tt Rec} \nelist{\recclause}{\tt And} {\tt In} -%% {\tacexpr}\\ -%% & | & -%% {\tt Match Context With} {\it (}$context\_rule$ {\tt |}{\it )}$^*$ -%% $context\_rule$\\ -%% & | & {\tt (} $vexpr$ {\tt )}\\ -%% & | & $vatom$ {\tt Orelse} $vatom$\\ -%% & | & {\tt Do} {\it (}{\naturalnumber} {\it |} {\ident}{\it )} $vatom$\\ -%% & | & {\tt Repeat} $vatom$\\ -%% & | & {\tt Try} $vatom$\\ -%% & | & {\tt First [} {\it (}$vexpr$ {\tt |}{\it )}$^*$ $vexpr$ {\tt ]}\\ -%% & | & {\tt Solve [} {\it (}$vexpr$ {\tt |}{\it )}$^*$ $vexpr$ {\tt ]}\\ -%% & | & {\tt Idtac}\\ -%% & | & {\tt Fail}\\ -%% & | & {\primitivetactic}\\ -%% & | & $arg$ -%% \end{tabular} -%% \end{center}}} -%% \caption{Values of ${\cal L}_{tac}$} -%% \label{ltacval} -%% \end{figure} - -%% \subsection{Evaluation} - -\subsubsection[Sequence]{Sequence\tacindex{;} -\index{Tacticals!;@{\tt {\tac$_1$};\tac$_2$}}} - -A sequence is an expression of the following form: -\begin{quote} -{\tacexpr}$_1$ {\tt ;} {\tacexpr}$_2$ -\end{quote} -The expression {\tacexpr}$_1$ is evaluated to $v_1$, which must be -a tactic value. The tactic $v_1$ is applied to the current goal, -possibly producing more goals. Then {\tacexpr}$_2$ is evaluated to -produce $v_2$, which must be a tactic value. The tactic $v_2$ is applied to -all the goals produced by the prior application. Sequence is associative. - -\subsubsection[Local application of tactics]{Local application of tactics\tacindex{[>\ldots$\mid$\ldots$\mid$\ldots]}\tacindex{;[\ldots$\mid$\ldots$\mid$\ldots]}\index{Tacticals![> \mid ]@{\tt {\tac$_0$};[{\tac$_1$}$\mid$\ldots$\mid$\tac$_n$]}}\index{Tacticals!; [ \mid ]@{\tt {\tac$_0$};[{\tac$_1$}$\mid$\ldots$\mid$\tac$_n$]}}} -%\tacindex{; [ | ]} -%\index{; [ | ]@{\tt ;[\ldots$\mid$\ldots$\mid$\ldots]}} - -Different tactics can be applied to the different goals using the following form: -\begin{quote} -{\tt [ >} {\tacexpr}$_1$ {\tt |} $...$ {\tt |} {\tacexpr}$_n$ {\tt ]} -\end{quote} -The expressions {\tacexpr}$_i$ are evaluated to $v_i$, for $i=0,...,n$ -and all have to be tactics. The $v_i$ is applied to the $i$-th goal, -for $=1,...,n$. It fails if the number of focused goals is not exactly $n$. - -\begin{Variants} - \item If no tactic is given for the $i$-th goal, it behaves as if - the tactic {\tt idtac} were given. For instance, {\tt [~> | auto - ]} is a shortcut for {\tt [ > idtac | auto ]}. - - \item {\tt [ >} {\tacexpr}$_1$ {\tt |} $...$ {\tt |} - {\tacexpr}$_i$ {\tt |} {\tacexpr} {\tt ..} {\tt |} - {\tacexpr}$_{i+1+j}$ {\tt |} $...$ {\tt |} {\tacexpr}$_n$ {\tt ]} - - In this variant, {\tt expr} is used for each goal numbered from - $i+1$ to $i+j$ (assuming $n$ is the number of goals). - - Note that {\tt ..} is part of the syntax, while $...$ is the meta-symbol used - to describe a list of {\tacexpr} of arbitrary length. - goals numbered from $i+1$ to $i+j$. - - \item {\tt [ >} {\tacexpr}$_1$ {\tt |} $...$ {\tt |} - {\tacexpr}$_i$ {\tt |} {\tt ..} {\tt |} {\tacexpr}$_{i+1+j}$ {\tt |} - $...$ {\tt |} {\tacexpr}$_n$ {\tt ]} - - In this variant, {\tt idtac} is used for the goals numbered from - $i+1$ to $i+j$. - - \item {\tt [ >} {\tacexpr} {\tt ..} {\tt ]} - - In this variant, the tactic {\tacexpr} is applied independently to - each of the goals, rather than globally. In particular, if there - are no goal, the tactic is not run at all. A tactic which - expects multiple goals, such as {\tt swap}, would act as if a single - goal is focused. - - \item {\tacexpr} {\tt ; [ } {\tacexpr}$_1$ {\tt |} $...$ {\tt |} {\tacexpr}$_n$ {\tt ]} - - This variant of local tactic application is paired with a - sequence. In this variant, $n$ must be the number of goals - generated by the application of {\tacexpr} to each of the - individual goals independently. All the above variants work in - this form too. Formally, {\tacexpr} {\tt ; [} $...$ {\tt ]} is - equivalent to - \begin{quote} - {\tt [ >} {\tacexpr} {\tt ; [ >} $...$ {\tt ]} {\tt ..} {\tt ]} - \end{quote} - -\end{Variants} - -\subsubsection[Goal selectors]{Goal selectors\label{ltac:selector} -\tacindex{\tt :}\index{Tacticals!:@{\tt :}}} - -We can restrict the application of a tactic to a subset of -the currently focused goals with: -\begin{quote} - {\toplevelselector} {\tt :} {\tacexpr} -\end{quote} -We can also use selectors as a tactical, which allows to use them nested in -a tactic expression, by using the keyword {\tt only}: -\begin{quote} - {\tt only} {\selector} {\tt :} {\tacexpr} -\end{quote} -When selecting several goals, the tactic {\tacexpr} is applied globally to -all selected goals. - -\begin{Variants} - \item{} [{\ident}] {\tt :} {\tacexpr} - - In this variant, {\tacexpr} is applied locally to a goal - previously named by the user (see~\ref{ExistentialVariables}). - - \item {\num} {\tt :} {\tacexpr} - - In this variant, {\tacexpr} is applied locally to the - {\num}-th goal. - - \item $n_1$-$m_1$, \dots, $n_k$-$m_k$ {\tt :} {\tacexpr} - - In this variant, {\tacexpr} is applied globally to the subset - of goals described by the given ranges. You can write a single - $n$ as a shortcut for $n$-$n$ when specifying multiple ranges. - - \item {\tt all:} {\tacexpr} - - In this variant, {\tacexpr} is applied to all focused goals. - {\tt all:} can only be used at the toplevel of a tactic expression. - - \item {\tt par:} {\tacexpr} - - In this variant, {\tacexpr} is applied to all focused goals - in parallel. The number of workers can be controlled via the - command line option {\tt -async-proofs-tac-j} taking as argument - the desired number of workers. Limitations: {\tt par: } only works - on goals containing no existential variables and {\tacexpr} must - either solve the goal completely or do nothing (i.e. it cannot make - some progress). - {\tt par:} can only be used at the toplevel of a tactic expression. - -\end{Variants} - -\ErrMsg \errindex{No such goal} - -\subsubsection[For loop]{For loop\tacindex{do} -\index{Tacticals!do@{\tt do}}} - -There is a for loop that repeats a tactic {\num} times: -\begin{quote} -{\tt do} {\num} {\tacexpr} -\end{quote} -{\tacexpr} is evaluated to $v$ which must be a tactic value. -This tactic value $v$ is -applied {\num} times. Supposing ${\num}>1$, after the first -application of $v$, $v$ is applied, at least once, to the generated -subgoals and so on. It fails if the application of $v$ fails before -the {\num} applications have been completed. - -\subsubsection[Repeat loop]{Repeat loop\tacindex{repeat} -\index{Tacticals!repeat@{\tt repeat}}} - -We have a repeat loop with: -\begin{quote} -{\tt repeat} {\tacexpr} -\end{quote} -{\tacexpr} is evaluated to $v$. If $v$ denotes a tactic, this tactic -is applied to each focused goal independently. If the application -succeeds, the tactic is applied recursively to all the generated subgoals -until it eventually fails. The recursion stops in a subgoal when the -tactic has failed \emph{to make progress}. The tactic {\tt repeat - {\tacexpr}} itself never fails. - -\subsubsection[Error catching]{Error catching\tacindex{try} -\index{Tacticals!try@{\tt try}}} - -We can catch the tactic errors with: -\begin{quote} -{\tt try} {\tacexpr} -\end{quote} -{\tacexpr} is evaluated to $v$ which must be a tactic value. -The tactic value $v$ is -applied to each focused goal independently. If the application of $v$ -fails in a goal, it catches the error and leaves the goal -unchanged. If the level of the exception is positive, then the -exception is re-raised with its level decremented. - -\subsubsection[Detecting progress]{Detecting progress\tacindex{progress}} - -We can check if a tactic made progress with: -\begin{quote} -{\tt progress} {\tacexpr} -\end{quote} -{\tacexpr} is evaluated to $v$ which must be a tactic value. -The tactic value $v$ is -applied to each focued subgoal independently. If the application of -$v$ to one of the focused subgoal produced subgoals equal to the -initial goals (up to syntactical equality), then an error of level 0 -is raised. - -\ErrMsg \errindex{Failed to progress} - -\subsubsection[Backtracking branching]{Backtracking branching\tacindex{$+$} -\index{Tacticals!or@{\tt $+$}}} - -We can branch with the following structure: -\begin{quote} -{\tacexpr}$_1$ {\tt +} {\tacexpr}$_2$ -\end{quote} -{\tacexpr}$_1$ and {\tacexpr}$_2$ are evaluated to $v_1$ and -$v_2$ which must be tactic values. The tactic value $v_1$ is applied to each -focused goal independently and if it fails or a later tactic fails, -then the proof backtracks to the current goal and $v_2$ is applied. - -Tactics can be seen as having several successes. When a tactic fails -it asks for more successes of the prior tactics. {\tacexpr}$_1$ {\tt - +} {\tacexpr}$_2$ has all the successes of $v_1$ followed by all the -successes of $v_2$. Algebraically, ({\tacexpr}$_1$ {\tt +} -{\tacexpr}$_2$);{\tacexpr}$_3$ $=$ ({\tacexpr}$_1$;{\tacexpr}$_3$) -{\tt +} ({\tacexpr}$_2$;{\tacexpr}$_3$). - -Branching is left-associative. - -\subsubsection[First tactic to work]{First tactic to work\tacindex{first} -\index{Tacticals!first@{\tt first}}} - -Backtracking branching may be too expensive. In this case we may -restrict to a local, left biased, branching and consider the first -tactic to work (i.e. which does not fail) among a panel of tactics: -\begin{quote} -{\tt first [} {\tacexpr}$_1$ {\tt |} $...$ {\tt |} {\tacexpr}$_n$ {\tt ]} -\end{quote} -{\tacexpr}$_i$ are evaluated to $v_i$ and $v_i$ must be tactic values, -for $i=1,...,n$. Supposing $n>1$, it applies, in each focused goal -independently, $v_1$, if it works, it stops otherwise it tries to -apply $v_2$ and so on. It fails when there is no applicable tactic. In -other words, {\tt first [} {\tacexpr}$_1$ {\tt |} $...$ {\tt |} - {\tacexpr}$_n$ {\tt ]} behaves, in each goal, as the the first $v_i$ -to have \emph{at least} one success. - -\ErrMsg \errindex{No applicable tactic} - -\variant {\tt first {\tacexpr}} - -This is an Ltac alias that gives a primitive access to the {\tt first} tactical -as a Ltac definition without going through a parsing rule. It expects to be -given a list of tactics through a {\tt Tactic Notation}, allowing to write -notations of the following form. - -\Example - -\begin{quote} -{\tt Tactic Notation "{foo}" tactic\_list(tacs) := first tacs.} -\end{quote} - -\subsubsection[Left-biased branching]{Left-biased branching\tacindex{$\mid\mid$} -\index{Tacticals!orelse@{\tt $\mid\mid$}}} - -Yet another way of branching without backtracking is the following structure: -\begin{quote} -{\tacexpr}$_1$ {\tt ||} {\tacexpr}$_2$ -\end{quote} -{\tacexpr}$_1$ and {\tacexpr}$_2$ are evaluated to $v_1$ and -$v_2$ which must be tactic values. The tactic value $v_1$ is applied in each -subgoal independently and if it fails \emph{to progress} then $v_2$ is -applied. {\tacexpr}$_1$ {\tt ||} {\tacexpr}$_2$ is equivalent to {\tt - first [} {\tt progress} {\tacexpr}$_1$ {\tt |} - {\tacexpr}$_2$ {\tt ]} (except that if it fails, it fails like -$v_2$). Branching is left-associative. - -\subsubsection[Generalized biased branching]{Generalized biased branching\tacindex{tryif} -\index{Tacticals!tryif@{\tt tryif}}} - -The tactic -\begin{quote} -{\tt tryif {\tacexpr}$_1$ then {\tacexpr}$_2$ else {\tacexpr}$_3$} -\end{quote} -is a generalization of the biased-branching tactics above. The -expression {\tacexpr}$_1$ is evaluated to $v_1$, which is then applied -to each subgoal independently. For each goal where $v_1$ succeeds at -least once, {\tacexpr}$_2$ is evaluated to $v_2$ which is then applied -collectively to the generated subgoals. The $v_2$ tactic can trigger -backtracking points in $v_1$: where $v_1$ succeeds at least once, {\tt - tryif {\tacexpr}$_1$ then {\tacexpr}$_2$ else {\tacexpr}$_3$} is -equivalent to $v_1;v_2$. In each of the goals where $v_1$ does not -succeed at least once, {\tacexpr}$_3$ is evaluated in $v_3$ which is -is then applied to the goal. - -\subsubsection[Soft cut]{Soft cut\tacindex{once}\index{Tacticals!once@{\tt once}}} - -Another way of restricting backtracking is to restrict a tactic to a -single success \emph{a posteriori}: -\begin{quote} -{\tt once} {\tacexpr} -\end{quote} -{\tacexpr} is evaluated to $v$ which must be a tactic value. -The tactic value $v$ is -applied but only its first success is used. If $v$ fails, {\tt once} -{\tacexpr} fails like $v$. If $v$ has a least one success, {\tt once} -{\tacexpr} succeeds once, but cannot produce more successes. - -\subsubsection[Checking the successes]{Checking the successes\tacindex{exactly\_once}\index{Tacticals!exactly\_once@{\tt exactly\_once}}} - -Coq provides an experimental way to check that a tactic has \emph{exactly one} success: -\begin{quote} -{\tt exactly\_once} {\tacexpr} -\end{quote} -{\tacexpr} is evaluated to $v$ which must be a tactic value. -The tactic value $v$ is -applied if it has at most one success. If $v$ fails, {\tt - exactly\_once} {\tacexpr} fails like $v$. If $v$ has a exactly one -success, {\tt exactly\_once} {\tacexpr} succeeds like $v$. If $v$ has -two or more successes, {\tt exactly\_once} {\tacexpr} fails. - -The experimental status of this tactic pertains to the fact if $v$ performs side effects, they may occur in a unpredictable way. Indeed, normally $v$ would only be executed up to the first success until backtracking is needed, however {\tt exactly\_once} needs to look ahead to see whether a second success exists, and may run further effects immediately. - -\ErrMsg \errindex{This tactic has more than one success} - -\subsubsection[Checking the failure]{Checking the failure\tacindex{assert\_fails}\index{Tacticals!assert\_fails@{\tt assert\_fails}}} - -Coq provides a derived tactic to check that a tactic \emph{fails}: -\begin{quote} -{\tt assert\_fails} {\tacexpr} -\end{quote} -This behaves like {\tt tryif {\tacexpr} then fail 0 tac "succeeds" else idtac}. - -\subsubsection[Checking the success]{Checking the success\tacindex{assert\_succeeds}\index{Tacticals!assert\_succeeds@{\tt assert\_succeeds}}} - -Coq provides a derived tactic to check that a tactic has \emph{at least one} success: -\begin{quote} -{\tt assert\_succeeds} {\tacexpr} -\end{quote} -This behaves like {\tt tryif (assert\_fails tac) then fail 0 tac "fails" else idtac}. - -\subsubsection[Solving]{Solving\tacindex{solve} -\index{Tacticals!solve@{\tt solve}}} - -We may consider the first to solve (i.e. which generates no subgoal) among a -panel of tactics: -\begin{quote} -{\tt solve [} {\tacexpr}$_1$ {\tt |} $...$ {\tt |} {\tacexpr}$_n$ {\tt ]} -\end{quote} -{\tacexpr}$_i$ are evaluated to $v_i$ and $v_i$ must be tactic values, -for $i=1,...,n$. Supposing $n>1$, it applies $v_1$ to each goal -independently, if it doesn't solve the goal then it tries to apply -$v_2$ and so on. It fails if there is no solving tactic. - -\ErrMsg \errindex{Cannot solve the goal} - -\variant {\tt solve {\tacexpr}} - -This is an Ltac alias that gives a primitive access to the {\tt solve} tactical. -See the {\tt first} tactical for more information. - -\subsubsection[Identity]{Identity\label{ltac:idtac}\tacindex{idtac} -\index{Tacticals!idtac@{\tt idtac}}} - -The constant {\tt idtac} is the identity tactic: it leaves any goal -unchanged but it appears in the proof script. - -\variant {\tt idtac \nelist{\messagetoken}{}} - -This prints the given tokens. Strings and integers are printed -literally. If a (term) variable is given, its contents are printed. - - -\subsubsection[Failing]{Failing\tacindex{fail} -\index{Tacticals!fail@{\tt fail}} -\tacindex{gfail}\index{Tacticals!gfail@{\tt gfail}}} - -The tactic {\tt fail} is the always-failing tactic: it does not solve -any goal. It is useful for defining other tacticals since it can be -caught by {\tt try}, {\tt repeat}, {\tt match goal}, or the branching -tacticals. The {\tt fail} tactic will, however, succeed if all the -goals have already been solved. - -\begin{Variants} -\item {\tt fail $n$}\\ The number $n$ is the failure level. If no - level is specified, it defaults to $0$. The level is used by {\tt - try}, {\tt repeat}, {\tt match goal} and the branching tacticals. - If $0$, it makes {\tt match goal} considering the next clause - (backtracking). If non zero, the current {\tt match goal} block, - {\tt try}, {\tt repeat}, or branching command is aborted and the - level is decremented. In the case of {\tt +}, a non-zero level skips - the first backtrack point, even if the call to {\tt fail $n$} is not - enclosed in a {\tt +} command, respecting the algebraic identity. - -\item {\tt fail \nelist{\messagetoken}{}}\\ -The given tokens are used for printing the failure message. - -\item {\tt fail $n$ \nelist{\messagetoken}{}}\\ -This is a combination of the previous variants. - -\item {\tt gfail}\\ -This variant fails even if there are no goals left. - -\item {\tt gfail \nelist{\messagetoken}{}}\\ -{\tt gfail $n$ \nelist{\messagetoken}{}}\\ -These variants fail with an error message or an error level even if -there are no goals left. Be careful however if Coq terms have to be -printed as part of the failure: term construction always forces the -tactic into the goals, meaning that if there are no goals when it is -evaluated, a tactic call like {\tt let x:=H in fail 0 x} will succeed. - -\end{Variants} - -\ErrMsg \errindex{Tactic Failure {\it message} (level $n$)}. - -\subsubsection[Timeout]{Timeout\tacindex{timeout} -\index{Tacticals!timeout@{\tt timeout}}} - -We can force a tactic to stop if it has not finished after a certain -amount of time: -\begin{quote} -{\tt timeout} {\num} {\tacexpr} -\end{quote} -{\tacexpr} is evaluated to $v$ which must be a tactic value. -The tactic value $v$ is -applied normally, except that it is interrupted after ${\num}$ seconds -if it is still running. In this case the outcome is a failure. - -Warning: For the moment, {\tt timeout} is based on elapsed time in -seconds, which is very -machine-dependent: a script that works on a quick machine may fail -on a slow one. The converse is even possible if you combine a -{\tt timeout} with some other tacticals. This tactical is hence -proposed only for convenience during debug or other development -phases, we strongly advise you to not leave any {\tt timeout} in -final scripts. Note also that this tactical isn't available on -the native Windows port of Coq. - -\subsubsection{Timing a tactic\tacindex{time} -\index{Tacticals!time@{\tt time}}} - -A tactic execution can be timed: -\begin{quote} - {\tt time} {\qstring} {\tacexpr} -\end{quote} -evaluates {\tacexpr} -and displays the time the tactic expression ran, whether it fails or -successes. In case of several successes, the time for each successive -runs is displayed. Time is in seconds and is machine-dependent. The -{\qstring} argument is optional. When provided, it is used to identify -this particular occurrence of {\tt time}. - -\subsubsection{Timing a tactic that evaluates to a term\tacindex{time\_constr}\tacindex{restart\_timer}\tacindex{finish\_timing} -\index{Tacticals!time\_constr@{\tt time\_constr}}} -\index{Tacticals!restart\_timer@{\tt restart\_timer}} -\index{Tacticals!finish\_timing@{\tt finish\_timing}} - -Tactic expressions that produce terms can be timed with the experimental tactic -\begin{quote} - {\tt time\_constr} {\tacexpr} -\end{quote} -which evaluates {\tacexpr\tt{ ()}} -and displays the time the tactic expression evaluated, assuming successful evaluation. -Time is in seconds and is machine-dependent. - -This tactic currently does not support nesting, and will report times based on the innermost execution. -This is due to the fact that it is implemented using the tactics -\begin{quote} - {\tt restart\_timer} {\qstring} -\end{quote} -and -\begin{quote} - {\tt finish\_timing} ({\qstring}) {\qstring} -\end{quote} -which (re)set and display an optionally named timer, respectively. -The parenthesized {\qstring} argument to {\tt finish\_timing} is also -optional, and determines the label associated with the timer for -printing. - -By copying the definition of {\tt time\_constr} from the standard -library, users can achive support for a fixed pattern of nesting by -passing different {\qstring} parameters to {\tt restart\_timer} and -{\tt finish\_timing} at each level of nesting. For example: - -\begin{coq_example} -Ltac time_constr1 tac := - let eval_early := match goal with _ => restart_timer "(depth 1)" end in - let ret := tac () in - let eval_early := match goal with _ => finish_timing ( "Tactic evaluation" ) "(depth 1)" end in - ret. - -Goal True. - let v := time_constr - ltac:(fun _ => - let x := time_constr1 ltac:(fun _ => constr:(10 * 10)) in - let y := time_constr1 ltac:(fun _ => eval compute in x) in - y) in - pose v. -Abort. -\end{coq_example} - -\subsubsection[Local definitions]{Local definitions\index{Ltac!let@\texttt{let}} -\index{Ltac!let rec@\texttt{let rec}} -\index{let@\texttt{let}!in Ltac} -\index{let rec@\texttt{let rec}!in Ltac}} - -Local definitions can be done as follows: -\begin{quote} -{\tt let} {\ident}$_1$ {\tt :=} {\tacexpr}$_1$\\ -{\tt with} {\ident}$_2$ {\tt :=} {\tacexpr}$_2$\\ -...\\ -{\tt with} {\ident}$_n$ {\tt :=} {\tacexpr}$_n$ {\tt in}\\ -{\tacexpr} -\end{quote} -each {\tacexpr}$_i$ is evaluated to $v_i$, then, {\tacexpr} is -evaluated by substituting $v_i$ to each occurrence of {\ident}$_i$, -for $i=1,...,n$. There is no dependencies between the {\tacexpr}$_i$ -and the {\ident}$_i$. - -Local definitions can be recursive by using {\tt let rec} instead of -{\tt let}. In this latter case, the definitions are evaluated lazily -so that the {\tt rec} keyword can be used also in non recursive cases -so as to avoid the eager evaluation of local definitions. - -\subsubsection{Application} - -An application is an expression of the following form: -\begin{quote} -{\qualid} {\tacarg}$_1$ ... {\tacarg}$_n$ -\end{quote} -The reference {\qualid} must be bound to some defined tactic -definition expecting at least $n$ arguments. The expressions -{\tacexpr}$_i$ are evaluated to $v_i$, for $i=1,...,n$. -%If {\tacexpr} is a {\tt Fun} or {\tt Rec} value then the body is evaluated by -%substituting $v_i$ to the formal parameters, for $i=1,...,n$. For recursive -%clauses, the bodies are lazily substituted (when an identifier to be evaluated -%is the name of a recursive clause). - -%\subsection{Application of tactic values} - -\subsubsection[Function construction]{Function construction\index{fun@\texttt{fun}!in Ltac} -\index{Ltac!fun@\texttt{fun}}} - -A parameterized tactic can be built anonymously (without resorting to -local definitions) with: -\begin{quote} -{\tt fun} {\ident${}_1$} ... {\ident${}_n$} {\tt =>} {\tacexpr} -\end{quote} -Indeed, local definitions of functions are a syntactic sugar for -binding a {\tt fun} tactic to an identifier. - -\subsubsection[Pattern matching on terms]{Pattern matching on terms\index{Ltac!match@\texttt{match}} -\index{match@\texttt{match}!in Ltac}} - -We can carry out pattern matching on terms with: -\begin{quote} -{\tt match} {\tacexpr} {\tt with}\\ -~~~{\cpattern}$_1$ {\tt =>} {\tacexpr}$_1$\\ -~{\tt |} {\cpattern}$_2$ {\tt =>} {\tacexpr}$_2$\\ -~...\\ -~{\tt |} {\cpattern}$_n$ {\tt =>} {\tacexpr}$_n$\\ -~{\tt |} {\tt \_} {\tt =>} {\tacexpr}$_{n+1}$\\ -{\tt end} -\end{quote} -The expression {\tacexpr} is evaluated and should yield a term which -is matched against {\cpattern}$_1$. The matching is non-linear: if a -metavariable occurs more than once, it should match the same -expression every time. It is first-order except on the -variables of the form {\tt @?id} that occur in head position of an -application. For these variables, the matching is second-order and -returns a functional term. - -Alternatively, when a metavariable of the form {\tt ?id} occurs under -binders, say $x_1$, \ldots, $x_n$ and the expression matches, the -metavariable is instantiated by a term which can then be used in any -context which also binds the variables $x_1$, \ldots, $x_n$ with -same types. This provides with a primitive form of matching -under context which does not require manipulating a functional term. - -If the matching with {\cpattern}$_1$ succeeds, then {\tacexpr}$_1$ is -evaluated into some value by substituting the pattern matching -instantiations to the metavariables. If {\tacexpr}$_1$ evaluates to a -tactic and the {\tt match} expression is in position to be applied to -a goal (e.g. it is not bound to a variable by a {\tt let in}), then -this tactic is applied. If the tactic succeeds, the list of resulting -subgoals is the result of the {\tt match} expression. If -{\tacexpr}$_1$ does not evaluate to a tactic or if the {\tt match} -expression is not in position to be applied to a goal, then the result -of the evaluation of {\tacexpr}$_1$ is the result of the {\tt match} -expression. - -If the matching with {\cpattern}$_1$ fails, or if it succeeds but the -evaluation of {\tacexpr}$_1$ fails, or if the evaluation of -{\tacexpr}$_1$ succeeds but returns a tactic in execution position -whose execution fails, then {\cpattern}$_2$ is used and so on. The -pattern {\_} matches any term and shunts all remaining patterns if -any. If all clauses fail (in particular, there is no pattern {\_}) -then a no-matching-clause error is raised. - -Failures in subsequent tactics do not cause backtracking to select new -branches or inside the right-hand side of the selected branch even if -it has backtracking points. - -\begin{ErrMsgs} - -\item \errindex{No matching clauses for match} - - No pattern can be used and, in particular, there is no {\tt \_} pattern. - -\item \errindex{Argument of match does not evaluate to a term} - - This happens when {\tacexpr} does not denote a term. - -\end{ErrMsgs} - -\begin{Variants} - -\item \index{multimatch@\texttt{multimatch}!in Ltac} -\index{Ltac!multimatch@\texttt{multimatch}} -Using {\tt multimatch} instead of {\tt match} will allow subsequent -tactics to backtrack into a right-hand side tactic which has -backtracking points left and trigger the selection of a new matching -branch when all the backtracking points of the right-hand side have -been consumed. - -The syntax {\tt match \ldots} is, in fact, a shorthand for -{\tt once multimatch \ldots}. - -\item \index{lazymatch@\texttt{lazymatch}!in Ltac} -\index{Ltac!lazymatch@\texttt{lazymatch}} -Using {\tt lazymatch} instead of {\tt match} will perform the same -pattern matching procedure but will commit to the first matching -branch rather than trying a new matching if the right-hand side -fails. If the right-hand side of the selected branch is a tactic with -backtracking points, then subsequent failures cause this tactic to -backtrack. - -\item \index{context@\texttt{context}!in pattern} -There is a special form of patterns to match a subterm against the -pattern: -\begin{quote} -{\tt context} {\ident} {\tt [} {\cpattern} {\tt ]} -\end{quote} -It matches any term with a subterm matching {\cpattern}. If there is -a match, the optional {\ident} is assigned the ``matched context'', i.e. -the initial term where the matched subterm is replaced by a -hole. The example below will show how to use such term contexts. - -If the evaluation of the right-hand-side of a valid match fails, the -next matching subterm is tried. If no further subterm matches, the -next clause is tried. Matching subterms are considered top-bottom and -from left to right (with respect to the raw printing obtained by -setting option {\tt Printing All}, see Section~\ref{SetPrintingAll}). - -\begin{coq_example} -Ltac f x := - match x with - context f [S ?X] => - idtac X; (* To display the evaluation order *) - assert (p := eq_refl 1 : X=1); (* To filter the case X=1 *) - let x:= context f[O] in assert (x=O) (* To observe the context *) - end. -Goal True. -f (3+4). -\end{coq_example} - -\end{Variants} - -\subsubsection[Pattern matching on goals]{Pattern matching on goals\index{Ltac!match goal@\texttt{match goal}}\label{ltac-match-goal} -\index{Ltac!match reverse goal@\texttt{match reverse goal}} -\index{match goal@\texttt{match goal}!in Ltac} -\index{match reverse goal@\texttt{match reverse goal}!in Ltac}} - -We can make pattern matching on goals using the following expression: -\begin{quote} -\begin{tabbing} -{\tt match goal with}\\ -~~\={\tt |} $hyp_{1,1}${\tt ,}...{\tt ,}$hyp_{1,m_1}$ - ~~{\tt |-}{\cpattern}$_1${\tt =>} {\tacexpr}$_1$\\ - \>{\tt |} $hyp_{2,1}${\tt ,}...{\tt ,}$hyp_{2,m_2}$ - ~~{\tt |-}{\cpattern}$_2${\tt =>} {\tacexpr}$_2$\\ -~~...\\ - \>{\tt |} $hyp_{n,1}${\tt ,}...{\tt ,}$hyp_{n,m_n}$ - ~~{\tt |-}{\cpattern}$_n${\tt =>} {\tacexpr}$_n$\\ - \>{\tt |\_}~~~~{\tt =>} {\tacexpr}$_{n+1}$\\ -{\tt end} -\end{tabbing} -\end{quote} - -If each hypothesis pattern $hyp_{1,i}$, with $i=1,...,m_1$ -is matched (non-linear first-order unification) by an hypothesis of -the goal and if {\cpattern}$_1$ is matched by the conclusion of the -goal, then {\tacexpr}$_1$ is evaluated to $v_1$ by substituting the -pattern matching to the metavariables and the real hypothesis names -bound to the possible hypothesis names occurring in the hypothesis -patterns. If $v_1$ is a tactic value, then it is applied to the -goal. If this application fails, then another combination of -hypotheses is tried with the same proof context pattern. If there is -no other combination of hypotheses then the second proof context -pattern is tried and so on. If the next to last proof context pattern -fails then {\tacexpr}$_{n+1}$ is evaluated to $v_{n+1}$ and $v_{n+1}$ -is applied. Note also that matching against subterms (using the {\tt -context} {\ident} {\tt [} {\cpattern} {\tt ]}) is available and is -also subject to yielding several matchings. - -Failures in subsequent tactics do not cause backtracking to select new -branches or combinations of hypotheses, or inside the right-hand side -of the selected branch even if it has backtracking points. - -\ErrMsg \errindex{No matching clauses for match goal} - -No clause succeeds, i.e. all matching patterns, if any, -fail at the application of the right-hand-side. - -\medskip - -It is important to know that each hypothesis of the goal can be -matched by at most one hypothesis pattern. The order of matching is -the following: hypothesis patterns are examined from the right to the -left (i.e. $hyp_{i,m_i}$ before $hyp_{i,1}$). For each hypothesis -pattern, the goal hypothesis are matched in order (fresher hypothesis -first), but it possible to reverse this order (older first) with -the {\tt match reverse goal with} variant. - -\variant - -\index{multimatch goal@\texttt{multimatch goal}!in Ltac} -\index{Ltac!multimatch goal@\texttt{multimatch goal}} -\index{multimatch reverse goal@\texttt{multimatch reverse goal}!in Ltac} -\index{Ltac!multimatch reverse goal@\texttt{multimatch reverse goal}} - -Using {\tt multimatch} instead of {\tt match} will allow subsequent -tactics to backtrack into a right-hand side tactic which has -backtracking points left and trigger the selection of a new matching -branch or combination of hypotheses when all the backtracking points -of the right-hand side have been consumed. - -The syntax {\tt match [reverse] goal \ldots} is, in fact, a shorthand for -{\tt once multimatch [reverse] goal \ldots}. - -\index{lazymatch goal@\texttt{lazymatch goal}!in Ltac} -\index{Ltac!lazymatch goal@\texttt{lazymatch goal}} -\index{lazymatch reverse goal@\texttt{lazymatch reverse goal}!in Ltac} -\index{Ltac!lazymatch reverse goal@\texttt{lazymatch reverse goal}} -Using {\tt lazymatch} instead of {\tt match} will perform the same -pattern matching procedure but will commit to the first matching -branch with the first matching combination of hypotheses rather than -trying a new matching if the right-hand side fails. If the right-hand -side of the selected branch is a tactic with backtracking points, then -subsequent failures cause this tactic to backtrack. - -\subsubsection[Filling a term context]{Filling a term context\index{context@\texttt{context}!in expression}} - -The following expression is not a tactic in the sense that it does not -produce subgoals but generates a term to be used in tactic -expressions: -\begin{quote} -{\tt context} {\ident} {\tt [} {\tacexpr} {\tt ]} -\end{quote} -{\ident} must denote a context variable bound by a {\tt context} -pattern of a {\tt match} expression. This expression evaluates -replaces the hole of the value of {\ident} by the value of -{\tacexpr}. - -\ErrMsg \errindex{not a context variable} - - -\subsubsection[Generating fresh hypothesis names]{Generating fresh hypothesis names\index{Ltac!fresh@\texttt{fresh}} -\index{fresh@\texttt{fresh}!in Ltac}} - -Tactics sometimes have to generate new names for hypothesis. Letting -the system decide a name with the {\tt intro} tactic is not so good -since it is very awkward to retrieve the name the system gave. -The following expression returns an identifier: -\begin{quote} -{\tt fresh} \nelist{\textrm{\textsl{component}}}{} -\end{quote} -It evaluates to an identifier unbound in the goal. This fresh -identifier is obtained by concatenating the value of the -\textrm{\textsl{component}}'s (each of them is, either an {\qualid} which -has to refer to a (unqualified) name, or directly a name denoted by a -{\qstring}). If the resulting name is already used, it is padded -with a number so that it becomes fresh. If no component is -given, the name is a fresh derivative of the name {\tt H}. - -\subsubsection[Computing in a constr]{Computing in a constr\index{Ltac!eval@\texttt{eval}} -\index{eval@\texttt{eval}!in Ltac}} - -Evaluation of a term can be performed with: -\begin{quote} -{\tt eval} {\nterm{redexpr}} {\tt in} {\term} -\end{quote} -where \nterm{redexpr} is a reduction tactic among {\tt red}, {\tt -hnf}, {\tt compute}, {\tt simpl}, {\tt cbv}, {\tt lazy}, {\tt unfold}, -{\tt fold}, {\tt pattern}. - -\subsubsection{Recovering the type of a term} -%\tacindex{type of} -\index{Ltac!type of@\texttt{type of}} -\index{type of@\texttt{type of}!in Ltac} - -The following returns the type of {\term}: - -\begin{quote} -{\tt type of} {\term} -\end{quote} - -\subsubsection[Manipulating untyped terms]{Manipulating untyped terms\index{Ltac!uconstr@\texttt{uconstr}} -\index{uconstr@\texttt{uconstr}!in Ltac} -\index{Ltac!type\_term@\texttt{type\_term}} -\index{type\_term@\texttt{type\_term}!in Ltac}} - -The terms built in Ltac are well-typed by default. It may not be -appropriate for building large terms using a recursive Ltac function: -the term has to be entirely type checked at each step, resulting in -potentially very slow behavior. It is possible to build untyped terms -using Ltac with the syntax - -\begin{quote} -{\tt uconstr :} {\term} -\end{quote} - -An untyped term, in Ltac, can contain references to hypotheses or to -Ltac variables containing typed or untyped terms. An untyped term can -be type-checked using the function {\tt type\_term} whose argument is -parsed as an untyped term and returns a well-typed term which can be -used in tactics. - -\begin{quote} -{\tt type\_term} {\term} -\end{quote} - -Untyped terms built using {\tt uconstr :} can also be used as -arguments to the {\tt refine} tactic~\ref{refine}. In that case the -untyped term is type checked against the conclusion of the goal, and -the holes which are not solved by the typing procedure are turned into -new subgoals. - -\subsubsection[Counting the goals]{Counting the goals\index{Ltac!numgoals@\texttt{numgoals}}\index{numgoals@\texttt{numgoals}!in Ltac}} - -The number of goals under focus can be recovered using the {\tt - numgoals} function. Combined with the {\tt guard} command below, it -can be used to branch over the number of goals produced by previous tactics. - -\begin{coq_example*} -Ltac pr_numgoals := let n := numgoals in idtac "There are" n "goals". - -Goal True /\ True /\ True. -split;[|split]. -\end{coq_example*} -\begin{coq_example} -all:pr_numgoals. -\end{coq_example} - -\subsubsection[Testing boolean expressions]{Testing boolean expressions\index{Ltac!guard@\texttt{guard}}\index{guard@\texttt{guard}!in Ltac}} - -The {\tt guard} tactic tests a boolean expression, and fails if the expression evaluates to false. If the expression evaluates to true, it succeeds without affecting the proof. - -\begin{quote} -{\tt guard} {\it test} -\end{quote} - -The accepted tests are simple integer comparisons. - -\begin{coq_example*} -Goal True /\ True /\ True. -split;[|split]. -\end{coq_example*} -\begin{coq_example} -all:let n:= numgoals in guard n<4. -Fail all:let n:= numgoals in guard n=2. -\end{coq_example} -\begin{ErrMsgs} - -\item \errindex{Condition not satisfied} - -\end{ErrMsgs} - -\begin{coq_eval} -Reset Initial. -\end{coq_eval} - -\subsubsection[Proving a subgoal as a separate lemma]{Proving a subgoal as a separate lemma\tacindex{abstract}\tacindex{transparent\_abstract} -\index{Tacticals!abstract@{\tt abstract}}\index{Tacticals!transparent\_abstract@{\tt transparent\_abstract}}} - -From the outside ``\texttt{abstract \tacexpr}'' is the same as -{\tt solve \tacexpr}. Internally it saves an auxiliary lemma called -{\ident}\texttt{\_subproof}\textit{n} where {\ident} is the name of the -current goal and \textit{n} is chosen so that this is a fresh name. -Such an auxiliary lemma is inlined in the final proof term. - -This tactical is useful with tactics such as \texttt{omega} or -\texttt{discriminate} that generate huge proof terms. With that tool -the user can avoid the explosion at time of the \texttt{Save} command -without having to cut manually the proof in smaller lemmas. - -It may be useful to generate lemmas minimal w.r.t. the assumptions they depend -on. This can be obtained thanks to the option below. - -\begin{Variants} -\item \texttt{abstract {\tacexpr} using {\ident}}.\\ - Give explicitly the name of the auxiliary lemma. - Use this feature at your own risk; explicitly named and reused subterms - don't play well with asynchronous proofs. -\item \texttt{transparent\_abstract {\tacexpr}}.\\ - Save the subproof in a transparent lemma rather than an opaque one. - Use this feature at your own risk; building computationally relevant terms - with tactics is fragile. -\item \texttt{transparent\_abstract {\tacexpr} using {\ident}}.\\ - Give explicitly the name of the auxiliary transparent lemma. - Use this feature at your own risk; building computationally relevant terms - with tactics is fragile, and explicitly named and reused subterms - don't play well with asynchronous proofs. -\end{Variants} - -\ErrMsg \errindex{Proof is not complete} - -\section[Tactic toplevel definitions]{Tactic toplevel definitions\comindex{Ltac}} - -\subsection{Defining {\ltac} functions} - -Basically, {\ltac} toplevel definitions are made as follows: -%{\tt Tactic Definition} {\ident} {\tt :=} {\tacexpr}\\ -% -%{\tacexpr} is evaluated to $v$ and $v$ is associated to {\ident}. Next, every -%script is evaluated by substituting $v$ to {\ident}. -% -%We can define functional definitions by:\\ -\begin{quote} -{\tt Ltac} {\ident} {\ident}$_1$ ... {\ident}$_n$ {\tt :=} -{\tacexpr} -\end{quote} -This defines a new {\ltac} function that can be used in any tactic -script or new {\ltac} toplevel definition. - -\Rem The preceding definition can equivalently be written: -\begin{quote} -{\tt Ltac} {\ident} {\tt := fun} {\ident}$_1$ ... {\ident}$_n$ -{\tt =>} {\tacexpr} -\end{quote} -Recursive and mutual recursive function definitions are also -possible with the syntax: -\begin{quote} -{\tt Ltac} {\ident}$_1$ {\ident}$_{1,1}$ ... -{\ident}$_{1,m_1}$~~{\tt :=} {\tacexpr}$_1$\\ -{\tt with} {\ident}$_2$ {\ident}$_{2,1}$ ... {\ident}$_{2,m_2}$~~{\tt :=} -{\tacexpr}$_2$\\ -...\\ -{\tt with} {\ident}$_n$ {\ident}$_{n,1}$ ... {\ident}$_{n,m_n}$~~{\tt :=} -{\tacexpr}$_n$ -\end{quote} -\medskip -It is also possible to \emph{redefine} an existing user-defined tactic -using the syntax: -\begin{quote} -{\tt Ltac} {\qualid} {\ident}$_1$ ... {\ident}$_n$ {\tt ::=} -{\tacexpr} -\end{quote} -A previous definition of {\qualid} must exist in the environment. -The new definition will always be used instead of the old one and -it goes across module boundaries. - -If preceded by the keyword {\tt Local} the tactic definition will not -be exported outside the current module. - -\subsection[Printing {\ltac} tactics]{Printing {\ltac} tactics\comindex{Print Ltac}} - -Defined {\ltac} functions can be displayed using the command - -\begin{quote} -{\tt Print Ltac {\qualid}.} -\end{quote} - -The command {\tt Print Ltac Signatures\comindex{Print Ltac Signatures}} displays a list of all user-defined tactics, with their arguments. - -\section{Debugging {\ltac} tactics} - -\subsection[Info trace]{Info trace\comindex{Info}\optindex{Info Level}} - -It is possible to print the trace of the path eventually taken by an {\ltac} script. That is, the list of executed tactics, discarding all the branches which have failed. To that end the {\tt Info} command can be used with the following syntax. - -\begin{quote} -{\tt Info} {\num} {\tacexpr}. -\end{quote} - -The number {\num} is the unfolding level of tactics in the trace. At level $0$, the trace contains a sequence of tactics in the actual script, at level $1$, the trace will be the concatenation of the traces of these tactics, etc\ldots - -\begin{coq_eval} -Reset Initial. -\end{coq_eval} -\begin{coq_example*} -Ltac t x := exists x; reflexivity. - -Goal exists n, n=0. -\end{coq_example*} -\begin{coq_example} -Info 0 t 1||t 0. -\end{coq_example} -\begin{coq_example*} -Undo. -\end{coq_example*} -\begin{coq_example} -Info 1 t 1||t 0. -\end{coq_example} - -The trace produced by {\tt Info} tries its best to be a reparsable {\ltac} script, but this goal is not achievable in all generality. So some of the output traces will contain oddities. - -As an additional help for debugging, the trace produced by {\tt Info} contains (in comments) the messages produced by the {\tt idtac} tacticals~\ref{ltac:idtac} at the right possition in the script. In particular, the calls to {\tt idtac} in branches which failed are not printed. - -An alternative to the {\tt Info} command is to use the {\tt Info Level} option as follows: - -\begin{quote} -{\tt Set Info Level} \num. -\end{quote} - -This will automatically print the same trace as {\tt Info \num} at each tactic call. The unfolding level can be overridden by a call to the {\tt Info} command. And this option can be turned off with: - -\begin{quote} -{\tt Unset Info Level} \num. -\end{quote} - -The current value for the {\tt Info Level} option can be checked using the {\tt Test Info Level} command. - -\subsection[Interactive debugger]{Interactive debugger\optindex{Ltac Debug}\optindex{Ltac Batch Debug}} - -The {\ltac} interpreter comes with a step-by-step debugger. The -debugger can be activated using the command - -\begin{quote} -{\tt Set Ltac Debug.} -\end{quote} - -\noindent and deactivated using the command - -\begin{quote} -{\tt Unset Ltac Debug.} -\end{quote} - -To know if the debugger is on, use the command \texttt{Test Ltac Debug}. -When the debugger is activated, it stops at every step of the -evaluation of the current {\ltac} expression and it prints information -on what it is doing. The debugger stops, prompting for a command which -can be one of the following: - -\medskip -\begin{tabular}{ll} -simple newline: & go to the next step\\ -h: & get help\\ -x: & exit current evaluation\\ -s: & continue current evaluation without stopping\\ -r $n$: & advance $n$ steps further\\ -r {\qstring}: & advance up to the next call to ``{\tt idtac} {\qstring}''\\ -\end{tabular} - -A non-interactive mode for the debugger is available via the command - -\begin{quote} -{\tt Set Ltac Batch Debug.} -\end{quote} - -This option has the effect of presenting a newline at every prompt, -when the debugger is on. The debug log thus created, which does not -require user input to generate when this option is set, can then be -run through external tools such as \texttt{diff}. - -\subsection[Profiling {\ltac} tactics]{Profiling {\ltac} tactics\optindex{Ltac Profiling}\comindex{Show Ltac Profile}\comindex{Reset Ltac Profile}} - -It is possible to measure the time spent in invocations of primitive tactics as well as tactics defined in {\ltac} and their inner invocations. The primary use is the development of complex tactics, which can sometimes be so slow as to impede interactive usage. The reasons for the performence degradation can be intricate, like a slowly performing {\ltac} match or a sub-tactic whose performance only degrades in certain situations. The profiler generates a call tree and indicates the time spent in a tactic depending its calling context. Thus it allows to locate the part of a tactic definition that contains the performance bug. - -\begin{quote} -{\tt Set Ltac Profiling}. -\end{quote} -Enables the profiler - -\begin{quote} -{\tt Unset Ltac Profiling}. -\end{quote} -Disables the profiler - -\begin{quote} -{\tt Show Ltac Profile}. -\end{quote} -Prints the profile - -\begin{quote} -{\tt Show Ltac Profile} {\qstring}. -\end{quote} -Prints a profile for all tactics that start with {\qstring}. Append a period (.) to the string if you only want exactly that name. - -\begin{quote} -{\tt Reset Ltac Profile}. -\end{quote} -Resets the profile, that is, deletes all accumulated information. Note that backtracking across a {\tt Reset Ltac Profile} will not restore the information. - -\begin{coq_eval} -Reset Initial. -\end{coq_eval} -\begin{coq_example*} -Require Import Coq.omega.Omega. - -Ltac mytauto := tauto. -Ltac tac := intros; repeat split; omega || mytauto. - -Notation max x y := (x + (y - x)) (only parsing). -\end{coq_example*} -\begin{coq_example*} -Goal forall x y z A B C D E F G H I J K L M N O P Q R S T U V W X Y Z, - max x (max y z) = max (max x y) z /\ max x (max y z) = max (max x y) z - /\ (A /\ B /\ C /\ D /\ E /\ F /\ G /\ H /\ I /\ J /\ K /\ L /\ M /\ N /\ O /\ P /\ Q /\ R /\ S /\ T /\ U /\ V /\ W /\ X /\ Y /\ Z - -> Z /\ Y /\ X /\ W /\ V /\ U /\ T /\ S /\ R /\ Q /\ P /\ O /\ N /\ M /\ L /\ K /\ J /\ I /\ H /\ G /\ F /\ E /\ D /\ C /\ B /\ A). -Proof. -\end{coq_example*} -\begin{coq_example} - Set Ltac Profiling. - tac. -\end{coq_example} -{\let\textit\texttt% use tt mode for the output of ltacprof -\begin{coq_example} - Show Ltac Profile. -\end{coq_example} -\begin{coq_example} - Show Ltac Profile "omega". -\end{coq_example} -} -\begin{coq_example*} -Abort. -Unset Ltac Profiling. -\end{coq_example*} - -\tacindex{start ltac profiling}\tacindex{stop ltac profiling} -The following two tactics behave like {\tt idtac} but enable and disable the profiling. They allow you to exclude parts of a proof script from profiling. - -\begin{quote} -{\tt start ltac profiling}. -\end{quote} - -\begin{quote} -{\tt stop ltac profiling}. -\end{quote} - -\tacindex{reset ltac profile}\tacindex{show ltac profile} -The following tactics behave like the corresponding vernacular commands and allow displaying and resetting the profile from tactic scripts for benchmarking purposes. - -\begin{quote} -{\tt reset ltac profile}. -\end{quote} - -\begin{quote} -{\tt show ltac profile}. -\end{quote} - -\begin{quote} -{\tt show ltac profile} {\qstring}. -\end{quote} - -You can also pass the {\tt -profile-ltac} command line option to {\tt coqc}, which performs a {\tt Set Ltac Profiling} at the beginning of each document, and a {\tt Show Ltac Profile} at the end. - -Note that the profiler currently does not handle backtracking into multi-success tactics, and issues a warning to this effect in many cases when such backtracking occurs. - -\subsection[Run-time optimization tactic]{Run-time optimization tactic\label{tactic-optimizeheap}}. - -The following tactic behaves like {\tt idtac}, and running it compacts the heap in the -OCaml run-time system. It is analogous to the Vernacular command {\tt Optimize Heap} (see~\ref{vernac-optimizeheap}). - -\tacindex{optimize\_heap} -\begin{quote} -{\tt optimize\_heap}. -\end{quote} - -\endinput - -\subsection{Permutation on closed lists} - -\begin{figure}[b] -\begin{center} -\fbox{\begin{minipage}{0.95\textwidth} -\begin{coq_eval} -Reset Initial. -\end{coq_eval} -\begin{coq_example*} -Require Import List. -Section Sort. -Variable A : Set. -Inductive permut : list A -> list A -> Prop := - | permut_refl : forall l, permut l l - | permut_cons : - forall a l0 l1, permut l0 l1 -> permut (a :: l0) (a :: l1) - | permut_append : forall a l, permut (a :: l) (l ++ a :: nil) - | permut_trans : - forall l0 l1 l2, permut l0 l1 -> permut l1 l2 -> permut l0 l2. -End Sort. -\end{coq_example*} -\end{center} -\caption{Definition of the permutation predicate} -\label{permutpred} -\end{figure} - - -Another more complex example is the problem of permutation on closed -lists. The aim is to show that a closed list is a permutation of -another one. First, we define the permutation predicate as shown on -Figure~\ref{permutpred}. - -\begin{figure}[p] -\begin{center} -\fbox{\begin{minipage}{0.95\textwidth} -\begin{coq_example} -Ltac Permut n := - match goal with - | |- (permut _ ?l ?l) => apply permut_refl - | |- (permut _ (?a :: ?l1) (?a :: ?l2)) => - let newn := eval compute in (length l1) in - (apply permut_cons; Permut newn) - | |- (permut ?A (?a :: ?l1) ?l2) => - match eval compute in n with - | 1 => fail - | _ => - let l1' := constr:(l1 ++ a :: nil) in - (apply (permut_trans A (a :: l1) l1' l2); - [ apply permut_append | compute; Permut (pred n) ]) - end - end. -Ltac PermutProve := - match goal with - | |- (permut _ ?l1 ?l2) => - match eval compute in (length l1 = length l2) with - | (?n = ?n) => Permut n - end - end. -\end{coq_example} -\end{minipage}} -\end{center} -\caption{Permutation tactic} -\label{permutltac} -\end{figure} - -\begin{figure}[p] -\begin{center} -\fbox{\begin{minipage}{0.95\textwidth} -\begin{coq_example*} -Lemma permut_ex1 : - permut nat (1 :: 2 :: 3 :: nil) (3 :: 2 :: 1 :: nil). -Proof. -PermutProve. -Qed. - -Lemma permut_ex2 : - permut nat - (0 :: 1 :: 2 :: 3 :: 4 :: 5 :: 6 :: 7 :: 8 :: 9 :: nil) - (0 :: 2 :: 4 :: 6 :: 8 :: 9 :: 7 :: 5 :: 3 :: 1 :: nil). -Proof. -PermutProve. -Qed. -\end{coq_example*} -\end{minipage}} -\end{center} -\caption{Examples of {\tt PermutProve} use} -\label{permutlem} -\end{figure} - -Next, we can write naturally the tactic and the result can be seen on -Figure~\ref{permutltac}. We can notice that we use two toplevel -definitions {\tt PermutProve} and {\tt Permut}. The function to be -called is {\tt PermutProve} which computes the lengths of the two -lists and calls {\tt Permut} with the length if the two lists have the -same length. {\tt Permut} works as expected. If the two lists are -equal, it concludes. Otherwise, if the lists have identical first -elements, it applies {\tt Permut} on the tail of the lists. Finally, -if the lists have different first elements, it puts the first element -of one of the lists (here the second one which appears in the {\tt - permut} predicate) at the end if that is possible, i.e., if the new -first element has been at this place previously. To verify that all -rotations have been done for a list, we use the length of the list as -an argument for {\tt Permut} and this length is decremented for each -rotation down to, but not including, 1 because for a list of length -$n$, we can make exactly $n-1$ rotations to generate at most $n$ -distinct lists. Here, it must be noticed that we use the natural -numbers of {\Coq} for the rotation counter. On Figure~\ref{ltac}, we -can see that it is possible to use usual natural numbers but they are -only used as arguments for primitive tactics and they cannot be -handled, in particular, we cannot make computations with them. So, a -natural choice is to use {\Coq} data structures so that {\Coq} makes -the computations (reductions) by {\tt eval compute in} and we can get -the terms back by {\tt match}. - -With {\tt PermutProve}, we can now prove lemmas such those shown on -Figure~\ref{permutlem}. - - -\subsection{Deciding intuitionistic propositional logic} - -\begin{figure}[tbp] -\begin{center} -\fbox{\begin{minipage}{0.95\textwidth} -\begin{coq_example} -Ltac Axioms := - match goal with - | |- True => trivial - | _:False |- _ => elimtype False; assumption - | _:?A |- ?A => auto - end. -Ltac DSimplif := - repeat - (intros; - match goal with - | id:(~ _) |- _ => red in id - | id:(_ /\ _) |- _ => - elim id; do 2 intro; clear id - | id:(_ \/ _) |- _ => - elim id; intro; clear id - | id:(?A /\ ?B -> ?C) |- _ => - cut (A -> B -> C); - [ intro | intros; apply id; split; assumption ] - | id:(?A \/ ?B -> ?C) |- _ => - cut (B -> C); - [ cut (A -> C); - [ intros; clear id - | intro; apply id; left; assumption ] - | intro; apply id; right; assumption ] - | id0:(?A -> ?B),id1:?A |- _ => - cut B; [ intro; clear id0 | apply id0; assumption ] - | |- (_ /\ _) => split - | |- (~ _) => red - end). -\end{coq_example} -\end{minipage}} -\end{center} -\caption{Deciding intuitionistic propositions (1)} -\label{tautoltaca} -\end{figure} - -\begin{figure} -\begin{center} -\fbox{\begin{minipage}{0.95\textwidth} -\begin{coq_example} -Ltac TautoProp := - DSimplif; - Axioms || - match goal with - | id:((?A -> ?B) -> ?C) |- _ => - cut (B -> C); - [ intro; cut (A -> B); - [ intro; cut C; - [ intro; clear id | apply id; assumption ] - | clear id ] - | intro; apply id; intro; assumption ]; TautoProp - | id:(~ ?A -> ?B) |- _ => - cut (False -> B); - [ intro; cut (A -> False); - [ intro; cut B; - [ intro; clear id | apply id; assumption ] - | clear id ] - | intro; apply id; red; intro; assumption ]; TautoProp - | |- (_ \/ _) => (left; TautoProp) || (right; TautoProp) - end. -\end{coq_example} -\end{minipage}} -\end{center} -\caption{Deciding intuitionistic propositions (2)} -\label{tautoltacb} -\end{figure} - -The pattern matching on goals allows a complete and so a powerful -backtracking when returning tactic values. An interesting application -is the problem of deciding intuitionistic propositional logic. -Considering the contraction-free sequent calculi {\tt LJT*} of -Roy~Dyckhoff (\cite{Dyc92}), it is quite natural to code such a tactic -using the tactic language. On Figure~\ref{tautoltaca}, the tactic {\tt - Axioms} tries to conclude using usual axioms. The {\tt DSimplif} -tactic applies all the reversible rules of Dyckhoff's system. -Finally, on Figure~\ref{tautoltacb}, the {\tt TautoProp} tactic (the -main tactic to be called) simplifies with {\tt DSimplif}, tries to -conclude with {\tt Axioms} and tries several paths using the -backtracking rules (one of the four Dyckhoff's rules for the left -implication to get rid of the contraction and the right or). - -\begin{figure}[tb] -\begin{center} -\fbox{\begin{minipage}{0.95\textwidth} -\begin{coq_example*} -Lemma tauto_ex1 : forall A B:Prop, A /\ B -> A \/ B. -Proof. -TautoProp. -Qed. - -Lemma tauto_ex2 : - forall A B:Prop, (~ ~ B -> B) -> (A -> B) -> ~ ~ A -> B. -Proof. -TautoProp. -Qed. -\end{coq_example*} -\end{minipage}} -\end{center} -\caption{Proofs of tautologies with {\tt TautoProp}} -\label{tautolem} -\end{figure} - -For example, with {\tt TautoProp}, we can prove tautologies like those of -Figure~\ref{tautolem}. - - -\subsection{Deciding type isomorphisms} - -A more tricky problem is to decide equalities between types and modulo -isomorphisms. Here, we choose to use the isomorphisms of the simply typed -$\lb{}$-calculus with Cartesian product and $unit$ type (see, for example, -\cite{RC95}). The axioms of this $\lb{}$-calculus are given by -Figure~\ref{isosax}. - -\begin{figure} -\begin{center} -\fbox{\begin{minipage}{0.95\textwidth} -\begin{coq_eval} -Reset Initial. -\end{coq_eval} -\begin{coq_example*} -Open Scope type_scope. -Section Iso_axioms. -Variables A B C : Set. -Axiom Com : A * B = B * A. -Axiom Ass : A * (B * C) = A * B * C. -Axiom Cur : (A * B -> C) = (A -> B -> C). -Axiom Dis : (A -> B * C) = (A -> B) * (A -> C). -Axiom P_unit : A * unit = A. -Axiom AR_unit : (A -> unit) = unit. -Axiom AL_unit : (unit -> A) = A. -Lemma Cons : B = C -> A * B = A * C. -Proof. -intro Heq; rewrite Heq; reflexivity. -Qed. -End Iso_axioms. -\end{coq_example*} -\end{minipage}} -\end{center} -\caption{Type isomorphism axioms} -\label{isosax} -\end{figure} - -The tactic to judge equalities modulo this axiomatization can be written as -shown on Figures~\ref{isosltac1} and~\ref{isosltac2}. The algorithm is quite -simple. Types are reduced using axioms that can be oriented (this done by {\tt -MainSimplif}). The normal forms are sequences of Cartesian -products without Cartesian product in the left component. These normal forms -are then compared modulo permutation of the components (this is done by {\tt -CompareStruct}). The main tactic to be called and realizing this algorithm is -{\tt IsoProve}. - -\begin{figure} -\begin{center} -\fbox{\begin{minipage}{0.95\textwidth} -\begin{coq_example} -Ltac DSimplif trm := - match trm with - | (?A * ?B * ?C) => - rewrite <- (Ass A B C); try MainSimplif - | (?A * ?B -> ?C) => - rewrite (Cur A B C); try MainSimplif - | (?A -> ?B * ?C) => - rewrite (Dis A B C); try MainSimplif - | (?A * unit) => - rewrite (P_unit A); try MainSimplif - | (unit * ?B) => - rewrite (Com unit B); try MainSimplif - | (?A -> unit) => - rewrite (AR_unit A); try MainSimplif - | (unit -> ?B) => - rewrite (AL_unit B); try MainSimplif - | (?A * ?B) => - (DSimplif A; try MainSimplif) || (DSimplif B; try MainSimplif) - | (?A -> ?B) => - (DSimplif A; try MainSimplif) || (DSimplif B; try MainSimplif) - end - with MainSimplif := - match goal with - | |- (?A = ?B) => try DSimplif A; try DSimplif B - end. -Ltac Length trm := - match trm with - | (_ * ?B) => let succ := Length B in constr:(S succ) - | _ => constr:1 - end. -Ltac assoc := repeat rewrite <- Ass. -\end{coq_example} -\end{minipage}} -\end{center} -\caption{Type isomorphism tactic (1)} -\label{isosltac1} -\end{figure} - -\begin{figure} -\begin{center} -\fbox{\begin{minipage}{0.95\textwidth} -\begin{coq_example} -Ltac DoCompare n := - match goal with - | [ |- (?A = ?A) ] => reflexivity - | [ |- (?A * ?B = ?A * ?C) ] => - apply Cons; let newn := Length B in DoCompare newn - | [ |- (?A * ?B = ?C) ] => - match eval compute in n with - | 1 => fail - | _ => - pattern (A * B) at 1; rewrite Com; assoc; DoCompare (pred n) - end - end. -Ltac CompareStruct := - match goal with - | [ |- (?A = ?B) ] => - let l1 := Length A - with l2 := Length B in - match eval compute in (l1 = l2) with - | (?n = ?n) => DoCompare n - end - end. -Ltac IsoProve := MainSimplif; CompareStruct. -\end{coq_example} -\end{minipage}} -\end{center} -\caption{Type isomorphism tactic (2)} -\label{isosltac2} -\end{figure} - -Figure~\ref{isoslem} gives examples of what can be solved by {\tt IsoProve}. - -\begin{figure} -\begin{center} -\fbox{\begin{minipage}{0.95\textwidth} -\begin{coq_example*} -Lemma isos_ex1 : - forall A B:Set, A * unit * B = B * (unit * A). -Proof. -intros; IsoProve. -Qed. - -Lemma isos_ex2 : - forall A B C:Set, - (A * unit -> B * (C * unit)) = - (A * unit -> (C -> unit) * C) * (unit -> A -> B). -Proof. -intros; IsoProve. -Qed. -\end{coq_example*} -\end{minipage}} -\end{center} -\caption{Type equalities solved by {\tt IsoProve}} -\label{isoslem} -\end{figure} - -%%% Local Variables: -%%% mode: latex -%%% TeX-master: "Reference-Manual" -%%% End: diff --git a/doc/refman/RefMan-oth.tex b/doc/refman/RefMan-oth.tex deleted file mode 100644 index bef31d3fa..000000000 --- a/doc/refman/RefMan-oth.tex +++ /dev/null @@ -1,1224 +0,0 @@ -\chapter[Vernacular commands]{Vernacular commands\label{Vernacular-commands} -\label{Other-commands}} -%HEVEA\cutname{vernacular.html} - -\section{Displaying} - -\subsection[\tt Print {\qualid}.]{\tt Print {\qualid}.\comindex{Print}} -This command displays on the screen information about the declared or -defined object referred by {\qualid}. - -\begin{ErrMsgs} -\item {\qualid} \errindex{not a defined object} -\item \errindex{Universe instance should have length} $n$. -\item \errindex{This object does not support universe names.} -\end{ErrMsgs} - -\begin{Variants} -\item {\tt Print Term {\qualid}.} -\comindex{Print Term}\\ -This is a synonym to {\tt Print {\qualid}} when {\qualid} denotes a -global constant. - -\item {\tt About {\qualid}.} -\label{About} -\comindex{About}\\ -This displays various information about the object denoted by {\qualid}: -its kind (module, constant, assumption, inductive, -constructor, abbreviation, \ldots), long name, type, implicit -arguments and argument scopes. It does not print the body of -definitions or proofs. - -\item {\tt Print {\qualid}@\{names\}.}\\ -This locally renames the polymorphic universes of {\qualid}. -An underscore means the raw universe is printed. -This form can be used with {\tt Print Term} and {\tt About}. - -%\item {\tt Print Proof {\qualid}.}\comindex{Print Proof}\\ -%In case \qualid\ denotes an opaque theorem defined in a section, -%it is stored on a special unprintable form and displayed as -%{\tt <recipe>}. {\tt Print Proof} forces the printable form of \qualid\ -%to be computed and displays it. -\end{Variants} - -\subsection[\tt Print All.]{\tt Print All.\comindex{Print All}} -This command displays information about the current state of the -environment, including sections and modules. - -\begin{Variants} -\item {\tt Inspect \num.}\comindex{Inspect}\\ -This command displays the {\num} last objects of the current -environment, including sections and modules. -\item {\tt Print Section {\ident}.}\comindex{Print Section}\\ -should correspond to a currently open section, this command -displays the objects defined since the beginning of this section. -% Discontinued -%% \item {\tt Print.}\comindex{Print}\\ -%% This command displays the axioms and variables declarations in the -%% environment as well as the constants defined since the last variable -%% was introduced. -\end{Variants} - -\section{Flags, Options and Tables} - -{\Coq} configurability is based on flags (e.g. {\tt Set Printing All} in -Section~\ref{SetPrintingAll}), options (e.g. {\tt Set Printing Width - {\integer}} in Section~\ref{SetPrintingWidth}), or tables (e.g. {\tt - Add Printing Record {\ident}}, in Section~\ref{AddPrintingLet}). The -names of flags, options and tables are made of non-empty sequences of -identifiers (conventionally with capital initial letter). The general -commands handling flags, options and tables are given below. - -\subsection[\tt Set {\rm\sl flag}.]{\tt Set {\rm\sl flag}.\comindex{Set}} -This command switches {\rm\sl flag} on. The original state of -{\rm\sl flag} is restored when the current module ends. - -\begin{Variants} -\item {\tt Local Set {\rm\sl flag}.}\\ -This command switches {\rm\sl flag} on. The original state of -{\rm\sl flag} is restored when the current \emph{section} ends. -\item {\tt Global Set {\rm\sl flag}.}\\ -This command switches {\rm\sl flag} on. The original state of -{\rm\sl flag} is \emph{not} restored at the end of the module. Additionally, -if set in a file, {\rm\sl flag} is switched on when the file is -{\tt Require}-d. -\end{Variants} - -\subsection[\tt Unset {\rm\sl flag}.]{\tt Unset {\rm\sl flag}.\comindex{Unset}} -This command switches {\rm\sl flag} off. The original state of {\rm\sl flag} -is restored when the current module ends. - -\begin{Variants} -\item {\tt Local Unset {\rm\sl flag}.\comindex{Local Unset}}\\ -This command switches {\rm\sl flag} off. The original state of {\rm\sl flag} -is restored when the current \emph{section} ends. -\item {\tt Global Unset {\rm\sl flag}.\comindex{Global Unset}}\\ -This command switches {\rm\sl flag} off. The original state of -{\rm\sl flag} is \emph{not} restored at the end of the module. Additionally, -if set in a file, {\rm\sl flag} is switched off when the file is -{\tt Require}-d. -\end{Variants} - -\subsection[\tt Test {\rm\sl flag}.]{\tt Test {\rm\sl flag}.\comindex{Test}} -This command prints whether {\rm\sl flag} is on or off. - -\subsection[\tt Set {\rm\sl option} {\rm\sl value}.]{\tt Set {\rm\sl option} {\rm\sl value}.\comindex{Set}} -This command sets {\rm\sl option} to {\rm\sl value}. The original value of -{\rm\sl option} is restored when the current module ends. - -\begin{Variants} -\item {\tt Local Set {\rm\sl option} {\rm\sl value}.\comindex{Local Set}} -This command sets {\rm\sl option} to {\rm\sl value}. The original value of -{\rm\sl option} is restored at the end of the module. -\item {\tt Global Set {\rm\sl option} {\rm\sl value}.\comindex{Global Set}} -This command sets {\rm\sl option} to {\rm\sl value}. The original value of -{\rm\sl option} is \emph{not} restored at the end of the module. Additionally, -if set in a file, {\rm\sl option} is set to {\rm\sl value} when the file is -{\tt Require}-d. -\end{Variants} - -\subsection[\tt Unset {\rm\sl option}.]{\tt Unset {\rm\sl option}.\comindex{Unset}} -This command resets {\rm\sl option} to its default value. - -\begin{Variants} -\item {\tt Local Unset {\rm\sl option}.\comindex{Local Unset}}\\ -This command resets {\rm\sl option} to its default value. The original state of {\rm\sl option} -is restored when the current \emph{section} ends. -\item {\tt Global Unset {\rm\sl option}.\comindex{Global Unset}}\\ -This command resets {\rm\sl option} to its default value. The original state of -{\rm\sl option} is \emph{not} restored at the end of the module. Additionally, -if unset in a file, {\rm\sl option} is reset to its default value when the file is -{\tt Require}-d. -\end{Variants} - -\subsection[\tt Test {\rm\sl option}.]{\tt Test {\rm\sl option}.\comindex{Test}} -This command prints the current value of {\rm\sl option}. - -\subsection{Tables} -The general commands for tables are {\tt Add {\rm\sf table} {\rm\sl - value}}, {\tt Remove {\rm\sf table} {\rm\sl value}}, {\tt Test - {\rm\sf table}}, {\tt Test {\rm\sf table} for {\rm\sl value}} and - {\tt Print Table {\rm\sf table}}. - -\subsection[\tt Print Options.]{\tt Print Options.\comindex{Print Options}} -This command lists all available flags, options and tables. - -\begin{Variants} -\item {\tt Print Tables}.\comindex{Print Tables}\\ -This is a synonymous of {\tt Print Options.} -\end{Variants} - -\section{Requests to the environment} - -\subsection[\tt Check {\term}.]{\tt Check {\term}.\label{Check} -\comindex{Check}} -This command displays the type of {\term}. When called in proof mode, -the term is checked in the local context of the current subgoal. - -\begin{Variants} -\item {\tt selector: Check {\term}}.\\ -specifies on which subgoal to perform typing (see - Section~\ref{tactic-syntax}). -\end{Variants} - - -\subsection[\tt Eval {\rm\sl convtactic} in {\term}.]{\tt Eval {\rm\sl convtactic} in {\term}.\comindex{Eval}} - -This command performs the specified reduction on {\term}, and displays -the resulting term with its type. The term to be reduced may depend on -hypothesis introduced in the first subgoal (if a proof is in -progress). - -\SeeAlso Section~\ref{Conversion-tactics}. - -\subsection[\tt Compute {\term}.]{\tt Compute {\term}.\comindex{Compute}} - -This command performs a call-by-value evaluation of {\term} by using -the bytecode-based virtual machine. It is a shortcut for -{\tt Eval vm\_compute in {\term}}. - -\SeeAlso Section~\ref{Conversion-tactics}. - -\subsection[\tt Extraction \term.]{\tt Extraction \term.\label{ExtractionTerm} -\comindex{Extraction}} -This command displays the extracted term from -{\term}. The extraction is processed according to the distinction -between {\Set} and {\Prop}; that is to say, between logical and -computational content (see Section~\ref{Sorts}). The extracted term is -displayed in {\ocaml} syntax, where global identifiers are still -displayed as in \Coq\ terms. - -\begin{Variants} -\item \texttt{Recursive Extraction} {\qualid$_1$} \ldots{} {\qualid$_n$}{\tt .}\\ - Recursively extracts all the material needed for the extraction of - global {\qualid$_1$}, \ldots, {\qualid$_n$}. -\end{Variants} - -\SeeAlso Chapter~\ref{Extraction}. - -\subsection[\tt Print Assumptions {\qualid}.]{\tt Print Assumptions {\qualid}.\comindex{Print Assumptions}} -\label{PrintAssumptions} - -This commands display all the assumptions (axioms, parameters and -variables) a theorem or definition depends on. Especially, it informs -on the assumptions with respect to which the validity of a theorem -relies. - -\begin{Variants} -\item \texttt{\tt Print Opaque Dependencies {\qualid}. - \comindex{Print Opaque Dependencies}}\\ - Displays the set of opaque constants {\qualid} relies on in addition - to the assumptions. -\item \texttt{\tt Print Transparent Dependencies {\qualid}. - \comindex{Print Transparent Dependencies}}\\ - Displays the set of transparent constants {\qualid} relies on in addition - to the assumptions. -\item \texttt{\tt Print All Dependencies {\qualid}. - \comindex{Print All Dependencies}}\\ - Displays all assumptions and constants {\qualid} relies on. -\end{Variants} - -\subsection[\tt Search {\qualid}.]{\tt Search {\qualid}.\comindex{Search}} -This command displays the name and type of all objects (hypothesis of -the current goal, theorems, axioms, etc) of the current context whose -statement contains \qualid. This command is useful to remind the user -of the name of library lemmas. - -\begin{ErrMsgs} -\item \errindex{The reference \qualid\ was not found in the current -environment}\\ - There is no constant in the environment named \qualid. -\end{ErrMsgs} - -\newcommand{\termpatternorstr}{{\termpattern}\textrm{\textsl{-}}{\str}} - -\begin{Variants} -\item {\tt Search {\str}.} - -If {\str} is a valid identifier, this command displays the name and type -of all objects (theorems, axioms, etc) of the current context whose -name contains {\str}. If {\str} is a notation's string denoting some -reference {\qualid} (referred to by its main symbol as in \verb="+"= -or by its notation's string as in \verb="_ + _"= or \verb="_ 'U' _"=, see -Section~\ref{Notation}), the command works like {\tt Search -{\qualid}}. - -\item {\tt Search {\str}\%{\delimkey}.} - -The string {\str} must be a notation or the main symbol of a notation -which is then interpreted in the scope bound to the delimiting key -{\delimkey} (see Section~\ref{scopechange}). - -\item {\tt Search {\termpattern}.} - -This searches for all statements or types of definition that contains -a subterm that matches the pattern {\termpattern} (holes of the -pattern are either denoted by ``{\texttt \_}'' or -by ``{\texttt ?{\ident}}'' when non linear patterns are expected). - -\item {\tt Search \nelist{\zeroone{-}{\termpatternorstr}}{}.}\\ - -\noindent where {\termpatternorstr} is a -{\termpattern} or a {\str}, or a {\str} followed by a scope -delimiting key {\tt \%{\delimkey}}. - -This generalization of {\tt Search} searches for all objects -whose statement or type contains a subterm matching {\termpattern} (or -{\qualid} if {\str} is the notation for a reference {\qualid}) and -whose name contains all {\str} of the request that correspond to valid -identifiers. If a {\termpattern} or a {\str} is prefixed by ``-'', the -search excludes the objects that mention that {\termpattern} or that -{\str}. - -\item - {\tt Search} \nelist{{\termpatternorstr}}{} - {\tt inside} {\module$_1$} \ldots{} {\module$_n$}{\tt .} - -This restricts the search to constructions defined in modules -{\module$_1$} \ldots{} {\module$_n$}. - -\item - {\tt Search \nelist{{\termpatternorstr}}{} - outside {\module$_1$}...{\module$_n$}.} - -This restricts the search to constructions not defined in modules -{\module$_1$} \ldots{} {\module$_n$}. - -\item {\tt selector: Search \nelist{\zeroone{-}{\termpatternorstr}}{}.} - - This specifies the goal on which to search hypothesis (see - Section~\ref{tactic-syntax}). By default the 1st goal is searched. - This variant can be combined with other variants presented here. -\end{Variants} - -\examples - -\begin{coq_example*} -Require Import ZArith. -\end{coq_example*} -\begin{coq_example} -Search Z.mul Z.add "distr". -Search "+"%Z "*"%Z "distr" -positive -Prop. -Search (?x * _ + ?x * _)%Z outside OmegaLemmas. -\end{coq_example} - -\Warning \comindex{SearchAbout} Up to {\Coq} version 8.4, {\tt Search} -had the behavior of current {\tt SearchHead} and the behavior of -current {\tt Search} was obtained with command {\tt SearchAbout}. For -compatibility, the deprecated name {\tt SearchAbout} can still be used -as a synonym of {\tt Search}. For compatibility, the list of objects to -search when using {\tt SearchAbout} may also be enclosed by optional -{\tt [ ]} delimiters. - -\subsection[\tt SearchHead {\term}.]{\tt SearchHead {\term}.\comindex{SearchHead}} -This command displays the name and type of all hypothesis of the -current goal (if any) and theorems of the current context whose -statement's conclusion has the form {\tt ({\term} t1 .. - tn)}. This command is useful to remind the user of the name of -library lemmas. - -\begin{coq_eval} -Reset Initial. -\end{coq_eval} - -\begin{coq_example} -SearchHead le. -SearchHead (@eq bool). -\end{coq_example} - -\begin{Variants} -\item -{\tt SearchHead} {\term} {\tt inside} {\module$_1$} \ldots{} {\module$_n$}{\tt .} - -This restricts the search to constructions defined in modules -{\module$_1$} \ldots{} {\module$_n$}. - -\item {\tt SearchHead} {\term} {\tt outside} {\module$_1$} \ldots{} {\module$_n$}{\tt .} - -This restricts the search to constructions not defined in modules -{\module$_1$} \ldots{} {\module$_n$}. - -\begin{ErrMsgs} -\item \errindex{Module/section \module{} not found} -No module \module{} has been required (see Section~\ref{Require}). -\end{ErrMsgs} - -\item {\tt selector: SearchHead {\term}.} - - This specifies the goal on which to search hypothesis (see - Section~\ref{tactic-syntax}). By default the 1st goal is searched. - This variant can be combined with other variants presented here. - -\end{Variants} - -\Warning Up to {\Coq} version 8.4, {\tt SearchHead} was named {\tt Search}. - -\subsection[\tt SearchPattern {\termpattern}.]{\tt SearchPattern {\term}.\comindex{SearchPattern}} - -This command displays the name and type of all hypothesis of the -current goal (if any) and theorems of the current context whose statement's -conclusion or last hypothesis and conclusion matches the expression -{\term} where holes in the latter are denoted by ``{\texttt \_}''. It -is a variant of {\tt Search - {\termpattern}} that does not look for subterms but searches for -statements whose conclusion has exactly the expected form, or whose -statement finishes by the given series of hypothesis/conclusion. - -\begin{coq_example*} -Require Import Arith. -\end{coq_example*} -\begin{coq_example} -SearchPattern (_ + _ = _ + _). -SearchPattern (nat -> bool). -SearchPattern (forall l : list _, _ l l). -\end{coq_example} - -Patterns need not be linear: you can express that the same expression -must occur in two places by using pattern variables `{\texttt -?{\ident}}''. - -\begin{coq_example} -SearchPattern (?X1 + _ = _ + ?X1). -\end{coq_example} - -\begin{Variants} -\item {\tt SearchPattern {\term} inside -{\module$_1$} \ldots{} {\module$_n$}.} - -This restricts the search to constructions defined in modules -{\module$_1$} \ldots{} {\module$_n$}. - -\item {\tt SearchPattern {\term} outside {\module$_1$} \ldots{} {\module$_n$}.} - -This restricts the search to constructions not defined in modules -{\module$_1$} \ldots{} {\module$_n$}. - -\item {\tt selector: SearchPattern {\term}.} - - This specifies the goal on which to search hypothesis (see - Section~\ref{tactic-syntax}). By default the 1st goal is searched. - This variant can be combined with other variants presented here. - -\end{Variants} - -\subsection[\tt SearchRewrite {\term}.]{\tt SearchRewrite {\term}.\comindex{SearchRewrite}} - -This command displays the name and type of all hypothesis of the -current goal (if any) and theorems of the current context whose -statement's conclusion is an equality of which one side matches the -expression {\term}. Holes in {\term} are denoted by ``{\texttt \_}''. - -\begin{coq_example} -Require Import Arith. -SearchRewrite (_ + _ + _). -\end{coq_example} - -\begin{Variants} -\item {\tt SearchRewrite {\term} inside -{\module$_1$} \ldots{} {\module$_n$}.} - -This restricts the search to constructions defined in modules -{\module$_1$} \ldots{} {\module$_n$}. - -\item {\tt SearchRewrite {\term} outside {\module$_1$} \ldots{} {\module$_n$}.} - -This restricts the search to constructions not defined in modules -{\module$_1$} \ldots{} {\module$_n$}. - -\item {\tt selector: SearchRewrite {\term}.} - - This specifies the goal on which to search hypothesis (see - Section~\ref{tactic-syntax}). By default the 1st goal is searched. - This variant can be combined with other variants presented here. - -\end{Variants} - -\subsubsection{Nota Bene:} -For the {\tt Search}, {\tt SearchHead}, {\tt SearchPattern} and -{\tt SearchRewrite} queries, it is possible to globally filter -the search results via the command -{\tt Add Search Blacklist "substring1"}. -A lemma whose fully-qualified name contains any of the declared substrings -will be removed from the search results. -The default blacklisted substrings are {\tt - "\_subproof" "Private\_"}. The command {\tt Remove Search Blacklist - ...} allows expunging this blacklist. - -% \begin{tabbing} -% \ \ \ \ \=11.\ \=\kill -% \>1.\>$A=B\mx{ if }A\stackrel{\bt{}\io{}}{\lra{}}B$\\ -% \>2.\>$\sa{}x:A.B=\sa{}y:A.B[x\la{}y]\mx{ if }y\not\in{}FV(\sa{}x:A.B)$\\ -% \>3.\>$\Pi{}x:A.B=\Pi{}y:A.B[x\la{}y]\mx{ if }y\not\in{}FV(\Pi{}x:A.B)$\\ -% \>4.\>$\sa{}x:A.B=\sa{}x:B.A\mx{ if }x\not\in{}FV(A,B)$\\ -% \>5.\>$\sa{}x:(\sa{}y:A.B).C=\sa{}x:A.\sa{}y:B[y\la{}x].C[x\la{}(x,y)]$\\ -% \>6.\>$\Pi{}x:(\sa{}y:A.B).C=\Pi{}x:A.\Pi{}y:B[y\la{}x].C[x\la{}(x,y)]$\\ -% \>7.\>$\Pi{}x:A.\sa{}y:B.C=\sa{}y:(\Pi{}x:A.B).(\Pi{}x:A.C[y\la{}(y\sm{}x)]$\\ -% \>8.\>$\sa{}x:A.unit=A$\\ -% \>9.\>$\sa{}x:unit.A=A[x\la{}tt]$\\ -% \>10.\>$\Pi{}x:A.unit=unit$\\ -% \>11.\>$\Pi{}x:unit.A=A[x\la{}tt]$ -% \end{tabbing} - -% For more informations about the exact working of this command, see -% \cite{Del97}. - -\subsection[\tt Locate {\qualid}.]{\tt Locate {\qualid}.\comindex{Locate} -\label{Locate}} -This command displays the full name of objects whose name is a prefix of the -qualified identifier {\qualid}, and consequently the \Coq\ module in which they -are defined. It searches for objects from the different qualified name spaces of -{\Coq}: terms, modules, Ltac, etc. - -\begin{coq_eval} -(*************** The last line should produce **************************) -(*********** Error: I.Dont.Exist not a defined object ******************) -\end{coq_eval} -\begin{coq_eval} -Set Printing Depth 50. -\end{coq_eval} -\begin{coq_example} -Locate nat. -Locate Datatypes.O. -Locate Init.Datatypes.O. -Locate Coq.Init.Datatypes.O. -Locate I.Dont.Exist. -\end{coq_example} - -\begin{Variants} -\item {\tt Locate Term {\qualid}.}\comindex{Locate Term}\\ - As {\tt Locate} but restricted to terms. - -\item {\tt Locate Module {\qualid}.} - As {\tt Locate} but restricted to modules. - -\item {\tt Locate Ltac {\qualid}.}\comindex{Locate Ltac}\\ - As {\tt Locate} but restricted to tactics. -\end{Variants} - - -\SeeAlso Section \ref{LocateSymbol} - -\section{Loading files} - -\Coq\ offers the possibility of loading different -parts of a whole development stored in separate files. Their contents -will be loaded as if they were entered from the keyboard. This means -that the loaded files are ASCII files containing sequences of commands -for \Coq's toplevel. This kind of file is called a {\em script} for -\Coq\index{Script file}. The standard (and default) extension of -\Coq's script files is {\tt .v}. - -\subsection[\tt Load {\ident}.]{\tt Load {\ident}.\comindex{Load}\label{Load}} -This command loads the file named {\ident}{\tt .v}, searching -successively in each of the directories specified in the {\em - loadpath}. (see Section~\ref{loadpath}) - -Files loaded this way cannot leave proofs open, and neither the {\tt - Load} command can be use inside a proof. - -\begin{Variants} -\item {\tt Load {\str}.}\label{Load-str}\\ - Loads the file denoted by the string {\str}, where {\str} is any - complete filename. Then the \verb.~. and {\tt ..} - abbreviations are allowed as well as shell variables. If no - extension is specified, \Coq\ will use the default extension {\tt - .v} -\item {\tt Load Verbose {\ident}.}, - {\tt Load Verbose {\str}}\\ - \comindex{Load Verbose} - Display, while loading, the answers of \Coq\ to each command - (including tactics) contained in the loaded file - \SeeAlso Section~\ref{Begin-Silent} -\end{Variants} - -\begin{ErrMsgs} -\item \errindex{Can't find file {\ident} on loadpath} -\item \errindex{Load is not supported inside proofs} -\item \errindex{Files processed by Load cannot leave open proofs} -\end{ErrMsgs} - -\section[Compiled files]{Compiled files\label{compiled}\index{Compiled files}} - -This section describes the commands used to load compiled files (see -Chapter~\ref{Addoc-coqc} for documentation on how to compile a file). -A compiled file is a particular case of module called {\em library file}. - -%%%%%%%%%%%% -% Import and Export described in RefMan-mod.tex -% the minor difference (to avoid multiple Exporting of libraries) in -% the treatment of normal modules and libraries by Export omitted - -\subsection[\tt Require {\qualid}.]{\tt Require {\qualid}.\label{Require} -\comindex{Require}} - -This command looks in the loadpath for a file containing -module {\qualid} and adds the corresponding module to the environment -of {\Coq}. As library files have dependencies in other library files, -the command {\tt Require {\qualid}} recursively requires all library -files the module {\qualid} depends on and adds the corresponding modules to the -environment of {\Coq} too. {\Coq} assumes that the compiled files have -been produced by a valid {\Coq} compiler and their contents are then not -replayed nor rechecked. - -To locate the file in the file system, {\qualid} is decomposed under -the form {\dirpath}{\tt .}{\textsl{ident}} and the file {\ident}{\tt -.vo} is searched in the physical directory of the file system that is -mapped in {\Coq} loadpath to the logical path {\dirpath} (see -Section~\ref{loadpath}). The mapping between physical directories and -logical names at the time of requiring the file must be consistent -with the mapping used to compile the file. If several files match, one of them -is picked in an unspecified fashion. - -\begin{Variants} -\item {\tt Require Import {\qualid}.} \comindex{Require Import} - - This loads and declares the module {\qualid} and its dependencies - then imports the contents of {\qualid} as described in - Section~\ref{Import}. - - It does not import the modules on which {\qualid} depends unless - these modules were itself required in module {\qualid} using {\tt - Require Export}, as described below, or recursively required through - a sequence of {\tt Require Export}. - - If the module required has already been loaded, {\tt Require Import - {\qualid}} simply imports it, as {\tt Import {\qualid}} would. - -\item {\tt Require Export {\qualid}.} - \comindex{Require Export} - - This command acts as {\tt Require Import} {\qualid}, but if a - further module, say {\it A}, contains a command {\tt Require - Export} {\it B}, then the command {\tt Require Import} {\it A} - also imports the module {\it B}. - -\item {\tt Require \zeroone{Import {\sl |} Export}} {\qualid}$_1$ {\ldots} {\qualid}$_n${\tt .} - - This loads the modules {\qualid}$_1$, \ldots, {\qualid}$_n$ and - their recursive dependencies. If {\tt Import} or {\tt Export} is - given, it also imports {\qualid}$_1$, \ldots, {\qualid}$_n$ and all - the recursive dependencies that were marked or transitively marked - as {\tt Export}. - -\item {\tt From {\dirpath} Require {\qualid}.} - \comindex{From Require} - - This command acts as {\tt Require}, but picks any library whose absolute name - is of the form {\tt{\dirpath}.{\dirpath'}.{\qualid}} for some {\dirpath'}. - This is useful to ensure that the {\qualid} library comes from a given - package by making explicit its absolute root. - -\end{Variants} - -\begin{ErrMsgs} - -\item \errindex{Cannot load {\qualid}: no physical path bound to {\dirpath}} - -\item \errindex{Cannot find library foo in loadpath} - - The command did not find the file {\tt foo.vo}. Either {\tt - foo.v} exists but is not compiled or {\tt foo.vo} is in a directory - which is not in your {\tt LoadPath} (see Section~\ref{loadpath}). - -\item \errindex{Compiled library {\ident}.vo makes inconsistent assumptions over library {\qualid}} - - The command tried to load library file {\ident}.vo that depends on - some specific version of library {\qualid} which is not the one - already loaded in the current {\Coq} session. Probably {\ident}.v - was not properly recompiled with the last version of the file - containing module {\qualid}. - -\item \errindex{Bad magic number} - - \index{Bad-magic-number@{\tt Bad Magic Number}} - The file {\tt{\ident}.vo} was found but either it is not a \Coq\ - compiled module, or it was compiled with an older and incompatible - version of {\Coq}. - -\item \errindex{The file {\ident}.vo contains library {\dirpath} and not - library {\dirpath'}} - - The library file {\dirpath'} is indirectly required by the {\tt - Require} command but it is bound in the current loadpath to the file - {\ident}.vo which was bound to a different library name {\dirpath} - at the time it was compiled. - -\item \errindex{Require is not allowed inside a module or a module type} - - This command is not allowed inside a module or a module type being defined. - It is meant to describe a dependency between compilation units. Note however - that the commands {\tt Import} and {\tt Export} alone can be used inside - modules (see Section~\ref{Import}). - -\end{ErrMsgs} - -\SeeAlso Chapter~\ref{Addoc-coqc} - -\subsection[\tt Print Libraries.]{\tt Print Libraries.\comindex{Print Libraries}} - -This command displays the list of library files loaded in the current -{\Coq} session. For each of these libraries, it also tells if it is -imported. - -\subsection[\tt Declare ML Module {\str$_1$} .. {\str$_n$}.]{\tt Declare ML Module {\str$_1$} .. {\str$_n$}.\comindex{Declare ML Module}} -This commands loads the {\ocaml} compiled files {\str$_1$} {\ldots} -{\str$_n$} (dynamic link). It is mainly used to load tactics -dynamically. -% (see Chapter~\ref{WritingTactics}). - The files are -searched into the current {\ocaml} loadpath (see the command {\tt -Add ML Path} in the Section~\ref{loadpath}). Loading of {\ocaml} -files is only possible under the bytecode version of {\tt coqtop} -(i.e. {\tt coqtop.byte}, see chapter -\ref{Addoc-coqc}), or when {\Coq} has been compiled with a version of -{\ocaml} that supports native {\tt Dynlink} ($\ge$ 3.11). - -\begin{Variants} -\item {\tt Local Declare ML Module {\str$_1$} .. {\str$_n$}.}\\ - This variant is not exported to the modules that import the module - where they occur, even if outside a section. -\end{Variants} - -\begin{ErrMsgs} -\item \errindex{File not found on loadpath : \str} -\item \errindex{Loading of ML object file forbidden in a native {\Coq}} -\end{ErrMsgs} - -\subsection[\tt Print ML Modules.]{\tt Print ML Modules.\comindex{Print ML Modules}} -This print the name of all \ocaml{} modules loaded with \texttt{Declare - ML Module}. To know from where these module were loaded, the user -should use the command \texttt{Locate File} (see Section~\ref{Locate File}) - -\section[Loadpath]{Loadpath} - -Loadpaths are preferably managed using {\Coq} command line options -(see Section~\ref{loadpath}) but there remain vernacular commands to -manage them for practical purposes. Such commands are only meant to be issued in -the toplevel, and using them in source files is discouraged. - -\subsection[\tt Pwd.]{\tt Pwd.\comindex{Pwd}\label{Pwd}} -This command displays the current working directory. - -\subsection[\tt Cd {\str}.]{\tt Cd {\str}.\comindex{Cd}} -This command changes the current directory according to {\str} -which can be any valid path. - -\begin{Variants} -\item {\tt Cd.}\\ - Is equivalent to {\tt Pwd.} -\end{Variants} - -\subsection[\tt Add LoadPath {\str} as {\dirpath}.]{\tt Add LoadPath {\str} as {\dirpath}.\comindex{Add LoadPath}\label{AddLoadPath}} - -This command is equivalent to the command line option {\tt -Q {\str} - {\dirpath}}. It adds the physical directory {\str} to the current {\Coq} -loadpath and maps it to the logical directory {\dirpath}. - -\begin{Variants} -\item {\tt Add LoadPath {\str}.}\\ -Performs as {\tt Add LoadPath {\str} as {\dirpath}} but for the empty directory path. -\end{Variants} - -\subsection[\tt Add Rec LoadPath {\str} as {\dirpath}.]{\tt Add Rec LoadPath {\str} as {\dirpath}.\comindex{Add Rec LoadPath}\label{AddRecLoadPath}} -This command is equivalent to the command line option {\tt -R {\str} - {\dirpath}}. It adds the physical directory {\str} and all its -subdirectories to the current {\Coq} loadpath. - -\begin{Variants} -\item {\tt Add Rec LoadPath {\str}.}\\ -Works as {\tt Add Rec LoadPath {\str} as {\dirpath}} but for the empty logical directory path. -\end{Variants} - -\subsection[\tt Remove LoadPath {\str}.]{\tt Remove LoadPath {\str}.\comindex{Remove LoadPath}} -This command removes the path {\str} from the current \Coq\ loadpath. - -\subsection[\tt Print LoadPath.]{\tt Print LoadPath.\comindex{Print LoadPath}} -This command displays the current \Coq\ loadpath. - -\begin{Variants} -\item {\tt Print LoadPath {\dirpath}.}\\ -Works as {\tt Print LoadPath} but displays only the paths that extend the {\dirpath} prefix. -\end{Variants} - -\subsection[\tt Add ML Path {\str}.]{\tt Add ML Path {\str}.\comindex{Add ML Path}} -This command adds the path {\str} to the current {\ocaml} loadpath (see -the command {\tt Declare ML Module} in the Section~\ref{compiled}). - -\subsection[\tt Add Rec ML Path {\str}.]{\tt Add Rec ML Path {\str}.\comindex{Add Rec ML Path}} -This command adds the directory {\str} and all its subdirectories -to the current {\ocaml} loadpath (see -the command {\tt Declare ML Module} in the Section~\ref{compiled}). - -\subsection[\tt Print ML Path {\str}.]{\tt Print ML Path {\str}.\comindex{Print ML Path}} -This command displays the current {\ocaml} loadpath. -This command makes sense only under the bytecode version of {\tt -coqtop}, i.e. {\tt coqtop.byte} (see the -command {\tt Declare ML Module} in the section -\ref{compiled}). - -\subsection[\tt Locate File {\str}.]{\tt Locate File {\str}.\comindex{Locate - File}\label{Locate File}} -This command displays the location of file {\str} in the current loadpath. -Typically, {\str} is a \texttt{.cmo} or \texttt{.vo} or \texttt{.v} file. - -\subsection[\tt Locate Library {\dirpath}.]{\tt Locate Library {\dirpath}.\comindex{Locate Library}\label{Locate Library}} -This command gives the status of the \Coq\ module {\dirpath}. It tells if the -module is loaded and if not searches in the load path for a module -of logical name {\dirpath}. - -\section{Backtracking} - -The backtracking commands described in this section can only be used -interactively, they cannot be part of a vernacular file loaded via -{\tt Load} or compiled by {\tt coqc}. - -\subsection[\tt Reset \ident.]{\tt Reset \ident.\comindex{Reset}} -This command removes all the objects in the environment since \ident\ -was introduced, including \ident. \ident\ may be the name of a defined -or declared object as well as the name of a section. One cannot reset -over the name of a module or of an object inside a module. - -\begin{ErrMsgs} -\item \ident: \errindex{no such entry} -\end{ErrMsgs} - -\begin{Variants} - \item {\tt Reset Initial.}\comindex{Reset Initial}\\ - Goes back to the initial state, just after the start of the - interactive session. -\end{Variants} - -\subsection[\tt Back.]{\tt Back.\comindex{Back}} - -This commands undoes all the effects of the last vernacular -command. Commands read from a vernacular file via a {\tt Load} are -considered as a single command. Proof management commands -are also handled by this command (see Chapter~\ref{Proof-handling}). -For that, {\tt Back} may have to undo more than one command in order -to reach a state where the proof management information is available. -For instance, when the last command is a {\tt Qed}, the management -information about the closed proof has been discarded. In this case, -{\tt Back} will then undo all the proof steps up to the statement of -this proof. - -\begin{Variants} -\item {\tt Back $n$} \\ - Undoes $n$ vernacular commands. As for {\tt Back}, some extra - commands may be undone in order to reach an adequate state. - For instance {\tt Back n} will not re-enter a closed proof, - but rather go just before that proof. -\end{Variants} - -\begin{ErrMsgs} -\item \errindex{Invalid backtrack} \\ - The user wants to undo more commands than available in the history. -\end{ErrMsgs} - -\subsection[\tt BackTo $\num$.]{\tt BackTo $\num$.\comindex{BackTo}} -\label{sec:statenums} - -This command brings back the system to the state labeled $\num$, -forgetting the effect of all commands executed after this state. -The state label is an integer which grows after each successful command. -It is displayed in the prompt when in \texttt{-emacs} mode. -Just as {\tt Back} (see above), the {\tt BackTo} command now handles -proof states. For that, it may have to undo some -extra commands and end on a state $\num' \leq \num$ if necessary. - -\begin{Variants} -\item {\tt Backtrack $\num_1$ $\num_2$ $\num_3$}.\comindex{Backtrack}\\ - {\tt Backtrack} is a \emph{deprecated} form of {\tt BackTo} which - allows explicitly manipulating the proof environment. The three - numbers $\num_1$, $\num_2$ and $\num_3$ represent the following: -\begin{itemize} -\item $\num_3$: Number of \texttt{Abort} to perform, i.e. the number - of currently opened nested proofs that must be canceled (see - Chapter~\ref{Proof-handling}). -\item $\num_2$: \emph{Proof state number} to unbury once aborts have - been done. {\Coq} will compute the number of \texttt{Undo} to perform - (see Chapter~\ref{Proof-handling}). -\item $\num_1$: State label to reach, as for {\tt BackTo}. -\end{itemize} -\end{Variants} - -\begin{ErrMsgs} -\item \errindex{Invalid backtrack} \\ - The destination state label is unknown. -\end{ErrMsgs} - -\section{Quitting and debugging} - -\subsection[\tt Quit.]{\tt Quit.\comindex{Quit}} -This command permits to quit \Coq. - -\subsection[\tt Drop.]{\tt Drop.\comindex{Drop}\label{Drop}} - -This is used mostly as a debug facility by \Coq's implementors -and does not concern the casual user. -This command permits to leave {\Coq} temporarily and enter the -{\ocaml} toplevel. The {\ocaml} command: - -\begin{flushleft} -\begin{verbatim} -#use "include";; -\end{verbatim} -\end{flushleft} - -\noindent add the right loadpaths and loads some toplevel printers for -all abstract types of \Coq - section\_path, identifiers, terms, judgments, -\dots. You can also use the file \texttt{base\_include} instead, -that loads only the pretty-printers for section\_paths and -identifiers. -% See Section~\ref{test-and-debug} more information on the -% usage of the toplevel. -You can return back to \Coq{} with the command: - -\begin{flushleft} -\begin{verbatim} -go();; -\end{verbatim} -\end{flushleft} - -\begin{Warnings} -\item It only works with the bytecode version of {\Coq} (i.e. {\tt coqtop} called with option {\tt -byte}, see the contents of Section~\ref{binary-images}). -\item You must have compiled {\Coq} from the source package and set the - environment variable \texttt{COQTOP} to the root of your copy of the sources (see Section~\ref{EnvVariables}). -\end{Warnings} - -\subsection[\tt Time \textrm{\textsl{command}}.]{\tt Time \textrm{\textsl{command}}.\comindex{Time} -\label{time}} -This command executes the vernacular command \textrm{\textsl{command}} -and display the time needed to execute it. - -\subsection[\tt Redirect "\textrm{\textsl{file}}" \textrm{\textsl{command}}.]{\tt Redirect "\textrm{\textsl{file}}" \textrm{\textsl{command}}.\comindex{Redirect} -\label{redirect}} -This command executes the vernacular command \textrm{\textsl{command}}, redirecting its output to ``\textrm{\textsl{file}}.out''. - -\subsection[\tt Timeout \textrm{\textsl{int}} \textrm{\textsl{command}}.]{\tt Timeout \textrm{\textsl{int}} \textrm{\textsl{command}}.\comindex{Timeout} -\label{timeout}} - -This command executes the vernacular command \textrm{\textsl{command}}. If -the command has not terminated after the time specified by the integer -(time expressed in seconds), then it is interrupted and an error message -is displayed. - -\subsection[\tt Set Default Timeout \textrm{\textsl{int}}.]{\tt Set - Default Timeout \textrm{\textsl{int}}.\optindex{Default Timeout}} - -After using this command, all subsequent commands behave as if they -were passed to a {\tt Timeout} command. Commands already starting by -a {\tt Timeout} are unaffected. - -\subsection[\tt Unset Default Timeout.]{\tt Unset Default Timeout.\optindex{Default Timeout}} - -This command turns off the use of a default timeout. - -\subsection[\tt Test Default Timeout.]{\tt Test Default Timeout.\optindex{Default Timeout}} - -This command displays whether some default timeout has be set or not. - -\subsection[\tt Fail \textrm{\textsl{command-or-tactic}}.]{\tt Fail \textrm{\textsl{command-or-tactic}}.\comindex{Fail}\label{Fail}} - -For debugging {\Coq} scripts, sometimes it is desirable to know -whether a command or a tactic fails. If the given command or tactic -fails, the {\tt Fail} statement succeeds, without changing the proof -state, and in interactive mode, {\Coq} prints a message confirming the failure. -If the command or tactic succeeds, the statement is an error, and -{\Coq} prints a message indicating that the failure did not occur. - -\section{Controlling display} - -\subsection[\tt Set Silent.]{\tt Set Silent.\optindex{Silent} -\label{Begin-Silent} -\index{Silent mode}} -This command turns off the normal displaying. - -\subsection[\tt Unset Silent.]{\tt Unset Silent.\optindex{Silent}} -This command turns the normal display on. - -\subsection[\tt Set Warnings ``(\nterm{w}$_1$,\ldots,% - \nterm{w}$_n$)''.]{{\tt Set Warnings ``(\nterm{w}$_1$,\ldots,% - \nterm{w}$_n$)''}.\optindex{Warnings}} -\label{SetWarnings} -This command configures the display of warnings. It is experimental, and -expects, between quotes, a comma-separated list of warning names or -categories. Adding~\texttt{-} in front of a warning or category disables it, -adding~\texttt{+} makes it an error. It is possible to use the special -categories \texttt{all} and \texttt{default}, the latter containing the warnings -enabled by default. The flags are interpreted from left to right, so in case of -an overlap, the flags on the right have higher priority, meaning that -\texttt{A,-A} is equivalent to \texttt{-A}. - -\subsection[\tt Set Search Output Name Only.]{\tt Set Search Output Name Only.\optindex{Search Output Name Only} -\label{Search-Output-Name-Only} -\index{Search Output Name Only mode}} -This command restricts the output of search commands to identifier names; turning it on causes invocations of {\tt Search}, {\tt SearchHead}, {\tt SearchPattern}, {\tt SearchRewrite} etc. to omit types from their output, printing only identifiers. - -\subsection[\tt Unset Search Output Name Only.]{\tt Unset Search Output Name Only.\optindex{Search Output Name Only}} -This command turns type display in search results back on. - -\subsection[\tt Set Printing Width {\integer}.]{\tt Set Printing Width {\integer}.\optindex{Printing Width}} -\label{SetPrintingWidth} -This command sets which left-aligned part of the width of the screen -is used for display. - -\subsection[\tt Unset Printing Width.]{\tt Unset Printing Width.\optindex{Printing Width}} -This command resets the width of the screen used for display to its -default value (which is 78 at the time of writing this documentation). - -\subsection[\tt Test Printing Width.]{\tt Test Printing Width.\optindex{Printing Width}} -This command displays the current screen width used for display. - -\subsection[\tt Set Printing Depth {\integer}.]{\tt Set Printing Depth {\integer}.\optindex{Printing Depth}} -This command sets the nesting depth of the formatter used for -pretty-printing. Beyond this depth, display of subterms is replaced by -dots. - -\subsection[\tt Unset Printing Depth.]{\tt Unset Printing Depth.\optindex{Printing Depth}} -This command resets the nesting depth of the formatter used for -pretty-printing to its default value (at the -time of writing this documentation, the default value is 50). - -\subsection[\tt Test Printing Depth.]{\tt Test Printing Depth.\optindex{Printing Depth}} -This command displays the current nesting depth used for display. - -\subsection[\tt Unset Printing Compact Contexts.]{\tt Unset Printing Compact Contexts.\optindex{Printing Compact Contexts}} -This command resets the displaying of goals contexts to non compact -mode (default at the time of writing this documentation). Non compact -means that consecutive variables of different types are printed on -different lines. - -\subsection[\tt Set Printing Compact Contexts.]{\tt Set Printing Compact Contexts.\optindex{Printing Compact Contexts}} -This command sets the displaying of goals contexts to compact mode. -The printer tries to reduce the vertical size of goals contexts by -putting several variables (even if of different types) on the same -line provided it does not exceed the printing width (See {\tt Set - Printing Width} above). - -\subsection[\tt Test Printing Compact Contexts.]{\tt Test Printing Compact Contexts.\optindex{Printing Compact Contexts}} -This command displays the current state of compaction of goal. - - -\subsection[\tt Unset Printing Unfocused.]{\tt Unset Printing Unfocused.\optindex{Printing Unfocused}} -This command resets the displaying of goals to focused goals only -(default). Unfocused goals are created by focusing other goals with -bullets(see~\ref{bullets}) or curly braces (see~\ref{curlybacket}). - -\subsection[\tt Set Printing Unfocused.]{\tt Set Printing Unfocused.\optindex{Printing Unfocused}} -This command enables the displaying of unfocused goals. The goals are -displayed after the focused ones and are distinguished by a separator. - -\subsection[\tt Test Printing Unfocused.]{\tt Test Printing Unfocused.\optindex{Printing Unfocused}} -This command displays the current state of unfocused goals display. - -\subsection[\tt Set Printing Dependent Evars Line.]{\tt Set Printing Dependent Evars Line.\optindex{Printing Dependent Evars Line}} -This command enables the printing of the ``{\tt (dependent evars: \ldots)}'' -line when {\tt -emacs} is passed. - -\subsection[\tt Unset Printing Dependent Evars Line.]{\tt Unset Printing Dependent Evars Line.\optindex{Printing Dependent Evars Line}} -This command disables the printing of the ``{\tt (dependent evars: \ldots)}'' -line when {\tt -emacs} is passed. - -%\subsection{\tt Abstraction ...} -%Not yet documented. - -\section{Controlling the reduction strategies and the conversion algorithm} -\label{Controlling_reduction_strategy} - -{\Coq} provides reduction strategies that the tactics can invoke and -two different algorithms to check the convertibility of types. -The first conversion algorithm lazily -compares applicative terms while the other is a brute-force but efficient -algorithm that first normalizes the terms before comparing them. The -second algorithm is based on a bytecode representation of terms -similar to the bytecode representation used in the ZINC virtual -machine~\cite{Leroy90}. It is especially useful for intensive -computation of algebraic values, such as numbers, and for reflection-based -tactics. The commands to fine-tune the reduction strategies and the -lazy conversion algorithm are described first. - -\subsection[{\tt Opaque} \qualid$_1$ {\ldots} \qualid$_n${\tt .}]{{\tt Opaque} \qualid$_1$ {\ldots} \qualid$_n${\tt .}\comindex{Opaque}\label{Opaque}} -This command has an effect on unfoldable constants, i.e. -on constants defined by {\tt Definition} or {\tt Let} (with an explicit -body), or by a command assimilated to a definition such as {\tt -Fixpoint}, {\tt Program Definition}, etc, or by a proof ended by {\tt -Defined}. The command tells not to unfold -the constants {\qualid$_1$} {\ldots} {\qualid$_n$} in tactics using -$\delta$-conversion (unfolding a constant is replacing it by its -definition). - -{\tt Opaque} has also an effect on the conversion algorithm of {\Coq}, -telling it to delay the unfolding of a constant as much as possible when -{\Coq} has to check the conversion (see Section~\ref{conv-rules}) -of two distinct applied constants. - -The scope of {\tt Opaque} is limited to the current section, or -current file, unless the variant {\tt Global Opaque \qualid$_1$ {\ldots} -\qualid$_n$} is used. - -\SeeAlso sections \ref{Conversion-tactics}, \ref{Automatizing}, -\ref{Theorem} - -\begin{ErrMsgs} -\item \errindex{The reference \qualid\ was not found in the current -environment}\\ - There is no constant referred by {\qualid} in the environment. - Nevertheless, if you asked \texttt{Opaque foo bar} - and if \texttt{bar} does not exist, \texttt{foo} is set opaque. -\end{ErrMsgs} - -\subsection[{\tt Transparent} \qualid$_1$ {\ldots} \qualid$_n${\tt .}]{{\tt Transparent} \qualid$_1$ {\ldots} \qualid$_n${\tt .}\comindex{Transparent}\label{Transparent}} -This command is the converse of {\tt Opaque} and it applies on -unfoldable constants to restore their unfoldability after an {\tt -Opaque} command. - -Note in particular that constants defined by a proof ended by {\tt -Qed} are not unfoldable and {\tt Transparent} has no effect on -them. This is to keep with the usual mathematical practice of {\em -proof irrelevance}: what matters in a mathematical development is the -sequence of lemma statements, not their actual proofs. This -distinguishes lemmas from the usual defined constants, whose actual -values are of course relevant in general. - -The scope of {\tt Transparent} is limited to the current section, or -current file, unless the variant {\tt Global Transparent} \qualid$_1$ -{\ldots} \qualid$_n$ is used. - -\begin{ErrMsgs} -% \item \errindex{Can not set transparent.}\\ -% It is a constant from a required module or a parameter. -\item \errindex{The reference \qualid\ was not found in the current -environment}\\ - There is no constant referred by {\qualid} in the environment. -\end{ErrMsgs} - -\SeeAlso sections \ref{Conversion-tactics}, \ref{Automatizing}, -\ref{Theorem} - -\subsection{{\tt Strategy} {\it level} {\tt [} \qualid$_1$ {\ldots} \qualid$_n$ - {\tt ].}\comindex{Strategy}\comindex{Local Strategy}\label{Strategy}} -This command generalizes the behavior of {\tt Opaque} and {\tt - Transparent} commands. It is used to fine-tune the strategy for -unfolding constants, both at the tactic level and at the kernel -level. This command associates a level to \qualid$_1$ {\ldots} -\qualid$_n$. Whenever two expressions with two distinct head -constants are compared (for instance, this comparison can be triggered -by a type cast), the one with lower level is expanded first. In case -of a tie, the second one (appearing in the cast type) is expanded. - -Levels can be one of the following (higher to lower): -\begin{description} -\item[opaque]: level of opaque constants. They cannot be expanded by - tactics (behaves like $+\infty$, see next item). -\item[\num]: levels indexed by an integer. Level $0$ corresponds - to the default behavior, which corresponds to transparent - constants. This level can also be referred to as {\bf transparent}. - Negative levels correspond to constants to be expanded before normal - transparent constants, while positive levels correspond to constants - to be expanded after normal transparent constants. -\item[expand]: level of constants that should be expanded first - (behaves like $-\infty$) -\end{description} - -These directives survive section and module closure, unless the -command is prefixed by {\tt Local}. In the latter case, the behavior -regarding sections and modules is the same as for the {\tt - Transparent} and {\tt Opaque} commands. - -\subsection{{\tt Print Strategy} \qualid{\tt .}\comindex{Print Strategy}\label{PrintStrategy}} - -This command prints the strategy currently associated to \qualid{}. It fails if -\qualid{} is not an unfoldable reference, that is, neither a variable nor a -constant. - -\begin{ErrMsgs} -\item The reference is not unfoldable. -\end{ErrMsgs} - -\begin{Variants} -\item {\tt Print Strategies}\comindex{Print Strategies}\\ - Print all the currently non-transparent strategies. -\end{Variants} - -\subsection{\tt Declare Reduction \ident\ := {\rm\sl convtactic}.} - -This command allows giving a short name to a reduction expression, -for instance {\tt lazy beta delta [foo bar]}. This short name can -then be used in {\tt Eval \ident\ in ...} or {\tt eval} directives. -This command accepts the {\tt Local} modifier, for discarding -this reduction name at the end of the file or module. For the moment -the name cannot be qualified. In particular declaring the same name -in several modules or in several functor applications will be refused -if these declarations are not local. The name \ident\ cannot be used -directly as an Ltac tactic, but nothing prevent the user to also -perform a {\tt Ltac \ident\ := {\rm\sl convtactic}}. - -\SeeAlso sections \ref{Conversion-tactics} - -\section{Controlling the locality of commands} - -\subsection{{\tt Local}, {\tt Global} -\comindex{Local} -\comindex{Global} -} - -Some commands support a {\tt Local} or {\tt Global} prefix modifier to -control the scope of their effect. There are four kinds of commands: - -\begin{itemize} -\item Commands whose default is to extend their effect both outside the - section and the module or library file they occur in. - - For these commands, the {\tt Local} modifier limits the effect of - the command to the current section or module it occurs in. - - As an example, the {\tt Coercion} (see Section~\ref{Coercions}) - and {\tt Strategy} (see Section~\ref{Strategy}) - commands belong to this category. - -\item Commands whose default behavior is to stop their effect at the - end of the section they occur in but to extent their effect outside - the module or library file they occur in. - - For these commands, the {\tt Local} modifier limits the effect of - the command to the current module if the command does not occur in a - section and the {\tt Global} modifier extends the effect outside the - current sections and current module if the command occurs in a - section. - - As an example, the {\tt Implicit Arguments} (see - Section~\ref{Implicit Arguments}), {\tt Ltac} (see - Chapter~\ref{TacticLanguage}) or {\tt Notation} (see - Section~\ref{Notation}) commands belong to this category. - - Notice that a subclass of these commands do not support extension of - their scope outside sections at all and the {\tt Global} is not - applicable to them. - -\item Commands whose default behavior is to stop their effect at the - end of the section or module they occur in. - - For these commands, the {\tt Global} modifier extends their effect - outside the sections and modules they occurs in. - - The {\tt Transparent} and {\tt Opaque} (see - Section~\ref{Controlling_reduction_strategy}) commands belong to - this category. - -\item Commands whose default behavior is to extend their effect - outside sections but not outside modules when they occur in a - section and to extend their effect outside the module or library - file they occur in when no section contains them. - - For these commands, the {\tt Local} modifier limits the effect to - the current section or module while the {\tt Global} modifier extends - the effect outside the module even when the command occurs in a section. - - The {\tt Set} and {\tt Unset} commands belong to this category. -\end{itemize} - - -%%% Local Variables: -%%% mode: latex -%%% TeX-master: "Reference-Manual" -%%% End: diff --git a/doc/refman/RefMan-pro.tex b/doc/refman/RefMan-pro.tex deleted file mode 100644 index bd74a40d7..000000000 --- a/doc/refman/RefMan-pro.tex +++ /dev/null @@ -1,581 +0,0 @@ -\chapter[Proof handling]{Proof handling\index{Proof editing} -\label{Proof-handling}} -%HEVEA\cutname{proof-handling.html} - -In \Coq's proof editing mode all top-level commands documented in -Chapter~\ref{Vernacular-commands} remain available -and the user has access to specialized commands dealing with proof -development pragmas documented in this section. He can also use some -other specialized commands called {\em tactics}. They are the very -tools allowing the user to deal with logical reasoning. They are -documented in Chapter~\ref{Tactics}.\\ -When switching in editing proof mode, the prompt -\index{Prompt} -{\tt Coq <} is changed into {\tt {\ident} <} where {\ident} is the -declared name of the theorem currently edited. - -At each stage of a proof development, one has a list of goals to -prove. Initially, the list consists only in the theorem itself. After -having applied some tactics, the list of goals contains the subgoals -generated by the tactics. - -To each subgoal is associated a number of -hypotheses called the {\em \index*{local context}} of the goal. -Initially, the local context contains the local variables and -hypotheses of the current section (see Section~\ref{Variable}) and the -local variables and hypotheses of the theorem statement. It is -enriched by the use of certain tactics (see e.g. {\tt intro} in -Section~\ref{intro}). - -When a proof is completed, the message {\tt Proof completed} is -displayed. One can then register this proof as a defined constant in the -environment. Because there exists a correspondence between proofs and -terms of $\lambda$-calculus, known as the {\em Curry-Howard -isomorphism} \cite{How80,Bar91,Gir89,Hue89}, \Coq~ stores proofs as -terms of {\sc Cic}. Those terms are called {\em proof - terms}\index{Proof term}. - -\ErrMsg When one attempts to use a proof editing command out of the -proof editing mode, \Coq~ raises the error message : \errindex{No focused - proof}. - -\section{Switching on/off the proof editing mode} - -The proof editing mode is entered by asserting a statement, which -typically is the assertion of a theorem: - -\begin{quote} -{\tt Theorem {\ident} \zeroone{\binders} : {\form}.\comindex{Theorem} -\label{Theorem}} -\end{quote} - -The list of assertion commands is given in -Section~\ref{Assertions}. The command {\tt Goal} can also be used. - -\subsection[Goal {\form}.]{\tt Goal {\form}.\comindex{Goal}\label{Goal}} - -This is intended for quick assertion of statements, without knowing in -advance which name to give to the assertion, typically for quick -testing of the provability of a statement. If the proof of the -statement is eventually completed and validated, the statement is then -bound to the name {\tt Unnamed\_thm} (or a variant of this name not -already used for another statement). - -\subsection[\tt Qed.]{\tt Qed.\comindex{Qed}\label{Qed}} -This command is available in interactive editing proof mode when the -proof is completed. Then {\tt Qed} extracts a proof term from the -proof script, switches back to {\Coq} top-level and attaches the -extracted proof term to the declared name of the original goal. This -name is added to the environment as an {\tt Opaque} constant. - -\begin{ErrMsgs} -\item \errindex{Attempt to save an incomplete proof} -%\item \ident\ \errindex{already exists}\\ -% The implicit name is already defined. You have then to provide -% explicitly a new name (see variant 3 below). -\item Sometimes an error occurs when building the proof term, -because tactics do not enforce completely the term construction -constraints. - -The user should also be aware of the fact that since the proof term is -completely rechecked at this point, one may have to wait a while when -the proof is large. In some exceptional cases one may even incur a -memory overflow. -\end{ErrMsgs} - -\begin{Variants} - -\item {\tt Defined.} -\comindex{Defined} -\label{Defined} - - Defines the proved term as a transparent constant. - -\item {\tt Save {\ident}.} - - Forces the name of the original goal to be {\ident}. This command - (and the following ones) can only be used if the original goal has - been opened using the {\tt Goal} command. - -\end{Variants} - -\subsection[\tt Admitted.]{\tt Admitted.\comindex{Admitted}\label{Admitted}} -This command is available in interactive editing proof mode to give up -the current proof and declare the initial goal as an axiom. - -\subsection[\tt Proof {\term}.]{\tt Proof {\term}.\comindex{Proof} -\label{BeginProof}} -This command applies in proof editing mode. It is equivalent to {\tt - exact {\term}. Qed.} That is, you have to give the full proof in -one gulp, as a proof term (see Section~\ref{exact}). - -\variant {\tt Proof.} - - Is a noop which is useful to delimit the sequence of tactic commands - which start a proof, after a {\tt Theorem} command. It is a good - practice to use {\tt Proof.} as an opening parenthesis, closed in - the script with a closing {\tt Qed.} - -\SeeAlso {\tt Proof with {\tac}.} in Section~\ref{ProofWith}. - -\subsection[{\tt Proof using} {\ident$_1$} {\ldots} {\ident$_n$}{\tt .}] -{{\tt Proof using} {\ident$_1$} {\ldots} {\ident$_n$}{\tt .} -\comindex{Proof using} \label{ProofUsing}} - -This command applies in proof editing mode. -It declares the set of section variables (see~\ref{Variable}) -used by the proof. At {\tt Qed} time, the system will assert that -the set of section variables actually used in the proof is a subset of -the declared one. - -The set of declared variables is closed under type dependency. -For example if {\tt T} is variable and {\tt a} is a variable of -type {\tt T}, the commands {\tt Proof using a} and -{\tt Proof using T a} are actually equivalent. - -\variant {\tt Proof using} {\ident$_1$} {\ldots} {\ident$_n$} {\tt with} {\tac}{\tt .} -in Section~\ref{ProofWith}. - -\variant {\tt Proof using All.} - - Use all section variables. - -\variant {\tt Proof using Type.} -\variant {\tt Proof using.} - - Use only section variables occurring in the statement. - -\variant {\tt Proof using Type*.} - - The {\tt *} operator computes the forward transitive closure. - E.g. if the variable {\tt H} has type {\tt p < 5} then {\tt H} is - in {\tt p*} since {\tt p} occurs in the type of {\tt H}. - {\tt Type* } is the forward transitive closure of the entire set of - section variables occurring in the statement. - -\variant {\tt Proof using -( \ident$_1$} {\ldots} {\tt \ident$_n$ ).} - - Use all section variables except {\ident$_1$} {\ldots} {\ident$_n$}. - -\variant {\tt Proof using \nterm{collection}$_1$ + \nterm{collection}$_2$ .} - -\variant {\tt Proof using \nterm{collection}$_1$ - \nterm{collection}$_2$ .} - -\variant {\tt Proof using \nterm{collection} - ( \ident$_1$} {\ldots} {\tt \ident$_n$ ).} - -\variant {\tt Proof using \nterm{collection} * .} - - Use section variables being, respectively, in the set union, set difference, - set complement, set forward transitive closure. - See Section~\ref{Collection} to know how to form a named - collection. - The {\tt *} operator binds stronger than {\tt +} and {\tt -}. - -\subsubsection{{\tt Proof using} options} -\optindex{Default Proof Using} -\optindex{Suggest Proof Using} -% \optindex{Proof Using Clear Unused} - -The following options modify the behavior of {\tt Proof using}. - -\variant {\tt Set Default Proof Using "expression".} - - Use {\tt expression} as the default {\tt Proof using} value. - E.g. {\tt Set Default Proof Using "a b".} will complete all {\tt Proof } - commands not followed by a {\tt using} part with {\tt using a b}. - -\variant {\tt Set Suggest Proof Using.} - - When {\tt Qed} is performed, suggest a {\tt using} annotation if - the user did not provide one. - -% \variant{\tt Unset Proof Using Clear Unused.} -% -% When {\tt Proof using a} all section variables but for {\tt a} and -% the variables used in the type of {\tt a} are cleared. -% This option can be used to turn off this behavior. -% -\subsubsection[\tt Collection]{Name a set of section hypotheses for {\tt Proof using}} -\comindex{Collection}\label{Collection} - -The command {\tt Collection} can be used to name a set of section hypotheses, -with the purpose of making {\tt Proof using} annotations more compact. - -\variant {\tt Collection Some := x y z.} - - Define the collection named "Some" containing {\tt x y} and {\tt z} - -\variant {\tt Collection Fewer := Some - x.} - - Define the collection named "Fewer" containing only {\tt x y} - -\variant {\tt Collection Many := Fewer + Some.} -\variant {\tt Collection Many := Fewer - Some.} - - Define the collection named "Many" containing the set union or set difference - of "Fewer" and "Some". - -\variant {\tt Collection Many := Fewer - (x y).} - - Define the collection named "Many" containing the set difference - of "Fewer" and the unnamed collection {\tt x y}. - -\subsection[\tt Abort.]{\tt Abort.\comindex{Abort}} - -This command cancels the current proof development, switching back to -the previous proof development, or to the \Coq\ toplevel if no other -proof was edited. - -\begin{ErrMsgs} -\item \errindex{No focused proof (No proof-editing in progress)} -\end{ErrMsgs} - -\begin{Variants} - -\item {\tt Abort {\ident}.} - - Aborts the editing of the proof named {\ident}. - -\item {\tt Abort All.} - - Aborts all current goals, switching back to the \Coq\ toplevel. - -\end{Variants} - -%%%% -\subsection[\tt Existential {\num} := {\term}.]{\tt Existential {\num} := {\term}.\comindex{Existential} -\label{Existential}} - -This command instantiates an existential variable. {\tt \num} -is an index in the list of uninstantiated existential variables -displayed by {\tt Show Existentials} (described in Section~\ref{Show}). - -This command is intended to be used to instantiate existential -variables when the proof is completed but some uninstantiated -existential variables remain. To instantiate existential variables -during proof edition, you should use the tactic {\tt instantiate}. - -\SeeAlso {\tt instantiate (\num:= \term).} in Section~\ref{instantiate}. -\SeeAlso {\tt Grab Existential Variables.} below. - -\subsection[\tt Grab Existential Variables.]{\tt Grab Existential Variables.\comindex{Grab Existential Variables} -\label{GrabEvars}} - -This command can be run when a proof has no more goal to be solved but has remaining -uninstantiated existential variables. It takes every uninstantiated existential variable -and turns it into a goal. - -%%%%%%%% -\section{Navigation in the proof tree} -%%%%%%%% - -\subsection[\tt Undo.]{\tt Undo.\comindex{Undo}} - -This command cancels the effect of the last command. Thus, it -backtracks one step. - -\begin{Variants} - -\item {\tt Undo {\num}.} - - Repeats {\tt Undo} {\num} times. - -\end{Variants} - -\subsection[\tt Restart.]{\tt Restart.\comindex{Restart}} -This command restores the proof editing process to the original goal. - -\begin{ErrMsgs} -\item \errindex{No focused proof to restart} -\end{ErrMsgs} - -\subsection[\tt Focus.]{\tt Focus.\comindex{Focus}} -This focuses the attention on the first subgoal to prove and the printing -of the other subgoals is suspended until the focused subgoal is -solved or unfocused. This is useful when there are many current -subgoals which clutter your screen. - -\begin{Variant} -\item {\tt Focus {\num}.}\\ -This focuses the attention on the $\num^{th}$ subgoal to prove. -\end{Variant} - -\emph{This command is deprecated since 8.8: prefer the use of bullets or - focusing brackets instead, including {\tt {\num}: \{}}. - -\subsection[\tt Unfocus.]{\tt Unfocus.\comindex{Unfocus}} -This command restores to focus the goal that were suspended by the -last {\tt Focus} command. - -\emph{This command is deprecated since 8.8.} - -\subsection[\tt Unfocused.]{\tt Unfocused.\comindex{Unfocused}} -Succeeds in the proof if fully unfocused, fails if there are some -goals out of focus. - -\subsection[\tt \{ \textrm{and} \}]{\tt \{ \textrm{and} \}\comindex{\{}\comindex{\}}}\label{curlybacket} -The command {\tt \{} (without a terminating period) focuses on the -first goal, much like {\tt Focus.} does, however, the subproof can -only be unfocused when it has been fully solved (\emph{i.e.} when -there is no focused goal left). Unfocusing is then handled by {\tt \}} -(again, without a terminating period). See also example in next section. - -Note that when a focused goal is proved a message is displayed -together with a suggestion about the right bullet or {\tt \}} to -unfocus it or focus the next one. - -\begin{Variants} - -\item {\tt {\num}: \{}\\ -This focuses on the $\num^{th}$ subgoal to prove. - -\end{Variants} - -\begin{ErrMsgs} -\item \errindex{This proof is focused, but cannot be unfocused - this way} You are trying to use {\tt \}} but the current subproof - has not been fully solved. -\item \errindex{No such goal} -\item \errindex{Brackets only support the single numbered goal selector} -\item see also error message about bullets below. -\end{ErrMsgs} - -\subsection[Bullets]{Bullets\comindex{+ (command)} - \comindex{- (command)}\comindex{* (command)}\index{Bullets}}\label{bullets} -Alternatively to {\tt \{} and {\tt \}}, proofs can be structured with -bullets. The use of a bullet $b$ for the first time focuses on the -first goal $g$, the same bullet cannot be used again until the proof -of $g$ is completed, then it is mandatory to focus the next goal with $b$. The -consequence is that $g$ and all goals present when $g$ was focused are -focused with the same bullet $b$. See the example below. - -Different bullets can be used to nest levels. The scope of bullet does -not go beyond enclosing {\tt \{} and {\tt \}}, so bullets can be -reused as further nesting levels provided they are delimited by these. -Available bullets are {\tt -}, {\tt +}, {\tt *}, {\tt --}, {\tt ++}, {\tt **}, -{\tt ---}, {\tt +++}, {\tt ***}, ... (without a -terminating period). - -Note again that when a focused goal is proved a message is displayed -together with a suggestion about the right bullet or {\tt \}} to -unfocus it or focus the next one. - -Remark: In {\ProofGeneral} (Emacs interface to {\Coq}), you must use -bullets with the priority ordering shown above to have a correct -indentation. For example {\tt -} must be the outer bullet and {\tt **} -the inner one in the example below. - -The following example script illustrates all these features: -\begin{coq_example*} -Goal (((True/\True)/\True)/\True)/\True. -Proof. - split. - - split. - + split. - ** { split. - - trivial. - - trivial. - } - ** trivial. - + trivial. - - assert True. - { trivial. } - assumption. -\end{coq_example*} - - -\begin{ErrMsgs} -\item \errindex{Wrong bullet {\abullet}1 : Current bullet - {\abullet}2 is not finished.} - - Before using bullet {\abullet}1 again, you should first finish - proving the current focused goal. Note that {\abullet}1 and - {\abullet}2 may be the same. - -\item \errindex{Wrong bullet {\abullet}1 : Bullet {\abullet}2 - is mandatory here.} You must put {\abullet}2 to focus next goal. - No other bullet is allowed here. - - -\item \errindex{No such goal. Focus next goal with bullet - {\abullet}.} - - You tried to applied a tactic but no goal where under focus. Using - {\abullet} is mandatory here. - -\item \errindex{No such goal. Try unfocusing with {"{\tt \}}"}.} You - just finished a goal focused by {\tt \{}, you must unfocus it with "{\tt \}}". - -\end{ErrMsgs} - -\subsection[\tt Set Bullet Behavior.]{\tt Set Bullet Behavior.\optindex{Bullet Behavior}} - -The bullet behavior can be controlled by the following commands. - -\begin{quote} -Set Bullet Behavior "None". -\end{quote} - -This makes bullets inactive. - -\begin{quote} -Set Bullet Behavior "Strict Subproofs". -\end{quote} - -This makes bullets active (this is the default behavior). - -\section{Requesting information} - -\subsection[\tt Show.]{\tt Show.\comindex{Show}\label{Show}} -This command displays the current goals. - -\begin{Variants} -\item {\tt Show {\num}.}\\ - Displays only the {\num}-th subgoal.\\ -\begin{ErrMsgs} -\item \errindex{No such goal} -\item \errindex{No focused proof} -\end{ErrMsgs} - -\item {\tt Show {\ident}.}\\ - Displays the named goal {\ident}. - This is useful in particular to display a shelved goal but only works - if the corresponding existential variable has been named by the user - (see~\ref{ExistentialVariables}) as in the following example. - -\begin{coq_eval} -Reset Initial. -\end{coq_eval} - -\begin{coq_example*} -Goal exists n, n = 0. - eexists ?[n]. -\end{coq_example*} -\begin{coq_example} - Show n. -\end{coq_example} - -\item {\tt Show Script.}\comindex{Show Script}\\ - Displays the whole list of tactics applied from the beginning - of the current proof. - This tactics script may contain some holes (subgoals not yet proved). - They are printed under the form \verb!<Your Tactic Text here>!. - -\item {\tt Show Proof.}\comindex{Show Proof}\\ -It displays the proof term generated by the -tactics that have been applied. -If the proof is not completed, this term contain holes, -which correspond to the sub-terms which are still to be -constructed. These holes appear as a question mark indexed -by an integer, and applied to the list of variables in -the context, since it may depend on them. -The types obtained by abstracting away the context from the -type of each hole-placer are also printed. - -\item {\tt Show Conjectures.}\comindex{Show Conjectures}\\ -It prints the list of the names of all the theorems that -are currently being proved. -As it is possible to start proving a previous lemma during -the proof of a theorem, this list may contain several -names. - -\item{\tt Show Intro.}\comindex{Show Intro}\\ -If the current goal begins by at least one product, this command -prints the name of the first product, as it would be generated by -an anonymous {\tt intro}. The aim of this command is to ease the -writing of more robust scripts. For example, with an appropriate -{\ProofGeneral} macro, it is possible to transform any anonymous {\tt - intro} into a qualified one such as {\tt intro y13}. -In the case of a non-product goal, it prints nothing. - -\item{\tt Show Intros.}\comindex{Show Intros}\\ -This command is similar to the previous one, it simulates the naming -process of an {\tt intros}. - -\item{\tt Show Existentials.\label{ShowExistentials}}\comindex{Show Existentials} -\\ It displays -the set of all uninstantiated existential variables in the current proof tree, -along with the type and the context of each variable. - -\item{\tt Show Match {\ident}.\label{ShowMatch}}\comindex{Show Match}\\ -This variant displays a template of the Gallina {\tt match} construct -with a branch for each constructor of the type {\ident}. - -Example: - -\begin{coq_example} -Show Match nat. -\end{coq_example} -\begin{ErrMsgs} -\item \errindex{Unknown inductive type} -\end{ErrMsgs} - -\item{\tt Show Universes.\label{ShowUniverses}}\comindex{Show Universes} -\\ It displays the set of all universe constraints and its -normalized form at the current stage of the proof, useful for -debugging universe inconsistencies. - -\end{Variants} - - -\subsection[\tt Guarded.]{\tt Guarded.\comindex{Guarded}\label{Guarded}} - -Some tactics (e.g. refine \ref{refine}) allow to build proofs using -fixpoint or co-fixpoint constructions. Due to the incremental nature -of interactive proof construction, the check of the termination (or -guardedness) of the recursive calls in the fixpoint or cofixpoint -constructions is postponed to the time of the completion of the proof. - -The command \verb!Guarded! allows checking if the guard condition for -fixpoint and cofixpoint is violated at some time of the construction -of the proof without having to wait the completion of the proof." - - -\section{Controlling the effect of proof editing commands} - -\subsection[\tt Set Hyps Limit {\num}.]{\tt Set Hyps Limit {\num}.\optindex{Hyps Limit}} -This command sets the maximum number of hypotheses displayed in -goals after the application of a tactic. -All the hypotheses remains usable in the proof development. - - -\subsection[\tt Unset Hyps Limit.]{\tt Unset Hyps Limit.\optindex{Hyps Limit}} -This command goes back to the default mode which is to print all -available hypotheses. - - -\subsection[\tt Set Automatic Introduction.]{\tt Set Automatic Introduction.\optindex{Automatic Introduction}\label{Set Automatic Introduction}} - -The option {\tt Automatic Introduction} controls the way binders are -handled in assertion commands such as {\tt Theorem {\ident} - \zeroone{\binders} : {\form}}. When the option is set, which is the -default, {\binders} are automatically put in the local context of the -goal to prove. - -The option can be unset by issuing {\tt Unset Automatic Introduction}. -When the option is unset, {\binders} are discharged on the statement -to be proved and a tactic such as {\tt intro} (see -Section~\ref{intro}) has to be used to move the assumptions to the -local context. - -\section{Controlling memory usage\comindex{Optimize Proof}\comindex{Optimize Heap}} - -When experiencing high memory usage the following commands can be -used to force Coq to optimize some of its internal data structures. - -\subsection[\tt Optimize Proof.]{\tt Optimize Proof.} - -This command forces Coq to shrink the data structure used to represent -the ongoing proof. - -\subsection[\tt Optimize Heap.]{\tt Optimize Heap.\label{vernac-optimizeheap}} - -This command forces the OCaml runtime to perform a heap compaction. -This is in general an expensive operation. See: \\ -\ \url{http://caml.inria.fr/pub/docs/manual-ocaml/libref/Gc.html#VALcompact} \\ -There is also an analogous tactic {\tt optimize\_heap} (see~\ref{tactic-optimizeheap}). - -%%% Local Variables: -%%% mode: latex -%%% TeX-master: "Reference-Manual" -%%% End: diff --git a/doc/refman/RefMan-uti.tex b/doc/refman/RefMan-uti.tex deleted file mode 100644 index 962aa98b6..000000000 --- a/doc/refman/RefMan-uti.tex +++ /dev/null @@ -1,482 +0,0 @@ -\chapter[Utilities]{Utilities\label{Utilities}} -%HEVEA\cutname{tools.html} - -The distribution provides utilities to simplify some tedious works -beside proof development, tactics writing or documentation. - -\section[Using Coq as a library]{Using Coq as a library} - -In previous versions, \texttt{coqmktop} was used to build custom -toplevels --- for example for better debugging or custom static -linking. Nowadays, the preferred method is to use \texttt{ocamlfind}. - -The most basic custom toplevel is built using: -\begin{quotation} -\texttt{\% ocamlfind ocamlopt -thread -rectypes -linkall -linkpkg - -package coq.toplevel toplevel/coqtop\_bin.ml -o my\_toplevel.native} -\end{quotation} - -For example, to statically link LTAC, you can just do: -\begin{quotation} -\texttt{\% ocamlfind ocamlopt -thread -rectypes -linkall -linkpkg - -package coq.toplevel -package coq.ltac toplevel/coqtop\_bin.ml -o my\_toplevel.native} -\end{quotation} -and similarly for other plugins. - -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% - -\section[Building a \Coq\ project with {\tt coq\_makefile}] -{Building a \Coq\ project with {\tt coq\_makefile} -\label{Makefile} -\ttindex{Makefile} -\ttindex{coq\_Makefile} -\ttindex{\_CoqProject}} - -The majority of \Coq\ projects are very similar: a collection of {\tt .v} -files and eventually some {\tt .ml} ones (a \Coq\ plugin). The main piece -of metadata needed in order to build the project are the command -line options to {\tt coqc} (e.g. {\tt -R, -I}, -\SeeAlso Section~\ref{coqoptions}). Collecting the list of files and -options is the job of the {\tt \_CoqProject} file. - -A simple example of a {\tt \_CoqProject} file follows: - -\begin{verbatim} --R theories/ MyCode -theories/foo.v -theories/bar.v --I src/ -src/baz.ml4 -src/bazaux.ml -src/qux_plugin.mlpack -\end{verbatim} - -Currently, both \CoqIDE{} and Proof General (version $\geq$ 4.3pre) understand -{\tt \_CoqProject} files and invoke \Coq\ with the desired options. - -The {\tt coq\_makefile} utility can be used to set up a build infrastructure -for the \Coq\ project based on makefiles. The recommended way of -invoking {\tt coq\_makefile} is the following one: - -\begin{verbatim} -coq_makefile -f _CoqProject -o CoqMakefile -\end{verbatim} - -Such command generates the following files: -\begin{description} - \item[{\tt CoqMakefile}] is a generic makefile for GNU Make that provides targets to build the project (both {\tt .v} and {\tt .ml*} files), to install it system-wide in the {\tt coq-contrib} directory (i.e. where \Coq\ is installed) as well as to invoke {\tt coqdoc} to generate html documentation. - - \item[{\tt CoqMakefile.conf}] contains make variables assignments that reflect the contents of the {\tt \_CoqProject} file as well as the path relevant to \Coq{}. -\end{description} - -An optional file {\bf {\tt CoqMakefile.local}} can be provided by the user in order to extend {\tt CoqMakefile}. In particular one can declare custom actions to be performed before or after the build process. Similarly one can customize the install target or even provide new targets. Extension points are documented in paragraph \ref{coqmakefile:local}. - -The extensions of the files listed in {\tt \_CoqProject} is -used in order to decide how to build them. In particular: - -\begin{itemize} -\item {\Coq} files must use the \texttt{.v} extension -\item {\ocaml} files must use the \texttt{.ml} or \texttt{.mli} extension -\item {\ocaml} files that require pre processing for syntax extensions (like {\tt VERNAC EXTEND}) must use the \texttt{.ml4} extension -\item In order to generate a plugin one has to list all {\ocaml} modules (i.e. ``Baz'' for ``baz.ml'') in a \texttt{.mlpack} file (or \texttt{.mllib} file). -\end{itemize} - -The use of \texttt{.mlpack} files has to be preferred over \texttt{.mllib} -files, since it results in a ``packed'' plugin: All auxiliary -modules (as {\tt Baz} and {\tt Bazaux}) are hidden inside -the plugin's ``name space'' ({\tt Qux\_plugin}). -This reduces the chances of begin unable to load two distinct plugins -because of a clash in their auxiliary module names. - -\paragraph{CoqMakefile.local} %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -\label{coqmakefile:local} - -The optional file {\tt CoqMakefile.local} is included by the generated file -{\tt CoqMakefile}. Such can contain two kinds of directives. - -\begin{description} - \item[Variable assignment] to the variables listed in the {\tt Parameters} - section of the generated makefile. Here we describe only few of them. - \begin{description} - \item[CAMLPKGS] can be used to specify third party findlib packages, and is - passed to the OCaml compiler on building or linking of modules. - Eg: {\tt -package yojson}. - \item[CAMLFLAGS] can be used to specify additional flags to the OCaml - compiler, like {\tt -bin-annot} or {\tt -w...}. - \item[COQC, COQDEP, COQDOC] can be set in order to use alternative - binaries (e.g. wrappers) - \item[COQ\_SRC\_SUBDIRS] can be extended by including other paths in which {\tt *.cm*} files are searched. For example {\tt COQ\_SRC\_SUBDIRS+=user-contrib/Unicoq} lets you build a plugin containing OCaml code that depends on the OCaml code of {\tt Unicoq}. - \end{description} -\item[Rule extension] - The following makefile rules can be extended. For example -\begin{verbatim} -pre-all:: - echo "This line is print before making the all target" -install-extra:: - cp ThisExtraFile /there/it/goes -\end{verbatim} - \begin{description} - \item[pre-all::] run before the {\tt all} target. One can use this - to configure the project, or initialize sub modules or check - dependencies are met. - \item[post-all::] run after the {\tt all} target. One can use this - to run a test suite, or compile extracted code. - \item[install-extra::] run after {\tt install}. One can use this - to install extra files. - \item[install-doc::] One can use this to install extra doc. - \item[uninstall::] - \item[uninstall-doc::] - \item[clean::] - \item[cleanall::] - \item[archclean::] - \item[merlin-hook::] One can append lines to the generated {\tt .merlin} - file extending this target. - \end{description} -\end{description} - -\paragraph{Timing targets and performance testing} %%%%%%%%%%%%%%%%%%%%%%%%%%% -The generated \texttt{Makefile} supports the generation of two kinds -of timing data: per-file build-times, and per-line times for an -individual file. - -The following targets and \texttt{Makefile} variables allow collection -of per-file timing data: -\begin{itemize} -\item \texttt{TIMED=1} --- passing this variable will cause - \texttt{make} to emit a line describing the user-space build-time - and peak memory usage for each file built. - - \texttt{Note}: On Mac OS, this works best if you've installed - \texttt{gnu-time}. - - \texttt{Example}: For example, the output of \texttt{make TIMED=1} - may look like this: -\begin{verbatim} -COQDEP Fast.v -COQDEP Slow.v -COQC Slow.v -Slow (user: 0.34 mem: 395448 ko) -COQC Fast.v -Fast (user: 0.01 mem: 45184 ko) -\end{verbatim} -\item \texttt{pretty-timed} --- this target stores the output of - \texttt{make TIMED=1} into \texttt{time-of-build.log}, and displays - a table of the times, sorted from slowest to fastest, which is also - stored in \texttt{time-of-build-pretty.log}. If you want to - construct the log for targets other than the default one, you can - pass them via the variable \texttt{TGTS}, e.g., \texttt{make - pretty-timed TGTS="a.vo b.vo"}. - - \texttt{Note}: This target requires \texttt{python} to build the table. - - \texttt{Note}: This target will \emph{append} to the timing log; if - you want a fresh start, you must remove the file - \texttt{time-of-build.log} or run \texttt{make cleanall}. - - \texttt{Example}: For example, the output of \texttt{make - pretty-timed} may look like this: -\begin{verbatim} -COQDEP Fast.v -COQDEP Slow.v -COQC Slow.v -Slow (user: 0.36 mem: 393912 ko) -COQC Fast.v -Fast (user: 0.05 mem: 45992 ko) -Time | File Name --------------------- -0m00.41s | Total --------------------- -0m00.36s | Slow -0m00.05s | Fast -\end{verbatim} -\item \texttt{print-pretty-timed-diff} --- this target builds a table - of timing changes between two compilations; run \texttt{make - make-pretty-timed-before} to build the log of the ``before'' - times, and run \texttt{make make-pretty-timed-after} to build the - log of the ``after'' times. The table is printed on the command - line, and stored in \texttt{time-of-build-both.log}. This target is - most useful for profiling the difference between two commits to a - repo. - - \texttt{Note}: This target requires \texttt{python} to build the table. - - \texttt{Note}: The \texttt{make-pretty-timed-before} and - \texttt{make-pretty-timed-after} targets will \emph{append} to the - timing log; if you want a fresh start, you must remove the files - \texttt{time-of-build-before.log} and - \texttt{time-of-build-after.log} or run \texttt{make cleanall} - \emph{before} building either the ``before'' or ``after'' targets. - - \texttt{Note}: The table will be sorted first by absolute time - differences rounded towards zero to a whole-number of seconds, then - by times in the ``after'' column, and finally lexicographically by - file name. This will put the biggest changes in either direction - first, and will prefer sorting by build-time over subsecond changes - in build time (which are frequently noise); lexicographic sorting - forces an order on files which take effectively no time to compile. - - \texttt{Example}: For example, the output table from \texttt{make - print-pretty-timed-diff} may look like this: -\begin{verbatim} -After | File Name | Before || Change | % Change --------------------------------------------------------- -0m00.39s | Total | 0m00.35s || +0m00.03s | +11.42% --------------------------------------------------------- -0m00.37s | Slow | 0m00.01s || +0m00.36s | +3600.00% -0m00.02s | Fast | 0m00.34s || -0m00.32s | -94.11% -\end{verbatim} -\end{itemize} - -The following targets and \texttt{Makefile} variables allow collection -of per-line timing data: -\begin{itemize} -\item \texttt{TIMING=1} --- passing this variable will cause - \texttt{make} to use \texttt{coqc -time} to write to a - \texttt{.v.timing} file for each \texttt{.v} file compiled, which - contains line-by-line timing information. - - \texttt{Example}: For example, running \texttt{make all TIMING=1} may - result in a file like this: -\begin{verbatim} -Chars 0 - 26 [Require~Coq.ZArith.BinInt.] 0.157 secs (0.128u,0.028s) -Chars 27 - 68 [Declare~Reduction~comp~:=~vm_c...] 0. secs (0.u,0.s) -Chars 69 - 162 [Definition~foo0~:=~Eval~comp~i...] 0.153 secs (0.136u,0.019s) -Chars 163 - 208 [Definition~foo1~:=~Eval~comp~i...] 0.239 secs (0.236u,0.s) -\end{verbatim} - -\item \texttt{print-pretty-single-time-diff - BEFORE=path/to/file.v.before-timing - AFTER=path/to/file.v.after-timing} --- this target will make a - sorted table of the per-line timing differences between the timing - logs in the \texttt{BEFORE} and \texttt{AFTER} files, display it, - and save it to the file specified by the - \texttt{TIME\_OF\_PRETTY\_BUILD\_FILE} variable, which defaults to - \texttt{time-of-build-pretty.log}. - - To generate the \texttt{.v.before-timing} or - \texttt{.v.after-timing} files, you should pass - \texttt{TIMING=before} or \texttt{TIMING=after} rather than - \texttt{TIMING=1}. - - \texttt{Note}: The sorting used here is the same as in the - \texttt{print-pretty-timed-diff} target. - - \texttt{Note}: This target requires \texttt{python} to build the table. - - \texttt{Example}: For example, running - \texttt{print-pretty-single-time-diff} might give a table like this: -\begin{verbatim} -After | Code | Before || Change | % Change ---------------------------------------------------------------------------------------------------- -0m00.50s | Total | 0m04.17s || -0m03.66s | -87.96% ---------------------------------------------------------------------------------------------------- -0m00.145s | Chars 069 - 162 [Definition~foo0~:=~Eval~comp~i...] | 0m00.192s || -0m00.04s | -24.47% -0m00.126s | Chars 000 - 026 [Require~Coq.ZArith.BinInt.] | 0m00.143s || -0m00.01s | -11.88% - N/A | Chars 027 - 068 [Declare~Reduction~comp~:=~nati...] | 0m00.s || +0m00.00s | N/A -0m00.s | Chars 027 - 068 [Declare~Reduction~comp~:=~vm_c...] | N/A || +0m00.00s | N/A -0m00.231s | Chars 163 - 208 [Definition~foo1~:=~Eval~comp~i...] | 0m03.836s || -0m03.60s | -93.97% -\end{verbatim} - -\item \texttt{all.timing.diff}, \texttt{path/to/file.v.timing.diff} - --- The \texttt{path/to/file.v.timing.diff} target will make a - \texttt{.v.timing.diff} file for the corresponding \texttt{.v} file, - with a table as would be generated by the - \texttt{print-pretty-single-time-diff} target; it depends on having - already made the corresponding \texttt{.v.before-timing} and - \texttt{.v.after-timing} files, which can be made by passing - \texttt{TIMING=before} and \texttt{TIMING=after}. The - \texttt{all.timing.diff} target will make such timing difference - files for all of the \texttt{.v} files that the \texttt{Makefile} - knows about. It will fail if some \texttt{.v.before-timing} or - \texttt{.v.after-timing} files don't exist. - - \texttt{Note}: This target requires \texttt{python} to build the table. -\end{itemize} - -\paragraph{Reusing/extending the generated Makefile} %%%%%%%%%%%%%%%%%%%%%%%%% - -Including the generated makefile with an {\tt include} directive is discouraged. -The contents of this file, including variable names -and status of rules shall change in the future. Users are advised to -include {\tt Makefile.conf} or call a target of the generated Makefile -as in {\tt make -f Makefile target} from another Makefile. - -One way to get access to all targets of the generated -\texttt{CoqMakefile} is to have a generic target for invoking unknown -targets. For example: -\begin{verbatim} -# KNOWNTARGETS will not be passed along to CoqMakefile -KNOWNTARGETS := CoqMakefile extra-stuff extra-stuff2 -# KNOWNFILES will not get implicit targets from the final rule, and so -# depending on them won't invoke the submake -# Warning: These files get declared as PHONY, so any targets depending -# on them always get rebuilt -KNOWNFILES := Makefile _CoqProject - -.DEFAULT_GOAL := invoke-coqmakefile - -CoqMakefile: Makefile _CoqProject - $(COQBIN)coq_makefile -f _CoqProject -o CoqMakefile - -invoke-coqmakefile: CoqMakefile - $(MAKE) --no-print-directory -f CoqMakefile $(filter-out $(KNOWNTARGETS),$(MAKECMDGOALS)) - -.PHONY: invoke-coqmakefile $(KNOWNFILES) - -#################################################################### -## Your targets here ## -#################################################################### - -# This should be the last rule, to handle any targets not declared above -%: invoke-coqmakefile - @true -\end{verbatim} - -\paragraph{Building a subset of the targets with -j} %%%%%%%%%%%%%%%%%%%%%%%%% - -To build, say, two targets \texttt{foo.vo} and \texttt{bar.vo} -in parallel one can use \texttt{make only TGTS="foo.vo bar.vo" -j}. - -Note that \texttt{make foo.vo bar.vo -j} has a different meaning for -the make utility, in particular it may build a shared prerequisite twice. - -\paragraph{Notes for users of {\tt coq\_makefile} with version $<$ 8.7} %%%%%% - -\begin{itemize} -\item Support for ``sub-directory'' is deprecated. To perform actions before - or after the build (like invoking make on a subdirectory) one can - hook in {\tt pre-all} and {\tt post-all} extension points -\item \texttt{-extra-phony} and \texttt{-extra} are deprecated. To provide - additional target ({\tt .PHONY} or not) please use - {\tt CoqMakefile.local} -\end{itemize} - -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% - -\section[Modules dependencies]{Modules dependencies\label{Dependencies}\index{Dependencies} - \ttindex{coqdep}} - -In order to compute modules dependencies (so to use {\tt make}), -\Coq\ comes with an appropriate tool, {\tt coqdep}. - -{\tt coqdep} computes inter-module dependencies for \Coq\ and -\ocaml\ programs, and prints the dependencies on the standard -output in a format readable by make. When a directory is given as -argument, it is recursively looked at. - -Dependencies of \Coq\ modules are computed by looking at {\tt Require} -commands ({\tt Require}, {\tt Requi\-re Export}, {\tt Require Import}, -but also at the command {\tt Declare ML Module}. - -Dependencies of \ocaml\ modules are computed by looking at -\verb!open! commands and the dot notation {\em module.value}. However, -this is done approximately and you are advised to use {\tt ocamldep} -instead for the \ocaml\ modules dependencies. - -See the man page of {\tt coqdep} for more details and options. - -The build infrastructure generated by {\tt coq\_makefile} -uses {\tt coqdep} to automatically compute the dependencies -among the files part of the project. - -\section[Documenting \Coq\ files with coqdoc]{Documenting \Coq\ files with coqdoc\label{coqdoc} -\ttindex{coqdoc}} - -\input{./coqdoc} - -\section[Embedded \Coq\ phrases inside \LaTeX\ documents]{Embedded \Coq\ phrases inside \LaTeX\ documents\label{Latex} - \ttindex{coq-tex}\index{Latex@{\LaTeX}}} - -When writing a documentation about a proof development, one may want -to insert \Coq\ phrases inside a \LaTeX\ document, possibly together with -the corresponding answers of the system. We provide a -mechanical way to process such \Coq\ phrases embedded in \LaTeX\ files: the -{\tt coq-tex} filter. This filter extracts Coq phrases embedded in -LaTeX files, evaluates them, and insert the outcome of the evaluation -after each phrase. - -Starting with a file {\em file}{\tt.tex} containing \Coq\ phrases, -the {\tt coq-tex} filter produces a file named {\em file}{\tt.v.tex} with -the \Coq\ outcome. - -There are options to produce the \Coq\ parts in smaller font, italic, -between horizontal rules, etc. -See the man page of {\tt coq-tex} for more details. - -\medskip\noindent {\bf Remark.} This Reference Manual and the Tutorial -have been completely produced with {\tt coq-tex}. - - -\section[\Coq\ and \emacs]{\Coq\ and \emacs\label{Emacs}\index{Emacs}} - -\subsection{The \Coq\ Emacs mode} - -\Coq\ comes with a Major mode for \emacs, {\tt gallina.el}. This mode provides -syntax highlighting -and also a rudimentary indentation facility -in the style of the Caml \emacs\ mode. - -Add the following lines to your \verb!.emacs! file: - -\begin{verbatim} - (setq auto-mode-alist (cons '("\\.v$" . coq-mode) auto-mode-alist)) - (autoload 'coq-mode "gallina" "Major mode for editing Coq vernacular." t) -\end{verbatim} - -The \Coq\ major mode is triggered by visiting a file with extension {\tt .v}, -or manually with the command \verb!M-x coq-mode!. -It gives you the correct syntax table for -the \Coq\ language, and also a rudimentary indentation facility: -\begin{itemize} - \item pressing {\sc Tab} at the beginning of a line indents the line like - the line above; - - \item extra {\sc Tab}s increase the indentation level - (by 2 spaces by default); - - \item M-{\sc Tab} decreases the indentation level. -\end{itemize} - -An inferior mode to run \Coq\ under Emacs, by Marco Maggesi, is also -included in the distribution, in file \texttt{inferior-coq.el}. -Instructions to use it are contained in this file. - -\subsection[{\ProofGeneral}]{{\ProofGeneral}\index{Proof General@{\ProofGeneral}}} - -{\ProofGeneral} is a generic interface for proof assistants based on -Emacs. The main idea is that the \Coq\ commands you are -editing are sent to a \Coq\ toplevel running behind Emacs and the -answers of the system automatically inserted into other Emacs buffers. -Thus you don't need to copy-paste the \Coq\ material from your files -to the \Coq\ toplevel or conversely from the \Coq\ toplevel to some -files. - -{\ProofGeneral} is developed and distributed independently of the -system \Coq. It is freely available at \verb!https://proofgeneral.github.io/!. - - -\section[Module specification]{Module specification\label{gallina}\ttindex{gallina}} - -Given a \Coq\ vernacular file, the {\tt gallina} filter extracts its -specification (inductive types declarations, definitions, type of -lemmas and theorems), removing the proofs parts of the file. The \Coq\ -file {\em file}{\tt.v} gives birth to the specification file -{\em file}{\tt.g} (where the suffix {\tt.g} stands for \gallina). - -See the man page of {\tt gallina} for more details and options. - - -\section[Man pages]{Man pages\label{ManPages}\index{Man pages}} - -There are man pages for the commands {\tt coqdep}, {\tt gallina} and -{\tt coq-tex}. Man pages are installed at installation time -(see installation instructions in file {\tt INSTALL}, step 6). - -%BEGIN LATEX -\RefManCutCommand{ENDREFMAN=\thepage} -%END LATEX - -%%% Local Variables: -%%% mode: latex -%%% TeX-master: t -%%% End: diff --git a/doc/refman/Reference-Manual.tex b/doc/refman/Reference-Manual.tex deleted file mode 100644 index e51116007..000000000 --- a/doc/refman/Reference-Manual.tex +++ /dev/null @@ -1,144 +0,0 @@ -%\RequirePackage{ifpdf} -%\ifpdf -% \documentclass[11pt,a4paper,pdftex]{book} -%\else - \documentclass[11pt,a4paper]{book} -%\fi - -\usepackage[utf8]{inputenc} -\usepackage[T1]{fontenc} -\usepackage{textcomp} -\usepackage{times} -\usepackage{url} -\usepackage{verbatim} -\usepackage{amsmath} -\usepackage{amssymb} -\usepackage{alltt} -\usepackage{hevea} -\usepackage{ifpdf} -\usepackage[headings]{fullpage} -\usepackage{headers} % in this directory -\usepackage{multicol} -\usepackage{xspace} -\usepackage{pmboxdraw} -\usepackage{float} -\usepackage{color} - \definecolor{dkblue}{rgb}{0,0.1,0.5} - \definecolor{lightblue}{rgb}{0,0.5,0.5} - \definecolor{dkgreen}{rgb}{0,0.4,0} - \definecolor{dk2green}{rgb}{0.4,0,0} - \definecolor{dkviolet}{rgb}{0.6,0,0.8} - \definecolor{dkpink}{rgb}{0.2,0,0.6} -\usepackage{listings} - \def\lstlanguagefiles{coq-listing.tex} -\usepackage{tabularx} -\usepackage{array,longtable} - -\floatstyle{boxed} -\restylefloat{figure} - -% for coqide -\ifpdf % si on est pas en pdflatex - \usepackage[pdftex]{graphicx} -\else - \usepackage[dvips]{graphicx} -\fi - - -%\includeonly{Setoid} - -\input{../common/version.tex} -\input{../common/macros.tex}% extension .tex pour htmlgen -\input{../common/title.tex}% extension .tex pour htmlgen -%\input{headers} - -\usepackage[linktocpage,colorlinks,bookmarks=true,bookmarksnumbered=true]{hyperref} -% The manual advises to load hyperref package last to be able to redefine -% necessary commands. -% The above should work for both latex and pdflatex. Even if PDF is produced -% through DVI and PS using dvips and ps2pdf, hyperlinks should still work. -% linktocpage option makes page numbers, not section names, to be links in -% the table of contents. -% colorlinks option colors the links instead of using boxes. - -% The command \tocnumber was added to HEVEA in version 1.06-6. -% It instructs HEVEA to put chapter numbers into the table of -% content entries. The table of content is produced by HACHA using -% the options -tocbis -o toc.html. HEVEA produces a warning when -% a command is not recognized, so versions earlier than 1.06-6 can -% still be used. -%HEVEA\tocnumber - -\begin{document} -%BEGIN LATEX -\sloppy\hbadness=5000 -%END LATEX - -%BEGIN LATEX -\coverpage{Reference Manual} -{The Coq Development Team} -{This material may be distributed only subject to the terms and -conditions set forth in the Open Publication License, v1.0 or later -(the latest version is presently available at -\url{http://www.opencontent.org/openpub}). -Options A and B of the licence are {\em not} elected.} -%END LATEX - -%\defaultheaders - -%BEGIN LATEX -\tableofcontents -%END LATEX - -\part{The language} -%BEGIN LATEX -\defaultheaders -%END LATEX -\include{RefMan-gal.v}% Gallina - - -\part{The proof engine} -\include{RefMan-oth.v}% Vernacular commands -\include{RefMan-pro.v}% Proof handling -\include{RefMan-ltac.v}% Writing tactics - -\lstset{language=SSR} -\lstset{moredelim=[is][]{|*}{*|}} -\lstset{moredelim=*[is][\itshape\rmfamily]{/*}{*/}} - -\part{User extensions} -%%SUPPRIME \include{RefMan-tus.v}% Writing tactics - -\part{Practical tools} -\include{RefMan-uti}% utilities (gallina, do_Makefile, etc) - -%BEGIN LATEX -\RefManCutCommand{BEGINADDENDUM=\thepage} -%END LATEX -\part{Addendum to the Reference Manual} -\include{AddRefMan-pre}% -\include{Universes.v}% Universe polymorphes -%BEGIN LATEX -\RefManCutCommand{ENDADDENDUM=\thepage} -%END LATEX -\nocite{*} -\bibliographystyle{plain} -\bibliography{biblio} -\cutname{biblio.html} - -\printrefmanindex{default}{Global Index}{general-index.html} -\printrefmanindex{tactic}{Tactics Index}{tactic-index.html} -\printrefmanindex{command}{Vernacular Commands Index}{command-index.html} -\printrefmanindex{option}{Vernacular Options Index}{option-index.html} -\printrefmanindex{error}{Index of Error Messages}{error-index.html} - -%BEGIN LATEX -\cleardoublepage -\phantomsection -\addcontentsline{toc}{chapter}{\listfigurename} -\listoffigures -%END LATEX - -\end{document} - - diff --git a/doc/refman/Universes.tex b/doc/refman/Universes.tex deleted file mode 100644 index c7d39c0f3..000000000 --- a/doc/refman/Universes.tex +++ /dev/null @@ -1,393 +0,0 @@ -\achapter{Polymorphic Universes} -%HEVEA\cutname{universes.html} -\aauthor{Matthieu Sozeau} - -\label{Universes-full} -\index{Universes!presentation} - -\asection{General Presentation} - -\begin{flushleft} - \em The status of Universe Polymorphism is experimental. -\end{flushleft} - -This section describes the universe polymorphic extension of Coq. -Universe polymorphism makes it possible to write generic definitions making use of -universes and reuse them at different and sometimes incompatible universe levels. - -A standard example of the difference between universe \emph{polymorphic} and -\emph{monomorphic} definitions is given by the identity function: - -\begin{coq_example*} -Definition identity {A : Type} (a : A) := a. -\end{coq_example*} - -By default, constant declarations are monomorphic, hence the identity -function declares a global universe (say \texttt{Top.1}) for its -domain. Subsequently, if we try to self-apply the identity, we will get -an error: - -\begin{coq_eval} -Set Printing Universes. -\end{coq_eval} -\begin{coq_example} -Fail Definition selfid := identity (@identity). -\end{coq_example} - -Indeed, the global level \texttt{Top.1} would have to be strictly smaller than itself -for this self-application to typecheck, as the type of \texttt{(@identity)} is -\texttt{forall (A : Type@{Top.1}), A -> A} whose type is itself \texttt{Type@{Top.1+1}}. - -A universe polymorphic identity function binds its domain universe level -at the definition level instead of making it global. - -\begin{coq_example} -Polymorphic Definition pidentity {A : Type} (a : A) := a. -About pidentity. -\end{coq_example} - -It is then possible to reuse the constant at different levels, like so: - -\begin{coq_example} -Definition selfpid := pidentity (@pidentity). -\end{coq_example} - -Of course, the two instances of \texttt{pidentity} in this definition -are different. This can be seen when \texttt{Set Printing Universes} is -on: - -\begin{coq_example} -Print selfpid. -\end{coq_example} - -Now \texttt{pidentity} is used at two different levels: at the head of -the application it is instantiated at \texttt{Top.3} while in the -argument position it is instantiated at \texttt{Top.4}. This definition -is only valid as long as \texttt{Top.4} is strictly smaller than -\texttt{Top.3}, as show by the constraints. Note that this definition is -monomorphic (not universe polymorphic), so the two universes -(in this case \texttt{Top.3} and \texttt{Top.4}) are actually global levels. - -When printing \texttt{pidentity}, we can see the universes it binds in -the annotation \texttt{@\{Top.2\}}. Additionally, when \texttt{Set - Printing Universes} is on we print the ``universe context'' of -\texttt{pidentity} consisting of the bound universes and the -constraints they must verify (for \texttt{pidentity} there are no -constraints). - -Inductive types can also be declared universes polymorphic on universes -appearing in their parameters or fields. A typical example is given by -monoids: - -\begin{coq_example} -Polymorphic Record Monoid := { mon_car :> Type; mon_unit : mon_car; - mon_op : mon_car -> mon_car -> mon_car }. -Print Monoid. -\end{coq_example} - -The \texttt{Monoid}'s carrier universe is polymorphic, hence it is -possible to instantiate it for example with \texttt{Monoid} itself. -First we build the trivial unit monoid in \texttt{Set}: -\begin{coq_example} -Definition unit_monoid : Monoid := - {| mon_car := unit; mon_unit := tt; mon_op x y := tt |}. -\end{coq_example} - -From this we can build a definition for the monoid of -\texttt{Set}-monoids (where multiplication would be given by the product -of monoids). - -\begin{coq_example*} -Polymorphic Definition monoid_monoid : Monoid. - refine (@Build_Monoid Monoid unit_monoid (fun x y => x)). -Defined. -\end{coq_example*} -\begin{coq_example} -Print monoid_monoid. -\end{coq_example} - -As one can see from the constraints, this monoid is ``large'', it lives -in a universe strictly higher than \texttt{Set}. - -\asection{\tt Polymorphic, Monomorphic} -\comindex{Polymorphic} -\comindex{Monomorphic} -\optindex{Universe Polymorphism} - -As shown in the examples, polymorphic definitions and inductives can be -declared using the \texttt{Polymorphic} prefix. There also exists an -option \texttt{Set Universe Polymorphism} which will implicitly prepend -it to any definition of the user. In that case, to make a definition -producing global universe constraints, one can use the -\texttt{Monomorphic} prefix. Many other commands support the -\texttt{Polymorphic} flag, including: - -\begin{itemize} -\item \texttt{Lemma}, \texttt{Axiom}, and all the other ``definition'' - keywords support polymorphism. -\item \texttt{Variables}, \texttt{Context}, \texttt{Universe} and - \texttt{Constraint} in a section support polymorphism. This means - that the universe variables (and associated constraints) are - discharged polymorphically over definitions that use them. In other - words, two definitions in the section sharing a common variable will - both get parameterized by the universes produced by the variable - declaration. This is in contrast to a ``mononorphic'' variable which - introduces global universes and constraints, making the two - definitions depend on the \emph{same} global universes associated to - the variable. -\item \texttt{Hint \{Resolve, Rewrite\}} will use the auto/rewrite hint - polymorphically, not at a single instance. -\end{itemize} - -\asection{{\tt Cumulative, NonCumulative}} -\comindex{Cumulative} -\comindex{NonCumulative} -\optindex{Polymorphic Inductive Cumulativity} - -Polymorphic inductive types, coinductive types, variants and records can be -declared cumulative using the \texttt{Cumulative} prefix. Alternatively, -there is an option \texttt{Set Polymorphic Inductive Cumulativity} which when set, -makes all subsequent \emph{polymorphic} inductive definitions cumulative. When set, -inductive types and the like can be enforced to be -\emph{non-cumulative} using the \texttt{NonCumulative} prefix. Consider the examples below. -\begin{coq_example*} -Polymorphic Cumulative Inductive list {A : Type} := -| nil : list -| cons : A -> list -> list. -\end{coq_example*} -\begin{coq_example} -Print list. -\end{coq_example} -When printing \texttt{list}, the universe context indicates the -subtyping constraints by prefixing the level names with symbols. - -Because inductive subtypings are only produced by comparing inductives -to themselves with universes changed, they amount to variance -information: each universe is either invariant, covariant or -irrelevant (there are no contravariant subtypings in Coq), -respectively represented by the symbols \texttt{=}, \texttt{+} and -\texttt{*}. - -Here we see that \texttt{list} binds an irrelevant universe, so any -two instances of \texttt{list} are convertible: -$\WTEGCONV{\mathtt{list@\{i\}} A}{\mathtt{list@\{j\}} B}$ whenever -$\WTEGCONV{A}{B}$ and furthermore their corresponding (when fully -applied to convertible arguments) constructors. - -See Chapter~\ref{Cic} for more details on convertibility and subtyping. -The following is an example of a record with non-trivial subtyping relation: -\begin{coq_example*} -Polymorphic Cumulative Record packType := {pk : Type}. -\end{coq_example*} -\begin{coq_example} -Print packType. -\end{coq_example} -\texttt{packType} binds a covariant universe, i.e. -$\WTEGCONV{\mathtt{packType@\{i\}}}{\mathtt{packType@\{j\}}}$ whenever -\texttt{i $\leq$ j}. - -Cumulative inductive types, coninductive types, variants and records -only make sense when they are universe polymorphic. Therefore, an -error is issued whenever the user uses the \texttt{Cumulative} or -\texttt{NonCumulative} prefix in a monomorphic context. -Notice that this is not the case for the option \texttt{Set Polymorphic Inductive Cumulativity}. -That is, this option, when set, makes all subsequent \emph{polymorphic} -inductive declarations cumulative (unless, of course the \texttt{NonCumulative} prefix is used) -but has no effect on \emph{monomorphic} inductive declarations. -Consider the following examples. -\begin{coq_example} -Monomorphic Cumulative Inductive Unit := unit. -\end{coq_example} -\begin{coq_example} -Monomorphic NonCumulative Inductive Unit := unit. -\end{coq_example} -\begin{coq_example*} -Set Polymorphic Inductive Cumulativity. -Inductive Unit := unit. -\end{coq_example*} -\begin{coq_example} -Print Unit. -\end{coq_example} - -\subsection*{An example of a proof using cumulativity} - -\begin{coq_example} -Set Universe Polymorphism. -Set Polymorphic Inductive Cumulativity. - -Inductive eq@{i} {A : Type@{i}} (x : A) : A -> Type@{i} := eq_refl : eq x x. - -Definition funext_type@{a b e} (A : Type@{a}) (B : A -> Type@{b}) - := forall f g : (forall a, B a), - (forall x, eq@{e} (f x) (g x)) - -> eq@{e} f g. - -Section down. - Universes a b e e'. - Constraint e' < e. - Lemma funext_down {A B} - (H : @funext_type@{a b e} A B) : @funext_type@{a b e'} A B. - Proof. - exact H. - Defined. -\end{coq_example} - -\subsection{\tt Cumulativity Weak Constraints} -\optindex{Cumulativity Weak Constraints} - -This option, on by default, causes ``weak'' constraints to be produced -when comparing universes in an irrelevant position. Processing weak -constraints is delayed until minimization time. A weak constraint -between {\tt u} and {\tt v} when neither is smaller than the other and -one is flexible causes them to be unified. Otherwise the constraint is -silently discarded. - -This heuristic is experimental and may change in future versions. -Disabling weak constraints is more predictable but may produce -arbitrary numbers of universes. - -\asection{Global and local universes} - -Each universe is declared in a global or local environment before it can -be used. To ensure compatibility, every \emph{global} universe is set to -be strictly greater than \Set~when it is introduced, while every -\emph{local} (i.e. polymorphically quantified) universe is introduced as -greater or equal to \Set. - -\asection{Conversion and unification} - -The semantics of conversion and unification have to be modified a little -to account for the new universe instance arguments to polymorphic -references. The semantics respect the fact that definitions are -transparent, so indistinguishable from their bodies during conversion. - -This is accomplished by changing one rule of unification, the -first-order approximation rule, which applies when two applicative terms -with the same head are compared. It tries to short-cut unfolding by -comparing the arguments directly. In case the constant is universe -polymorphic, we allow this rule to fire only when unifying the universes -results in instantiating a so-called flexible universe variables (not -given by the user). Similarly for conversion, if such an equation of -applicative terms fail due to a universe comparison not being satisfied, -the terms are unfolded. This change implies that conversion and -unification can have different unfolding behaviors on the same -development with universe polymorphism switched on or off. - -\asection{Minimization} -\optindex{Universe Minimization ToSet} - -Universe polymorphism with cumulativity tends to generate many useless -inclusion constraints in general. Typically at each application of a -polymorphic constant $f$, if an argument has expected type -\verb|Type@{i}| and is given a term of type \verb|Type@{j}|, a $j \le i$ -constraint will be generated. It is however often the case that an -equation $j = i$ would be more appropriate, when $f$'s -universes are fresh for example. Consider the following example: - -\begin{coq_eval} -Set Printing Universes. -\end{coq_eval} -\begin{coq_example} -Definition id0 := @pidentity nat 0. -Print id0. -\end{coq_example} - -This definition is elaborated by minimizing the universe of id to level -\Set~while the more general definition would keep the fresh level i -generated at the application of id and a constraint that $\Set \le i$. -This minimization process is applied only to fresh universe -variables. It simply adds an equation between the variable and its lower -bound if it is an atomic universe (i.e. not an algebraic \texttt{max()} -universe). - -The option \texttt{Unset Universe Minimization ToSet} disallows -minimization to the sort $\Set$ and only collapses floating universes -between themselves. - -\asection{Explicit Universes} - -The syntax has been extended to allow users to explicitly bind names to -universes and explicitly instantiate polymorphic definitions. - -\subsection{\tt Universe {\ident}. - \comindex{Universe} - \label{UniverseCmd}} - -In the monorphic case, this command declares a new global universe named -{\ident}, which can be referred to using its qualified name as -well. Global universe names live in a separate namespace. The command -supports the polymorphic flag only in sections, meaning the universe -quantification will be discharged on each section definition -independently. One cannot mix polymorphic and monomorphic declarations -in the same section. - -\subsection{\tt Constraint {\ident} {\textit{ord}} {\ident}. - \comindex{Constraint} - \label{ConstraintCmd}} - -This command declares a new constraint between named universes. -The order relation can be one of $<$, $\le$ or $=$. If consistent, -the constraint is then enforced in the global environment. Like -\texttt{Universe}, it can be used with the \texttt{Polymorphic} prefix -in sections only to declare constraints discharged at section closing time. -One cannot declare a global constraint on polymorphic universes. - -\begin{ErrMsgs} -\item \errindex{Undeclared universe {\ident}}. -\item \errindex{Universe inconsistency} -\end{ErrMsgs} - -\subsection{Polymorphic definitions} -For polymorphic definitions, the declaration of (all) universe levels -introduced by a definition uses the following syntax: - -\begin{coq_example*} -Polymorphic Definition le@{i j} (A : Type@{i}) : Type@{j} := A. -\end{coq_example*} -\begin{coq_example} -Print le. -\end{coq_example} - -During refinement we find that $j$ must be larger or equal than $i$, as -we are using $A : Type@{i} <= Type@{j}$, hence the generated -constraint. At the end of a definition or proof, we check that the only -remaining universes are the ones declared. In the term and in general in -proof mode, introduced universe names can be referred to in -terms. Note that local universe names shadow global universe names. -During a proof, one can use \texttt{Show Universes} to display -the current context of universes. - -Definitions can also be instantiated explicitly, giving their full instance: -\begin{coq_example} -Check (pidentity@{Set}). -Universes k l. -Check (le@{k l}). -\end{coq_example} - -User-named universes and the anonymous universe implicitly attached to -an explicit $Type$ are considered rigid for unification and are never -minimized. Flexible anonymous universes can be produced with an -underscore or by omitting the annotation to a polymorphic definition. - -\begin{coq_example} - Check (fun x => x) : Type -> Type. - Check (fun x => x) : Type -> Type@{_}. - - Check le@{k _}. - Check le. -\end{coq_example} - -\subsection{\tt Unset Strict Universe Declaration. - \optindex{Strict Universe Declaration} - \label{StrictUniverseDeclaration}} - -The command \texttt{Unset Strict Universe Declaration} allows one to -freely use identifiers for universes without declaring them first, with -the semantics that the first use declares it. In this mode, the universe -names are not associated with the definition or proof once it has been -defined. This is meant mainly for debugging purposes. - -%%% Local Variables: -%%% mode: latex -%%% TeX-master: "Reference-Manual" -%%% End: diff --git a/doc/refman/biblio.bib b/doc/refman/biblio.bib deleted file mode 100644 index e69725838..000000000 --- a/doc/refman/biblio.bib +++ /dev/null @@ -1,1397 +0,0 @@ -@String{jfp = "Journal of Functional Programming"} -@String{lncs = "Lecture Notes in Computer Science"} -@String{lnai = "Lecture Notes in Artificial Intelligence"} -@String{SV = "{Sprin-ger-Verlag}"} - -@InProceedings{Aud91, - author = {Ph. Audebaud}, - booktitle = {Proceedings of the sixth Conf. on Logic in Computer Science.}, - publisher = {IEEE}, - title = {Partial {Objects} in the {Calculus of Constructions}}, - year = {1991} -} - -@PhDThesis{Aud92, - author = {Ph. Audebaud}, - school = {{Universit\'e} Bordeaux I}, - title = {Extension du Calcul des Constructions par Points fixes}, - year = {1992} -} - -@InProceedings{Audebaud92b, - author = {Ph. Audebaud}, - booktitle = {{Proceedings of the 1992 Workshop on Types for Proofs and Programs}}, - editor = {{B. Nordstr\"om and K. Petersson and G. Plotkin}}, - note = {Also Research Report LIP-ENS-Lyon}, - pages = {21--34}, - title = {{CC+ : an extension of the Calculus of Constructions with fixpoints}}, - year = {1992} -} - -@InProceedings{Augustsson85, - author = {L. Augustsson}, - title = {{Compiling Pattern Matching}}, - booktitle = {Conference Functional Programming and -Computer Architecture}, - year = {1985} -} - -@Article{BaCo85, - author = {J.L. Bates and R.L. Constable}, - journal = {ACM transactions on Programming Languages and Systems}, - title = {Proofs as {Programs}}, - volume = {7}, - year = {1985} -} - -@Book{Bar81, - author = {H.P. Barendregt}, - publisher = {North-Holland}, - title = {The Lambda Calculus its Syntax and Semantics}, - year = {1981} -} - -@TechReport{Bar91, - author = {H. Barendregt}, - institution = {Catholic University Nijmegen}, - note = {In Handbook of Logic in Computer Science, Vol II}, - number = {91-19}, - title = {Lambda {Calculi with Types}}, - year = {1991} -} - -@Article{BeKe92, - author = {G. Bellin and J. Ketonen}, - journal = {Theoretical Computer Science}, - pages = {115--142}, - title = {A decision procedure revisited : Notes on direct logic, linear logic and its implementation}, - volume = {95}, - year = {1992} -} - -@Book{Bee85, - author = {M.J. Beeson}, - publisher = SV, - title = {Foundations of Constructive Mathematics, Metamathematical Studies}, - year = {1985} -} - -@Book{Bis67, - author = {E. Bishop}, - publisher = {McGraw-Hill}, - title = {Foundations of Constructive Analysis}, - year = {1967} -} - -@Book{BoMo79, - author = {R.S. Boyer and J.S. Moore}, - key = {BoMo79}, - publisher = {Academic Press}, - series = {ACM Monograph}, - title = {A computational logic}, - year = {1979} -} - -@MastersThesis{Bou92, - author = {S. Boutin}, - month = sep, - school = {{Universit\'e Paris 7}}, - title = {Certification d'un compilateur {ML en Coq}}, - year = {1992} -} - -@InProceedings{Bou97, - title = {Using reflection to build efficient and certified decision procedure -s}, - author = {S. Boutin}, - booktitle = {TACS'97}, - editor = {Martin Abadi and Takahashi Ito}, - publisher = SV, - series = lncs, - volume = 1281, - year = {1997} -} - -@PhDThesis{Bou97These, - author = {S. Boutin}, - title = {R\'eflexions sur les quotients}, - school = {Paris 7}, - year = 1997, - type = {th\`ese d'Universit\'e}, - month = apr -} - -@Article{Bru72, - author = {N.J. de Bruijn}, - journal = {Indag. Math.}, - title = {{Lambda-Calculus Notation with Nameless Dummies, a Tool for Automatic Formula Manipulation, with Application to the Church-Rosser Theorem}}, - volume = {34}, - year = {1972} -} - - -@InCollection{Bru80, - author = {N.J. de Bruijn}, - booktitle = {to H.B. Curry : Essays on Combinatory Logic, Lambda Calculus and Formalism.}, - editor = {J.P. Seldin and J.R. Hindley}, - publisher = {Academic Press}, - title = {A survey of the project {Automath}}, - year = {1980} -} - -@TechReport{COQ93, - author = {G. Dowek and A. Felty and H. Herbelin and G. Huet and C. Murthy and C. Parent and C. Paulin-Mohring and B. Werner}, - institution = {INRIA}, - month = may, - number = {154}, - title = {{The Coq Proof Assistant User's Guide Version 5.8}}, - year = {1993} -} - -@TechReport{COQ02, - author = {The Coq Development Team}, - institution = {INRIA}, - month = Feb, - number = {255}, - title = {{The Coq Proof Assistant Reference Manual Version 7.2}}, - year = {2002} -} - -@TechReport{CPar93, - author = {C. Parent}, - institution = {Ecole {Normale} {Sup\'erieure} de {Lyon}}, - month = oct, - note = {Also in~\cite{Nijmegen93}}, - number = {93-29}, - title = {Developing certified programs in the system {Coq}- {The} {Program} tactic}, - year = {1993} -} - -@PhDThesis{CPar95, - author = {C. Parent}, - school = {Ecole {Normale} {Sup\'erieure} de {Lyon}}, - title = {{Synth\`ese de preuves de programmes dans le Calcul des Constructions Inductives}}, - year = {1995} -} - -@Book{Caml, - author = {P. Weis and X. Leroy}, - publisher = {InterEditions}, - title = {Le langage Caml}, - year = {1993} -} - -@InProceedings{ChiPotSimp03, - author = {Laurent Chicli and Lo\"{\i}c Pottier and Carlos Simpson}, - title = {Mathematical Quotients and Quotient Types in Coq}, - booktitle = {TYPES}, - crossref = {DBLP:conf/types/2002}, - year = {2002} -} - -@TechReport{CoC89, - author = {Projet Formel}, - institution = {INRIA}, - number = {110}, - title = {{The Calculus of Constructions. Documentation and user's guide, Version 4.10}}, - year = {1989} -} - -@InProceedings{CoHu85a, - author = {Th. Coquand and G. Huet}, - address = {Linz}, - booktitle = {EUROCAL'85}, - publisher = SV, - series = LNCS, - title = {{Constructions : A Higher Order Proof System for Mechanizing Mathematics}}, - volume = {203}, - year = {1985} -} - -@InProceedings{CoHu85b, - author = {Th. Coquand and G. Huet}, - booktitle = {Logic Colloquium'85}, - editor = {The Paris Logic Group}, - publisher = {North-Holland}, - title = {{Concepts Math\'ematiques et Informatiques formalis\'es dans le Calcul des Constructions}}, - year = {1987} -} - -@Article{CoHu86, - author = {Th. Coquand and G. Huet}, - journal = {Information and Computation}, - number = {2/3}, - title = {The {Calculus of Constructions}}, - volume = {76}, - year = {1988} -} - -@InProceedings{CoPa89, - author = {Th. Coquand and C. Paulin-Mohring}, - booktitle = {Proceedings of Colog'88}, - editor = {P. Martin-L\"of and G. Mints}, - publisher = SV, - series = LNCS, - title = {Inductively defined types}, - volume = {417}, - year = {1990} -} - -@Book{Con86, - author = {R.L. {Constable et al.}}, - publisher = {Prentice-Hall}, - title = {{Implementing Mathematics with the Nuprl Proof Development System}}, - year = {1986} -} - -@PhDThesis{Coq85, - author = {Th. Coquand}, - month = jan, - school = {Universit\'e Paris~7}, - title = {Une Th\'eorie des Constructions}, - year = {1985} -} - -@InProceedings{Coq86, - author = {Th. Coquand}, - address = {Cambridge, MA}, - booktitle = {Symposium on Logic in Computer Science}, - publisher = {IEEE Computer Society Press}, - title = {{An Analysis of Girard's Paradox}}, - year = {1986} -} - -@InProceedings{Coq90, - author = {Th. Coquand}, - booktitle = {Logic and Computer Science}, - editor = {P. Oddifredi}, - note = {INRIA Research Report 1088, also in~\cite{CoC89}}, - publisher = {Academic Press}, - title = {{Metamathematical Investigations of a Calculus of Constructions}}, - year = {1990} -} - -@InProceedings{Coq91, - author = {Th. Coquand}, - booktitle = {Proceedings 9th Int. Congress of Logic, Methodology and Philosophy of Science}, - title = {{A New Paradox in Type Theory}}, - month = {August}, - year = {1991} -} - -@InProceedings{Coq92, - author = {Th. Coquand}, - title = {{Pattern Matching with Dependent Types}}, - year = {1992}, - crossref = {Bastad92} -} - -@InProceedings{Coquand93, - author = {Th. Coquand}, - booktitle = {Types for Proofs and Programs}, - editor = {H. Barendregt and T. Nipokow}, - publisher = SV, - series = LNCS, - title = {{Infinite objects in Type Theory}}, - volume = {806}, - year = {1993}, - pages = {62-78} -} - -@inproceedings{Corbineau08types, - author = {P. Corbineau}, - title = {A Declarative Language for the Coq Proof Assistant}, - editor = {M. Miculan and I. Scagnetto and F. Honsell}, - booktitle = {TYPES '07, Cividale del Friuli, Revised Selected Papers}, - publisher = {Springer}, - series = LNCS, - volume = {4941}, - year = {2007}, - pages = {69-84}, - ee = {http://dx.doi.org/10.1007/978-3-540-68103-8_5}, -} - -@PhDThesis{Cor97, - author = {C. Cornes}, - month = nov, - school = {{Universit\'e Paris 7}}, - title = {Conception d'un langage de haut niveau de représentation de preuves}, - type = {Th\`ese de Doctorat}, - year = {1997} -} - -@MastersThesis{Cou94a, - author = {J. Courant}, - month = sep, - school = {DEA d'Informatique, ENS Lyon}, - title = {Explicitation de preuves par r\'ecurrence implicite}, - year = {1994} -} - -@book{Cur58, - author = {Haskell B. Curry and Robert Feys and William Craig}, - title = {Combinatory Logic}, - volume = 1, - publisher = "North-Holland", - year = 1958, - note = {{\S{9E}}}, -} - -@InProceedings{Del99, - author = {Delahaye, D.}, - title = {Information Retrieval in a Coq Proof Library using - Type Isomorphisms}, - booktitle = {Proceedings of TYPES '99, L\"okeberg}, - publisher = SV, - series = lncs, - year = {1999}, - url = - "\\{\sf ftp://ftp.inria.fr/INRIA/Projects/coq/David.Delahaye/papers/}"# - "{\sf TYPES99-SIsos.ps.gz}" -} - -@InProceedings{Del00, - author = {Delahaye, D.}, - title = {A {T}actic {L}anguage for the {S}ystem {{\sf Coq}}}, - booktitle = {Proceedings of Logic for Programming and Automated Reasoning - (LPAR), Reunion Island}, - publisher = SV, - series = LNCS, - volume = {1955}, - pages = {85--95}, - month = {November}, - year = {2000}, - url = - "{\sf ftp://ftp.inria.fr/INRIA/Projects/coq/David.Delahaye/papers/}"# - "{\sf LPAR2000-ltac.ps.gz}" -} - -@InProceedings{DelMay01, - author = {Delahaye, D. and Mayero, M.}, - title = {{\tt Field}: une proc\'edure de d\'ecision pour les nombres r\'eels en {\Coq}}, - booktitle = {Journ\'ees Francophones des Langages Applicatifs, Pontarlier}, - publisher = {INRIA}, - month = {Janvier}, - year = {2001}, - url = - "\\{\sf ftp://ftp.inria.fr/INRIA/Projects/coq/David.Delahaye/papers/}"# - "{\sf JFLA2000-Field.ps.gz}" -} - -@TechReport{Dow90, - author = {G. Dowek}, - institution = {INRIA}, - number = {1283}, - title = {Naming and Scoping in a Mathematical Vernacular}, - type = {Research Report}, - year = {1990} -} - -@Article{Dow91a, - author = {G. Dowek}, - journal = {Compte-Rendus de l'Acad\'emie des Sciences}, - note = {The undecidability of Third Order Pattern Matching in Calculi with Dependent Types or Type Constructors}, - number = {12}, - pages = {951--956}, - title = {L'Ind\'ecidabilit\'e du Filtrage du Troisi\`eme Ordre dans les Calculs avec Types D\'ependants ou Constructeurs de Types}, - volume = {I, 312}, - year = {1991} -} - -@InProceedings{Dow91b, - author = {G. Dowek}, - booktitle = {Proceedings of Mathematical Foundation of Computer Science}, - note = {Also INRIA Research Report}, - pages = {151--160}, - publisher = SV, - series = LNCS, - title = {A Second Order Pattern Matching Algorithm in the Cube of Typed $\lambda$-calculi}, - volume = {520}, - year = {1991} -} - -@PhDThesis{Dow91c, - author = {G. Dowek}, - month = dec, - school = {Universit\'e Paris 7}, - title = {D\'emonstration automatique dans le Calcul des Constructions}, - year = {1991} -} - -@Article{Dow92a, - author = {G. Dowek}, - title = {The Undecidability of Pattern Matching in Calculi where Primitive Recursive Functions are Representable}, - year = 1993, - journal = tcs, - volume = 107, - number = 2, - pages = {349-356} -} - -@Article{Dow94a, - author = {G. Dowek}, - journal = {Annals of Pure and Applied Logic}, - volume = {69}, - pages = {135--155}, - title = {Third order matching is decidable}, - year = {1994} -} - -@InProceedings{Dow94b, - author = {G. Dowek}, - booktitle = {Proceedings of the second international conference on typed lambda calculus and applications}, - title = {Lambda-calculus, Combinators and the Comprehension Schema}, - year = {1995} -} - -@InProceedings{Dyb91, - author = {P. Dybjer}, - booktitle = {Logical Frameworks}, - editor = {G. Huet and G. Plotkin}, - pages = {59--79}, - publisher = {Cambridge University Press}, - title = {Inductive sets and families in {Martin-Löf's} - Type Theory and their set-theoretic semantics: An inversion principle for {Martin-L\"of's} type theory}, - volume = {14}, - year = {1991} -} - -@Article{Dyc92, - author = {Roy Dyckhoff}, - journal = {The Journal of Symbolic Logic}, - month = sep, - number = {3}, - title = {Contraction-free sequent calculi for intuitionistic logic}, - volume = {57}, - year = {1992} -} - -@MastersThesis{Fil94, - author = {J.-C. Filli\^atre}, - month = sep, - school = {DEA d'Informatique, ENS Lyon}, - title = {Une proc\'edure de d\'ecision pour le Calcul des Pr\'edicats Direct. Étude et impl\'ementation dans le syst\`eme {\Coq}}, - year = {1994} -} - -@TechReport{Filliatre95, - author = {J.-C. Filli\^atre}, - institution = {LIP-ENS-Lyon}, - title = {A decision procedure for Direct Predicate Calculus}, - type = {Research report}, - number = {96--25}, - year = {1995} -} - -@Article{Filliatre03jfp, - author = {J.-C. Filliâtre}, - title = {Verification of Non-Functional Programs - using Interpretations in Type Theory}, - journal = jfp, - volume = 13, - number = 4, - pages = {709--745}, - month = jul, - year = 2003, - note = {[English translation of \cite{Filliatre99}]}, - url = {http://www.lri.fr/~filliatr/ftp/publis/jphd.ps.gz}, - topics = {team, lri}, - type_publi = {irevcomlec} -} - -@PhDThesis{Filliatre99, - author = {J.-C. Filli\^atre}, - title = {Preuve de programmes imp\'eratifs en th\'eorie des types}, - type = {Thèse de Doctorat}, - school = {Universit\'e Paris-Sud}, - year = 1999, - month = {July}, - url = {\url{http://www.lri.fr/~filliatr/ftp/publis/these.ps.gz}} -} - -@Unpublished{Filliatre99c, - author = {J.-C. Filli\^atre}, - title = {{Formal Proof of a Program: Find}}, - month = {January}, - year = 2000, - note = {Submitted to \emph{Science of Computer Programming}}, - url = {\url{http://www.lri.fr/~filliatr/ftp/publis/find.ps.gz}} -} - -@InProceedings{FilliatreMagaud99, - author = {J.-C. Filli\^atre and N. Magaud}, - title = {Certification of sorting algorithms in the system {\Coq}}, - booktitle = {Theorem Proving in Higher Order Logics: - Emerging Trends}, - year = 1999, - url = {\url{http://www.lri.fr/~filliatr/ftp/publis/Filliatre-Magaud.ps.gz}} -} - -@Unpublished{Fle90, - author = {E. Fleury}, - month = jul, - note = {Rapport de Stage}, - title = {Implantation des algorithmes de {Floyd et de Dijkstra} dans le {Calcul des Constructions}}, - year = {1990} -} - -@Book{Fourier, - author = {Jean-Baptiste-Joseph Fourier}, - publisher = {Gauthier-Villars}, - title = {Fourier's method to solve linear - inequations/equations systems.}, - year = {1890} -} - -@InProceedings{Gim94, - author = {E. Gim\'enez}, - booktitle = {Types'94 : Types for Proofs and Programs}, - note = {Extended version in LIP research report 95-07, ENS Lyon}, - publisher = SV, - series = LNCS, - title = {Codifying guarded definitions with recursive schemes}, - volume = {996}, - year = {1994} -} - -@PhDThesis{Gim96, - author = {E. Gim\'enez}, - title = {Un calcul des constructions infinies et son application \'a la v\'erification de syst\`emes communicants}, - school = {\'Ecole Normale Sup\'erieure de Lyon}, - year = {1996} -} - -@TechReport{Gim98, - author = {E. Gim\'enez}, - title = {A Tutorial on Recursive Types in Coq}, - institution = {INRIA}, - year = 1998, - month = mar -} - -@Unpublished{GimCas05, - author = {E. Gim\'enez and P. Cast\'eran}, - title = {A Tutorial on [Co-]Inductive Types in Coq}, - institution = {INRIA}, - year = 2005, - month = jan, - note = {available at \url{http://coq.inria.fr/doc}} -} - -@InProceedings{Gimenez95b, - author = {E. Gim\'enez}, - booktitle = {Workshop on Types for Proofs and Programs}, - series = LNCS, - number = {1158}, - pages = {135-152}, - title = {An application of co-Inductive types in Coq: - verification of the Alternating Bit Protocol}, - editorS = {S. Berardi and M. Coppo}, - publisher = SV, - year = {1995} -} - -@InProceedings{Gir70, - author = {J.-Y. Girard}, - booktitle = {Proceedings of the 2nd Scandinavian Logic Symposium}, - publisher = {North-Holland}, - title = {Une extension de l'interpr\'etation de {G\"odel} \`a l'analyse, et son application \`a l'\'elimination des coupures dans l'analyse et la th\'eorie des types}, - year = {1970} -} - -@PhDThesis{Gir72, - author = {J.-Y. Girard}, - school = {Universit\'e Paris~7}, - title = {Interpr\'etation fonctionnelle et \'elimination des coupures de l'arithm\'etique d'ordre sup\'erieur}, - year = {1972} -} - -@Book{Gir89, - author = {J.-Y. Girard and Y. Lafont and P. Taylor}, - publisher = {Cambridge University Press}, - series = {Cambridge Tracts in Theoretical Computer Science 7}, - title = {Proofs and Types}, - year = {1989} -} - -@TechReport{Har95, - author = {John Harrison}, - title = {Metatheory and Reflection in Theorem Proving: A Survey and Critique}, - institution = {SRI International Cambridge Computer Science Research Centre,}, - year = 1995, - type = {Technical Report}, - number = {CRC-053}, - abstract = {http://www.cl.cam.ac.uk/users/jrh/papers.html} -} - -@MastersThesis{Hir94, - author = {D. Hirschkoff}, - month = sep, - school = {DEA IARFA, Ecole des Ponts et Chauss\'ees, Paris}, - title = {Écriture d'une tactique arithm\'etique pour le syst\`eme {\Coq}}, - year = {1994} -} - -@InProceedings{HofStr98, - author = {Martin Hofmann and Thomas Streicher}, - title = {The groupoid interpretation of type theory}, - booktitle = {Proceedings of the meeting Twenty-five years of constructive type theory}, - publisher = {Oxford University Press}, - year = {1998} -} - -@InCollection{How80, - author = {W.A. Howard}, - booktitle = {to H.B. Curry : Essays on Combinatory Logic, Lambda Calculus and Formalism.}, - editor = {J.P. Seldin and J.R. Hindley}, - note = {Unpublished 1969 Manuscript}, - publisher = {Academic Press}, - title = {The Formulae-as-Types Notion of Constructions}, - year = {1980} -} - -@InProceedings{Hue87tapsoft, - author = {G. Huet}, - title = {Programming of Future Generation Computers}, - booktitle = {Proceedings of TAPSOFT87}, - series = LNCS, - volume = 249, - pages = {276--286}, - year = 1987, - publisher = SV -} - -@InProceedings{Hue87, - author = {G. Huet}, - booktitle = {Programming of Future Generation Computers}, - editor = {K. Fuchi and M. Nivat}, - note = {Also in \cite{Hue87tapsoft}}, - publisher = {Elsevier Science}, - title = {Induction Principles Formalized in the {Calculus of Constructions}}, - year = {1988} -} - -@InProceedings{Hue88, - author = {G. Huet}, - booktitle = {A perspective in Theoretical Computer Science. Commemorative Volume for Gift Siromoney}, - editor = {R. Narasimhan}, - note = {Also in~\cite{CoC89}}, - publisher = {World Scientific Publishing}, - title = {{The Constructive Engine}}, - year = {1989} -} - -@Unpublished{Hue88b, - author = {G. Huet}, - title = {Extending the Calculus of Constructions with Type:Type}, - year = 1988, - note = {Unpublished} -} - -@Book{Hue89, - editor = {G. Huet}, - publisher = {Addison-Wesley}, - series = {The UT Year of Programming Series}, - title = {Logical Foundations of Functional Programming}, - year = {1989} -} - -@InProceedings{Hue92, - author = {G. Huet}, - booktitle = {Proceedings of 12th FST/TCS Conference, New Delhi}, - pages = {229--240}, - publisher = SV, - series = LNCS, - title = {The Gallina Specification Language : A case study}, - volume = {652}, - year = {1992} -} - -@Article{Hue94, - author = {G. Huet}, - journal = {J. Functional Programming}, - pages = {371--394}, - publisher = {Cambridge University Press}, - title = {Residual theory in $\lambda$-calculus: a formal development}, - volume = {4,3}, - year = {1994} -} - -@InCollection{HuetLevy79, - author = {G. Huet and J.-J. L\'{e}vy}, - title = {Call by Need Computations in Non-Ambigous -Linear Term Rewriting Systems}, - note = {Also research report 359, INRIA, 1979}, - booktitle = {Computational Logic, Essays in Honor of -Alan Robinson}, - editor = {J.-L. Lassez and G. Plotkin}, - publisher = {The MIT press}, - year = {1991} -} - -@Article{KeWe84, - author = {J. Ketonen and R. Weyhrauch}, - journal = {Theoretical Computer Science}, - pages = {297--307}, - title = {A decidable fragment of {P}redicate {C}alculus}, - volume = {32}, - year = {1984} -} - -@Book{Kle52, - author = {S.C. Kleene}, - publisher = {North-Holland}, - series = {Bibliotheca Mathematica}, - title = {Introduction to Metamathematics}, - year = {1952} -} - -@Book{Kri90, - author = {J.-L. Krivine}, - publisher = {Masson}, - series = {Etudes et recherche en informatique}, - title = {Lambda-calcul {types et mod\`eles}}, - year = {1990} -} - -@Book{LE92, - editor = {G. Huet and G. Plotkin}, - publisher = {Cambridge University Press}, - title = {Logical Environments}, - year = {1992} -} - -@Book{LF91, - editor = {G. Huet and G. Plotkin}, - publisher = {Cambridge University Press}, - title = {Logical Frameworks}, - year = {1991} -} - -@Article{Laville91, - author = {A. Laville}, - title = {Comparison of Priority Rules in Pattern -Matching and Term Rewriting}, - journal = {Journal of Symbolic Computation}, - volume = {11}, - pages = {321--347}, - year = {1991} -} - -@InProceedings{LePa94, - author = {F. Leclerc and C. Paulin-Mohring}, - booktitle = {{Types for Proofs and Programs, Types' 93}}, - editor = {H. Barendregt and T. Nipkow}, - publisher = SV, - series = {LNCS}, - title = {{Programming with Streams in Coq. A case study : The Sieve of Eratosthenes}}, - volume = {806}, - year = {1994} -} - -@TechReport{Leroy90, - author = {X. Leroy}, - title = {The {ZINC} experiment: an economical implementation -of the {ML} language}, - institution = {INRIA}, - number = {117}, - year = {1990} -} - -@InProceedings{Let02, - author = {P. Letouzey}, - title = {A New Extraction for Coq}, - booktitle = {TYPES}, - year = 2002, - crossref = {DBLP:conf/types/2002}, - url = {draft at \url{http://www.pps.jussieu.fr/~letouzey/download/extraction2002.ps.gz}} -} - -@PhDThesis{Luo90, - author = {Z. Luo}, - title = {An Extended Calculus of Constructions}, - school = {University of Edinburgh}, - year = {1990} -} - -@inproceedings{Luttik97specificationof, - Author = {Sebastiaan P. Luttik and Eelco Visser}, - Booktitle = {2nd International Workshop on the Theory and Practice of Algebraic Specifications (ASF+SDF'97), Electronic Workshops in Computing}, - Publisher = {Springer-Verlag}, - Title = {Specification of Rewriting Strategies}, - Year = {1997}} - -@Book{MaL84, - author = {{P. Martin-L\"of}}, - publisher = {Bibliopolis}, - series = {Studies in Proof Theory}, - title = {Intuitionistic Type Theory}, - year = {1984} -} - -@Article{MaSi94, - author = {P. Manoury and M. Simonot}, - title = {Automatizing Termination Proofs of Recursively Defined Functions.}, - journal = {TCS}, - volume = {135}, - number = {2}, - year = {1994}, - pages = {319-343}, -} - -@InProceedings{Miquel00, - author = {A. Miquel}, - title = {A Model for Impredicative Type Systems with Universes, -Intersection Types and Subtyping}, - booktitle = {{Proceedings of the 15th Annual IEEE Symposium on Logic in Computer Science (LICS'00)}}, - publisher = {IEEE Computer Society Press}, - year = {2000} -} - -@PhDThesis{Miquel01a, - author = {A. Miquel}, - title = {Le Calcul des Constructions implicite: syntaxe et s\'emantique}, - month = {dec}, - school = {{Universit\'e Paris 7}}, - year = {2001} -} - -@InProceedings{Miquel01b, - author = {A. Miquel}, - title = {The Implicit Calculus of Constructions: Extending Pure Type Systems with an Intersection Type Binder and Subtyping}, - booktitle = {{Proceedings of the fifth International Conference on Typed Lambda Calculi and Applications (TLCA01), Krakow, Poland}}, - publisher = SV, - series = {LNCS}, - number = 2044, - year = {2001} -} - -@InProceedings{MiWer02, - author = {A. Miquel and B. Werner}, - title = {The Not So Simple Proof-Irrelevant Model of CC}, - booktitle = {TYPES}, - year = {2002}, - pages = {240-258}, - ee = {http://link.springer.de/link/service/series/0558/bibs/2646/26460240.htm}, - crossref = {DBLP:conf/types/2002}, - bibsource = {DBLP, http://dblp.uni-trier.de} -} - -@proceedings{DBLP:conf/types/2002, - editor = {H. Geuvers and F. Wiedijk}, - title = {Types for Proofs and Programs, Second International Workshop, - TYPES 2002, Berg en Dal, The Netherlands, April 24-28, 2002, - Selected Papers}, - booktitle = {TYPES}, - publisher = SV, - series = LNCS, - volume = {2646}, - year = {2003}, - isbn = {3-540-14031-X}, - bibsource = {DBLP, http://dblp.uni-trier.de} -} - -@InProceedings{Moh89a, - author = {C. Paulin-Mohring}, - address = {Austin}, - booktitle = {Sixteenth Annual ACM Symposium on Principles of Programming Languages}, - month = jan, - publisher = {ACM}, - title = {Extracting ${F}_{\omega}$'s programs from proofs in the {Calculus of Constructions}}, - year = {1989} -} - -@PhDThesis{Moh89b, - author = {C. Paulin-Mohring}, - month = jan, - school = {{Universit\'e Paris 7}}, - title = {Extraction de programmes dans le {Calcul des Constructions}}, - year = {1989} -} - -@InProceedings{Moh93, - author = {C. Paulin-Mohring}, - booktitle = {Proceedings of the conference Typed Lambda Calculi and Applications}, - editor = {M. Bezem and J.-F. Groote}, - note = {Also LIP research report 92-49, ENS Lyon}, - number = {664}, - publisher = SV, - series = {LNCS}, - title = {{Inductive Definitions in the System Coq - Rules and Properties}}, - year = {1993} -} - -@Book{Moh97, - author = {C. Paulin-Mohring}, - month = jan, - publisher = {{ENS Lyon}}, - title = {{Le syst\`eme Coq. \mbox{Th\`ese d'habilitation}}}, - year = {1997} -} - -@MastersThesis{Mun94, - author = {C. Muñoz}, - month = sep, - school = {DEA d'Informatique Fondamentale, Universit\'e Paris 7}, - title = {D\'emonstration automatique dans la logique propositionnelle intuitionniste}, - year = {1994} -} - -@PhDThesis{Mun97d, - author = {C. Mu{\~{n}}oz}, - title = {Un calcul de substitutions pour la repr\'esentation - de preuves partielles en th\'eorie de types}, - school = {Universit\'e Paris 7}, - year = {1997}, - note = {Version en anglais disponible comme rapport de - recherche INRIA RR-3309}, - type = {Th\`ese de Doctorat} -} - -@Book{NoPS90, - author = {B. {Nordstr\"om} and K. Peterson and J. Smith}, - booktitle = {Information Processing 83}, - publisher = {Oxford Science Publications}, - series = {International Series of Monographs on Computer Science}, - title = {Programming in {Martin-L\"of's} Type Theory}, - year = {1990} -} - -@Article{Nor88, - author = {B. {Nordstr\"om}}, - journal = {BIT}, - title = {Terminating General Recursion}, - volume = {28}, - year = {1988} -} - -@Book{Odi90, - editor = {P. Odifreddi}, - publisher = {Academic Press}, - title = {Logic and Computer Science}, - year = {1990} -} - -@InProceedings{PaMS92, - author = {M. Parigot and P. Manoury and M. Simonot}, - address = {St. Petersburg, Russia}, - booktitle = {Logic Programming and automated reasoning}, - editor = {A. Voronkov}, - month = jul, - number = {624}, - publisher = SV, - series = {LNCS}, - title = {{ProPre : A Programming language with proofs}}, - year = {1992} -} - -@Article{PaWe92, - author = {C. Paulin-Mohring and B. Werner}, - journal = {Journal of Symbolic Computation}, - pages = {607--640}, - title = {{Synthesis of ML programs in the system Coq}}, - volume = {15}, - year = {1993} -} - -@Article{Par92, - author = {M. Parigot}, - journal = {Theoretical Computer Science}, - number = {2}, - pages = {335--356}, - title = {{Recursive Programming with Proofs}}, - volume = {94}, - year = {1992} -} - -@InProceedings{Parent95b, - author = {C. Parent}, - booktitle = {{Mathematics of Program Construction'95}}, - publisher = SV, - series = {LNCS}, - title = {{Synthesizing proofs from programs in -the Calculus of Inductive Constructions}}, - volume = {947}, - year = {1995} -} - -@InProceedings{Prasad93, - author = {K.V. Prasad}, - booktitle = {{Proceedings of CONCUR'93}}, - publisher = SV, - series = {LNCS}, - title = {{Programming with broadcasts}}, - volume = {715}, - year = {1993} -} - -@Book{RC95, - author = {di~Cosmo, R.}, - title = {Isomorphisms of Types: from $\lambda$-calculus to information - retrieval and language design}, - series = {Progress in Theoretical Computer Science}, - publisher = {Birkhauser}, - year = {1995}, - note = {ISBN-0-8176-3763-X} -} - -@TechReport{Rou92, - author = {J. Rouyer}, - institution = {INRIA}, - month = nov, - number = {1795}, - title = {{Développement de l'Algorithme d'Unification dans le Calcul des Constructions}}, - year = {1992} -} - -@Article{Rushby98, - title = {Subtypes for Specifications: Predicate Subtyping in - {PVS}}, - author = {John Rushby and Sam Owre and N. Shankar}, - journal = {IEEE Transactions on Software Engineering}, - pages = {709--720}, - volume = 24, - number = 9, - month = sep, - year = 1998 -} - -@TechReport{Saibi94, - author = {A. Sa\"{\i}bi}, - institution = {INRIA}, - month = dec, - number = {2345}, - title = {{Axiomatization of a lambda-calculus with explicit-substitutions in the Coq System}}, - year = {1994} -} - - -@MastersThesis{Ter92, - author = {D. Terrasse}, - month = sep, - school = {IARFA}, - title = {{Traduction de TYPOL en COQ. Application \`a Mini ML}}, - year = {1992} -} - -@TechReport{ThBeKa92, - author = {L. Th\'ery and Y. Bertot and G. Kahn}, - institution = {INRIA Sophia}, - month = may, - number = {1684}, - title = {Real theorem provers deserve real user-interfaces}, - type = {Research Report}, - year = {1992} -} - -@Book{TrDa89, - author = {A.S. Troelstra and D. van Dalen}, - publisher = {North-Holland}, - series = {Studies in Logic and the foundations of Mathematics, volumes 121 and 123}, - title = {Constructivism in Mathematics, an introduction}, - year = {1988} -} - -@PhDThesis{Wer94, - author = {B. Werner}, - school = {Universit\'e Paris 7}, - title = {Une th\'eorie des constructions inductives}, - type = {Th\`ese de Doctorat}, - year = {1994} -} - -@PhDThesis{Bar99, - author = {B. Barras}, - school = {Universit\'e Paris 7}, - title = {Auto-validation d'un système de preuves avec familles inductives}, - type = {Th\`ese de Doctorat}, - year = {1999} -} - -@Unpublished{ddr98, - author = {D. de Rauglaudre}, - title = {Camlp4 version 1.07.2}, - year = {1998}, - note = {In Camlp4 distribution} -} - -@Article{dowek93, - author = {G. Dowek}, - title = {{A Complete Proof Synthesis Method for the Cube of Type Systems}}, - journal = {Journal Logic Computation}, - volume = {3}, - number = {3}, - pages = {287--315}, - month = {June}, - year = {1993} -} - -@InProceedings{manoury94, - author = {P. Manoury}, - title = {{A User's Friendly Syntax to Define -Recursive Functions as Typed $\lambda-$Terms}}, - booktitle = {{Types for Proofs and Programs, TYPES'94}}, - series = {LNCS}, - volume = {996}, - month = jun, - year = {1994} -} - -@TechReport{maranget94, - author = {L. Maranget}, - institution = {INRIA}, - number = {2385}, - title = {{Two Techniques for Compiling Lazy Pattern Matching}}, - year = {1994} -} - -@InProceedings{puel-suarez90, - author = {L.Puel and A. Su\'arez}, - booktitle = {{Conference Lisp and Functional Programming}}, - series = {ACM}, - publisher = SV, - title = {{Compiling Pattern Matching by Term -Decomposition}}, - year = {1990} -} - -@MastersThesis{saidi94, - author = {H. Saidi}, - month = sep, - school = {DEA d'Informatique Fondamentale, Universit\'e Paris 7}, - title = {R\'esolution d'\'equations dans le syst\`eme T - de G\"odel}, - year = {1994} -} - -@inproceedings{sozeau06, - author = {Matthieu Sozeau}, - title = {Subset Coercions in {C}oq}, - year = {2007}, - booktitle = {TYPES'06}, - pages = {237-252}, - volume = {4502}, - publisher = "Springer", - series = {LNCS} -} - -@inproceedings{sozeau08, - Author = {Matthieu Sozeau and Nicolas Oury}, - booktitle = {TPHOLs'08}, - Pdf = {http://www.lri.fr/~sozeau/research/publications/drafts/classes.pdf}, - Title = {{F}irst-{C}lass {T}ype {C}lasses}, - Year = {2008}, -} - -@Misc{streicher93semantical, - author = {T. Streicher}, - title = {Semantical Investigations into Intensional Type Theory}, - note = {Habilitationsschrift, LMU Munchen.}, - year = {1993} -} - -@Misc{Pcoq, - author = {Lemme Team}, - title = {Pcoq a graphical user-interface for {Coq}}, - note = {\url{http://www-sop.inria.fr/lemme/pcoq/}} -} - -@Misc{ProofGeneral, - author = {David Aspinall}, - title = {Proof General}, - note = {\url{https://proofgeneral.github.io/}} -} - -@Book{CoqArt, - title = {Interactive Theorem Proving and Program Development. - Coq'Art: The Calculus of Inductive Constructions}, - author = {Yves Bertot and Pierre Castéran}, - publisher = {Springer Verlag}, - series = {Texts in Theoretical Computer Science. An EATCS series}, - year = 2004 -} - -@InCollection{wadler87, - author = {P. Wadler}, - title = {Efficient Compilation of Pattern Matching}, - booktitle = {The Implementation of Functional Programming -Languages}, - editor = {S.L. Peyton Jones}, - publisher = {Prentice-Hall}, - year = {1987} -} - -@inproceedings{DBLP:conf/types/CornesT95, - author = {Cristina Cornes and - Delphine Terrasse}, - title = {Automating Inversion of Inductive Predicates in Coq}, - booktitle = {TYPES}, - year = {1995}, - pages = {85-104}, - crossref = {DBLP:conf/types/1995}, - bibsource = {DBLP, http://dblp.uni-trier.de} -} -@proceedings{DBLP:conf/types/1995, - editor = {Stefano Berardi and - Mario Coppo}, - title = {Types for Proofs and Programs, International Workshop TYPES'95, - Torino, Italy, June 5-8, 1995, Selected Papers}, - booktitle = {TYPES}, - publisher = {Springer}, - series = {Lecture Notes in Computer Science}, - volume = {1158}, - year = {1996}, - isbn = {3-540-61780-9}, - bibsource = {DBLP, http://dblp.uni-trier.de} -} - -@inproceedings{DBLP:conf/types/McBride00, - author = {Conor McBride}, - title = {Elimination with a Motive}, - booktitle = {TYPES}, - year = {2000}, - pages = {197-216}, - ee = {http://link.springer.de/link/service/series/0558/bibs/2277/22770197.htm}, - crossref = {DBLP:conf/types/2000}, - bibsource = {DBLP, http://dblp.uni-trier.de} -} - -@proceedings{DBLP:conf/types/2000, - editor = {Paul Callaghan and - Zhaohui Luo and - James McKinna and - Robert Pollack}, - title = {Types for Proofs and Programs, International Workshop, TYPES - 2000, Durham, UK, December 8-12, 2000, Selected Papers}, - booktitle = {TYPES}, - publisher = {Springer}, - series = {Lecture Notes in Computer Science}, - volume = {2277}, - year = {2002}, - isbn = {3-540-43287-6}, - bibsource = {DBLP, http://dblp.uni-trier.de} -} - -@INPROCEEDINGS{sugar, - author = {Alessandro Giovini and Teo Mora and Gianfranco Niesi and Lorenzo Robbiano and Carlo Traverso}, - title = {"One sugar cube, please" or Selection strategies in the Buchberger algorithm}, - booktitle = { Proceedings of the ISSAC'91, ACM Press}, - year = {1991}, - pages = {5--4}, - publisher = {} -} - -@article{LeeWerner11, - author = {Gyesik Lee and - Benjamin Werner}, - title = {Proof-irrelevant model of {CC} with predicative induction - and judgmental equality}, - journal = {Logical Methods in Computer Science}, - volume = {7}, - number = {4}, - year = {2011}, - ee = {http://dx.doi.org/10.2168/LMCS-7(4:5)2011}, - bibsource = {DBLP, http://dblp.uni-trier.de} -} - -@Comment{cross-references, must be at end} - -@Book{Bastad92, - editor = {B. Nordstr\"om and K. Petersson and G. Plotkin}, - publisher = {Available by ftp at site ftp.inria.fr}, - title = {Proceedings of the 1992 Workshop on Types for Proofs and Programs}, - year = {1992} -} - -@Book{Nijmegen93, - editor = {H. Barendregt and T. Nipkow}, - publisher = SV, - series = LNCS, - title = {Types for Proofs and Programs}, - volume = {806}, - year = {1994} -} - -@article{ TheOmegaPaper, - author = "W. Pugh", - title = "The Omega test: a fast and practical integer programming algorithm for dependence analysis", - journal = "Communication of the ACM", - pages = "102--114", - year = "1992", -} - -@inproceedings{CSwcu, - hal_id = {hal-00816703}, - url = {http://hal.inria.fr/hal-00816703}, - title = {{Canonical Structures for the working Coq user}}, - author = {Mahboubi, Assia and Tassi, Enrico}, - booktitle = {{ITP 2013, 4th Conference on Interactive Theorem Proving}}, - publisher = {Springer}, - pages = {19-34}, - address = {Rennes, France}, - volume = {7998}, - editor = {Sandrine Blazy and Christine Paulin and David Pichardie }, - series = {LNCS }, - doi = {10.1007/978-3-642-39634-2\_5 }, - year = {2013}, -} - -@article{CSlessadhoc, - author = {Gonthier, Georges and Ziliani, Beta and Nanevski, Aleksandar and Dreyer, Derek}, - title = {How to Make Ad Hoc Proof Automation Less Ad Hoc}, - journal = {SIGPLAN Not.}, - issue_date = {September 2011}, - volume = {46}, - number = {9}, - month = sep, - year = {2011}, - issn = {0362-1340}, - pages = {163--175}, - numpages = {13}, - url = {http://doi.acm.org/10.1145/2034574.2034798}, - doi = {10.1145/2034574.2034798}, - acmid = {2034798}, - publisher = {ACM}, - address = {New York, NY, USA}, - keywords = {canonical structures, coq, custom proof automation, hoare type theory, interactive theorem proving, tactics, type classes}, -} - -@inproceedings{CompiledStrongReduction, - author = {Benjamin Gr{\'{e}}goire and - Xavier Leroy}, - editor = {Mitchell Wand and - Simon L. Peyton Jones}, - title = {A compiled implementation of strong reduction}, - booktitle = {Proceedings of the Seventh {ACM} {SIGPLAN} International Conference - on Functional Programming {(ICFP} '02), Pittsburgh, Pennsylvania, - USA, October 4-6, 2002.}, - pages = {235--246}, - publisher = {{ACM}}, - year = {2002}, - url = {http://doi.acm.org/10.1145/581478.581501}, - doi = {10.1145/581478.581501}, - timestamp = {Tue, 11 Jun 2013 13:49:16 +0200}, - biburl = {http://dblp.uni-trier.de/rec/bib/conf/icfp/GregoireL02}, - bibsource = {dblp computer science bibliography, http://dblp.org} -} - -@inproceedings{FullReduction, - author = {Mathieu Boespflug and - Maxime D{\'{e}}n{\`{e}}s and - Benjamin Gr{\'{e}}goire}, - editor = {Jean{-}Pierre Jouannaud and - Zhong Shao}, - title = {Full Reduction at Full Throttle}, - booktitle = {Certified Programs and Proofs - First International Conference, {CPP} - 2011, Kenting, Taiwan, December 7-9, 2011. Proceedings}, - series = {Lecture Notes in Computer Science}, - volume = {7086}, - pages = {362--377}, - publisher = {Springer}, - year = {2011}, - url = {http://dx.doi.org/10.1007/978-3-642-25379-9_26}, - doi = {10.1007/978-3-642-25379-9_26}, - timestamp = {Thu, 17 Nov 2011 13:33:48 +0100}, - biburl = {http://dblp.uni-trier.de/rec/bib/conf/cpp/BoespflugDG11}, - bibsource = {dblp computer science bibliography, http://dblp.org} -} diff --git a/doc/refman/coq-listing.tex b/doc/refman/coq-listing.tex deleted file mode 100644 index c69c3b1b8..000000000 --- a/doc/refman/coq-listing.tex +++ /dev/null @@ -1,152 +0,0 @@ -%======================================================================= -% Listings LaTeX package style for Gallina + SSReflect (Assia Mahboubi 2007) - -\lstdefinelanguage{SSR} { - -% Anything betweeen $ becomes LaTeX math mode -mathescape=true, -% Comments may or not include Latex commands -texcl=false, - - -% Vernacular commands -morekeywords=[1]{ -From, Section, Module, End, Require, Import, Export, Defensive, Function, -Variable, Variables, Parameter, Parameters, Axiom, Hypothesis, Hypotheses, -Notation, Local, Tactic, Reserved, Scope, Open, Close, Bind, Delimit, -Definition, Let, Ltac, Fixpoint, CoFixpoint, Add, Morphism, Relation, -Implicit, Arguments, Set, Unset, Contextual, Strict, Prenex, Implicits, -Inductive, CoInductive, Record, Structure, Canonical, Coercion, -Theorem, Lemma, Corollary, Proposition, Fact, Remark, Example, -Proof, Goal, Save, Qed, Defined, Hint, Resolve, Rewrite, View, -Search, Show, Print, Printing, All, Graph, Projections, inside, -outside, Locate, Maximal}, - -% Gallina -morekeywords=[2]{forall, exists, exists2, fun, fix, cofix, struct, - match, with, end, as, in, return, let, if, is, then, else, - for, of, nosimpl}, - -% Sorts -morekeywords=[3]{Type, Prop}, - -% Various tactics, some are std Coq subsumed by ssr, for the manual purpose -morekeywords=[4]{ - pose, set, move, case, elim, apply, clear, - hnf, intro, intros, generalize, rename, pattern, after, - destruct, induction, using, refine, inversion, injection, - rewrite, congr, unlock, compute, ring, field, - replace, fold, unfold, change, cutrewrite, simpl, - have, gen, generally, suff, wlog, suffices, without, loss, nat_norm, - assert, cut, trivial, revert, bool_congr, nat_congr, abstract, - symmetry, transitivity, auto, split, left, right, autorewrite}, - -% Terminators -morekeywords=[5]{ - by, done, exact, reflexivity, tauto, romega, omega, - assumption, solve, contradiction, discriminate}, - - -% Control -morekeywords=[6]{do, last, first, try, idtac, repeat}, - -% Various symbols -% For the ssr manual we turn off the prettyprint of formulas -% literate= -% {->}{{$\rightarrow\,$}}2 -% {->}{{\tt ->}}3 -% {<-}{{$\leftarrow\,$}}2 -% {<-}{{\tt <-}}2 -% {>->}{{$\mapsto$}}3 -% {<=}{{$\leq$}}1 -% {>=}{{$\geq$}}1 -% {<>}{{$\neq$}}1 -% {/\\}{{$\wedge$}}2 -% {\\/}{{$\vee$}}2 -% {<->}{{$\leftrightarrow\;$}}3 -% {<=>}{{$\Leftrightarrow\;$}}3 -% {:nat}{{$~\in\mathbb{N}$}}3 -% {fforall\ }{{$\forall_f\,$}}1 -% {forall\ }{{$\forall\,$}}1 -% {exists\ }{{$\exists\,$}}1 -% {negb}{{$\neg$}}1 -% {spp}{{:*:\,}}1 -% {~}{{$\sim$}}1 -% {\\in}{{$\in\;$}}1 -% {/\\}{$\land\,$}1 -% {:*:}{{$*$}}2 -% {=>}{{$\,\Rightarrow\ $}}1 -% {=>}{{\tt =>}}2 -% {:=}{{{\tt:=}\,\,}}2 -% {==}{{$\equiv$}\,}2 -% {!=}{{$\neq$}\,}2 -% {^-1}{{$^{-1}$}}1 -% {elt'}{elt'}1 -% {=}{{\tt=}\,\,}2 -% {+}{{\tt+}\,\,}2, -literate= - {isn't }{{{\ttfamily\color{dkgreen} isn't }}}1, - -% Comments delimiters, we do turn this off for the manual -%comment=[s]{(*}{*)}, - -% Spaces are not displayed as a special character -showstringspaces=false, - -% String delimiters -morestring=[b]", -morestring=[d]", - -% Size of tabulations -tabsize=3, - -% Enables ASCII chars 128 to 255 -extendedchars=true, - -% Case sensitivity -sensitive=true, - -% Automatic breaking of long lines -breaklines=true, - -% Default style fors listings -basicstyle=\ttfamily, - -% Position of captions is bottom -captionpos=b, - -% Full flexible columns -columns=[l]fullflexible, - -% Style for (listings') identifiers -identifierstyle={\ttfamily\color{black}}, -% Note : highlighting of Coq identifiers is done through a new -% delimiter definition through an lstset at the begining of the -% document. Don't know how to do better. - -% Style for declaration keywords -keywordstyle=[1]{\ttfamily\color{dkviolet}}, - -% Style for gallina keywords -keywordstyle=[2]{\ttfamily\color{dkgreen}}, - -% Style for sorts keywords -keywordstyle=[3]{\ttfamily\color{lightblue}}, - -% Style for tactics keywords -keywordstyle=[4]{\ttfamily\color{dkblue}}, - -% Style for terminators keywords -keywordstyle=[5]{\ttfamily\color{red}}, - - -%Style for iterators -keywordstyle=[6]{\ttfamily\color{dkpink}}, - -% Style for strings -stringstyle=\ttfamily, - -% Style for comments -commentstyle=\rmfamily, - -} diff --git a/doc/refman/coqdoc.tex b/doc/refman/coqdoc.tex deleted file mode 100644 index 26dbd59e7..000000000 --- a/doc/refman/coqdoc.tex +++ /dev/null @@ -1,573 +0,0 @@ - -%\newcommand{\Coq}{\textsf{Coq}} -\newcommand{\javadoc}{\textsf{javadoc}} -\newcommand{\ocamldoc}{\textsf{ocamldoc}} -\newcommand{\coqdoc}{\textsf{coqdoc}} -\newcommand{\texmacs}{\TeX{}macs} -\newcommand{\monurl}[1]{#1} -%HEVEA\renewcommand{\monurl}[1]{\ahref{#1}{#1}} -%\newcommand{\lnot}{not} % Hevea handles these symbols nicely -%\newcommand{\lor}{or} -%\newcommand{\land}{\&} -%%% Beware : in a \texttt, -- is displayed as a unique - hence -%%% the following macro: -\newcommand{\mm}{\symbol{45}\symbol{45}} - - -\coqdoc\ is a documentation tool for the proof assistant -\Coq, similar to \javadoc\ or \ocamldoc. -The task of \coqdoc\ is -\begin{enumerate} -\item to produce a nice \LaTeX\ and/or HTML document from the \Coq\ - sources, readable for a human and not only for the proof assistant; -\item to help the user navigating in his own (or third-party) sources. -\end{enumerate} - - -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% - -\subsection{Principles} - -Documentation is inserted into \Coq\ files as \emph{special comments}. -Thus your files will compile as usual, whether you use \coqdoc\ or not. -\coqdoc\ presupposes that the given \Coq\ files are well-formed (at -least lexically). Documentation starts with -\texttt{(**}, followed by a space, and ends with the pending \texttt{*)}. -The documentation format is inspired - by Todd~A.~Coram's \emph{Almost Free Text (AFT)} tool: it is mainly -ASCII text with some syntax-light controls, described below. -\coqdoc\ is robust: it shouldn't fail, whatever the input is. But -remember: ``garbage in, garbage out''. - -\paragraph{\Coq\ material inside documentation.} -\Coq\ material is quoted between the -delimiters \texttt{[} and \texttt{]}. Square brackets may be nested, -the inner ones being understood as being part of the quoted code (thus -you can quote a term like \texttt{fun x => u} by writing -\texttt{[fun x => u]}). Inside quotations, the code is pretty-printed in -the same way as it is in code parts. - -Pre-formatted vernacular is enclosed by \texttt{[[} and -\texttt{]]}. The former must be followed by a newline and the latter -must follow a newline. - -\paragraph{Pretty-printing.} -\coqdoc\ uses different faces for identifiers and keywords. -The pretty-printing of \Coq\ tokens (identifiers or symbols) can be -controlled using one of the following commands: -\begin{alltt} -(** printing \emph{token} %...\LaTeX...% #...HTML...# *) -\end{alltt} -or -\begin{alltt} -(** printing \emph{token} $...\LaTeX\ math...$ #...HTML...# *) -\end{alltt} -It gives the \LaTeX\ and HTML texts to be produced for the given \Coq\ -token. One of the \LaTeX\ or HTML text may be omitted, causing the -default pretty-printing to be used for this token. - -The printing for one token can be removed with -\begin{alltt} -(** remove printing \emph{token} *) -\end{alltt} - -Initially, the pretty-printing table contains the following mapping: -\begin{center} - \begin{tabular}{ll@{\qquad\qquad}ll@{\qquad\qquad}ll@{\qquad\qquad}} - \verb!->! & $\rightarrow$ & - \verb!<-! & $\leftarrow$ & - \verb|*| & $\times$ \\ - \verb|<=| & $\le$ & - \verb|>=| & $\ge$ & - \verb|=>| & $\Rightarrow$ \\ - \verb|<>| & $\not=$ & - \verb|<->| & $\leftrightarrow$ & - \verb!|-! & $\vdash$ \\ - \verb|\/| & $\lor$ & - \verb|/\| & $\land$ & - \verb|~| & $\lnot$ - \end{tabular} -\end{center} -Any of these can be overwritten or suppressed using the -\texttt{printing} commands. - -Important note: the recognition of tokens is done by a (ocaml)lex -automaton and thus applies the longest-match rule. For instance, -\verb!->~! is recognized as a single token, where \Coq\ sees two -tokens. It is the responsibility of the user to insert space between -tokens \emph{or} to give pretty-printing rules for the possible -combinations, e.g. -\begin{verbatim} -(** printing ->~ %\ensuremath{\rightarrow\lnot}% *) -\end{verbatim} - - -\paragraph{Sections.} -Sections are introduced by 1 to 4 leading stars (i.e. at the beginning of the -line) followed by a space. One star is a section, two stars a sub-section, etc. -The section title is given on the remaining of the line. -Example: -\begin{verbatim} - (** * Well-founded relations - - In this section, we introduce... *) -\end{verbatim} - - -%TODO \paragraph{Fonts.} - - -\paragraph{Lists.} -List items are introduced by a leading dash. \coqdoc\ uses whitespace -to determine the depth of a new list item and which text belongs in -which list items. A list ends when a line of text starts at or before -the level of indenting of the list's dash. A list item's dash must -always be the first non-space character on its line (so, in -particular, a list can not begin on the first line of a comment - -start it on the second line instead). - -Example: -\begin{verbatim} - We go by induction on [n]: - - If [n] is 0... - - If [n] is [S n'] we require... - - two paragraphs of reasoning, and two subcases: - - - In the first case... - - In the second case... - - So the theorem holds. -\end{verbatim} - -\paragraph{Rules.} -More than 4 leading dashes produce a horizontal rule. - -\paragraph{Emphasis.} -Text can be italicized by placing it in underscores. A non-identifier -character must precede the leading underscore and follow the trailing -underscore, so that uses of underscores in names aren't mistaken for -emphasis. Usually, these are spaces or punctuation. - -\begin{verbatim} - This sentence contains some _emphasized text_. -\end{verbatim} - -\paragraph{Escaping to \LaTeX\ and HTML.} -Pure \LaTeX\ or HTML material can be inserted using the following -escape sequences: -\begin{itemize} -\item \verb+$...LaTeX stuff...$+ inserts some \LaTeX\ material in math mode. - Simply discarded in HTML output. - -\item \verb+%...LaTeX stuff...%+ inserts some \LaTeX\ material. - Simply discarded in HTML output. - -\item \verb+#...HTML stuff...#+ inserts some HTML material. Simply - discarded in \LaTeX\ output. -\end{itemize} - -Note: to simply output the characters \verb+$+, \verb+%+ and \verb+#+ -and escaping their escaping role, these characters must be doubled. - -\paragraph{Verbatim.} -Verbatim material is introduced by a leading \verb+<<+ and closed by -\verb+>>+ at the beginning of a line. Example: -\begin{verbatim} -Here is the corresponding caml code: -<< - let rec fact n = - if n <= 1 then 1 else n * fact (n-1) ->> -\end{verbatim} - - -\paragraph{Hyperlinks.} -Hyperlinks can be inserted into the HTML output, so that any -identifier is linked to the place of its definition. - -\texttt{coqc \emph{file}.v} automatically dumps localization information -in \texttt{\emph{file}.glob} or appends it to a file specified using option -\texttt{\mm{}dump-glob \emph{file}}. Take care of erasing this global file, if -any, when starting the whole compilation process. - -Then invoke \texttt{coqdoc} or \texttt{coqdoc \mm{}glob-from \emph{file}} to tell -\coqdoc\ to look for name resolutions into the file \texttt{\emph{file}} -(it will look in \texttt{\emph{file}.glob} by default). - -Identifiers from the \Coq\ standard library are linked to the \Coq\ -web site at \url{http://coq.inria.fr/library/}. This behavior can be -changed using command line options \texttt{\mm{}no-externals} and -\texttt{\mm{}coqlib}; see below. - - -\paragraph{Hiding / Showing parts of the source.} -Some parts of the source can be hidden using command line options -\texttt{-g} and \texttt{-l} (see below), or using such comments: -\begin{alltt} -(* begin hide *) -\emph{some Coq material} -(* end hide *) -\end{alltt} -Conversely, some parts of the source which would be hidden can be -shown using such comments: -\begin{alltt} -(* begin show *) -\emph{some Coq material} -(* end show *) -\end{alltt} -The latter cannot be used around some inner parts of a proof, but can -be used around a whole proof. - - -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% - -\subsection{Usage} - -\coqdoc\ is invoked on a shell command line as follows: -\begin{displaymath} - \texttt{coqdoc }<\textit{options and files}> -\end{displaymath} -Any command line argument which is not an option is considered to be a -file (even if it starts with a \verb!-!). \Coq\ files are identified -by the suffixes \verb!.v! and \verb!.g! and \LaTeX\ files by the -suffix \verb!.tex!. - -\begin{description} -\item[HTML output] ~\par - This is the default output. - One HTML file is created for each \Coq\ file given on the command line, - together with a file \texttt{index.html} (unless option - \texttt{-no-index} is passed). The HTML pages use a style sheet - named \texttt{style.css}. Such a file is distributed with \coqdoc. - -\item[\LaTeX\ output] ~\par - A single \LaTeX\ file is created, on standard output. It can be - redirected to a file with option \texttt{-o}. - The order of files on the command line is kept in the final - document. \LaTeX\ files given on the command line are copied `as is' - in the final document . - DVI and PostScript can be produced directly with the options - \texttt{-dvi} and \texttt{-ps} respectively. - -\item[\texmacs\ output] ~\par - To translate the input files to \texmacs\ format, to be used by - the \texmacs\ Coq interface. - %broken link: - %(see \url{http://www-sop.inria.fr/lemme/Philippe.Audebaud/tmcoq/}). -\end{description} - - -\subsubsection*{Command line options} - - -\paragraph{Overall options} - -\begin{description} - -\item[\texttt{\mm{}html}] ~\par - - Select a HTML output. - -\item[\texttt{\mm{}latex}] ~\par - - Select a \LaTeX\ output. - -\item[\texttt{\mm{}dvi}] ~\par - - Select a DVI output. - -\item[\texttt{\mm{}ps}] ~\par - - Select a PostScript output. - -\item[\texttt{\mm{}texmacs}] ~\par - - Select a \texmacs\ output. - -\item[\texttt{\mm{}stdout}] ~\par - - Write output to stdout. - -\item[\texttt{-o }\textit{file}, \texttt{\mm{}output }\textit{file}] ~\par - - Redirect the output into the file `\textit{file}' (meaningless with - \texttt{-html}). - -\item[\texttt{-d }\textit{dir}, \texttt{\mm{}directory }\textit{dir}] ~\par - - Output files into directory `\textit{dir}' instead of current - directory (option \texttt{-d} does not change the filename specified - with option \texttt{-o}, if any). - -\item[\texttt{\mm{}body-only}] ~\par - - Suppress the header and trailer of the final document. Thus, you can - insert the resulting document into a larger one. - -\item[\texttt{-p} \textit{string}, \texttt{\mm{}preamble} \textit{string}]~\par - - Insert some material in the \LaTeX\ preamble, right before - \verb!\begin{document}! (meaningless with \texttt{-html}). - -\item[\texttt{\mm{}vernac-file }\textit{file}, - \texttt{\mm{}tex-file }\textit{file}] ~\par - - Considers the file `\textit{file}' respectively as a \verb!.v! - (or \verb!.g!) file or a \verb!.tex! file. - -\item[\texttt{\mm{}files-from }\textit{file}] ~\par - - Read file names to process in file `\textit{file}' as if they were - given on the command line. Useful for program sources split up into - several directories. - -\item[\texttt{-q}, \texttt{\mm{}quiet}] ~\par - - Be quiet. Do not print anything except errors. - -\item[\texttt{-h}, \texttt{\mm{}help}] ~\par - - Give a short summary of the options and exit. - -\item[\texttt{-v}, \texttt{\mm{}version}] ~\par - - Print the version and exit. - -\end{description} - -\paragraph{Index options} - -Default behavior is to build an index, for the HTML output only, into -\texttt{index.html}. - -\begin{description} - -\item[\texttt{\mm{}no-index}] ~\par - - Do not output the index. - -\item[\texttt{\mm{}multi-index}] ~\par - - Generate one page for each category and each letter in the index, - together with a top page \texttt{index.html}. - -\item[\texttt{\mm{}index }\textit{string}] ~\par - - Make the filename of the index \textit{string} instead of ``index''. - Useful since ``index.html'' is special. - -\end{description} - -\paragraph{Table of contents option} - -\begin{description} - -\item[\texttt{-toc}, \texttt{\mm{}table-of-contents}] ~\par - - Insert a table of contents. - For a \LaTeX\ output, it inserts a \verb!\tableofcontents! at the - beginning of the document. For a HTML output, it builds a table of - contents into \texttt{toc.html}. - -\item[\texttt{\mm{}toc-depth }\textit{int}] ~\par - - Only include headers up to depth \textit{int} in the table of - contents. - -\end{description} - -\paragraph{Hyperlinks options} -\begin{description} - -\item[\texttt{\mm{}glob-from }\textit{file}] ~\par - - Make references using \Coq\ globalizations from file \textit{file}. - (Such globalizations are obtained with \Coq\ option \texttt{-dump-glob}). - -\item[\texttt{\mm{}no-externals}] ~\par - - Do not insert links to the \Coq\ standard library. - -\item[\texttt{\mm{}external }\textit{url}~\textit{coqdir}] ~\par - - Use given URL for linking references whose name starts with prefix - \textit{coqdir}. - -\item[\texttt{\mm{}coqlib }\textit{url}] ~\par - - Set base URL for the \Coq\ standard library (default is - \url{http://coq.inria.fr/library/}). This is equivalent to - \texttt{\mm{}external }\textit{url}~\texttt{Coq}. - -\item[\texttt{-R }\textit{dir }\textit{coqdir}] ~\par - - Map physical directory \textit{dir} to \Coq\ logical directory - \textit{coqdir} (similarly to \Coq\ option \texttt{-R}). - - Note: option \texttt{-R} only has effect on the files - \emph{following} it on the command line, so you will probably need - to put this option first. - -\end{description} - -\paragraph{Title options} -\begin{description} -\item[\texttt{-s }, \texttt{\mm{}short}] ~\par - - Do not insert titles for the files. The default behavior is to - insert a title like ``Library Foo'' for each file. - -\item[\texttt{\mm{}lib-name }\textit{string}] ~\par - - Print ``\textit{string} Foo'' instead of ``Library Foo'' in titles. - For example ``Chapter'' and ``Module'' are reasonable choices. - -\item[\texttt{\mm{}no-lib-name}] ~\par - - Print just ``Foo'' instead of ``Library Foo'' in titles. - -\item[\texttt{\mm{}lib-subtitles}] ~\par - - Look for library subtitles. When enabled, the beginning of each - file is checked for a comment of the form: -\begin{alltt} -(** * ModuleName : text *) -\end{alltt} - where \texttt{ModuleName} must be the name of the file. If it is - present, the \texttt{text} is used as a subtitle for the module in - appropriate places. - -\item[\texttt{-t }\textit{string}, - \texttt{\mm{}title }\textit{string}] ~\par - - Set the document title. - -\end{description} - -\paragraph{Contents options} -\begin{description} - -\item[\texttt{-g}, \texttt{\mm{}gallina}] ~\par - - Do not print proofs. - -\item[\texttt{-l}, \texttt{\mm{}light}] ~\par - - Light mode. Suppress proofs (as with \texttt{-g}) and the following commands: - \begin{itemize} - \item {}[\texttt{Recursive}] \texttt{Tactic Definition} - \item \texttt{Hint / Hints} - \item \texttt{Require} - \item \texttt{Transparent / Opaque} - \item \texttt{Implicit Argument / Implicits} - \item \texttt{Section / Variable / Hypothesis / End} - \end{itemize} - -\end{description} -The behavior of options \texttt{-g} and \texttt{-l} can be locally -overridden using the \texttt{(* begin show *)} \dots\ \texttt{(* end - show *)} environment (see above). - -There are a few options to drive the parsing of comments: -\begin{description} -\item[\texttt{\mm{}parse-comments}] ~\par - - Parses regular comments delimited by \texttt{(*} and \texttt{*)} as - well. They are typeset inline. - -\item[\texttt{\mm{}plain-comments}] ~\par - - Do not interpret comments, simply copy them as plain-text. - -\item[\texttt{\mm{}interpolate}] ~\par - - Use the globalization information to typeset identifiers appearing in - \Coq{} escapings inside comments. -\end{description} - - -\paragraph{Language options} - -Default behavior is to assume ASCII 7 bits input files. - -\begin{description} - -\item[\texttt{-latin1}, \texttt{\mm{}latin1}] ~\par - - Select ISO-8859-1 input files. It is equivalent to - \texttt{\mm{}inputenc latin1 \mm{}charset iso-8859-1}. - -\item[\texttt{-utf8}, \texttt{\mm{}utf8}] ~\par - - Set \texttt{\mm{}inputenc utf8x} for \LaTeX\ output and - \texttt{\mm{}charset utf-8} for HTML output. Also use Unicode - replacements for a couple of standard plain ASCII notations such - as $\rightarrow$ for \texttt{->} and $\forall$ for - \texttt{forall}. \LaTeX\ UTF-8 support can be found at - \url{http://www.ctan.org/pkg/unicode}. - - For the interpretation of Unicode characters by \LaTeX, extra - packages which {\coqdoc} does not provide by default might be - required, such as \texttt{textgreek} for some Greek letters or - \texttt{stmaryrd} for some mathematical symbols. If a Unicode - character is missing an interpretation in the \texttt{utf8x} input - encoding, add - \verb=\DeclareUnicodeCharacter{=\textit{code}\verb=}{=\textit{latex-interpretation}\verb=}=. Packages - and declarations can be added with option \texttt{-p}. - -\item[\texttt{\mm{}inputenc} \textit{string}] ~\par - - Give a \LaTeX\ input encoding, as an option to \LaTeX\ package - \texttt{inputenc}. - -\item[\texttt{\mm{}charset} \textit{string}] ~\par - - Specify the HTML character set, to be inserted in the HTML header. - -\end{description} - - -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% - -\subsection[The coqdoc \LaTeX{} style file]{The coqdoc \LaTeX{} style file\label{section:coqdoc.sty}} - -In case you choose to produce a document without the default \LaTeX{} -preamble (by using option \verb|--no-preamble|), then you must insert -into your own preamble the command -\begin{quote} - \verb|\usepackage{coqdoc}| -\end{quote} - -The package optionally takes the argument \verb|[color]| to typeset -identifiers with colors (this requires the \verb|xcolor| package). - -Then you may alter the rendering of the document by -redefining some macros: -\begin{description} - -\item[\texttt{coqdockw}, \texttt{coqdocid}, \ldots] ~ - - The one-argument macros for typesetting keywords and identifiers. - Defaults are sans-serif for keywords and italic for identifiers. - - For example, if you would like a slanted font for keywords, you - may insert -\begin{verbatim} - \renewcommand{\coqdockw}[1]{\textsl{#1}} -\end{verbatim} - anywhere between \verb|\usepackage{coqdoc}| and - \verb|\begin{document}|. - -\item[\texttt{coqdocmodule}] ~ - - One-argument macro for typesetting the title of a \verb|.v| file. - Default is -\begin{verbatim} -\newcommand{\coqdocmodule}[1]{\section*{Module #1}} -\end{verbatim} - and you may redefine it using \verb|\renewcommand|. - -\end{description} - - diff --git a/doc/refman/coqide-queries.png b/doc/refman/coqide-queries.png Binary files differdeleted file mode 100644 index 7a46ac4e6..000000000 --- a/doc/refman/coqide-queries.png +++ /dev/null diff --git a/doc/refman/coqide.png b/doc/refman/coqide.png Binary files differdeleted file mode 100644 index e300401c9..000000000 --- a/doc/refman/coqide.png +++ /dev/null diff --git a/doc/refman/headers.hva b/doc/refman/headers.hva deleted file mode 100644 index 9714a29be..000000000 --- a/doc/refman/headers.hva +++ /dev/null @@ -1,44 +0,0 @@ -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -% File headers.hva -% Hevea version of headers.sty -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% - -%%%%%%%%%%%%%%%%%%%%%%%%%%%% -% Commands for indexes -%%%%%%%%%%%%%%%%%%%%%%%%%%%% -\usepackage{index} -\makeindex - - -\newindex{tactic}{tacidx}{tacind}{Tactics Index} -\newindex{command}{comidx}{comind}{Vernacular Commands Index} -\newindex{option}{optidx}{optind}{Vernacular Options Index} -\newindex{error}{erridx}{errind}{Index of Error Messages} -\renewindex{default}{idx}{ind}{Global Index} - -\newcommand{\printrefmanindex}[3]{% -\addcontentsline{toc}{chapter}{#2}% -\printindex[#1]% -\cutname{#3}% -} - -\newcommand{\tacindex}[1]{% -\index{#1@\texttt{#1}}\index[tactic]{#1@\texttt{#1}}} -\newcommand{\comindex}[1]{% -\index{#1@\texttt{#1}}\index[command]{#1@\texttt{#1}}} -\newcommand{\optindex}[1]{% -\index{#1@\texttt{#1}}\index[option]{#1@\texttt{#1}}} -\newcommand{\errindex}[1]{\texttt{#1}\index[error]{#1}} -\newcommand{\errindexbis}[2]{\texttt{#1}\index[error]{#2}} -\newcommand{\ttindex}[1]{\index{#1@\texttt{#1}}} - -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -% For the Addendum table of contents -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -\newcommand{\aauthor}[1]{{\LARGE \bf #1} \bigskip} % 3 \bigskip's that were here originally - % may be good for LaTeX but too much for HTML -\newcommand{\atableofcontents}{} -\newcommand{\achapter}[1]{\chapter{#1}} -\newcommand{\asection}{\section} -\newcommand{\asubsection}{\subsection} -\newcommand{\asubsubsection}{\subsubsection} diff --git a/doc/refman/headers.sty b/doc/refman/headers.sty deleted file mode 100644 index fb39f687d..000000000 --- a/doc/refman/headers.sty +++ /dev/null @@ -1,88 +0,0 @@ -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -% File headers.sty -% Commands for pretty headers, multiple indexes, and the appendix. -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -\usepackage{fancyhdr} - -\setlength{\headheight}{14pt} - -\pagestyle{fancyplain} - -\newcommand{\coqfooter}{\tiny Coq Reference Manual, V\coqversion{}, \today} - -\cfoot{} -\lfoot[{\coqfooter}]{} -\rfoot[]{{\coqfooter}} - -\newcommand{\setheaders}[1]{\rhead[\fancyplain{}{\textbf{#1}}]{\fancyplain{}{\thepage}}\lhead[\fancyplain{}{\thepage}]{\fancyplain{}{\textbf{#1}}}} -\newcommand{\defaultheaders}{\rhead[\fancyplain{}{\leftmark}]{\fancyplain{}{\thepage}}\lhead[\fancyplain{}{\thepage}]{\fancyplain{}{\rightmark}}} - -\renewcommand{\chaptermark}[1]{\markboth{{\bf \thechapter~#1}}{}} -\renewcommand{\sectionmark}[1]{\markright{\thesection~#1}} -\renewcommand{\contentsname}{% -\protect\setheaders{Table of contents}Table of contents} -\renewcommand{\bibname}{\protect\setheaders{Bibliography}% -\protect\RefManCutCommand{BEGINBIBLIO=\thepage}% -\protect\addcontentsline{toc}{chapter}{Bibliography}Bibliography} - -%%%%%%%%%%%%%%%%%%%%%%%%%%%% -% Commands for indexes -%%%%%%%%%%%%%%%%%%%%%%%%%%%% -\usepackage{index} -\makeindex - -\newindex{tactic}{tacidx}{tacind}{Tactics Index} -\newindex{command}{comidx}{comind}{Vernacular Commands Index} -\newindex{option}{optidx}{optind}{Vernacular Options Index} -\newindex{error}{erridx}{errind}{Index of Error Messages} -\renewindex{default}{idx}{ind}{Global Index} - -\newcommand{\printrefmanindex}[3]{% -\cleardoublepage% -\phantomsection% -\setheaders{#2}% -\addcontentsline{toc}{chapter}{#2}% -\printindex[#1]% -\cutname{#3}% -} - -\newcommand{\tacindex}[1]{% -\index{#1@\texttt{#1}}\index[tactic]{#1@\texttt{#1}}} -\newcommand{\comindex}[1]{% -\index{#1@\texttt{#1}}\index[command]{#1@\texttt{#1}}} -\newcommand{\optindex}[1]{% -\index{#1@\texttt{#1}}\index[option]{#1@\texttt{#1}}} -\newcommand{\errindex}[1]{\texttt{#1}\index[error]{#1}} -\newcommand{\errindexbis}[2]{\texttt{#1}\index[error]{#2}} -\newcommand{\ttindex}[1]{\index{#1@\texttt{#1}}} - -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -% For the Addendum table of contents -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -\newcommand{\aauthor}[1]{{\LARGE \bf #1} \bigskip \bigskip \bigskip} -\newcommand{\atableofcontents}{\section*{Contents}\@starttoc{atoc}} -\newcommand{\achapter}[1]{ - \chapter{#1}\addcontentsline{atoc}{chapter}{#1}} -\newcommand{\asection}[1]{ - \section{#1}\addcontentsline{atoc}{section}{#1}} -\newcommand{\asubsection}[1]{ - \subsection{#1}\addcontentsline{atoc}{subsection}{#1}} -\newcommand{\asubsubsection}[1]{ - \subsubsection{#1}\addcontentsline{atoc}{subsubsection}{#1}} - -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -% Reference-Manual.sh is generated to cut the Postscript -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -%\@starttoc{sh} -\newwrite\RefManCut@out% -\immediate\openout\RefManCut@out\jobname.sh -\newcommand{\RefManCutCommand}[1]{% -\immediate\write\RefManCut@out{#1}} -\newcommand{\RefManCutClose}{% -\immediate\closeout\RefManCut@out} - - -%%% Local Variables: -%%% mode: latex -%%% TeX-master: "Reference-Manual" -%%% End: diff --git a/doc/refman/hevea.sty b/doc/refman/hevea.sty deleted file mode 100644 index 6d49aa8ce..000000000 --- a/doc/refman/hevea.sty +++ /dev/null @@ -1,78 +0,0 @@ -% hevea : hevea.sty -% This is a very basic style file for latex document to be processed -% with hevea. It contains definitions of LaTeX environment which are -% processed in a special way by the translator. -% Mostly : -% - latexonly, not processed by hevea, processed by latex. -% - htmlonly , the reverse. -% - rawhtml, to include raw HTML in hevea output. -% - toimage, to send text to the image file. -% The package also provides hevea logos, html related commands (ahref -% etc.), void cutting and image commands. -\NeedsTeXFormat{LaTeX2e} -\ProvidesPackage{hevea}[2002/01/11] -\RequirePackage{comment} -\newif\ifhevea\heveafalse -\@ifundefined{ifimagen}{\newif\ifimagen\imagenfalse} -\makeatletter% -\newcommand{\heveasmup}[2]{% -\raise #1\hbox{$\m@th$% - \csname S@\f@size\endcsname - \fontsize\sf@size 0% - \math@fontsfalse\selectfont -#2% -}}% -\DeclareRobustCommand{\hevea}{H\kern-.15em\heveasmup{.2ex}{E}\kern-.15emV\kern-.15em\heveasmup{.2ex}{E}\kern-.15emA}% -\DeclareRobustCommand{\hacha}{H\kern-.15em\heveasmup{.2ex}{A}\kern-.15emC\kern-.1em\heveasmup{.2ex}{H}\kern-.15emA}% -\DeclareRobustCommand{\html}{\protect\heveasmup{0.ex}{HTML}} -%%%%%%%%% Hyperlinks hevea style -\newcommand{\ahref}[2]{{#2}} -\newcommand{\ahrefloc}[2]{{#2}} -\newcommand{\aname}[2]{{#2}} -\newcommand{\ahrefurl}[1]{\texttt{#1}} -\newcommand{\footahref}[2]{#2\footnote{\texttt{#1}}} -\newcommand{\mailto}[1]{\texttt{#1}} -\newcommand{\imgsrc}[2][]{} -\newcommand{\home}[1]{\protect\raisebox{-.75ex}{\char126}#1} -\AtBeginDocument -{\@ifundefined{url} -{%url package is not loaded -\let\url\ahref\let\oneurl\ahrefurl\let\footurl\footahref} -{}} -%% Void cutting instructions -\newcounter{cuttingdepth} -\newcommand{\tocnumber}{} -\newcommand{\notocnumber}{} -\newcommand{\cuttingunit}{} -\newcommand{\cutdef}[2][]{} -\newcommand{\cuthere}[2]{} -\newcommand{\cutend}{} -\newcommand{\htmlhead}[1]{} -\newcommand{\htmlfoot}[1]{} -\newcommand{\htmlprefix}[1]{} -\newenvironment{cutflow}[1]{}{} -\newcommand{\cutname}[1]{} -\newcommand{\toplinks}[3]{} -%%%% Html only -\excludecomment{rawhtml} -\newcommand{\rawhtmlinput}[1]{} -\excludecomment{htmlonly} -%%%% Latex only -\newenvironment{latexonly}{}{} -\newenvironment{verblatex}{}{} -%%%% Image file stuff -\def\toimage{\endgroup} -\def\endtoimage{\begingroup\def\@currenvir{toimage}} -\def\verbimage{\endgroup} -\def\endverbimage{\begingroup\def\@currenvir{verbimage}} -\newcommand{\imageflush}[1][]{} -%%% Bgcolor definition -\newsavebox{\@bgcolorbin} -\newenvironment{bgcolor}[2][] - {\newcommand{\@mycolor}{#2}\begin{lrbox}{\@bgcolorbin}\vbox\bgroup} - {\egroup\end{lrbox}% - \begin{flushleft}% - \colorbox{\@mycolor}{\usebox{\@bgcolorbin}}% - \end{flushleft}} -%%% Postlude -\makeatother diff --git a/doc/refman/index.html b/doc/refman/index.html deleted file mode 100644 index b937350e6..000000000 --- a/doc/refman/index.html +++ /dev/null @@ -1,14 +0,0 @@ -<HTML> - -<HEAD> - -<TITLE>The Coq Proof Assistant Reference Manual</TITLE> - -</HEAD> - -<FRAMESET ROWS=90%,*> - <FRAME SRC="cover.html" NAME="UP"> - <FRAME SRC="menu.html"> -</FRAMESET> - -</HTML> diff --git a/doc/refman/menu.html b/doc/refman/menu.html deleted file mode 100644 index 7312ad344..000000000 --- a/doc/refman/menu.html +++ /dev/null @@ -1,32 +0,0 @@ -<HTML> - -<BODY> - -<CENTER> - -<TABLE BORDER="0" CELLPADDING=10> -<TR> -<TD><CENTER><A HREF="cover.html" TARGET="UP"><FONT SIZE=2>Cover page</FONT></A></CENTER></TD> -<TD><CENTER><A HREF="toc.html" TARGET="UP"><FONT SIZE=2>Table of contents</FONT></A></CENTER></TD> -<TD><CENTER><A HREF="biblio.html" TARGET="UP"><FONT SIZE=2> -Bibliography</FONT></A></CENTER></TD> -<TD><CENTER><A HREF="general-index.html" TARGET="UP"><FONT SIZE=2> -Global Index -</FONT></A></CENTER></TD> -<TD><CENTER><A HREF="tactic-index.html" TARGET="UP"><FONT SIZE=2> -Tactics Index -</FONT></A></CENTER></TD> -<TD><CENTER><A HREF="command-index.html" TARGET="UP"><FONT SIZE=2> -Vernacular Commands Index -</FONT></A></CENTER></TD> -<TD><CENTER><A HREF="option-index.html" TARGET="UP"><FONT SIZE=2> -Vernacular Options Index -</FONT></A></CENTER></TD> -<TD><CENTER><A HREF="error-index.html" TARGET="UP"><FONT SIZE=2> -Index of Error Messages -</FONT></A></CENTER></TD> -</TABLE> - -</CENTER> - -</BODY></HTML> diff --git a/doc/sphinx/MIGRATING b/doc/sphinx/MIGRATING deleted file mode 100644 index fa6fe1537..000000000 --- a/doc/sphinx/MIGRATING +++ /dev/null @@ -1,238 +0,0 @@ -How to migrate the Coq Reference Manual to Sphinx -================================================= - -# Install Python3 packages (requires Python 3, python3-pip, python3-setuptools) - - * pip3 install bs4 sphinx sphinx_rtd_theme pexpect antlr4-python3-runtime sphinxcontrib-bibtex - -# You may want to do this under a virtualenv, particularly if you end up with issues finding sphinxcontrib.bibtex. http://docs.python-guide.org/en/latest/dev/virtualenvs/ - - * pip3 install virtualenv - * virtualenv coqsphinxing # you may want to use -p to specify the python version - * source coqsphinxing/bin/activate # activate the virtual environment - -# After activating the virtual environment you can run the above pip3 command to install sphinx. You will have to activate the virtual environment before building the docs in your session. - -# Add this Elisp code to .emacs, if you're using emacs (recommended): - - (defun sphinx/quote-coq-refman-region (left right &optional beg end count) - (unless beg - (if (region-active-p) - (setq beg (region-beginning) end (region-end)) - (setq beg (point) end nil))) - (unless count - (setq count 1)) - (save-excursion - (goto-char (or end beg)) - (dotimes (_ count) (insert right))) - (save-excursion - (goto-char beg) - (dotimes (_ count) (insert left))) - (if (and end (characterp left)) ;; Second test handles the ::`` case - (goto-char (+ (* 2 count) end)) - (goto-char (+ count beg)))) - - (defun sphinx/coqtop (beg end) - (interactive (list (region-beginning) (region-end))) - (replace-regexp "^Coq < " " " nil beg end) - (indent-rigidly beg end -3) - (goto-char beg) - (insert ".. coqtop:: all\n\n")) - - (defun sphinx/rst-coq-action () - (interactive) - (pcase (read-char "Command?") - (?g (sphinx/quote-coq-refman-region ":g:`" "`")) - (?n (sphinx/quote-coq-refman-region ":n:`" "`")) - (?t (sphinx/quote-coq-refman-region ":token:`" "`")) - (?m (sphinx/quote-coq-refman-region ":math:`" "`")) - (?: (sphinx/quote-coq-refman-region "::`" "`")) - (?` (sphinx/quote-coq-refman-region "``" "``")) - (?c (sphinx/coqtop (region-beginning) (region-end))))) - - (global-set-key (kbd "<f12>") #'sphinx/rst-coq-action) - - With this code installed, you can hit "F12" followed by an appropriate key to do quick markup of text - (this will make more sense once you've started editing the text). - -# Fork the Coq repo, if needed: - - https://github.com/coq/coq - -# Clone the repo to your work machine - -# Add Maxime Dénès's repo as a remote: - - git remote add sphinx https://github.com/maximedenes/coq.git - - (or choose a name other than "sphinx") - - Verify with: - - git remote -v - -# Fetch from the remote - - git fetch sphinx - -# Checkout the sphinx-doc branch - - git checkout sphinx-doc - - You should pull from the repo from time to time to keep your local copy up-to-date: - - git pull sphinx sphinx-doc - - You may want to create a new branch to do your work in. - -# Choose a Reference Manual chapter to work on at - - https://docs.google.com/document/d/1Yo7dV4OI0AY9Di-lsEQ3UTmn5ygGLlhxjym7cTCMCWU - -# For each chapter, raw ReStructuredText (the Sphinx format), created by the "html2rest" utility, - is available in the directory porting/raw-rst/ - - Elsewhere, depending on the chapter, there should be an almost-empty template file already created, - which is in the location where the final version should go - -# Manually edit the .rst file, place it in the correct location - - There are small examples in sphinx/porting/, a larger example in language/gallina-extensions.rst - - (N.B.: the migration is a work-in-progress, your suggestions are welcome) - - Find the chapter you're working on from the online manual at https://coq.inria.fr/distrib/current/refman/. - At the top of the file, after the chapter heading, add: - - :Source: https://coq.inria.fr/distrib/current/refman/the-chapter-file.html - :Converted by: Your Name - - N.B.: These source and converted-by annotations should help for the migration phase. Later on, - those annotations will be removed, and contributors will be mentioned in the Coq credits. - - Remove chapter numbers - - Replace section, subsection numbers with reference labels: - - .. _some-reference-label: - - Place the label before the section or subsection, followed by a blank line. - - Note the leading underscore. Use :ref:`some_reference-label` to refer to such a label; note the leading underscore is omitted. - Many cross-references may be to other chapters. If the required label exists, use it. Otherwise, use a dummy reference of the form - `TODO-n.n.n-mnemonic` we can fixup later. Example: - - :ref:`TODO-1.3.2-definitions` - - We can grep for those TODOs, and the existing subsection number makes it easy to find in the exisyting manual. - - For the particular case of references to chapters, we can use a -convention for the cross-reference name, so no TODO is needed. - - :ref:`thegallinaspecificationlanguage` - -That is, the chapter label is the chapter title, all in lower-case, -with no spaces or punctuation. For chapters with subtitles marked with -a ":", like those for Omega and Nsatz, use just the chapter part -preceding the ":". These labels should already be in the -placeholder .rst files for each chapter. - - - You can also label other items, like grammars, with the same syntax. To refer to such labels, not involving a - section or subsection, use the syntax - - :ref:`Some link text <label-name>` - - Yes, the angle-brackets are needed here! - - For bibliographic references (those in biblio.bib), use :cite:`thecitation`. - - Grammars will get mangled by the translation. Look for "productionlist" in the examples, also see - http://www.sphinx-doc.org/en/stable/markup/para.html. - - For Coq examples that appear, look at the "coqtop" syntax in porting/tricky-bits.rst. The Sphinx - script will run coqtop on those examples, and can show the output (or not). - - The file replaces.rst contains replacement definitions for some items that are clumsy to write out otherwise. - Use - - .. include:: replaces.rst - - to gain access to those definitions in your file (you might need a path prefix). Some especially-important - replacements are |Cic|, |Coq|, |CoqIDE|, and |Gallina|, which display those names in small-caps. Please use them, - so that they're rendered consistently. - - Similarly, there are some LaTeX macros in preamble.rst that can be useful. - - Conventions: - - - Keywords and other literal text is double-backquoted (e.g. ``Module``, ``Section``, ``(``, ``,``). - - - Metavariables are single-backquotes (e.g. `term`, `ident`) - - - Use the cmd directive for Vernacular commands, like: - - .. cmd:: Set Printing All. - - Within this directive, prefix metavariables (ident, term) with @: - - .. cmd:: Add Printing Let @ident. - - There's also the "cmdv" directive for variants of a command. - - - Use the "exn" and "warn" directives for errors and warnings: - - .. exn:: Something's not right. - .. warn:: You shouldn't do that. - - - Use the "example" directive for examples - - - Use the "g" role for inline Gallina, like :g:`fun x => x` - - - Use code blocks for blocks of Gallina. You can use a double-colon at the end of a line:: - - your code here - - which prints a single colon, or put the double-colon on a newline. - -:: - - your other code here - -# Making changes to the text - - The goal of the migration is simply to change the storage format from LaTeX to ReStructuredText. The goal is not - to make any organizational or other substantive changes to the text. If you do notice nits (misspellings, wrong - verb tense, and so on), please do change them. For example, the programming language that Coq is written in is these days - called "OCaml", and there are mentions of the older name "Objective Caml" in the reference manual that should be changed. - -# Build, view the manual - - In the root directory of your local repo, run "make sphinx". You can view the result in a browser by loading the HTML file - associated with your chapter, which will be contained in the directory doc/sphinx/_build/html/ beneath the repo root directory. - Make any changes you need until there are no build warnings and the output is perfect. :-) - -# Creating pull requests - - When your changes are done, commit them, push to your fork: - - git commit -m "useful commit message" file - git push origin sphinx-doc - - (or push to another branch, if you've created one). Then go to your GitHub - fork and create a pull request against Maxime's sphinx-doc - branch. If your commit is recent, you should see a link on your - fork's code page to do that. Otherwise, you may need to go to your - branch on GitHub to do that. - -# Issues/Questions/Suggestions - - As the migration proceeds, if you have technical issues, have a more general question, or want to suggest something, please contact: - - Paul Steckler <steck@stecksoft.com> - Maxime Dénès <maxime.denes@inria.fr> - -# Issues - - Should the stuff in replaces.rst go in preamble.rst? - In LaTeX, some of the grammars add productions to existing nonterminals, like term ++= ... . How to indicate that? diff --git a/doc/sphinx/README.rst b/doc/sphinx/README.rst new file mode 100644 index 000000000..35a605ddd --- /dev/null +++ b/doc/sphinx/README.rst @@ -0,0 +1,395 @@ +============================= + Documenting Coq with Sphinx +============================= + +.. + README.rst is auto-generated from README.template.rst and the coqrst docs; + use ``doc/tools/coqrst/regen_readme.py`` to rebuild it. + +Coq's reference manual is written in `reStructuredText <http://www.sphinx-doc.org/en/master/usage/restructuredtext/basics.html>`_ (“reST”), and compiled with `Sphinx <http://www.sphinx-doc.org/en/master/>`_. + +In addition to standard reST directives (a directive is similar to a LaTeX environment) and roles (a role is similar to a LaTeX command), the ``coqrst`` plugin loaded by the documentation uses a custom *Coq domain* — a set of Coq-specific directives that define *objects* like tactics, commands (vernacs), warnings, etc. —, some custom *directives*, and a few custom *roles*. Finally, this manual uses a small DSL to describe tactic invocations and commands. + +Coq objects +=========== + +Our Coq domain define multiple `objects`_. Each object has a *signature* (think *type signature*), followed by an optional body (a description of that object). The following example defines two objects: a variant of the ``simpl`` tactic, and an error that it may raise:: + + .. tacv:: simpl @pattern at {+ @num} + :name: simpl_at + + This applies ``simpl`` only to the :n:`{+ @num}` occurrences of the subterms + matching :n:`@pattern` in the current goal. + + .. exn:: Too few occurrences + :undocumented: + +Objects are automatically collected into indices, and can be linked to using the role version of the object's directive. For example, you could link to the tactic variant above using ``:tacv:`simpl_at```, and to its exception using ``:exn:`Too few occurrences```. + +Names (link targets) are auto-generated for most simple objects, though they can always be overwritten using a ``:name:`` option, as shown above. + +- Options, errors, warnings have their name set to their signature, with ``...`` replacing all notation bits. For example, the auto-generated name of ``.. exn:: @qualid is not a module`` is ``... is not a module``, and a link to it would take the form ``:exn:`... is not a module```. +- Vernacs (commands) have their name set to the first word of their signature. For example, the auto-generated name of ``Axiom @ident : @term`` is ``Axiom``, and a link to it would take the form ``:cmd:`Axiom```. +- Vernac variants, tactic notations, and tactic variants do not have a default name. + +Most objects should have a body (i.e. a block of indented text following the signature, called “contents” in Sphinx terms). Undocumented objects should have the `:undocumented:` flag instead, as shown above. When multiple objects have a single description, they can be grouped into a single object, like this (semicolons can be used to separate the names of the objects):: + + .. cmdv:: Lemma @ident {? @binders} : @type + Remark @ident {? @binders} : @type + Fact @ident {? @binders} : @type + Corollary @ident {? @binders} : @type + Proposition @ident {? @binders} : @type + :name: Lemma; Remark; Fact; Corollary; Proposition + + These commands are all synonyms of :n:`Theorem @ident {? @binders } : type`. + +Notations +--------- + +The signatures of most objects can be written using a succinct DSL for Coq notations (think regular expressions written with a Lispy syntax). A typical signature might look like ``Hint Extern @num {? @pattern} => @tactic``, which means that the ``Hint Extern`` command takes a number (``num``), followed by an optional pattern, and a mandatory tactic. The language has the following constructs (the full grammar is in `TacticNotations.g </doc/tools/coqrst/notations/TacticNotations.g>`_): + +``@…`` + A placeholder (``@ident``, ``@num``, ``@tactic``\ …) + +``{? …}`` + an optional block + +``{* …}``, ``{+ …}`` + an optional (``*``) or mandatory (``+``) block that can be repeated, with repetitions separated by spaces + +``{*, …}``, ``{+, …}`` + an optional or mandatory repeatable block, with repetitions separated by commas + +``%|``, ``%{``, … + an escaped character (rendered without the leading ``%``) + +.. + FIXME document the new subscript support + +As an exercise, what do the following patterns mean? + +.. code:: + + pattern {+, @term {? at {+ @num}}} + generalize {+, @term at {+ @num} as @ident} + fix @ident @num with {+ (@ident {+ @binder} {? {struct @ident'}} : @type)} + +Objects +------- + +Here is the list of all objects of the Coq domain (The symbol :black_nib: indicates an object whose signature can be written using the notations DSL): + +``.. cmd::`` :black_nib: A Coq command. + Example:: + + .. cmd:: Infix "@symbol" := @term ({+, @modifier}). + + This command is equivalent to :n:`…`. + +``.. cmdv::`` :black_nib: A variant of a Coq command. + Example:: + + .. cmd:: Axiom @ident : @term. + + This command links :token:`term` to the name :token:`term` as its specification in + the global context. The fact asserted by :token:`term` is thus assumed as a + postulate. + + .. cmdv:: Parameter @ident : @term. + + This is equivalent to :n:`Axiom @ident : @term`. + +``.. exn::`` :black_nib: An error raised by a Coq command or tactic. + This commonly appears nested in the ``.. tacn::`` that raises the + exception. + + Example:: + + .. tacv:: assert @form by @tactic + + This tactic applies :n:`@tactic` to solve the subgoals generated by + ``assert``. + + .. exn:: Proof is not complete + + Raised if :n:`@tactic` does not fully solve the goal. + +``.. opt::`` :black_nib: A Coq option. + Example:: + + .. opt:: Nonrecursive Elimination Schemes + + This option controls whether types declared with the keywords + :cmd:`Variant` and :cmd:`Record` get an automatic declaration of the + induction principles. + +``.. prodn::`` :black_nib: Grammar productions. + This is useful if you intend to document individual grammar productions. + Otherwise, use Sphinx's `production lists + <http://www.sphinx-doc.org/en/stable/markup/para.html#directive-productionlist>`_. + +``.. tacn::`` :black_nib: A tactic, or a tactic notation. + Example:: + + .. tacn:: do @num @expr + + :token:`expr` is evaluated to ``v`` which must be a tactic value. … + +``.. tacv::`` :black_nib: A variant of a tactic. + Example:: + + .. tacn:: fail + + This is the always-failing tactic: it does not solve any goal. It is + useful for defining other tacticals since it can be caught by + :tacn:`try`, :tacn:`repeat`, :tacn:`match goal`, or the branching + tacticals. … + + .. tacv:: fail @natural + + The number is the failure level. If no level is specified, it + defaults to 0. … + +``.. thm::`` A theorem. + Example:: + + .. thm:: Bound on the ceiling function + + Let :math:`p` be an integer and :math:`c` a rational constant. Then + :math:`p \ge c \rightarrow p \ge \lceil{c}\rceil`. + +``.. warn::`` :black_nib: An warning raised by a Coq command or tactic.. + Do not mistake this for ``.. warning::``; this directive is for warning + messages produced by Coq. + + + Example:: + + .. warn:: Ambiguous path + + When the coercion :token:`qualid` is added to the inheritance graph, non + valid coercion paths are ignored. + +Coq directives +============== + +In addition to the objects above, the ``coqrst`` Sphinx plugin defines the following directives: + +``.. coqtop::`` A reST directive to describe interactions with Coqtop. + Usage:: + + .. coqtop:: options… + + Coq code to send to coqtop + + Example:: + + .. coqtop:: in reset undo + + Print nat. + Definition a := 1. + + Here is a list of permissible options: + + - Display options + + - ``all``: Display input and output + - ``in``: Display only input + - ``out``: Display only output + - ``none``: Display neither (useful for setup commands) + + - Behavior options + + - ``reset``: Send a ``Reset Initial`` command before running this block + - ``undo``: Send an ``Undo n`` (``n`` = number of sentences) command after + running all the commands in this block + + ``coqtop``\ 's state is preserved across consecutive ``.. coqtop::`` blocks + of the same document (``coqrst`` creates a single ``coqtop`` process per + reST source file). Use the ``reset`` option to reset Coq's state. + +``.. coqdoc::`` A reST directive to display Coqtop-formatted source code. + Usage:: + + .. coqdoc:: + + Coq code to highlight + + Example:: + + .. coqdoc:: + + Definition test := 1. + +``.. example::`` A reST directive for examples. + This behaves like a generic admonition; see + http://docutils.sourceforge.net/docs/ref/rst/directives.html#generic-admonition + for more details. + + Example:: + + .. example:: Adding a hint to a database + + The following adds ``plus_comm`` to the ``plu`` database: + + .. coqdoc:: + + Hint Resolve plus_comm : plu. + +``.. inference::`` A reST directive to format inference rules. + This also serves as a small illustration of the way to create new Sphinx + directives. + + Usage:: + + .. inference:: name + + newline-separated premisses + ------------------------ + conclusion + + Example:: + + .. inference:: Prod-Pro + + \WTEG{T}{s} + s \in \Sort + \WTE{\Gamma::(x:T)}{U}{\Prop} + ----------------------------- + \WTEG{\forall~x:T,U}{\Prop} + +``.. preamble::`` A reST directive for hidden math. + Mostly useful to let MathJax know about `\def`\ s and `\newcommand`\ s. + + Example:: + + .. preamble:: + + \newcommand{\paren}[#1]{\left(#1\right)} + +Coq roles +========= + +In addition to the objects and directives above, the ``coqrst`` Sphinx plugin defines the following roles: + +``:g:`` Coq code. + Use this for Gallina and Ltac snippets:: + + :g:`apply plus_comm; reflexivity` + :g:`Set Printing All.` + :g:`forall (x: t), P(x)` + +``:n:`` Any text using the notation syntax (``@id``, ``{+, …}``, etc.). + Use this to explain tactic equivalences. For example, you might write + this:: + + :n:`generalize @term as @ident` is just like :n:`generalize @term`, but + it names the introduced hypothesis :token:`ident`. + + Note that this example also uses ``:token:``. That's because ``ident`` is + defined in the the Coq manual as a grammar production, and ``:token:`` + creates a link to that. When referring to a placeholder that happens to be + a grammar production, ``:token:`…``` is typically preferable to ``:n:`@…```. + +``:production:`` A grammar production not included in a ``productionlist`` directive. + Useful to informally introduce a production, as part of running text. + + Example:: + + :production:`string` indicates a quoted string. + + You're not likely to use this role very commonly; instead, use a + `production list + <http://www.sphinx-doc.org/en/stable/markup/para.html#directive-productionlist>`_ + and reference its tokens using ``:token:`…```. + +Common mistakes +=============== + +Improper nesting +---------------- + +DO + .. code:: + + .. cmd:: Foo @bar + + Foo the first instance of :token:`bar`\ s. + + .. cmdv:: Foo All + + Foo all the :token:`bar`\ s in + the current context + +DON'T + .. code:: + + .. cmd:: Foo @bar + + Foo the first instance of :token:`bar`\ s. + + .. cmdv:: Foo All + + Foo all the :token:`bar`\ s in + the current context + +You can set the ``report_undocumented_coq_objects`` setting in ``conf.py`` to ``"info"`` or ``"warning"`` to get a list of all Coq objects without a description. + +Overusing ``:token:`` +--------------------- + +DO + .. code:: + + This is equivalent to :n:`Axiom @ident : @term`. + +DON'T + .. code:: + + This is equivalent to ``Axiom`` :token`ident` : :token:`term`. + +Omitting annotations +-------------------- + +DO + .. code:: + + .. tacv:: assert @form as @intro_pattern + +DON'T + .. code:: + + .. tacv:: assert form as intro_pattern + +Tips and tricks +=============== + +Nested lemmas +------------- + +The ``.. coqtop::`` directive does *not* reset Coq after running its contents. That is, the following will create two nested lemmas:: + + .. coqtop:: all + + Lemma l1: 1 + 1 = 2. + + .. coqtop:: all + + Lemma l2: 2 + 2 <> 1. + +Add either ``undo`` to the first block or ``reset`` to the second block to avoid nesting lemmas. + +Abbreviations and macros +------------------------ + +Abbreviations and placeholders for specially-formatted names (like ``|Cic|``, ``|Coq|``, ``|CoqIDE|``, ``|Ltac|``, and ``|Gallina|``) are defined in a `separate file </doc/sphinx/replaces.rst>`_ included by most chapters of the manual. Some useful LaTeX macros are defined in `</doc/sphinx/preamble.rst>`_. + +Emacs +----- + +The ``dev/tools/coqdev.el`` folder contains a convenient Emacs function to quickly insert Sphinx roles and quotes. It takes a single character (one of ``gntm:```), and inserts one of ``:g:``, ``:n:``, ``:t:``, or an arbitrary role, or double quotes. You can also select a region of text, and wrap it in single or double backticks using that function. + +Use the following snippet to bind it to :kbd:`F12` in ``rst-mode``:: + + (with-eval-after-load 'rst + (define-key rst-mode-map (kbd "<f12>") #'coqdev-sphinx-rst-coq-action)) diff --git a/doc/sphinx/README.template.rst b/doc/sphinx/README.template.rst new file mode 100644 index 000000000..f1d2541eb --- /dev/null +++ b/doc/sphinx/README.template.rst @@ -0,0 +1,187 @@ +============================= + Documenting Coq with Sphinx +============================= + +.. + README.rst is auto-generated from README.template.rst and the coqrst docs; + use ``doc/tools/coqrst/regen_readme.py`` to rebuild it. + +Coq's reference manual is written in `reStructuredText <http://www.sphinx-doc.org/en/master/usage/restructuredtext/basics.html>`_ (“reST”), and compiled with `Sphinx <http://www.sphinx-doc.org/en/master/>`_. + +In addition to standard reST directives (a directive is similar to a LaTeX environment) and roles (a role is similar to a LaTeX command), the ``coqrst`` plugin loaded by the documentation uses a custom *Coq domain* — a set of Coq-specific directives that define *objects* like tactics, commands (vernacs), warnings, etc. —, some custom *directives*, and a few custom *roles*. Finally, this manual uses a small DSL to describe tactic invocations and commands. + +Coq objects +=========== + +Our Coq domain define multiple `objects`_. Each object has a *signature* (think *type signature*), followed by an optional body (a description of that object). The following example defines two objects: a variant of the ``simpl`` tactic, and an error that it may raise:: + + .. tacv:: simpl @pattern at {+ @num} + :name: simpl_at + + This applies ``simpl`` only to the :n:`{+ @num}` occurrences of the subterms + matching :n:`@pattern` in the current goal. + + .. exn:: Too few occurrences + :undocumented: + +Objects are automatically collected into indices, and can be linked to using the role version of the object's directive. For example, you could link to the tactic variant above using ``:tacv:`simpl_at```, and to its exception using ``:exn:`Too few occurrences```. + +Names (link targets) are auto-generated for most simple objects, though they can always be overwritten using a ``:name:`` option, as shown above. + +- Options, errors, warnings have their name set to their signature, with ``...`` replacing all notation bits. For example, the auto-generated name of ``.. exn:: @qualid is not a module`` is ``... is not a module``, and a link to it would take the form ``:exn:`... is not a module```. +- Vernacs (commands) have their name set to the first word of their signature. For example, the auto-generated name of ``Axiom @ident : @term`` is ``Axiom``, and a link to it would take the form ``:cmd:`Axiom```. +- Vernac variants, tactic notations, and tactic variants do not have a default name. + +Most objects should have a body (i.e. a block of indented text following the signature, called “contents” in Sphinx terms). Undocumented objects should have the `:undocumented:` flag instead, as shown above. When multiple objects have a single description, they can be grouped into a single object, like this (semicolons can be used to separate the names of the objects):: + + .. cmdv:: Lemma @ident {? @binders} : @type + Remark @ident {? @binders} : @type + Fact @ident {? @binders} : @type + Corollary @ident {? @binders} : @type + Proposition @ident {? @binders} : @type + :name: Lemma; Remark; Fact; Corollary; Proposition + + These commands are all synonyms of :n:`Theorem @ident {? @binders } : type`. + +Notations +--------- + +The signatures of most objects can be written using a succinct DSL for Coq notations (think regular expressions written with a Lispy syntax). A typical signature might look like ``Hint Extern @num {? @pattern} => @tactic``, which means that the ``Hint Extern`` command takes a number (``num``), followed by an optional pattern, and a mandatory tactic. The language has the following constructs (the full grammar is in `TacticNotations.g </doc/tools/coqrst/notations/TacticNotations.g>`_): + +``@…`` + A placeholder (``@ident``, ``@num``, ``@tactic``\ …) + +``{? …}`` + an optional block + +``{* …}``, ``{+ …}`` + an optional (``*``) or mandatory (``+``) block that can be repeated, with repetitions separated by spaces + +``{*, …}``, ``{+, …}`` + an optional or mandatory repeatable block, with repetitions separated by commas + +``%|``, ``%{``, … + an escaped character (rendered without the leading ``%``) + +.. + FIXME document the new subscript support + +As an exercise, what do the following patterns mean? + +.. code:: + + pattern {+, @term {? at {+ @num}}} + generalize {+, @term at {+ @num} as @ident} + fix @ident @num with {+ (@ident {+ @binder} {? {struct @ident'}} : @type)} + +Objects +------- + +Here is the list of all objects of the Coq domain (The symbol :black_nib: indicates an object whose signature can be written using the notations DSL): + +[OBJECTS] + +Coq directives +============== + +In addition to the objects above, the ``coqrst`` Sphinx plugin defines the following directives: + +[DIRECTIVES] + +Coq roles +========= + +In addition to the objects and directives above, the ``coqrst`` Sphinx plugin defines the following roles: + +[ROLES] + +Common mistakes +=============== + +Improper nesting +---------------- + +DO + .. code:: + + .. cmd:: Foo @bar + + Foo the first instance of :token:`bar`\ s. + + .. cmdv:: Foo All + + Foo all the :token:`bar`\ s in + the current context + +DON'T + .. code:: + + .. cmd:: Foo @bar + + Foo the first instance of :token:`bar`\ s. + + .. cmdv:: Foo All + + Foo all the :token:`bar`\ s in + the current context + +You can set the ``report_undocumented_coq_objects`` setting in ``conf.py`` to ``"info"`` or ``"warning"`` to get a list of all Coq objects without a description. + +Overusing ``:token:`` +--------------------- + +DO + .. code:: + + This is equivalent to :n:`Axiom @ident : @term`. + +DON'T + .. code:: + + This is equivalent to ``Axiom`` :token`ident` : :token:`term`. + +Omitting annotations +-------------------- + +DO + .. code:: + + .. tacv:: assert @form as @intro_pattern + +DON'T + .. code:: + + .. tacv:: assert form as intro_pattern + +Tips and tricks +=============== + +Nested lemmas +------------- + +The ``.. coqtop::`` directive does *not* reset Coq after running its contents. That is, the following will create two nested lemmas:: + + .. coqtop:: all + + Lemma l1: 1 + 1 = 2. + + .. coqtop:: all + + Lemma l2: 2 + 2 <> 1. + +Add either ``undo`` to the first block or ``reset`` to the second block to avoid nesting lemmas. + +Abbreviations and macros +------------------------ + +Abbreviations and placeholders for specially-formatted names (like ``|Cic|``, ``|Coq|``, ``|CoqIDE|``, ``|Ltac|``, and ``|Gallina|``) are defined in a `separate file </doc/sphinx/replaces.rst>`_ included by most chapters of the manual. Some useful LaTeX macros are defined in `</doc/sphinx/preamble.rst>`_. + +Emacs +----- + +The ``dev/tools/coqdev.el`` folder contains a convenient Emacs function to quickly insert Sphinx roles and quotes. It takes a single character (one of ``gntm:```), and inserts one of ``:g:``, ``:n:``, ``:t:``, or an arbitrary role, or double quotes. You can also select a region of text, and wrap it in single or double backticks using that function. + +Use the following snippet to bind it to :kbd:`F12` in ``rst-mode``:: + + (with-eval-after-load 'rst + (define-key rst-mode-map (kbd "<f12>") #'coqdev-sphinx-rst-coq-action)) diff --git a/doc/sphinx/_static/CoqNotations.ttf b/doc/sphinx/_static/CoqNotations.ttf Binary files differnew file mode 100644 index 000000000..da8f2850d --- /dev/null +++ b/doc/sphinx/_static/CoqNotations.ttf diff --git a/doc/sphinx/_static/UbuntuMono-Square.ttf b/doc/sphinx/_static/UbuntuMono-Square.ttf Binary files differdeleted file mode 100644 index 12b7c6d51..000000000 --- a/doc/sphinx/_static/UbuntuMono-Square.ttf +++ /dev/null diff --git a/doc/sphinx/_static/notations.css b/doc/sphinx/_static/notations.css index 9b7b826d5..f899945a3 100644 --- a/doc/sphinx/_static/notations.css +++ b/doc/sphinx/_static/notations.css @@ -22,10 +22,10 @@ } @font-face { /* This font has been edited to center all characters */ - font-family: 'UbuntuMono-Square'; + font-family: 'CoqNotations'; font-style: normal; font-weight: 800; - src: local('UbuntuMono-Square'), url(./UbuntuMono-Square.ttf) format('truetype'); + src: local('CoqNotations'), url(./CoqNotations.ttf) format('truetype'); } .notation .notation-sup, .notation .notation-sub { @@ -34,15 +34,15 @@ color: black; /* cursor: help; */ display: inline-block; - font-size: 0.5em; + font-size: 0.45em; font-weight: bolder; - font-family: UbuntuMono-Square, monospace; - height: 2em; + font-family: CoqNotations, monospace; + height: 2.2em; line-height: 1.6em; position: absolute; right: -1em; /* half of the width */ text-align: center; - width: 2em; + width: 2.2em; } .notation .repeat { diff --git a/doc/sphinx/addendum/extended-pattern-matching.rst b/doc/sphinx/addendum/extended-pattern-matching.rst index 64d4eddf0..c4f014772 100644 --- a/doc/sphinx/addendum/extended-pattern-matching.rst +++ b/doc/sphinx/addendum/extended-pattern-matching.rst @@ -46,7 +46,7 @@ the expressiveness of the theory remains the same. Once the stage of parsing has finished only simple patterns remain. Re-nesting of pattern is performed at printing time. An easy way to see the result of the expansion is to toggle off the nesting performed at printing -(use here :opt:`Set Printing Matching`), then by printing the term with :cmd:`Print` +(use here :opt:`Printing Matching`), then by printing the term with :cmd:`Print` if the term is a constant, or using the command :cmd:`Check`. The extended ``match`` still accepts an optional *elimination predicate* @@ -75,7 +75,7 @@ by: Multiple patterns ----------------- -Using multiple patterns in the definition of max lets us write: +Using multiple patterns in the definition of ``max`` lets us write: .. coqtop:: in undo @@ -273,7 +273,7 @@ This option (off by default) removes parameters from constructors in patterns: match l with | nil => nil | cons _ l' => l' - end) + end). Unset Asymmetric Patterns. Implicit arguments in patterns @@ -305,6 +305,8 @@ explicitations (as for terms 2.7.11). end). +.. _matching-dependent: + Matching objects of dependent types ----------------------------------- @@ -414,6 +416,7 @@ length, by writing I have a copy of :g:`b` in type :g:`listn 0` resp :g:`listn (S n')`. +.. _match-in-patterns: Patterns in ``in`` ~~~~~~~~~~~~~~~~~~ @@ -427,7 +430,7 @@ become impossible branches. In an impossible branch, you can answer anything but False_rect unit has the advantage to be subterm of anything. -To be concrete: the tail function can be written: +To be concrete: the ``tail`` function can be written: .. coqtop:: in @@ -588,24 +591,24 @@ generated expression and the original. Here is a summary of the error messages corresponding to each situation: -.. exn:: The constructor @ident expects @num arguments +.. exn:: The constructor @ident expects @num arguments. The variable ident is bound several times in pattern termFound a constructor of inductive type term while a constructor of term is expectedPatterns are incorrect (because constructors are not applied to the correct number of the arguments, because they are not linear or they are wrongly typed). -.. exn:: Non exhaustive pattern-matching +.. exn:: Non exhaustive pattern-matching. The pattern matching is not exhaustive. .. exn:: The elimination predicate term should be of arity @num (for non \ - dependent case) or @num (for dependent case) + dependent case) or @num (for dependent case). The elimination predicate provided to match has not the expected arity. .. exn:: Unable to infer a match predicate - Either there is a type incompatibility or the problem involves dependencies + Either there is a type incompatibility or the problem involves dependencies. There is a type mismatch between the different branches. The user should provide an elimination predicate. diff --git a/doc/sphinx/addendum/extraction.rst b/doc/sphinx/addendum/extraction.rst index d7f97edab..cb93d48a4 100644 --- a/doc/sphinx/addendum/extraction.rst +++ b/doc/sphinx/addendum/extraction.rst @@ -1,16 +1,16 @@ -.. _extraction: - .. include:: ../replaces.rst -Extraction of programs in OCaml and Haskell -============================================ +.. _extraction: + +Extraction of programs in |OCaml| and Haskell +============================================= :Authors: Jean-Christophe Filliâtre and Pierre Letouzey We present here the |Coq| extraction commands, used to build certified and relatively efficient functional programs, extracting them from either |Coq| functions or |Coq| proofs of specifications. The -functional languages available as output are currently OCaml, Haskell +functional languages available as output are currently |OCaml|, Haskell and Scheme. In the following, "ML" will be used (abusively) to refer to any of the three. @@ -37,11 +37,11 @@ Generating ML Code The next two commands are meant to be used for rapid preview of extraction. They both display extracted term(s) inside |Coq|. -.. cmd:: Extraction @qualid. +.. cmd:: Extraction @qualid Extraction of the mentioned object in the |Coq| toplevel. -.. cmd:: Recursive Extraction @qualid ... @qualid. +.. cmd:: Recursive Extraction {+ @qualid } Recursive extraction of all the mentioned objects and all their dependencies in the |Coq| toplevel. @@ -49,7 +49,7 @@ extraction. They both display extracted term(s) inside |Coq|. All the following commands produce real ML files. User can choose to produce one monolithic file or one file per |Coq| library. -.. cmd:: Extraction "@file" @qualid ... @qualid. +.. cmd:: Extraction "@file" {+ @qualid } Recursive extraction of all the mentioned objects and all their dependencies in one monolithic `file`. @@ -57,43 +57,43 @@ produce one monolithic file or one file per |Coq| library. language to fulfill its syntactic conventions, keeping original names as much as possible. -.. cmd:: Extraction Library @ident. +.. cmd:: Extraction Library @ident Extraction of the whole |Coq| library ``ident.v`` to an ML module ``ident.ml``. In case of name clash, identifiers are here renamed using prefixes ``coq_`` or ``Coq_`` to ensure a session-independent renaming. -.. cmd:: Recursive Extraction Library @ident. +.. cmd:: Recursive Extraction Library @ident Extraction of the |Coq| library ``ident.v`` and all other modules ``ident.v`` depends on. -.. cmd:: Separate Extraction @qualid ... @qualid. +.. cmd:: Separate Extraction {+ @qualid } Recursive extraction of all the mentioned objects and all their dependencies, just as ``Extraction "file"``, but instead of producing one monolithic file, this command splits the produced code in separate ML files, one per corresponding Coq ``.v`` file. This command is hence quite similar to - ``Recursive Extraction Library``, except that only the needed + :cmd:`Recursive Extraction Library`, except that only the needed parts of Coq libraries are extracted instead of the whole. The naming convention in case of name clash is the same one as - ``Extraction Library``: identifiers are here renamed using prefixes + :cmd:`Extraction Library`: identifiers are here renamed using prefixes ``coq_`` or ``Coq_``. The following command is meant to help automatic testing of the extraction, see for instance the ``test-suite`` directory in the |Coq| sources. -.. cmd:: Extraction TestCompile @qualid ... @qualid. +.. cmd:: Extraction TestCompile {+ @qualid } All the mentioned objects and all their dependencies are extracted - to a temporary OCaml file, just as in ``Extraction "file"``. Then + to a temporary |OCaml| file, just as in ``Extraction "file"``. Then this temporary file and its signature are compiled with the same - OCaml compiler used to built |Coq|. This command succeeds only - if the extraction and the OCaml compilation succeed. It fails - if the current target language of the extraction is not OCaml. + |OCaml| compiler used to built |Coq|. This command succeeds only + if the extraction and the |OCaml| compilation succeed. It fails + if the current target language of the extraction is not |OCaml|. Extraction Options ------------------- @@ -102,26 +102,26 @@ Setting the target language ~~~~~~~~~~~~~~~~~~~~~~~~~~~ The ability to fix target language is the first and more important -of the extraction options. Default is ``Ocaml``. +of the extraction options. Default is ``OCaml``. -.. cmd:: Extraction Language Ocaml. -.. cmd:: Extraction Language Haskell. -.. cmd:: Extraction Language Scheme. +.. cmd:: Extraction Language OCaml +.. cmd:: Extraction Language Haskell +.. cmd:: Extraction Language Scheme Inlining and optimizations ~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Since OCaml is a strict language, the extracted code has to +Since |OCaml| is a strict language, the extracted code has to be optimized in order to be efficient (for instance, when using induction principles we do not want to compute all the recursive calls but only the needed ones). So the extraction mechanism provides an automatic optimization routine that will be called each time the user -want to generate OCaml programs. The optimizations can be split in two +want to generate |OCaml| programs. The optimizations can be split in two groups: the type-preserving ones (essentially constant inlining and reductions) and the non type-preserving ones (some function abstractions of dummy types are removed when it is deemed safe in order to have more elegant types). Therefore some constants may not appear in the -resulting monolithic OCaml program. In the case of modular extraction, +resulting monolithic |OCaml| program. In the case of modular extraction, even if some inlining is done, the inlined constant are nevertheless printed, to ensure session-independent programs. @@ -131,14 +131,14 @@ order to produce more readable code. The type-preserving optimizations are controlled by the following |Coq| options: -.. opt:: Extraction Optimize. +.. opt:: Extraction Optimize Default is on. This controls all type-preserving optimizations made on the ML terms (mostly reduction of dummy beta/iota redexes, but also simplifications on Cases, etc). Turn this option off if you want a ML term as close as possible to the Coq term. -.. opt:: Extraction Conservative Types. +.. opt:: Extraction Conservative Types Default is off. This controls the non type-preserving optimizations made on ML terms (which try to avoid function abstraction of dummy @@ -146,7 +146,7 @@ The type-preserving optimizations are controlled by the following |Coq| options: implies that ``e':t'`` where ``e'`` and ``t'`` are the extracted code of ``e`` and ``t`` respectively. -.. opt:: Extraction KeepSingleton. +.. opt:: Extraction KeepSingleton Default is off. Normally, when the extraction of an inductive type produces a singleton type (i.e. a type with only one constructor, and @@ -155,7 +155,7 @@ The type-preserving optimizations are controlled by the following |Coq| options: The typical example is ``sig``. This option allows disabling this optimization when one wishes to preserve the inductive structure of types. -.. opt:: Extraction AutoInline. +.. opt:: Extraction AutoInline Default is on. The extraction mechanism inlines the bodies of some defined constants, according to some heuristics @@ -163,22 +163,22 @@ The type-preserving optimizations are controlled by the following |Coq| options: Those heuristics are not always perfect; if you want to disable this feature, turn this option off. -.. cmd:: Extraction Inline @qualid ... @qualid. +.. cmd:: Extraction Inline {+ @qualid } In addition to the automatic inline feature, the constants mentionned by this command will always be inlined during extraction. -.. cmd:: Extraction NoInline @qualid ... @qualid. +.. cmd:: Extraction NoInline {+ @qualid } Conversely, the constants mentionned by this command will never be inlined during extraction. -.. cmd:: Print Extraction Inline. +.. cmd:: Print Extraction Inline Prints the current state of the table recording the custom inlinings declared by the two previous commands. -.. cmd:: Reset Extraction Inline. +.. cmd:: Reset Extraction Inline Empties the table recording the custom inlinings (see the previous commands). @@ -213,7 +213,7 @@ code elimination performed during extraction, in a way which is independent but complementary to the main elimination principles of extraction (logical parts and types). -.. cmd:: Extraction Implicit @qualid [ @ident ... @ident ]. +.. cmd:: Extraction Implicit @qualid [ {+ @ident } ] This experimental command allows declaring some arguments of `qualid` as implicit, i.e. useless in extracted code and hence to @@ -223,11 +223,11 @@ principles of extraction (logical parts and types). by a number indicating its position, starting from 1. When an actual extraction takes place, an error is normally raised if the -``Extraction Implicit`` declarations cannot be honored, that is +:cmd:`Extraction Implicit` declarations cannot be honored, that is if any of the implicited variables still occurs in the final code. This behavior can be relaxed via the following option: -.. opt:: Extraction SafeImplicits. +.. opt:: Extraction SafeImplicits Default is on. When this option is off, a warning is emitted instead of an error if some implicited variables still occur in the @@ -253,21 +253,20 @@ a closed term, and of course the system cannot guess the program which realizes an axiom. Therefore, it is possible to tell the system what ML term corresponds to a given axiom. -.. cmd:: Extract Constant @qualid => @string. +.. cmd:: Extract Constant @qualid => @string Give an ML extraction for the given constant. The `string` may be an identifier or a quoted string. -.. cmd:: Extract Inlined Constant @qualid => @string. +.. cmd:: Extract Inlined Constant @qualid => @string Same as the previous one, except that the given ML terms will be inlined everywhere instead of being declared via a ``let``. .. note:: - - This command is sugar for an ``Extract Constant`` followed - by a ``Extraction Inline``. Hence a ``Reset Extraction Inline`` - will have an effect on the realized and inlined axiom. + This command is sugar for an :cmd:`Extract Constant` followed + by a :cmd:`Extraction Inline`. Hence a :cmd:`Reset Extraction Inline` + will have an effect on the realized and inlined axiom. .. caution:: It is the responsibility of the user to ensure that the ML terms given to realize the axioms do have the expected types. In @@ -286,7 +285,7 @@ Notice that in the case of type scheme axiom (i.e. whose type is an arity, that is a sequence of product finished by a sort), then some type variables have to be given (as quoted strings). The syntax is then: -.. cmdv:: Extract Constant @qualid @string ... @string => @string. +.. cmdv:: Extract Constant @qualid @string ... @string => @string The number of type variables is checked by the system. For example: @@ -295,7 +294,7 @@ The number of type variables is checked by the system. For example: Axiom Y : Set -> Set -> Set. Extract Constant Y "'a" "'b" => " 'a * 'b ". -Realizing an axiom via ``Extract Constant`` is only useful in the +Realizing an axiom via :cmd:`Extract Constant` is only useful in the case of an informative axiom (of sort ``Type`` or ``Set``). A logical axiom have no computational content and hence will not appears in extracted terms. But a warning is nonetheless issued if extraction encounters a @@ -315,7 +314,7 @@ The system also provides a mechanism to specify ML terms for inductive types and constructors. For instance, the user may want to use the ML native boolean type instead of |Coq| one. The syntax is the following: -.. cmd:: Extract Inductive @qualid => @string [ @string ... @string ]. +.. cmd:: Extract Inductive @qualid => @string [ {+ @string } ] Give an ML extraction for the given inductive type. You must specify extractions for the type itself (first `string`) and all its @@ -323,7 +322,7 @@ native boolean type instead of |Coq| one. The syntax is the following: the ML extraction must be an ML inductive datatype, and the native pattern-matching of the language will be used. -.. cmdv:: Extract Inductive @qualid => @string [ @string ... @string ] @string. +.. cmdv:: Extract Inductive @qualid => @string [ {+ @string } ] @string Same as before, with a final extra `string` that indicates how to perform pattern-matching over this inductive type. In this form, @@ -336,10 +335,10 @@ native boolean type instead of |Coq| one. The syntax is the following: argument is considered to have one unit argument, in order to block early evaluation of the branch: ``| O => bar`` leads to the functional form ``(fun () -> bar)``. For instance, when extracting ``nat`` - into OCaml ``int``, the code to provide has type: + into |OCaml| ``int``, the code to provide has type: ``(unit->'a)->(int->'a)->int->'a``. -.. caution:: As for ``Extract Constant``, this command should be used with care: +.. caution:: As for :cmd:`Extract Constant`, this command should be used with care: * The ML code provided by the user is currently **not** checked at all by extraction, even for syntax errors. @@ -347,17 +346,17 @@ native boolean type instead of |Coq| one. The syntax is the following: * Extracting an inductive type to a pre-existing ML inductive type is quite sound. But extracting to a general type (by providing an ad-hoc pattern-matching) will often **not** be fully rigorously - correct. For instance, when extracting ``nat`` to OCaml ``int``, + correct. For instance, when extracting ``nat`` to |OCaml| ``int``, it is theoretically possible to build ``nat`` values that are - larger than OCaml ``max_int``. It is the user's responsibility to + larger than |OCaml| ``max_int``. It is the user's responsibility to be sure that no overflow or other bad events occur in practice. * Translating an inductive type to an arbitrary ML type does **not** magically improve the asymptotic complexity of functions, even if the ML type is an efficient representation. For instance, when extracting - ``nat`` to OCaml ``int``, the function ``Nat.mul`` stays quadratic. + ``nat`` to |OCaml| ``int``, the function ``Nat.mul`` stays quadratic. It might be interesting to associate this translation with - some specific ``Extract Constant`` when primitive counterparts exist. + some specific :cmd:`Extract Constant` when primitive counterparts exist. Typical examples are the following: @@ -369,9 +368,9 @@ Typical examples are the following: .. note:: - When extracting to Ocaml, if an inductive constructor or type has arity 2 and + When extracting to |OCaml|, if an inductive constructor or type has arity 2 and the corresponding string is enclosed by parentheses, and the string meets - Ocaml's lexical criteria for an infix symbol, then the rest of the string is + |OCaml|'s lexical criteria for an infix symbol, then the rest of the string is used as infix constructor or type. .. coqtop:: in @@ -380,7 +379,7 @@ Typical examples are the following: Extract Inductive prod => "(*)" [ "(,)" ]. As an example of translation to a non-inductive datatype, let's turn -``nat`` into OCaml ``int`` (see caveat above): +``nat`` into |OCaml| ``int`` (see caveat above): .. coqtop:: in @@ -389,28 +388,28 @@ As an example of translation to a non-inductive datatype, let's turn Avoiding conflicts with existing filenames ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When using ``Extraction Library``, the names of the extracted files +When using :cmd:`Extraction Library`, the names of the extracted files directly depends from the names of the |Coq| files. It may happen that these filenames are in conflict with already existing files, either in the standard library of the target language or in other code that is meant to be linked with the extracted code. -For instance the module ``List`` exists both in |Coq| and in OCaml. +For instance the module ``List`` exists both in |Coq| and in |OCaml|. It is possible to instruct the extraction not to use particular filenames. -.. cmd:: Extraction Blacklist @ident ... @ident. +.. cmd:: Extraction Blacklist {+ @ident } Instruct the extraction to avoid using these names as filenames for extracted code. -.. cmd:: Print Extraction Blacklist. +.. cmd:: Print Extraction Blacklist Show the current list of filenames the extraction should avoid. -.. cmd:: Reset Extraction Blacklist. +.. cmd:: Reset Extraction Blacklist Allow the extraction to use any filename. -For OCaml, a typical use of these commands is +For |OCaml|, a typical use of these commands is ``Extraction Blacklist String List``. Differences between |Coq| and ML type systems @@ -418,7 +417,7 @@ Differences between |Coq| and ML type systems Due to differences between |Coq| and ML type systems, some extracted programs are not directly typable in ML. -We now solve this problem (at least in OCaml) by adding +We now solve this problem (at least in |OCaml|) by adding when needed some unsafe casting ``Obj.magic``, which give a generic type ``'a`` to any term. @@ -432,7 +431,7 @@ function: Definition dp {A B:Type}(x:A)(y:B)(f:forall C:Type, C->C) := (f A x, f B y). -In Ocaml, for instance, the direct extracted term would be:: +In |OCaml|, for instance, the direct extracted term would be:: let dp x y f = Pair((f () x),(f () y)) @@ -455,12 +454,12 @@ of a constructor; for example: Inductive anything : Type := dummy : forall A:Set, A -> anything. which corresponds to the definition of an ML dynamic type. -In OCaml, we must cast any argument of the constructor dummy +In |OCaml|, we must cast any argument of the constructor dummy (no GADT are produced yet by the extraction). Even with those unsafe castings, you should never get error like ``segmentation fault``. In fact even if your program may seem -ill-typed to the Ocaml type-checker, it can't go wrong : it comes +ill-typed to the |OCaml| type-checker, it can't go wrong : it comes from a Coq well-typed terms, so for example inductive types will always have the correct number of arguments, etc. Of course, when launching manually some extracted function, you should apply it to arguments @@ -470,14 +469,14 @@ More details about the correctness of the extracted programs can be found in :cite:`Let02`. We have to say, though, that in most "realistic" programs, these problems do not -occur. For example all the programs of Coq library are accepted by the OCaml +occur. For example all the programs of Coq library are accepted by the |OCaml| type-checker without any ``Obj.magic`` (see examples below). Some examples ------------- We present here two examples of extractions, taken from the -|Coq| Standard Library. We choose OCaml as target language, +|Coq| Standard Library. We choose |OCaml| as target language, but all can be done in the other dialects with slight modifications. We then indicate where to find other examples and tests of extraction. @@ -493,7 +492,7 @@ This module contains a theorem ``eucl_dev``, whose type is:: where ``diveucl`` is a type for the pair of the quotient and the modulo, plus some logical assertions that disappear during extraction. -We can now extract this program to OCaml: +We can now extract this program to |OCaml|: .. coqtop:: none @@ -513,7 +512,7 @@ You can then copy-paste the output to a file ``euclid.ml`` or let Extraction "euclid" eucl_dev. -Let us play the resulting program (in an OCaml toplevel):: +Let us play the resulting program (in an |OCaml| toplevel):: #use "euclid.ml";; type nat = O | S of nat @@ -527,7 +526,7 @@ Let us play the resulting program (in an OCaml toplevel):: # eucl_dev (S (S O)) (S (S (S (S (S O)))));; - : diveucl = Divex (S (S O), S O) -It is easier to test on OCaml integers:: +It is easier to test on |OCaml| integers:: # let rec nat_of_int = function 0 -> O | n -> S (nat_of_int (n-1));; val nat_of_int : int -> nat = <fun> diff --git a/doc/sphinx/addendum/generalized-rewriting.rst b/doc/sphinx/addendum/generalized-rewriting.rst index da9e97e6f..e10e16c10 100644 --- a/doc/sphinx/addendum/generalized-rewriting.rst +++ b/doc/sphinx/addendum/generalized-rewriting.rst @@ -1,14 +1,12 @@ -.. _generalizedrewriting: - ------------------------ - Generalized rewriting ------------------------ +.. include:: ../preamble.rst +.. include:: ../replaces.rst -:Author: Matthieu Sozeau +.. _generalizedrewriting: Generalized rewriting ===================== +:Author: Matthieu Sozeau This chapter presents the extension of several equality related tactics to work over user-defined structures (called setoids) that are @@ -181,7 +179,7 @@ A parametric relation :g:`Aeq: forall (y1 : β1 ... ym : βm )`, :g:`relation (A t1 ... tn)` over :g:`(A : αi -> ... αn -> Type)` can be declared with the following command: -.. cmd:: Add Parametric Relation (x1 : T1) ... (xn : Tk) : (A t1 ... tn) (Aeq t′1 ... t′m ) {? reflexivity proved by refl} {? symmetry proved by sym} {? transitivity proved by trans} as @ident. +.. cmd:: Add Parametric Relation (x1 : T1) ... (xn : Tk) : (A t1 ... tn) (Aeq t′1 ... t′m ) {? reflexivity proved by refl} {? symmetry proved by sym} {? transitivity proved by trans} as @ident after having required the ``Setoid`` module with the ``Require Setoid`` command. @@ -220,15 +218,15 @@ For Leibniz equality, we may declare: [reflexivity proved by @refl_equal A] ... -Some tactics (``reflexivity``, ``symmetry``, ``transitivity``) work only on +Some tactics (:tacn:`reflexivity`, :tacn:`symmetry`, :tacn:`transitivity`) work only on relations that respect the expected properties. The remaining tactics -(``replace``, ``rewrite`` and derived tactics such as ``autorewrite``) do not +(`replace`, :tacn:`rewrite` and derived tactics such as :tacn:`autorewrite`) do not require any properties over the relation. However, they are able to replace terms with related ones only in contexts that are syntactic compositions of parametric morphism instances declared with the following command. -.. cmd:: Add Parametric Morphism (x1 : T1 ) ... (xk : Tk ) : (f t1 ... tn ) with signature sig as @ident. +.. cmd:: Add Parametric Morphism (x1 : T1 ) ... (xk : Tk ) : (f t1 ... tn ) with signature sig as @ident The command declares ``f`` as a parametric morphism of signature ``sig``. The identifier ``id`` gives a unique name to the morphism and it is used as @@ -319,7 +317,7 @@ instance mechanism. The behavior on section close is to generalize the instances by the variables of the section (and possibly hypotheses used in the proofs of instance declarations) but not to export them in the rest of the development for proof search. One can use the -``Existing Instance`` command to do so outside the section, using the name of the +cmd:`Existing Instance` command to do so outside the section, using the name of the declared morphism suffixed by ``_Morphism``, or use the ``Global`` modifier for the corresponding class instance declaration (see :ref:`First Class Setoids and Morphisms <first-class-setoids-and-morphisms>`) at @@ -429,7 +427,7 @@ equality over ordered lists) ``set_eq ==> set_eq ==> set_eq`` ``multiset_eq ==> multiset_eq ==> multiset_eq`` (``multiset_eq`` being the equality over unordered lists). -To declare multiple signatures for a morphism, repeat the ``Add Morphism`` +To declare multiple signatures for a morphism, repeat the :cmd:`Add Morphism` command. When morphisms have multiple signatures it can be the case that a @@ -479,7 +477,7 @@ The declaration itself amounts to the definition of an object of the record type ``Coq.Classes.RelationClasses.Equivalence`` and a hint added to the ``typeclass_instances`` hint database. Morphism declarations are also instances of a type class defined in ``Classes.Morphisms``. See the -documentation on type classes :ref:`TODO-chapter-20-type-classes` +documentation on type classes :ref:`typeclasses` and the theories files in Classes for further explanations. One can inform the rewrite tactic about morphisms and relations just @@ -532,21 +530,26 @@ Tactics enabled on user provided relations The following tactics, all prefixed by ``setoid_``, deal with arbitrary registered relations and morphisms. Moreover, all the corresponding -unprefixed tactics (i.e. ``reflexivity``, ``symmetry``, ``transitivity``, -``replace``, ``rewrite``) have been extended to fall back to their prefixed +unprefixed tactics (i.e. :tacn:`reflexivity`, :tacn:`symmetry`, :tacn:`transitivity`, +:tacn:`replace`, :tacn:`rewrite`) have been extended to fall back to their prefixed counterparts when the relation involved is not Leibniz equality. Notice, however, that using the prefixed tactics it is possible to pass additional arguments such as ``using relation``. .. tacv:: setoid_reflexivity + :name: setoid_reflexivity .. tacv:: setoid_symmetry [in @ident] + :name: setoid_symmetry .. tacv:: setoid_transitivity + :name: setoid_transitivity .. tacv:: setoid_rewrite [@orientation] @term [at @occs] [in @ident] + :name: setoid_rewrite .. tacv:: setoid_replace @term with @term [in @ident] [using relation @term] [by @tactic] + :name: setoid_replace The ``using relation`` arguments cannot be passed to the unprefixed form. @@ -561,21 +564,23 @@ on a given type. Every derived tactic that is based on the unprefixed forms of the tactics considered above will also work up to user defined relations. -For instance, it is possible to register hints for ``autorewrite`` that +For instance, it is possible to register hints for :tacn:`autorewrite` that are not proof of Leibniz equalities. In particular it is possible to -exploit ``autorewrite`` to simulate normalization in a term rewriting +exploit :tacn:`autorewrite` to simulate normalization in a term rewriting system up to user defined equalities. Printing relations and morphisms ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The ``Print Instances`` command can be used to show the list of currently +.. cmd:: Print Instances + +This command can be used to show the list of currently registered ``Reflexive`` (using ``Print Instances Reflexive``), ``Symmetric`` or ``Transitive`` relations, Equivalences, PreOrders, PERs, and Morphisms (implemented as ``Proper`` instances). When the rewriting tactics refuse to replace a term in a context because the latter is not a composition -of morphisms, the ``Print Instances`` commands can be useful to understand +of morphisms, the :cmd:`Print Instances` command can be useful to understand what additional morphisms should be registered. @@ -585,7 +590,7 @@ Deprecated syntax and backward incompatibilities Due to backward compatibility reasons, the following syntax for the declaration of setoids and morphisms is also accepted. -.. tacv:: Add Setoid @A @Aeq @ST as @ident +.. cmd:: Add Setoid @A @Aeq @ST as @ident where ``Aeq`` is a congruence relation without parameters, ``A`` is its carrier and ``ST`` is an object of type (``Setoid_Theory A Aeq``) (i.e. a record @@ -593,7 +598,8 @@ packing together the reflexivity, symmetry and transitivity lemmas). Notice that the syntax is not completely backward compatible since the identifier was not required. -.. cmd:: Add Morphism f : @ident. +.. cmd:: Add Morphism f : @ident + :name: Add Morphism The latter command also is restricted to the declaration of morphisms without parameters. It is not fully backward compatible since the @@ -607,11 +613,11 @@ Notice that several limitations of the old implementation have been lifted. In particular, it is now possible to declare several relations with the same carrier and several signatures for the same morphism. Moreover, it is now also possible to declare several morphisms having -the same signature. Finally, the replace and rewrite tactics can be +the same signature. Finally, the :tacn:`replace` and :tacn:`rewrite` tactics can be used to replace terms in contexts that were refused by the old implementation. As discussed in the next section, the semantics of the -new ``setoid_rewrite`` command differs slightly from the old one and -``rewrite``. +new :tacn:`setoid_rewrite` tactic differs slightly from the old one and +:tacn:`rewrite`. Extensions @@ -621,8 +627,9 @@ Extensions Rewriting under binders ~~~~~~~~~~~~~~~~~~~~~~~ -warning:: Due to compatibility issues, this feature is enabled only -when calling the ``setoid_rewrite`` tactics directly and not ``rewrite``. +.. warning:: + Due to compatibility issues, this feature is enabled only + when calling the :tacn:`setoid_rewrite` tactic directly and not :tacn:`rewrite`. To be able to rewrite under binding constructs, one must declare morphisms with respect to pointwise (setoid) equivalence of functions. @@ -669,12 +676,12 @@ where ``list_equiv`` implements an equivalence on lists parameterized by an equivalence on the elements. Note that when one does rewriting with a lemma under a binder using -``setoid_rewrite``, the application of the lemma may capture the bound +:tacn:`setoid_rewrite`, the application of the lemma may capture the bound variable, as the semantics are different from rewrite where the lemma -is first matched on the whole term. With the new ``setoid_rewrite``, +is first matched on the whole term. With the new :tacn:`setoid_rewrite`, matching is done on each subterm separately and in its local environment, and all matches are rewritten *simultaneously* by -default. The semantics of the previous ``setoid_rewrite`` implementation +default. The semantics of the previous :tacn:`setoid_rewrite` implementation can almost be recovered using the ``at 1`` modifier. @@ -707,22 +714,20 @@ defined constants as transparent by default. This may slow down the resolution due to a lot of unifications (all the declared ``Proper`` instances are tried at each node of the search tree). To speed it up, declare your constant as rigid for proof search using the command -``Typeclasses Opaque`` (see :ref:`TODO-20.6.7-typeclasses-transparency`). - +:cmd:`Typeclasses Opaque`. Strategies for rewriting ------------------------ - Definitions ~~~~~~~~~~~ -The generalized rewriting tactic is based on a set of strategies that -can be combined to obtain custom rewriting procedures. Its set of -strategies is based on Elan’s rewriting strategies :ref:`TODO-102-biblio`. Rewriting +The generalized rewriting tactic is based on a set of strategies that can be +combined to obtain custom rewriting procedures. Its set of strategies is based +on Elan’s rewriting strategies :cite:`Luttik97specificationof`. Rewriting strategies are applied using the tactic ``rewrite_strat s`` where ``s`` is a -strategy expression. Strategies are defined inductively as described -by the following grammar: +strategy expression. Strategies are defined inductively as described by the +following grammar: .. productionlist:: rewriting s, t, u : `strategy` @@ -808,11 +813,11 @@ strategy. Their counterparts ``bottomup`` and ``topdown`` perform as many rewritings as possible, starting from the bottom or the top of the term. -Hint databases created for ``autorewrite`` can also be used -by ``rewrite_strat`` using the ``hints`` strategy that applies any of the +Hint databases created for :tacn:`autorewrite` can also be used +by :tacn:`rewrite_strat` using the ``hints`` strategy that applies any of the lemmas at the current subterm. The ``terms`` strategy takes the lemma names directly as arguments. The ``eval`` strategy expects a reduction -expression (see :ref:`TODO-8.7-performing-computations`) and succeeds +expression (see :ref:`performingcomputations`) and succeeds if it reduces the subterm under consideration. The ``fold`` strategy takes a term ``c`` and tries to *unify* it to the current subterm, converting it to ``c`` on success, it is stronger than the tactic ``fold``. @@ -822,7 +827,8 @@ Usage ~~~~~ -.. tacv:: rewrite_strat @s [in @ident] +.. tacn:: rewrite_strat @s [in @ident] + :name: rewrite_strat Rewrite using the strategy s in hypothesis ident or the conclusion. diff --git a/doc/sphinx/addendum/implicit-coercions.rst b/doc/sphinx/addendum/implicit-coercions.rst index f5ca5be44..09faa0676 100644 --- a/doc/sphinx/addendum/implicit-coercions.rst +++ b/doc/sphinx/addendum/implicit-coercions.rst @@ -1,7 +1,7 @@ -.. _implicitcoercions: - .. include:: ../replaces.rst +.. _implicitcoercions: + Implicit Coercions ==================== @@ -65,7 +65,7 @@ conditions holds: We then write :g:`f : C >-> D`. The restriction on the type of coercions is called *the uniform inheritance condition*. -.. note:: The abstract classe ``Sortclass`` can be used as a source class, but +.. note:: The abstract class ``Sortclass`` can be used as a source class, but the abstract class ``Funclass`` cannot. To coerce an object :g:`t:C t₁..tₙ` of ``C`` towards ``D``, we have to @@ -124,49 +124,49 @@ term consists of the successive application of its coercions. Declaration of Coercions ------------------------- -.. cmd:: Coercion @qualid : @class >-> @class. +.. cmd:: Coercion @qualid : @class >-> @class Declares the construction denoted by `qualid` as a coercion between the two given classes. - .. exn:: @qualid not declared - .. exn:: @qualid is already a coercion - .. exn:: Funclass cannot be a source class - .. exn:: @qualid is not a function - .. exn:: Cannot find the source class of @qualid - .. exn:: Cannot recognize @class as a source class of @qualid - .. exn:: @qualid does not respect the uniform inheritance condition + .. exn:: @qualid not declared. + .. exn:: @qualid is already a coercion. + .. exn:: Funclass cannot be a source class. + .. exn:: @qualid is not a function. + .. exn:: Cannot find the source class of @qualid. + .. exn:: Cannot recognize @class as a source class of @qualid. + .. exn:: @qualid does not respect the uniform inheritance condition. .. exn:: Found target class ... instead of ... - .. warn:: Ambigous path: + .. warn:: Ambiguous path. - When the coercion `qualid` is added to the inheritance graph, non - valid coercion paths are ignored; they are signaled by a warning - displaying these paths of the form :g:`[f₁;..;fₙ] : C >-> D`. + When the coercion :token:`qualid` is added to the inheritance graph, non + valid coercion paths are ignored; they are signaled by a warning + displaying these paths of the form :g:`[f₁;..;fₙ] : C >-> D`. - .. cmdv:: Local Coercion @qualid : @class >-> @class. + .. cmdv:: Local Coercion @qualid : @class >-> @class - Declares the construction denoted by `qualid` as a coercion local to - the current section. + Declares the construction denoted by `qualid` as a coercion local to + the current section. - .. cmdv:: Coercion @ident := @term. + .. cmdv:: Coercion @ident := @term - This defines `ident` just like ``Definition`` `ident` ``:=`` `term`, - and then declares `ident` as a coercion between it source and its target. + This defines `ident` just like ``Definition`` `ident` ``:=`` `term`, + and then declares `ident` as a coercion between it source and its target. - .. cmdv:: Coercion @ident := @term : @type. + .. cmdv:: Coercion @ident := @term : @type - This defines `ident` just like ``Definition`` `ident` : `type` ``:=`` `term`, - and then declares `ident` as a coercion between it source and its target. + This defines `ident` just like ``Definition`` `ident` : `type` ``:=`` `term`, + and then declares `ident` as a coercion between it source and its target. - .. cmdv:: Local Coercion @ident := @term. + .. cmdv:: Local Coercion @ident := @term - This defines `ident` just like ``Let`` `ident` ``:=`` `term`, - and then declares `ident` as a coercion between it source and its target. + This defines `ident` just like ``Let`` `ident` ``:=`` `term`, + and then declares `ident` as a coercion between it source and its target. Assumptions can be declared as coercions at declaration time. This extends the grammar of assumptions from -Figure :ref:`TODO-1.3-sentences-syntax` as follows: +Figure :ref:`vernacular` as follows: .. FIXME: @@ -186,7 +186,7 @@ assumptions are declared as coercions. Similarly, constructors of inductive types can be declared as coercions at definition time of the inductive type. This extends and modifies the -grammar of inductive types from Figure :ref:`TODO-1.3-sentences-syntax` as follows: +grammar of inductive types from Figure :ref:`vernacular` as follows: .. FIXME: @@ -202,7 +202,7 @@ grammar of inductive types from Figure :ref:`TODO-1.3-sentences-syntax` as follo Especially, if the extra ``>`` is present in a constructor declaration, this constructor is declared as a coercion. -.. cmd:: Identity Coercion @ident : @class >-> @class. +.. cmd:: Identity Coercion @ident : @class >-> @class If ``C`` is the source `class` and ``D`` the destination, we check that ``C`` is a constant with a body of the form @@ -211,13 +211,14 @@ declaration, this constructor is declared as a coercion. function with type :g:`forall (x₁:T₁)..(xₙ:Tₙ)(y:C x₁..xₙ),D t₁..tₘ`, and we declare it as an identity coercion between ``C`` and ``D``. - .. exn:: @class must be a transparent constant + .. exn:: @class must be a transparent constant. - .. cmdv:: Local Identity Coercion @ident : @ident >-> @ident. + .. cmdv:: Local Identity Coercion @ident : @ident >-> @ident Idem but locally to the current section. - .. cmdv:: SubClass @ident := @type. + .. cmdv:: SubClass @ident := @type + :name: SubClass If `type` is a class `ident'` applied to some arguments then `ident` is defined and an identity coercion of name @@ -228,7 +229,7 @@ declaration, this constructor is declared as a coercion. ``Identity Coercion`` `Id_ident_ident'` : `ident` ``>->`` `ident'`. - .. cmdv:: Local SubClass @ident := @type. + .. cmdv:: Local SubClass @ident := @type Same as before but locally to the current section. @@ -236,67 +237,67 @@ declaration, this constructor is declared as a coercion. Displaying Available Coercions ------------------------------- -.. cmd:: Print Classes. +.. cmd:: Print Classes Print the list of declared classes in the current context. -.. cmd:: Print Coercions. +.. cmd:: Print Coercions Print the list of declared coercions in the current context. -.. cmd:: Print Graph. +.. cmd:: Print Graph Print the list of valid coercion paths in the current context. -.. cmd:: Print Coercion Paths @class @class. +.. cmd:: Print Coercion Paths @class @class Print the list of valid coercion paths between the two given classes. Activating the Printing of Coercions ------------------------------------- -.. cmd:: Set Printing Coercions. +.. opt:: Printing Coercions + + When on, this option forces all the coercions to be printed. + By default, coercions are not printed. + +.. cmd:: Add Printing Coercion @qualid - This command forces all the coercions to be printed. - Conversely, to skip the printing of coercions, use - ``Unset Printing Coercions``. By default, coercions are not printed. + This command forces coercion denoted by :n:`@qualid` to be printed. + By default, a coercion is never printed. -.. cmd:: Add Printing Coercion @qualid. +.. cmd:: Remove Printing Coercion @qualid - This command forces coercion denoted by `qualid` to be printed. - To skip the printing of coercion `qualid`, use - ``Remove Printing Coercion`` `qualid`. By default, a coercion is never printed. + Use this command, to skip the printing of coercion :n:`@qualid`. +.. _coercions-classes-as-records: Classes as Records ------------------ -We allow the definition of *Structures with Inheritance* (or -classes as records) by extending the existing ``Record`` macro -(see Section :ref:`TODO-2.1-Record`). Its new syntax is: +We allow the definition of *Structures with Inheritance* (or classes as records) +by extending the existing :cmd:`Record` macro. Its new syntax is: -.. cmd:: Record {? >} @ident {? @binders} : @sort := {? @ident} { {+; @ident :{? >} @term } }. +.. cmdv:: Record {? >} @ident {? @binders} : @sort := {? @ident} { {+; @ident :{? >} @term } } - The first identifier `ident` is the name of the defined record and - `sort` is its type. The optional identifier after ``:=`` is the name - of the constuctor (it will be ``Build_``\ `ident` if not given). - The other identifiers are the names of the fields, and the `term` - are their respective types. If ``:>`` is used instead of ``:`` in - the declaration of a field, then the name of this field is automatically - declared as a coercion from the record name to the class of this - field type. Remark that the fields always verify the uniform - inheritance condition. If the optional ``>`` is given before the - record name, then the constructor name is automatically declared as - a coercion from the class of the last field type to the record name - (this may fail if the uniform inheritance condition is not - satisfied). + The first identifier `ident` is the name of the defined record and + `sort` is its type. The optional identifier after ``:=`` is the name + of the constuctor (it will be ``Build_``\ `ident` if not given). + The other identifiers are the names of the fields, and the `term` + are their respective types. If ``:>`` is used instead of ``:`` in + the declaration of a field, then the name of this field is automatically + declared as a coercion from the record name to the class of this + field type. Remark that the fields always verify the uniform + inheritance condition. If the optional ``>`` is given before the + record name, then the constructor name is automatically declared as + a coercion from the class of the last field type to the record name + (this may fail if the uniform inheritance condition is not + satisfied). -.. note:: +.. cmdv:: Structure {? >} @ident {? @binders} : @sort := {? @ident} { {+; @ident :{? >} @term } } + :name: Structure - The keyword ``Structure`` is a synonym of ``Record``. - -.. - FIXME: \comindex{Structure} + This is a synonym of :cmd:`Record`. Coercions and Sections @@ -312,20 +313,17 @@ coercions which do not verify the uniform inheritance condition any longer are also forgotten. Coercions and Modules ---------------------= - -From |Coq| version 8.3, the coercions present in a module are activated -only when the module is explicitly imported. Formerly, the coercions -were activated as soon as the module was required, whatever it was -imported or not. - -To recover the behavior of the versions of |Coq| prior to 8.3, use the -following command: +--------------------- -.. cmd:: Set Automatic Coercions Import. +.. opt:: Automatic Coercions Import -To cancel the effect of the option, use instead ``Unset Automatic Coercions Import``. + Since |Coq| version 8.3, the coercions present in a module are activated + only when the module is explicitly imported. Formerly, the coercions + were activated as soon as the module was required, whatever it was + imported or not. + This option makes it possible to recover the behavior of the versions of + |Coq| prior to 8.3. Examples -------- diff --git a/doc/sphinx/addendum/micromega.rst b/doc/sphinx/addendum/micromega.rst index e850587c8..0e9c23b9b 100644 --- a/doc/sphinx/addendum/micromega.rst +++ b/doc/sphinx/addendum/micromega.rst @@ -13,20 +13,19 @@ tactics for solving arithmetic goals over :math:`\mathbb{Z}`, :math:`\mathbb{Q}` It also possible to get the tactics for integers by a ``Require Import Lia``, rationals ``Require Import Lqa`` and reals ``Require Import Lra``. -+ ``lia`` is a decision procedure for linear integer arithmetic (see Section :ref:`lia <lia>`); -+ ``nia`` is an incomplete proof procedure for integer non-linear - arithmetic (see Section :ref:`nia <nia>`); -+ ``lra`` is a decision procedure for linear (real or rational) arithmetic - (see Section :ref:`lra <lra>`); -+ ``nra`` is an incomplete proof procedure for non-linear (real or - rational) arithmetic (see Section :ref:`nra <nra>`); -+ ``psatz D n`` where ``D`` is :math:`\mathbb{Z}` or :math:`\mathbb{Q}` or :math:`\mathbb{R}`, and ++ :tacn:`lia` is a decision procedure for linear integer arithmetic; ++ :tacn:`nia` is an incomplete proof procedure for integer non-linear + arithmetic; ++ :tacn:`lra` is a decision procedure for linear (real or rational) arithmetic; ++ :tacn:`nra` is an incomplete proof procedure for non-linear (real or + rational) arithmetic; ++ :tacn:`psatz` ``D n`` where ``D`` is :math:`\mathbb{Z}` or :math:`\mathbb{Q}` or :math:`\mathbb{R}`, and ``n`` is an optional integer limiting the proof search depth is an incomplete proof procedure for non-linear arithmetic. It is based on John Harrison’s HOL Light driver to the external prover `csdp` [#]_. Note that the `csdp` driver is generating a *proof cache* which makes it possible to rerun scripts - even without `csdp` (see Section :ref:`psatz <psatz>`). + even without `csdp`. The tactics solve propositional formulas parameterized by atomic arithmetic expressions interpreted over a domain :math:`D` ∈ {ℤ, ℚ, ℝ}. @@ -91,12 +90,13 @@ For each conjunct :math:`C_i`, the tactic calls a oracle which searches for expression* that is normalized by the ring tactic (see :ref:`theringandfieldtacticfamilies`) and checked to be :math:`-1`. -.. _lra: - `lra`: a decision procedure for linear real and rational arithmetic ------------------------------------------------------------------- -The `lra` tactic is searching for *linear* refutations using Fourier +.. tacn:: lra + :name: lra + +This tactic is searching for *linear* refutations using Fourier elimination [#]_. As a result, this tactic explores a subset of the *Cone* defined as @@ -107,16 +107,17 @@ The deductive power of `lra` is the combined deductive power of tactic *e.g.*, :math:`x = 10 * x / 10` is solved by `lra`. -.. _lia: - `lia`: a tactic for linear integer arithmetic --------------------------------------------- -The tactic lia offers an alternative to the omega and romega tactic -(see :ref:`omega`). Roughly speaking, the deductive power of lia is -the combined deductive power of `ring_simplify` and `omega`. However, it -solves linear goals that `omega` and `romega` do not solve, such as the -following so-called *omega nightmare* :cite:`TheOmegaPaper`. +.. tacn:: lia + :name: lia + +This tactic offers an alternative to the :tacn:`omega` and :tacn:`romega` +tactics. Roughly speaking, the deductive power of lia is the combined deductive +power of :tacn:`ring_simplify` and :tacn:`omega`. However, it solves linear +goals that :tacn:`omega` and :tacn:`romega` do not solve, such as the following +so-called *omega nightmare* :cite:`TheOmegaPaper`. .. coqtop:: in @@ -124,8 +125,8 @@ following so-called *omega nightmare* :cite:`TheOmegaPaper`. 27 <= 11 * x + 13 * y <= 45 -> -10 <= 7 * x - 9 * y <= 4 -> False. -The estimation of the relative efficiency of `lia` *vs* `omega` and `romega` -is under evaluation. +The estimation of the relative efficiency of :tacn:`lia` *vs* :tacn:`omega` and +:tacn:`romega` is under evaluation. High level view of `lia` ~~~~~~~~~~~~~~~~~~~~~~~~ @@ -149,9 +150,10 @@ are a way to take into account the discreteness of :math:`\mathbb{Z}` by roundin .. _ceil_thm: -**Theorem**. Let :math:`p` be an integer and :math:`c` a rational constant. Then +.. thm:: Bound on the ceiling function - :math:`p \ge c \rightarrow p \ge \lceil{c}\rceil` + Let :math:`p` be an integer and :math:`c` a rational constant. Then + :math:`p \ge c \rightarrow p \ge \lceil{c}\rceil`. For instance, from 2 x = 1 we can deduce @@ -182,12 +184,13 @@ Our current oracle tries to find an expression :math:`e` with a small range with an equation :math:`e = i` for :math:`i \in [c_1,c_2]` and recursively search for a proof. -.. _nra: - `nra`: a proof procedure for non-linear arithmetic -------------------------------------------------- -The `nra` tactic is an *experimental* proof procedure for non-linear +.. tacn:: nra + :name: nra + +This tactic is an *experimental* proof procedure for non-linear arithmetic. The tactic performs a limited amount of non-linear reasoning before running the linear prover of `lra`. This pre-processing does the following: @@ -202,21 +205,23 @@ does the following: After this pre-processing, the linear prover of `lra` searches for a proof by abstracting monomials by variables. -.. _nia: - `nia`: a proof procedure for non-linear integer arithmetic ---------------------------------------------------------- -The `nia` tactic is a proof procedure for non-linear integer arithmetic. +.. tacn:: nia + :name: nia + +This tactic is a proof procedure for non-linear integer arithmetic. It performs a pre-processing similar to `nra`. The obtained goal is solved using the linear integer prover `lia`. -.. _psatz: - `psatz`: a proof procedure for non-linear arithmetic ---------------------------------------------------- -The `psatz` tactic explores the :math:`\mathit{Cone}` by increasing degrees – hence the +.. tacn:: psatz + :name: psatz + +This tactic explores the :math:`\mathit{Cone}` by increasing degrees – hence the depth parameter :math:`n`. In theory, such a proof search is complete – if the goal is provable the search eventually stops. Unfortunately, the external oracle is using numeric (approximate) optimization techniques diff --git a/doc/sphinx/addendum/miscellaneous-extensions.rst b/doc/sphinx/addendum/miscellaneous-extensions.rst index b0343a8f0..b6c35d8fa 100644 --- a/doc/sphinx/addendum/miscellaneous-extensions.rst +++ b/doc/sphinx/addendum/miscellaneous-extensions.rst @@ -3,23 +3,15 @@ .. _miscellaneousextensions: Miscellaneous extensions -======================= - -:Source: https://coq.inria.fr/distrib/current/refman/miscellaneous.html -:Converted by: Paul Steckler - -.. contents:: - :local: - :depth: 1 ----- +======================== Program derivation ------------------ +------------------ |Coq| comes with an extension called ``Derive``, which supports program derivation. Typically in the style of Bird and Meertens or derivations of program refinements. To use the Derive extension it must first be -required with ``Require Coq.Derive.Derive``. When the extension is loaded, +required with ``Require Coq.derive.Derive``. When the extension is loaded, it provides the following command: .. cmd:: Derive @ident SuchThat @term As @ident @@ -28,7 +20,7 @@ The first `ident` can appear in `term`. This command opens a new proof presenting the user with a goal for term in which the name `ident` is bound to an existential variable `?x` (formally, there are other goals standing for the existential variables but they are shelved, as -described in Section :ref:`TODO-8.17.4`). +described in :tacn:`shelve`). When the proof ends two constants are defined: diff --git a/doc/sphinx/addendum/nsatz.rst b/doc/sphinx/addendum/nsatz.rst index ef9b3505d..387d61495 100644 --- a/doc/sphinx/addendum/nsatz.rst +++ b/doc/sphinx/addendum/nsatz.rst @@ -19,7 +19,7 @@ where :math:`P, Q, P₁,Q₁,\ldots,Pₛ, Qₛ` are polynomials and :math:`A` is domain, i.e. a commutative ring with no zero divisor. For example, :math:`A` can be :math:`\mathbb{R}`, :math:`\mathbb{Z}`, or :math:`\mathbb{Q}`. Note that the equality :math:`=` used in these goals can be -any setoid equality (see :ref:`TODO-27.2.2`) , not only Leibnitz equality. +any setoid equality (see :ref:`tactics-enabled-on-user-provided-relations`) , not only Leibnitz equality. It also proves formulas diff --git a/doc/sphinx/addendum/omega.rst b/doc/sphinx/addendum/omega.rst index 20e40c550..80ce01620 100644 --- a/doc/sphinx/addendum/omega.rst +++ b/doc/sphinx/addendum/omega.rst @@ -12,24 +12,29 @@ This tactic does not need any parameter: .. tacn:: omega -``omega`` solves a goal in Presburger arithmetic, i.e. a universally +:tacn:`omega` solves a goal in Presburger arithmetic, i.e. a universally quantified formula made of equations and inequations. Equations may be specified either on the type ``nat`` of natural numbers or on the type ``Z`` of binary-encoded integer numbers. Formulas on ``nat`` are automatically injected into ``Z``. The procedure may use any hypothesis of the current proof session to solve the goal. -Multiplication is handled by ``omega`` but only goals where at +Multiplication is handled by :tacn:`omega` but only goals where at least one of the two multiplicands of products is a constant are solvable. This is the restriction meant by "Presburger arithmetic". If the tactic cannot solve the goal, it fails with an error message. In any case, the computation eventually stops. +.. tacv:: romega + :name: romega + + To be documented. + Arithmetical goals recognized by ``omega`` ------------------------------------------ -``omega`` applied only to quantifier-free formulas built from the +:tacn:`omega` applied only to quantifier-free formulas built from the connectors:: /\ \/ ~ -> @@ -38,11 +43,11 @@ on atomic formulas. Atomic formulas are built from the predicates:: = < <= > >= -on ``nat`` or ``Z``. In expressions of type ``nat``, ``omega`` recognizes:: +on ``nat`` or ``Z``. In expressions of type ``nat``, :tacn:`omega` recognizes:: + - * S O pred -and in expressions of type ``Z``, ``omega`` recognizes numeral constants and:: +and in expressions of type ``Z``, :tacn:`omega` recognizes numeral constants and:: + - * Z.succ Z.pred @@ -53,32 +58,32 @@ were arbitrary variables of type ``nat`` or ``Z``. Messages from ``omega`` ----------------------- -When ``omega`` does not solve the goal, one of the following errors +When :tacn:`omega` does not solve the goal, one of the following errors is generated: -.. exn:: omega can't solve this system +.. exn:: omega can't solve this system. This may happen if your goal is not quantifier-free (if it is - universally quantified, try ``intros`` first; if it contains - existentials quantifiers too, ``omega`` is not strong enough to solve your + universally quantified, try :tacn:`intros` first; if it contains + existentials quantifiers too, :tacn:`omega` is not strong enough to solve your goal). This may happen also if your goal contains arithmetical - operators unknown from ``omega``. Finally, your goal may be really + operators unknown from :tacn:`omega`. Finally, your goal may be really wrong! -.. exn:: omega: Not a quantifier-free goal +.. exn:: omega: Not a quantifier-free goal. If your goal is universally quantified, you should first apply - ``intro`` as many time as needed. + :tacn:`intro` as many times as needed. -.. exn:: omega: Unrecognized predicate or connective: @ident +.. exn:: omega: Unrecognized predicate or connective: @ident. .. exn:: omega: Unrecognized atomic proposition: ... -.. exn:: omega: Can't solve a goal with proposition variables +.. exn:: omega: Can't solve a goal with proposition variables. -.. exn:: omega: Unrecognized proposition +.. exn:: omega: Unrecognized proposition. -.. exn:: omega: Can't solve a goal with non-linear products +.. exn:: omega: Can't solve a goal with non-linear products. .. exn:: omega: Can't solve a goal with equality on type ... @@ -115,21 +120,23 @@ Options .. opt:: Stable Omega -This deprecated option (on by default) is for compatibility with Coq pre 8.5. It -resets internal name counters to make executions of ``omega`` independent. + .. deprecated:: 8.5 + + This deprecated option (on by default) is for compatibility with Coq pre 8.5. It + resets internal name counters to make executions of :tacn:`omega` independent. .. opt:: Omega UseLocalDefs -This option (on by default) allows ``omega`` to use the bodies of local -variables. + This option (on by default) allows :tacn:`omega` to use the bodies of local + variables. .. opt:: Omega System -This option (off by default) activate the printing of debug information + This option (off by default) activate the printing of debug information .. opt:: Omega Action -This option (off by default) activate the printing of debug information + This option (off by default) activate the printing of debug information Technical data -------------- @@ -149,7 +156,7 @@ Overview of the tactic Overview of the OMEGA decision procedure ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The OMEGA decision procedure involved in the ``omega`` tactic uses +The OMEGA decision procedure involved in the :tacn:`omega` tactic uses a small subset of the decision procedure presented in :cite:`TheOmegaPaper` Here is an overview, look at the original paper for more information. diff --git a/doc/sphinx/addendum/parallel-proof-processing.rst b/doc/sphinx/addendum/parallel-proof-processing.rst index 8c1b9d152..edb8676a5 100644 --- a/doc/sphinx/addendum/parallel-proof-processing.rst +++ b/doc/sphinx/addendum/parallel-proof-processing.rst @@ -39,14 +39,14 @@ Proof annotations To process a proof asynchronously |Coq| needs to know the precise statement of the theorem without looking at the proof. This requires some annotations if the theorem is proved inside a Section (see -Section :ref:`TODO-2.4`). +Section :ref:`section-mechanism`). When a section ends, |Coq| looks at the proof object to decide which section variables are actually used and hence have to be quantified in the statement of the theorem. To avoid making the construction of proofs mandatory when ending a section, one can start each proof with -the ``Proof using`` command (Section :ref:`TODO-7.1.5`) that declares which section -variables the theorem uses. +the ``Proof using`` command (Section :ref:`proof-editing-mode`) that +declares which section variables the theorem uses. The presence of ``Proof`` using is needed to process proofs asynchronously in interactive mode. diff --git a/doc/sphinx/addendum/program.rst b/doc/sphinx/addendum/program.rst index eb50e52dc..b685e68e4 100644 --- a/doc/sphinx/addendum/program.rst +++ b/doc/sphinx/addendum/program.rst @@ -135,7 +135,7 @@ support types, avoiding uses of proof-irrelevance that would come up when reasoning with equality on the subset types themselves. The next two commands are similar to their standard counterparts -Definition (see Section `TODO-1.3.2-Definition`_) and Fixpoint (see Section `TODO-1.3.4-Fixpoint`_) +:cmd:`Definition` and :cmd:`Fixpoint` in that they define constants. However, they may require the user to prove some goals to construct the final definitions. @@ -145,13 +145,14 @@ prove some goals to construct the final definitions. Program Definition ~~~~~~~~~~~~~~~~~~ -.. cmd:: Program Definition @ident := @term. +.. cmd:: Program Definition @ident := @term This command types the value term in Russell and generates proof obligations. Once solved using the commands shown below, it binds the final |Coq| term to the name ``ident`` in the environment. - .. exn:: ident already exists + .. exn:: @ident already exists. + :name: @ident already exists. (Program Definition) .. cmdv:: Program Definition @ident : @type := @term @@ -166,7 +167,7 @@ Program Definition .. exn:: In environment … the term: @term does not have type @type. Actually, it has type ... - .. cmdv:: Program Definition @ident @binders : @type := @term. + .. cmdv:: Program Definition @ident @binders : @type := @term This is equivalent to: @@ -174,14 +175,14 @@ Program Definition .. TODO refer to production in alias -See also: Sections `TODO-6.10.1-Opaque`_, `TODO-6.10.2-Transparent`_, `TODO-8.7.5-unfold`_ +See also: Sections :ref:`vernac-controlling-the-reduction-strategies`, :tacn:`unfold` .. _program_fixpoint: Program Fixpoint ~~~~~~~~~~~~~~~~ -.. cmd:: Program Fixpoint @ident @params {? {@order}} : @type := @term. +.. cmd:: Program Fixpoint @ident @params {? {@order}} : @type := @term The optional order annotation follows the grammar: @@ -196,7 +197,7 @@ The optional order annotation follows the grammar: + :g:`wf R x` which is equivalent to :g:`measure x (R)`. The structural fixpoint operator behaves just like the one of |Coq| (see -Section `TODO-1.3.4-Fixpoint`_), except it may also generate obligations. It works +:cmd:`Fixpoint`), except it may also generate obligations. It works with mutually recursive definitions too. .. coqtop:: reset none @@ -254,7 +255,7 @@ using the syntax: Program Lemma ~~~~~~~~~~~~~ -.. cmd:: Program Lemma @ident : @type. +.. cmd:: Program Lemma @ident : @type The Russell language can also be used to type statements of logical properties. It will generate obligations, try to solve them @@ -276,6 +277,7 @@ obligations (e.g. when defining mutually recursive blocks). The optional tactic is replaced by the default one if not specified. .. cmd:: {? Local|Global} Obligation Tactic := @tactic + :name: Obligation Tactic Sets the default obligation solving tactic applied to all obligations automatically, whether to solve them or when starting to prove one, @@ -348,7 +350,7 @@ Frequently Asked Questions --------------------------- -.. exn:: Ill-formed recursive definition +.. exn:: Ill-formed recursive definition. This error can happen when one tries to define a function by structural recursion on a subset object, which means the |Coq| function looks like: diff --git a/doc/sphinx/addendum/ring.rst b/doc/sphinx/addendum/ring.rst index b861892cb..47d3a7d7c 100644 --- a/doc/sphinx/addendum/ring.rst +++ b/doc/sphinx/addendum/ring.rst @@ -171,21 +171,21 @@ performs the simplification in the hypothesis named :n:`@ident`. Error messages: -.. exn:: not a valid ring equation +.. exn:: Not a valid ring equation. The conclusion of the goal is not provable in the corresponding ring theory. -.. exn:: arguments of ring_simplify do not have all the same type +.. exn:: Arguments of ring_simplify do not have all the same type. ``ring_simplify`` cannot simplify terms of several rings at the same time. Invoke the tactic once per ring structure. -.. exn:: cannot find a declared ring structure over @term +.. exn:: Cannot find a declared ring structure over @term. No ring has been declared for the type of the terms to be simplified. Use ``Add Ring`` first. -.. exn:: cannot find a declared ring structure for equality @term +.. exn:: Cannot find a declared ring structure for equality @term. Same as above is the case of the ``ring`` tactic. @@ -303,7 +303,7 @@ following property: The syntax for adding a new ring is -.. cmd:: Add Ring @ident : @term {? ( @ring_mod {* , @ring_mod } )}. +.. cmd:: Add Ring @ident : @term {? ( @ring_mod {* , @ring_mod } )} The :n:`@ident` is not relevant. It is just used for error messages. The :n:`@term` is a proof that the ring signature satisfies the (semi-)ring @@ -396,18 +396,18 @@ div :n:`@term` Error messages: -.. exn:: bad ring structure +.. exn:: Bad ring structure. The proof of the ring structure provided is not of the expected type. -.. exn:: bad lemma for decidability of equality +.. exn:: Bad lemma for decidability of equality. The equality function provided in the case of a computational ring has not the expected type. -.. exn:: ring operation should be declared as a morphism +.. exn:: Ring operation should be declared as a morphism. A setoid associated to the carrier of the ring structure has been found, but the ring operation should be declared as morphism. See :ref:`tactics-enabled-on-user-provided-relations`. @@ -656,7 +656,7 @@ zero for the correctness of the algorithm. The syntax for adding a new field is -.. cmd:: Add Field @ident : @term {? ( @field_mod {* , @field_mod } )}. +.. cmd:: Add Field @ident : @term {? ( @field_mod {* , @field_mod } )} The :n:`@ident` is not relevant. It is just used for error messages. :n:`@term` is a proof that the field signature satisfies the @@ -701,7 +701,7 @@ for |Coq|’s type-checker. Let us see why: At each step of rewriting, the whole context is duplicated in the proof term. Then, a tactic that does hundreds of rewriting generates huge proof terms. Since ``ACDSimpl`` was too slow, Samuel Boutin rewrote -it using reflection (see his article in TACS’97 [Bou97]_). Later, it +it using reflection (see :cite:`Bou97`). Later, it was rewritten by Patrick Loiseleur: the new tactic does not any more require ``ACDSimpl`` to compile and it makes use of |bdi|-reduction not only to replace the rewriting steps, but also to achieve the diff --git a/doc/sphinx/addendum/type-classes.rst b/doc/sphinx/addendum/type-classes.rst index becebb421..6c7258f9c 100644 --- a/doc/sphinx/addendum/type-classes.rst +++ b/doc/sphinx/addendum/type-classes.rst @@ -5,9 +5,6 @@ Type Classes ============ -:Source: https://coq.inria.fr/distrib/current/refman/type-classes.html -:Author: Matthieu Sozeau - This chapter presents a quick reference of the commands related to type classes. For an actual introduction to type classes, there is a description of the system :cite:`sozeau08` and the literature on type @@ -71,8 +68,8 @@ the remaining fields, e.g.: Defined. One has to take care that the transparency of every field is -determined by the transparency of the ``Instance`` proof. One can use -alternatively the ``Program Instance`` variant which has richer facilities +determined by the transparency of the :cmd:`Instance` proof. One can use +alternatively the :cmd:`Program Instance` variant which has richer facilities for dealing with obligations. @@ -151,11 +148,10 @@ database. Sections and contexts --------------------- -To ease the parametrization of developments by type classes, we -provide a new way to introduce variables into section contexts, -compatible with the implicit argument mechanism. The new command works -similarly to the ``Variables`` vernacular (:ref:`TODO-1.3.2-Definitions`), except it -accepts any binding context as argument. For example: +To ease the parametrization of developments by type classes, we provide a new +way to introduce variables into section contexts, compatible with the implicit +argument mechanism. The new command works similarly to the :cmd:`Variables` +vernacular, except it accepts any binding context as argument. For example: .. coqtop:: all @@ -273,12 +269,9 @@ the Existing Instance command to achieve the same effect. Summary of the commands ----------------------- +.. cmd:: Class @ident {? @binders} : {? @sort} := {? @ident} { {+; @ident :{? >} @term } } -.. _Class: - -.. cmd:: Class @ident {? @binders} : {? @sort} := {? @ident} { {+; @ident :{? >} @term } }. - - The ``Class`` command is used to declare a type class with parameters + The :cmd:`Class` command is used to declare a type class with parameters ``binders`` and fields the declared record fields. Variants: @@ -303,12 +296,10 @@ Variants: This variant declares a class a posteriori from a constant or inductive definition. No methods or instances are defined. -.. _Instance: - .. cmd:: Instance @ident {? @binders} : Class t1 … tn [| priority] := { field1 := b1 ; …; fieldi := bi } -The ``Instance`` command is used to declare a type class instance named -``ident`` of the class ``Class`` with parameters ``t1`` to ``tn`` and +The :cmd:`Instance` command is used to declare a type class instance named +``ident`` of the class :cmd:`Class` with parameters ``t1`` to ``tn`` and fields ``b1`` to ``bi``, where each field must be a declared field of the class. Missing fields must be filled in interactive proof mode. @@ -318,233 +309,235 @@ optional priority can be declared, 0 being the highest priority as for auto hints. If the priority is not specified, it defaults to the number of non-dependent binders of the instance. -Variants: - - -.. cmd:: Instance ident {? @binders} : forall {? @binders}, Class t1 … tn [| priority] := @term +.. cmdv:: Instance @ident {? @binders} : forall {? @binders}, Class t1 … tn [| priority] := @term This syntax is used for declaration of singleton class instances or for directly giving an explicit term of type ``forall binders, Class t1 … tn``. One need not even mention the unique field name for singleton classes. -.. cmd:: Global Instance +.. cmdv:: Global Instance One can use the ``Global`` modifier on instances declared in a section so that their generalization is automatically redeclared after the section is closed. -.. cmd:: Program Instance +.. cmdv:: Program Instance + :name: Program Instance - Switches the type-checking to Program (chapter :ref:`program`) and + Switches the type-checking to Program (chapter :ref:`programs`) and uses the obligation mechanism to manage missing fields. -.. cmd:: Declare Instance +.. cmdv:: Declare Instance + :name: Declare Instance In a Module Type, this command states that a corresponding concrete - instance should exist in any implementation of thisModule Type. This - is similar to the distinction betweenParameter vs. Definition, or - between Declare Module and Module. + instance should exist in any implementation of this Module Type. This + is similar to the distinction between :cmd:`Parameter` vs. :cmd:`Definition`, or + between :cmd:`Declare Module` and :cmd:`Module`. -Besides the ``Class`` and ``Instance`` vernacular commands, there are a +Besides the :cmd:`Class` and :cmd:`Instance` vernacular commands, there are a few other commands related to type classes. -.. _ExistingInstance: - -Existing Instance -~~~~~~~~~~~~~~~~~ - .. cmd:: Existing Instance {+ @ident} [| priority] -This commands adds an arbitrary list of constants whose type ends with -an applied type class to the instance database with an optional -priority. It can be used for redeclaring instances at the end of -sections, or declaring structure projections as instances. This is -equivalent to ``Hint Resolve ident : typeclass_instances``, except it -registers instances for ``Print Instances``. - -.. _Context: - -Context -~~~~~~~ + This commands adds an arbitrary list of constants whose type ends with + an applied type class to the instance database with an optional + priority. It can be used for redeclaring instances at the end of + sections, or declaring structure projections as instances. This is + equivalent to ``Hint Resolve ident : typeclass_instances``, except it + registers instances for :cmd:`Print Instances`. .. cmd:: Context @binders -Declares variables according to the given binding context, which might -use :ref:`implicit-generalization`. + Declares variables according to the given binding context, which might + use :ref:`implicit-generalization`. + +.. tacn:: typeclasses eauto + :name: typeclasses eauto + + This tactic uses a different resolution engine than :tacn:`eauto` and + :tacn:`auto`. The main differences are the following: + + + Contrary to :tacn:`eauto` and :tacn:`auto`, the resolution is done entirely in + the new proof engine (as of Coq 8.6), meaning that backtracking is + available among dependent subgoals, and shelving goals is supported. + typeclasses eauto is a multi-goal tactic. It analyses the dependencies + between subgoals to avoid backtracking on subgoals that are entirely + independent. + + + When called with no arguments, typeclasses eauto uses + the ``typeclass_instances`` database by default (instead of core). + Dependent subgoals are automatically shelved, and shelved goals can + remain after resolution ends (following the behavior of Coq 8.5). + + .. note:: + As of Coq 8.6, ``all:once (typeclasses eauto)`` faithfully + mimicks what happens during typeclass resolution when it is called + during refinement/type-inference, except that *only* declared class + subgoals are considered at the start of resolution during type + inference, while ``all`` can select non-class subgoals as well. It might + move to ``all:typeclasses eauto`` in future versions when the + refinement engine will be able to backtrack. + + + When called with specific databases (e.g. with), typeclasses eauto + allows shelved goals to remain at any point during search and treat + typeclasses goals like any other. + + + The transparency information of databases is used consistently for + all hints declared in them. It is always used when calling the + unifier. When considering the local hypotheses, we use the transparent + state of the first hint database given. Using an empty database + (created with :cmd:`Create HintDb` for example) with unfoldable variables and + constants as the first argument of typeclasses eauto hence makes + resolution with the local hypotheses use full conversion during + unification. + + + .. cmdv:: typeclasses eauto @num + + .. warning:: + The semantics for the limit :n:`@num` + is different than for auto. By default, if no limit is given the + search is unbounded. Contrary to auto, introduction steps (intro) are + counted, which might result in larger limits being necessary when + searching with typeclasses eauto than auto. + + .. cmdv:: typeclasses eauto with {+ @ident} + + This variant runs resolution with the given hint databases. It treats + typeclass subgoals the same as other subgoals (no shelving of + non-typeclass goals in particular). + +.. tacn:: autoapply @term with @ident + :name: autoapply + + The tactic autoapply applies a term using the transparency information + of the hint database ident, and does *no* typeclass resolution. This can + be used in :cmd:`Hint Extern`’s for typeclass instances (in the hint + database ``typeclass_instances``) to allow backtracking on the typeclass + subgoals created by the lemma application, rather than doing type class + resolution locally at the hint application time. +.. _TypeclassesTransparent: -.. _typeclasses-eauto: - -``typeclasses eauto`` -~~~~~~~~~~~~~~~~~~~~~ - -The ``typeclasses eauto`` tactic uses a different resolution engine than -eauto and auto. The main differences are the following: - -+ Contrary to ``eauto`` and ``auto``, the resolution is done entirely in - the new proof engine (as of Coq v8.6), meaning that backtracking is - available among dependent subgoals, and shelving goals is supported. - typeclasses eauto is a multi-goal tactic. It analyses the dependencies - between subgoals to avoid backtracking on subgoals that are entirely - independent. - -+ When called with no arguments, typeclasses eauto uses - thetypeclass_instances database by default (instead of core). - Dependent subgoals are automatically shelved, and shelved goals can - remain after resolution ends (following the behavior ofCoq 8.5). - *Note: * As of Coq 8.6, all:once (typeclasses eauto) faithfully - mimicks what happens during typeclass resolution when it is called - during refinement/type-inference, except that *only* declared class - subgoals are considered at the start of resolution during type - inference, while “all” can select non-class subgoals as well. It might - move to ``all:typeclasses eauto`` in future versions when the - refinement engine will be able to backtrack. - -+ When called with specific databases (e.g. with), typeclasses eauto - allows shelved goals to remain at any point during search and treat - typeclasses goals like any other. - -+ The transparency information of databases is used consistently for - all hints declared in them. It is always used when calling the - unifier. When considering the local hypotheses, we use the transparent - state of the first hint database given. Using an empty database - (created with Create HintDb for example) with unfoldable variables and - constants as the first argument of typeclasses eauto hence makes - resolution with the local hypotheses use full conversion during - unification. - - -Variants: - -#. ``typeclasses eauto [num]`` +Typeclasses Transparent, Typclasses Opaque +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - *Warning:* The semantics for the limit num - is different than for auto. By default, if no limit is given the - search is unbounded. Contrary to auto, introduction steps (intro) are - counted, which might result in larger limits being necessary when - searching with typeclasses eauto than auto. +.. cmd:: Typeclasses Transparent {+ @ident} -#. ``typeclasses eauto with {+ @ident}`` + This command defines makes the identifiers transparent during type class + resolution. - This variant runs resolution with the given hint databases. It treats - typeclass subgoals the same as other subgoals (no shelving of - non-typeclass goals in particular). +.. cmd:: Typeclasses Opaque {+ @ident} -.. _autoapply: + Make the identifiers opaque for typeclass search. It is useful when some + constants prevent some unifications and make resolution fail. It is also + useful to declare constants which should never be unfolded during + proof-search, like fixpoints or anything which does not look like an + abbreviation. This can additionally speed up proof search as the typeclass + map can be indexed by such rigid constants (see + :ref:`thehintsdatabasesforautoandeauto`). -``autoapply term with ident`` -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +By default, all constants and local variables are considered transparent. One +should take care not to make opaque any constant that is used to abbreviate a +type, like: -The tactic autoapply applies a term using the transparency information -of the hint database ident, and does *no* typeclass resolution. This can -be used in ``Hint Extern``’s for typeclass instances (in the hint -database ``typeclass_instances``) to allow backtracking on the typeclass -subgoals created by the lemma application, rather than doing type class -resolution locally at the hint application time. +:: -.. _TypeclassesTransparent: + relation A := A -> A -> Prop. -Typeclasses Transparent, Typclasses Opaque -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +This is equivalent to ``Hint Transparent, Opaque ident : typeclass_instances``. -.. cmd:: Typeclasses { Transparent | Opaque } {+ @ident} - This commands defines the transparency of the given identifiers - during type class resolution. It is useful when some constants - prevent some unifications and make resolution fail. It is also useful - to declare constants which should never be unfolded during - proof-search, like fixpoints or anything which does not look like an - abbreviation. This can additionally speed up proof search as the - typeclass map can be indexed by such rigid constants (see - :ref:`thehintsdatabasesforautoandeauto`). By default, all constants - and local variables are considered transparent. One should take care - not to make opaque any constant that is used to abbreviate a type, - like: +Options +~~~~~~~ -:: +.. opt:: Typeclasses Dependency Order - relation A := A -> A -> Prop. + This option (on by default since 8.6) respects the dependency order + between subgoals, meaning that subgoals which are depended on by other + subgoals come first, while the non-dependent subgoals were put before + the dependent ones previously (Coq 8.5 and below). This can result in + quite different performance behaviors of proof search. -This is equivalent to ``Hint Transparent, Opaque ident : typeclass_instances``. +.. opt:: Typeclasses Filtered Unification -Set Typeclasses Dependency Order -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + This option, available since Coq 8.6 and off by default, switches the + hint application procedure to a filter-then-unify strategy. To apply a + hint, we first check that the goal *matches* syntactically the + inferred or specified pattern of the hint, and only then try to + *unify* the goal with the conclusion of the hint. This can drastically + improve performance by calling unification less often, matching + syntactic patterns being very quick. This also provides more control + on the triggering of instances. For example, forcing a constant to + explicitely appear in the pattern will make it never apply on a goal + where there is a hole in that place. -This option (on by default since 8.6) respects the dependency order -between subgoals, meaning that subgoals which are depended on by other -subgoals come first, while the non-dependent subgoals were put before -the dependent ones previously (Coq v8.5 and below). This can result in -quite different performance behaviors of proof search. +.. opt:: Typeclasses Limit Intros -Set Typeclasses Filtered Unification -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + This option (on by default) controls the ability to apply hints while + avoiding (functional) eta-expansions in the generated proof term. It + does so by allowing hints that conclude in a product to apply to a + goal with a matching product directly, avoiding an introduction. + *Warning:* this can be expensive as it requires rebuilding hint + clauses dynamically, and does not benefit from the invertibility + status of the product introduction rule, resulting in potentially more + expensive proof-search (i.e. more useless backtracking). -This option, available since Coq 8.6 and off by default, switches the -hint application procedure to a filter-then-unify strategy. To apply a -hint, we first check that the goal *matches* syntactically the -inferred or specified pattern of the hint, and only then try to -*unify* the goal with the conclusion of the hint. This can drastically -improve performance by calling unification less often, matching -syntactic patterns being very quick. This also provides more control -on the triggering of instances. For example, forcing a constant to -explicitely appear in the pattern will make it never apply on a goal -where there is a hole in that place. +.. opt:: Typeclass Resolution For Conversion -Set Typeclasses Limit Intros -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + This option (on by default) controls the use of typeclass resolution + when a unification problem cannot be solved during elaboration/type- + inference. With this option on, when a unification fails, typeclass + resolution is tried before launching unification once again. -This option (on by default) controls the ability to apply hints while -avoiding (functional) eta-expansions in the generated proof term. It -does so by allowing hints that conclude in a product to apply to a -goal with a matching product directly, avoiding an introduction. -*Warning:* this can be expensive as it requires rebuilding hint -clauses dynamically, and does not benefit from the invertibility -status of the product introduction rule, resulting in potentially more -expensive proof-search (i.e. more useless backtracking). +.. opt:: Typeclasses Strict Resolution + Typeclass declarations introduced when this option is set have a + stricter resolution behavior (the option is off by default). When + looking for unifications of a goal with an instance of this class, we + “freeze” all the existentials appearing in the goals, meaning that + they are considered rigid during unification and cannot be + instantiated. -Set Typeclass Resolution For Conversion -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -This option (on by default) controls the use of typeclass resolution -when a unification problem cannot be solved during elaboration/type- -inference. With this option on, when a unification fails, typeclass -resolution is tried before launching unification once again. +.. opt:: Typeclasses Unique Solutions + When a typeclass resolution is launched we ensure that it has a single + solution or fail. This ensures that the resolution is canonical, but + can make proof search much more expensive. -Set Typeclasses Strict Resolution -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Typeclass declarations introduced when this option is set have a -stricter resolution behavior (the option is off by default). When -looking for unifications of a goal with an instance of this class, we -“freeze” all the existentials appearing in the goals, meaning that -they are considered rigid during unification and cannot be -instantiated. +.. opt:: Typeclasses Unique Instances + Typeclass declarations introduced when this option is set have a more + efficient resolution behavior (the option is off by default). When a + solution to the typeclass goal of this class is found, we never + backtrack on it, assuming that it is canonical. -Set Typeclasses Unique Solutions -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +.. opt:: Typeclasses Debug {? Verbosity @num} -When a typeclass resolution is launched we ensure that it has a single -solution or fail. This ensures that the resolution is canonical, but -can make proof search much more expensive. + These options allow to see the resolution steps of typeclasses that are + performed during search. The ``Debug`` option is synonymous to ``Debug + Verbosity 1``, and ``Debug Verbosity 2`` provides more information + (tried tactics, shelving of goals, etc…). +.. opt:: Refine Instance Mode -Set Typeclasses Unique Instances -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + This option allows to switch the behavior of instance declarations made through + the Instance command. -Typeclass declarations introduced when this option is set have a more -efficient resolution behavior (the option is off by default). When a -solution to the typeclass goal of this class is found, we never -backtrack on it, assuming that it is canonical. + + When it is on (the default), instances that have unsolved holes in + their proof-term silently open the proof mode with the remaining + obligations to prove. + + When it is off, they fail with an error instead. Typeclasses eauto `:=` ~~~~~~~~~~~~~~~~~~~~~~ @@ -561,27 +554,3 @@ Typeclasses eauto `:=` default) or breadth-first search. + ``depth`` This sets the depth limit of the search. - - -Set Typeclasses Debug -~~~~~~~~~~~~~~~~~~~~~ - -.. cmd:: Set Typeclasses Debug {? Verbosity @num} - -These options allow to see the resolution steps of typeclasses that are -performed during search. The ``Debug`` option is synonymous to ``Debug -Verbosity 1``, and ``Debug Verbosity 2`` provides more information -(tried tactics, shelving of goals, etc…). - - -Set Refine Instance Mode -~~~~~~~~~~~~~~~~~~~~~~~~ - -The option Refine Instance Mode allows to switch the behavior of -instance declarations made through the Instance command. - -+ When it is on (the default), instances that have unsolved holes in - their proof-term silently open the proof mode with the remaining - obligations to prove. - -+ When it is off, they fail with an error instead. diff --git a/doc/sphinx/addendum/universe-polymorphism.rst b/doc/sphinx/addendum/universe-polymorphism.rst new file mode 100644 index 000000000..6e7ccba63 --- /dev/null +++ b/doc/sphinx/addendum/universe-polymorphism.rst @@ -0,0 +1,445 @@ +.. include:: ../replaces.rst + +.. _polymorphicuniverses: + +Polymorphic Universes +====================== + +:Author: Matthieu Sozeau + +General Presentation +--------------------- + +.. warning:: + + The status of Universe Polymorphism is experimental. + +This section describes the universe polymorphic extension of |Coq|. +Universe polymorphism makes it possible to write generic definitions +making use of universes and reuse them at different and sometimes +incompatible universe levels. + +A standard example of the difference between universe *polymorphic* +and *monomorphic* definitions is given by the identity function: + +.. coqtop:: in + + Definition identity {A : Type} (a : A) := a. + +By default, constant declarations are monomorphic, hence the identity +function declares a global universe (say ``Top.1``) for its domain. +Subsequently, if we try to self-apply the identity, we will get an +error: + +.. coqtop:: all + + Fail Definition selfid := identity (@identity). + +Indeed, the global level ``Top.1`` would have to be strictly smaller than +itself for this self-application to typecheck, as the type of +:g:`(@identity)` is :g:`forall (A : Type@{Top.1}), A -> A` whose type is itself +:g:`Type@{Top.1+1}`. + +A universe polymorphic identity function binds its domain universe +level at the definition level instead of making it global. + +.. coqtop:: in + + Polymorphic Definition pidentity {A : Type} (a : A) := a. + +.. coqtop:: all + + About pidentity. + +It is then possible to reuse the constant at different levels, like +so: + +.. coqtop:: in + + Definition selfpid := pidentity (@pidentity). + +Of course, the two instances of :g:`pidentity` in this definition are +different. This can be seen when the :opt:`Printing Universes` option is on: + +.. coqtop:: none + + Set Printing Universes. + +.. coqtop:: all + + Print selfpid. + +Now :g:`pidentity` is used at two different levels: at the head of the +application it is instantiated at ``Top.3`` while in the argument position +it is instantiated at ``Top.4``. This definition is only valid as long as +``Top.4`` is strictly smaller than ``Top.3``, as show by the constraints. Note +that this definition is monomorphic (not universe polymorphic), so the +two universes (in this case ``Top.3`` and ``Top.4``) are actually global +levels. + +When printing :g:`pidentity`, we can see the universes it binds in +the annotation :g:`@{Top.2}`. Additionally, when +:opt:`Printing Universes` is on we print the "universe context" of +:g:`pidentity` consisting of the bound universes and the +constraints they must verify (for :g:`pidentity` there are no constraints). + +Inductive types can also be declared universes polymorphic on +universes appearing in their parameters or fields. A typical example +is given by monoids: + +.. coqtop:: in + + Polymorphic Record Monoid := { mon_car :> Type; mon_unit : mon_car; + mon_op : mon_car -> mon_car -> mon_car }. + +.. coqtop:: in + + Print Monoid. + +The Monoid's carrier universe is polymorphic, hence it is possible to +instantiate it for example with :g:`Monoid` itself. First we build the +trivial unit monoid in :g:`Set`: + +.. coqtop:: in + + Definition unit_monoid : Monoid := + {| mon_car := unit; mon_unit := tt; mon_op x y := tt |}. + +From this we can build a definition for the monoid of :g:`Set`\-monoids +(where multiplication would be given by the product of monoids). + +.. coqtop:: in + + Polymorphic Definition monoid_monoid : Monoid. + refine (@Build_Monoid Monoid unit_monoid (fun x y => x)). + Defined. + +.. coqtop:: all + + Print monoid_monoid. + +As one can see from the constraints, this monoid is “large”, it lives +in a universe strictly higher than :g:`Set`. + +Polymorphic, Monomorphic +------------------------- + +.. cmd:: Polymorphic @definition + + As shown in the examples, polymorphic definitions and inductives can be + declared using the ``Polymorphic`` prefix. + +.. opt:: Universe Polymorphism + + Once enabled, this option will implicitly prepend ``Polymorphic`` to any + definition of the user. + +.. cmd:: Monomorphic @definition + + When the :opt:`Universe Polymorphism` option is set, to make a definition + producing global universe constraints, one can use the ``Monomorphic`` prefix. + +Many other commands support the ``Polymorphic`` flag, including: + +.. TODO add links on each of these? + +- ``Lemma``, ``Axiom``, and all the other “definition” keywords support + polymorphism. + +- ``Variables``, ``Context``, ``Universe`` and ``Constraint`` in a section support + polymorphism. This means that the universe variables (and associated + constraints) are discharged polymorphically over definitions that use + them. In other words, two definitions in the section sharing a common + variable will both get parameterized by the universes produced by the + variable declaration. This is in contrast to a “mononorphic” variable + which introduces global universes and constraints, making the two + definitions depend on the *same* global universes associated to the + variable. + +- :cmd:`Hint Resolve` and :cmd:`Hint Rewrite` will use the auto/rewrite hint + polymorphically, not at a single instance. + +Cumulative, NonCumulative +------------------------- + +Polymorphic inductive types, coinductive types, variants and records can be +declared cumulative using the :g:`Cumulative` prefix. + +.. cmd:: Cumulative @inductive + + Declares the inductive as cumulative + +Alternatively, there is an option :opt:`Polymorphic Inductive +Cumulativity` which when set, makes all subsequent *polymorphic* +inductive definitions cumulative. When set, inductive types and the +like can be enforced to be non-cumulative using the :g:`NonCumulative` +prefix. + +.. cmd:: NonCumulative @inductive + + Declares the inductive as non-cumulative + +.. opt:: Polymorphic Inductive Cumulativity + + When this option is on, it sets all following polymorphic inductive + types as cumulative (it is off by default). + +Consider the examples below. + +.. coqtop:: in + + Polymorphic Cumulative Inductive list {A : Type} := + | nil : list + | cons : A -> list -> list. + +.. coqtop:: all + + Print list. + +When printing :g:`list`, the universe context indicates the subtyping +constraints by prefixing the level names with symbols. + +Because inductive subtypings are only produced by comparing inductives +to themselves with universes changed, they amount to variance +information: each universe is either invariant, covariant or +irrelevant (there are no contravariant subtypings in Coq), +respectively represented by the symbols `=`, `+` and `*`. + +Here we see that :g:`list` binds an irrelevant universe, so any two +instances of :g:`list` are convertible: :math:`E[Γ] ⊢ \mathsf{list}@\{i\}~A +=_{βδιζη} \mathsf{list}@\{j\}~B` whenever :math:`E[Γ] ⊢ A =_{βδιζη} B` and +this applies also to their corresponding constructors, when +they are comparable at the same type. + +See :ref:`Conversion-rules` for more details on convertibility and subtyping. +The following is an example of a record with non-trivial subtyping relation: + +.. coqtop:: all + + Polymorphic Cumulative Record packType := {pk : Type}. + +:g:`packType` binds a covariant universe, i.e. + +.. math:: + + E[Γ] ⊢ \mathsf{packType}@\{i\} =_{βδιζη} + \mathsf{packType}@\{j\}~\mbox{ whenever }~i ≤ j + +Cumulative inductive types, coninductive types, variants and records +only make sense when they are universe polymorphic. Therefore, an +error is issued whenever the user uses the :g:`Cumulative` or +:g:`NonCumulative` prefix in a monomorphic context. +Notice that this is not the case for the option :opt:`Polymorphic Inductive Cumulativity`. +That is, this option, when set, makes all subsequent *polymorphic* +inductive declarations cumulative (unless, of course the :g:`NonCumulative` prefix is used) +but has no effect on *monomorphic* inductive declarations. + +Consider the following examples. + +.. coqtop:: all reset + + Monomorphic Cumulative Inductive Unit := unit. + +.. coqtop:: all reset + + Monomorphic NonCumulative Inductive Unit := unit. + +.. coqtop:: all reset + + Set Polymorphic Inductive Cumulativity. + Inductive Unit := unit. + +An example of a proof using cumulativity +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +.. coqtop:: in + + Set Universe Polymorphism. + Set Polymorphic Inductive Cumulativity. + + Inductive eq@{i} {A : Type@{i}} (x : A) : A -> Type@{i} := eq_refl : eq x x. + + Definition funext_type@{a b e} (A : Type@{a}) (B : A -> Type@{b}) + := forall f g : (forall a, B a), + (forall x, eq@{e} (f x) (g x)) + -> eq@{e} f g. + + Section down. + Universes a b e e'. + Constraint e' < e. + Lemma funext_down {A B} + (H : @funext_type@{a b e} A B) : @funext_type@{a b e'} A B. + Proof. + exact H. + Defined. + End down. + +Cumulativity Weak Constraints +----------------------------- + +.. opt:: Cumulativity Weak Constraints + +This option, on by default, causes "weak" constraints to be produced +when comparing universes in an irrelevant position. Processing weak +constraints is delayed until minimization time. A weak constraint +between `u` and `v` when neither is smaller than the other and +one is flexible causes them to be unified. Otherwise the constraint is +silently discarded. + +This heuristic is experimental and may change in future versions. +Disabling weak constraints is more predictable but may produce +arbitrary numbers of universes. + + +Global and local universes +--------------------------- + +Each universe is declared in a global or local environment before it +can be used. To ensure compatibility, every *global* universe is set +to be strictly greater than :g:`Set` when it is introduced, while every +*local* (i.e. polymorphically quantified) universe is introduced as +greater or equal to :g:`Set`. + + +Conversion and unification +--------------------------- + +The semantics of conversion and unification have to be modified a +little to account for the new universe instance arguments to +polymorphic references. The semantics respect the fact that +definitions are transparent, so indistinguishable from their bodies +during conversion. + +This is accomplished by changing one rule of unification, the first- +order approximation rule, which applies when two applicative terms +with the same head are compared. It tries to short-cut unfolding by +comparing the arguments directly. In case the constant is universe +polymorphic, we allow this rule to fire only when unifying the +universes results in instantiating a so-called flexible universe +variables (not given by the user). Similarly for conversion, if such +an equation of applicative terms fail due to a universe comparison not +being satisfied, the terms are unfolded. This change implies that +conversion and unification can have different unfolding behaviors on +the same development with universe polymorphism switched on or off. + + +Minimization +------------- + +Universe polymorphism with cumulativity tends to generate many useless +inclusion constraints in general. Typically at each application of a +polymorphic constant :g:`f`, if an argument has expected type :g:`Type@{i}` +and is given a term of type :g:`Type@{j}`, a :math:`j ≤ i` constraint will be +generated. It is however often the case that an equation :math:`j = i` would +be more appropriate, when :g:`f`\'s universes are fresh for example. +Consider the following example: + +.. coqtop:: none + + Polymorphic Definition pidentity {A : Type} (a : A) := a. + Set Printing Universes. + +.. coqtop:: in + + Definition id0 := @pidentity nat 0. + +.. coqtop:: all + + Print id0. + +This definition is elaborated by minimizing the universe of :g:`id0` to +level :g:`Set` while the more general definition would keep the fresh level +:g:`i` generated at the application of :g:`id` and a constraint that :g:`Set` :math:`≤ i`. +This minimization process is applied only to fresh universe variables. +It simply adds an equation between the variable and its lower bound if +it is an atomic universe (i.e. not an algebraic max() universe). + +.. opt:: Universe Minimization ToSet + + Turning this option off (it is on by default) disallows minimization + to the sort :g:`Set` and only collapses floating universes between + themselves. + + +Explicit Universes +------------------- + +The syntax has been extended to allow users to explicitly bind names +to universes and explicitly instantiate polymorphic definitions. + +.. cmd:: Universe @ident + + In the monorphic case, this command declares a new global universe + named :g:`ident`, which can be referred to using its qualified name + as well. Global universe names live in a separate namespace. The + command supports the polymorphic flag only in sections, meaning the + universe quantification will be discharged on each section definition + independently. One cannot mix polymorphic and monomorphic + declarations in the same section. + + +.. cmd:: Constraint @ident @ord @ident + + This command declares a new constraint between named universes. The + order relation :n:`@ord` can be one of :math:`<`, :math:`≤` or :math:`=`. If consistent, the constraint + is then enforced in the global environment. Like ``Universe``, it can be + used with the ``Polymorphic`` prefix in sections only to declare + constraints discharged at section closing time. One cannot declare a + global constraint on polymorphic universes. + + .. exn:: Undeclared universe @ident. + + .. exn:: Universe inconsistency. + + +Polymorphic definitions +~~~~~~~~~~~~~~~~~~~~~~~ + +For polymorphic definitions, the declaration of (all) universe levels +introduced by a definition uses the following syntax: + +.. coqtop:: in + + Polymorphic Definition le@{i j} (A : Type@{i}) : Type@{j} := A. + +.. coqtop:: all + + Print le. + +During refinement we find that :g:`j` must be larger or equal than :g:`i`, as we +are using :g:`A : Type@{i} <= Type@{j}`, hence the generated constraint. At the +end of a definition or proof, we check that the only remaining +universes are the ones declared. In the term and in general in proof +mode, introduced universe names can be referred to in terms. Note that +local universe names shadow global universe names. During a proof, one +can use :cmd:`Show Universes` to display the current context of universes. + +Definitions can also be instantiated explicitly, giving their full +instance: + +.. coqtop:: all + + Check (pidentity@{Set}). + Monomorphic Universes k l. + Check (le@{k l}). + +User-named universes and the anonymous universe implicitly attached to +an explicit :g:`Type` are considered rigid for unification and are never +minimized. Flexible anonymous universes can be produced with an +underscore or by omitting the annotation to a polymorphic definition. + +.. coqtop:: all + + Check (fun x => x) : Type -> Type. + Check (fun x => x) : Type -> Type@{_}. + + Check le@{k _}. + Check le. + +.. opt:: Strict Universe Declaration. + + Turning this option off allows one to freely use + identifiers for universes without declaring them first, with the + semantics that the first use declares it. In this mode, the universe + names are not associated with the definition or proof once it has been + defined. This is meant mainly for debugging purposes. diff --git a/doc/sphinx/biblio.bib b/doc/sphinx/biblio.bib index 247f32103..3e988709c 100644 --- a/doc/sphinx/biblio.bib +++ b/doc/sphinx/biblio.bib @@ -3,47 +3,6 @@ @String{lnai = "Lecture Notes in Artificial Intelligence"} @String{SV = "{Sprin-ger-Verlag}"} -@InProceedings{Aud91, - author = {Ph. Audebaud}, - booktitle = {Proceedings of the sixth Conf. on Logic in Computer Science.}, - publisher = {IEEE}, - title = {Partial {Objects} in the {Calculus of Constructions}}, - year = {1991} -} - -@PhDThesis{Aud92, - author = {Ph. Audebaud}, - school = {{Universit\'e} Bordeaux I}, - title = {Extension du Calcul des Constructions par Points fixes}, - year = {1992} -} - -@InProceedings{Audebaud92b, - author = {Ph. Audebaud}, - booktitle = {{Proceedings of the 1992 Workshop on Types for Proofs and Programs}}, - editor = {{B. Nordstr\"om and K. Petersson and G. Plotkin}}, - note = {Also Research Report LIP-ENS-Lyon}, - pages = {21--34}, - title = {{CC+ : an extension of the Calculus of Constructions with fixpoints}}, - year = {1992} -} - -@InProceedings{Augustsson85, - author = {L. Augustsson}, - title = {{Compiling Pattern Matching}}, - booktitle = {Conference Functional Programming and -Computer Architecture}, - year = {1985} -} - -@Article{BaCo85, - author = {J.L. Bates and R.L. Constable}, - journal = {ACM transactions on Programming Languages and Systems}, - title = {Proofs as {Programs}}, - volume = {7}, - year = {1985} -} - @Book{Bar81, author = {H.P. Barendregt}, publisher = {North-Holland}, @@ -51,55 +10,6 @@ Computer Architecture}, year = {1981} } -@TechReport{Bar91, - author = {H. Barendregt}, - institution = {Catholic University Nijmegen}, - note = {In Handbook of Logic in Computer Science, Vol II}, - number = {91-19}, - title = {Lambda {Calculi with Types}}, - year = {1991} -} - -@Article{BeKe92, - author = {G. Bellin and J. Ketonen}, - journal = {Theoretical Computer Science}, - pages = {115--142}, - title = {A decision procedure revisited : Notes on direct logic, linear logic and its implementation}, - volume = {95}, - year = {1992} -} - -@Book{Bee85, - author = {M.J. Beeson}, - publisher = SV, - title = {Foundations of Constructive Mathematics, Metamathematical Studies}, - year = {1985} -} - -@Book{Bis67, - author = {E. Bishop}, - publisher = {McGraw-Hill}, - title = {Foundations of Constructive Analysis}, - year = {1967} -} - -@Book{BoMo79, - author = {R.S. Boyer and J.S. Moore}, - key = {BoMo79}, - publisher = {Academic Press}, - series = {ACM Monograph}, - title = {A computational logic}, - year = {1979} -} - -@MastersThesis{Bou92, - author = {S. Boutin}, - month = sep, - school = {{Universit\'e Paris 7}}, - title = {Certification d'un compilateur {ML en Coq}}, - year = {1992} -} - @InProceedings{Bou97, title = {Using reflection to build efficient and certified decision procedure s}, @@ -112,15 +22,6 @@ s}, year = {1997} } -@PhDThesis{Bou97These, - author = {S. Boutin}, - title = {R\'eflexions sur les quotients}, - school = {Paris 7}, - year = 1997, - type = {th\`ese d'Universit\'e}, - month = apr -} - @Article{Bru72, author = {N.J. de Bruijn}, journal = {Indag. Math.}, @@ -129,121 +30,6 @@ s}, year = {1972} } - -@InCollection{Bru80, - author = {N.J. de Bruijn}, - booktitle = {to H.B. Curry : Essays on Combinatory Logic, Lambda Calculus and Formalism.}, - editor = {J.P. Seldin and J.R. Hindley}, - publisher = {Academic Press}, - title = {A survey of the project {Automath}}, - year = {1980} -} - -@TechReport{COQ93, - author = {G. Dowek and A. Felty and H. Herbelin and G. Huet and C. Murthy and C. Parent and C. Paulin-Mohring and B. Werner}, - institution = {INRIA}, - month = may, - number = {154}, - title = {{The Coq Proof Assistant User's Guide Version 5.8}}, - year = {1993} -} - -@TechReport{COQ02, - author = {The Coq Development Team}, - institution = {INRIA}, - month = Feb, - number = {255}, - title = {{The Coq Proof Assistant Reference Manual Version 7.2}}, - year = {2002} -} - -@TechReport{CPar93, - author = {C. Parent}, - institution = {Ecole {Normale} {Sup\'erieure} de {Lyon}}, - month = oct, - note = {Also in~\cite{Nijmegen93}}, - number = {93-29}, - title = {Developing certified programs in the system {Coq}- {The} {Program} tactic}, - year = {1993} -} - -@PhDThesis{CPar95, - author = {C. Parent}, - school = {Ecole {Normale} {Sup\'erieure} de {Lyon}}, - title = {{Synth\`ese de preuves de programmes dans le Calcul des Constructions Inductives}}, - year = {1995} -} - -@Book{Caml, - author = {P. Weis and X. Leroy}, - publisher = {InterEditions}, - title = {Le langage Caml}, - year = {1993} -} - -@InProceedings{ChiPotSimp03, - author = {Laurent Chicli and Lo\"{\i}c Pottier and Carlos Simpson}, - title = {Mathematical Quotients and Quotient Types in Coq}, - booktitle = {TYPES}, - crossref = {DBLP:conf/types/2002}, - year = {2002} -} - -@TechReport{CoC89, - author = {Projet Formel}, - institution = {INRIA}, - number = {110}, - title = {{The Calculus of Constructions. Documentation and user's guide, Version 4.10}}, - year = {1989} -} - -@InProceedings{CoHu85a, - author = {Th. Coquand and G. Huet}, - address = {Linz}, - booktitle = {EUROCAL'85}, - publisher = SV, - series = LNCS, - title = {{Constructions : A Higher Order Proof System for Mechanizing Mathematics}}, - volume = {203}, - year = {1985} -} - -@InProceedings{CoHu85b, - author = {Th. Coquand and G. Huet}, - booktitle = {Logic Colloquium'85}, - editor = {The Paris Logic Group}, - publisher = {North-Holland}, - title = {{Concepts Math\'ematiques et Informatiques formalis\'es dans le Calcul des Constructions}}, - year = {1987} -} - -@Article{CoHu86, - author = {Th. Coquand and G. Huet}, - journal = {Information and Computation}, - number = {2/3}, - title = {The {Calculus of Constructions}}, - volume = {76}, - year = {1988} -} - -@InProceedings{CoPa89, - author = {Th. Coquand and C. Paulin-Mohring}, - booktitle = {Proceedings of Colog'88}, - editor = {P. Martin-L\"of and G. Mints}, - publisher = SV, - series = LNCS, - title = {Inductively defined types}, - volume = {417}, - year = {1990} -} - -@Book{Con86, - author = {R.L. {Constable et al.}}, - publisher = {Prentice-Hall}, - title = {{Implementing Mathematics with the Nuprl Proof Development System}}, - year = {1986} -} - @PhDThesis{Coq85, author = {Th. Coquand}, month = jan, @@ -261,24 +47,6 @@ s}, year = {1986} } -@InProceedings{Coq90, - author = {Th. Coquand}, - booktitle = {Logic and Computer Science}, - editor = {P. Oddifredi}, - note = {INRIA Research Report 1088, also in~\cite{CoC89}}, - publisher = {Academic Press}, - title = {{Metamathematical Investigations of a Calculus of Constructions}}, - year = {1990} -} - -@InProceedings{Coq91, - author = {Th. Coquand}, - booktitle = {Proceedings 9th Int. Congress of Logic, Methodology and Philosophy of Science}, - title = {{A New Paradox in Type Theory}}, - month = {August}, - year = {1991} -} - @InProceedings{Coq92, author = {Th. Coquand}, title = {{Pattern Matching with Dependent Types}}, @@ -286,49 +54,18 @@ s}, booktitle = {Proceedings of the 1992 Workshop on Types for Proofs and Programs} } -@InProceedings{Coquand93, - author = {Th. Coquand}, - booktitle = {Types for Proofs and Programs}, - editor = {H. Barendregt and T. Nipokow}, - publisher = SV, - series = LNCS, - title = {{Infinite objects in Type Theory}}, - volume = {806}, - year = {1993}, - pages = {62-78} -} - -@inproceedings{Corbineau08types, - author = {P. Corbineau}, - title = {A Declarative Language for the Coq Proof Assistant}, - editor = {M. Miculan and I. Scagnetto and F. Honsell}, - booktitle = {TYPES '07, Cividale del Friuli, Revised Selected Papers}, - publisher = {Springer}, - series = LNCS, - volume = {4941}, - year = {2007}, - pages = {69-84}, - ee = {http://dx.doi.org/10.1007/978-3-540-68103-8_5}, -} - -@PhDThesis{Cor97, - author = {C. Cornes}, - month = nov, - school = {{Universit\'e Paris 7}}, - title = {Conception d'un langage de haut niveau de représentation de preuves}, - type = {Th\`ese de Doctorat}, - year = {1997} -} - -@MastersThesis{Cou94a, - author = {J. Courant}, - month = sep, - school = {DEA d'Informatique, ENS Lyon}, - title = {Explicitation de preuves par r\'ecurrence implicite}, - year = {1994} +@InProceedings{DBLP:conf/types/CornesT95, + author = {Cristina Cornes and + Delphine Terrasse}, + title = {Automating Inversion of Inductive Predicates in Coq}, + booktitle = {TYPES}, + year = {1995}, + pages = {85-104}, + crossref = {DBLP:conf/types/1995}, + bibsource = {DBLP, http://dblp.uni-trier.de} } -@book{Cur58, +@Book{Cur58, author = {Haskell B. Curry and Robert Feys and William Craig}, title = {Combinatory Logic}, volume = 1, @@ -337,17 +74,40 @@ s}, note = {{\S{9E}}}, } -@InProceedings{Del99, - author = {Delahaye, D.}, - title = {Information Retrieval in a Coq Proof Library using - Type Isomorphisms}, - booktitle = {Proceedings of TYPES '99, L\"okeberg}, - publisher = SV, - series = lncs, - year = {1999}, - url = - "\\{\sf ftp://ftp.inria.fr/INRIA/Projects/coq/David.Delahaye/papers/}"# - "{\sf TYPES99-SIsos.ps.gz}" +@Article{CSlessadhoc, + author = {Gonthier, Georges and Ziliani, Beta and Nanevski, Aleksandar and Dreyer, Derek}, + title = {How to Make Ad Hoc Proof Automation Less Ad Hoc}, + journal = {SIGPLAN Not.}, + issue_date = {September 2011}, + volume = {46}, + number = {9}, + month = sep, + year = {2011}, + issn = {0362-1340}, + pages = {163--175}, + numpages = {13}, + url = {http://doi.acm.org/10.1145/2034574.2034798}, + doi = {10.1145/2034574.2034798}, + acmid = {2034798}, + publisher = {ACM}, + address = {New York, NY, USA}, + keywords = {canonical structures, coq, custom proof automation, hoare type theory, interactive theorem proving, tactics, type classes}, +} + +@InProceedings{CSwcu, + hal_id = {hal-00816703}, + url = {http://hal.inria.fr/hal-00816703}, + title = {{Canonical Structures for the working Coq user}}, + author = {Mahboubi, Assia and Tassi, Enrico}, + booktitle = {{ITP 2013, 4th Conference on Interactive Theorem Proving}}, + publisher = {Springer}, + pages = {19-34}, + address = {Rennes, France}, + volume = {7998}, + editor = {Sandrine Blazy and Christine Paulin and David Pichardie }, + series = {LNCS }, + doi = {10.1007/978-3-642-39634-2\_5 }, + year = {2013}, } @InProceedings{Del00, @@ -361,99 +121,7 @@ s}, pages = {85--95}, month = {November}, year = {2000}, - url = - "{\sf ftp://ftp.inria.fr/INRIA/Projects/coq/David.Delahaye/papers/}"# - "{\sf LPAR2000-ltac.ps.gz}" -} - -@InProceedings{DelMay01, - author = {Delahaye, D. and Mayero, M.}, - title = {{\tt Field}: une proc\'edure de d\'ecision pour les nombres r\'eels en {\Coq}}, - booktitle = {Journ\'ees Francophones des Langages Applicatifs, Pontarlier}, - publisher = {INRIA}, - month = {Janvier}, - year = {2001}, - url = - "\\{\sf ftp://ftp.inria.fr/INRIA/Projects/coq/David.Delahaye/papers/}"# - "{\sf JFLA2000-Field.ps.gz}" -} - -@TechReport{Dow90, - author = {G. Dowek}, - institution = {INRIA}, - number = {1283}, - title = {Naming and Scoping in a Mathematical Vernacular}, - type = {Research Report}, - year = {1990} -} - -@Article{Dow91a, - author = {G. Dowek}, - journal = {Compte-Rendus de l'Acad\'emie des Sciences}, - note = {The undecidability of Third Order Pattern Matching in Calculi with Dependent Types or Type Constructors}, - number = {12}, - pages = {951--956}, - title = {L'Ind\'ecidabilit\'e du Filtrage du Troisi\`eme Ordre dans les Calculs avec Types D\'ependants ou Constructeurs de Types}, - volume = {I, 312}, - year = {1991} -} - -@InProceedings{Dow91b, - author = {G. Dowek}, - booktitle = {Proceedings of Mathematical Foundation of Computer Science}, - note = {Also INRIA Research Report}, - pages = {151--160}, - publisher = SV, - series = LNCS, - title = {A Second Order Pattern Matching Algorithm in the Cube of Typed $\lambda$-calculi}, - volume = {520}, - year = {1991} -} - -@PhDThesis{Dow91c, - author = {G. Dowek}, - month = dec, - school = {Universit\'e Paris 7}, - title = {D\'emonstration automatique dans le Calcul des Constructions}, - year = {1991} -} - -@Article{Dow92a, - author = {G. Dowek}, - title = {The Undecidability of Pattern Matching in Calculi where Primitive Recursive Functions are Representable}, - year = 1993, - journal = {Theoretical Computer Science}, - volume = 107, - number = 2, - pages = {349-356} -} - -@Article{Dow94a, - author = {G. Dowek}, - journal = {Annals of Pure and Applied Logic}, - volume = {69}, - pages = {135--155}, - title = {Third order matching is decidable}, - year = {1994} -} - -@InProceedings{Dow94b, - author = {G. Dowek}, - booktitle = {Proceedings of the second international conference on typed lambda calculus and applications}, - title = {Lambda-calculus, Combinators and the Comprehension Schema}, - year = {1995} -} - -@InProceedings{Dyb91, - author = {P. Dybjer}, - booktitle = {Logical Frameworks}, - editor = {G. Huet and G. Plotkin}, - pages = {59--79}, - publisher = {Cambridge University Press}, - title = {Inductive sets and families in {Martin-Löf's} - Type Theory and their set-theoretic semantics: An inversion principle for {Martin-L\"of's} type theory}, - volume = {14}, - year = {1991} + url = {http://www.lirmm.fr/\%7Edelahaye/papers/ltac\%20(LPAR\%2700).pdf} } @Article{Dyc92, @@ -466,75 +134,6 @@ s}, year = {1992} } -@MastersThesis{Fil94, - author = {J.-C. Filli\^atre}, - month = sep, - school = {DEA d'Informatique, ENS Lyon}, - title = {Une proc\'edure de d\'ecision pour le Calcul des Pr\'edicats Direct. Étude et impl\'ementation dans le syst\`eme {\Coq}}, - year = {1994} -} - -@TechReport{Filliatre95, - author = {J.-C. Filli\^atre}, - institution = {LIP-ENS-Lyon}, - title = {A decision procedure for Direct Predicate Calculus}, - type = {Research report}, - number = {96--25}, - year = {1995} -} - -@Article{Filliatre03jfp, - author = {J.-C. Filliâtre}, - title = {Verification of Non-Functional Programs - using Interpretations in Type Theory}, - journal = jfp, - volume = 13, - number = 4, - pages = {709--745}, - month = jul, - year = 2003, - note = {[English translation of \cite{Filliatre99}]}, - url = {http://www.lri.fr/~filliatr/ftp/publis/jphd.ps.gz}, - topics = {team, lri}, - type_publi = {irevcomlec} -} - -@PhDThesis{Filliatre99, - author = {J.-C. Filli\^atre}, - title = {Preuve de programmes imp\'eratifs en th\'eorie des types}, - type = {Thèse de Doctorat}, - school = {Universit\'e Paris-Sud}, - year = 1999, - month = {July}, - url = {\url{http://www.lri.fr/~filliatr/ftp/publis/these.ps.gz}} -} - -@Unpublished{Filliatre99c, - author = {J.-C. Filli\^atre}, - title = {{Formal Proof of a Program: Find}}, - month = {January}, - year = 2000, - note = {Submitted to \emph{Science of Computer Programming}}, - url = {\url{http://www.lri.fr/~filliatr/ftp/publis/find.ps.gz}} -} - -@InProceedings{FilliatreMagaud99, - author = {J.-C. Filli\^atre and N. Magaud}, - title = {Certification of sorting algorithms in the system {\Coq}}, - booktitle = {Theorem Proving in Higher Order Logics: - Emerging Trends}, - year = 1999, - url = {\url{http://www.lri.fr/~filliatr/ftp/publis/Filliatre-Magaud.ps.gz}} -} - -@Unpublished{Fle90, - author = {E. Fleury}, - month = jul, - note = {Rapport de Stage}, - title = {Implantation des algorithmes de {Floyd et de Dijkstra} dans le {Calcul des Constructions}}, - year = {1990} -} - @Book{Fourier, author = {Jean-Baptiste-Joseph Fourier}, publisher = {Gauthier-Villars}, @@ -554,13 +153,6 @@ s}, year = {1994} } -@PhDThesis{Gim96, - author = {E. Gim\'enez}, - title = {Un calcul des constructions infinies et son application \'a la v\'erification de syst\`emes communicants}, - school = {\'Ecole Normale Sup\'erieure de Lyon}, - year = {1996} -} - @TechReport{Gim98, author = {E. Gim\'enez}, title = {A Tutorial on Recursive Types in Coq}, @@ -591,21 +183,6 @@ s}, year = {1995} } -@InProceedings{Gir70, - author = {J.-Y. Girard}, - booktitle = {Proceedings of the 2nd Scandinavian Logic Symposium}, - publisher = {North-Holland}, - title = {Une extension de l'interpr\'etation de {G\"odel} \`a l'analyse, et son application \`a l'\'elimination des coupures dans l'analyse et la th\'eorie des types}, - year = {1970} -} - -@PhDThesis{Gir72, - author = {J.-Y. Girard}, - school = {Universit\'e Paris~7}, - title = {Interpr\'etation fonctionnelle et \'elimination des coupures de l'arithm\'etique d'ordre sup\'erieur}, - year = {1972} -} - @Book{Gir89, author = {J.-Y. Girard and Y. Lafont and P. Taylor}, publisher = {Cambridge University Press}, @@ -614,32 +191,6 @@ s}, year = {1989} } -@TechReport{Har95, - author = {John Harrison}, - title = {Metatheory and Reflection in Theorem Proving: A Survey and Critique}, - institution = {SRI International Cambridge Computer Science Research Centre,}, - year = 1995, - type = {Technical Report}, - number = {CRC-053}, - abstract = {http://www.cl.cam.ac.uk/users/jrh/papers.html} -} - -@MastersThesis{Hir94, - author = {D. Hirschkoff}, - month = sep, - school = {DEA IARFA, Ecole des Ponts et Chauss\'ees, Paris}, - title = {Écriture d'une tactique arithm\'etique pour le syst\`eme {\Coq}}, - year = {1994} -} - -@InProceedings{HofStr98, - author = {Martin Hofmann and Thomas Streicher}, - title = {The groupoid interpretation of type theory}, - booktitle = {Proceedings of the meeting Twenty-five years of constructive type theory}, - publisher = {Oxford University Press}, - year = {1998} -} - @InCollection{How80, author = {W.A. Howard}, booktitle = {to H.B. Curry : Essays on Combinatory Logic, Lambda Calculus and Formalism.}, @@ -650,149 +201,31 @@ s}, year = {1980} } -@InProceedings{Hue87tapsoft, - author = {G. Huet}, - title = {Programming of Future Generation Computers}, - booktitle = {Proceedings of TAPSOFT87}, - series = LNCS, - volume = 249, - pages = {276--286}, - year = 1987, - publisher = SV -} - -@InProceedings{Hue87, - author = {G. Huet}, - booktitle = {Programming of Future Generation Computers}, - editor = {K. Fuchi and M. Nivat}, - note = {Also in \cite{Hue87tapsoft}}, - publisher = {Elsevier Science}, - title = {Induction Principles Formalized in the {Calculus of Constructions}}, - year = {1988} -} - @InProceedings{Hue88, author = {G. Huet}, booktitle = {A perspective in Theoretical Computer Science. Commemorative Volume for Gift Siromoney}, editor = {R. Narasimhan}, - note = {Also in~\cite{CoC89}}, publisher = {World Scientific Publishing}, title = {{The Constructive Engine}}, year = {1989} } -@Unpublished{Hue88b, - author = {G. Huet}, - title = {Extending the Calculus of Constructions with Type:Type}, - year = 1988, - note = {Unpublished} -} - -@Book{Hue89, - editor = {G. Huet}, - publisher = {Addison-Wesley}, - series = {The UT Year of Programming Series}, - title = {Logical Foundations of Functional Programming}, - year = {1989} -} - -@InProceedings{Hue92, - author = {G. Huet}, - booktitle = {Proceedings of 12th FST/TCS Conference, New Delhi}, - pages = {229--240}, - publisher = SV, - series = LNCS, - title = {The Gallina Specification Language : A case study}, - volume = {652}, - year = {1992} -} - -@Article{Hue94, - author = {G. Huet}, - journal = {J. Functional Programming}, - pages = {371--394}, - publisher = {Cambridge University Press}, - title = {Residual theory in $\lambda$-calculus: a formal development}, - volume = {4,3}, - year = {1994} -} - -@InCollection{HuetLevy79, - author = {G. Huet and J.-J. L\'{e}vy}, - title = {Call by Need Computations in Non-Ambigous -Linear Term Rewriting Systems}, - note = {Also research report 359, INRIA, 1979}, - booktitle = {Computational Logic, Essays in Honor of -Alan Robinson}, - editor = {J.-L. Lassez and G. Plotkin}, - publisher = {The MIT press}, - year = {1991} -} - -@Article{KeWe84, - author = {J. Ketonen and R. Weyhrauch}, - journal = {Theoretical Computer Science}, - pages = {297--307}, - title = {A decidable fragment of {P}redicate {C}alculus}, - volume = {32}, - year = {1984} -} - -@Book{Kle52, - author = {S.C. Kleene}, - publisher = {North-Holland}, - series = {Bibliotheca Mathematica}, - title = {Introduction to Metamathematics}, - year = {1952} -} - -@Book{Kri90, - author = {J.-L. Krivine}, - publisher = {Masson}, - series = {Etudes et recherche en informatique}, - title = {Lambda-calcul {types et mod\`eles}}, - year = {1990} -} - -@Book{LE92, - editor = {G. Huet and G. Plotkin}, - publisher = {Cambridge University Press}, - title = {Logical Environments}, - year = {1992} -} - -@Book{LF91, - editor = {G. Huet and G. Plotkin}, - publisher = {Cambridge University Press}, - title = {Logical Frameworks}, - year = {1991} -} - -@Article{Laville91, - author = {A. Laville}, - title = {Comparison of Priority Rules in Pattern -Matching and Term Rewriting}, - journal = {Journal of Symbolic Computation}, - volume = {11}, - pages = {321--347}, - year = {1991} -} - -@InProceedings{LePa94, - author = {F. Leclerc and C. Paulin-Mohring}, - booktitle = {{Types for Proofs and Programs, Types' 93}}, - editor = {H. Barendregt and T. Nipkow}, - publisher = SV, - series = {LNCS}, - title = {{Programming with Streams in Coq. A case study : The Sieve of Eratosthenes}}, - volume = {806}, - year = {1994} +@Article{LeeWerner11, + author = {Gyesik Lee and + Benjamin Werner}, + title = {Proof-irrelevant model of {CC} with predicative induction + and judgmental equality}, + journal = {Logical Methods in Computer Science}, + volume = {7}, + number = {4}, + year = {2011}, + ee = {http://dx.doi.org/10.2168/LMCS-7(4:5)2011}, + bibsource = {DBLP, http://dblp.uni-trier.de} } @TechReport{Leroy90, author = {X. Leroy}, - title = {The {ZINC} experiment: an economical implementation -of the {ML} language}, + title = {The {ZINC} experiment: an economical implementation of the {ML} language}, institution = {INRIA}, number = {117}, year = {1990} @@ -807,106 +240,23 @@ of the {ML} language}, url = {draft at \url{http://www.irif.fr/~letouzey/download/extraction2002.pdf}} } -@PhDThesis{Luo90, - author = {Z. Luo}, - title = {An Extended Calculus of Constructions}, - school = {University of Edinburgh}, - year = {1990} -} - -@inproceedings{Luttik97specificationof, - Author = {Sebastiaan P. Luttik and Eelco Visser}, - Booktitle = {2nd International Workshop on the Theory and Practice of Algebraic Specifications (ASF+SDF'97), Electronic Workshops in Computing}, - Publisher = {Springer-Verlag}, - Title = {Specification of Rewriting Strategies}, - Year = {1997}} - -@Book{MaL84, - author = {{P. Martin-L\"of}}, - publisher = {Bibliopolis}, - series = {Studies in Proof Theory}, - title = {Intuitionistic Type Theory}, - year = {1984} +@InProceedings{Luttik97specificationof, + author = {Sebastiaan P. Luttik and Eelco Visser}, + booktitle = {2nd International Workshop on the Theory and Practice of Algebraic Specifications (ASF+SDF'97), Electronic Workshops in Computing}, + publisher = {Springer-Verlag}, + title = {Specification of Rewriting Strategies}, + year = {1997} } -@Article{MaSi94, - author = {P. Manoury and M. Simonot}, - title = {Automatizing Termination Proofs of Recursively Defined Functions.}, - journal = {TCS}, - volume = {135}, - number = {2}, - year = {1994}, - pages = {319-343}, -} - -@InProceedings{Miquel00, - author = {A. Miquel}, - title = {A Model for Impredicative Type Systems with Universes, -Intersection Types and Subtyping}, - booktitle = {{Proceedings of the 15th Annual IEEE Symposium on Logic in Computer Science (LICS'00)}}, - publisher = {IEEE Computer Society Press}, - year = {2000} -} - -@PhDThesis{Miquel01a, - author = {A. Miquel}, - title = {Le Calcul des Constructions implicite: syntaxe et s\'emantique}, - month = {dec}, - school = {{Universit\'e Paris 7}}, - year = {2001} -} - -@InProceedings{Miquel01b, - author = {A. Miquel}, - title = {The Implicit Calculus of Constructions: Extending Pure Type Systems with an Intersection Type Binder and Subtyping}, - booktitle = {{Proceedings of the fifth International Conference on Typed Lambda Calculi and Applications (TLCA01), Krakow, Poland}}, - publisher = SV, - series = {LNCS}, - number = 2044, - year = {2001} -} - -@InProceedings{MiWer02, - author = {A. Miquel and B. Werner}, - title = {The Not So Simple Proof-Irrelevant Model of CC}, - booktitle = {TYPES}, - year = {2002}, - pages = {240-258}, - ee = {http://link.springer.de/link/service/series/0558/bibs/2646/26460240.htm}, - crossref = {DBLP:conf/types/2002}, - bibsource = {DBLP, http://dblp.uni-trier.de} -} - -@proceedings{DBLP:conf/types/2002, - editor = {H. Geuvers and F. Wiedijk}, - title = {Types for Proofs and Programs, Second International Workshop, - TYPES 2002, Berg en Dal, The Netherlands, April 24-28, 2002, - Selected Papers}, - booktitle = {TYPES}, - publisher = SV, - series = LNCS, - volume = {2646}, - year = {2003}, - isbn = {3-540-14031-X}, - bibsource = {DBLP, http://dblp.uni-trier.de} -} - -@InProceedings{Moh89a, - author = {C. Paulin-Mohring}, - address = {Austin}, - booktitle = {Sixteenth Annual ACM Symposium on Principles of Programming Languages}, - month = jan, - publisher = {ACM}, - title = {Extracting ${F}_{\omega}$'s programs from proofs in the {Calculus of Constructions}}, - year = {1989} -} - -@PhDThesis{Moh89b, - author = {C. Paulin-Mohring}, - month = jan, - school = {{Universit\'e Paris 7}}, - title = {Extraction de programmes dans le {Calcul des Constructions}}, - year = {1989} +@InProceedings{DBLP:conf/types/McBride00, + author = {Conor McBride}, + title = {Elimination with a Motive}, + booktitle = {TYPES}, + year = {2000}, + pages = {197-216}, + ee = {http://link.springer.de/link/service/series/0558/bibs/2277/22770197.htm}, + crossref = {DBLP:conf/types/2000}, + bibsource = {DBLP, http://dblp.uni-trier.de} } @InProceedings{Moh93, @@ -921,14 +271,6 @@ Intersection Types and Subtyping}, year = {1993} } -@Book{Moh97, - author = {C. Paulin-Mohring}, - month = jan, - publisher = {{ENS Lyon}}, - title = {{Le syst\`eme Coq. \mbox{Th\`ese d'habilitation}}}, - year = {1997} -} - @MastersThesis{Mun94, author = {C. Muñoz}, month = sep, @@ -937,73 +279,6 @@ Intersection Types and Subtyping}, year = {1994} } -@PhDThesis{Mun97d, - author = {C. Mu{\~{n}}oz}, - title = {Un calcul de substitutions pour la repr\'esentation - de preuves partielles en th\'eorie de types}, - school = {Universit\'e Paris 7}, - year = {1997}, - note = {Version en anglais disponible comme rapport de - recherche INRIA RR-3309}, - type = {Th\`ese de Doctorat} -} - -@Book{NoPS90, - author = {B. {Nordstr\"om} and K. Peterson and J. Smith}, - booktitle = {Information Processing 83}, - publisher = {Oxford Science Publications}, - series = {International Series of Monographs on Computer Science}, - title = {Programming in {Martin-L\"of's} Type Theory}, - year = {1990} -} - -@Article{Nor88, - author = {B. {Nordstr\"om}}, - journal = {BIT}, - title = {Terminating General Recursion}, - volume = {28}, - year = {1988} -} - -@Book{Odi90, - editor = {P. Odifreddi}, - publisher = {Academic Press}, - title = {Logic and Computer Science}, - year = {1990} -} - -@InProceedings{PaMS92, - author = {M. Parigot and P. Manoury and M. Simonot}, - address = {St. Petersburg, Russia}, - booktitle = {Logic Programming and automated reasoning}, - editor = {A. Voronkov}, - month = jul, - number = {624}, - publisher = SV, - series = {LNCS}, - title = {{ProPre : A Programming language with proofs}}, - year = {1992} -} - -@Article{PaWe92, - author = {C. Paulin-Mohring and B. Werner}, - journal = {Journal of Symbolic Computation}, - pages = {607--640}, - title = {{Synthesis of ML programs in the system Coq}}, - volume = {15}, - year = {1993} -} - -@Article{Par92, - author = {M. Parigot}, - journal = {Theoretical Computer Science}, - number = {2}, - pages = {335--356}, - title = {{Recursive Programming with Proofs}}, - volume = {94}, - year = {1992} -} - @InProceedings{Parent95b, author = {C. Parent}, booktitle = {{Mathematics of Program Construction'95}}, @@ -1015,14 +290,16 @@ the Calculus of Inductive Constructions}}, year = {1995} } -@InProceedings{Prasad93, - author = {K.V. Prasad}, - booktitle = {{Proceedings of CONCUR'93}}, - publisher = SV, - series = {LNCS}, - title = {{Programming with broadcasts}}, - volume = {715}, - year = {1993} +@Misc{Pcoq, + author = {Lemme Team}, + title = {Pcoq a graphical user-interface for {Coq}}, + note = {\url{http://www-sop.inria.fr/lemme/pcoq/}} +} + +@Misc{ProofGeneral, + author = {David Aspinall}, + title = {Proof General}, + note = {\url{https://proofgeneral.github.io/}} } @Book{RC95, @@ -1035,15 +312,6 @@ the Calculus of Inductive Constructions}}, note = {ISBN-0-8176-3763-X} } -@TechReport{Rou92, - author = {J. Rouyer}, - institution = {INRIA}, - month = nov, - number = {1795}, - title = {{Développement de l'Algorithme d'Unification dans le Calcul des Constructions}}, - year = {1992} -} - @Article{Rushby98, title = {Subtypes for Specifications: Predicate Subtyping in {PVS}}, @@ -1056,115 +324,7 @@ the Calculus of Inductive Constructions}}, year = 1998 } -@TechReport{Saibi94, - author = {A. Sa\"{\i}bi}, - institution = {INRIA}, - month = dec, - number = {2345}, - title = {{Axiomatization of a lambda-calculus with explicit-substitutions in the Coq System}}, - year = {1994} -} - - -@MastersThesis{Ter92, - author = {D. Terrasse}, - month = sep, - school = {IARFA}, - title = {{Traduction de TYPOL en COQ. Application \`a Mini ML}}, - year = {1992} -} - -@TechReport{ThBeKa92, - author = {L. Th\'ery and Y. Bertot and G. Kahn}, - institution = {INRIA Sophia}, - month = may, - number = {1684}, - title = {Real theorem provers deserve real user-interfaces}, - type = {Research Report}, - year = {1992} -} - -@Book{TrDa89, - author = {A.S. Troelstra and D. van Dalen}, - publisher = {North-Holland}, - series = {Studies in Logic and the foundations of Mathematics, volumes 121 and 123}, - title = {Constructivism in Mathematics, an introduction}, - year = {1988} -} - -@PhDThesis{Wer94, - author = {B. Werner}, - school = {Universit\'e Paris 7}, - title = {Une th\'eorie des constructions inductives}, - type = {Th\`ese de Doctorat}, - year = {1994} -} - -@PhDThesis{Bar99, - author = {B. Barras}, - school = {Universit\'e Paris 7}, - title = {Auto-validation d'un système de preuves avec familles inductives}, - type = {Th\`ese de Doctorat}, - year = {1999} -} - -@Unpublished{ddr98, - author = {D. de Rauglaudre}, - title = {Camlp4 version 1.07.2}, - year = {1998}, - note = {In Camlp4 distribution} -} - -@Article{dowek93, - author = {G. Dowek}, - title = {{A Complete Proof Synthesis Method for the Cube of Type Systems}}, - journal = {Journal Logic Computation}, - volume = {3}, - number = {3}, - pages = {287--315}, - month = {June}, - year = {1993} -} - -@InProceedings{manoury94, - author = {P. Manoury}, - title = {{A User's Friendly Syntax to Define -Recursive Functions as Typed $\lambda-$Terms}}, - booktitle = {{Types for Proofs and Programs, TYPES'94}}, - series = {LNCS}, - volume = {996}, - month = jun, - year = {1994} -} - -@TechReport{maranget94, - author = {L. Maranget}, - institution = {INRIA}, - number = {2385}, - title = {{Two Techniques for Compiling Lazy Pattern Matching}}, - year = {1994} -} - -@InProceedings{puel-suarez90, - author = {L.Puel and A. Su\'arez}, - booktitle = {{Conference Lisp and Functional Programming}}, - series = {ACM}, - publisher = SV, - title = {{Compiling Pattern Matching by Term -Decomposition}}, - year = {1990} -} - -@MastersThesis{saidi94, - author = {H. Saidi}, - month = sep, - school = {DEA d'Informatique Fondamentale, Universit\'e Paris 7}, - title = {R\'esolution d'\'equations dans le syst\`eme T - de G\"odel}, - year = {1994} -} - -@inproceedings{sozeau06, +@InProceedings{sozeau06, author = {Matthieu Sozeau}, title = {Subset Coercions in {C}oq}, year = {2007}, @@ -1175,7 +335,7 @@ Decomposition}}, series = {LNCS} } -@inproceedings{sozeau08, +@InProceedings{sozeau08, Author = {Matthieu Sozeau and Nicolas Oury}, booktitle = {TPHOLs'08}, Pdf = {http://www.lri.fr/~sozeau/research/publications/drafts/classes.pdf}, @@ -1183,96 +343,7 @@ Decomposition}}, Year = {2008}, } -@Misc{streicher93semantical, - author = {T. Streicher}, - title = {Semantical Investigations into Intensional Type Theory}, - note = {Habilitationsschrift, LMU Munchen.}, - year = {1993} -} - -@Misc{Pcoq, - author = {Lemme Team}, - title = {Pcoq a graphical user-interface for {Coq}}, - note = {\url{http://www-sop.inria.fr/lemme/pcoq/}} -} - -@Misc{ProofGeneral, - author = {David Aspinall}, - title = {Proof General}, - note = {\url{https://proofgeneral.github.io/}} -} - -@Book{CoqArt, - title = {Interactive Theorem Proving and Program Development. - Coq'Art: The Calculus of Inductive Constructions}, - author = {Yves Bertot and Pierre Castéran}, - publisher = {Springer Verlag}, - series = {Texts in Theoretical Computer Science. An EATCS series}, - year = 2004 -} - -@InCollection{wadler87, - author = {P. Wadler}, - title = {Efficient Compilation of Pattern Matching}, - booktitle = {The Implementation of Functional Programming -Languages}, - editor = {S.L. Peyton Jones}, - publisher = {Prentice-Hall}, - year = {1987} -} - -@inproceedings{DBLP:conf/types/CornesT95, - author = {Cristina Cornes and - Delphine Terrasse}, - title = {Automating Inversion of Inductive Predicates in Coq}, - booktitle = {TYPES}, - year = {1995}, - pages = {85-104}, - crossref = {DBLP:conf/types/1995}, - bibsource = {DBLP, http://dblp.uni-trier.de} -} -@proceedings{DBLP:conf/types/1995, - editor = {Stefano Berardi and - Mario Coppo}, - title = {Types for Proofs and Programs, International Workshop TYPES'95, - Torino, Italy, June 5-8, 1995, Selected Papers}, - booktitle = {TYPES}, - publisher = {Springer}, - series = {Lecture Notes in Computer Science}, - volume = {1158}, - year = {1996}, - isbn = {3-540-61780-9}, - bibsource = {DBLP, http://dblp.uni-trier.de} -} - -@inproceedings{DBLP:conf/types/McBride00, - author = {Conor McBride}, - title = {Elimination with a Motive}, - booktitle = {TYPES}, - year = {2000}, - pages = {197-216}, - ee = {http://link.springer.de/link/service/series/0558/bibs/2277/22770197.htm}, - crossref = {DBLP:conf/types/2000}, - bibsource = {DBLP, http://dblp.uni-trier.de} -} - -@proceedings{DBLP:conf/types/2000, - editor = {Paul Callaghan and - Zhaohui Luo and - James McKinna and - Robert Pollack}, - title = {Types for Proofs and Programs, International Workshop, TYPES - 2000, Durham, UK, December 8-12, 2000, Selected Papers}, - booktitle = {TYPES}, - publisher = {Springer}, - series = {Lecture Notes in Computer Science}, - volume = {2277}, - year = {2002}, - isbn = {3-540-43287-6}, - bibsource = {DBLP, http://dblp.uni-trier.de} -} - -@INPROCEEDINGS{sugar, +@InProceedings{sugar, author = {Alessandro Giovini and Teo Mora and Gianfranco Niesi and Lorenzo Robbiano and Carlo Traverso}, title = {"One sugar cube, please" or Selection strategies in the Buchberger algorithm}, booktitle = { Proceedings of the ISSAC'91, ACM Press}, @@ -1281,38 +352,7 @@ Languages}, publisher = {} } -@article{LeeWerner11, - author = {Gyesik Lee and - Benjamin Werner}, - title = {Proof-irrelevant model of {CC} with predicative induction - and judgmental equality}, - journal = {Logical Methods in Computer Science}, - volume = {7}, - number = {4}, - year = {2011}, - ee = {http://dx.doi.org/10.2168/LMCS-7(4:5)2011}, - bibsource = {DBLP, http://dblp.uni-trier.de} -} - -@Comment{cross-references, must be at end} - -@Book{Bastad92, - editor = {B. Nordstr\"om and K. Petersson and G. Plotkin}, - publisher = {Available by ftp at site ftp.inria.fr}, - title = {Proceedings of the 1992 Workshop on Types for Proofs and Programs}, - year = {1992} -} - -@Book{Nijmegen93, - editor = {H. Barendregt and T. Nipkow}, - publisher = SV, - series = LNCS, - title = {Types for Proofs and Programs}, - volume = {806}, - year = {1994} -} - -@article{TheOmegaPaper, +@Article{TheOmegaPaper, author = "W. Pugh", title = "The Omega test: a fast and practical integer programming algorithm for dependence analysis", journal = "Communication of the ACM", @@ -1320,43 +360,15 @@ Languages}, year = "1992", } -@inproceedings{CSwcu, - hal_id = {hal-00816703}, - url = {http://hal.inria.fr/hal-00816703}, - title = {{Canonical Structures for the working Coq user}}, - author = {Mahboubi, Assia and Tassi, Enrico}, - booktitle = {{ITP 2013, 4th Conference on Interactive Theorem Proving}}, - publisher = {Springer}, - pages = {19-34}, - address = {Rennes, France}, - volume = {7998}, - editor = {Sandrine Blazy and Christine Paulin and David Pichardie }, - series = {LNCS }, - doi = {10.1007/978-3-642-39634-2\_5 }, - year = {2013}, -} - -@article{CSlessadhoc, - author = {Gonthier, Georges and Ziliani, Beta and Nanevski, Aleksandar and Dreyer, Derek}, - title = {How to Make Ad Hoc Proof Automation Less Ad Hoc}, - journal = {SIGPLAN Not.}, - issue_date = {September 2011}, - volume = {46}, - number = {9}, - month = sep, - year = {2011}, - issn = {0362-1340}, - pages = {163--175}, - numpages = {13}, - url = {http://doi.acm.org/10.1145/2034574.2034798}, - doi = {10.1145/2034574.2034798}, - acmid = {2034798}, - publisher = {ACM}, - address = {New York, NY, USA}, - keywords = {canonical structures, coq, custom proof automation, hoare type theory, interactive theorem proving, tactics, type classes}, +@PhDThesis{Wer94, + author = {B. Werner}, + school = {Universit\'e Paris 7}, + title = {Une th\'eorie des constructions inductives}, + type = {Th\`ese de Doctorat}, + year = {1994} } -@inproceedings{CompiledStrongReduction, +@InProceedings{CompiledStrongReduction, author = {Benjamin Gr{\'{e}}goire and Xavier Leroy}, editor = {Mitchell Wand and @@ -1375,7 +387,7 @@ Languages}, bibsource = {dblp computer science bibliography, http://dblp.org} } -@inproceedings{FullReduction, +@InProceedings{FullReduction, author = {Mathieu Boespflug and Maxime D{\'{e}}n{\`{e}}s and Benjamin Gr{\'{e}}goire}, diff --git a/doc/sphinx/conf.py b/doc/sphinx/conf.py index 23bc9a2e4..f65400e88 100755 --- a/doc/sphinx/conf.py +++ b/doc/sphinx/conf.py @@ -51,6 +51,10 @@ extensions = [ 'coqrst.coqdomain' ] +# Change this to "info" or "warning" to get notifications about undocumented Coq +# objects (objects with no contents). +report_undocumented_coq_objects = None + # Add any paths that contain templates here, relative to this directory. templates_path = ['_templates'] @@ -96,11 +100,13 @@ language = None # directories to ignore when looking for source files. # This patterns also effect to html_static_path and html_extra_path exclude_patterns = [ - '_build', - 'Thumbs.db', - '.DS_Store', - 'introduction.rst', - 'credits.rst' + '_build', + 'Thumbs.db', + '.DS_Store', + 'introduction.rst', + 'credits.rst', + 'README.rst', + 'README.template.rst' ] # The reST default role (used for this markup: `text`) to use for all diff --git a/doc/sphinx/credits.rst b/doc/sphinx/credits.rst index fac0d0a4f..a75659798 100644 --- a/doc/sphinx/credits.rst +++ b/doc/sphinx/credits.rst @@ -1307,9 +1307,9 @@ features and deprecations, cleanups of the internals of the system along with a few new features. The main user visible changes are: - Kernel: fix a subject reduction failure due to allowing fixpoints - on non-recursive values, which allows to recover full parametricity - for CIC, by Matthieu Sozeau. Handling of evars in the VM (the kernel - still does not accept evars) by Pierre-Marie Pédrot. + on non-recursive values, by Matthieu Sozeau. + Handling of evars in the VM (the kernel still does not accept evars) + by Pierre-Marie Pédrot. - Notations: many improvements on recursive notations and support for destructuring patterns in the syntax of notations by Hugo Herbelin. @@ -1338,7 +1338,14 @@ with a few new features. The main user visible changes are: - Documentation: a large community effort resulted in the migration of the reference manual to the Sphinx documentation tool. The result - is this manual. + is this manual. The new documentation infrastructure (based on Sphinx) + is by Clément Pit-Claudel. The migration was coordinated by Maxime Dénès + and Paul Steckler, with some help of Théo Zimmermann during the + final integration phase. The 14 people who ported the manual are + Calvin Beck, Heiko Becker, Yves Bertot, Maxime Dénès, Richard Ford, + Pierre Letouzey, Assia Mahboubi, Clément Pit-Claudel, + Laurence Rideau, Matthieu Sozeau, Paul Steckler, Enrico Tassi, + Laurent Théry, Nikita Zyuzin. - Tools: experimental ``-mangle-names`` option to coqtop/coqc for linting proof scripts, by Jasper Hugunin. @@ -1366,17 +1373,16 @@ The OPAM repository for |Coq| packages has been maintained by Guillaume Melquiond, Matthieu Sozeau, Enrico Tassi with contributions from many users. A list of packages is available at https://coq.inria.fr/opam/www. -The 40 contributors for this version are Yves Bertot, Joachim -Breitner, Tej Chajed, Arthur Charguéraud, Jacques-Pascal Deplaix, Maxime -Dénès, Jim Fehrle, Yannick Forster, Gaëtan Gilbert, Jason Gross, Samuel -Gruetter, Thomas Hebb, Hugo Herbelin, Jasper Hugunin, Emilio Jesus -Gallego Arias, Ralf Jung, Johannes Kloos, Matej Košík, Robbert Krebbers, -Tony Beta Lambda, Vincent Laporte, Pierre Letouzey, Farzon Lotfi, -Cyprien Mangin, Guillaume Melquiond, Raphaël Monat, Carl Patenaude -Poulin, Pierre-Marie Pédrot, Matthew Ryan, Matt Quinn, Sigurd Schneider, -Bernhard Schommer, Matthieu Sozeau, Arnaud Spiwack, Paul Steckler, -Enrico Tassi, Anton Trunov, Martin Vassor, Vadim Zaliva and Théo -Zimmermann. +The 44 contributors for this version are Yves Bertot, Joachim Breitner, Tej +Chajed, Arthur Charguéraud, Jacques-Pascal Deplaix, Maxime Dénès, Jim Fehrle, +Julien Forest, Yannick Forster, Gaëtan Gilbert, Jason Gross, Samuel Gruetter, +Thomas Hebb, Hugo Herbelin, Jasper Hugunin, Emilio Jesus Gallego Arias, Ralf +Jung, Johannes Kloos, Matej Košík, Robbert Krebbers, Tony Beta Lambda, Vincent +Laporte, Peter LeFanu Lumsdaine, Pierre Letouzey, Farzon Lotfi, Cyprien Mangin, +Guillaume Melquiond, Raphaël Monat, Carl Patenaude Poulin, Pierre-Marie Pédrot, +Clément Pit-Claudel, Matthew Ryan, Matt Quinn, Sigurd Schneider, Bernhard +Schommer, Michael Soegtrop, Matthieu Sozeau, Arnaud Spiwack, Paul Steckler, +Enrico Tassi, Anton Trunov, Martin Vassor, Vadim Zaliva and Théo Zimmermann. Version 8.8 is the third release of |Coq| developed on a time-based development cycle. Its development spanned 6 months from the release of diff --git a/doc/sphinx/index.rst b/doc/sphinx/index.rst index db03693ff..136f9088b 100644 --- a/doc/sphinx/index.rst +++ b/doc/sphinx/index.rst @@ -3,9 +3,6 @@ .. include:: preamble.rst .. include:: replaces.rst -Introduction -=========================================== - .. include:: introduction.rst .. include:: credits.rst @@ -16,6 +13,7 @@ Table of contents .. toctree:: :caption: The language + language/gallina-specification-language language/gallina-extensions language/coq-library language/cic @@ -24,7 +22,10 @@ Table of contents .. toctree:: :caption: The proof engine + proof-engine/vernacular-commands + proof-engine/proof-handling proof-engine/tactics + proof-engine/ltac proof-engine/detailed-tactic-examples proof-engine/ssreflect-proof-language @@ -38,6 +39,7 @@ Table of contents :caption: Practical tools practical-tools/coq-commands + practical-tools/utilities practical-tools/coqide .. toctree:: @@ -56,6 +58,7 @@ Table of contents addendum/generalized-rewriting addendum/parallel-proof-processing addendum/miscellaneous-extensions + addendum/universe-polymorphism .. toctree:: :caption: Reference diff --git a/doc/sphinx/introduction.rst b/doc/sphinx/introduction.rst index 514745c1b..75ff72c4d 100644 --- a/doc/sphinx/introduction.rst +++ b/doc/sphinx/introduction.rst @@ -2,12 +2,11 @@ Introduction ------------------------ -This document is the Reference Manual of version of the |Coq| proof -assistant. A companion volume, the |Coq| Tutorial, is provided for the -beginners. It is advised to read the Tutorial first. A -book :cite:`CoqArt` on practical uses of the |Coq| system was -published in 2004 and is a good support for both the beginner and the -advanced user. +This document is the Reference Manual of the |Coq| proof assistant. +To start using Coq, it is advised to first read a tutorial. +Links to several tutorials can be found at +https://coq.inria.fr/documentation (see also +https://github.com/coq/coq/wiki#coq-tutorials). The |Coq| system is designed to develop mathematical proofs, and especially to write formal specifications, programs and to verify that @@ -60,7 +59,7 @@ continuous reading. However, it has some structure that is explained below. - The first part describes the specification language, |Gallina|. - Chapters :ref:`thegallinaspecificationlanguage` and :ref:`extensionsofgallina` describe the concrete + Chapters :ref:`gallinaspecificationlanguage` and :ref:`extensionsofgallina` describe the concrete syntax as well as the meaning of programs, theorems and proofs in the Calculus of Inductive Constructions. Chapter :ref:`thecoqlibrary` describes the standard library of |Coq|. Chapter :ref:`calculusofinductiveconstructions` is a mathematical description @@ -76,7 +75,7 @@ below. Chapter :ref:`proofhandling`. In Chapter :ref:`tactics`, all commands that realize one or more steps of the proof are presented: we call them *tactics*. The language to combine these tactics into complex proof - strategies is given in Chapter :ref:`thetacticlanguage`. Examples of tactics + strategies is given in Chapter :ref:`ltac`. Examples of tactics are described in Chapter :ref:`detailedexamplesoftactics`. - The third part describes how to extend the syntax of |Coq|. It diff --git a/doc/sphinx/language/cic.rst b/doc/sphinx/language/cic.rst index 7ed652409..f6bab0267 100644 --- a/doc/sphinx/language/cic.rst +++ b/doc/sphinx/language/cic.rst @@ -97,7 +97,7 @@ ensure the existence of a mapping of the universes to the positive integers, the graph of constraints must remain acyclic. Typing expressions that violate the acyclicity of the graph of constraints results in a Universe inconsistency error (see also Section -:ref:`TODO-2.10`). +:ref:`printing-universes`). .. _Terms: @@ -373,19 +373,22 @@ following rules. -**Remark**: **Prod-Prop** and **Prod-Set** typing-rules make sense if we consider the -semantic difference between :math:`\Prop` and :math:`\Set`: +.. note:: + **Prod-Prop** and **Prod-Set** typing-rules make sense if we consider the + semantic difference between :math:`\Prop` and :math:`\Set`: -+ All values of a type that has a sort :math:`\Set` are extractable. -+ No values of a type that has a sort :math:`\Prop` are extractable. + + All values of a type that has a sort :math:`\Set` are extractable. + + No values of a type that has a sort :math:`\Prop` are extractable. -**Remark**: We may have :math:`\letin{x}{t:T}{u}` well-typed without having -:math:`((λ x:T.u) t)` well-typed (where :math:`T` is a type of -:math:`t`). This is because the value :math:`t` associated to -:math:`x` may be used in a conversion rule (see Section :ref:`Conversion-rules`). +.. note:: + We may have :math:`\letin{x}{t:T}{u}` well-typed without having + :math:`((λ x:T.u) t)` well-typed (where :math:`T` is a type of + :math:`t`). This is because the value :math:`t` associated to + :math:`x` may be used in a conversion rule + (see Section :ref:`Conversion-rules`). .. _Conversion-rules: @@ -398,9 +401,11 @@ can decide if two programs are *intentionally* equal (one says *convertible*). Convertibility is described in this section. -.. _β-reduction: +.. _beta-reduction: + +β-reduction +~~~~~~~~~~~ -**β-reduction.** We want to be able to identify some terms as we can identify the application of a function to a given argument with its result. For instance the identity function over a given type T can be written @@ -424,9 +429,11 @@ theoretically of great importance but we will not detail them here and refer the interested reader to :cite:`Coq85`. -.. _ι-reduction: +.. _iota-reduction: + +ι-reduction +~~~~~~~~~~~ -**ι-reduction.** A specific conversion rule is associated to the inductive objects in the global environment. We shall give later on (see Section :ref:`Well-formed-inductive-definitions`) the precise rules but it @@ -435,9 +442,11 @@ constructor behaves as expected. This reduction is called ι-reduction and is more precisely studied in :cite:`Moh93,Wer94`. -.. _δ-reduction: +.. _delta-reduction: + +δ-reduction +~~~~~~~~~~~ -**δ-reduction.** We may have variables defined in local contexts or constants defined in the global environment. It is legal to identify such a reference with its value, that is to expand (or unfold) it into its value. This @@ -458,9 +467,11 @@ reduction is called δ-reduction and shows as follows. E[Γ] ⊢ c~\triangleright_δ~t -.. _ζ-reduction: +.. _zeta-reduction: + +ζ-reduction +~~~~~~~~~~~ -**ζ-reduction.** |Coq| allows also to remove local definitions occurring in terms by replacing the defined variable by its value. The declaration being destroyed, this reduction differs from δ-reduction. It is called @@ -475,9 +486,11 @@ destroyed, this reduction differs from δ-reduction. It is called E[Γ] ⊢ \letin{x}{u}{t}~\triangleright_ζ~\subst{t}{x}{u} -.. _η-expansion: +.. _eta-expansion: + +η-expansion +~~~~~~~~~~~ -**η-expansion.** Another important concept is η-expansion. It is legal to identify any term :math:`t` of functional type :math:`∀ x:T, U` with its so-called η-expansion @@ -487,34 +500,38 @@ term :math:`t` of functional type :math:`∀ x:T, U` with its so-called η-expan for :math:`x` an arbitrary variable name fresh in :math:`t`. -**Remark**: We deliberately do not define η-reduction: +.. note:: -.. math:: - λ x:T. (t~x) \not\triangleright_η t + We deliberately do not define η-reduction: -This is because, in general, the type of :math:`t` need not to be convertible -to the type of :math:`λ x:T. (t~x)`. E.g., if we take :math:`f` such that: + .. math:: + λ x:T. (t~x) \not\triangleright_η t -.. math:: - f : ∀ x:\Type(2),\Type(1) + This is because, in general, the type of :math:`t` need not to be convertible + to the type of :math:`λ x:T. (t~x)`. E.g., if we take :math:`f` such that: + + .. math:: + f : ∀ x:\Type(2),\Type(1) -then + then -.. math:: - λ x:\Type(1),(f~x) : ∀ x:\Type(1),\Type(1) + .. math:: + λ x:\Type(1),(f~x) : ∀ x:\Type(1),\Type(1) -We could not allow + We could not allow -.. math:: - λ x:Type(1),(f x) \triangleright_η f + .. math:: + λ x:Type(1),(f x) \triangleright_η f -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).` + 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).` + +.. _convertibility: -.. _Convertibility: +Convertibility +~~~~~~~~~~~~~~ -**Convertibility.** Let us write :math:`E[Γ] ⊢ t \triangleright u` for the contextual closure of the relation :math:`t` reduces to :math:`u` in the global environment :math:`E` and local context :math:`Γ` with one of the previous @@ -704,8 +721,6 @@ called the *context of parameters*. Furthermore, we must have that each :math:`T` in :math:`(t:T)∈Γ_I` can be written as: :math:`∀Γ_P,∀Γ_{\mathit{Arr}(t)}, S` where :math:`Γ_{\mathit{Arr}(t)}` is called the *Arity* of the inductive type t and :math:`S` is called the sort of the inductive type t (not to be confused with :math:`\Sort` which is the set of sorts). - - ** Examples** The declaration for parameterized lists is: .. math:: @@ -794,18 +809,18 @@ contains an inductive declaration. --------------------- E[Γ] ⊢ c : C -**Example.** -Provided that our environment :math:`E` contains inductive definitions we showed before, -these two inference rules above enable us to conclude that: +.. example:: + Provided that our environment :math:`E` contains inductive definitions we showed before, + these two inference rules above enable us to conclude that: -.. math:: - \begin{array}{l} + .. math:: + \begin{array}{l} E[Γ] ⊢ \even : \nat→\Prop\\ E[Γ] ⊢ \odd : \nat→\Prop\\ E[Γ] ⊢ \even\_O : \even~O\\ E[Γ] ⊢ \even\_S : \forall~n:\nat, \odd~n → \even~(S~n)\\ E[Γ] ⊢ \odd\_S : \forall~n:\nat, \even~n → \odd~(S~n) - \end{array} + \end{array} @@ -820,8 +835,9 @@ to inconsistent systems. We restrict ourselves to definitions which satisfy a syntactic criterion of positivity. Before giving the formal rules, we need a few definitions: +Arity of a given sort ++++++++++++++++++++++ -**Type is an Arity of Sort S.** A type :math:`T` is an *arity of sort s* if it converts to the sort s or to a product :math:`∀ x:T,U` with :math:`U` an arity of sort s. @@ -831,7 +847,8 @@ product :math:`∀ x:T,U` with :math:`U` an arity of sort s. :math:`\Prop`. -**Type is an Arity.** +Arity ++++++ A type :math:`T` is an *arity* if there is a :math:`s∈ \Sort` such that :math:`T` is an arity of sort s. @@ -841,32 +858,34 @@ sort s. :math:`A→ Set` and :math:`∀ A:\Prop,A→ \Prop` are arities. -**Type of Constructor of I.** +Type constructor +++++++++++++++++ We say that T is a *type of constructor of I* in one of the following two cases: - + :math:`T` is :math:`(I~t_1 … t_n )` + :math:`T` is :math:`∀ x:U,T'` where :math:`T'` is also a type of constructor of :math:`I` - - .. example:: :math:`\nat` and :math:`\nat→\nat` are types of constructor of :math:`\nat`. :math:`∀ A:Type,\List~A` and :math:`∀ A:Type,A→\List~A→\List~A` are types of constructor of :math:`\List`. -**Positivity Condition.** +.. _positivity: + +Positivity Condition +++++++++++++++++++++ + The type of constructor :math:`T` will be said to *satisfy the positivity condition* for a constant :math:`X` in the following cases: - + :math:`T=(X~t_1 … t_n )` and :math:`X` does not occur free in any :math:`t_i` + :math:`T=∀ x:U,V` and :math:`X` occurs only strictly positively in :math:`U` and the type :math:`V` satisfies the positivity condition for :math:`X`. - -**Occurs Strictly Positively.** +Strict positivity ++++++++++++++++++ + The constant :math:`X` *occurs strictly positively* in :math:`T` in the following cases: @@ -886,63 +905,51 @@ cases: any of the :math:`t_i`, and the (instantiated) types of constructor :math:`\subst{C_i}{p_j}{a_j}_{j=1… m}` of :math:`I` satisfy the nested positivity condition for :math:`X` -**Nested Positivity Condition.** +Nested Positivity ++++++++++++++++++ + The type of constructor :math:`T` of :math:`I` *satisfies the nested positivity condition* for a constant :math:`X` in the following cases: - + :math:`T=(I~b_1 … b_m~u_1 … u_p)`, :math:`I` is an inductive definition with :math:`m` parameters and :math:`X` does not occur in any :math:`u_i` + :math:`T=∀ x:U,V` and :math:`X` occurs only strictly positively in :math:`U` and the type :math:`V` satisfies the nested positivity condition for :math:`X` -For instance, if one considers the type - .. example:: - .. coqtop:: all + For instance, if one considers the following variant of a tree type + branching over the natural numbers: - Module TreeExample. - Inductive tree (A:Type) : Type := - | leaf : tree A - | node : A -> (nat -> tree A) -> tree A. + .. coqtop:: in + + Inductive nattree (A:Type) : Type := + | leaf : nattree A + | node : A -> (nat -> nattree A) -> nattree A. End TreeExample. -:: + Then every instantiated constructor of ``nattree A`` satisfies the nested positivity + condition for ``nattree``: - [TODO Note: This commentary does not seem to correspond to the - preceding example. Instead it is referring to the first example - in Inductive Definitions section. It seems we should either - delete the preceding example and refer the the example above of - type `list A`, or else we should rewrite the commentary below.] - - Then every instantiated constructor of list A satisfies the nested positivity - condition for list - │ - ├─ concerning type list A of constructor nil: - │ Type list A of constructor nil satisfies the positivity condition for list - │ because list does not appear in any (real) arguments of the type of that - | constructor (primarily because list does not have any (real) - | arguments) ... (bullet 1) - │ - ╰─ concerning type ∀ A → list A → list A of constructor cons: - Type ∀ A : Type, A → list A → list A of constructor cons - satisfies the positivity condition for list because: - │ - ├─ list occurs only strictly positively in Type ... (bullet 3) - │ - ├─ list occurs only strictly positively in A ... (bullet 3) - │ - ├─ list occurs only strictly positively in list A ... (bullet 4) - │ - ╰─ list satisfies the positivity condition for list A ... (bullet 1) + + Type ``nattree A`` of constructor ``leaf`` satisfies the positivity condition for + ``nattree`` because ``nattree`` does not appear in any (real) arguments of the + type of that constructor (primarily because ``nattree`` does not have any (real) + arguments) ... (bullet 1) + + + Type ``A → (nat → nattree A) → nattree A`` of constructor ``node`` satisfies the + positivity condition for ``nattree`` because: + - ``nattree`` occurs only strictly positively in ``A`` ... (bullet 3) + - ``nattree`` occurs only strictly positively in ``nat → nattree A`` ... (bullet 3 + 2) + - ``nattree`` satisfies the positivity condition for ``nattree A`` ... (bullet 1) .. _Correctness-rules: -**Correctness rules.** +Correctness rules ++++++++++++++++++ + We shall now describe the rules allowing the introduction of a new inductive definition. @@ -1009,7 +1016,9 @@ has type :math:`\Type(k)` with :math:`k<j` and :math:`k≤ i`. .. _Template-polymorphism: -**Template polymorphism.** +Template polymorphism ++++++++++++++++++++++ + Inductive types declared in Type are polymorphic over their arguments in Type. If :math:`A` is an arity of some sort and s is a sort, we write :math:`A_{/s}` for the arity obtained from :math:`A` by replacing its sort with s. @@ -1053,7 +1062,7 @@ provided that the following side conditions hold: we have :math:`(E[Γ_{I′} ;Γ_{P′}] ⊢ C_i : s_{q_i})_{i=1… n}` ; + the sorts :math:`s_i` are such that all eliminations, to :math:`\Prop`, :math:`\Set` and :math:`\Type(j)`, are allowed - (see Section Destructors_). + (see Section :ref:`Destructors`). @@ -1083,14 +1092,14 @@ The sorts :math:`s_j` are chosen canonically so that each :math:`s_j` is minimal respect to the hierarchy :math:`\Prop ⊂ \Set_p ⊂ \Type` where :math:`\Set_p` is predicative :math:`\Set`. More precisely, an empty or small singleton inductive definition (i.e. an inductive definition of which all inductive types are -singleton – see paragraph Destructors_) is set in :math:`\Prop`, a small non-singleton +singleton – see Section :ref:`Destructors`) is set in :math:`\Prop`, a small non-singleton inductive type is set in :math:`\Set` (even in case :math:`\Set` is impredicative – see Section The-Calculus-of-Inductive-Construction-with-impredicative-Set_), and otherwise in the Type hierarchy. Note that the side-condition about allowed elimination sorts in the rule **Ind-Family** is just to avoid to recompute the allowed elimination -sorts at each instance of a pattern-matching (see section Destructors_). As +sorts at each instance of a pattern-matching (see Section :ref:`Destructors`). As an example, let us consider the following definition: .. example:: @@ -1106,7 +1115,7 @@ in the Type hierarchy. Here, the parameter :math:`A` has this property, hence, if :g:`option` is applied to a type in :math:`\Set`, the result is in :math:`\Set`. Note that if :g:`option` is applied to a type in :math:`\Prop`, then, the result is not set in :math:`\Prop` but in :math:`\Set` still. This is because :g:`option` is not a singleton type -(see section Destructors_) and it would lose the elimination to :math:`\Set` and :math:`\Type` +(see Section :ref:`Destructors`) and it would lose the elimination to :math:`\Set` and :math:`\Type` if set in :math:`\Prop`. .. example:: @@ -1135,9 +1144,10 @@ eliminations schemes are allowed. Check (fun (A:Prop) (B:Set) => prod A B). Check (fun (A:Type) (B:Prop) => prod A B). -Remark: Template polymorphism used to be called “sort-polymorphism of -inductive types” before universe polymorphism (see Chapter :ref:`polymorphicuniverses`) was -introduced. +.. note:: + Template polymorphism used to be called “sort-polymorphism of + inductive types” before universe polymorphism + (see Chapter :ref:`polymorphicuniverses`) was introduced. .. _Destructors: @@ -1213,9 +1223,11 @@ Coquand in :cite:`Coq92`. One is the definition by pattern-matching. The second one is a definition by guarded fixpoints. -.. _The-match…with-end-construction: +.. _match-construction: + +The match ... with ... end construction ++++++++++++++++++++++++++++++++++++++++ -**The match…with …end construction** The basic idea of this operator is that we have an object :math:`m` in an inductive type :math:`I` and we want to prove a property which possibly depends on :math:`m`. For this, it is enough to prove the property for @@ -1272,7 +1284,7 @@ and :math:`I:A` and :math:`λ a x . P : B` then by :math:`[I:A|B]` we mean that :math:`λ a x . P` with :math:`m` in the above match-construct. -.. _Notations: +.. _cic_notations: **Notations.** The :math:`[I:A|B]` is defined as the smallest relation satisfying the following rules: We write :math:`[I|B]` for :math:`[I:A|B]` where :math:`A` is the type of :math:`I`. @@ -1473,20 +1485,20 @@ definition :math:`\ind{r}{Γ_I}{Γ_C}` with :math:`Γ_C = [c_1 :C_1 ;…;c_n :C_ -**Example.** -Below is a typing rule for the term shown in the previous example: +.. example:: + Below is a typing rule for the term shown in the previous example: -.. inference:: list example + .. inference:: list example - \begin{array}{l} - E[Γ] ⊢ t : (\List ~\nat) \\ - E[Γ] ⊢ P : B \\ - [(\List ~\nat)|B] \\ - E[Γ] ⊢ f_1 : {(\kw{nil} ~\nat)}^P \\ - E[Γ] ⊢ f_2 : {(\kw{cons} ~\nat)}^P - \end{array} - ------------------------------------------------ - E[Γ] ⊢ \case(t,P,f_1 |f_2 ) : (P~t) + \begin{array}{l} + E[Γ] ⊢ t : (\List ~\nat) \\ + E[Γ] ⊢ P : B \\ + [(\List ~\nat)|B] \\ + E[Γ] ⊢ f_1 : {(\kw{nil} ~\nat)}^P \\ + E[Γ] ⊢ f_2 : {(\kw{cons} ~\nat)}^P + \end{array} + ------------------------------------------------ + E[Γ] ⊢ \case(t,P,f_1 |f_2 ) : (P~t) .. _Definition-of-ι-reduction: @@ -1619,9 +1631,8 @@ Given a variable :math:`y` of type an inductive definition in a declaration ones in which one of the :math:`I_l` occurs) are structurally smaller than y. -The following definitions are correct, we enter them using the ``Fixpoint`` -command as described in Section :ref:`TODO-1.3.4` and show the internal -representation. +The following definitions are correct, we enter them using the :cmd:`Fixpoint` +command and show the internal representation. .. example:: .. coqtop:: all @@ -1678,7 +1689,7 @@ possible: **Mutual induction** The principles of mutual induction can be automatically generated -using the Scheme command described in Section :ref:`TODO-13.1`. +using the Scheme command described in Section :ref:`proofschemes-induction-principles`. .. _Admissible-rules-for-global-environments: diff --git a/doc/sphinx/language/coq-library.rst b/doc/sphinx/language/coq-library.rst index 29053d6a5..afb49413d 100644 --- a/doc/sphinx/language/coq-library.rst +++ b/doc/sphinx/language/coq-library.rst @@ -5,9 +5,6 @@ The |Coq| library ================= -:Source: https://coq.inria.fr/distrib/current/refman/stdlib.html -:Converted by: Pierre Letouzey - .. index:: single: Theories @@ -22,7 +19,7 @@ The |Coq| library is structured into two parts: developments of |Coq| axiomatizations about sets, lists, sorting, arithmetic, etc. This library comes with the system and its modules are directly accessible through the ``Require`` command (see - Section :ref:`TODO-6.5.1-Require`); + Section :ref:`compiled-files`); In addition, user-provided libraries or developments are provided by |Coq| users' community. These libraries and developments are available @@ -51,6 +48,7 @@ at the |Coq| root directory; this includes the modules ``Tactics``. Module ``Logic_Type`` also makes it in the initial state. +.. _init-notations: Notations ~~~~~~~~~ @@ -93,6 +91,8 @@ Notation Precedence Associativity ``_ ^ _`` 30 right ================ ============ =============== +.. _coq-library-logic: + Logic ~~~~~ @@ -200,6 +200,8 @@ The following abbreviations are allowed: The type annotation ``:A`` can be omitted when ``A`` can be synthesized by the system. +.. _coq-equality: + Equality ++++++++ @@ -524,7 +526,7 @@ provides a scope ``nat_scope`` gathering standard notations for common operations (``+``, ``*``) and a decimal notation for numbers, allowing for instance to write ``3`` for :g:`S (S (S O)))`. This also works on the left hand side of a ``match`` expression (see for example -section :ref:`TODO-refine-example`). This scope is opened by default. +section :tacn:`refine`). This scope is opened by default. .. example:: @@ -756,7 +758,7 @@ subdirectories: These directories belong to the initial load path of the system, and the modules they provide are compiled at installation time. So they are directly accessible with the command ``Require`` (see -Section :ref:`TODO-6.5.1-Require`). +Section :ref:`compiled-files`). The different modules of the |Coq| standard library are documented online at http://coq.inria.fr/stdlib. @@ -930,9 +932,8 @@ tactics (see Chapter :ref:`tactics`), there are also: Goal forall x y z:R, x * y * z <> 0. intros; split_Rmult. -These tactics has been written with the tactic language Ltac -described in Chapter :ref:`thetacticlanguage`. - +These tactics has been written with the tactic language |Ltac| +described in Chapter :ref:`ltac`. List library ~~~~~~~~~~~~ diff --git a/doc/sphinx/language/gallina-extensions.rst b/doc/sphinx/language/gallina-extensions.rst index 1d6c11b38..ff5d352c9 100644 --- a/doc/sphinx/language/gallina-extensions.rst +++ b/doc/sphinx/language/gallina-extensions.rst @@ -13,43 +13,42 @@ Extensions of |Gallina| Record types ---------------- -The ``Record`` construction is a macro allowing the definition of +The :cmd:`Record` construction is a macro allowing the definition of records as is done in many programming languages. Its syntax is -described in the grammar below. In fact, the ``Record`` macro is more general +described in the grammar below. In fact, the :cmd:`Record` macro is more general than the usual record types, since it allows also for “manifest” -expressions. In this sense, the ``Record`` construction allows defining +expressions. In this sense, the :cmd:`Record` construction allows defining “signatures”. .. _record_grammar: .. productionlist:: `sentence` - record : `record_keyword` ident [binders] [: sort] := [ident] { [`field` ; … ; `field`] }. + record : `record_keyword` `ident` [ `binders` ] [: `sort` ] := [ `ident` ] { [ `field` ; … ; `field` ] }. record_keyword : Record | Inductive | CoInductive - field : name [binders] : type [ where notation ] - : | name [binders] [: term] := term + field : `ident` [ `binders` ] : `type` [ where `notation` ] + : | `ident` [ `binders` ] [: `type` ] := `term` In the expression: -.. cmd:: Record @ident {* @param } {? : @sort} := {? @ident} { {*; @ident {* @binder } : @term } }. +.. cmd:: Record @ident @binders {? : @sort} := {? @ident} { {*; @ident @binders : @type } } -the first identifier `ident` is the name of the defined record and `sort` is its +the first identifier :token:`ident` is the name of the defined record and :token:`sort` is its type. The optional identifier following ``:=`` is the name of its constructor. If it is omitted, -the default name ``Build_``\ `ident`, where `ident` is the record name, is used. If `sort` is +the default name ``Build_``\ :token:`ident`, where :token:`ident` is the record name, is used. If :token:`sort` is omitted, the default sort is `\Type`. The identifiers inside the brackets are the names of -fields. For a given field `ident`, its type is :g:`forall binder …, term`. +fields. For a given field :token:`ident`, its type is :g:`forall binders, type`. Remark that the type of a particular identifier may depend on a previously-given identifier. Thus the -order of the fields is important. Finally, each `param` is a parameter of the record. +order of the fields is important. Finally, :token:`binders` are parameters of the record. More generally, a record may have explicitly defined (a.k.a. manifest) -fields. For instance, we might have:: - - Record ident param : sort := { ident₁ : type₁ ; ident₂ := term₂ ; ident₃ : type₃ }. - -in which case the correctness of |type_3| may rely on the instance |term_2| of |ident_2| and |term_2| in turn -may depend on |ident_1|. +fields. For instance, we might have: +:n:`Record @ident @binders : @sort := { @ident₁ : @type₁ ; @ident₂ := @term₂ ; @ident₃ : @type₃ }`. +in which case the correctness of :n:`@type₃` may rely on the instance :n:`@term₂` of :n:`@ident₂` and :n:`@term₂` may in turn depend on :n:`@ident₁`. .. example:: + The set of rational numbers may be defined as: + .. coqtop:: reset all Record Rat : Set := mkRat @@ -65,11 +64,10 @@ depends on both ``top`` and ``bottom``. Let us now see the work done by the ``Record`` macro. First the macro generates a variant type definition with just one constructor: +:n:`Variant @ident {? @binders } : @sort := @ident₀ {? @binders }`. -.. cmd:: Variant @ident {* @params} : @sort := @ident {* (@ident : @term_1)}. - -To build an object of type `ident`, one should provide the constructor -|ident_0| with the appropriate number of terms filling the fields of the record. +To build an object of type :n:`@ident`, one should provide the constructor +:n:`@ident₀` with the appropriate number of terms filling the fields of the record. .. example:: Let us define the rational :math:`1/2`: @@ -101,15 +99,15 @@ to be all present if the missing ones can be inferred or prompted for This syntax can be disabled globally for printing by -.. cmd:: Unset Printing Records. +.. cmd:: Unset Printing Records For a given type, one can override this using either -.. cmd:: Add Printing Record @ident. +.. cmd:: Add Printing Record @ident to get record syntax or -.. cmd:: Add Printing Constructor @ident. +.. cmd:: Add Printing Constructor @ident to get constructor syntax. @@ -144,7 +142,7 @@ available: It can be activated for printing with -.. cmd:: Set Printing Projections. +.. opt:: Printing Projections .. example:: @@ -169,7 +167,7 @@ and the syntax `term.(@qualid` |term_1| |term_n| `)` to `@qualid` |term_1| `…` In each case, `term` is the object projected and the other arguments are the parameters of the inductive type. -.. note::. Records defined with the ``Record`` keyword are not allowed to be +.. note:: Records defined with the ``Record`` keyword are not allowed to be recursive (references to the record's name in the type of its field raises an error). To define recursive records, one can use the ``Inductive`` and ``CoInductive`` keywords, resulting in an inductive or co-inductive record. @@ -179,9 +177,9 @@ other arguments are the parameters of the inductive type. .. note:: Induction schemes are automatically generated for inductive records. Automatic generation of induction schemes for non-recursive records defined with the ``Record`` keyword can be activated with the - ``Nonrecursive Elimination Schemes`` option (see :ref:`TODO-13.1.1-nonrecursive-elimination-schemes`). + ``Nonrecursive Elimination Schemes`` option (see :ref:`proofschemes-induction-principles`). -.. note::``Structure`` is a synonym of the keyword ``Record``. +.. note:: ``Structure`` is a synonym of the keyword ``Record``. .. warn:: @ident cannot be defined. @@ -189,9 +187,9 @@ other arguments are the parameters of the inductive type. This message is followed by an explanation of this impossibility. There may be three reasons: - #. The name `ident` already exists in the environment (see Section :ref:`TODO-1.3.1-axioms`). + #. The name `ident` already exists in the environment (see :cmd:`Axiom`). #. The body of `ident` uses an incorrect elimination for - `ident` (see Sections :ref:`TODO-1.3.4-fixpoint` and :ref:`TODO-4.5.3-case-expr`). + `ident` (see :cmd:`Fixpoint` and :ref:`Destructors`). #. The type of the projections `ident` depends on previous projections which themselves could not be defined. @@ -208,16 +206,18 @@ other arguments are the parameters of the inductive type. During the definition of the one-constructor inductive definition, all the errors of inductive definitions, as described in Section -:ref:`TODO-1.3.3-inductive-definitions`, may also occur. +:ref:`gallina-inductive-definitions`, may also occur. -**See also** Coercions and records in Section :ref:`TODO-18.9-coercions-and-records` of the chapter devoted to coercions. +**See also** Coercions and records in Section :ref:`coercions-classes-as-records` of the chapter devoted to coercions. .. _primitive_projections: Primitive Projections ~~~~~~~~~~~~~~~~~~~~~ -The option ``Set Primitive Projections`` turns on the use of primitive +.. opt:: Primitive Projections + +Turns on the use of primitive projections when defining subsequent records (even through the ``Inductive`` and ``CoInductive`` commands). Primitive projections extended the Calculus of Inductive Constructions with a new binary @@ -229,21 +229,27 @@ terms when manipulating parameterized records and typechecking time. On the user level, primitive projections can be used as a replacement for the usual defined ones, although there are a few notable differences. -The internally omitted parameters can be reconstructed at printing time -even though they are absent in the actual AST manipulated by the kernel. This -can be obtained by setting the ``Printing Primitive Projection Parameters`` -flag. Another compatibility printing can be activated thanks to the -``Printing Primitive Projection Compatibility`` option which governs the +.. opt:: Printing Primitive Projection Parameters + +This compatibility option reconstructs internally omitted parameters at +printing time (even though they are absent in the actual AST manipulated +by the kernel). + +.. opt:: Printing Primitive Projection Compatibility + +This compatibility option (on by default) governs the printing of pattern-matching over primitive records. Primitive Record Types ++++++++++++++++++++++ -When the ``Set Primitive Projections`` option is on, definitions of +When the :opt:`Primitive Projections` option is on, definitions of record types change meaning. When a type is declared with primitive projections, its :g:`match` construct is disabled (see :ref:`primitive_projections` though). To eliminate the (co-)inductive type, one must use its defined primitive projections. +.. The following paragraph is quite redundant with what is above + For compatibility, the parameters still appear to the user when printing terms even though they are absent in the actual AST manipulated by the kernel. This can be changed by unsetting the @@ -304,7 +310,7 @@ printed back as :g:`match` constructs. Variants and extensions of :g:`match` ------------------------------------- -.. _extended pattern-matching: +.. _mult-match: Multiple and nested pattern-matching ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -316,10 +322,11 @@ patterns are allowed, as in ML-like languages. The extension just acts as a macro that is expanded during parsing into a sequence of match on simple patterns. Especially, a construction defined using the extended match is generally printed -under its expanded form (see ``Set Printing Matching`` in :ref:`controlling-match-pp`). +under its expanded form (see :opt:`Printing Matching`). -See also: :ref:`extended pattern-matching`. +See also: :ref:`extendedpatternmatching`. +.. _if-then-else: Pattern-matching on boolean values: the if expression ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -366,6 +373,7 @@ we have the following equivalence Notice that the printing uses the :g:`if` syntax because `sumbool` is declared as such (see :ref:`controlling-match-pp`). +.. _irrefutable-patterns: Irrefutable patterns: the destructuring let variants ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -462,116 +470,63 @@ of :g:`match` expressions. Printing nested patterns +++++++++++++++++++++++++ +.. opt:: Printing Matching + The Calculus of Inductive Constructions knows pattern-matching only over simple patterns. It is however convenient to re-factorize nested pattern-matching into a single pattern-matching over a nested -pattern. |Coq|’s printer tries to do such limited re-factorization. - -.. cmd:: Set Printing Matching. +pattern. -This tells |Coq| to try to use nested patterns. This is the default -behavior. +When this option is on (default), |Coq|’s printer tries to do such +limited re-factorization. +Turning it off tells |Coq| to print only simple pattern-matching problems +in the same way as the |Coq| kernel handles them. -.. cmd:: Unset Printing Matching. - -This tells |Coq| to print only simple pattern-matching problems in the -same way as the |Coq| kernel handles them. - -.. cmd:: Test Printing Matching. - -This tells if the printing matching mode is on or off. The default is -on. Factorization of clauses with same right-hand side ++++++++++++++++++++++++++++++++++++++++++++++++++ +.. opt:: Printing Factorizable Match Patterns + When several patterns share the same right-hand side, it is additionally possible to share the clauses using disjunctive patterns. Assuming that the -printing matching mode is on, whether |Coq|'s printer shall try to do this kind -of factorization is governed by the following commands: - -.. cmd:: Set Printing Factorizable Match Patterns. - -This tells |Coq|'s printer to try to use disjunctive patterns. This is the -default behavior. - -.. cmd:: Unset Printing Factorizable Match Patterns. - -This tells |Coq|'s printer not to try to use disjunctive patterns. - -.. cmd:: Test Printing Factorizable Match Patterns. - -This tells if the factorization of clauses with same right-hand side is on or -off. +printing matching mode is on, this option (on by default) tells |Coq|'s +printer to try to do this kind of factorization. Use of a default clause +++++++++++++++++++++++ +.. opt:: Printing Allow Default Clause + When several patterns share the same right-hand side which do not depend on the arguments of the patterns, yet an extra factorization is possible: the disjunction of patterns can be replaced with a `_` default clause. Assuming that -the printing matching mode and the factorization mode are on, whether |Coq|'s -printer shall try to use a default clause is governed by the following commands: - -.. cmd:: Set Printing Allow Default Clause. - -This tells |Coq|'s printer to use a default clause when relevant. This is the -default behavior. - -.. cmd:: Unset Printing Allow Default Clause. - -This tells |Coq|'s printer not to use a default clause. - -.. cmd:: Test Printing Allow Default Clause. - -This tells if the use of a default clause is allowed. +the printing matching mode and the factorization mode are on, this option (on by +default) tells |Coq|'s printer to use a default clause when relevant. Printing of wildcard patterns ++++++++++++++++++++++++++++++ -Some variables in a pattern may not occur in the right-hand side of -the pattern-matching clause. There are options to control the display -of these variables. - -.. cmd:: Set Printing Wildcard. +.. opt:: Printing Wildcard -The variables having no occurrences in the right-hand side of the +Some variables in a pattern may not occur in the right-hand side of +the pattern-matching clause. When this option is on (default), the +variables having no occurrences in the right-hand side of the pattern-matching clause are just printed using the wildcard symbol “_”. -.. cmd:: Unset Printing Wildcard. - -The variables, even useless, are printed using their usual name. But -some non-dependent variables have no name. These ones are still -printed using a “_”. - -.. cmd:: Test Printing Wildcard. - -This tells if the wildcard printing mode is on or off. The default is -to print wildcard for useless variables. - Printing of the elimination predicate +++++++++++++++++++++++++++++++++++++ +.. opt:: Printing Synth + In most of the cases, the type of the result of a matched term is mechanically synthesizable. Especially, if the result type does not -depend of the matched term. - -.. cmd:: Set Printing Synth. - -The result type is not printed when |Coq| knows that it can re- +depend of the matched term. When this option is on (default), +the result type is not printed when |Coq| knows that it can re- synthesize it. -.. cmd:: Unset Printing Synth. - -This forces the result type to be always printed. - -.. cmd:: Test Printing Synth. - -This tells if the non-printing of synthesizable types is on or off. -The default is to not print synthesizable types. - Printing matching on irrefutable patterns ++++++++++++++++++++++++++++++++++++++++++ @@ -579,23 +534,23 @@ Printing matching on irrefutable patterns If an inductive type has just one constructor, pattern-matching can be written using the first destructuring let syntax. -.. cmd:: Add Printing Let @ident. +.. cmd:: Add Printing Let @ident This adds `ident` to the list of inductive types for which pattern-matching is written using a let expression. -.. cmd:: Remove Printing Let @ident. +.. cmd:: Remove Printing Let @ident This removes ident from this list. Note that removing an inductive type from this list has an impact only for pattern-matching written using :g:`match`. Pattern-matching explicitly written using a destructuring :g:`let` are not impacted. -.. cmd:: Test Printing Let for @ident. +.. cmd:: Test Printing Let for @ident This tells if `ident` belongs to the list. -.. cmd:: Print Table Printing Let. +.. cmd:: Print Table Printing Let This prints the list of inductive types for which pattern-matching is written using a let expression. @@ -611,20 +566,20 @@ Printing matching on booleans If an inductive type is isomorphic to the boolean type, pattern-matching can be written using ``if`` … ``then`` … ``else`` …: -.. cmd:: Add Printing If @ident. +.. cmd:: Add Printing If @ident This adds ident to the list of inductive types for which pattern-matching is written using an if expression. -.. cmd:: Remove Printing If @ident. +.. cmd:: Remove Printing If @ident This removes ident from this list. -.. cmd:: Test Printing If for @ident. +.. cmd:: Test Printing If for @ident This tells if ident belongs to the list. -.. cmd:: Print Table Printing If. +.. cmd:: Print Table Printing If This prints the list of inductive types for which pattern-matching is written using an if expression. @@ -662,12 +617,12 @@ Advanced recursive functions The following experimental command is available when the ``FunInd`` library has been loaded via ``Require Import FunInd``: -.. cmd:: Function @ident {* @binder} { @decrease_annot } : @type := @term. +.. cmd:: Function @ident {* @binder} { @decrease_annot } : @type := @term This command can be seen as a generalization of ``Fixpoint``. It is actually a wrapper for several ways of defining a function *and other useful related objects*, namely: an induction principle that reflects the recursive -structure of the function (see Section :ref:`TODO-8.5.5-functional-induction`) and its fixpoint equality. +structure of the function (see :tacn:`function induction`) and its fixpoint equality. The meaning of this declaration is to define a function ident, similarly to ``Fixpoint`. Like in ``Fixpoint``, the decreasing argument must be given (unless the function is not recursive), but it might not @@ -680,8 +635,8 @@ The ``Function`` construction also enjoys the ``with`` extension to define mutually recursive definitions. However, this feature does not work for non structurally recursive functions. -See the documentation of functional induction (:ref:`TODO-8.5.5-functional-induction`) -and ``Functional Scheme`` (:ref:`TODO-13.2-functional-scheme`) for how to use +See the documentation of functional induction (:tacn:`function induction`) +and ``Functional Scheme`` (:ref:`functional-scheme`) for how to use the induction principle to easily reason about the function. Remark: To obtain the right principle, it is better to put rigid @@ -729,11 +684,11 @@ presence of partial application of `wrong` in the body of For now, dependent cases are not treated for non structurally terminating functions. -.. exn:: The recursive argument must be specified -.. exn:: No argument name @ident -.. exn:: Cannot use mutual definition with well-founded recursion or measure +.. exn:: The recursive argument must be specified. +.. exn:: No argument name @ident. +.. exn:: Cannot use mutual definition with well-founded recursion or measure. -.. warn:: Cannot define graph for @ident +.. warn:: Cannot define graph for @ident. The generation of the graph relation (`R_ident`) used to compute the induction scheme of ident raised a typing error. Only `ident` is defined; the induction scheme @@ -743,16 +698,16 @@ terminating functions. which ``Function`` cannot deal with yet. - the definition is not a *pattern-matching tree* as explained above. -.. warn:: Cannot define principle(s) for @ident +.. warn:: Cannot define principle(s) for @ident. The generation of the graph relation (`R_ident`) succeeded but the induction principle could not be built. Only `ident` is defined. Please report. -.. warn:: Cannot build functional inversion principle +.. warn:: Cannot build functional inversion principle. `functional inversion` will not be available for the function. -See also: :ref:`TODO-13.2-generating-ind-principles` and ref:`TODO-8.5.5-functional-induction` +See also: :ref:`functional-scheme` and :tacn:`function induction` Depending on the ``{…}`` annotation, different definition mechanisms are used by ``Function``. A more precise description is given below. @@ -763,7 +718,7 @@ used by ``Function``. A more precise description is given below. the following are defined: + `ident_rect`, `ident_rec` and `ident_ind`, which reflect the pattern - matching structure of `term` (see the documentation of :ref:`TODO-1.3.3-Inductive`); + matching structure of `term` (see :cmd:`Inductive`); + The inductive `R_ident` corresponding to the graph of `ident` (silently); + `ident_complete` and `ident_correct` which are inversion information linking the function and its graph. @@ -812,21 +767,22 @@ used by ``Function``. A more precise description is given below. hand. Remark: Proof obligations are presented as several subgoals belonging to a Lemma `ident`\ :math:`_{\sf tcc}`. +.. _section-mechanism: Section mechanism ----------------- The sectioning mechanism can be used to to organize a proof in structured sections. Then local declarations become available (see -Section :ref:`TODO-1.3.2-Definitions`). +Section :ref:`gallina-definitions`). -.. cmd:: Section @ident. +.. cmd:: Section @ident This command is used to open a section named `ident`. -.. cmd:: End @ident. +.. cmd:: End @ident This command closes the section named `ident`. After closing of the section, the local declarations (variables and local definitions) get @@ -859,7 +815,7 @@ Section :ref:`TODO-1.3.2-Definitions`). Notice the difference between the value of `x’` and `x’’` inside section `s1` and outside. - .. exn:: This is not the last opened section + .. exn:: This is not the last opened section. **Remarks:** @@ -888,44 +844,44 @@ together, as well as a means of massive abstraction. In the syntax of module application, the ! prefix indicates that any `Inline` directive in the type of the functor arguments will be ignored -(see :ref:`named_module_type` below). +(see the ``Module Type`` command below). -.. cmd:: Module @ident. +.. cmd:: Module @ident This command is used to start an interactive module named `ident`. -.. cmdv:: Module @ident {* @module_binding}. +.. cmdv:: Module @ident {* @module_binding} Starts an interactive functor with parameters given by module_bindings. -.. cmdv:: Module @ident : @module_type. +.. cmdv:: Module @ident : @module_type Starts an interactive module specifying its module type. -.. cmdv:: Module @ident {* @module_binding} : @module_type. +.. cmdv:: Module @ident {* @module_binding} : @module_type Starts an interactive functor with parameters given by the list of `module binding`, and output module type `module_type`. -.. cmdv:: Module @ident <: {+<: @module_type }. +.. cmdv:: Module @ident <: {+<: @module_type } Starts an interactive module satisfying each `module_type`. - .. cmdv:: Module @ident {* @module_binding} <: {+<; @module_type }. + .. cmdv:: Module @ident {* @module_binding} <: {+<: @module_type }. Starts an interactive functor with parameters given by the list of `module_binding`. The output module type is verified against each `module_type`. -.. cmdv:: Module [ Import | Export ]. +.. cmdv:: Module [ Import | Export ] Behaves like ``Module``, but automatically imports or exports the module. Reserved commands inside an interactive module ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -.. cmd:: Include @module. +.. cmd:: Include @module Includes the content of module in the current interactive module. Here module can be a module expression or a module @@ -933,11 +889,11 @@ Reserved commands inside an interactive module expression then the system tries to instantiate module by the current interactive module. -.. cmd:: Include {+<+ @module}. +.. cmd:: Include {+<+ @module} is a shortcut for the commands ``Include`` `module` for each `module`. -.. cmd:: End @ident. +.. cmd:: End @ident This command closes the interactive module `ident`. If the module type was given the content of the module is matched against it and an error @@ -945,42 +901,40 @@ Reserved commands inside an interactive module functor) its components (constants, inductive types, submodules etc.) are now available through the dot notation. - .. exn:: No such label @ident + .. exn:: No such label @ident. - .. exn:: Signature components for label @ident do not match + .. exn:: Signature components for label @ident do not match. - .. exn:: This is not the last opened module + .. exn:: This is not the last opened module. -.. cmd:: Module @ident := @module_expression. +.. cmd:: Module @ident := @module_expression This command defines the module identifier `ident` to be equal to `module_expression`. - .. cmdv:: Module @ident {* @module_binding} := @module_expression. + .. cmdv:: Module @ident {* @module_binding} := @module_expression Defines a functor with parameters given by the list of `module_binding` and body `module_expression`. - .. cmdv:: Module @ident {* @module_binding} : @module_type := @module_expression. + .. cmdv:: Module @ident {* @module_binding} : @module_type := @module_expression Defines a functor with parameters given by the list of `module_binding` (possibly none), and output module type `module_type`, with body `module_expression`. - .. cmdv:: Module @ident {* @module_binding} <: {+<: @module_type} := @module_expression. + .. cmdv:: Module @ident {* @module_binding} <: {+<: @module_type} := @module_expression Defines a functor with parameters given by module_bindings (possibly none) with body `module_expression`. The body is checked against each |module_type_i|. - .. cmdv:: Module @ident {* @module_binding} := {+<+ @module_expression}. + .. cmdv:: Module @ident {* @module_binding} := {+<+ @module_expression} is equivalent to an interactive module where each `module_expression` is included. -.. _named_module_type: - -.. cmd:: Module Type @ident. +.. cmd:: Module Type @ident This command is used to start an interactive module type `ident`. - .. cmdv:: Module Type @ident {* @module_binding}. + .. cmdv:: Module Type @ident {* @module_binding} Starts an interactive functor type with parameters given by `module_bindings`. @@ -988,43 +942,44 @@ This command is used to start an interactive module type `ident`. Reserved commands inside an interactive module type: ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -.. cmd:: Include @module. +.. cmd:: Include @module Same as ``Include`` inside a module. -.. cmd:: Include {+<+ @module}. +.. cmd:: Include {+<+ @module} is a shortcut for the command ``Include`` `module` for each `module`. -.. cmd:: @assumption_keyword Inline @assums. +.. cmd:: @assumption_keyword Inline @assums + :name: Inline The instance of this assumption will be automatically expanded at functor application, except when this functor application is prefixed by a ``!`` annotation. -.. cmd:: End @ident. +.. cmd:: End @ident This command closes the interactive module type `ident`. - .. exn:: This is not the last opened module type + .. exn:: This is not the last opened module type. -.. cmd:: Module Type @ident := @module_type. +.. cmd:: Module Type @ident := @module_type Defines a module type `ident` equal to `module_type`. - .. cmdv:: Module Type @ident {* @module_binding} := @module_type. + .. cmdv:: Module Type @ident {* @module_binding} := @module_type Defines a functor type `ident` specifying functors taking arguments `module_bindings` and returning `module_type`. - .. cmdv:: Module Type @ident {* @module_binding} := {+<+ @module_type }. + .. cmdv:: Module Type @ident {* @module_binding} := {+<+ @module_type } is equivalent to an interactive module type were each `module_type` is included. -.. cmd:: Declare Module @ident : @module_type. +.. cmd:: Declare Module @ident : @module_type Declares a module `ident` of type `module_type`. - .. cmdv:: Declare Module @ident {* @module_binding} : @module_type. + .. cmdv:: Declare Module @ident {* @module_binding} : @module_type Declares a functor with parameters given by the list of `module_binding` and output module type `module_type`. @@ -1188,107 +1143,107 @@ some of the fields and give one of its possible implementations: Notice that ``M`` is a correct body for the component ``M2`` since its ``T`` component is equal ``nat`` and hence ``M1.T`` as specified. -**Remarks:** +.. note:: -#. Modules and module types can be nested components of each other. -#. One can have sections inside a module or a module type, but not a - module or a module type inside a section. -#. Commands like ``Hint`` or ``Notation`` can also appear inside modules and - module types. Note that in case of a module definition like: + #. Modules and module types can be nested components of each other. + #. One can have sections inside a module or a module type, but not a + module or a module type inside a section. + #. Commands like ``Hint`` or ``Notation`` can also appear inside modules and + module types. Note that in case of a module definition like: -:: + :: - Module N : SIG := M. + Module N : SIG := M. -or:: + or:: - Module N : SIG. … End N. + Module N : SIG. … End N. -hints and the like valid for ``N`` are not those defined in ``M`` (or the module body) but the ones defined -in ``SIG``. + hints and the like valid for ``N`` are not those defined in ``M`` + (or the module body) but the ones defined in ``SIG``. .. _import_qualid: -.. cmd:: Import @qualid. +.. cmd:: Import @qualid If `qualid` denotes a valid basic module (i.e. its module type is a signature), makes its components available by their short names. -.. example:: + .. example:: - .. coqtop:: reset all + .. coqtop:: reset all - Module Mod. + Module Mod. - Definition T:=nat. + Definition T:=nat. - Check T. + Check T. - End Mod. + End Mod. - Check Mod.T. + Check Mod.T. - Fail Check T. + Fail Check T. - Import Mod. + Import Mod. - Check T. + Check T. -Some features defined in modules are activated only when a module is -imported. This is for instance the case of notations (see :ref:`TODO-12.1-Notations`). + Some features defined in modules are activated only when a module is + imported. This is for instance the case of notations (see :ref:`Notations`). -Declarations made with the Local flag are never imported by theImport -command. Such declarations are only accessible through their fully -qualified name. + Declarations made with the ``Local`` flag are never imported by the :cmd:`Import` + command. Such declarations are only accessible through their fully + qualified name. -.. example:: + .. example:: - .. coqtop:: all + .. coqtop:: all - Module A. + Module A. - Module B. + Module B. - Local Definition T := nat. + Local Definition T := nat. - End B. + End B. - End A. + End A. - Import A. + Import A. - Fail Check B.T. + Fail Check B.T. .. cmdv:: Export @qualid + :name: Export When the module containing the command Export qualid is imported, qualid is imported as well. - .. exn:: @qualid is not a module + .. exn:: @qualid is not a module. .. warn:: Trying to mask the absolute name @qualid! -.. cmd:: Print Module @ident. +.. cmd:: Print Module @ident - Prints the module type and (optionally) the body of the module `ident`. + Prints the module type and (optionally) the body of the module :n:`@ident`. -.. cmd:: Print Module Type @ident. +.. cmd:: Print Module Type @ident - Prints the module type corresponding to `ident`. + Prints the module type corresponding to :n:`@ident`. .. opt:: Short Module Printing - This option (off by default) disables the printing of the types of fields, - leaving only their names, for the commands ``Print Module`` and ``Print Module Type``. - -.. cmd:: Locate Module @qualid. - - Prints the full name of the module `qualid`. + This option (off by default) disables the printing of the types of fields, + leaving only their names, for the commands :cmd:`Print Module` and + :cmd:`Print Module Type`. Libraries and qualified names --------------------------------- +.. _names-of-libraries: + Names of libraries ~~~~~~~~~~~~~~~~~~ @@ -1296,15 +1251,16 @@ The theories developed in |Coq| are stored in *library files* which are hierarchically classified into *libraries* and *sublibraries*. To express this hierarchy, library names are represented by qualified identifiers qualid, i.e. as list of identifiers separated by dots (see -:ref:`TODO-1.2.3-identifiers`). For instance, the library file ``Mult`` of the standard +:ref:`gallina-identifiers`). For instance, the library file ``Mult`` of the standard |Coq| library ``Arith`` is named ``Coq.Arith.Mult``. The identifier that starts the name of a library is called a *library root*. All library files of the standard library of |Coq| have the reserved root |Coq| but library file names based on other roots can be obtained by using |Coq| commands -(coqc, coqtop, coqdep, …) options ``-Q`` or ``-R`` (see :ref:`TODO-14.3.3-command-line-options`). +(coqc, coqtop, coqdep, …) options ``-Q`` or ``-R`` (see :ref:`command-line-options`). Also, when an interactive |Coq| session starts, a library of root ``Top`` is -started, unless option ``-top`` or ``-notop`` is set (see :ref:`TODO-14.3.3-command-line-options`). +started, unless option ``-top`` or ``-notop`` is set (see :ref:`command-line-options`). +.. _qualified-names: Qualified names ~~~~~~~~~~~~~~~ @@ -1339,13 +1295,13 @@ names also applies to library file names. |Coq| maintains a table called the name table which maps partially qualified names of constructions to absolute names. This table is updated by the -commands ``Require`` (see :ref:`TODO-6.5.1-Require`), Import and Export (see :ref:`import_qualid`) and +commands :cmd:`Require`, :cmd:`Import` and :cmd:`Export` and also each time a new declaration is added to the context. An absolute name is called visible from a given short or partially qualified name when this latter name is enough to denote it. This means that the short or partially qualified name is mapped to the absolute name in |Coq| name table. Definitions flagged as Local are only accessible with -their fully qualified name (see :ref:`TODO-1.3.2-definitions`). +their fully qualified name (see :ref:`gallina-definitions`). It may happen that a visible name is hidden by the short name or a qualified name of another construction. In this case, the name that @@ -1367,16 +1323,15 @@ accessible, absolute names can never be hidden. Locate nat. -See also: Command Locate in :ref:`TODO-6.3.10-locate-qualid` and Locate Library in -:ref:`TODO-6.6.11-locate-library`. +See also: Commands :cmd:`Locate` and :cmd:`Locate Library`. +.. _libraries-and-filesystem: Libraries and filesystem ~~~~~~~~~~~~~~~~~~~~~~~~ -Please note that the questions described here have been subject to -redesign in |Coq| v8.5. Former versions of |Coq| use the same terminology -to describe slightly different things. +.. note:: The questions described here have been subject to redesign in |Coq| 8.5. + Former versions of |Coq| use the same terminology to describe slightly different things. Compiled files (``.vo`` and ``.vio``) store sub-libraries. In order to refer to them inside |Coq|, a translation from file-system names to |Coq| names @@ -1412,7 +1367,7 @@ translation and with an empty logical prefix. The command line option ``-R`` is a variant of ``-Q`` which has the strictly same behavior regarding loadpaths, but which also makes the corresponding ``.vo`` files available through their short names in a way -not unlike the ``Import`` command (see :ref:`import_qualid`). For instance, ``-R`` `path` ``Lib`` +not unlike the ``Import`` command (see :ref:`here <import_qualid>`). For instance, ``-R`` `path` ``Lib`` associates to the ``filepath/fOO/Bar/File.vo`` the logical name ``Lib.fOO.Bar.File``, but allows this file to be accessed through the short names ``fOO.Bar.File,Bar.File`` and ``File``. If several files with @@ -1420,7 +1375,7 @@ identical base name are present in different subdirectories of a recursive loadpath, which of these files is found first may be system- dependent and explicit qualification is recommended. The ``From`` argument of the ``Require`` command can be used to bypass the implicit shortening -by providing an absolute root to the required file (see :ref:`TODO-6.5.1-require-qualid`). +by providing an absolute root to the required file (see :ref:`compiled-files`). There also exists another independent loadpath mechanism attached to OCaml object files (``.cmo`` or ``.cmxs``) rather than |Coq| object @@ -1428,11 +1383,12 @@ files as described above. The OCaml loadpath is managed using the option ``-I`` `path` (in the OCaml world, there is neither a notion of logical name prefix nor a way to access files in subdirectories of path). See the command ``Declare`` ``ML`` ``Module`` in -:ref:`TODO-6.5-compiled-files` to understand the need of the OCaml loadpath. +:ref:`compiled-files` to understand the need of the OCaml loadpath. -See :ref:`TODO-14.3.3-command-line-options` for a more general view over the |Coq| command +See :ref:`command-line-options` for a more general view over the |Coq| command line options. +.. _ImplicitArguments: Implicit arguments ------------------ @@ -1477,7 +1433,9 @@ For instance, the first argument of in module ``List.v`` is strict because :g:`list` is an inductive type and :g:`A` will always be inferable from the type :g:`list A` of the third argument of -:g:`cons`. On the contrary, the second argument of a term of type +:g:`cons`. Also, the first argument of :g:`cons` is strict with respect to the second one, +since the first argument is exactly the type of the second argument. +On the contrary, the second argument of a term of type :: forall P:nat->Prop, forall n:nat, P n -> ex nat P @@ -1548,10 +1506,9 @@ inserted. In the second case, the function is considered to be implicitly applied to the implicit arguments it is waiting for: one says that the implicit argument is maximally inserted. -Each implicit argument can be declared to have to be inserted -maximally or non maximally. This can be governed argument per argument -by the command ``Implicit Arguments`` (see Section :ref:`declare-implicit-args`) or globally by the -command ``Set Maximal Implicit Insertion`` (see Section :ref:`controlling-insertion-implicit-args`). +Each implicit argument can be declared to have to be inserted maximally or non +maximally. This can be governed argument per argument by the command +:cmd:`Arguments (implicits)` or globally by the :opt:`Maximal Implicit Insertion` option. See also :ref:`displaying-implicit-args`. @@ -1564,6 +1521,7 @@ force the given argument to be guessed by replacing it by “_”. If possible, the correct argument will be automatically generated. .. exn:: Cannot infer a term for this placeholder. + :name: Cannot infer a term for this placeholder. (Casual use of implicit arguments) |Coq| was not able to deduce an instantiation of a “_”. @@ -1603,7 +1561,7 @@ absent in every situation but still be able to specify it if needed: The syntax is supported in all top-level definitions: -``Definition``, ``Fixpoint``, ``Lemma`` and so on. For (co-)inductive datatype +:cmd:`Definition`, :cmd:`Fixpoint`, :cmd:`Lemma` and so on. For (co-)inductive datatype declarations, the semantics are the following: an inductive parameter declared as an implicit argument need not be repeated in the inductive definition but will become implicit for the constructors of the @@ -1626,7 +1584,8 @@ Declaring Implicit Arguments To set implicit arguments *a posteriori*, one can use the command: -.. cmd:: Arguments @qualid {* @possibly_bracketed_ident }. +.. cmd:: Arguments @qualid {* @possibly_bracketed_ident } + :name: Arguments (implicits) where the list of `possibly_bracketed_ident` is a prefix of the list of arguments of `qualid` where the ones to be declared implicit are @@ -1639,7 +1598,7 @@ of `qualid`. Implicit arguments can be cleared with the following syntax: -.. cmd:: Arguments @qualid : clear implicits. +.. cmd:: Arguments @qualid : clear implicits .. cmdv:: Global Arguments @qualid {* @possibly_bracketed_ident } @@ -1648,13 +1607,13 @@ Implicit arguments can be cleared with the following syntax: implicit arguments known from inside the section to be the ones declared by the command. -.. cmdv:: Local Arguments @qualid {* @possibly_bracketed_ident }. +.. cmdv:: Local Arguments @qualid {* @possibly_bracketed_ident } When in a module, tell not to activate the implicit arguments ofqualid declared by this command to contexts that require the module. -.. cmdv:: {? Global | Local } Arguments @qualid {*, {+ @possibly_bracketed_ident } }. +.. cmdv:: {? Global | Local } Arguments @qualid {*, {+ @possibly_bracketed_ident } } For names of constants, inductive types, constructors, lemmas which can only be applied to a fixed number of @@ -1706,7 +1665,7 @@ Automatic declaration of implicit arguments |Coq| can also automatically detect what are the implicit arguments of a defined object. The command is just -.. cmd:: Arguments @qualid : default implicits. +.. cmd:: Arguments @qualid : default implicits The auto-detection is governed by options telling if strict, contextual, or reversible-pattern implicit arguments must be @@ -1780,14 +1739,10 @@ appear strictly in the body of the type, they are implicit. Mode for automatic declaration of implicit arguments ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -In case one wants to systematically declare implicit the arguments -detectable as such, one may switch to the automatic declaration of -implicit arguments mode by using the command: - -.. cmd:: Set Implicit Arguments. +.. opt:: Implicit Arguments -Conversely, one may unset the mode by using ``Unset Implicit Arguments``. -The mode is off by default. Auto-detection of implicit arguments is +This option (off by default) allows to systematically declare implicit +the arguments detectable as such. Auto-detection of implicit arguments is governed by options controlling whether strict and contextual implicit arguments have to be considered or not. @@ -1796,76 +1751,55 @@ arguments have to be considered or not. Controlling strict implicit arguments ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +.. opt:: Strict Implicit + When the mode for automatic declaration of implicit arguments is on, the default is to automatically set implicit only the strict implicit arguments plus, for historical reasons, a small subset of the non-strict implicit arguments. To relax this constraint and to set -implicit all non strict implicit arguments by default, use the command: - -.. cmd:: Unset Strict Implicit. +implicit all non strict implicit arguments by default, you can turn this +option off. -Conversely, use the command ``Set Strict Implicit`` to restore the -original mode that declares implicit only the strict implicit -arguments plus a small subset of the non strict implicit arguments. +.. opt:: Strongly Strict Implicit -In the other way round, to capture exactly the strict implicit -arguments and no more than the strict implicit arguments, use the -command - -.. cmd:: Set Strongly Strict Implicit. - -Conversely, use the command ``Unset Strongly Strict Implicit`` to let the -option “Strict Implicit” decide what to do. - -Remark: In versions of |Coq| prior to version 8.0, the default was to -declare the strict implicit arguments as implicit. +Use this option (off by default) to capture exactly the strict implicit +arguments and no more than the strict implicit arguments. .. _controlling-contextual-implicit-args: Controlling contextual implicit arguments ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -By default, |Coq| does not automatically set implicit the contextual -implicit arguments. To tell |Coq| to infer also contextual implicit -argument, use command - -.. cmd:: Set Contextual Implicit. +.. opt:: Contextual Implicit -Conversely, use command ``Unset Contextual Implicit`` to unset the -contextual implicit mode. +By default, |Coq| does not automatically set implicit the contextual +implicit arguments. You can turn this option on to tell |Coq| to also +infer contextual implicit argument. .. _controlling-rev-pattern-implicit-args: Controlling reversible-pattern implicit arguments ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -By default, |Coq| does not automatically set implicit the reversible-pattern -implicit arguments. To tell |Coq| to infer also reversible- -pattern implicit argument, use command - -.. cmd:: Set Reversible Pattern Implicit. +.. opt:: Reversible Pattern Implicit -Conversely, use command ``Unset Reversible Pattern Implicit`` to unset the -reversible-pattern implicit mode. +By default, |Coq| does not automatically set implicit the reversible-pattern +implicit arguments. You can turn this option on to tell |Coq| to also infer +reversible-pattern implicit argument. .. _controlling-insertion-implicit-args: Controlling the insertion of implicit arguments not followed by explicit arguments ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Implicit arguments can be declared to be automatically inserted when a -function is partially applied and the next argument of the function is -an implicit one. In case the implicit arguments are automatically -declared (with the command ``Set Implicit Arguments``), the command - -.. cmd:: Set Maximal Implicit Insertion. +.. opt:: Maximal Implicit Insertion -is used to tell to declare the implicit arguments with a maximal -insertion status. By default, automatically declared implicit -arguments are not declared to be insertable maximally. To restore the -default mode for maximal insertion, use the command +Assuming the implicit argument mode is on, this option (off by default) +declares implicit arguments to be automatically inserted when a +function is partially applied and the next argument of the function is +an implicit one. -.. cmd:: Unset Maximal Implicit Insertion. +.. _explicit-applications: Explicit applications ~~~~~~~~~~~~~~~~~~~~~ @@ -1904,7 +1838,7 @@ Renaming implicit arguments Implicit arguments names can be redefined using the following syntax: -.. cmd:: Arguments @qualid {* @name} : @rename. +.. cmd:: Arguments @qualid {* @name} : @rename With the assert flag, ``Arguments`` can be used to assert that a given object has the expected number of arguments and that these arguments @@ -1930,33 +1864,25 @@ Displaying what the implicit arguments are To display the implicit arguments associated to an object, and to know if each of them is to be used maximally or not, use the command -.. cmd:: Print Implicit @qualid. +.. cmd:: Print Implicit @qualid Explicit displaying of implicit arguments for pretty-printing ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -By default the basic pretty-printing rules hide the inferable implicit -arguments of an application. To force printing all implicit arguments, -use command - -.. cmd:: Set Printing Implicit. +.. opt:: Printing Implicit -Conversely, to restore the hiding of implicit arguments, use command +By default, the basic pretty-printing rules hide the inferable implicit +arguments of an application. Turn this option on to force printing all +implicit arguments. -.. cmd:: Unset Printing Implicit. +.. opt:: Printing Implicit Defensive -By default the basic pretty-printing rules display the implicit +By default, the basic pretty-printing rules display the implicit arguments that are not detected as strict implicit arguments. This “defensive” mode can quickly make the display cumbersome so this can -be deactivated by using the command - -.. cmd:: Unset Printing Implicit Defensive. +be deactivated by turning this option off. -Conversely, to force the display of non strict arguments, use command - -.. cmd:: Set Printing Implicit Defensive. - -See also: ``Set Printing All`` in :ref:`printing_constructions_full`. +See also: :opt:`Printing All`. Interaction with subtyping ~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1981,17 +1907,14 @@ but succeeds in Deactivation of implicit arguments for parsing ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Use of implicit arguments can be deactivated by issuing the command: +.. opt:: Parsing Explicit -.. cmd:: Set Parsing Explicit. +Turning this option on (it is off by default) deactivates the use of implicit arguments. In this case, all arguments of constants, inductive types, constructors, etc, including the arguments declared as implicit, have -to be given as if none arguments were implicit. By symmetry, this also -affects printing. To restore parsing and normal printing of implicit -arguments, use: - -.. cmd:: Unset Parsing Explicit. +to be given as if no arguments were implicit. By symmetry, this also +affects printing. Canonical structures ~~~~~~~~~~~~~~~~~~~~ @@ -2006,7 +1929,7 @@ Assume that `qualid` denotes an object ``(Build_struc`` |c_1| … |c_n| ``)`` in structure *struct* of which the fields are |x_1|, …, |x_n|. Assume that `qualid` is declared as a canonical structure using the command -.. cmd:: Canonical Structure @qualid. +.. cmd:: Canonical Structure @qualid Then, each time an equation of the form ``(``\ |x_i| ``_)`` |eq_beta_delta_iota_zeta| |c_i| has to be solved during the type-checking process, `qualid` is used as a solution. @@ -2047,11 +1970,11 @@ and ``B`` can be synthesized in the next statement. Remark: If a same field occurs in several canonical structure, then only the structure declared first as canonical is considered. -.. cmdv:: Canonical Structure @ident := @term : @type. +.. cmdv:: Canonical Structure @ident := @term : @type -.. cmdv:: Canonical Structure @ident := @term. +.. cmdv:: Canonical Structure @ident := @term -.. cmdv:: Canonical Structure @ident : @type := @term. +.. cmdv:: Canonical Structure @ident : @type := @term These are equivalent to a regular definition of `ident` followed by the declaration ``Canonical Structure`` `ident`. @@ -2079,7 +2002,7 @@ It is possible to bind variable names to a given type (e.g. in a development using arithmetic, it may be convenient to bind the names `n` or `m` to the type ``nat`` of natural numbers). The command for that is -.. cmd:: Implicit Types {+ @ident } : @type. +.. cmd:: Implicit Types {+ @ident } : @type The effect of the command is to automatically set the type of bound variables starting with `ident` (either `ident` itself or `ident` followed by @@ -2101,7 +2024,7 @@ case, this latter type is considered). Lemma cons_inj_bool : forall (m n:bool) l, n :: l = m :: l -> n = m. -.. cmdv:: Implicit Type @ident : @type. +.. cmdv:: Implicit Type @ident : @type This is useful for declaring the implicit type of a single variable. @@ -2140,7 +2063,7 @@ the ``Generalizable`` vernacular command to avoid unexpected generalizations when mistyping identifiers. There are several commands that specify which variables should be generalizable. -.. cmd:: Generalizable All Variables. +.. cmd:: Generalizable All Variables All variables are candidate for generalization if they appear free in the context under a @@ -2148,16 +2071,16 @@ that specify which variables should be generalizable. of typos. In such cases, the context will probably contain some unexpected generalized variable. -.. cmd:: Generalizable No Variables. +.. cmd:: Generalizable No Variables Disable implicit generalization entirely. This is the default behavior. -.. cmd:: Generalizable (Variable | Variables) {+ @ident }. +.. cmd:: Generalizable (Variable | Variables) {+ @ident } Allow generalization of the given identifiers only. Calling this command multiple times adds to the allowed identifiers. -.. cmd:: Global Generalizable. +.. cmd:: Global Generalizable Allows exporting the choice of generalizable variables. @@ -2177,6 +2100,7 @@ implicitly, as maximally-inserted arguments. In these binders, the binding name for the bound object is optional, whereas the type is mandatory, dually to regular binders. +.. _Coercions: Coercions --------- @@ -2201,43 +2125,38 @@ to coercions are provided in :ref:`implicitcoercions`. Printing constructions in full ------------------------------ +.. opt:: Printing All + Coercions, implicit arguments, the type of pattern-matching, but also notations (see :ref:`syntaxextensionsandinterpretationscopes`) can obfuscate the behavior of some tactics (typically the tactics applying to occurrences of subterms are -sensitive to the implicit arguments). The command - -.. cmd:: Set Printing All. - +sensitive to the implicit arguments). Turning this option on deactivates all high-level printing features such as coercions, implicit arguments, returned type of pattern-matching, notations and various syntactic sugar for pattern-matching or record projections. -Otherwise said, ``Set Printing All`` includes the effects of the commands -``Set Printing Implicit``, ``Set Printing Coercions``, ``Set Printing Synth``, -``Unset Printing Projections``, and ``Unset Printing Notations``. To reactivate -the high-level printing features, use the command +Otherwise said, :opt:`Printing All` includes the effects of the options +:opt:`Printing Implicit`, :opt:`Printing Coercions`, :opt:`Printing Synth`, +:opt:`Printing Projections`, and :opt:`Printing Notations`. To reactivate +the high-level printing features, use the command ``Unset Printing All``. -.. cmd:: Unset Printing All. +.. _printing-universes: Printing universes ------------------ -The following command: - -.. cmd:: Set Printing Universes. - -activates the display of the actual level of each occurrence of ``Type``. -See :ref:`TODO-4.1.1-sorts` for details. This wizard option, in combination -with ``Set Printing All`` (see :ref:`printing_constructions_full`) can help to diagnose failures -to unify terms apparently identical but internally different in the -Calculus of Inductive Constructions. To reactivate the display of the -actual level of the occurrences of Type, use +.. opt:: Printing Universes -.. cmd:: Unset Printing Universes. +Turn this option on to activate the display of the actual level of each +occurrence of :g:`Type`. See :ref:`Sorts` for details. This wizard option, in +combination with :opt:`Printing All` can help to diagnose failures to unify +terms apparently identical but internally different in the Calculus of Inductive +Constructions. The constraints on the internal level of the occurrences of Type -(see :ref:`TODO-4.1.1-sorts`) can be printed using the command +(see :ref:`Sorts`) can be printed using the command -.. cmd:: Print {? Sorted} Universes. +.. cmd:: Print {? Sorted} Universes + :name: Print Universes If the optional ``Sorted`` option is given, each universe will be made equivalent to a numbered label reflecting its level (with a linear @@ -2245,12 +2164,13 @@ ordering) in the universe hierarchy. This command also accepts an optional output filename: -.. cmd:: Print {? Sorted} Universes @string. +.. cmdv:: Print {? Sorted} Universes @string If `string` ends in ``.dot`` or ``.gv``, the constraints are printed in the DOT language, and can be processed by Graphviz tools. The format is unspecified if `string` doesn’t end in ``.dot`` or ``.gv``. +.. _existential-variables: Existential variables --------------------- @@ -2260,9 +2180,9 @@ subterms to eventually be replaced by actual subterms. Existential variables are generated in place of unsolvable implicit arguments or “_” placeholders when using commands such as ``Check`` (see -Section :ref:`TODO-6.3.1-check`) or when using tactics such as ``refine`` (see Section -:ref:`TODO-8.2.3-refine`), as well as in place of unsolvable instances when using -tactics such that ``eapply`` (see Section :ref:`TODO-8.2.4-apply`). An existential +Section :ref:`requests-to-the-environment`) or when using tactics such as +:tacn:`refine`, as well as in place of unsolvable instances when using +tactics such that :tacn:`eapply`. An existential variable is defined in a context, which is the context of variables of the placeholder which generated the existential variable, and a type, which is the expected type of the placeholder. @@ -2307,25 +2227,20 @@ existential variable used in the same context as its context of definition is wr Existential variables can be named by the user upon creation using the syntax ``?``\ `ident`. This is useful when the existential variable needs to be explicitly handled later in the script (e.g. -with a named-goal selector, see :ref:`TODO-9.2-goal-selectors`). +with a named-goal selector, see :ref:`goal-selectors`). .. _explicit-display-existentials: Explicit displaying of existential instances for pretty-printing ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The command: - -.. cmd:: Set Printing Existential Instances. - -activates the full display of how the context of an existential -variable is instantiated at each of the occurrences of the existential -variable. +.. opt:: Printing Existential Instances -To deactivate the full display of the instances of existential -variables, use +This option (off by default) activates the full display of how the +context of an existential variable is instantiated at each of the +occurrences of the existential variable. -.. cmd:: Unset Printing Existential Instances. +.. _tactics-in-terms: Solving existential variables using tactics ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -2338,7 +2253,7 @@ is not specified and is implementation-dependent. The inner tactic may use any variable defined in its scope, including repeated alternations between variables introduced by term binding as well as those introduced by tactic binding. The expression `tacexpr` can be any tactic -expression as described in :ref:`thetacticlanguage`. +expression as described in :ref:`ltac`. .. coqtop:: all @@ -2349,5 +2264,5 @@ using highly automated tactics without resorting to writing the proof-term by means of the interactive proof engine. This mechanism is comparable to the ``Declare Implicit Tactic`` command -defined at :ref:`TODO-8.9.7-implicit-automation`, except that the used +defined at :ref:`tactics-implicit-automation`, except that the used tactic is local to each hole instead of being declared globally. diff --git a/doc/sphinx/language/gallina-specification-language.rst b/doc/sphinx/language/gallina-specification-language.rst new file mode 100644 index 000000000..c26ae2a93 --- /dev/null +++ b/doc/sphinx/language/gallina-specification-language.rst @@ -0,0 +1,1363 @@ +.. _gallinaspecificationlanguage: + +------------------------------------ + The Gallina specification language +------------------------------------ + +This chapter describes Gallina, the specification language of Coq. It allows +developing mathematical theories and to prove specifications of programs. The +theories are built from axioms, hypotheses, parameters, lemmas, theorems and +definitions of constants, functions, predicates and sets. The syntax of logical +objects involved in theories is described in Section :ref:`term`. The +language of commands, called *The Vernacular* is described in Section +:ref:`vernacular`. + +In Coq, logical objects are typed to ensure their logical correctness. The +rules implemented by the typing algorithm are described in Chapter :ref:`calculusofinductiveconstructions`. + + +About the grammars in the manual +================================ + +Grammars are presented in Backus-Naur form (BNF). Terminal symbols are +set in black ``typewriter font``. In addition, there are special notations for +regular expressions. + +An expression enclosed in square brackets ``[…]`` means at most one +occurrence of this expression (this corresponds to an optional +component). + +The notation “``entry sep … sep entry``” stands for a non empty sequence +of expressions parsed by entry and separated by the literal “``sep``” [1]_. + +Similarly, the notation “``entry … entry``” stands for a non empty +sequence of expressions parsed by the “``entry``” entry, without any +separator between. + +At the end, the notation “``[entry sep … sep entry]``” stands for a +possibly empty sequence of expressions parsed by the “``entry``” entry, +separated by the literal “``sep``”. + + +Lexical conventions +=================== + +Blanks + Space, newline and horizontal tabulation are considered as blanks. + Blanks are ignored but they separate tokens. + +Comments + Comments in Coq are enclosed between ``(*`` and ``*)``, and can be nested. + They can contain any character. However, :token:`string` literals must be + correctly closed. Comments are treated as blanks. + +Identifiers and access identifiers + Identifiers, written :token:`ident`, are sequences of letters, digits, ``_`` and + ``'``, that do not start with a digit or ``'``. That is, they are + recognized by the following lexical class: + + .. productionlist:: coq + first_letter : a..z ∣ A..Z ∣ _ ∣ unicode-letter + subsequent_letter : a..z ∣ A..Z ∣ 0..9 ∣ _ ∣ ' ∣ unicode-letter ∣ unicode-id-part + ident : `first_letter`[`subsequent_letter`…`subsequent_letter`] + access_ident : .`ident` + + All characters are meaningful. In particular, identifiers are case-sensitive. + The entry ``unicode-letter`` non-exhaustively includes Latin, + Greek, Gothic, Cyrillic, Arabic, Hebrew, Georgian, Hangul, Hiragana + and Katakana characters, CJK ideographs, mathematical letter-like + symbols, hyphens, non-breaking space, … The entry ``unicode-id-part`` + non-exhaustively includes symbols for prime letters and subscripts. + + Access identifiers, written :token:`access_ident`, are identifiers prefixed by + `.` (dot) without blank. They are used in the syntax of qualified + identifiers. + +Natural numbers and integers + Numerals are sequences of digits. Integers are numerals optionally + preceded by a minus sign. + + .. productionlist:: coq + digit : 0..9 + num : `digit`…`digit` + integer : [-]`num` + +Strings + Strings are delimited by ``"`` (double quote), and enclose a sequence of + any characters different from ``"`` or the sequence ``""`` to denote the + double quote character. In grammars, the entry for quoted strings is + :production:`string`. + +Keywords + The following identifiers are reserved keywords, and cannot be + 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 + +Special tokens + The following sequences of characters are special tokens:: + + ! % & && ( () ) * + ++ , - -> . .( .. + / /\ : :: :< := :> ; < <- <-> <: <= <> = + => =_D > >-> >= ? ?= @ [ \/ ] ^ { | |- + || } ~ + + Lexical ambiguities are resolved according to the “longest match” + rule: when a sequence of non alphanumerical characters can be + decomposed into several different ways, then the first token is the + longest possible one (among all tokens defined at this moment), and so + on. + +.. _term: + +Terms +===== + +Syntax of terms +--------------- + +The following grammars describe the basic syntax of the terms of the +*Calculus of Inductive Constructions* (also called Cic). The formal +presentation of Cic is given in Chapter :ref:`calculusofinductiveconstructions`. Extensions of this syntax +are given in Chapter :ref:`extensionsofgallina`. How to customize the syntax +is described in Chapter :ref:`syntaxextensionsandinterpretationscopes`. + +.. productionlist:: coq + term : forall `binders` , `term` + : | fun `binders` => `term` + : | fix `fix_bodies` + : | cofix `cofix_bodies` + : | let `ident` [`binders`] [: `term`] := `term` in `term` + : | let fix `fix_body` in `term` + : | let cofix `cofix_body` in `term` + : | let ( [`name` , … , `name`] ) [`dep_ret_type`] := `term` in `term` + : | let ' `pattern` [in `term`] := `term` [`return_type`] in `term` + : | if `term` [`dep_ret_type`] then `term` else `term` + : | `term` : `term` + : | `term` <: `term` + : | `term` :> + : | `term` -> `term` + : | `term` `arg` … `arg` + : | @ `qualid` [`term` … `term`] + : | `term` % `ident` + : | match `match_item` , … , `match_item` [`return_type`] with + : [[|] `equation` | … | `equation`] end + : | `qualid` + : | `sort` + : | `num` + : | _ + : | ( `term` ) + arg : `term` + : | ( `ident` := `term` ) + binders : `binder` … `binder` + binder : `name` + : | ( `name` … `name` : `term` ) + : | ( `name` [: `term`] := `term` ) + : | ' `pattern` + name : `ident` | _ + qualid : `ident` | `qualid` `access_ident` + sort : Prop | Set | Type + fix_bodies : `fix_body` + : | `fix_body` with `fix_body` with … with `fix_body` for `ident` + cofix_bodies : `cofix_body` + : | `cofix_body` with `cofix_body` with … with `cofix_body` for `ident` + fix_body : `ident` `binders` [`annotation`] [: `term`] := `term` + cofix_body : `ident` [`binders`] [: `term`] := `term` + annotation : { struct `ident` } + match_item : `term` [as `name`] [in `qualid` [`pattern` … `pattern`]] + dep_ret_type : [as `name`] `return_type` + return_type : return `term` + equation : `mult_pattern` | … | `mult_pattern` => `term` + mult_pattern : `pattern` , … , `pattern` + pattern : `qualid` `pattern` … `pattern` + : | @ `qualid` `pattern` … `pattern` + : | `pattern` as `ident` + : | `pattern` % `ident` + : | `qualid` + : | _ + : | `num` + : | ( `or_pattern` , … , `or_pattern` ) + or_pattern : `pattern` | … | `pattern` + + +Types +----- + +Coq terms are typed. Coq types are recognized by the same syntactic +class as :token:`term`. We denote by :production:`type` the semantic subclass +of types inside the syntactic class :token:`term`. + +.. _gallina-identifiers: + +Qualified identifiers and simple identifiers +-------------------------------------------- + +*Qualified identifiers* (:token:`qualid`) denote *global constants* +(definitions, lemmas, theorems, remarks or facts), *global variables* +(parameters or axioms), *inductive types* or *constructors of inductive +types*. *Simple identifiers* (or shortly :token:`ident`) are a syntactic subset +of qualified identifiers. Identifiers may also denote *local variables*, +while qualified identifiers do not. + +Numerals +-------- + +Numerals have no definite semantics in the calculus. They are mere +notations that can be bound to objects through the notation mechanism +(see Chapter :ref:`syntaxextensionsandinterpretationscopes` for details). +Initially, numerals are bound to Peano’s representation of natural +numbers (see :ref:`datatypes`). + +.. note:: + + Negative integers are not at the same level as :token:`num`, for this + would make precedence unnatural. + +Sorts +----- + +There are three sorts :g:`Set`, :g:`Prop` and :g:`Type`. + +- :g:`Prop` is the universe of *logical propositions*. The logical propositions + themselves are typing the proofs. We denote propositions by :production:`form`. + This constitutes a semantic subclass of the syntactic class :token:`term`. + +- :g:`Set` is is the universe of *program types* or *specifications*. The + specifications themselves are typing the programs. We denote + 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` + +More on sorts can be found in Section :ref:`sorts`. + +.. _binders: + +Binders +------- + +Various constructions such as :g:`fun`, :g:`forall`, :g:`fix` and :g:`cofix` +*bind* variables. A binding is represented by an identifier. If the binding +variable is not used in the expression, the identifier can be replaced by the +symbol :g:`_`. When the type of a bound variable cannot be synthesized by the +system, it can be specified with the notation :n:`(@ident : @type)`. There is also +a notation for a sequence of binding variables sharing the same type: +:n:`({+ @ident} : @type)`. A +binder can also be any pattern prefixed by a quote, e.g. :g:`'(x,y)`. + +Some constructions allow the binding of a variable to value. This is +called a “let-binder”. The entry :token:`binder` of the grammar accepts +either an assumption binder as defined above or a let-binder. The notation in +the latter case is :n:`(@ident := @term)`. In a let-binder, only one +variable can be introduced at the same time. It is also possible to give +the type of the variable as follows: +:n:`(@ident : @type := @term)`. + +Lists of :token:`binder` are allowed. In the case of :g:`fun` and :g:`forall`, +it is intended that at least one binder of the list is an assumption otherwise +fun and forall gets identical. Moreover, parentheses can be omitted in +the case of a single sequence of bindings sharing the same type (e.g.: +:g:`fun (x y z : A) => t` can be shortened in :g:`fun x y z : A => t`). + +Abstractions +------------ + +The expression :n:`fun @ident : @type => @term` defines the +*abstraction* of the variable :token:`ident`, of type :token:`type`, over the term +:token:`term`. It denotes a function of the variable :token:`ident` that evaluates to +the expression :token:`term` (e.g. :g:`fun x : A => x` denotes the identity +function on type :g:`A`). The keyword :g:`fun` can be followed by several +binders as given in Section :ref:`binders`. Functions over +several variables are equivalent to an iteration of one-variable +functions. For instance the expression +“fun :token:`ident`\ :math:`_{1}` … :token:`ident`\ :math:`_{n}` +: :token:`type` => :token:`term`” +denotes the same function as “ fun :token:`ident`\ +:math:`_{1}` : :token:`type` => … +fun :token:`ident`\ :math:`_{n}` : :token:`type` => :token:`term`”. If +a let-binder occurs in +the list of binders, it is expanded to a let-in definition (see +Section :ref:`let-in`). + +Products +-------- + +The expression :n:`forall @ident : @type, @term` denotes the +*product* of the variable :token:`ident` of type :token:`type`, over the term :token:`term`. +As for abstractions, :g:`forall` is followed by a binder list, and products +over several variables are equivalent to an iteration of one-variable +products. Note that :token:`term` is intended to be a type. + +If the variable :token:`ident` occurs in :token:`term`, the product is called +*dependent product*. The intention behind a dependent product +:g:`forall x : A, B` is twofold. It denotes either +the universal quantification of the variable :g:`x` of type :g:`A` +in the proposition :g:`B` or the functional dependent product from +:g:`A` to :g:`B` (a construction usually written +:math:`\Pi_{x:A}.B` in set theory). + +Non dependent product types have a special notation: :g:`A -> B` stands for +:g:`forall _ : A, B`. The *non dependent product* is used both to denote +the propositional implication and function types. + +Applications +------------ + +The expression :token:`term`\ :math:`_0` :token:`term`\ :math:`_1` denotes the +application of :token:`term`\ :math:`_0` to :token:`term`\ :math:`_1`. + +The expression :token:`term`\ :math:`_0` :token:`term`\ :math:`_1` ... +:token:`term`\ :math:`_n` denotes the application of the term +:token:`term`\ :math:`_0` to the arguments :token:`term`\ :math:`_1` ... then +:token:`term`\ :math:`_n`. It is equivalent to ( … ( :token:`term`\ :math:`_0` +:token:`term`\ :math:`_1` ) … ) :token:`term`\ :math:`_n` : associativity is to the +left. + +The notation :n:`(@ident := @term)` for arguments is used for making +explicit the value of implicit arguments (see +Section :ref:`explicit-applications`). + +Type cast +--------- + +The expression :n:`@term : @type` is a type cast expression. It enforces +the type of :token:`term` to be :token:`type`. + +:n:`@term <: @type` locally sets up the virtual machine for checking that +:token:`term` has type :token:`type`. + +Inferable subterms +------------------ + +Expressions often contain redundant pieces of information. Subterms that can be +automatically inferred by Coq can be replaced by the symbol ``_`` and Coq will +guess the missing piece of information. + +.. _let-in: + +Let-in definitions +------------------ + +:n:`let @ident := @term in @term’` +denotes the local binding of :token:`term` to the variable +:token:`ident` in :token:`term`’. There is a syntactic sugar for let-in +definition of functions: :n:`let @ident {+ @binder} := @term in @term’` +stands for :n:`let @ident := fun {+ @binder} => @term in @term’`. + +Definition by case analysis +--------------------------- + +Objects of inductive types can be destructurated by a case-analysis +construction called *pattern-matching* expression. A pattern-matching +expression is used to analyze the structure of an inductive object and +to apply specific treatments accordingly. + +This paragraph describes the basic form of pattern-matching. See +Section :ref:`Mult-match` and Chapter :ref:`extendedpatternmatching` for the description +of the general form. The basic form of pattern-matching is characterized +by a single :token:`match_item` expression, a :token:`mult_pattern` restricted to a +single :token:`pattern` and :token:`pattern` restricted to the form +:n:`@qualid {* @ident}`. + +The expression match ":token:`term`:math:`_0` :token:`return_type` with +:token:`pattern`:math:`_1` => :token:`term`:math:`_1` :math:`|` … :math:`|` +:token:`pattern`:math:`_n` => :token:`term`:math:`_n` end" denotes a +*pattern-matching* over the term :token:`term`:math:`_0` (expected to be +of an inductive type :math:`I`). The terms :token:`term`:math:`_1`\ …\ +:token:`term`:math:`_n` are the *branches* of the pattern-matching +expression. Each of :token:`pattern`:math:`_i` has a form :token:`qualid` +:token:`ident` where :token:`qualid` must denote a constructor. There should be +exactly one branch for every constructor of :math:`I`. + +The :token:`return_type` expresses the type returned by the whole match +expression. There are several cases. In the *non dependent* case, all +branches have the same type, and the :token:`return_type` is the common type of +branches. In this case, :token:`return_type` can usually be omitted as it can be +inferred from the type of the branches [2]_. + +In the *dependent* case, there are three subcases. In the first subcase, +the type in each branch may depend on the exact value being matched in +the branch. In this case, the whole pattern-matching itself depends on +the term being matched. This dependency of the term being matched in the +return type is expressed with an “as :token:`ident`” clause where :token:`ident` +is dependent in the return type. For instance, in the following example: + +.. coqtop:: in + + Inductive bool : Type := true : bool | false : bool. + Inductive eq (A:Type) (x:A) : A -> Prop := eq_refl : eq A x x. + Inductive or (A:Prop) (B:Prop) : Prop := + | or_introl : A -> or A B + | or_intror : B -> or A B. + + Definition bool_case (b:bool) : or (eq bool b true) (eq bool b false) := + match b as x return or (eq bool x true) (eq bool x false) with + | true => or_introl (eq bool true true) (eq bool true false) (eq_refl bool true) + | false => or_intror (eq bool false true) (eq bool false false) (eq_refl bool false) + end. + +the branches have respective types ":g:`or (eq bool true true) (eq bool true false)`" +and ":g:`or (eq bool false true) (eq bool false false)`" while the whole +pattern-matching expression has type ":g:`or (eq bool b true) (eq bool b false)`", +the identifier :g:`b` being used to represent the dependency. + +.. note:: + + When the term being matched is a variable, the ``as`` clause can be + omitted and the term being matched can serve itself as binding name in + the return type. For instance, the following alternative definition is + accepted and has the same meaning as the previous one. + + .. coqtop:: in + + Definition bool_case (b:bool) : or (eq bool b true) (eq bool b false) := + match b return or (eq bool b true) (eq bool b false) with + | true => or_introl (eq bool true true) (eq bool true false) (eq_refl bool true) + | false => or_intror (eq bool false true) (eq bool false false) (eq_refl bool false) + end. + +The second subcase is only relevant for annotated inductive types such +as the equality predicate (see Section :ref:`coq-equality`), +the order predicate on natural numbers or the type of lists of a given +length (see Section :ref:`matching-dependent`). In this configuration, the +type of each branch can depend on the type dependencies specific to the +branch and the whole pattern-matching expression has a type determined +by the specific dependencies in the type of the term being matched. This +dependency of the return type in the annotations of the inductive type +is expressed using a “:g:`in` :math:`I` :g:`_ … _` :token:`pattern`:math:`_1` … +:token:`pattern`:math:`_n`” clause, where + +- :math:`I` is the inductive type of the term being matched; + +- the :g:`_` are matching the parameters of the inductive type: the + return type is not dependent on them. + +- the :token:`pattern`:math:`_i` are matching the annotations of the + inductive type: the return type is dependent on them + +- in the basic case which we describe below, each :token:`pattern`:math:`_i` + is a name :token:`ident`:math:`_i`; see :ref:`match-in-patterns` for the + general case + +For instance, in the following example: + +.. coqtop:: in + + Definition eq_sym (A:Type) (x y:A) (H:eq A x y) : eq A y x := + match H in eq _ _ z return eq A z x with + | eq_refl _ => eq_refl A x + end. + +the type of the branch is :g:`eq A x x` because the third argument of +:g:`eq` is :g:`x` in the type of the pattern :g:`eq_refl`. On the contrary, the +type of the whole pattern-matching expression has type :g:`eq A y x` because the +third argument of eq is y in the type of H. This dependency of the case analysis +in the third argument of :g:`eq` is expressed by the identifier :g:`z` in the +return type. + +Finally, the third subcase is a combination of the first and second +subcase. In particular, it only applies to pattern-matching on terms in +a type with annotations. For this third subcase, both the clauses ``as`` and +``in`` are available. + +There are specific notations for case analysis on types with one or two +constructors: ``if … then … else …`` and ``let (…,…) := … in …`` (see +Sections :ref:`if-then-else` and :ref:`irrefutable-patterns`). + +Recursive functions +------------------- + +The expression “``fix`` :token:`ident`:math:`_1` :token:`binder`:math:`_1` ``:`` +:token:`type`:math:`_1` ``:=`` :token:`term`:math:`_1` ``with … with`` +:token:`ident`:math:`_n` :token:`binder`:math:`_n` : :token:`type`:math:`_n` +``:=`` :token:`term`:math:`_n` ``for`` :token:`ident`:math:`_i`” denotes the +:math:`i`-th component of a block of functions defined by mutual structural +recursion. It is the local counterpart of the :cmd:`Fixpoint` command. When +:math:`n=1`, the “``for`` :token:`ident`:math:`_i`” clause is omitted. + +The expression “``cofix`` :token:`ident`:math:`_1` :token:`binder`:math:`_1` ``:`` +:token:`type`:math:`_1` ``with … with`` :token:`ident`:math:`_n` :token:`binder`:math:`_n` +: :token:`type`:math:`_n` ``for`` :token:`ident`:math:`_i`” denotes the +:math:`i`-th component of a block of terms defined by a mutual guarded +co-recursion. It is the local counterpart of the :cmd:`CoFixpoint` command. When +:math:`n=1`, the “``for`` :token:`ident`:math:`_i`” clause is omitted. + +The association of a single fixpoint and a local definition have a special +syntax: :n:`let fix @ident @binders := @term in` stands for +:n:`let @ident := fix @ident @binders := @term in`. The same applies for co-fixpoints. + +.. _vernacular: + +The Vernacular +============== + +.. productionlist:: coq + sentence : `assumption` + : | `definition` + : | `inductive` + : | `fixpoint` + : | `assertion` `proof` + assumption : `assumption_keyword` `assums`. + assumption_keyword : Axiom | Conjecture + : | Parameter | Parameters + : | Variable | Variables + : | Hypothesis | Hypotheses + assums : `ident` … `ident` : `term` + : | ( `ident` … `ident` : `term` ) … ( `ident` … `ident` : `term` ) + definition : [Local] Definition `ident` [`binders`] [: `term`] := `term` . + : | Let `ident` [`binders`] [: `term`] := `term` . + inductive : Inductive `ind_body` with … with `ind_body` . + : | CoInductive `ind_body` with … with `ind_body` . + ind_body : `ident` [`binders`] : `term` := + : [[|] `ident` [`binders`] [:`term`] | … | `ident` [`binders`] [:`term`]] + fixpoint : Fixpoint `fix_body` with … with `fix_body` . + : | CoFixpoint `cofix_body` with … with `cofix_body` . + assertion : `assertion_keyword` `ident` [`binders`] : `term` . + assertion_keyword : Theorem | Lemma + : | Remark | Fact + : | Corollary | Proposition + : | Definition | Example + proof : Proof . … Qed . + : | Proof . … Defined . + : | Proof . … Admitted . + +.. todo:: This use of … in this grammar is inconsistent + What about removing the proof part of this grammar from this chapter + and putting it somewhere where top-level tactics can be described as well? + See also #7583. + +This grammar describes *The Vernacular* which is the language of +commands of Gallina. A sentence of the vernacular language, like in +many natural languages, begins with a capital letter and ends with a +dot. + +The different kinds of command are described hereafter. They all suppose +that the terms occurring in the sentences are well-typed. + +.. _gallina-assumptions: + +Assumptions +----------- + +Assumptions extend the environment with axioms, parameters, hypotheses +or variables. An assumption binds an :token:`ident` to a :token:`type`. It is accepted +by Coq if and only if this :token:`type` is a correct type in the environment +preexisting the declaration and if :token:`ident` was not previously defined in +the same module. This :token:`type` is considered to be the type (or +specification, or statement) assumed by :token:`ident` and we say that :token:`ident` +has type :token:`type`. + +.. _Axiom: + +.. cmd:: Parameter @ident : @type + + This command links :token:`type` to the name :token:`ident` as its specification in + the global context. The fact asserted by :token:`type` is thus assumed as a + postulate. + + .. exn:: @ident already exists. + :name: @ident already exists. (Axiom) + :undocumented: + + .. cmdv:: Parameter {+ @ident } : @type + + Adds several parameters with specification :token:`type`. + + .. cmdv:: Parameter {+ ( {+ @ident } : @type ) } + + Adds blocks of parameters with different specifications. + + .. cmdv:: Local Parameter {+ ( {+ @ident } : @type ) } + :name: Local Parameter + + Such parameters are never made accessible through their unqualified name by + :cmd:`Import` and its variants. You have to explicitly give their fully + qualified name to refer to them. + + .. cmdv:: {? Local } Parameters {+ ( {+ @ident } : @type ) } + {? Local } Axiom {+ ( {+ @ident } : @type ) } + {? Local } Axioms {+ ( {+ @ident } : @type ) } + {? Local } Conjecture {+ ( {+ @ident } : @type ) } + {? Local } Conjectures {+ ( {+ @ident } : @type ) } + :name: Parameters; Axiom; Axioms; Conjecture; Conjectures + + These variants are synonyms of :n:`{? Local } Parameter {+ ( {+ @ident } : @type ) }`. + +.. cmd:: Variable @ident : @type + + This command links :token:`type` to the name :token:`ident` in the context of + the current section (see Section :ref:`section-mechanism` for a description of + the section mechanism). When the current section is closed, name :token:`ident` + will be unknown and every object using this variable will be explicitly + parametrized (the variable is *discharged*). Using the :cmd:`Variable` command out + of any section is equivalent to using :cmd:`Local Parameter`. + + .. exn:: @ident already exists. + :name: @ident already exists. (Variable) + :undocumented: + + .. cmdv:: Variable {+ @ident } : @term + + Links :token:`type` to each :token:`ident`. + + .. cmdv:: Variable {+ ( {+ @ident } : @term ) } + + Adds blocks of variables with different specifications. + + .. cmdv:: Variables {+ ( {+ @ident } : @term) } + Hypothesis {+ ( {+ @ident } : @term) } + Hypotheses {+ ( {+ @ident } : @term) } + :name: Variables; Hypothesis; Hypotheses + + These variants are synonyms of :n:`Variable {+ ( {+ @ident } : @term) }`. + +.. note:: + It is advised to use the commands :cmd:`Axiom`, :cmd:`Conjecture` and + :cmd:`Hypothesis` (and their plural forms) for logical postulates (i.e. when + the assertion :token:`type` is of sort :g:`Prop`), and to use the commands + :cmd:`Parameter` and :cmd:`Variable` (and their plural forms) in other cases + (corresponding to the declaration of an abstract mathematical entity). + +.. _gallina-definitions: + +Definitions +----------- + +Definitions extend the environment with associations of names to terms. +A definition can be seen as a way to give a meaning to a name or as a +way to abbreviate a term. In any case, the name can later be replaced at +any time by its definition. + +The operation of unfolding a name into its definition is called +:math:`\delta`-conversion (see Section :ref:`delta-reduction`). A +definition is accepted by the system if and only if the defined term is +well-typed in the current context of the definition and if the name is +not already used. The name defined by the definition is called a +*constant* and the term it refers to is its *body*. A definition has a +type which is the type of its body. + +A formal presentation of constants and environments is given in +Section :ref:`typing-rules`. + +.. cmd:: Definition @ident := @term + + This command binds :token:`term` to the name :token:`ident` in the environment, + provided that :token:`term` is well-typed. + + .. exn:: @ident already exists. + :name: @ident already exists. (Definition) + :undocumented: + + .. cmdv:: Definition @ident : @type := @term + + This variant checks that the type of :token:`term` is definitionally equal to + :token:`type`, and registers :token:`ident` as being of type + :token:`type`, and bound to value :token:`term`. + + .. exn:: The term @term has type @type while it is expected to have type @type'. + :undocumented: + + .. cmdv:: Definition @ident @binders {? : @term } := @term + + This is equivalent to + :n:`Definition @ident : forall @binders, @term := fun @binders => @term`. + + .. cmdv:: Local Definition @ident {? @binders } {? : @type } := @term + :name: Local Definition + + Such definitions are never made accessible through their + unqualified name by :cmd:`Import` and its variants. + You have to explicitly give their fully qualified name to refer to them. + + .. cmdv:: {? Local } Example @ident {? @binders } {? : @type } := @term + :name: Example + + This is equivalent to :cmd:`Definition`. + +.. seealso:: :cmd:`Opaque`, :cmd:`Transparent`, :tacn:`unfold`. + +.. cmd:: Let @ident := @term + + This command binds the value :token:`term` to the name :token:`ident` in the + environment of the current section. The name :token:`ident` disappears when the + current section is eventually closed, and all persistent objects (such + as theorems) defined within the section and depending on :token:`ident` are + prefixed by the let-in definition :n:`let @ident := @term in`. + Using the :cmd:`Let` command out of any section is equivalent to using + :cmd:`Local Definition`. + + .. exn:: @ident already exists. + :name: @ident already exists. (Let) + :undocumented: + + .. cmdv:: Let @ident {? @binders } {? : @type } := @term + :undocumented: + + .. cmdv:: Let Fixpoint @ident @fix_body {* with @fix_body} + :name: Let Fixpoint + :undocumented: + + .. cmdv:: Let CoFixpoint @ident @cofix_body {* with @cofix_body} + :name: Let CoFixpoint + :undocumented: + +.. seealso:: Section :ref:`section-mechanism`, commands :cmd:`Opaque`, + :cmd:`Transparent`, and tactic :tacn:`unfold`. + +.. _gallina-inductive-definitions: + +Inductive definitions +--------------------- + +We gradually explain simple inductive types, simple annotated inductive +types, simple parametric inductive types, mutually inductive types. We +explain also co-inductive types. + +Simple inductive types +~~~~~~~~~~~~~~~~~~~~~~ + +.. cmd:: Inductive @ident : {? @sort } := {? | } @ident : @type {* | @ident : @type } + + This command defines a simple inductive type and its constructors. + The first :token:`ident` is the name of the inductively defined type + and :token:`sort` is the universe where it lives. The next :token:`ident`\s + 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`. + The type of the destructors expresses structural induction/recursion + principles over objects of type :token:`ident`. + The constant :token:`ident`\ ``_ind`` is always provided, + whereas :token:`ident`\ ``_rec`` and :token:`ident`\ ``_rect`` can be + impossible to derive (for example, when :token:`ident` is a proposition). + + .. exn:: Non strictly positive occurrence of @ident in @type. + + The types of the constructors have to satisfy a *positivity condition* + (see Section :ref:`positivity`). This condition ensures the soundness of + the inductive definition. + + .. exn:: The conclusion of @type is not valid; it must be built from @ident. + + The conclusion of the type of the constructors must be the inductive type + :token:`ident` being defined (or :token:`ident` applied to arguments in + the case of annotated inductive types — cf. next section). + + .. example:: + The set of natural numbers is defined as: + + .. coqtop:: all + + Inductive nat : Set := + | O : nat + | S : nat -> nat. + + The type nat is defined as the least :g:`Set` containing :g:`O` and closed by + the :g:`S` constructor. The names :g:`nat`, :g:`O` and :g:`S` are added to the + environment. + + Now let us have a look at the elimination principles. They are three of them: + :g:`nat_ind`, :g:`nat_rec` and :g:`nat_rect`. The type of :g:`nat_ind` is: + + .. coqtop:: all + + Check nat_ind. + + This is the well known structural induction principle over natural + numbers, i.e. the second-order form of Peano’s induction principle. It + allows proving some universal property of natural numbers (:g:`forall + n:nat, P n`) by induction on :g:`n`. + + The types of :g:`nat_rec` and :g:`nat_rect` are similar, except that they pertain + to :g:`(P:nat->Set)` and :g:`(P:nat->Type)` respectively. They correspond to + primitive induction principles (allowing dependent types) respectively + over sorts ``Set`` and ``Type``. + + .. cmdv:: Inductive @ident {? : @sort } := {? | } {*| @ident {? @binders } {? : @type } } + + Constructors :token:`ident`\s can come with :token:`binders` in which case, + the actual type of the constructor is :n:`forall @binders, @type`. + + In the case where inductive types have no annotations (next section + gives an example of such annotations), a constructor can be defined + by only giving the type of its arguments. + + .. example:: + + .. coqtop:: in + + Inductive nat : Set := O | S (_:nat). + + +Simple annotated inductive types +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +In an annotated inductive types, the universe where the inductive type +is defined is no longer a simple sort, but what is called an arity, +which is a type whose conclusion is a sort. + +.. example:: + + As an example of annotated inductive types, let us define the + :g:`even` predicate: + + .. coqtop:: all + + Inductive even : nat -> Prop := + | even_0 : even O + | even_SS : forall n:nat, even n -> even (S (S n)). + + The type :g:`nat->Prop` means that even is a unary predicate (inductively + defined) over natural numbers. The type of its two constructors are the + defining clauses of the predicate even. The type of :g:`even_ind` is: + + .. coqtop:: all + + Check even_ind. + + From a mathematical point of view it asserts that the natural numbers satisfying + the predicate even are exactly in the smallest set of naturals satisfying the + clauses :g:`even_0` or :g:`even_SS`. This is why, when we want to prove any + predicate :g:`P` over elements of :g:`even`, it is enough to prove it for :g:`O` + and to prove that if any natural number :g:`n` satisfies :g:`P` its double + successor :g:`(S (S n))` satisfies also :g:`P`. This is indeed analogous to the + structural induction principle we got for :g:`nat`. + +Parametrized inductive types +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +.. cmdv:: Inductive @ident @binders {? : @type } := {? | } @ident : @type {* | @ident : @type} + + In the previous example, each constructor introduces a different + instance of the predicate :g:`even`. In some cases, all the constructors + introduce the same generic instance of the inductive definition, in + which case, instead of an annotation, we use a context of parameters + which are :token:`binders` shared by all the constructors of the definition. + + Parameters differ from inductive type annotations in the fact that the + conclusion of each type of constructor invoke the inductive type with + the same values of parameters as its specification. + + .. example:: + + A typical example is the definition of polymorphic lists: + + .. coqtop:: in + + Inductive list (A:Set) : Set := + | nil : list A + | cons : A -> list A -> list A. + + In the type of :g:`nil` and :g:`cons`, we write :g:`(list A)` and not + just :g:`list`. The constructors :g:`nil` and :g:`cons` will have respectively + types: + + .. coqtop:: all + + Check nil. + Check cons. + + Types of destructors are also quantified with :g:`(A:Set)`. + + Once again, it is possible to specify only the type of the arguments + of the constructors, and to omit the type of the conclusion: + + .. coqtop:: in + + Inductive list (A:Set) : Set := nil | cons (_:A) (_:list A). + +.. note:: + + It is possible in the type of a constructor, to + invoke recursively the inductive definition on an argument which is not + the parameter itself. + + One can define : + + .. coqtop:: all + + Inductive list2 (A:Set) : Set := + | nil2 : list2 A + | cons2 : A -> list2 (A*A) -> list2 A. + + that can also be written by specifying only the type of the arguments: + + .. coqtop:: all reset + + Inductive list2 (A:Set) : Set := nil2 | cons2 (_:A) (_:list2 (A*A)). + + But the following definition will give an error: + + .. coqtop:: all + + Fail Inductive listw (A:Set) : Set := + | nilw : listw (A*A) + | consw : A -> listw (A*A) -> listw (A*A). + + because the conclusion of the type of constructors should be :g:`listw A` + in both cases. + + + A parametrized inductive definition can be defined using annotations + instead of parameters but it will sometimes give a different (bigger) + sort for the inductive definition and will produce a less convenient + rule for case elimination. + +.. seealso:: + Section :ref:`inductive-definitions` and the :tacn:`induction` tactic. + +Variants +~~~~~~~~ + +.. cmd:: Variant @ident @binders {? : @type } := {? | } @ident : @type {* | @ident : @type} + + The :cmd:`Variant` command is identical to the :cmd:`Inductive` command, except + that it disallows recursive definition of types (for instance, lists cannot + be defined using :cmd:`Variant`). No induction scheme is generated for + this variant, unless option :opt:`Nonrecursive Elimination Schemes` is on. + + .. exn:: The @num th argument of @ident must be @ident in @type. + :undocumented: + +Mutually defined inductive types +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +.. cmdv:: Inductive @ident {? : @type } := {? | } {*| @ident : @type } {* with {? | } {*| @ident {? : @type } } } + + This variant allows defining a block of mutually inductive types. + It has the same semantics as the above :cmd:`Inductive` definition for each + :token:`ident`. All :token:`ident` are simultaneously added to the environment. + Then well-typing of constructors can be checked. Each one of the :token:`ident` + can be used on its own. + + .. cmdv:: Inductive @ident @binders {? : @type } := {? | } {*| @ident : @type } {* with {? | } {*| @ident @binders {? : @type } } } + + In this variant, the inductive definitions are parametrized + with :token:`binders`. However, parameters correspond to a local context + in which the whole set of inductive declarations is done. For this + reason, the parameters must be strictly the same for each inductive types. + +.. example:: + The typical example of a mutual inductive data type is the one for trees and + forests. We assume given two types :g:`A` and :g:`B` as variables. It can + be declared the following way. + + .. coqtop:: in + + Variables A B : Set. + + Inductive tree : Set := node : A -> forest -> tree + + with forest : Set := + | leaf : B -> forest + | cons : tree -> forest -> forest. + + This declaration generates automatically six induction principles. They are + respectively called :g:`tree_rec`, :g:`tree_ind`, :g:`tree_rect`, + :g:`forest_rec`, :g:`forest_ind`, :g:`forest_rect`. These ones are not the most + general ones but are just the induction principles corresponding to each + inductive part seen as a single inductive definition. + + To illustrate this point on our example, we give the types of :g:`tree_rec` + and :g:`forest_rec`. + + .. coqtop:: all + + Check tree_rec. + + Check forest_rec. + + Assume we want to parametrize our mutual inductive definitions with the + two type variables :g:`A` and :g:`B`, the declaration should be + done the following way: + + .. coqtop:: in + + Inductive tree (A B:Set) : Set := node : A -> forest A B -> tree A B + + with forest (A B:Set) : Set := + | leaf : B -> forest A B + | cons : tree A B -> forest A B -> forest A B. + + Assume we define an inductive definition inside a section + (cf. :ref:`section-mechanism`). When the section is closed, the variables + declared in the section and occurring free in the declaration are added as + parameters to the inductive definition. + +.. seealso:: + A generic command :cmd:`Scheme` is useful to build automatically various + mutual induction principles. + +.. _coinductive-types: + +Co-inductive types +~~~~~~~~~~~~~~~~~~ + +The objects of an inductive type are well-founded with respect to the +constructors of the type. In other words, such objects contain only a +*finite* number of constructors. Co-inductive types arise from relaxing +this condition, and admitting types whose objects contain an infinity of +constructors. Infinite objects are introduced by a non-ending (but +effective) process of construction, defined in terms of the constructors +of the type. + +.. cmd:: CoInductive @ident @binders {? : @type } := {? | } @ident : @type {* | @ident : @type} + + This command introduces a co-inductive type. + The syntax of the command is the same as the command :cmd:`Inductive`. + No principle of induction is derived from the definition of a co-inductive + type, since such principles only make sense for inductive types. + For co-inductive types, the only elimination principle is case analysis. + +.. example:: + An example of a co-inductive type is the type of infinite sequences of + natural numbers, usually called streams. + + .. coqtop:: in + + CoInductive Stream : Set := Seq : nat -> Stream -> Stream. + + The usual destructors on streams :g:`hd:Stream->nat` and :g:`tl:Str->Str` + can be defined as follows: + + .. coqtop:: in + + Definition hd (x:Stream) := let (a,s) := x in a. + Definition tl (x:Stream) := let (a,s) := x in s. + +Definition of co-inductive predicates and blocks of mutually +co-inductive definitions are also allowed. + +.. example:: + An example of a co-inductive predicate is the extensional equality on + streams: + + .. coqtop:: in + + CoInductive EqSt : Stream -> Stream -> Prop := + eqst : forall s1 s2:Stream, + hd s1 = hd s2 -> EqSt (tl s1) (tl s2) -> EqSt s1 s2. + + In order to prove the extensional equality of two streams :g:`s1` and :g:`s2` + we have to construct an infinite proof of equality, that is, an infinite + object of type :g:`(EqSt s1 s2)`. We will see how to introduce infinite + objects in Section :ref:`cofixpoint`. + +Definition of recursive functions +--------------------------------- + +Definition of functions by recursion over inductive objects +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +This section describes the primitive form of definition by recursion over +inductive objects. See the :cmd:`Function` command for more advanced +constructions. + +.. _Fixpoint: + +.. cmd:: Fixpoint @ident @binders {? {struct @ident} } {? : @type } := @term + + This command allows defining functions by pattern-matching over inductive + objects using a fixed point construction. The meaning of this declaration is + to define :token:`ident` a recursive function with arguments specified by + the :token:`binders` such that :token:`ident` applied to arguments + corresponding to these :token:`binders` has type :token:`type`, and is + equivalent to the expression :token:`term`. The type of :token:`ident` is + consequently :n:`forall @binders, @type` and its value is equivalent + to :n:`fun @binders => @term`. + + To be accepted, a :cmd:`Fixpoint` definition has to satisfy some syntactical + constraints on a special argument called the decreasing argument. They + are needed to ensure that the :cmd:`Fixpoint` definition always terminates. + The point of the :n:`{struct @ident}` annotation is to let the user tell the + system which argument decreases along the recursive calls. + + The :n:`{struct @ident}` annotation may be left implicit, in this case the + system tries successively arguments from left to right until it finds one + that satisfies the decreasing condition. + + .. note:: + + + Some fixpoints may have several arguments that fit as decreasing + arguments, and this choice influences the reduction of the fixpoint. + Hence an explicit annotation must be used if the leftmost decreasing + argument is not the desired one. Writing explicit annotations can also + speed up type-checking of large mutual fixpoints. + + + In order to keep the strong normalization property, the fixed point + reduction will only be performed when the argument in position of the + decreasing argument (which type should be in an inductive definition) + starts with a constructor. + + + .. example:: + One can define the addition function as : + + .. coqtop:: all + + Fixpoint add (n m:nat) {struct n} : nat := + match n with + | O => m + | S p => S (add p m) + end. + + The match operator matches a value (here :g:`n`) with the various + constructors of its (inductive) type. The remaining arguments give the + respective values to be returned, as functions of the parameters of the + corresponding constructor. Thus here when :g:`n` equals :g:`O` we return + :g:`m`, and when :g:`n` equals :g:`(S p)` we return :g:`(S (add p m))`. + + The match operator is formally described in + Section :ref:`match-construction`. + The system recognizes that in the inductive call :g:`(add p m)` the first + argument actually decreases because it is a *pattern variable* coming + from :g:`match n with`. + + .. example:: + + The following definition is not correct and generates an error message: + + .. coqtop:: all + + Fail Fixpoint wrongplus (n m:nat) {struct n} : nat := + match m with + | O => n + | S p => S (wrongplus n p) + end. + + because the declared decreasing argument :g:`n` does not actually + decrease in the recursive call. The function computing the addition over + the second argument should rather be written: + + .. coqtop:: all + + Fixpoint plus (n m:nat) {struct m} : nat := + match m with + | O => n + | S p => S (plus n p) + end. + + .. example:: + + The recursive call may not only be on direct subterms of the recursive + variable :g:`n` but also on a deeper subterm and we can directly write + the function :g:`mod2` which gives the remainder modulo 2 of a natural + number. + + .. coqtop:: all + + Fixpoint mod2 (n:nat) : nat := + match n with + | O => O + | S p => match p with + | O => S O + | S q => mod2 q + end + end. + + + .. cmdv:: Fixpoint @ident @binders {? {struct @ident} } {? : @type } := @term {* with @ident @binders {? : @type } := @term } + + This variant allows defining simultaneously several mutual fixpoints. + It is especially useful when defining functions over mutually defined + inductive types. + + .. example:: + The size of trees and forests can be defined the following way: + + .. coqtop:: all + + Fixpoint tree_size (t:tree) : nat := + match t with + | node a f => S (forest_size f) + end + with forest_size (f:forest) : nat := + match f with + | leaf b => 1 + | cons t f' => (tree_size t + forest_size f') + end. + +.. _cofixpoint: + +Definitions of recursive objects in co-inductive types +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +.. cmd:: CoFixpoint @ident {? @binders } {? : @type } := @term + + This command introduces a method for constructing an infinite object of a + coinductive type. For example, the stream containing all natural numbers can + be introduced applying the following method to the number :g:`O` (see + Section :ref:`coinductive-types` for the definition of :g:`Stream`, :g:`hd` + and :g:`tl`): + + .. coqtop:: all + + CoFixpoint from (n:nat) : Stream := Seq n (from (S n)). + + Oppositely to recursive ones, there is no decreasing argument in a + co-recursive definition. To be admissible, a method of construction must + provide at least one extra constructor of the infinite object for each + iteration. A syntactical guard condition is imposed on co-recursive + definitions in order to ensure this: each recursive call in the + definition must be protected by at least one constructor, and only by + constructors. That is the case in the former definition, where the single + recursive call of :g:`from` is guarded by an application of :g:`Seq`. + On the contrary, the following recursive function does not satisfy the + guard condition: + + .. coqtop:: all + + Fail CoFixpoint filter (p:nat -> bool) (s:Stream) : Stream := + if p (hd s) then Seq (hd s) (filter p (tl s)) else filter p (tl s). + + The elimination of co-recursive definition is done lazily, i.e. the + definition is expanded only when it occurs at the head of an application + which is the argument of a case analysis expression. In any other + context, it is considered as a canonical expression which is completely + evaluated. We can test this using the command :cmd:`Eval`, which computes + the normal forms of a term: + + .. coqtop:: all + + Eval compute in (from 0). + Eval compute in (hd (from 0)). + Eval compute in (tl (from 0)). + + .. cmdv:: CoFixpoint @ident {? @binders } {? : @type } := @term {* with @ident {? @binders } : {? @type } := @term } + + As in the :cmd:`Fixpoint` command, it is possible to introduce a block of + mutually dependent methods. + +.. _Assertions: + +Assertions and proofs +--------------------- + +An assertion states a proposition (or a type) of which the proof (or an +inhabitant of the type) is interactively built using tactics. The interactive +proof mode is described in Chapter :ref:`proofhandling` and the tactics in +Chapter :ref:`Tactics`. The basic assertion command is: + +.. cmd:: Theorem @ident {? @binders } : @type + + After the statement is asserted, Coq needs a proof. Once a proof of + :token:`type` under the assumptions represented by :token:`binders` is given and + validated, the proof is generalized into a proof of :n:`forall @binders, @type` and + the theorem is bound to the name :token:`ident` in the environment. + + .. exn:: The term @term has type @type which should be Set, Prop or Type. + :undocumented: + + .. exn:: @ident already exists. + :name: @ident already exists. (Theorem) + + The name you provided is already defined. You have then to choose + another name. + + .. exn:: Nested proofs are not allowed unless you turn option Nested Proofs Allowed on. + + You are asserting a new statement while already being in proof editing mode. + This feature, called nested proofs, is disabled by default. + To activate it, turn option :opt:`Nested Proofs Allowed` on. + + .. cmdv:: Lemma @ident {? @binders } : @type + Remark @ident {? @binders } : @type + Fact @ident {? @binders } : @type + Corollary @ident {? @binders } : @type + Proposition @ident {? @binders } : @type + :name: Lemma; Remark; Fact; Corollary; Proposition + + These commands are all synonyms of :n:`Theorem @ident {? @binders } : type`. + +.. cmdv:: Theorem @ident {? @binders } : @type {* with @ident {? @binders } : @type} + + This command is useful for theorems that are proved by simultaneous induction + over a mutually inductive assumption, or that assert mutually dependent + statements in some mutual co-inductive type. It is equivalent to + :cmd:`Fixpoint` or :cmd:`CoFixpoint` but using tactics to build the proof of + the statements (or the body of the specification, depending on the point of + view). The inductive or co-inductive types on which the induction or + coinduction has to be done is assumed to be non ambiguous and is guessed by + the system. + + Like in a :cmd:`Fixpoint` or :cmd:`CoFixpoint` definition, the induction hypotheses + have to be used on *structurally smaller* arguments (for a :cmd:`Fixpoint`) or + be *guarded by a constructor* (for a :cmd:`CoFixpoint`). The verification that + recursive proof arguments are correct is done only at the time of registering + the lemma in the environment. To know if the use of induction hypotheses is + correct at some time of the interactive development of a proof, use the + command :cmd:`Guarded`. + + The command can be used also with :cmd:`Lemma`, :cmd:`Remark`, etc. instead of + :cmd:`Theorem`. + +.. cmdv:: Definition @ident {? @binders } : @type + + This allows defining a term of type :token:`type` using the proof editing + mode. It behaves as :cmd:`Theorem` but is intended to be used in conjunction with + :cmd:`Defined` in order to define a constant of which the computational + behavior is relevant. + + The command can be used also with :cmd:`Example` instead of :cmd:`Definition`. + + .. seealso:: :cmd:`Opaque`, :cmd:`Transparent`, :tacn:`unfold`. + +.. cmdv:: Let @ident {? @binders } : @type + + Like :n:`Definition @ident {? @binders } : @type` except that the definition is + turned into a let-in definition generalized over the declarations depending + on it after closing the current section. + +.. cmdv:: Fixpoint @ident @binders : @type {* with @ident @binders : @type} + + This generalizes the syntax of :cmd:`Fixpoint` so that one or more bodies + can be defined interactively using the proof editing mode (when a + body is omitted, its type is mandatory in the syntax). When the block + of proofs is completed, it is intended to be ended by :cmd:`Defined`. + +.. cmdv:: CoFixpoint @ident {? @binders } : @type {* with @ident {? @binders } : @type} + + This generalizes the syntax of :cmd:`CoFixpoint` so that one or more bodies + can be defined interactively using the proof editing mode. + +A proof starts by the keyword :cmd:`Proof`. Then Coq enters the proof editing mode +until the proof is completed. The proof editing mode essentially contains +tactics that are described in chapter :ref:`Tactics`. Besides tactics, there +are commands to manage the proof editing mode. They are described in Chapter +:ref:`proofhandling`. + +When the proof is completed it should be validated and put in the environment +using the keyword :cmd:`Qed`. + +.. note:: + + #. Several statements can be simultaneously asserted provided option + :opt:`Nested Proofs Allowed` was turned on. + + #. Not only other assertions but any vernacular command can be given + while in the process of proving a given assertion. In this case, the + command is understood as if it would have been given before the + statements still to be proved. Nonetheless, this practice is discouraged + and may stop working in future versions. + + #. Proofs ended by :cmd:`Qed` are declared opaque. Their content cannot be + unfolded (see :ref:`performingcomputations`), thus + realizing some form of *proof-irrelevance*. To be able to unfold a + proof, the proof should be ended by :cmd:`Defined`. + + #. :cmd:`Proof` is recommended but can currently be omitted. On the opposite + side, :cmd:`Qed` (or :cmd:`Defined`) is mandatory to validate a proof. + + #. One can also use :cmd:`Admitted` in place of :cmd:`Qed` to turn the + current asserted statement into an axiom and exit the proof editing mode. + +.. [1] + This is similar to the expression “*entry* :math:`\{` sep *entry* + :math:`\}`” in standard BNF, or “*entry* :math:`(` sep *entry* + :math:`)`\ \*” in the syntax of regular expressions. + +.. [2] + Except if the inductive type is empty in which case there is no + equation that can be used to infer the return type. diff --git a/doc/sphinx/practical-tools/coq-commands.rst b/doc/sphinx/practical-tools/coq-commands.rst index 1ff808894..ad1f0caa6 100644 --- a/doc/sphinx/practical-tools/coq-commands.rst +++ b/doc/sphinx/practical-tools/coq-commands.rst @@ -16,6 +16,8 @@ The options are (basically) the same for the first two commands, and roughly described below. You can also look at the ``man`` pages of ``coqtop`` and ``coqc`` for more details. +.. _interactive-use: + Interactive use (coqtop) ------------------------ @@ -39,10 +41,12 @@ Batch compilation (coqc) The ``coqc`` command takes a name *file* as argument. Then it looks for a vernacular file named *file*.v, and tries to compile it into a -*file*.vo file (See :ref:`TODO-6.5`). Warning: The name *file* should be a -regular |Coq| identifier, as defined in Section :ref:'TODO-1.1'. It should contain -only letters, digits or underscores (_). For instance, ``/bar/foo/toto.v`` is valid, but -``/bar/foo/to-to.v`` is invalid. +*file*.vo file (See :ref:`compiled-files`). + +.. caution:: The name *file* should be a + regular |Coq| identifier, as defined in Section :ref:'TODO-1.1'. It should contain + only letters, digits or underscores (_). For instance, ``/bar/foo/toto.v`` is valid, but + ``/bar/foo/to-to.v`` is invalid. Customization at launch time @@ -51,18 +55,24 @@ Customization at launch time By resource file ~~~~~~~~~~~~~~~~~~~~~~~ -When |Coq| is launched, with either ``coqtop`` or ``coqc``, the resource file -``$XDG_CONFIG_HOME/coq/coqrc.xxx`` is loaded, where ``$XDG_CONFIG_HOME`` +When |Coq| is launched, with either ``coqtop`` or ``coqc``, the +resource file ``$XDG_CONFIG_HOME/coq/coqrc.xxx``, if it exists, will +be implicitly prepended to any document read by Coq, whether it is an +interactive session or a file to compile. Here, ``$XDG_CONFIG_HOME`` is the configuration directory of the user (by default its home -directory ``/.config`` and ``xxx`` is the version number (e.g. 8.8). If +directory ``~/.config``) and ``xxx`` is the version number (e.g. 8.8). If this file is not found, then the file ``$XDG_CONFIG_HOME/coqrc`` is -searched. You can also specify an arbitrary name for the resource file +searched. If not found, it is the file ``~/.coqrc.xxx`` which is searched, +and, if still not found, the file ``~/.coqrc``. If the latter is also +absent, no resource file is loaded. +You can also specify an arbitrary name for the resource file (see option ``-init-file`` below). -This file may contain, for instance, ``Add LoadPath`` commands to add +The resource file may contain, for instance, ``Add LoadPath`` commands to add directories to the load path of |Coq|. It is possible to skip the loading of the resource file with the option ``-q``. +.. _customization-by-environment-variables: By environment variables ~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -70,7 +80,7 @@ By environment variables Load path can be specified to the |Coq| system by setting up ``$COQPATH`` environment variable. It is a list of directories separated by ``:`` (``;`` on Windows). |Coq| will also honor ``$XDG_DATA_HOME`` and -``$XDG_DATA_DIRS`` (see Section :ref:`TODO-2.6.3`). +``$XDG_DATA_DIRS`` (see Section :ref:`libraries-and-filesystem`). Some |Coq| commands call other |Coq| commands. In this case, they look for the commands in directory specified by ``$COQBIN``. If this variable is @@ -84,6 +94,8 @@ list of assignments of the form ``name=``:n:``{*; attr}`` where ANSI escape code. The list of highlight tags can be retrieved with the ``-list-tags`` command-line option of ``coqtop``. +.. _command-line-options: + By command line options ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -91,25 +103,25 @@ The following command-line options are recognized by the commands ``coqc`` and ``coqtop``, unless stated otherwise: :-I *directory*, -include *directory*: Add physical path *directory* - to the OCaml loadpath. See also: :ref:`TODO-2.6.1` and the - command Declare ML Module Section :ref:`TODO-6.5`. + to the OCaml loadpath. See also: :ref:`names-of-libraries` and the + command Declare ML Module Section :ref:`compiled-files`. :-Q *directory* dirpath: Add physical path *directory* to the list of directories where |Coq| looks for a file and bind it to the the logical directory *dirpath*. The subdirectory structure of *directory* is recursively available from |Coq| using absolute names (extending the - dirpath prefix) (see Section :ref:`TODO-2.6.2`).Note that only those + dirpath prefix) (see Section :ref:`qualified-names`).Note that only those subdirectories and files which obey the lexical conventions of what is - an ident (see Section :ref:`TODO-1.1`) are taken into account. Conversely, the + an :n:`@ident` are taken into account. Conversely, the underlying file systems or operating systems may be more restrictive than |Coq|. While Linux’s ext4 file system supports any |Coq| recursive layout (within the limit of 255 bytes per file name), the default on NTFS (Windows) or HFS+ (MacOS X) file systems is on the contrary to disallow two files differing only in the case in the same directory. - See also: Section :ref:`TODO-2.6.1`. + See also: Section :ref:`names-of-libraries`. :-R *directory* dirpath: Do as -Q *directory* dirpath but make the subdirectory structure of *directory* recursively visible so that the recursive contents of physical *directory* is available from |Coq| using - short or partially qualified names. See also: Section :ref:`TODO-2.6.1`. + short or partially qualified names. See also: Section :ref:`names-of-libraries`. :-top dirpath: Set the toplevel module name to dirpath instead of Top. Not valid for `coqc` as the toplevel module name is inferred from the name of the output file. @@ -145,7 +157,7 @@ and ``coqtop``, unless stated otherwise: -compile-verbose. :-w (all|none|w₁,…,wₙ): Configure the display of warnings. This option expects all, none or a comma-separated list of warning names or - categories (see Section :ref:`TODO-6.9.3`). + categories (see Section :ref:`controlling-display`). :-color (on|off|auto): Enable or not the coloring of output of `coqtop`. Default is auto, meaning that `coqtop` dynamically decides, depending on whether the output channel supports ANSI escape sequences. @@ -164,13 +176,13 @@ and ``coqtop``, unless stated otherwise: Coq's auto-generated name scheme with names of the form *ident0*, *ident1*, etc. The command ``Set Mangle Names`` turns the behavior on in a document, and ``Set Mangle Names Prefix "ident"`` changes the used prefix. This feature - s intended to be used as a linter for developments that want to be robust to + is intended to be used as a linter for developments that want to be robust to changes in the auto-generated name scheme. The options are provided to facilitate tracking down problems. :-compat *version*: Attempt to maintain some backward-compatibility with a previous version. :-dump-glob *file*: Dump references for global names in file *file* - (to be used by coqdoc, see :ref:`TODO-15.4`). By default, if *file.v* is being + (to be used by coqdoc, see :ref:`coqdoc`). By default, if *file.v* is being compiled, *file.glob* is used. :-no-glob: Disable the dumping of references for global names. :-image *file*: Set the binary image to be used by `coqc` to be *file* diff --git a/doc/sphinx/practical-tools/coqide.rst b/doc/sphinx/practical-tools/coqide.rst index 1fcfc665b..f9903e610 100644 --- a/doc/sphinx/practical-tools/coqide.rst +++ b/doc/sphinx/practical-tools/coqide.rst @@ -10,7 +10,7 @@ used as a user-friendly replacement to `coqtop`. Its main purpose is to allow the user to navigate forward and backward into a Coq vernacular file, executing corresponding commands or undoing them respectively. -CoqIDE is run by typing the command `coqide` on the command line. +|CoqIDE| is run by typing the command `coqide` on the command line. Without argument, the main screen is displayed with an “unnamed buffer”, and with a file name as argument, another buffer displaying the contents of that file. Additionally, `coqide` accepts the same @@ -43,7 +43,7 @@ is the one where Coq commands are currently executed. Buffers may be edited as in any text editor, and classical basic editing commands (Copy/Paste, …) are available in the *Edit* menu. -CoqIDE offers only basic editing commands, so if you need more complex +|CoqIDE| offers only basic editing commands, so if you need more complex editing commands, you may launch your favorite text editor on the current buffer, using the *Edit/External Editor* menu. @@ -75,7 +75,7 @@ There are two additional buttons for navigation within the running buffer. The "down" button with a line goes directly to the end; the "up" button with a line goes back to the beginning. The handling of errors when using the go-to-the-end button depends on whether |Coq| is running in asynchronous mode or not (see -Chapter :ref:`Asyncprocessing`). If it is not running in that mode, execution +Chapter :ref:`asynchronousandparallelproofprocessing`). If it is not running in that mode, execution stops as soon as an error is found. Otherwise, execution continues, and the error is marked with an underline in the error foreground color, with a background in the error background color (pink by default). The same @@ -86,14 +86,14 @@ If you ever try to execute a command which happens to run during a long time, and would like to abort it before its termination, you may use the interrupt button (the white cross on a red circle). -There are other buttons on the CoqIDE toolbar: a button to save the running +There are other buttons on the |CoqIDE| toolbar: a button to save the running buffer; a button to close the current buffer (an "X"); buttons to switch among buffers (left and right arrows); an "information" button; and a "gears" button. -The "information" button is described in Section :ref:`sec:trytactics`. +The "information" button is described in Section :ref:`try-tactics-automatically`. The "gears" button submits proof terms to the |Coq| kernel for type-checking. -When |Coq| uses asynchronous processing (see Chapter :ref:`Asyncprocessing`), +When |Coq| uses asynchronous processing (see Chapter :ref:`asynchronousandparallelproofprocessing`), proofs may have been completed without kernel-checking of generated proof terms. The presence of unchecked proof terms is indicated by ``Qed`` statements that have a subdued *being-processed* color (light blue by default), rather than the @@ -150,18 +150,16 @@ arguments. Queries ------------ -.. _coqide_queryselected: - .. image:: ../_static/coqide-queries.png :alt: |CoqIDE| queries We call *query* any vernacular command that does not change the current state, such as ``Check``, ``Search``, etc. To run such commands interactively, without -writing them in scripts, CoqIDE offers a *query pane*. The query pane can be +writing them in scripts, |CoqIDE| offers a *query pane*. The query pane can be displayed on demand by using the ``View`` menu, or using the shortcut ``F1``. Queries can also be performed by selecting a particular phrase, then choosing an item from the ``Queries`` menu. The response then appears in the message window. -Figure :ref:`fig:queryselected` shows the result after selecting of the phrase +The image above shows the result after selecting of the phrase ``Nat.mul`` in the script window, and choosing ``Print`` from the ``Queries`` menu. @@ -221,7 +219,7 @@ still edit this configuration file by hand, but this is more involved. Using Unicode symbols -------------------------- -CoqIDE is based on GTK+ and inherits from it support for Unicode in +|CoqIDE| is based on GTK+ and inherits from it support for Unicode in its text windows. Consequently a large set of symbols is available for notations. diff --git a/doc/sphinx/practical-tools/utilities.rst b/doc/sphinx/practical-tools/utilities.rst new file mode 100644 index 000000000..5dba92429 --- /dev/null +++ b/doc/sphinx/practical-tools/utilities.rst @@ -0,0 +1,1020 @@ +.. include:: ../replaces.rst + +.. _utilities: + +--------------------- + Utilities +--------------------- + +The distribution provides utilities to simplify some tedious works +beside proof development, tactics writing or documentation. + + +Using Coq as a library +---------------------- + +In previous versions, ``coqmktop`` was used to build custom +toplevels - for example for better debugging or custom static +linking. Nowadays, the preferred method is to use ``ocamlfind``. + +The most basic custom toplevel is built using: + +:: + + % ocamlfind ocamlopt -thread -rectypes -linkall -linkpkg \ + -package coq.toplevel \ + toplevel/coqtop\_bin.ml -o my\_toplevel.native + + +For example, to statically link |L_tac|, you can just do: + +:: + + % ocamlfind ocamlopt -thread -rectypes -linkall -linkpkg \ + -package coq.toplevel -package coq.ltac \ + toplevel/coqtop\_bin.ml -o my\_toplevel.native + +and similarly for other plugins. + + +Building a |Coq| project with coq_makefile +------------------------------------------ + +The majority of |Coq| projects are very similar: a collection of ``.v`` +files and eventually some ``.ml`` ones (a |Coq| plugin). The main piece of +metadata needed in order to build the project are the command line +options to ``coqc`` (e.g. ``-R``, ``-I``, see also: Section +:ref:`command-line-options`). Collecting the list of files and options is the job +of the ``_CoqProject`` file. + +A simple example of a ``_CoqProject`` file follows: + +:: + + -R theories/ MyCode + theories/foo.v + theories/bar.v + -I src/ + src/baz.ml4 + src/bazaux.ml + src/qux_plugin.mlpack + + +Currently, both |CoqIDE| and Proof-General (version ≥ ``4.3pre``) +understand ``_CoqProject`` files and invoke |Coq| with the desired options. + +The ``coq_makefile`` utility can be used to set up a build infrastructure +for the |Coq| project based on makefiles. The recommended way of +invoking ``coq_makefile`` is the following one: + +:: + + coq_makefile -f _CoqProject -o CoqMakefile + + +Such command generates the following files: + +CoqMakefile + is a generic makefile for ``GNU Make`` that provides + targets to build the project (both ``.v`` and ``.ml*`` files), to install it + system-wide in the ``coq-contrib`` directory (i.e. where |Coq| is installed) + as well as to invoke coqdoc to generate HTML documentation. + +CoqMakefile.conf + contains make variables assignments that reflect + the contents of the ``_CoqProject`` file as well as the path relevant to + |Coq|. + + +An optional file ``CoqMakefile.local`` can be provided by the user in order to +extend ``CoqMakefile``. In particular one can declare custom actions to be +performed before or after the build process. Similarly one can customize the +install target or even provide new targets. Extension points are documented in +paragraph :ref:`coqmakefilelocal`. + +The extensions of the files listed in ``_CoqProject`` is used in order to +decide how to build them. In particular: + + ++ |Coq| files must use the ``.v`` extension ++ |OCaml| files must use the ``.ml`` or ``.mli`` extension ++ |OCaml| files that require pre processing for syntax + extensions (like ``VERNAC EXTEND``) must use the ``.ml4`` extension ++ In order to generate a plugin one has to list all |OCaml| + modules (i.e. ``Baz`` for ``baz.ml``) in a ``.mlpack`` file (or ``.mllib`` + file). + + +The use of ``.mlpack`` files has to be preferred over ``.mllib`` files, +since it results in a “packed” plugin: All auxiliary modules (as +``Baz`` and ``Bazaux``) are hidden inside the plugin’s “name space” +(``Qux_plugin``). This reduces the chances of begin unable to load two +distinct plugins because of a clash in their auxiliary module names. + +.. _coqmakefilelocal: + +CoqMakefile.local +~~~~~~~~~~~~~~~~~ + +The optional file ``CoqMakefile.local`` is included by the generated +file ``CoqMakefile``. It can contain two kinds of directives. + +**Variable assignment** + +The variable must belong to the variables listed in the ``Parameters`` +section of the generated makefile. +Here we describe only few of them. + +:CAMLPKGS: + can be used to specify third party findlib packages, and is + passed to the OCaml compiler on building or linking of modules. Eg: + ``-package yojson``. +:CAMLFLAGS: + can be used to specify additional flags to the |OCaml| + compiler, like ``-bin-annot`` or ``-w``.... +:COQC, COQDEP, COQDOC: + can be set in order to use alternative binaries + (e.g. wrappers) +:COQ_SRC_SUBDIRS: + can be extended by including other paths in which ``*.cm*`` files + are searched. For example ``COQ_SRC_SUBDIRS+=user-contrib/Unicoq`` + lets you build a plugin containing OCaml code that depends on the + OCaml code of ``Unicoq`` +:COQFLAGS: + override the flags passed to ``coqc``. By default ``-q``. +:COQEXTRAFLAGS: + extend the flags passed to ``coqc`` +:COQCHKFLAGS: + override the flags passed to ``coqchk``. By default ``-silent -o``. +:COQCHKEXTRAFLAGS: + extend the flags passed to ``coqchk`` +:COQDOCFLAGS: + override the flags passed to ``coqdoc``. By default ``-interpolate -utf8``. +:COQDOCEXTRAFLAGS: + extend the flags passed to ``coqdoc`` + +**Rule extension** + +The following makefile rules can be extended. + +.. example:: + + :: + + pre-all:: + echo "This line is print before making the all target" + install-extra:: + cp ThisExtraFile /there/it/goes + +``pre-all::`` + run before the ``all`` target. One can use this to configure + the project, or initialize sub modules or check dependencies are met. + +``post-all::`` + run after the ``all`` target. One can use this to run a test + suite, or compile extracted code. + +``install-extra::`` + run after ``install``. One can use this to install extra files. + +``install-doc::`` + One can use this to install extra doc. + +``uninstall::`` + \ + +``uninstall-doc::`` + \ + +``clean::`` + \ + +``cleanall::`` + \ + +``archclean::`` + \ + +``merlin-hook::`` + One can append lines to the generated ``.merlin`` file extending this + target. + +Timing targets and performance testing +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +The generated ``Makefile`` supports the generation of two kinds of timing +data: per-file build-times, and per-line times for an individual file. + +The following targets and Makefile variables allow collection of per- +file timing data: + + ++ ``TIMED=1`` + passing this variable will cause ``make`` to emit a line + describing the user-space build-time and peak memory usage for each + file built. + + .. note:: + On ``Mac OS``, this works best if you’ve installed ``gnu-time``. + + .. example:: + For example, the output of ``make TIMED=1`` may look like + this: + + :: + + COQDEP Fast.v + COQDEP Slow.v + COQC Slow.v + Slow (user: 0.34 mem: 395448 ko) + COQC Fast.v + Fast (user: 0.01 mem: 45184 ko) + ++ ``pretty-timed`` + this target stores the output of ``make TIMED=1`` into + ``time-of-build.log``, and displays a table of the times, sorted from + slowest to fastest, which is also stored in ``time-of-build-pretty.log``. + If you want to construct the ``log`` for targets other than the default + one, you can pass them via the variable ``TGTS``, e.g., ``make pretty-timed + TGTS="a.vo b.vo"``. + + .. :: + This target requires ``python`` to build the table. + + .. note:: + This target will *append* to the timing log; if you want a + fresh start, you must remove the ``filetime-of-build.log`` or + ``run make cleanall``. + + .. example:: + + For example, the output of ``make pretty-timed`` may look like this: + + :: + + COQDEP Fast.v + COQDEP Slow.v + COQC Slow.v + Slow (user: 0.36 mem: 393912 ko) + COQC Fast.v + Fast (user: 0.05 mem: 45992 ko) + Time | File Name + -------------------- + 0m00.41s | Total + -------------------- + 0m00.36s | Slow + 0m00.05s | Fast + + ++ ``print-pretty-timed-diff`` + this target builds a table of timing + changes between two compilations; run ``make make-pretty-timed-before`` to + build the log of the “before” times, and run ``make make-pretty-timed- + after`` to build the log of the “after” times. The table is printed on + the command line, and stored in ``time-of-build-both.log``. This target is + most useful for profiling the difference between two commits to a + repo. + + .. note:: + This target requires ``python`` to build the table. + + .. note:: + The ``make-pretty-timed-before`` and ``make-pretty-timed-after`` targets will + *append* to the timing log; if you want a fresh start, you must remove + the files ``time-of-build-before.log`` and ``time-of-build-after.log`` or run + ``make cleanall`` *before* building either the “before” or “after” + targets. + + .. note:: + The table will be sorted first by absolute time + differences rounded towards zero to a whole-number of seconds, then by + times in the “after” column, and finally lexicographically by file + name. This will put the biggest changes in either direction first, and + will prefer sorting by build-time over subsecond changes in build time + (which are frequently noise); lexicographic sorting forces an order on + files which take effectively no time to compile. + + .. example:: + For example, the output table from + ``make print-pretty-timed-diff`` may look like this: + + :: + + After | File Name | Before || Change | % Change + -------------------------------------------------------- + 0m00.39s | Total | 0m00.35s || +0m00.03s | +11.42% + -------------------------------------------------------- + 0m00.37s | Slow | 0m00.01s || +0m00.36s | +3600.00% + 0m00.02s | Fast | 0m00.34s || -0m00.32s | -94.11% + + +The following targets and ``Makefile`` variables allow collection of per- +line timing data: + + ++ ``TIMING=1`` + passing this variable will cause ``make`` to use ``coqc -time`` to + write to a ``.v.timing`` file for each ``.v`` file compiled, which contains + line-by-line timing information. + + .. example:: + For example, running ``make all TIMING=1`` may result in a file like this: + + :: + + Chars 0 - 26 [Require~Coq.ZArith.BinInt.] 0.157 secs (0.128u,0.028s) + Chars 27 - 68 [Declare~Reduction~comp~:=~vm_c...] 0. secs (0.u,0.s) + Chars 69 - 162 [Definition~foo0~:=~Eval~comp~i...] 0.153 secs (0.136u,0.019s) + Chars 163 - 208 [Definition~foo1~:=~Eval~comp~i...] 0.239 secs (0.236u,0.s) + ++ ``print-pretty-single-time-diff`` + :: + print-pretty-single-time-diff BEFORE=path/to/file.v.before-timing AFTER=path/to/file.v.after-timing + + this target will make a sorted table of the per-line timing differences + between the timing logs in the ``BEFORE`` and ``AFTER`` files, display it, and + save it to the file specified by the ``TIME_OF_PRETTY_BUILD_FILE`` variable, + which defaults to ``time-of-build-pretty.log``. + To generate the ``.v.before-timing`` or ``.v.after-timing`` files, you should + pass ``TIMING=before`` or ``TIMING=after`` rather than ``TIMING=1``. + + .. note:: + The sorting used here is the same as in the ``print-pretty-timed -diff`` target. + + .. note:: + This target requires python to build the table. + + .. example:: + For example, running ``print-pretty-single-time-diff`` might give a table like this: + + :: + + After | Code | Before || Change | % Change + --------------------------------------------------------------------------------------------------- + 0m00.50s | Total | 0m04.17s || -0m03.66s | -87.96% + --------------------------------------------------------------------------------------------------- + 0m00.145s | Chars 069 - 162 [Definition~foo0~:=~Eval~comp~i...] | 0m00.192s || -0m00.04s | -24.47% + 0m00.126s | Chars 000 - 026 [Require~Coq.ZArith.BinInt.] | 0m00.143s || -0m00.01s | -11.88% + N/A | Chars 027 - 068 [Declare~Reduction~comp~:=~nati...] | 0m00.s || +0m00.00s | N/A + 0m00.s | Chars 027 - 068 [Declare~Reduction~comp~:=~vm_c...] | N/A || +0m00.00s | N/A + 0m00.231s | Chars 163 - 208 [Definition~foo1~:=~Eval~comp~i...] | 0m03.836s || -0m03.60s | -93.97% + + ++ ``all.timing.diff``, ``path/to/file.v.timing.diff`` + The ``path/to/file.v.timing.diff`` target will make a ``.v.timing.diff`` file for + the corresponding ``.v`` file, with a table as would be generated by + the ``print-pretty-single-time-diff`` target; it depends on having already + made the corresponding ``.v.before-timing`` and ``.v.after-timing`` files, + which can be made by passing ``TIMING=before`` and ``TIMING=after``. + The ``all.timing.diff`` target will make such timing difference files for + all of the ``.v`` files that the ``Makefile`` knows about. It will fail if + some ``.v.before-timing`` or ``.v.after-timing`` files don’t exist. + + .. note:: + This target requires python to build the table. + + +Reusing/extending the generated Makefile +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +Including the generated makefile with an include directive is +discouraged. The contents of this file, including variable names and +status of rules shall change in the future. Users are advised to +include ``Makefile.conf`` or call a target of the generated Makefile as in +``make -f Makefile target`` from another Makefile. + +One way to get access to all targets of the generated ``CoqMakefile`` is to +have a generic target for invoking unknown targets. + +.. example:: + + :: + + # KNOWNTARGETS will not be passed along to CoqMakefile + KNOWNTARGETS := CoqMakefile extra-stuff extra-stuff2 + # KNOWNFILES will not get implicit targets from the final rule, and so + # depending on them won't invoke the submake + # Warning: These files get declared as PHONY, so any targets depending + # on them always get rebuilt + KNOWNFILES := Makefile _CoqProject + + .DEFAULT_GOAL := invoke-coqmakefile + + CoqMakefile: Makefile _CoqProject + $(COQBIN)coq_makefile -f _CoqProject -o CoqMakefile + + invoke-coqmakefile: CoqMakefile + $(MAKE) --no-print-directory -f CoqMakefile $(filter-out $(KNOWNTARGETS),$(MAKECMDGOALS)) + + .PHONY: invoke-coqmakefile $(KNOWNFILES) + + #################################################################### + ## Your targets here ## + #################################################################### + + # This should be the last rule, to handle any targets not declared above + %: invoke-coqmakefile + @true + + + +Building a subset of the targets with ``-j`` +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +To build, say, two targets foo.vo and bar.vo in parallel one can use +``make only TGTS="foo.vo bar.vo" -j``. + +.. note:: + + ``make foo.vo bar.vo -j`` has a different meaning for the make + utility, in particular it may build a shared prerequisite twice. + + +.. note:: + + For users of coq_makefile with version < 8.7 + + + Support for “sub-directory” is deprecated. To perform actions before + or after the build (like invoking ``make`` on a subdirectory) one can hook + in pre-all and post-all extension points. + + ``-extra-phony`` and ``-extra`` are deprecated. To provide additional target + (``.PHONY`` or not) please use ``CoqMakefile.local``. + + + +Modules dependencies +-------------------- + +In order to compute modules dependencies (so to use ``make``), |Coq| comes +with an appropriate tool, ``coqdep``. + +``coqdep`` computes inter-module dependencies for |Coq| and |OCaml| +programs, and prints the dependencies on the standard output in a +format readable by make. When a directory is given as argument, it is +recursively looked at. + +Dependencies of |Coq| modules are computed by looking at ``Require`` +commands (``Require``, ``Require Export``, ``Require Import``), but also at the +command ``Declare ML Module``. + +Dependencies of |OCaml| modules are computed by looking at +`open` commands and the dot notation *module.value*. However, this is +done approximately and you are advised to use ``ocamldep`` instead for the +|OCaml| modules dependencies. + +See the man page of ``coqdep`` for more details and options. + +The build infrastructure generated by ``coq_makefile`` uses ``coqdep`` to +automatically compute the dependencies among the files part of the +project. + + +.. _coqdoc: + +Documenting |Coq| files with coqdoc +----------------------------------- + +coqdoc is a documentation tool for the proof assistant |Coq|, similar to +``javadoc`` or ``ocamldoc``. The task of coqdoc is + + +#. to produce a nice |Latex| and/or HTML document from the |Coq| + sources, readable for a human and not only for the proof assistant; +#. to help the user navigating in his own (or third-party) sources. + + + +Principles +~~~~~~~~~~ + +Documentation is inserted into |Coq| files as *special comments*. Thus +your files will compile as usual, whether you use coqdoc or not. coqdoc +presupposes that the given |Coq| files are well-formed (at least +lexically). Documentation starts with ``(**``, followed by a space, and +ends with the pending ``*)``. The documentation format is inspired by Todd +A. Coram’s *Almost Free Text (AFT)* tool: it is mainly ``ASCII`` text with +some syntax-light controls, described below. coqdoc is robust: it +shouldn’t fail, whatever the input is. But remember: “garbage in, +garbage out”. + + +|Coq| material inside documentation. +++++++++++++++++++++++++++++++++++++ + +|Coq| material is quoted between the delimiters ``[`` and ``]``. Square brackets +may be nested, the inner ones being understood as being part of the +quoted code (thus you can quote a term like ``fun x => u`` by writing ``[fun +x => u]``). Inside quotations, the code is pretty-printed in the same +way as it is in code parts. + +Pre-formatted vernacular is enclosed by ``[[`` and ``]]``. The former must be +followed by a newline and the latter must follow a newline. + + +Pretty-printing. +++++++++++++++++ + +coqdoc uses different faces for identifiers and keywords. The pretty- +printing of |Coq| tokens (identifiers or symbols) can be controlled +using one of the following commands: + +:: + + + (** printing *token* %...LATEX...% #...html...# *) + + +or + +:: + + + (** printing *token* $...LATEX math...$ #...html...# *) + + +It gives the |Latex| and HTML texts to be produced for the given |Coq| +token. One of the |Latex| or HTML text may be omitted, causing the +default pretty-printing to be used for this token. + +The printing for one token can be removed with + +:: + + + (** remove printing *token* *) + + +Initially, the pretty-printing table contains the following mapping: + +==== === ==== ===== === ==== ==== === +`->` → `<-` ← `*` × +`<=` ≤ `>=` ≥ `=>` ⇒ +`<>` ≠ `<->` ↔ `|-` ⊢ +`\/` ∨ `/\\` ∧ `~` ¬ +==== === ==== ===== === ==== ==== === + +Any of these can be overwritten or suppressed using the printing +commands. + +.. note:: + + The recognition of tokens is done by a (``ocaml``) lex + automaton and thus applies the longest-match rule. For instance, `->~` + is recognized as a single token, where |Coq| sees two tokens. It is the + responsibility of the user to insert space between tokens *or* to give + pretty-printing rules for the possible combinations, e.g. + + :: + + (** printing ->~ %\ensuremath{\rightarrow\lnot}% *) + + + +Sections +++++++++ + +Sections are introduced by 1 to 4 leading stars (i.e. at the beginning +of the line) followed by a space. One star is a section, two stars a +sub-section, etc. The section title is given on the remaining of the +line. + +.. example:: + + :: + + (** * Well-founded relations + + In this section, we introduce... *) + + +Lists. +++++++ + +List items are introduced by a leading dash. coqdoc uses whitespace to +determine the depth of a new list item and which text belongs in which +list items. A list ends when a line of text starts at or before the +level of indenting of the list’s dash. A list item’s dash must always +be the first non-space character on its line (so, in particular, a +list can not begin on the first line of a comment - start it on the +second line instead). + +.. example:: + + :: + + We go by induction on [n]: + - If [n] is 0... + - If [n] is [S n'] we require... + + two paragraphs of reasoning, and two subcases: + + - In the first case... + - In the second case... + + So the theorem holds. + + + +Rules. +++++++ + +More than 4 leading dashes produce a horizontal rule. + + +Emphasis. ++++++++++ + +Text can be italicized by placing it in underscores. A non-identifier +character must precede the leading underscore and follow the trailing +underscore, so that uses of underscores in names aren’t mistaken for +emphasis. Usually, these are spaces or punctuation. + +:: + + This sentence contains some _emphasized text_. + + + +Escaping to |Latex| and HTML. ++++++++++++++++++++++++++++++++ + +Pure |Latex| or HTML material can be inserted using the following +escape sequences: + + ++ ``$...LATEX stuff...$`` inserts some |Latex| material in math mode. + Simply discarded in HTML output. ++ ``%...LATEX stuff...%`` inserts some |Latex| material. Simply + discarded in HTML output. ++ ``#...HTML stuff...#`` inserts some HTML material. Simply discarded in + |Latex| output. + +.. note:: + to simply output the characters ``$``, ``%`` and ``#`` and escaping + their escaping role, these characters must be doubled. + + +Verbatim +++++++++ + +Verbatim material is introduced by a leading ``<<`` and closed by ``>>`` +at the beginning of a line. + +.. example:: + + :: + + Here is the corresponding caml code: + << + let rec fact n = + if n <= 1 then 1 else n * fact (n-1) + >> + + + +Hyperlinks +++++++++++ + +Hyperlinks can be inserted into the HTML output, so that any +identifier is linked to the place of its definition. + +``coqc file.v`` automatically dumps localization information in +``file.glob`` or appends it to a file specified using option ``--dump-glob +file``. Take care of erasing this global file, if any, when starting +the whole compilation process. + +Then invoke coqdoc or ``coqdoc --glob-from file`` to tell coqdoc to look +for name resolutions into the file ``file`` (it will look in ``file.glob`` +by default). + +Identifiers from the |Coq| standard library are linked to the Coq web +site at `<http://coq.inria.fr/library/>`_. This behavior can be changed +using command line options ``--no-externals`` and ``--coqlib``; see below. + + +Hiding / Showing parts of the source. ++++++++++++++++++++++++++++++++++++++ + +Some parts of the source can be hidden using command line options ``-g`` +and ``-l`` (see below), or using such comments: + +:: + + + (* begin hide *) + *some Coq material* + (* end hide *) + + +Conversely, some parts of the source which would be hidden can be +shown using such comments: + +:: + + + (* begin show *) + *some Coq material* + (* end show *) + + +The latter cannot be used around some inner parts of a proof, but can +be used around a whole proof. + + +Usage +~~~~~ + +coqdoc is invoked on a shell command line as follows: +``coqdoc <options and files>``. +Any command line argument which is not an option is considered to be a +file (even if it starts with a ``-``). |Coq| files are identified by the +suffixes ``.v`` and ``.g`` and |Latex| files by the suffix ``.tex``. + + +:HTML output: This is the default output. One HTML file is created for + each |Coq| file given on the command line, together with a file + ``index.html`` (unless ``option-no-index is passed``). The HTML pages use a + style sheet named ``style.css``. Such a file is distributed with coqdoc. +:|Latex| output: A single |Latex| file is created, on standard + output. It can be redirected to a file with option ``-o``. The order of + files on the command line is kept in the final document. |Latex| + files given on the command line are copied ‘as is’ in the final + document . DVI and PostScript can be produced directly with the + options ``-dvi`` and ``-ps`` respectively. +:TEXmacs output: To translate the input files to TEXmacs format, + to be used by the TEXmacs |Coq| interface. + + + +Command line options +++++++++++++++++++++ + + +**Overall options** + + + :--HTML: Select a HTML output. + :--|Latex|: Select a |Latex| output. + :--dvi: Select a DVI output. + :--ps: Select a PostScript output. + :--texmacs: Select a TEXmacs output. + :--stdout: Write output to stdout. + :-o file, --output file: Redirect the output into the file ‘file’ + (meaningless with ``-html``). + :-d dir, --directory dir: Output files into directory ‘dir’ instead of + current directory (option ``-d`` does not change the filename specified + with option ``-o``, if any). + :--body-only: Suppress the header and trailer of the final document. + Thus, you can insert the resulting document into a larger one. + :-p string, --preamble string: Insert some material in the |Latex| + preamble, right before ``\begin{document}`` (meaningless with ``-html``). + :--vernac-file file,--tex-file file: Considers the file ‘file’ + respectively as a ``.v`` (or ``.g``) file or a ``.tex`` file. + :--files-from file: Read file names to process in file ‘file’ as if + they were given on the command line. Useful for program sources split + up into several directories. + :-q, --quiet: Be quiet. Do not print anything except errors. + :-h, --help: Give a short summary of the options and exit. + :-v, --version: Print the version and exit. + + + +**Index options** + + Default behavior is to build an index, for the HTML output only, + into ``index.html``. + + :--no-index: Do not output the index. + :--multi-index: Generate one page for each category and each letter in + the index, together with a top page ``index.html``. + :--index string: Make the filename of the index string instead of + “index”. Useful since “index.html” is special. + + + +**Table of contents option** + + :-toc, --table-of-contents: Insert a table of contents. For a |Latex| + output, it inserts a ``\tableofcontents`` at the beginning of the + document. For a HTML output, it builds a table of contents into + ``toc.html``. + :--toc-depth int: Only include headers up to depth ``int`` in the table of + contents. + + +**Hyperlinks options** + + :--glob-from file: Make references using |Coq| globalizations from file + file. (Such globalizations are obtained with Coq option ``-dump-glob``). + :--no-externals: Do not insert links to the |Coq| standard library. + :--external url coqdir: Use given URL for linking references whose + name starts with prefix ``coqdir``. + :--coqlib url: Set base URL for the Coq standard library (default is + `<http://coq.inria.fr/library/>`_). This is equivalent to ``--external url + Coq``. + :-R dir coqdir: Map physical directory dir to |Coq| logical + directory ``coqdir`` (similarly to |Coq| option ``-R``). + + .. note:: + + option ``-R`` only has + effect on the files *following* it on the command line, so you will + probably need to put this option first. + + +**Title options** + + :-s , --short: Do not insert titles for the files. The default + behavior is to insert a title like “Library Foo” for each file. + :--lib-name string: Print “string Foo” instead of “Library Foo” in + titles. For example “Chapter” and “Module” are reasonable choices. + :--no-lib-name: Print just “Foo” instead of “Library Foo” in titles. + :--lib-subtitles: Look for library subtitles. When enabled, the + beginning of each file is checked for a comment of the form: + + :: + + (** * ModuleName : text *) + + where ``ModuleName`` must be the name of the file. If it is present, the + text is used as a subtitle for the module in appropriate places. + :-t string, --title string: Set the document title. + + +**Contents options** + + :-g, --gallina: Do not print proofs. + :-l, --light: Light mode. Suppress proofs (as with ``-g``) and the following commands: + + + [Recursive] Tactic Definition + + Hint / Hints + + Require + + Transparent / Opaque + + Implicit Argument / Implicits + + Section / Variable / Hypothesis / End + + + + The behavior of options ``-g`` and ``-l`` can be locally overridden using the + ``(* begin show *) … (* end show *)`` environment (see above). + + There are a few options to drive the parsing of comments: + + :--parse-comments: Parses regular comments delimited by ``(*`` and ``*)`` as + well. They are typeset inline. + :--plain-comments: Do not interpret comments, simply copy them as + plain-text. + :--interpolate: Use the globalization information to typeset + identifiers appearing in |Coq| escapings inside comments. + +**Language options** + + + Default behavior is to assume ASCII 7 bits input files. + + :-latin1, --latin1: Select ISO-8859-1 input files. It is equivalent to + --inputenc latin1 --charset iso-8859-1. + :-utf8, --utf8: Set --inputenc utf8x for |Latex| output and--charset + utf-8 for HTML output. Also use Unicode replacements for a couple of + standard plain ASCII notations such as → for ``->`` and ∀ for ``forall``. |Latex| + UTF-8 support can be found + at `<http://www.ctan.org/pkg/unicode>`_. For the interpretation of Unicode + characters by |Latex|, extra packages which coqdoc does not provide + by default might be required, such as textgreek for some Greek letters + or ``stmaryrd`` for some mathematical symbols. If a Unicode character is + missing an interpretation in the utf8x input encoding, add + ``\DeclareUnicodeCharacter{code}{LATEX-interpretation}``. Packages + and declarations can be added with option ``-p``. + :--inputenc string: Give a |Latex| input encoding, as an option to |Latex| + package ``inputenc``. + :--charset string: Specify the HTML character set, to be inserted in + the HTML header. + + + +The coqdoc |Latex| style file +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +In case you choose to produce a document without the default |Latex| +preamble (by using option ``--no-preamble``), then you must insert into +your own preamble the command + +:: + + \usepackage{coqdoc} + +The package optionally takes the argument ``[color]`` to typeset +identifiers with colors (this requires the ``xcolor`` package). + +Then you may alter the rendering of the document by redefining some +macros: + +:coqdockw, coqdocid, …: The one-argument macros for typesetting + keywords and identifiers. Defaults are sans-serif for keywords and + italic for identifiers.For example, if you would like a slanted font + for keywords, you may insert + + :: + + \renewcommand{\coqdockw}[1]{\textsl{#1}} + + + anywhere between ``\usepackage{coqdoc}`` and ``\begin{document}``. + + +:coqdocmodule: + One-argument macro for typesetting the title of a ``.v`` + file. Default is + + :: + + \newcommand{\coqdocmodule}[1]{\section*{Module #1}} + + and you may redefine it using ``\renewcommand``. + +Embedded Coq phrases inside |Latex| documents +--------------------------------------------- + +When writing a documentation about a proof development, one may want +to insert |Coq| phrases inside a |Latex| document, possibly together +with the corresponding answers of the system. We provide a mechanical +way to process such |Coq| phrases embedded in |Latex| files: the ``coq-tex`` +filter. This filter extracts |Coq| phrases embedded in |Latex| files, +evaluates them, and insert the outcome of the evaluation after each +phrase. + +Starting with a file ``file.tex`` containing |Coq| phrases, the ``coq-tex`` +filter produces a file named ``file.v.tex`` with the Coq outcome. + +There are options to produce the |Coq| parts in smaller font, italic, +between horizontal rules, etc. See the man page of ``coq-tex`` for more +details. + +|Coq| and GNU Emacs +----------------------- + + +The |Coq| Emacs mode +~~~~~~~~~~~~~~~~~~~~~~~~~ + +|Coq| comes with a Major mode for GNU Emacs, ``gallina.el``. This mode +provides syntax highlighting and also a rudimentary indentation +facility in the style of the ``Caml`` GNU Emacs mode. + +Add the following lines to your ``.emacs`` file: + +:: + + (setq auto-mode-alist (cons '("\\.v$" . coq-mode) auto-mode-alist)) + (autoload 'coq-mode "gallina" "Major mode for editing Coq vernacular." t) + + +The |Coq| major mode is triggered by visiting a file with extension ``.v``, +or manually with the command ``M-x coq-mode``. It gives you the correct +syntax table for the |Coq| language, and also a rudimentary indentation +facility: + + ++ pressing ``Tab`` at the beginning of a line indents the line like the + line above; ++ extra tabulations increase the indentation level (by 2 spaces by default); ++ ``M-Tab`` decreases the indentation level. + + +An inferior mode to run |Coq| under Emacs, by Marco Maggesi, is also +included in the distribution, in file ``inferior-coq.el``. Instructions to +use it are contained in this file. + + +Proof-General +~~~~~~~~~~~~~ + +Proof-General is a generic interface for proof assistants based on +Emacs. The main idea is that the |Coq| commands you are editing are sent +to a |Coq| toplevel running behind Emacs and the answers of the system +automatically inserted into other Emacs buffers. Thus you don’t need +to copy-paste the |Coq| material from your files to the |Coq| toplevel or +conversely from the |Coq| toplevel to some files. + +Proof-General is developed and distributed independently of the system +|Coq|. It is freely available at `<https://proofgeneral.github.io/>`_. + + +Module specification +-------------------- + +Given a |Coq| vernacular file, the gallina filter extracts its +specification (inductive types declarations, definitions, type of +lemmas and theorems), removing the proofs parts of the file. The |Coq| +file ``file.v`` gives birth to the specification file ``file.g`` (where +the suffix ``.g`` stands for |Gallina|). + +See the man page of ``gallina`` for more details and options. + + +Man pages +--------- + +There are man pages for the commands ``coqdep``, ``gallina`` and ``coq-tex``. Man +pages are installed at installation time (see installation +instructions in file ``INSTALL``, step 6). diff --git a/doc/sphinx/proof-engine/detailed-tactic-examples.rst b/doc/sphinx/proof-engine/detailed-tactic-examples.rst index 932f96788..84810ddba 100644 --- a/doc/sphinx/proof-engine/detailed-tactic-examples.rst +++ b/doc/sphinx/proof-engine/detailed-tactic-examples.rst @@ -6,6 +6,8 @@ Detailed examples of tactics This chapter presents detailed examples of certain tactics, to illustrate their behavior. +.. _dependent-induction: + dependent induction ------------------- @@ -316,7 +318,7 @@ explicit proof terms: This concludes our example. -See also: The ``induction`` :ref:`TODO-9-induction`, ``case`` :ref:`TODO-9-induction` and ``inversion`` :ref:`TODO-8.14-inversion` tactics. +See also: The :tacn:`induction`, :tacn:`case`, and :tacn:`inversion` tactics. autorewrite @@ -403,6 +405,8 @@ Example 2: Mac Carthy function autorewrite with base1 using reflexivity || simpl. +.. _quote: + quote ----- @@ -544,8 +548,7 @@ Combining variables and constants ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ One can have both variables and constants in abstracts terms; for -example, this is the case for the ``ring`` tactic -:ref:`TODO-25-ringandfieldtacticfamilies`. Then one must provide to +example, this is the case for the :tacn:`ring` tactic. Then one must provide to ``quote`` a list of *constructors of constants*. For example, if the list is ``[O S]`` then closed natural numbers will be considered as constants and other terms as variables. @@ -606,7 +609,7 @@ don’t expect miracles from it! See also: comments of source file ``plugins/quote/quote.ml`` -See also: the ``ring`` tactic :ref:`TODO-25-ringandfieldtacticfamilies` +See also: the :tacn:`ring` tactic. Using the tactical language @@ -733,7 +736,7 @@ and this length is decremented for each rotation down to, but not including, 1 because for a list of length ``n``, we can make exactly ``n−1`` rotations to generate at most ``n`` distinct lists. Here, it must be noticed that we use the natural numbers of Coq for the -rotation counter. On Figure :ref:`TODO-9.1-tactic-language`, we can +rotation counter. In :ref:`ltac-syntax`, we can see that it is possible to use usual natural numbers but they are only used as arguments for primitive tactics and they cannot be handled, in particular, we cannot make computations with them. So, a natural @@ -830,7 +833,7 @@ The pattern matching on goals allows a complete and so a powerful backtracking when returning tactic values. An interesting application is the problem of deciding intuitionistic propositional logic. Considering the contraction-free sequent calculi LJT* of Roy Dyckhoff -:ref:`TODO-56-biblio`, it is quite natural to code such a tactic +:cite:`Dyc92`, it is quite natural to code such a tactic using the tactic language as shown on figures: :ref:`Deciding intuitionistic propositions (1) <decidingintuitionistic1>` and :ref:`Deciding intuitionistic propositions (2) @@ -868,7 +871,7 @@ Deciding type isomorphisms A more tricky problem is to decide equalities between types and modulo isomorphisms. Here, we choose to use the isomorphisms of the simply typed λ-calculus with Cartesian product and unit type (see, for -example, [:ref:`TODO-45`]). The axioms of this λ-calculus are given below. +example, :cite:`RC95`). The axioms of this λ-calculus are given below. .. coqtop:: in reset diff --git a/doc/sphinx/proof-engine/ltac.rst b/doc/sphinx/proof-engine/ltac.rst new file mode 100644 index 000000000..88c1e225f --- /dev/null +++ b/doc/sphinx/proof-engine/ltac.rst @@ -0,0 +1,1310 @@ +.. include:: ../preamble.rst +.. include:: ../replaces.rst + +.. _ltac: + +The tactic language +=================== + +This chapter gives a compact documentation of |Ltac|, the tactic language +available in |Coq|. We start by giving the syntax, and next, we present the +informal semantics. If you want to know more regarding this language and +especially about its foundations, you can refer to :cite:`Del00`. Chapter +:ref:`detailedexamplesoftactics` is devoted to giving examples of use of this +language on small but also with non-trivial problems. + +.. _ltac-syntax: + +Syntax +------ + +The syntax of the tactic language is given below. See Chapter +:ref:`gallinaspecificationlanguage` for a description of the BNF metasyntax used +in these grammar rules. Various already defined entries will be used in this +chapter: entries :token:`natural`, :token:`integer`, :token:`ident`, +:token:`qualid`, :token:`term`, :token:`cpattern` and :token:`atomic_tactic` +represent respectively the natural and integer numbers, the authorized +identificators and qualified names, Coq terms and patterns and all the atomic +tactics described in Chapter :ref:`tactics`. The syntax of :token:`cpattern` is +the same as that of terms, but it is extended with pattern matching +metavariables. In :token:`cpattern`, a pattern-matching metavariable is +represented with the syntax :g:`?id` where :g:`id` is an :token:`ident`. The +notation :g:`_` can also be used to denote metavariable whose instance is +irrelevant. In the notation :g:`?id`, the identifier allows us to keep +instantiations and to make constraints whereas :g:`_` shows that we are not +interested in what will be matched. On the right hand side of pattern-matching +clauses, the named metavariable are used without the question mark prefix. There +is also a special notation for second-order pattern-matching problems: in an +applicative pattern of the form :g:`@?id id1 … idn`, the variable id matches any +complex expression with (possible) dependencies in the variables :g:`id1 … idn` +and returns a functional term of the form :g:`fun id1 … idn => term`. + +The main entry of the grammar is :n:`@expr`. This language is used in proof +mode but it can also be used in toplevel definitions as shown below. + +.. note:: + + - The infix tacticals “… \|\| …”, “… + …”, and “… ; …” are associative. + + - In :token:`tacarg`, there is an overlap between qualid as a direct tactic + argument and :token:`qualid` as a particular case of term. The resolution is + done by first looking for a reference of the tactic language and if + it fails, for a reference to a term. To force the resolution as a + reference of the tactic language, use the form :g:`ltac:(@qualid)`. To + force the resolution as a reference to a term, use the syntax + :g:`(@qualid)`. + + - As shown by the figure, tactical ``\|\|`` binds more than the prefix + tacticals try, repeat, do and abstract which themselves bind more + than the postfix tactical “… ;[ … ]” which binds more than “… ; …”. + + For instance + + .. coqtop:: in + + try repeat tac1 || tac2; tac3; [tac31 | ... | tac3n]; tac4. + + is understood as + + .. coqtop:: in + + try (repeat (tac1 || tac2)); + ((tac3; [tac31 | ... | tac3n]); tac4). + +.. productionlist:: coq + expr : `expr` ; `expr` + : | [> `expr` | ... | `expr` ] + : | `expr` ; [ `expr` | ... | `expr` ] + : | `tacexpr3` + tacexpr3 : do (`natural` | `ident`) tacexpr3 + : | progress `tacexpr3` + : | repeat `tacexpr3` + : | try `tacexpr3` + : | once `tacexpr3` + : | exactly_once `tacexpr3` + : | timeout (`natural` | `ident`) `tacexpr3` + : | time [`string`] `tacexpr3` + : | only `selector`: `tacexpr3` + : | `tacexpr2` + tacexpr2 : `tacexpr1` || `tacexpr3` + : | `tacexpr1` + `tacexpr3` + : | tryif `tacexpr1` then `tacexpr1` else `tacexpr1` + : | `tacexpr1` + tacexpr1 : fun `name` ... `name` => `atom` + : | let [rec] `let_clause` with ... with `let_clause` in `atom` + : | match goal with `context_rule` | ... | `context_rule` end + : | match reverse goal with `context_rule` | ... | `context_rule` end + : | match `expr` with `match_rule` | ... | `match_rule` end + : | lazymatch goal with `context_rule` | ... | `context_rule` end + : | lazymatch reverse goal with `context_rule` | ... | `context_rule` end + : | lazymatch `expr` with `match_rule` | ... | `match_rule` end + : | multimatch goal with `context_rule` | ... | `context_rule` end + : | multimatch reverse goal with `context_rule` | ... | `context_rule` end + : | multimatch `expr` with `match_rule` | ... | `match_rule` end + : | abstract `atom` + : | abstract `atom` using `ident` + : | first [ `expr` | ... | `expr` ] + : | solve [ `expr` | ... | `expr` ] + : | idtac [ `message_token` ... `message_token`] + : | fail [`natural`] [`message_token` ... `message_token`] + : | fresh | fresh `string` | fresh `qualid` + : | context `ident` [`term`] + : | eval `redexpr` in `term` + : | type of `term` + : | constr : `term` + : | uconstr : `term` + : | type_term `term` + : | numgoals + : | guard `test` + : | assert_fails `tacexpr3` + : | assert_suceeds `tacexpr3` + : | `atomic_tactic` + : | `qualid` `tacarg` ... `tacarg` + : | `atom` + atom : `qualid` + : | () + : | `integer` + : | ( `expr` ) + message_token : `string` | `ident` | `integer` + tacarg : `qualid` + : | () + : | ltac : `atom` + : | `term` + let_clause : `ident` [`name` ... `name`] := `expr` + context_rule : `context_hyp`, ..., `context_hyp` |- `cpattern` => `expr` + : | `cpattern` => `expr` + : | |- `cpattern` => `expr` + : | _ => `expr` + context_hyp : `name` : `cpattern` + : | `name` := `cpattern` [: `cpattern`] + match_rule : `cpattern` => `expr` + : | context [ident] [ `cpattern` ] => `expr` + : | _ => `expr` + test : `integer` = `integer` + : | `integer` (< | <= | > | >=) `integer` + selector : [`ident`] + : | `integer` + : (`integer` | `integer` - `integer`), ..., (`integer` | `integer` - `integer`) + toplevel_selector : `selector` + : | `all` + : | `par` + +.. productionlist:: coq + top : [Local] Ltac `ltac_def` with ... with `ltac_def` + ltac_def : `ident` [`ident` ... `ident`] := `expr` + : | `qualid` [`ident` ... `ident`] ::= `expr` + +.. _ltac-semantics: + +Semantics +--------- + +Tactic expressions can only be applied in the context of a proof. The +evaluation yields either a term, an integer or a tactic. Intermediary +results can be terms or integers but the final result must be a tactic +which is then applied to the focused goals. + +There is a special case for ``match goal`` expressions of which the clauses +evaluate to tactics. Such expressions can only be used as end result of +a tactic expression (never as argument of a non recursive local +definition or of an application). + +The rest of this section explains the semantics of every construction of +|Ltac|. + +Sequence +~~~~~~~~ + +A sequence is an expression of the following form: + +.. tacn:: @expr ; @expr + :name: ltac-seq + + The expression :n:`@expr__1` is evaluated to :n:`v__1`, which must be + a tactic value. The tactic :n:`v__1` is applied to the current goal, + possibly producing more goals. Then :n:`@expr__2` is evaluated to + produce :n:`v__2`, which must be a tactic value. The tactic + :n:`v__2` is applied to all the goals produced by the prior + application. Sequence is associative. + +Local application of tactics +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +Different tactics can be applied to the different goals using the +following form: + +.. tacn:: [> {*| @expr }] + :name: [> ... | ... | ... ] (dispatch) + + The expressions :n:`@expr__i` are evaluated to :n:`v__i`, for + i=0,...,n and all have to be tactics. The :n:`v__i` is applied to the + i-th goal, for =1,...,n. It fails if the number of focused goals is not + exactly n. + + .. note:: + + If no tactic is given for the i-th goal, it behaves as if the tactic idtac + were given. For instance, ``[> | auto]`` is a shortcut for ``[> idtac | auto + ]``. + + .. tacv:: [> {*| @expr} | @expr .. | {*| @expr}] + + In this variant, token:`expr` is used for each goal coming after those + covered by the first list of :n:`@expr` but before those coevered by the + last list of :n:`@expr`. + + .. tacv:: [> {*| @expr} | .. | {*| @expr}] + + In this variant, idtac is used for the goals not covered by the two lists of + :n:`@expr`. + + .. tacv:: [> @expr .. ] + + In this variant, the tactic :n:`@expr` is applied independently to each of + the goals, rather than globally. In particular, if there are no goal, the + tactic is not run at all. A tactic which expects multiple goals, such as + ``swap``, would act as if a single goal is focused. + + .. tacv:: expr ; [{*| @expr}] + + This variant of local tactic application is paired with a sequence. In this + variant, there must be as many :n:`@expr` in the list as goals generated + by the application of the first :n:`@expr` to each of the individual goals + independently. All the above variants work in this form too. + Formally, :n:`@expr ; [ ... ]` is equivalent to :n:`[> @expr ; [> ... ] .. ]`. + +.. _goal-selectors: + +Goal selectors +~~~~~~~~~~~~~~ + +We can restrict the application of a tactic to a subset of the currently +focused goals with: + +.. tacn:: @toplevel_selector : @expr + :name: ... : ... (goal selector) + + We can also use selectors as a tactical, which allows to use them nested + in a tactic expression, by using the keyword ``only``: + + .. tacv:: only selector : expr + :name: only ... : ... + + When selecting several goals, the tactic expr is applied globally to all + selected goals. + + .. tacv:: [@ident] : @expr + + In this variant, :n:`@expr` is applied locally to a goal previously named + by the user (see :ref:`existential-variables`). + + .. tacv:: @num : @expr + + In this variant, :n:`@expr` is applied locally to the :token:`num`-th goal. + + .. tacv:: {+, @num-@num} : @expr + + In this variant, :n:`@expr` is applied globally to the subset of goals + described by the given ranges. You can write a single ``n`` as a shortcut + for ``n-n`` when specifying multiple ranges. + + .. tacv:: all: @expr + :name: all: ... + + In this variant, :n:`@expr` is applied to all focused goals. ``all:`` can only + be used at the toplevel of a tactic expression. + + .. tacv:: !: @expr + + In this variant, if exactly one goal is focused :n:`expr` is + applied to it. Otherwise the tactical fails. ``!:`` can only be + used at the toplevel of a tactic expression. + + .. tacv:: par: @expr + :name: par: ... + + In this variant, :n:`@expr` is applied to all focused goals in parallel. + The number of workers can be controlled via the command line option + ``-async-proofs-tac-j`` taking as argument the desired number of workers. + Limitations: ``par:`` only works on goals containing no existential + variables and :n:`@expr` must either solve the goal completely or do + nothing (i.e. it cannot make some progress). ``par:`` can only be used at + the toplevel of a tactic expression. + + .. exn:: No such goal. + :name: No such goal. (Goal selector) + + .. TODO change error message index entry + +For loop +~~~~~~~~ + +There is a for loop that repeats a tactic :token:`num` times: + +.. tacn:: do @num @expr + :name: do + + :n:`@expr` is evaluated to ``v`` which must be a tactic value. This tactic + value ``v`` is applied :token:`num` times. Supposing :token:`num` > 1, after the + first application of ``v``, ``v`` is applied, at least once, to the generated + subgoals and so on. It fails if the application of ``v`` fails before the num + applications have been completed. + +Repeat loop +~~~~~~~~~~~ + +We have a repeat loop with: + +.. tacn:: repeat @expr + :name: repeat + + :n:`@expr` is evaluated to ``v``. If ``v`` denotes a tactic, this tactic is + applied to each focused goal independently. If the application succeeds, the + tactic is applied recursively to all the generated subgoals until it eventually + fails. The recursion stops in a subgoal when the tactic has failed *to make + progress*. The tactic :n:`repeat @expr` itself never fails. + +Error catching +~~~~~~~~~~~~~~ + +We can catch the tactic errors with: + +.. tacn:: try @expr + :name: try + + :n:`@expr` is evaluated to ``v`` which must be a tactic value. The tactic + value ``v`` is applied to each focused goal independently. If the application of + ``v`` fails in a goal, it catches the error and leaves the goal unchanged. If the + level of the exception is positive, then the exception is re-raised with its + level decremented. + +Detecting progress +~~~~~~~~~~~~~~~~~~ + +We can check if a tactic made progress with: + +.. tacn:: progress expr + :name: progress + + :n:`@expr` is evaluated to v which must be a tactic value. The tactic value ``v`` + is applied to each focued subgoal independently. If the application of ``v`` + to one of the focused subgoal produced subgoals equal to the initial + goals (up to syntactical equality), then an error of level 0 is raised. + + .. exn:: Failed to progress. + +Backtracking branching +~~~~~~~~~~~~~~~~~~~~~~ + +We can branch with the following structure: + +.. tacn:: @expr__1 + @expr__2 + :name: + (backtracking branching) + + :n:`@expr__1` and :n:`@expr__2` are evaluated respectively to :n:`v__1` and + :n:`v__2` which must be tactic values. The tactic value :n:`v__1` is applied to + each focused goal independently and if it fails or a later tactic fails, then + the proof backtracks to the current goal and :n:`v__2` is applied. + + Tactics can be seen as having several successes. When a tactic fails it + asks for more successes of the prior tactics. + :n:`@expr__1 + @expr__2` has all the successes of :n:`v__1` followed by all the + successes of :n:`v__2`. Algebraically, + :n:`(@expr__1 + @expr__2); @expr__3 = (@expr__1; @expr__3) + (@expr__2; @expr__3)`. + + Branching is left-associative. + +First tactic to work +~~~~~~~~~~~~~~~~~~~~ + +Backtracking branching may be too expensive. In this case we may +restrict to a local, left biased, branching and consider the first +tactic to work (i.e. which does not fail) among a panel of tactics: + +.. tacn:: first [{*| @expr}] + :name: first + + The :n:`@expr__i` are evaluated to :n:`v__i` and :n:`v__i` must be + tactic values, for i=1,...,n. Supposing n>1, it applies, in each focused + goal independently, :n:`v__1`, if it works, it stops otherwise it + tries to apply :n:`v__2` and so on. It fails when there is no + applicable tactic. In other words, + :n:`first [:@expr__1 | ... | @expr__n]` behaves, in each goal, as the the first + :n:`v__i` to have *at least* one success. + + .. exn:: No applicable tactic. + + .. tacv:: first @expr + + This is an |Ltac| alias that gives a primitive access to the first + tactical as a |Ltac| definition without going through a parsing rule. It + expects to be given a list of tactics through a ``Tactic Notation``, + allowing to write notations of the following form: + + .. example:: + + .. coqtop:: in + + Tactic Notation "foo" tactic_list(tacs) := first tacs. + +Left-biased branching +~~~~~~~~~~~~~~~~~~~~~ + +Yet another way of branching without backtracking is the following +structure: + +.. tacn:: @expr__1 || @expr__2 + :name: || (left-biased branching) + + :n:`@expr__1` and :n:`@expr__2` are evaluated respectively to :n:`v__1` and + :n:`v__2` which must be tactic values. The tactic value :n:`v__1` is + applied in each subgoal independently and if it fails *to progress* then + :n:`v__2` is applied. :n:`@expr__1 || @expr__2` is + equivalent to :n:`first [ progress @expr__1 | @expr__2 ]` (except that + if it fails, it fails like :n:`v__2`). Branching is left-associative. + +Generalized biased branching +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +The tactic + +.. tacn:: tryif @expr__1 then @expr__2 else @expr__3 + :name: tryif + + is a generalization of the biased-branching tactics above. The + expression :n:`@expr__1` is evaluated to :n:`v__1`, which is then + applied to each subgoal independently. For each goal where :n:`v__1` + succeeds at least once, :n:`@expr__2` is evaluated to :n:`v__2` which + is then applied collectively to the generated subgoals. The :n:`v__2` + tactic can trigger backtracking points in :n:`v__1`: where :n:`v__1` + succeeds at least once, + :n:`tryif @expr__1 then @expr__2 else @expr__3` is equivalent to + :n:`v__1; v__2`. In each of the goals where :n:`v__1` does not succeed at least + once, :n:`@expr__3` is evaluated in :n:`v__3` which is is then applied to the + goal. + +Soft cut +~~~~~~~~ + +Another way of restricting backtracking is to restrict a tactic to a +single success *a posteriori*: + +.. tacn:: once @expr + :name: once + + :n:`@expr` is evaluated to ``v`` which must be a tactic value. The tactic value + ``v`` is applied but only its first success is used. If ``v`` fails, + :n:`once @expr` fails like ``v``. If ``v`` has a least one success, + :n:`once @expr` succeeds once, but cannot produce more successes. + +Checking the successes +~~~~~~~~~~~~~~~~~~~~~~ + +Coq provides an experimental way to check that a tactic has *exactly +one* success: + +.. tacn:: exactly_once @expr + :name: exactly_once + + :n:`@expr` is evaluated to ``v`` which must be a tactic value. The tactic value + ``v`` is applied if it has at most one success. If ``v`` fails, + :n:`exactly_once @expr` fails like ``v``. If ``v`` has a exactly one success, + :n:`exactly_once @expr` succeeds like ``v``. If ``v`` has two or more + successes, exactly_once expr fails. + + .. warning:: + + The experimental status of this tactic pertains to the fact if ``v`` + performs side effects, they may occur in a unpredictable way. Indeed, + normally ``v`` would only be executed up to the first success until + backtracking is needed, however exactly_once needs to look ahead to see + whether a second success exists, and may run further effects + immediately. + + .. exn:: This tactic has more than one success. + +Checking the failure +~~~~~~~~~~~~~~~~~~~~ + +Coq provides a derived tactic to check that a tactic *fails*: + +.. tacn:: assert_fails @expr + :name: assert_fails + + This behaves like :n:`tryif @expr then fail 0 tac "succeeds" else idtac`. + +Checking the success +~~~~~~~~~~~~~~~~~~~~ + +Coq provides a derived tactic to check that a tactic has *at least one* +success: + +.. tacn:: assert_succeeds @expr + :name: assert_suceeds + + This behaves like + :n:`tryif (assert_fails tac) then fail 0 tac "fails" else idtac`. + +Solving +~~~~~~~ + +We may consider the first to solve (i.e. which generates no subgoal) +among a panel of tactics: + +.. tacn:: solve [{*| @expr}] + :name: solve + + The :n:`@expr__i` are evaluated to :n:`v__i` and :n:`v__i` must be + tactic values, for i=1,...,n. Supposing n>1, it applies :n:`v__1` to + each goal independently, if it doesn’t solve the goal then it tries to + apply :n:`v__2` and so on. It fails if there is no solving tactic. + + .. exn:: Cannot solve the goal. + + .. tacv:: solve @expr + + This is an |Ltac| alias that gives a primitive access to the :n:`solve:` + tactical. See the :n:`first` tactical for more information. + +Identity +~~~~~~~~ + +The constant :n:`idtac` is the identity tactic: it leaves any goal unchanged but +it appears in the proof script. + +.. tacn:: idtac {* message_token} + :name: idtac + + This prints the given tokens. Strings and integers are printed + literally. If a (term) variable is given, its contents are printed. + +Failing +~~~~~~~ + +.. tacn:: fail + :name: fail + + This is the always-failing tactic: it does not solve any + goal. It is useful for defining other tacticals since it can be caught by + :tacn:`try`, :tacn:`repeat`, :tacn:`match goal`, or the branching tacticals. The + :tacn:`fail` tactic will, however, succeed if all the goals have already been + solved. + + .. tacv:: fail @num + + The number is the failure level. If no level is specified, it defaults to 0. + The level is used by :tacn:`try`, :tacn:`repeat`, :tacn:`match goal` and the branching + tacticals. If 0, it makes :tacn:`match goal` considering the next clause + (backtracking). If non zero, the current :tacn:`match goal` block, :tacn:`try`, + :tacn:`repeat`, or branching command is aborted and the level is decremented. In + the case of :n:`+`, a non-zero level skips the first backtrack point, even if + the call to :n:`fail @num` is not enclosed in a :n:`+` command, + respecting the algebraic identity. + + .. tacv:: fail {* message_token} + + The given tokens are used for printing the failure message. + + .. tacv:: fail @num {* message_token} + + This is a combination of the previous variants. + + .. tacv:: gfail + :name: gfail + + This variant fails even if there are no goals left. + + .. tacv:: gfail {* message_token} + + .. tacv:: gfail @num {* message_token} + + These variants fail with an error message or an error level even if + there are no goals left. Be careful however if Coq terms have to be + printed as part of the failure: term construction always forces the + tactic into the goals, meaning that if there are no goals when it is + evaluated, a tactic call like :n:`let x:=H in fail 0 x` will succeed. + + .. exn:: Tactic Failure message (level @num). + +Timeout +~~~~~~~ + +We can force a tactic to stop if it has not finished after a certain +amount of time: + +.. tacn:: timeout @num @expr + :name: timeout + + :n:`@expr` is evaluated to ``v`` which must be a tactic value. The tactic value + ``v`` is applied normally, except that it is interrupted after :n:`@num` seconds + if it is still running. In this case the outcome is a failure. + + .. warning:: + + For the moment, timeout is based on elapsed time in seconds, + which is very machine-dependent: a script that works on a quick machine + may fail on a slow one. The converse is even possible if you combine a + timeout with some other tacticals. This tactical is hence proposed only + for convenience during debug or other development phases, we strongly + advise you to not leave any timeout in final scripts. Note also that + this tactical isn’t available on the native Windows port of Coq. + +Timing a tactic +~~~~~~~~~~~~~~~ + +A tactic execution can be timed: + +.. tacn:: time @string @expr + :name: time + + evaluates :n:`@expr` and displays the time the tactic expression ran, whether it + fails or successes. In case of several successes, the time for each successive + runs is displayed. Time is in seconds and is machine-dependent. The :n:`@string` + argument is optional. When provided, it is used to identify this particular + occurrence of time. + +Timing a tactic that evaluates to a term +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +Tactic expressions that produce terms can be timed with the experimental +tactic + +.. tacn:: time_constr expr + :name: time_constr + + which evaluates :n:`@expr ()` and displays the time the tactic expression + evaluated, assuming successful evaluation. Time is in seconds and is + machine-dependent. + + This tactic currently does not support nesting, and will report times + based on the innermost execution. This is due to the fact that it is + implemented using the tactics + + .. tacn:: restart_timer @string + :name: restart_timer + + and + + .. tacn:: finish_timing {? @string} @string + :name: finish_timing + + which (re)set and display an optionally named timer, respectively. The + parenthesized string argument to :n:`finish_timing` is also optional, and + determines the label associated with the timer for printing. + + By copying the definition of :n:`time_constr` from the standard library, + users can achive support for a fixed pattern of nesting by passing + different :n:`@string` parameters to :n:`restart_timer` and :n:`finish_timing` + at each level of nesting. + + .. example:: + + .. coqtop:: all + + Ltac time_constr1 tac := + let eval_early := match goal with _ => restart_timer "(depth 1)" end in + let ret := tac () in + let eval_early := match goal with _ => finish_timing ( "Tactic evaluation" ) "(depth 1)" end in + ret. + + Goal True. + let v := time_constr + ltac:(fun _ => + let x := time_constr1 ltac:(fun _ => constr:(10 * 10)) in + let y := time_constr1 ltac:(fun _ => eval compute in x) in + y) in + pose v. + Abort. + +Local definitions +~~~~~~~~~~~~~~~~~ + +Local definitions can be done as follows: + +.. tacn:: let @ident__1 := @expr__1 {* with @ident__i := @expr__i} in @expr + + each :n:`@expr__i` is evaluated to :n:`v__i`, then, :n:`@expr` is evaluated + by substituting :n:`v__i` to each occurrence of :n:`@ident__i`, for + i=1,...,n. There is no dependencies between the :n:`@expr__i` and the + :n:`@ident__i`. + + Local definitions can be recursive by using :n:`let rec` instead of :n:`let`. + In this latter case, the definitions are evaluated lazily so that the rec + keyword can be used also in non recursive cases so as to avoid the eager + evaluation of local definitions. + + .. but rec changes the binding!! + +Application +~~~~~~~~~~~ + +An application is an expression of the following form: + +.. tacn:: @qualid {+ @tacarg} + + The reference :n:`@qualid` must be bound to some defined tactic definition + expecting at least as many arguments as the provided :n:`tacarg`. The + expressions :n:`@expr__i` are evaluated to :n:`v__i`, for i=1,...,n. + + .. what expressions ?? + +Function construction +~~~~~~~~~~~~~~~~~~~~~ + +A parameterized tactic can be built anonymously (without resorting to +local definitions) with: + +.. tacn:: fun {+ @ident} => @expr + + Indeed, local definitions of functions are a syntactic sugar for binding + a :n:`fun` tactic to an identifier. + +Pattern matching on terms +~~~~~~~~~~~~~~~~~~~~~~~~~ + +We can carry out pattern matching on terms with: + +.. tacn:: match @expr with {+| @cpattern__i => @expr__i} end + + The expression :n:`@expr` is evaluated and should yield a term which is + matched against :n:`cpattern__1`. The matching is non-linear: if a + metavariable occurs more than once, it should match the same expression + every time. It is first-order except on the variables of the form :n:`@?id` + that occur in head position of an application. For these variables, the + matching is second-order and returns a functional term. + + Alternatively, when a metavariable of the form :n:`?id` occurs under binders, + say :n:`x__1, …, x__n` and the expression matches, the + metavariable is instantiated by a term which can then be used in any + context which also binds the variables :n:`x__1, …, x__n` with + same types. This provides with a primitive form of matching under + context which does not require manipulating a functional term. + + If the matching with :n:`@cpattern__1` succeeds, then :n:`@expr__1` is + evaluated into some value by substituting the pattern matching + instantiations to the metavariables. If :n:`@expr__1` evaluates to a + tactic and the match expression is in position to be applied to a goal + (e.g. it is not bound to a variable by a :n:`let in`), then this tactic is + applied. If the tactic succeeds, the list of resulting subgoals is the + result of the match expression. If :n:`@expr__1` does not evaluate to a + tactic or if the match expression is not in position to be applied to a + goal, then the result of the evaluation of :n:`@expr__1` is the result + of the match expression. + + If the matching with :n:`@cpattern__1` fails, or if it succeeds but the + evaluation of :n:`@expr__1` fails, or if the evaluation of + :n:`@expr__1` succeeds but returns a tactic in execution position whose + execution fails, then :n:`cpattern__2` is used and so on. The pattern + :n:`_` matches any term and shunts all remaining patterns if any. If all + clauses fail (in particular, there is no pattern :n:`_`) then a + no-matching-clause error is raised. + + Failures in subsequent tactics do not cause backtracking to select new + branches or inside the right-hand side of the selected branch even if it + has backtracking points. + + .. exn:: No matching clauses for match. + + No pattern can be used and, in particular, there is no :n:`_` pattern. + + .. exn:: Argument of match does not evaluate to a term. + + This happens when :n:`@expr` does not denote a term. + + .. tacv:: multimatch @expr with {+| @cpattern__i => @expr__i} end + + Using multimatch instead of match will allow subsequent tactics to + backtrack into a right-hand side tactic which has backtracking points + left and trigger the selection of a new matching branch when all the + backtracking points of the right-hand side have been consumed. + + The syntax :n:`match …` is, in fact, a shorthand for :n:`once multimatch …`. + + .. tacv:: lazymatch @expr with {+| @cpattern__i => @expr__i} end + + Using lazymatch instead of match will perform the same pattern + matching procedure but will commit to the first matching branch + rather than trying a new matching if the right-hand side fails. If + the right-hand side of the selected branch is a tactic with + backtracking points, then subsequent failures cause this tactic to + backtrack. + + .. tacv:: context @ident [@cpattern] + + This special form of patterns matches any term with a subterm matching + cpattern. If there is a match, the optional :n:`@ident` is assigned the "matched + context", i.e. the initial term where the matched subterm is replaced by a + hole. The example below will show how to use such term contexts. + + If the evaluation of the right-hand-side of a valid match fails, the next + matching subterm is tried. If no further subterm matches, the next clause + is tried. Matching subterms are considered top-bottom and from left to + right (with respect to the raw printing obtained by setting option + :opt:`Printing All`). + + .. example:: + + .. coqtop:: all + + Ltac f x := + match x with + context f [S ?X] => + idtac X; (* To display the evaluation order *) + assert (p := eq_refl 1 : X=1); (* To filter the case X=1 *) + let x:= context f[O] in assert (x=O) (* To observe the context *) + end. + Goal True. + f (3+4). + +.. _ltac-match-goal: + +Pattern matching on goals +~~~~~~~~~~~~~~~~~~~~~~~~~ + +We can make pattern matching on goals using the following expression: + +.. we should provide the full grammar here + +.. tacn:: match goal with {+| {+ hyp} |- @cpattern => @expr } | _ => @expr end + :name: match goal + + If each hypothesis pattern :n:`hyp`\ :sub:`1,i`, with i=1,...,m\ :sub:`1` is + matched (non-linear first-order unification) by an hypothesis of the + goal and if :n:`cpattern_1` is matched by the conclusion of the goal, + then :n:`@expr__1` is evaluated to :n:`v__1` by substituting the + pattern matching to the metavariables and the real hypothesis names + bound to the possible hypothesis names occurring in the hypothesis + patterns. If :n:`v__1` is a tactic value, then it is applied to the + goal. If this application fails, then another combination of hypotheses + is tried with the same proof context pattern. If there is no other + combination of hypotheses then the second proof context pattern is tried + and so on. If the next to last proof context pattern fails then + the last :n:`@expr` is evaluated to :n:`v` and :n:`v` is + applied. Note also that matching against subterms (using the :n:`context + @ident [ @cpattern ]`) is available and is also subject to yielding several + matchings. + + Failures in subsequent tactics do not cause backtracking to select new + branches or combinations of hypotheses, or inside the right-hand side of + the selected branch even if it has backtracking points. + + .. exn:: No matching clauses for match goal. + + No clause succeeds, i.e. all matching patterns, if any, fail at the + application of the right-hand-side. + + .. note:: + + It is important to know that each hypothesis of the goal can be matched + by at most one hypothesis pattern. The order of matching is the + following: hypothesis patterns are examined from the right to the left + (i.e. hyp\ :sub:`i,m`\ :sub:`i`` before hyp\ :sub:`i,1`). For each + hypothesis pattern, the goal hypothesis are matched in order (fresher + hypothesis first), but it possible to reverse this order (older first) + with the :n:`match reverse goal with` variant. + + .. tacv:: multimatch goal with {+| {+ hyp} |- @cpattern => @expr } | _ => @expr end + + Using :n:`multimatch` instead of :n:`match` will allow subsequent tactics + to backtrack into a right-hand side tactic which has backtracking points + left and trigger the selection of a new matching branch or combination of + hypotheses when all the backtracking points of the right-hand side have + been consumed. + + The syntax :n:`match [reverse] goal …` is, in fact, a shorthand for + :n:`once multimatch [reverse] goal …`. + + .. tacv:: lazymatch goal with {+| {+ hyp} |- @cpattern => @expr } | _ => @expr end + + Using lazymatch instead of match will perform the same pattern matching + procedure but will commit to the first matching branch with the first + matching combination of hypotheses rather than trying a new matching if + the right-hand side fails. If the right-hand side of the selected branch + is a tactic with backtracking points, then subsequent failures cause + this tactic to backtrack. + +Filling a term context +~~~~~~~~~~~~~~~~~~~~~~ + +The following expression is not a tactic in the sense that it does not +produce subgoals but generates a term to be used in tactic expressions: + +.. tacn:: context @ident [@expr] + + :n:`@ident` must denote a context variable bound by a context pattern of a + match expression. This expression evaluates replaces the hole of the + value of :n:`@ident` by the value of :n:`@expr`. + + .. exn:: Not a context variable. + +Generating fresh hypothesis names +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +Tactics sometimes have to generate new names for hypothesis. Letting the +system decide a name with the intro tactic is not so good since it is +very awkward to retrieve the name the system gave. The following +expression returns an identifier: + +.. tacn:: fresh {* component} + + It evaluates to an identifier unbound in the goal. This fresh identifier + is obtained by concatenating the value of the :n:`@component`s (each of them + is, either a :n:`@qualid` which has to refer to a (unqualified) name, or + directly a name denoted by a :n:`@string`). + + .. I don't understand this component thing. Couldn't we give the grammar? + + If the resulting name is already used, it is padded with a number so that it + becomes fresh. If no component is given, the name is a fresh derivative of + the name ``H``. + +Computing in a constr +~~~~~~~~~~~~~~~~~~~~~ + +Evaluation of a term can be performed with: + +.. tacn:: eval @redexpr in @term + + where :n:`@redexpr` is a reduction tactic among :tacn:`red`, :tacn:`hnf`, + :tacn:`compute`, :tacn:`simpl`, :tacn:`cbv`, :tacn:`lazy`, :tacn:`unfold`, + :tacn:`fold`, :tacn:`pattern`. + +Recovering the type of a term +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +The following returns the type of term: + +.. tacn:: type of @term + +Manipulating untyped terms +~~~~~~~~~~~~~~~~~~~~~~~~~~ + +.. tacn:: uconstr : @term + + The terms built in |Ltac| are well-typed by default. It may not be + appropriate for building large terms using a recursive |Ltac| function: the + term has to be entirely type checked at each step, resulting in potentially + very slow behavior. It is possible to build untyped terms using |Ltac| with + the :n:`uconstr : @term` syntax. + +.. tacn:: type_term @term + + An untyped term, in |Ltac|, can contain references to hypotheses or to + |Ltac| variables containing typed or untyped terms. An untyped term can be + type-checked using the function type_term whose argument is parsed as an + untyped term and returns a well-typed term which can be used in tactics. + +Untyped terms built using :n:`uconstr :` can also be used as arguments to the +:tacn:`refine` tactic. In that case the untyped term is type +checked against the conclusion of the goal, and the holes which are not solved +by the typing procedure are turned into new subgoals. + +Counting the goals +~~~~~~~~~~~~~~~~~~ + +.. tacn:: numgoals + + The number of goals under focus can be recovered using the :n:`numgoals` + function. Combined with the guard command below, it can be used to + branch over the number of goals produced by previous tactics. + + .. example:: + + .. coqtop:: in + + Ltac pr_numgoals := let n := numgoals in idtac "There are" n "goals". + + Goal True /\ True /\ True. + split;[|split]. + + .. coqtop:: all + + all:pr_numgoals. + +Testing boolean expressions +~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +.. tacn:: guard @test + :name: guard + + The :tacn:`guard` tactic tests a boolean expression, and fails if the expression + evaluates to false. If the expression evaluates to true, it succeeds + without affecting the proof. + + The accepted tests are simple integer comparisons. + + .. example:: + + .. coqtop:: in + + Goal True /\ True /\ True. + split;[|split]. + + .. coqtop:: all + + all:let n:= numgoals in guard n<4. + Fail all:let n:= numgoals in guard n=2. + + .. exn:: Condition not satisfied. + +Proving a subgoal as a separate lemma +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +.. tacn:: abstract @expr + :name: abstract + + From the outside, :n:`abstract @expr` is the same as :n:`solve @expr`. + Internally it saves an auxiliary lemma called ``ident_subproofn`` where + ``ident`` is the name of the current goal and ``n`` is chosen so that this is + a fresh name. Such an auxiliary lemma is inlined in the final proof term. + + This tactical is useful with tactics such as :tacn:`omega` or + :tacn:`discriminate` that generate huge proof terms. With that tool the user + can avoid the explosion at time of the Save command without having to cut + manually the proof in smaller lemmas. + + It may be useful to generate lemmas minimal w.r.t. the assumptions they + depend on. This can be obtained thanks to the option below. + + .. tacv:: abstract @expr using @ident + + Give explicitly the name of the auxiliary lemma. + + .. warning:: + + Use this feature at your own risk; explicitly named and reused subterms + don’t play well with asynchronous proofs. + + .. tacv:: transparent_abstract @expr + :name: transparent_abstract + + Save the subproof in a transparent lemma rather than an opaque one. + + .. warning:: + + Use this feature at your own risk; building computationally relevant + terms with tactics is fragile. + + .. tacv:: transparent_abstract @expr using @ident + + Give explicitly the name of the auxiliary transparent lemma. + + .. warning:: + + Use this feature at your own risk; building computationally relevant terms + with tactics is fragile, and explicitly named and reused subterms + don’t play well with asynchronous proofs. + + .. exn:: Proof is not complete. + :name: Proof is not complete. (abstract) + +Tactic toplevel definitions +--------------------------- + +Defining |Ltac| functions +~~~~~~~~~~~~~~~~~~~~~~~~~ + +Basically, |Ltac| toplevel definitions are made as follows: + +.. cmd:: Ltac @ident {* @ident} := @expr + + This defines a new |Ltac| function that can be used in any tactic + script or new |Ltac| toplevel definition. + + .. note:: + + The preceding definition can equivalently be written: + + :n:`Ltac @ident := fun {+ @ident} => @expr` + + Recursive and mutual recursive function definitions are also possible + with the syntax: + + .. cmdv:: Ltac @ident {* @ident} {* with @ident {* @ident}} := @expr + + It is also possible to *redefine* an existing user-defined tactic using the syntax: + + .. cmdv:: Ltac @qualid {* @ident} ::= @expr + + A previous definition of qualid must exist in the environment. The new + definition will always be used instead of the old one and it goes across + module boundaries. + + If preceded by the keyword Local the tactic definition will not be + exported outside the current module. + +Printing |Ltac| tactics +~~~~~~~~~~~~~~~~~~~~~~~ + +.. cmd:: Print Ltac @qualid + + Defined |Ltac| functions can be displayed using this command. + +.. cmd:: Print Ltac Signatures + + This command displays a list of all user-defined tactics, with their arguments. + +Debugging |Ltac| tactics +------------------------ + +Info trace +~~~~~~~~~~ + +.. cmd:: Info @num @expr + :name: Info + + This command can be used to print the trace of the path eventually taken by an + |Ltac| script. That is, the list of executed tactics, discarding + all the branches which have failed. To that end the :cmd:`Info` command can be + used with the following syntax. + + + The number :n:`@num` is the unfolding level of tactics in the trace. At level + 0, the trace contains a sequence of tactics in the actual script, at level 1, + the trace will be the concatenation of the traces of these tactics, etc… + + .. example:: + + .. coqtop:: in reset + + Ltac t x := exists x; reflexivity. + Goal exists n, n=0. + + .. coqtop:: all + + Info 0 t 1||t 0. + + .. coqtop:: in + + Undo. + + .. coqtop:: all + + Info 1 t 1||t 0. + + The trace produced by :cmd:`Info` tries its best to be a reparsable + |Ltac| script, but this goal is not achievable in all generality. + So some of the output traces will contain oddities. + + As an additional help for debugging, the trace produced by :cmd:`Info` contains + (in comments) the messages produced by the :tacn:`idtac` tactical at the right + position in the script. In particular, the calls to idtac in branches which failed are + not printed. + + .. opt:: Info Level @num + + This option is an alternative to the :cmd:`Info` command. + + This will automatically print the same trace as :n:`Info @num` at each + tactic call. The unfolding level can be overridden by a call to the + :cmd:`Info` command. + +Interactive debugger +~~~~~~~~~~~~~~~~~~~~ + +.. opt:: Ltac Debug + + This option governs the step-by-step debugger that comes with the |Ltac| interpreter + +When the debugger is activated, it stops at every step of the evaluation of +the current |Ltac| expression and it prints information on what it is doing. +The debugger stops, prompting for a command which can be one of the +following: + ++-----------------+-----------------------------------------------+ +| simple newline: | go to the next step | ++-----------------+-----------------------------------------------+ +| h: | get help | ++-----------------+-----------------------------------------------+ +| x: | exit current evaluation | ++-----------------+-----------------------------------------------+ +| s: | continue current evaluation without stopping | ++-----------------+-----------------------------------------------+ +| r n: | advance n steps further | ++-----------------+-----------------------------------------------+ +| r string: | advance up to the next call to “idtac string” | ++-----------------+-----------------------------------------------+ + +A non-interactive mode for the debugger is available via the option: + +.. opt:: Ltac Batch Debug + + This option has the effect of presenting a newline at every prompt, when + the debugger is on. The debug log thus created, which does not require + user input to generate when this option is set, can then be run through + external tools such as diff. + +Profiling |Ltac| tactics +~~~~~~~~~~~~~~~~~~~~~~~~ + +It is possible to measure the time spent in invocations of primitive +tactics as well as tactics defined in |Ltac| and their inner +invocations. The primary use is the development of complex tactics, +which can sometimes be so slow as to impede interactive usage. The +reasons for the performence degradation can be intricate, like a slowly +performing |Ltac| match or a sub-tactic whose performance only +degrades in certain situations. The profiler generates a call tree and +indicates the time spent in a tactic depending its calling context. Thus +it allows to locate the part of a tactic definition that contains the +performance bug. + +.. opt:: Ltac Profiling + + This option enables and disables the profiler. + +.. cmd:: Show Ltac Profile + + Prints the profile + + .. cmdv:: Show Ltac Profile @string + + Prints a profile for all tactics that start with :n:`@string`. Append a period + (.) to the string if you only want exactly that name. + +.. cmd:: Reset Ltac Profile + + Resets the profile, that is, deletes all accumulated information. + + .. warning:: + + Backtracking across a :cmd:`Reset Ltac Profile` will not restore the information. + +.. coqtop:: reset in + + Require Import Coq.omega.Omega. + + Ltac mytauto := tauto. + Ltac tac := intros; repeat split; omega || mytauto. + + Notation max x y := (x + (y - x)) (only parsing). + + Goal forall x y z A B C D E F G H I J K L M N O P Q R S T U V W X Y Z, + max x (max y z) = max (max x y) z /\ max x (max y z) = max (max x y) z + /\ (A /\ B /\ C /\ D /\ E /\ F /\ G /\ H /\ I /\ J /\ K /\ L /\ M /\ N /\ O /\ P /\ Q /\ R /\ S /\ T /\ U /\ V /\ W /\ X /\ Y /\ Z + -> Z /\ Y /\ X /\ W /\ V /\ U /\ T /\ S /\ R /\ Q /\ P /\ O /\ N /\ M /\ L /\ K /\ J /\ I /\ H /\ G /\ F /\ E /\ D /\ C /\ B /\ A). + Proof. + +.. coqtop:: all + + Set Ltac Profiling. + tac. + Show Ltac Profile. + Show Ltac Profile "omega". + +.. coqtop:: in + + Abort. + Unset Ltac Profiling. + +.. tacn:: start ltac profiling + :name: start ltac profiling + + This tactic behaves like :tacn:`idtac` but enables the profiler. + +.. tacn:: stop ltac profiling + :name: stop ltac profiling + + Similarly to :tacn:`start ltac profiling`, this tactic behaves like + :tacn:`idtac`. Together, they allow you to exclude parts of a proof script + from profiling. + +.. tacn:: reset ltac profile + :name: reset ltac profile + + This tactic behaves like the corresponding vernacular command + and allow displaying and resetting the profile from tactic scripts for + benchmarking purposes. + +.. tacn:: show ltac profile + :name: show ltac profile + + This tactic behaves like the corresponding vernacular command + and allow displaying and resetting the profile from tactic scripts for + benchmarking purposes. + +.. tacn:: show ltac profile @string + :name: show ltac profile + + This tactic behaves like the corresponding vernacular command + and allow displaying and resetting the profile from tactic scripts for + benchmarking purposes. + +You can also pass the ``-profile-ltac`` command line option to ``coqc``, which +turns the :opt:`Ltac Profiling` option on at the beginning of each document, +and performs a :cmd:`Show Ltac Profile` at the end. + +.. warning:: + + Note that the profiler currently does not handle backtracking into + multi-success tactics, and issues a warning to this effect in many cases + when such backtracking occurs. + +Run-time optimization tactic +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +.. tacn:: optimize_heap + :name: optimize_heap + +This tactic behaves like :n:`idtac`, except that running it compacts the +heap in the OCaml run-time system. It is analogous to the Vernacular +command :cmd:`Optimize Heap`. diff --git a/doc/sphinx/proof-engine/proof-handling.rst b/doc/sphinx/proof-engine/proof-handling.rst new file mode 100644 index 000000000..eba0db3ff --- /dev/null +++ b/doc/sphinx/proof-engine/proof-handling.rst @@ -0,0 +1,595 @@ +.. include:: ../replaces.rst +.. _proofhandling: + +------------------- + Proof handling +------------------- + +In |Coq|’s proof editing mode all top-level commands documented in +Chapter :ref:`vernacularcommands` remain available and the user has access to specialized +commands dealing with proof development pragmas documented in this +section. They can also use some other specialized commands called +*tactics*. They are the very tools allowing the user to deal with +logical reasoning. They are documented in Chapter :ref:`tactics`. + +Coq user interfaces usually have a way of marking whether the user has +switched to proof editing mode. For instance, in coqtop the prompt ``Coq <`` is changed into +:n:`@ident <` where :token:`ident` is the declared name of the theorem currently edited. + +At each stage of a proof development, one has a list of goals to +prove. Initially, the list consists only in the theorem itself. After +having applied some tactics, the list of goals contains the subgoals +generated by the tactics. + +To each subgoal is associated a number of hypotheses called the *local context* +of the goal. Initially, the local context contains the local variables and +hypotheses of the current section (see Section :ref:`gallina-assumptions`) and +the local variables and hypotheses of the theorem statement. It is enriched by +the use of certain tactics (see e.g. :tacn:`intro`). + +When a proof is completed, the message ``Proof completed`` is displayed. +One can then register this proof as a defined constant in the +environment. Because there exists a correspondence between proofs and +terms of λ-calculus, known as the *Curry-Howard isomorphism* +:cite:`How80,Bar81,Gir89,Hue88`, |Coq| stores proofs as terms of |Cic|. Those +terms are called *proof terms*. + + +.. exn:: No focused proof. + + Coq raises this error message when one attempts to use a proof editing command + out of the proof editing mode. + +.. _proof-editing-mode: + +Switching on/off the proof editing mode +------------------------------------------- + +The proof editing mode is entered by asserting a statement, which typically is +the assertion of a theorem using an assertion command like :cmd:`Theorem`. The +list of assertion commands is given in :ref:`Assertions`. The command +:cmd:`Goal` can also be used. + +.. cmd:: Goal @form + + This is intended for quick assertion of statements, without knowing in + advance which name to give to the assertion, typically for quick + testing of the provability of a statement. If the proof of the + statement is eventually completed and validated, the statement is then + bound to the name ``Unnamed_thm`` (or a variant of this name not already + used for another statement). + +.. cmd:: Qed + + This command is available in interactive editing proof mode when the + proof is completed. Then :cmd:`Qed` extracts a proof term from the proof + script, switches back to Coq top-level and attaches the extracted + proof term to the declared name of the original goal. This name is + added to the environment as an opaque constant. + + .. exn:: Attempt to save an incomplete proof. + + .. note:: + + Sometimes an error occurs when building the proof term, because + tactics do not enforce completely the term construction + constraints. + + The user should also be aware of the fact that since the + proof term is completely rechecked at this point, one may have to wait + a while when the proof is large. In some exceptional cases one may + even incur a memory overflow. + + .. cmdv:: Defined + :name: Defined + + Same as :cmd:`Qed` but the proof is then declared transparent, which means + that its content can be explicitly used for type-checking and that it can be + unfolded in conversion tactics (see :ref:`performingcomputations`, + :cmd:`Opaque`, :cmd:`Transparent`). + + .. cmdv:: Save @ident + :name: Save + + Forces the name of the original goal to be :token:`ident`. This + command (and the following ones) can only be used if the original goal + has been opened using the :cmd:`Goal` command. + +.. cmd:: Admitted + + This command is available in interactive editing mode to give up + the current proof and declare the initial goal as an axiom. + +.. cmd:: Abort + + This command cancels the current proof development, switching back to + the previous proof development, or to the |Coq| toplevel if no other + proof was edited. + + .. exn:: No focused proof (No proof-editing in progress). + + .. cmdv:: Abort @ident + + Aborts the editing of the proof named :token:`ident` (in case you have + nested proofs). + + .. seealso:: :opt:`Nested Proofs Allowed` + + .. cmdv:: Abort All + + Aborts all current goals. + +.. cmd:: Proof @term + :name: Proof `term` + + This command applies in proof editing mode. It is equivalent to + :n:`exact @term. Qed.` + That is, you have to give the full proof in one gulp, as a + proof term (see Section :ref:`applyingtheorems`). + +.. cmd:: Proof + + Is a no-op which is useful to delimit the sequence of tactic commands + which start a proof, after a :cmd:`Theorem` command. It is a good practice to + use :cmd:`Proof` as an opening parenthesis, closed in the script with a + closing :cmd:`Qed`. + + .. seealso:: :cmd:`Proof with` + +.. cmd:: Proof using {+ @ident } + + This command applies in proof editing mode. It declares the set of + section variables (see :ref:`gallina-assumptions`) used by the proof. + At :cmd:`Qed` time, the + system will assert that the set of section variables actually used in + the proof is a subset of the declared one. + + The set of declared variables is closed under type dependency. For + example if ``T`` is variable and a is a variable of type ``T``, the commands + ``Proof using a`` and ``Proof using T a`` are actually equivalent. + + .. cmdv:: Proof using {+ @ident } with @tactic + + Combines in a single line :cmd:`Proof with` and :cmd:`Proof using`. + + .. seealso:: :ref:`tactics-implicit-automation` + + .. cmdv:: Proof using All + + Use all section variables. + + .. cmdv:: Proof using {? Type } + + Use only section variables occurring in the statement. + + .. cmdv:: Proof using Type* + + The ``*`` operator computes the forward transitive closure. E.g. if the + variable ``H`` has type ``p < 5`` then ``H`` is in ``p*`` since ``p`` occurs in the type + of ``H``. ``Type*`` is the forward transitive closure of the entire set of + section variables occurring in the statement. + + .. cmdv:: Proof using -({+ @ident }) + + Use all section variables except the list of :token:`ident`. + + .. cmdv:: Proof using @collection1 + @collection2 + + Use section variables from the union of both collections. + See :ref:`nameaset` to know how to form a named collection. + + .. cmdv:: Proof using @collection1 - @collection2 + + Use section variables which are in the first collection but not in the + second one. + + .. cmdv:: Proof using @collection - ({+ @ident }) + + Use section variables which are in the first collection but not in the + list of :token:`ident`. + + .. cmdv:: Proof using @collection * + + Use section variables in the forward transitive closure of the collection. + The ``*`` operator binds stronger than ``+`` and ``-``. + + +Proof using options +``````````````````` + +The following options modify the behavior of ``Proof using``. + + +.. opt:: Default Proof Using "@expression" + + Use :n:`@expression` as the default ``Proof using`` value. E.g. ``Set Default + Proof Using "a b"`` will complete all ``Proof`` commands not followed by a + ``using`` part with ``using a b``. + + +.. opt:: Suggest Proof Using + + When :cmd:`Qed` is performed, suggest a ``using`` annotation if the user did not + provide one. + +.. _`nameaset`: + +Name a set of section hypotheses for ``Proof using`` +```````````````````````````````````````````````````` + +.. cmd:: Collection @ident := @expression + + This can be used to name a set of section + hypotheses, with the purpose of making ``Proof using`` annotations more + compact. + + .. example:: + + Define the collection named ``Some`` containing ``x``, ``y`` and ``z``:: + + Collection Some := x y z. + + Define the collection named ``Fewer`` containing only ``x`` and ``y``:: + + Collection Fewer := Some - z + + Define the collection named ``Many`` containing the set union or set + difference of ``Fewer`` and ``Some``:: + + Collection Many := Fewer + Some + Collection Many := Fewer - Some + + Define the collection named ``Many`` containing the set difference of + ``Fewer`` and the unnamed collection ``x y``:: + + Collection Many := Fewer - (x y) + + + +.. cmd:: Existential @num := @term + + This command instantiates an existential variable. :token:`num` is an index in + the list of uninstantiated existential variables displayed by :cmd:`Show Existentials`. + + This command is intended to be used to instantiate existential + variables when the proof is completed but some uninstantiated + existential variables remain. To instantiate existential variables + during proof edition, you should use the tactic :tacn:`instantiate`. + +.. cmd:: Grab Existential Variables + + This command can be run when a proof has no more goal to be solved but + has remaining uninstantiated existential variables. It takes every + uninstantiated existential variable and turns it into a goal. + + +Navigation in the proof tree +-------------------------------- + +.. cmd:: Undo + + This command cancels the effect of the last command. Thus, it + backtracks one step. + +.. cmdv:: Undo @num + + Repeats Undo :token:`num` times. + +.. cmdv:: Restart + :name: Restart + + This command restores the proof editing process to the original goal. + + .. exn:: No focused proof to restart. + +.. cmd:: Focus + + This focuses the attention on the first subgoal to prove and the + printing of the other subgoals is suspended until the focused subgoal + is solved or unfocused. This is useful when there are many current + subgoals which clutter your screen. + + .. deprecated:: 8.8 + + Prefer the use of bullets or focusing brackets (see below). + +.. cmdv:: Focus @num + + This focuses the attention on the :token:`num` th subgoal to prove. + + .. deprecated:: 8.8 + + Prefer the use of focusing brackets with a goal selector (see below). + +.. cmd:: Unfocus + + This command restores to focus the goal that were suspended by the + last :cmd:`Focus` command. + + .. deprecated:: 8.8 + +.. cmd:: Unfocused + + Succeeds if the proof is fully unfocused, fails if there are some + goals out of focus. + +.. _curly-braces: + +.. cmd:: %{ %| %} + + The command ``{`` (without a terminating period) focuses on the first + goal, much like :cmd:`Focus` does, however, the subproof can only be + unfocused when it has been fully solved ( *i.e.* when there is no + focused goal left). Unfocusing is then handled by ``}`` (again, without a + terminating period). See also example in next section. + + Note that when a focused goal is proved a message is displayed + together with a suggestion about the right bullet or ``}`` to unfocus it + or focus the next one. + + .. cmdv:: @num: %{ + + This focuses on the :token:`num` th subgoal to prove. + + Error messages: + + .. exn:: This proof is focused, but cannot be unfocused this way. + + You are trying to use ``}`` but the current subproof has not been fully solved. + + .. exn:: No such goal. + :name: No such goal. (Focusing) + + .. exn:: Brackets only support the single numbered goal selector. + + See also error messages about bullets below. + +.. _bullets: + +Bullets +``````` + +Alternatively to ``{`` and ``}``, proofs can be structured with bullets. The +use of a bullet ``b`` for the first time focuses on the first goal ``g``, the +same bullet cannot be used again until the proof of ``g`` is completed, +then it is mandatory to focus the next goal with ``b``. The consequence is +that ``g`` and all goals present when ``g`` was focused are focused with the +same bullet ``b``. See the example below. + +Different bullets can be used to nest levels. The scope of bullet does +not go beyond enclosing ``{`` and ``}``, so bullets can be reused as further +nesting levels provided they are delimited by these. Available bullets +are ``-``, ``+``, ``*``, ``--``, ``++``, ``**``, ``---``, ``+++``, ``***``, ... (without a terminating period). + +Note again that when a focused goal is proved a message is displayed +together with a suggestion about the right bullet or ``}`` to unfocus it +or focus the next one. + +.. note:: + + In Proof General (``Emacs`` interface to |Coq|), you must use + bullets with the priority ordering shown above to have a correct + indentation. For example ``-`` must be the outer bullet and ``**`` the inner + one in the example below. + +The following example script illustrates all these features: + +.. example:: + .. coqtop:: all + + Goal (((True /\ True) /\ True) /\ True) /\ True. + Proof. + split. + - split. + + split. + ** { split. + - trivial. + - trivial. + } + ** trivial. + + trivial. + - assert True. + { trivial. } + assumption. + + +.. exn:: Wrong bullet @bullet1: Current bullet @bullet2 is not finished. + + Before using bullet :n:`@bullet1` again, you should first finish proving the current focused goal. Note that :n:`@bullet1` and :n:`@bullet2` may be the same. + +.. exn:: Wrong bullet @bullet1: Bullet @bullet2 is mandatory here. + + You must put :n:`@bullet2` to focus next goal. No other bullet is allowed here. + +.. exn:: No such goal. Focus next goal with bullet @bullet. + + You tried to apply a tactic but no goal where under focus. Using :n:`@bullet` is mandatory here. + +.. exn:: No such goal. Try unfocusing with %{. + + You just finished a goal focused by ``{``, you must unfocus it with ``}``. + +Set Bullet Behavior +``````````````````` +.. opt:: Bullet Behavior %( "None" %| "Strict Subproofs" %) + + This option controls the bullet behavior and can take two possible values: + + - "None": this makes bullets inactive. + - "Strict Subproofs": this makes bullets active (this is the default behavior). + +.. _requestinginformation: + +Requesting information +---------------------- + + +.. cmd:: Show + + This command displays the current goals. + + .. exn:: No focused proof. + + .. cmdv:: Show @num + + Displays only the :token:`num` th subgoal. + + .. exn:: No such goal. + + + .. cmdv:: Show @ident + + Displays the named goal :token:`ident`. This is useful in + particular to display a shelved goal but only works if the + corresponding existential variable has been named by the user + (see :ref:`existential-variables`) as in the following example. + + .. example:: + + .. coqtop:: all + + Goal exists n, n = 0. + eexists ?[n]. + Show n. + + .. cmdv:: Show Script + :name: Show Script + + Displays the whole list of tactics applied from the + beginning of the current proof. This tactics script may contain some + holes (subgoals not yet proved). They are printed under the form + + ``<Your Tactic Text here>``. + + .. cmdv:: Show Proof + :name: Show Proof + + It displays the proof term generated by the tactics + that have been applied. If the proof is not completed, this term + contain holes, which correspond to the sub-terms which are still to be + constructed. These holes appear as a question mark indexed by an + integer, and applied to the list of variables in the context, since it + may depend on them. The types obtained by abstracting away the context + from the type of each hole-placer are also printed. + + .. cmdv:: Show Conjectures + :name: Show Conjectures + + It prints the list of the names of all the + theorems that are currently being proved. As it is possible to start + proving a previous lemma during the proof of a theorem, this list may + contain several names. + + .. cmdv:: Show Intro + :name: Show Intro + + If the current goal begins by at least one product, + this command prints the name of the first product, as it would be + generated by an anonymous :tacn:`intro`. The aim of this command is to ease + the writing of more robust scripts. For example, with an appropriate + Proof General macro, it is possible to transform any anonymous :tacn:`intro` + into a qualified one such as ``intro y13``. In the case of a non-product + goal, it prints nothing. + + .. cmdv:: Show Intros + :name: Show Intros + + This command is similar to the previous one, it + simulates the naming process of an :tacn:`intros`. + + .. cmdv:: Show Existentials + :name: Show Existentials + + It displays the set of all uninstantiated + existential variables in the current proof tree, along with the type + and the context of each variable. + + .. cmdv:: Show Match @ident + + This variant displays a template of the Gallina + ``match`` construct with a branch for each constructor of the type + :token:`ident` + + .. example:: + .. coqtop:: all + + Show Match nat. + + .. exn:: Unknown inductive type. + + .. cmdv:: Show Universes + :name: Show Universes + + It displays the set of all universe constraints and + its normalized form at the current stage of the proof, useful for + debugging universe inconsistencies. + + +.. cmd:: Guarded + + Some tactics (e.g. :tacn:`refine`) allow to build proofs using + fixpoint or co-fixpoint constructions. Due to the incremental nature + of interactive proof construction, the check of the termination (or + guardedness) of the recursive calls in the fixpoint or cofixpoint + constructions is postponed to the time of the completion of the proof. + + The command :cmd:`Guarded` allows checking if the guard condition for + fixpoint and cofixpoint is violated at some time of the construction + of the proof without having to wait the completion of the proof. + + +Controlling the effect of proof editing commands +------------------------------------------------ + + +.. opt:: Hyps Limit @num + + This option controls the maximum number of hypotheses displayed in goals + after the application of a tactic. All the hypotheses remain usable + in the proof development. + When unset, it goes back to the default mode which is to print all + available hypotheses. + + +.. opt:: Automatic Introduction + + This option controls the way binders are handled + in assertion commands such as :n:`Theorem @ident {? @binders} : @term`. When the + option is on, which is the default, binders are automatically put in + the local context of the goal to prove. + + When the option is off, binders are discharged on the statement to be + proved and a tactic such as :tacn:`intro` (see Section :ref:`managingthelocalcontext`) + has to be used to move the assumptions to the local context. + + +.. opt:: Nested Proofs Allowed + + When turned on (it is off by default), this option enables support for nested + proofs: a new assertion command can be inserted before the current proof is + finished, in which case Coq will temporarily switch to the proof of this + *nested lemma*. When the proof of the nested lemma is finished (with :cmd:`Qed` + or :cmd:`Defined`), its statement will be made available (as if it had been + proved before starting the previous proof) and Coq will switch back to the + proof of the previous assertion. + + +Controlling memory usage +------------------------ + +When experiencing high memory usage the following commands can be used +to force |Coq| to optimize some of its internal data structures. + + +.. cmd:: Optimize Proof + + This command forces |Coq| to shrink the data structure used to represent + the ongoing proof. + + +.. cmd:: Optimize Heap + + This command forces the |OCaml| runtime to perform a heap compaction. + This is in general an expensive operation. + See: `OCaml Gc <http://caml.inria.fr/pub/docs/manual-ocaml/libref/Gc.html#VALcompact>`_ + There is also an analogous tactic :tacn:`optimize_heap`. diff --git a/doc/sphinx/proof-engine/ssreflect-proof-language.rst b/doc/sphinx/proof-engine/ssreflect-proof-language.rst index 61dffa024..3b2009657 100644 --- a/doc/sphinx/proof-engine/ssreflect-proof-language.rst +++ b/doc/sphinx/proof-engine/ssreflect-proof-language.rst @@ -6,10 +6,7 @@ The |SSR| proof language ------------------------------ -:Source: https://coq.inria.fr/distrib/current/refman/ssreflect.html -:Converted by: Enrico Tassi - -Author: Georges Gonthier, Assia Mahboubi, Enrico Tassi +:Authors: Georges Gonthier, Assia Mahboubi, Enrico Tassi Introduction @@ -40,7 +37,7 @@ bookkeeping is performed on the conclusion of the goal, using for that purpose a couple of syntactic constructions behaving similar to tacticals (and often named as such in this chapter). The ``:`` tactical moves hypotheses from the context to the conclusion, while ``=>`` moves hypotheses from the -conclusion to the context, and in moves back and forth an hypothesis from the +conclusion to the context, and ``in`` moves back and forth an hypothesis from the context to the conclusion for the time of applying an action to it. While naming hypotheses is commonly done by means of an ``as`` clause in the @@ -50,20 +47,22 @@ often followed by ``=>`` to explicitly name them. While generalizing the goal is normally not explicitly needed in Chapter :ref:`tactics`, it is an explicit operation performed by ``:``. +.. seealso:: :ref:`bookkeeping_ssr` + Beside the difference of bookkeeping model, this chapter includes specific tactics which have no explicit counterpart in Chapter :ref:`tactics` -such as tactics to mix forward steps and generalizations as generally -have or without loss. +such as tactics to mix forward steps and generalizations as +:tacn:`generally have` or :tacn:`without loss`. |SSR| adopts the point of view that rewriting, definition expansion and partial evaluation participate all to a same concept of rewriting a goal in a larger sense. As such, all these functionalities -are provided by the rewrite tactic. +are provided by the :tacn:`rewrite <rewrite (ssreflect)>` tactic. |SSR| includes a little language of patterns to select subterms in tactics or tacticals where it matters. Its most notable application is -in the rewrite tactic, where patterns are used to specify where the -rewriting step has to take place. +in the :tacn:`rewrite <rewrite (ssreflect)>` tactic, where patterns are +used to specify where the rewriting step has to take place. Finally, |SSR| supports so-called reflection steps, typically allowing to switch back and forth between the computational view and @@ -90,20 +89,24 @@ Getting started ~~~~~~~~~~~~~~~ To be available, the tactics presented in this manual need the -following minimal set of libraries to loaded: ``ssreflect.v``, +following minimal set of libraries to be loaded: ``ssreflect.v``, ``ssrfun.v`` and ``ssrbool.v``. Moreover, these tactics come with a methodology specific to the authors of |SSR| and which requires a few options to be set in a different way than in their default way. All in all, this corresponds to working in the following context: -.. coqtop:: all +.. coqtop:: in From Coq Require Import ssreflect ssrfun ssrbool. Set Implicit Arguments. Unset Strict Implicit. Unset Printing Implicit Defensive. +.. seealso:: + :opt:`Implicit Arguments`, :opt:`Strict Implicit`, + :opt:`Printing Implicit Defensive` + .. _compatibility_issues_ssr: @@ -117,14 +120,14 @@ compatible with the rest of |Coq|, up to a few discrepancies: + New keywords (``is``) might clash with variable, constant, tactic or tactical names, or with quasi-keywords in tactic or vernacular notations. -+ New tactic(al)s names (``last``, ``done``, ``have``, ``suffices``, - ``suff``, ``without loss``, ``wlog``, ``congr``, ``unlock``) ++ New tactic(al)s names (:tacn:`last`, :tacn:`done`, :tacn:`have`, :tacn:`suffices`, + :tacn:`suff`, :tacn:`without loss`, :tacn:`wlog`, :tacn:`congr`, :tacn:`unlock`) might clash with user tactic names. + Identifiers with both leading and trailing ``_``, such as ``_x_``, are reserved by |SSR| and cannot appear in scripts. -+ The extensions to the rewrite tactic are partly incompatible with those ++ The extensions to the :tacn:`rewrite` tactic are partly incompatible with those available in current versions of |Coq|; in particular: ``rewrite .. in - (type of k)`` or ``rewrite .. in *`` or any other variant of ``rewrite`` + (type of k)`` or ``rewrite .. in *`` or any other variant of :tacn:`rewrite` will not work, and the |SSR| syntax and semantics for occurrence selection and rule chaining is different. Use an explicit rewrite direction (``rewrite <- …`` or ``rewrite -> …``) to access the |Coq| rewrite tactic. @@ -142,7 +145,7 @@ compatible with the rest of |Coq|, up to a few discrepancies: Note that the full syntax of |SSR|’s rewrite and reserved identifiers are enabled only if the ssreflect module has been required and if ``SsrSyntax`` has - been imported. Thus a file that requires (without importing) ssreflect + been imported. Thus a file that requires (without importing) ``ssreflect`` and imports ``SsrSyntax``, can be required and imported without automatically enabling |SSR|’s extended rewrite syntax and reserved identifiers. @@ -151,9 +154,10 @@ compatible with the rest of |Coq|, up to a few discrepancies: such as have, set and pose. + The generalization of if statements to non-Boolean conditions is turned off by |SSR|, because it is mostly subsumed by Coercion to ``bool`` of the - ``sumXXX`` types (declared in ``ssrfun.v``) and the ``if`` *term* ``is`` *pattern* ``then`` - *term* ``else`` *term* construct (see :ref:`pattern_conditional_ssr`). To use the - generalized form, turn off the |SSR| Boolean if notation using the command: + ``sumXXX`` types (declared in ``ssrfun.v``) and the + :n:`if @term is @pattern then @term else @term` construct + (see :ref:`pattern_conditional_ssr`). To use the + generalized form, turn off the |SSR| Boolean ``if`` notation using the command: ``Close Scope boolean_if_scope``. + The following two options can be unset to disable the incompatible rewrite syntax and allow reserved identifiers to appear in scripts. @@ -194,9 +198,9 @@ construct differs from the latter in that + The pattern can be nested (deep pattern matching), in particular, this allows expression of the form: -.. coqtop:: in +.. coqdoc:: - let: exist (x, y) p_xy := Hp in … . + let: exist (x, y) p_xy := Hp in … . + The destructured constructor is explicitly given in the pattern, and is used for type inference. @@ -225,11 +229,7 @@ construct differs from the latter in that The ``let:`` construct is just (more legible) notation for the primitive -|Gallina| expression - -.. coqtop:: in - - match term with pattern => term end. +|Gallina| expression :n:`match @term with @pattern => @term end`. The |SSR| destructuring assignment supports all the dependent match annotations; the full syntax is @@ -289,28 +289,17 @@ assignment with a refutable pattern, adapted to the pure functional setting of |Gallina|, which lacks a ``Match_Failure`` exception. Like ``let:`` above, the ``if…is`` construct is just (more legible) notation -for the primitive |Gallina| expression: - -.. coqtop:: in - - match term with pattern => term | _ => term end. +for the primitive |Gallina| expression +:n:`match @term with @pattern => @term | _ => @term end`. Similarly, it will always be displayed as the expansion of this form in terms of primitive match expressions (where the default expression may be replicated). Explicit pattern testing also largely subsumes the generalization of -the if construct to all binary data types; compare: - -.. coqtop:: in - - if term is inl _ then term else term. - -and: - -.. coqtop:: in - - if term then term else term. +the ``if`` construct to all binary data types; compare +:n:`if @term is inl _ then @term else @term` and +:n:`if @term then @term else @term`. The latter appears to be marginally shorter, but it is quite ambiguous, and indeed often requires an explicit annotation @@ -426,7 +415,7 @@ an improvement over ``all null s``. The syntax of the new declaration is -.. cmd:: Prenex Implicits {+ @ident}. +.. cmd:: Prenex Implicits {+ @ident} Let us denote :math:`c_1` … :math:`c_n` the list of identifiers given to a ``Prenex Implicits`` command. The command checks that each ci is the name of @@ -437,7 +426,7 @@ a functional constant, whose implicit arguments are prenex, i.e., the first As these prenex implicit arguments are ubiquitous and have often large display strings, it is strongly recommended to change the default display settings of |Coq| so that they are not printed (except after -a ``Set Printing All command``). All |SSR| library files thus start +a ``Set Printing All`` command). All |SSR| library files thus start with the incantation .. coqtop:: all undo @@ -451,7 +440,7 @@ Anonymous arguments ~~~~~~~~~~~~~~~~~~~ When in a definition, the type of a certain argument is mandatory, but -not its name, one usually use “arrow” abstractions for prenex +not its name, one usually uses “arrow” abstractions for prenex arguments, or the ``(_ : term)`` syntax for inner arguments. In |SSR|, the latter can be replaced by the open syntax ``of term`` or (equivalently) ``& term``, which are both syntactically equivalent to a @@ -496,19 +485,13 @@ inferred from the whole context of the goal (see for example section Definitions ~~~~~~~~~~~ -The pose tactic allows to add a defined constant to a proof context. -|SSR| generalizes this tactic in several ways. In particular, the -|SSR| pose tactic supports *open syntax*: the body of the -definition does not need surrounding parentheses. For instance: +.. tacn:: pose + :name: pose (ssreflect) -.. coqtop:: reset - - From Coq Require Import ssreflect. - Set Implicit Arguments. - Unset Strict Implicit. - Unset Printing Implicit Defensive. - Lemma test : True. - Proof. + This tactic allows to add a defined constant to a proof context. + |SSR| generalizes this tactic in several ways. In particular, the + |SSR| pose tactic supports *open syntax*: the body of the + definition does not need surrounding parentheses. For instance: .. coqtop:: in @@ -518,10 +501,18 @@ is a valid tactic expression. The pose tactic is also improved for the local definition of higher order terms. Local definitions of functions can use the same syntax as -global ones. For example the tactic ``pose`` supoprts parameters: +global ones. +For example, the tactic :tacn:`pose <pose (ssreflect)>` supoprts parameters: .. example:: + .. coqtop:: reset + + From Coq Require Import ssreflect. + Set Implicit Arguments. + Unset Strict Implicit. + Unset Printing Implicit Defensive. + .. coqtop:: all Lemma test : True. @@ -631,7 +622,7 @@ where: surrounding the second :token:`term` are mandatory. + In the occurrence switch :token:`occ_switch`, if the first element of the list is a natural, this element should be a number, and not an Ltac - variable. The empty list {} is not interpreted as a valid occurrence + variable. The empty list ``{}`` is not interpreted as a valid occurrence switch. The tactic: @@ -667,7 +658,7 @@ The tactic first tries to find a subterm of the goal matching the second :token:`term` (and its type), and stops at the first subterm it finds. Then the occurrences of this subterm selected by the optional :token:`occ_switch` -are replaced by :token:`ident` and a definition ``ident := term`` +are replaced by :token:`ident` and a definition :n:`@ident := @term` is added to the context. If no :token:`occ_switch` is present, then all the occurrences are abstracted. @@ -676,20 +667,20 @@ abstracted. Matching ```````` -The matching algorithm compares a pattern ``term`` with a subterm of the +The matching algorithm compares a pattern :token:`term` with a subterm of the goal by comparing their heads and then pairwise unifying their arguments (modulo conversion). Head symbols match under the following conditions: -+ If the head of ``term`` is a constant, then it should be syntactically ++ If the head of :token:`term` is a constant, then it should be syntactically equal to the head symbol of the subterm. + If this head is a projection of a canonical structure, then canonical structure equations are used for the matching. + If the head of term is *not* a constant, the subterm should have the same structure (λ abstraction,let…in structure …). -+ If the head of ``term`` is a hole, the subterm should have at least as - many arguments as ``term``. ++ If the head of :token:`term` is a hole, the subterm should have at least as + many arguments as :token:`term`. .. example:: @@ -1082,7 +1073,7 @@ constants to the goal. Because they are tacticals, ``:`` and ``=>`` can be combined, as in -.. coqtop: in +.. coqtop:: in move: m le_n_m => p le_n_p. @@ -1147,9 +1138,7 @@ induction on the top variable ``m`` with elim=> [|m IHm] n le_n. The general form of the localization tactical in is also best -explained in terms of the goal stack: - -.. coqtop:: in +explained in terms of the goal stack:: tactic in a H1 H2 *. @@ -1212,8 +1201,8 @@ product or a ``let…in``, and performs ``hnf`` otherwise. Of course this tactic is most often used in combination with the bookkeeping tacticals (see section :ref:`introduction_ssr` and :ref:`discharge_ssr`). These -combinations mostly subsume the ``intros``, ``generalize``, ``revert``, ``rename``, -``clear`` and ``pattern`` tactics. +combinations mostly subsume the :tacn:`intros`, :tacn:`generalize`, :tacn:`revert`, :tacn:`rename`, +:tacn:`clear` and :tacn:`pattern` tactics. The case tactic @@ -1229,15 +1218,11 @@ The |SSR| case tactic has a special behavior on equalities. If the top assumption of the goal is an equality, the case tactic “destructs” it as a set of equalities between the constructor arguments of its left and right hand sides, as per the tactic injection. For example, -``case`` changes the goal - -.. coqtop:: in +``case`` changes the goal:: (x, y) = (1, 2) -> G. -into - -.. coqtop:: in +into:: x = 1 -> y = 2 -> G. @@ -1289,13 +1274,11 @@ In fact the |SSR| tactic: .. tacn:: apply :name: apply (ssreflect) -is a synonym for: - -.. coqtop:: in +is a synonym for:: intro top; first [refine top | refine (top _) | refine (top _ _) | …]; clear top. -where ``top`` is fresh name, and the sequence of refine tactics tries to +where ``top`` is a fresh name, and the sequence of refine tactics tries to catch the appropriate number of wildcards to be inserted. Note that this use of the refine tactic implies that the tactic tries to match the goal up to expansion of constants and evaluation of subterms. @@ -1322,18 +1305,14 @@ existential metavariables of sort Prop. Note that the last ``_`` of the tactic ``apply: (ex_intro _ (exist _ y _))`` - represents a proof that ``y < 3``. Instead of generating the goal - - .. coqtop:: in + represents a proof that ``y < 3``. Instead of generating the goal:: 0 < proj1_sig (exist (fun n : nat => n < 3) y ?Goal). the system tries to prove ``y < 3`` calling the trivial tactic. If it succeeds, let’s say because the context contains ``H : y < 3``, then the - system generates the following goal: - - .. coqtop:: in + system generates the following goal:: 0 < proj1_sig (exist (fun n => n < 3) y H). @@ -1352,6 +1331,7 @@ Discharge The general syntax of the discharging tactical ``:`` is: .. tacn:: @tactic {? @ident } : {+ @d_item } {? @clear_switch } + :name: ... : ... (ssreflect) .. prodn:: d_item ::= {? @occ_switch %| @clear_switch } @term @@ -1503,9 +1483,11 @@ side of an equation. The abstract tactic ``````````````````` -The ``abstract`` tactic assigns an ``abstract`` constant previously -introduced with the ``[: name ]`` intro pattern -(see section :ref:`introduction_ssr`). +.. tacn:: abstract: {+ d_item} + :name abstract (ssreflect) + +This tactic assigns an abstract constant previously introduced with the ``[: +name ]`` intro pattern (see section :ref:`introduction_ssr`). In a goal like the following:: @@ -1573,10 +1555,10 @@ The :token:`i_pattern` s can be seen as a variant of *intro patterns* :ref:`tactics`: each performs an introduction operation, i.e., pops some variables or assumptions from the goal. -An :token:`s_item` can simplify the set of subgoals or the subgoal themselves: +An :token:`s_item` can simplify the set of subgoals or the subgoals themselves: + ``//`` removes all the “trivial” subgoals that can be resolved by the - |SSR| tactic ``done`` described in :ref:`terminators_ssr`, i.e., + |SSR| tactic :tacn:`done` described in :ref:`terminators_ssr`, i.e., it executes ``try done``. + ``/=`` simplifies the goal by performing partial evaluation, as per the tactic ``simpl`` [#5]_. @@ -1734,7 +1716,7 @@ new constant as an equation. The tactic: .. coqtop:: in - move En: (size l) => n. + move En: (size l) => n. where ``l`` is a list, replaces ``size l`` by ``n`` in the goal and adds the fact ``En : size l = n`` to the context. @@ -1742,7 +1724,7 @@ This is quite different from: .. coqtop:: in - pose n := (size l). + pose n := (size l). which generates a definition ``n := (size l)``. It is not possible to generalize or rewrite such a definition; on the other hand, it is @@ -1812,6 +1794,8 @@ of a :token:`d_item` immediately following this ``/`` switch, using the syntax: .. tacv:: case: {+ @d_item } / {+ @d_item } + :name: case (ssreflect) + .. tacv:: elim: {+ @d_item } / {+ @d_item } The :token:`d_item` on the right side of the ``/`` switch are discharged as @@ -1829,9 +1813,9 @@ compact syntax: .. coqtop:: in - case: {2}_ / eqP. + case: {2}_ / eqP. -were ``_`` is interpreted as ``(_ == _)`` since +where ``_`` is interpreted as ``(_ == _)`` since ``eqP T a b : reflect (a = b) (a == b)`` and reflect is a type family with one index. @@ -1994,19 +1978,9 @@ into a closing one (similar to now). Its general syntax is: .. tacn:: by @tactic :name: by -The Ltac expression: - -.. coqtop:: in - - by [@tactic | [@tactic | …]. - -is equivalent to: - -.. coqtop:: in - - [by @tactic | by @tactic | ...]. - -and this form should be preferred to the former. +The Ltac expression :n:`by [@tactic | [@tactic | …]` is equivalent to +:n:`[by @tactic | by @tactic | ...]` and this form should be preferred +to the former. In the script provided as example in section :ref:`indentation_ssr`, the paragraph corresponding to each sub-case ends with a tactic line prefixed @@ -2016,20 +1990,13 @@ with a ``by``, like in: by apply/eqP; rewrite -dvdn1. -The by tactical is implemented using the user-defined, and extensible -done tactic. This done tactic tries to solve the current goal by some -trivial means and fails if it doesn’t succeed. Indeed, the tactic -expression: - -.. coqtop:: in - - by tactic. +.. tacn:: done + :name: done -is equivalent to: - -.. coqtop:: in - - tactic; done. +The :tacn:`by` tactical is implemented using the user-defined, and extensible +:tacn:`done` tactic. This :tacn:`done` tactic tries to solve the current goal by some +trivial means and fails if it doesn’t succeed. Indeed, the tactic +expression :n:`by @tactic` is equivalent to :n:`@tactic; done`. Conversely, the tactic @@ -2074,7 +2041,7 @@ is equivalent to: do [done | by move=> top; apply top]. -where top is a fresh name affected to the top assumption of the goal. +where ``top`` is a fresh name assigned to the top assumption of the goal. This applied form is supported by the : discharge tactical, and the tactic: @@ -2090,7 +2057,7 @@ is equivalent to: (see section :ref:`discharge_ssr` for the documentation of the apply: combination). -Warning The list of tactics, possibly chained by semi-columns, that +Warning The list of tactics, possibly chained by semicolons, that follows a by keyword is considered as a parenthesized block applied to the current goal. Hence for example if the tactic: @@ -2123,7 +2090,7 @@ generated by the previous tactic. This covers the frequent cases where a tactic generates two subgoals one of which can be easily disposed of. -This is an other powerful way of linearization of scripts, since it +This is another powerful way of linearization of scripts, since it happens very often that a trivial subgoal can be solved in a less than one line tactic. For instance, the tactic: @@ -2131,14 +2098,14 @@ one line tactic. For instance, the tactic: :name: last tries to solve the last subgoal generated by the first -tactic using the given second tactic , and fails if it does not succeeds. -Its analogous +tactic using the given second tactic, and fails if it does not succeed. +Its analogue .. tacn:: @tactic ; first by @tactic - :name: first + :name: first (ssreflect) tries to solve the first subgoal generated by the first tactic using the -second given tactic, and fails if it does not succeeds. +second given tactic, and fails if it does not succeed. |SSR| also offers an extension of this facility, by supplying tactics to *permute* the subgoals generated by a tactic. The tactic: @@ -2152,10 +2119,10 @@ equivalent to: More generally, the tactic: -.. tacn:: @tactic; last @natural first +.. tacn:: @tactic; last @num first :name: last first -where :token:`natural` is a |Coq| numeral, or and Ltac variable +where :token:`num` is a |Coq| numeral, or an Ltac variable denoting a |Coq| numeral, having the value k. It rotates the n subgoals G1 , …, Gn generated by tactic. The first subgoal becomes Gn + 1 − k and the @@ -2163,7 +2130,7 @@ circular order of subgoals remains unchanged. Conversely, the tactic: -.. tacn:: @tactic; first @natural last +.. tacn:: @tactic; first @num last :name: first last rotates the n subgoals G1 , …, Gn generated by tactic in order that @@ -2215,7 +2182,7 @@ Iteration thanks to the do tactical, whose general syntax is: .. tacn:: do {? @mult } ( @tactic | [ {+| @tactic } ] ) - :name: do + :name: do (ssreflect) where :token:`mult` is a *multiplier*. @@ -2259,14 +2226,14 @@ For instance, the tactic: tactic; do 1? rewrite mult_comm. -rewrites at most one time the lemma ``mult_com`` in all the subgoals +rewrites at most one time the lemma ``mult_comm`` in all the subgoals generated by tactic , whereas the tactic: .. coqtop:: in tactic; do 2! rewrite mult_comm. -rewrites exactly two times the lemma ``mult_com`` in all the subgoals +rewrites exactly two times the lemma ``mult_comm`` in all the subgoals generated by tactic, and fails if this rewrite is not possible in some subgoal. @@ -2335,10 +2302,10 @@ to the following one: .. tacv:: @tactic in {+ @clear_switch | {? @ } @ident | ( @ident ) | ( {? @ } @ident := @c_pattern ) } {? * } In its simplest form the last option lets one rename hypotheses that -can’t be cleared (like section variables). For example ``(y := x)`` +can’t be cleared (like section variables). For example, ``(y := x)`` generalizes over ``x`` and reintroduces the generalized variable under the name ``y`` (and does not clear ``x``). -For a more precise description this form of localization refer +For a more precise description of this form of localization refer to :ref:`advanced_generalization_ssr`. @@ -2351,7 +2318,7 @@ Forward reasoning structures the script by explicitly specifying some assumptions to be added to the proof context. It is closely associated with the declarative style of proof, since an extensive use of these highlighted statements make the script closer to a (very detailed) -text book proof. +textbook proof. Forward chaining tactics allow to state an intermediate lemma and start a piece of script dedicated to the proof of this statement. The use of closing @@ -2492,7 +2459,7 @@ also supported (assuming x occurs in the goal only): have {x} -> : x = y. -An other frequent use of the intro patterns combined with ``have`` is the +Another frequent use of the intro patterns combined with ``have`` is the destruction of existential assumptions like in the tactic: .. example:: @@ -2730,7 +2697,7 @@ type classes inference. Full inference for ``ty``. The first subgoal demands a proof of such instantiated statement. -+ coqtop:: ++ .. coqdoc:: have foo : ty := . @@ -2752,12 +2719,9 @@ type classes inference. No inference for ``t``. Unresolved instances are quantified in the (inferred) type of ``t`` and abstracted in ``t``. +.. opt:: SsrHave NoTCResolution -The behavior of |SSR| 1.4 and below (never resolve type classes) -can be restored with the option - -.. cmd:: Set SsrHave NoTCResolution. - + This option restores the behavior of |SSR| 1.4 and below (never resolve type classes). Variants: the suff and wlog tactics ``````````````````````````````````` @@ -2815,21 +2779,23 @@ Another useful construct is reduction, showing that a particular case is in fact general enough to prove a general property. This kind of reasoning step usually starts with: “Without loss of generality, we can suppose that …”. Formally, this corresponds to the proof of a goal -G by introducing a cut wlog_statement -> G. Hence the user shall -provide a proof for both (wlog_statement -> G) -> G and -wlog_statement -> G. However, such cuts are usually rather +``G`` by introducing a cut ``wlog_statement -> G``. Hence the user shall +provide a proof for both ``(wlog_statement -> G) -> G`` and +``wlog_statement -> G``. However, such cuts are usually rather painful to perform by -hand, because the statement wlog_statement is tedious to write by hand, +hand, because the statement ``wlog_statement`` is tedious to write by hand, and sometimes even to read. -|SSR| implements this kind of reasoning step through the without -loss tactic, whose short name is ``wlog``. It offers support to describe +|SSR| implements this kind of reasoning step through the :tacn:`without loss` +tactic, whose short name is :tacn:`wlog`. It offers support to describe the shape of the cut statements, by providing the simplifying hypothesis and by pointing at the elements of the initial goals which should be generalized. The general syntax of without loss is: .. tacn:: wlog {? suff } {? @clear_switch } {? @i_item } : {* @ident } / @term :name: wlog +.. tacv:: without loss {? suff } {? @clear_switch } {? @i_item } : {* @ident } / @term + :name: without loss where each :token:`ident` is a constant in the context of the goal. Open syntax is supported for :token:`term`. @@ -2837,16 +2803,17 @@ of the goal. Open syntax is supported for :token:`term`. In its defective form: .. tacv:: wlog: / @term +.. tacv:: without loss: / @term on a goal G, it creates two subgoals: a first one to prove the formula (term -> G) -> G and a second one to prove the formula term -> G. -If the optional list of :token:`itent` is present +If the optional list of :token:`ident` is present on the left side of ``/``, these constants are generalized in the -premise (term -> G) of the first subgoal. By default the body of local -definitions is erased. This behavior can be inhibited prefixing the +premise (term -> G) of the first subgoal. By default bodies of local +definitions are erased. This behavior can be inhibited by prefixing the name of the local definition with the ``@`` character. In the second subgoal, the tactic: @@ -2856,9 +2823,9 @@ In the second subgoal, the tactic: move=> clear_switch i_item. is performed if at least one of these optional switches is present in -the ``wlog`` tactic. +the :tacn:`wlog` tactic. -The ``wlog`` tactic is specially useful when a symmetry argument +The :tacn:`wlog` tactic is specially useful when a symmetry argument simplifies a proof. Here is an example showing the beginning of the proof that quotient and reminder of natural number euclidean division are unique. @@ -2879,9 +2846,10 @@ are unique. wlog: q1 q2 r1 r2 / q1 <= q2. by case (le_gt_dec q1 q2)=> H; last symmetry; eauto with arith. -The ``wlog suff`` variant is simpler, since it cuts wlog_statement instead -of wlog_statement -> G. It thus opens the goals wlog_statement -> G -and wlog_statement. +The ``wlog suff`` variant is simpler, since it cuts ``wlog_statement`` instead +of ``wlog_statement -> G``. It thus opens the goals +``wlog_statement -> G`` +and ``wlog_statement``. In its simplest form the ``generally have : …`` tactic is equivalent to ``wlog suff : …`` followed by last first. When the ``have`` tactic is used @@ -2920,7 +2888,7 @@ Advanced generalization The complete syntax for the items on the left hand side of the ``/`` separator is the following one: -.. tacv wlog … : {? @clear_switch | {? @ } @ident | ( {? @ } @ident := @c_pattern) } / @term +.. tacv:: wlog … : {? @clear_switch | {? @ } @ident | ( {? @ } @ident := @c_pattern) } / @term Clear operations are intertwined with generalization operations. This helps in particular avoiding dependency issues while generalizing some @@ -2936,7 +2904,7 @@ renaming does not require the original variable to be cleared. The syntax ``(@x := y)`` generates a let-in abstraction but with the following caveat: ``x`` will not bind ``y``, but its body, whenever ``y`` can be -unfolded. This cover the case of both local and global definitions, as +unfolded. This covers the case of both local and global definitions, as illustrated in the following example. .. example:: @@ -3035,7 +3003,7 @@ operation should be performed: specifies if and how the rewrite operation should be repeated. + A rewrite operation matches the occurrences of a *rewrite pattern*, - and replaces these occurrences by an other term, according to the + and replaces these occurrences by another term, according to the given :token:`r_item`. The optional *redex switch* ``[r_pattern]``, which should always be surrounded by brackets, gives explicitly this rewrite @@ -3329,7 +3297,7 @@ The rewrite tactic can be provided a *tuple* of rewrite rules, or more generally a tree of such rules, since this tuple can feature arbitrary inner parentheses. We call *multirule* such a generalized rewrite rule. This feature is of special interest when it is combined with -multiplier switches, which makes the rewrite tactic iterates the +multiplier switches, which makes the rewrite tactic iterate the rewrite operations prescribed by the rules on the current goal. @@ -3473,7 +3441,7 @@ efficient ones, e.g. for the purpose of a correctness proof. Wildcards vs abstractions ````````````````````````` -The rewrite tactic supports :token:`r_items` containing holes. For example in +The rewrite tactic supports :token:`r_items` containing holes. For example, in the tactic ``rewrite (_ : _ * 0 = 0).`` the term ``_ * 0 = 0`` is interpreted as ``forall n : nat, n * 0 = 0.`` Anyway this tactic is *not* equivalent to @@ -3730,14 +3698,15 @@ We provide a special tactic unlock for unfolding such definitions while removing “locks”, e.g., the tactic: .. tacn:: unlock {? @occ_switch } @ident + :name: unlock replaces the occurrence(s) of :token:`ident` coded by the :token:`occ_switch` with the corresponding body. We found that it was usually preferable to prevent the expansion of some functions by the partial evaluation switch ``/=``, unless this -allowed the evaluation of a condition. This is possible thanks to an -other mechanism of term tagging, resting on the following *Notation*: +allowed the evaluation of a condition. This is possible thanks to another +mechanism of term tagging, resting on the following *Notation*: .. coqtop:: in @@ -3781,7 +3750,7 @@ arithmetic operations. We define for instance: The operation ``addn`` behaves exactly like ``plus``, except that ``(addn (S n) m)`` will not simplify spontaneously to -``(S (addn n m))`` (the two terms, however, are inter-convertible). +``(S (addn n m))`` (the two terms, however, are convertible). In addition, the unfolding step: ``rewrite /addn`` will replace ``addn`` directly with ``plus``, so the ``nosimpl`` form is essentially invisible. @@ -3792,7 +3761,7 @@ essentially invisible. Congruence ~~~~~~~~~~ -Because of the way matching interferes with type families parameters, +Because of the way matching interferes with parameters of type families, the tactic: .. coqtop:: in @@ -3912,8 +3881,8 @@ The simple form of patterns used so far, terms possibly containing wild cards, often require an additional :token:`occ_switch` to be specified. While this may work pretty fine for small goals, the use of polymorphic functions and dependent types may lead to an invisible -duplication of functions arguments. These copies usually end up in -types hidden by the implicit arguments machinery or by user defined +duplication of function arguments. These copies usually end up in +types hidden by the implicit arguments machinery or by user-defined notations. In these situations computing the right occurrence numbers is very tedious because they must be counted on the goal as printed after setting the Printing All flag. Moreover the resulting script is @@ -3981,7 +3950,7 @@ pattern for the redex looking at the rule used for rewriting. The first :token:`c_pattern` is the simplest form matching any context but selecting a specific redex and has been described in the previous sections. We have seen so far that the possibility of selecting a -redex using a term with holes is already a powerful mean of redex +redex using a term with holes is already a powerful means of redex selection. Similarly, any terms provided by the user in the more complex forms of :token:`c_patterns` presented in the tables above can contain @@ -4064,7 +4033,7 @@ Contextual pattern in set and the : tactical As already mentioned in section :ref:`abbreviations_ssr` the ``set`` tactic takes as an argument a term in open syntax. This term is interpreted as the -simplest for of :token:`c_pattern`. To void confusion in the grammar, open +simplest form of :token:`c_pattern`. To avoid confusion in the grammar, open syntax is supported only for the simplest form of patterns, while parentheses are required around more complex patterns. @@ -4086,17 +4055,17 @@ parentheses are required around more complex patterns. set t := (a + _ in X in _ = X). -Since the user may define an infix notation for ``in`` the former tactic -may result ambiguous. The disambiguation rule implemented is to prefer +Since the user may define an infix notation for ``in`` the result of the former +tactic may be ambiguous. The disambiguation rule implemented is to prefer patterns over simple terms, but to interpret a pattern with double -parentheses as a simple term. For example the following tactic would +parentheses as a simple term. For example, the following tactic would capture any occurrence of the term ``a in A``. .. coqtop:: in set t := ((a in A)). -Contextual pattern can also be used as arguments of the ``:`` tactical. +Contextual patterns can also be used as arguments of the ``:`` tactical. For example: .. coqtop:: in @@ -4139,7 +4108,7 @@ Contextual patterns in rewrite Note that the right hand side of ``addn0`` is undetermined, but the rewrite pattern specifies the redex explicitly. The right hand side - of ``addn0`` is unified with the term identified by ``X``, ``0`` here. + of ``addn0`` is unified with the term identified by ``X``, here ``0``. The following pattern does not specify a redex, since it identifies an @@ -4269,7 +4238,7 @@ generation (see section :ref:`generation_of_equations_ssr`). .. example:: - The following script illustrate a toy example of this feature. Let us + The following script illustrates a toy example of this feature. Let us define a function adding an element at the end of a list: .. coqtop:: reset @@ -4283,7 +4252,7 @@ generation (see section :ref:`generation_of_equations_ssr`). .. coqtop:: all Variable d : Type. - Fixpoint add_last(s : list d) (z : d) {struct s} : list d := + Fixpoint add_last (s : list d) (z : d) {struct s} : list d := if s is cons x s' then cons x (add_last s' z) else z :: nil. One can define an alternative, reversed, induction principle on @@ -4296,7 +4265,7 @@ generation (see section :ref:`generation_of_equations_ssr`). forall s : list d, P s. Then the combination of elimination views with equation names result - in a concise syntax for reasoning inductively using the user defined + in a concise syntax for reasoning inductively using the user-defined elimination scheme. .. coqtop:: all @@ -4305,8 +4274,8 @@ generation (see section :ref:`generation_of_equations_ssr`). elim/last_ind_list E : l=> [| u v]; last first. -User provided eliminators (potentially generated with the ``Function`` -|Coq|’s command) can be combined with the type family switches described +User-provided eliminators (potentially generated with |Coq|’s ``Function`` +command) can be combined with the type family switches described in section :ref:`type_families_ssr`. Consider an eliminator ``foo_ind`` of type: @@ -4341,7 +4310,7 @@ The ``elim/`` tactic distinguishes two cases: As explained in section :ref:`type_families_ssr`, the initial prefix of ``ei`` can be omitted. -Here an example of a regular, but non trivial, eliminator. +Here is an example of a regular, but nontrivial, eliminator. .. example:: @@ -4423,7 +4392,7 @@ Here an example of a regular, but non trivial, eliminator. ``P`` should be the same as the second argument of ``plus``, in the second argument of ``P``, but ``y`` and ``z`` do no unify. -Here an example of a truncated eliminator: +Here is an example of a truncated eliminator: .. example:: @@ -4481,7 +4450,7 @@ Interpreting assumptions ~~~~~~~~~~~~~~~~~~~~~~~~ Interpreting an assumption in the context of a proof consists in -applying it a lemma before generalizing, and/or decomposing this +applying to it a lemma before generalizing, and/or decomposing this assumption. For instance, with the extensive use of boolean reflection (see section :ref:`views_and_reflection_ssr`.4), it is quite frequent to need to decompose the logical interpretation of (the boolean @@ -4681,15 +4650,17 @@ Note that the goal interpretation view mechanism supports both ``apply`` and ``exact`` tactics. As expected, a goal interpretation view command exact/term should solve the current goal or it will fail. -*Warning* Goal interpretation view tactics are *not* compatible with -the bookkeeping tactical ``=>`` since this would be redundant with the -``apply: term => _`` construction. +.. warning:: + + Goal interpretation view tactics are *not* compatible with + the bookkeeping tactical ``=>`` since this would be redundant with the + ``apply: term => _`` construction. Boolean reflection ~~~~~~~~~~~~~~~~~~ -In the Calculus of Inductive Construction, there is an obvious +In the Calculus of Inductive Constructions, there is an obvious distinction between logical propositions and boolean values. On the one hand, logical propositions are objects of *sort* ``Prop`` which is the carrier of intuitionistic reasoning. Logical connectives in @@ -5002,7 +4973,7 @@ but they also allow complex transformation, involving negations. Note that views, being part of :token:`i_pattern`, can be used to interpret assertions too. For example the following script asserts ``a && b`` but -actually used its propositional interpretation. +actually uses its propositional interpretation. .. example:: @@ -5038,7 +5009,7 @@ applied to a goal ``top`` is interpreted in the following way: Like assumption interpretation view hints, goal interpretation ones -are user defined lemmas stored (see section :ref:`views_and_reflection_ssr`) in the ``Hint View`` +are user-defined lemmas stored (see section :ref:`views_and_reflection_ssr`) in the ``Hint View`` database bridging the possible gap between the type of ``term`` and the type of the goal. @@ -5132,7 +5103,7 @@ See the files ``ssreflect.v`` and ``ssrbool.v`` for examples. Multiple views ~~~~~~~~~~~~~~ -The hypotheses and the goal can be interpreted applying multiple views +The hypotheses and the goal can be interpreted by applying multiple views in sequence. Both move and apply can be followed by an arbitrary number of ``/term``. The main difference between the following two tactics @@ -5188,8 +5159,9 @@ equivalences are indeed taken into account, otherwise only single |SSR| proposes an extension of the Search command. Its syntax is: .. cmd:: Search {? @pattern } {* {? - } %( @string %| @pattern %) {? % @ident} } {? in {+ {? - } @qualid } } + :name: Search (ssreflect) -where :token:`qualid` is the name of an open module. This command search returns +where :token:`qualid` is the name of an open module. This command returns the list of lemmas: @@ -5214,7 +5186,7 @@ Note that: + As for regular terms, patterns can feature scope indications. For instance, the command: ``Search _ (_ + _)%N.`` lists all the lemmas whose - statement (conclusion or hypotheses) involve an application of the + statement (conclusion or hypotheses) involves an application of the binary operation denoted by the infix ``+`` symbol in the ``N`` scope (which is |SSR| scope for natural numbers). + Patterns with holes should be surrounded by parentheses. @@ -5318,11 +5290,11 @@ intro item see :ref:`introduction_ssr` multiplier see :ref:`iteration_ssr` -.. prodn:: occ_switch ::= { {? + %| - } {* @natural } } +.. prodn:: occ_switch ::= { {? + %| - } {* @num } } occur. switch see :ref:`occurrence_selection_ssr` -.. prodn:: mult ::= {? @natural } @mult_mark +.. prodn:: mult ::= {? @num } @mult_mark multiplier see :ref:`iteration_ssr` @@ -5386,6 +5358,8 @@ rewrite see :ref:`rewriting_ssr` .. tacn:: have suff {? @clear_switch } {? @i_pattern } {? : @term } := @term .. tacv:: have suff {? @clear_switch } {? @i_pattern } : @term {? by @tactic } .. tacv:: gen have {? @ident , } {? @i_pattern } : {+ @gen_item } / @term {? by @tactic } +.. tacv:: generally have {? @ident , } {? @i_pattern } : {+ @gen_item } / @term {? by @tactic } + :name: generally have forward chaining see :ref:`structure_ssr` @@ -5395,7 +5369,11 @@ forward chaining see :ref:`structure_ssr` specializing see :ref:`structure_ssr` .. tacn:: suff {* @i_item } {? @i_pattern } {+ @binder } : @term {? by @tactic } + :name: suff +.. tacv:: suffices {* @i_item } {? @i_pattern } {+ @binder } : @term {? by @tactic } + :name: suffices .. tacv:: suff {? have } {? @clear_switch } {? @i_pattern } : @term {? by @tactic } +.. tacv:: suffices {? have } {? @clear_switch } {? @i_pattern } : @term {? by @tactic } backchaining see :ref:`structure_ssr` @@ -5491,7 +5469,7 @@ prenex implicits declaration see :ref:`parametric_polymorphism_ssr` used for such generated names. .. [#7] More precisely, it should have a quantified inductive type with a assumptions and m − a constructors. -.. [#8] This is an implementation feature: there is not such obstruction +.. [#8] This is an implementation feature: there is no such obstruction in the metatheory .. [#9] The current state of the proof shall be displayed by the Show Proof command of |Coq| proof mode. diff --git a/doc/sphinx/proof-engine/tactics.rst b/doc/sphinx/proof-engine/tactics.rst index da34e3b55..29c2f8b81 100644 --- a/doc/sphinx/proof-engine/tactics.rst +++ b/doc/sphinx/proof-engine/tactics.rst @@ -24,7 +24,7 @@ Each (sub)goal is denoted with a number. The current goal is numbered 1. By default, a tactic is applied to the current goal, but one can address a particular goal in the list by writing n:tactic which means “apply tactic tactic to goal number n”. We can show the list of -subgoals by typing Show (see Section :ref:`TODO-7.3.1-Show`). +subgoals by typing Show (see Section :ref:`requestinginformation`). Since not every rule applies to a given statement, every tactic cannot be used to reduce any goal. In other words, before applying a tactic @@ -34,15 +34,16 @@ satisfied. If it is not the case, the tactic raises an error message. Tactics are built from atomic tactics and tactic expressions (which extends the folklore notion of tactical) to combine those atomic tactics. This chapter is devoted to atomic tactics. The tactic -language will be described in Chapter :ref:`TODO-9-Thetacticlanguage`. +language will be described in Chapter :ref:`ltac`. + +.. _invocation-of-tactics: Invocation of tactics ------------------------- A tactic is applied as an ordinary command. It may be preceded by a -goal selector (see Section :ref:`TODO-9.2-Semantics`). If no selector is -specified, the default selector (see Section -:ref:`TODO-8.1.1-Setdefaultgoalselector`) is used. +goal selector (see Section :ref:`ltac-semantics`). If no selector is +specified, the default selector is used. .. _tactic_invocation_grammar: @@ -50,20 +51,22 @@ specified, the default selector (see Section tactic_invocation : toplevel_selector : tactic. : |tactic . -.. cmd:: Set Default Goal Selector @toplevel_selector. +.. opt:: Default Goal Selector @toplevel_selector + + This option controls the default selector, used when no selector is + specified when applying a tactic. The initial value is 1, hence the + tactics are, by default, applied to the first goal. -After using this command, the default selector – used when no selector -is specified when applying a tactic – is set to the chosen value. The -initial value is 1, hence the tactics are, by default, applied to the -first goal. Using Set Default Goal Selector ‘‘all’’ will make is so -that tactics are, by default, applied to every goal simultaneously. -Then, to apply a tactic tac to the first goal only, you can write -1:tac. Although more selectors are available, only ‘‘all’’ or a single -natural number are valid default goal selectors. + Using value ``all`` will make it so that tactics are, by default, + applied to every goal simultaneously. Then, to apply a tactic tac + to the first goal only, you can write ``1:tac``. -.. cmd:: Test Default Goal Selector. + Using value ``!`` enforces that all tactics are used either on a + single focused goal or with a local selector (’’strict focusing + mode’’). -This command displays the current default selector. + Although more selectors are available, only ``all``, ``!`` or a + single natural number are valid default goal selectors. .. _bindingslist: @@ -89,14 +92,14 @@ bindings_list`` where ``bindings_list`` may be of two different forms: the ``n``-th non dependent premise of the ``term``, as determined by the type of ``term``. - .. exn:: No such binder + .. exn:: No such binder. + A bindings list can also be a simple list of terms :n:`{* term}`. In that case the references to which these terms correspond are - determined by the tactic. In case of ``induction``, ``destruct``, ``elim`` - and ``case`` (see :ref:`TODO-9-Thetacticlanguage`) the terms have to + determined by the tactic. In case of :tacn:`induction`, :tacn:`destruct`, :tacn:`elim` + and :tacn:`case`, the terms have to provide instances for all the dependent products in the type of term while in - the case of ``apply``, or of ``constructor`` and its variants, only instances + the case of :tacn:`apply`, or of :tacn:`constructor` and its variants, only instances for the dependent products that are not bound in the conclusion of the type are required. @@ -122,14 +125,12 @@ following syntax: The role of an occurrence clause is to select a set of occurrences of a term in a goal. In the first case, the :n:`@ident {? at {* num}}` parts indicate that -occurrences have to be selected in the hypotheses named :n:`@ident`. If no numbers -are given for hypothesis :n:`@ident`, then all the occurrences of `term` in the -hypothesis are selected. If numbers are given, they refer to occurrences of -`term` when the term is printed using option ``Set Printing All`` (see -:ref:`TODO-2.9-Printingconstructionsinfull`), counting from left to right. In -particular, occurrences of `term` in implicit arguments (see -:ref:`TODO-2.7-Implicitarguments`) or coercions (see :ref:`TODO-2.8-Coercions`) -are counted. +occurrences have to be selected in the hypotheses named :n:`@ident`. If no +numbers are given for hypothesis :n:`@ident`, then all the occurrences of `term` +in the hypothesis are selected. If numbers are given, they refer to occurrences +of `term` when the term is printed using option :opt:`Printing All`, counting +from left to right. In particular, occurrences of `term` in implicit arguments +(see :ref:`ImplicitArguments`) or coercions (see :ref:`Coercions`) are counted. If a minus sign is given between at and the list of occurrences, it negates the condition so that the clause denotes all the occurrences @@ -150,14 +151,15 @@ no numbers are given, all occurrences of :n:`@term` in the goal are selected. Finally, the last notation is an abbreviation for ``* |- *``. Note also that ``|-`` is optional in the first case when no ``*`` is given. -Here are some tactics that understand occurrences clauses: ``set``, ``remember`` -, ``induction``, ``destruct``. +Here are some tactics that understand occurrences clauses: :tacn:`set`, :tacn:`remember` +, :tacn:`induction`, :tacn:`destruct`. -See also: :ref:`TODO-8.3.7-Managingthelocalcontext`, -:ref:`TODO-8.5.2-Caseanalysisandinduction`, -:ref:`TODO-2.9-Printingconstructionsinfull`. +See also: :ref:`Managingthelocalcontext`, +:ref:`caseanalysisandinduction`, +:ref:`printing_constructions_full`. +.. _applyingtheorems: Applying theorems --------------------- @@ -165,195 +167,203 @@ Applying theorems .. tacn:: exact @term :name: exact -This tactic applies to any goal. It gives directly the exact proof -term of the goal. Let ``T`` be our goal, let ``p`` be a term of type ``U`` then -``exact p`` succeeds iff ``T`` and ``U`` are convertible (see -:ref:`TODO-4.3-Conversionrules`). + This tactic applies to any goal. It gives directly the exact proof + term of the goal. Let ``T`` be our goal, let ``p`` be a term of type ``U`` then + ``exact p`` succeeds iff ``T`` and ``U`` are convertible (see + :ref:`Conversion-rules`). -.. exn:: Not an exact proof. + .. exn:: Not an exact proof. -.. tacv:: eexact @term. + .. tacv:: eexact @term. + :name: eexact -This tactic behaves like exact but is able to handle terms and goals with -meta-variables. + This tactic behaves like exact but is able to handle terms and goals with + meta-variables. .. tacn:: assumption :name: assumption -This tactic looks in the local context for an hypothesis which type is equal to -the goal. If it is the case, the subgoal is proved. Otherwise, it fails. + This tactic looks in the local context for an hypothesis which type is equal to + the goal. If it is the case, the subgoal is proved. Otherwise, it fails. -.. exn:: No such assumption. + .. exn:: No such assumption. -.. tacv:: eassumption + .. tacv:: eassumption + :name: eassumption -This tactic behaves like assumption but is able to handle goals with -meta-variables. + This tactic behaves like assumption but is able to handle goals with + meta-variables. .. tacn:: refine @term :name: refine -This tactic applies to any goal. It behaves like exact with a big -difference: the user can leave some holes (denoted by ``_`` or``(_:type)``) in -the term. refine will generate as many subgoals as there are holes in -the term. The type of holes must be either synthesized by the system -or declared by an explicit cast like ``(_:nat->Prop)``. Any subgoal that -occurs in other subgoals is automatically shelved, as if calling -shelve_unifiable (see Section 8.17.4). This low-level tactic can be -useful to advanced users. + This tactic applies to any goal. It behaves like :tacn:`exact` with a big + difference: the user can leave some holes (denoted by ``_`` or ``(_:type)``) in + the term. :tacn:`refine` will generate as many subgoals as there are holes in + the term. The type of holes must be either synthesized by the system + or declared by an explicit cast like ``(_:nat->Prop)``. Any subgoal that + occurs in other subgoals is automatically shelved, as if calling + :tacn:`shelve_unifiable`. This low-level tactic can be + useful to advanced users. -.. example:: - .. coqtop:: reset all + .. example:: + .. coqtop:: reset all - Inductive Option : Set := - | Fail : Option - | Ok : bool -> Option. + Inductive Option : Set := + | Fail : Option + | Ok : bool -> Option. - Definition get : forall x:Option, x <> Fail -> bool. + Definition get : forall x:Option, x <> Fail -> bool. - refine - (fun x:Option => - match x return x <> Fail -> bool with - | Fail => _ - | Ok b => fun _ => b - end). + refine + (fun x:Option => + match x return x <> Fail -> bool with + | Fail => _ + | Ok b => fun _ => b + end). - intros; absurd (Fail = Fail); trivial. + intros; absurd (Fail = Fail); trivial. - Defined. + Defined. -.. exn:: invalid argument + .. exn:: Invalid argument. - The tactic ``refine`` does not know what to do with the term you gave. + The tactic :tacn:`refine` does not know what to do with the term you gave. -.. exn:: Refine passed ill-formed term + .. exn:: Refine passed ill-formed term. - The term you gave is not a valid proof (not easy to debug in general). This - message may also occur in higher-level tactics that call ``refine`` - internally. + The term you gave is not a valid proof (not easy to debug in general). This + message may also occur in higher-level tactics that call :tacn:`refine` + internally. -.. exn:: Cannot infer a term for this placeholder + .. exn:: Cannot infer a term for this placeholder. + :name: Cannot infer a term for this placeholder. (refine) - There is a hole in the term you gave which type cannot be inferred. Put a - cast around it. + There is a hole in the term you gave whose type cannot be inferred. Put a + cast around it. -.. tacv:: simple refine @term + .. tacv:: simple refine @term + :name: simple refine - This tactic behaves like refine, but it does not shelve any subgoal. It does - not perform any beta-reduction either. + This tactic behaves like refine, but it does not shelve any subgoal. It does + not perform any beta-reduction either. -.. tacv:: notypeclasses refine @term + .. tacv:: notypeclasses refine @term + :name: notypeclasses refine - This tactic behaves like ``refine`` except it performs typechecking without - resolution of typeclasses. + This tactic behaves like :tacn:`refine` except it performs typechecking without + resolution of typeclasses. -.. tacv:: simple notypeclasses refine @term + .. tacv:: simple notypeclasses refine @term + :name: simple notypeclasses refine - This tactic behaves like ``simple refine`` except it performs typechecking - without resolution of typeclasses. + This tactic behaves like :tacn:`simple refine` except it performs typechecking + without resolution of typeclasses. -.. tacv:: apply @term +.. tacn:: apply @term :name: apply -This tactic applies to any goal. The argument term is a term well-formed in the -local context. The tactic apply tries to match the current goal against the -conclusion of the type of term. If it succeeds, then the tactic returns as many -subgoals as the number of non-dependent premises of the type of term. If the -conclusion of the type of term does not match the goal *and* the conclusion is -an inductive type isomorphic to a tuple type, then each component of the tuple -is recursively matched to the goal in the left-to-right order. + This tactic applies to any goal. The argument term is a term well-formed in the + local context. The tactic apply tries to match the current goal against the + conclusion of the type of term. If it succeeds, then the tactic returns as many + subgoals as the number of non-dependent premises of the type of term. If the + conclusion of the type of term does not match the goal *and* the conclusion is + an inductive type isomorphic to a tuple type, then each component of the tuple + is recursively matched to the goal in the left-to-right order. -The tactic ``apply`` relies on first-order unification with dependent types -unless the conclusion of the type of ``term`` is of the form :g:`P (t`:sub:`1` -:g:`...` :g:`t`:sub:`n` :g:`)` with `P` to be instantiated. In the latter case, the behavior -depends on the form of the goal. If the goal is of the form -:g:`(fun x => Q) u`:sub:`1` :g:`...` :g:`u`:sub:`n` and the :g:`t`:sub:`i` and -:g:`u`:sub:`i` unifies, then :g:`P` is taken to be :g:`(fun x => Q)`. Otherwise, -``apply`` tries to define :g:`P` by abstracting over :g:`t`:sub:`1` :g:`...` -:g:`t`:sub:`n` in the goal. See :tacn:`pattern` to transform the goal so that it -gets the form :g:`(fun x => Q) u`:sub:`1` :g:`...` :g:`u`:sub:`n`. + The tactic :tacn:`apply` relies on first-order unification with dependent types + unless the conclusion of the type of :token:`term` is of the form :g:`P (t`:sub:`1` + :g:`...` :g:`t`:sub:`n` :g:`)` with `P` to be instantiated. In the latter case, the behavior + depends on the form of the goal. If the goal is of the form + :g:`(fun x => Q) u`:sub:`1` :g:`...` :g:`u`:sub:`n` and the :g:`t`:sub:`i` and + :g:`u`:sub:`i` unifies, then :g:`P` is taken to be :g:`(fun x => Q)`. Otherwise, + :tacn:`apply` tries to define :g:`P` by abstracting over :g:`t`:sub:`1` :g:`...` + :g:`t`:sub:`n` in the goal. See :tacn:`pattern` to transform the goal so that it + gets the form :g:`(fun x => Q) u`:sub:`1` :g:`...` :g:`u`:sub:`n`. -.. exn:: Unable to unify ... with ... . + .. exn:: Unable to unify ... with ... . -The apply tactic failed to match the conclusion of term and the current goal. -You can help the apply tactic by transforming your goal with the -:ref:`change <change_term>` or :tacn:`pattern` tactics. + The apply tactic failed to match the conclusion of :token:`term` and the + current goal. You can help the apply tactic by transforming your goal with + the :tacn:`change` or :tacn:`pattern` tactics. -.. exn:: Unable to find an instance for the variables {+ @ident}. + .. exn:: Unable to find an instance for the variables {+ @ident}. -This occurs when some instantiations of the premises of term are not deducible -from the unification. This is the case, for instance, when you want to apply a -transitivity property. In this case, you have to use one of the variants below: + This occurs when some instantiations of the premises of :token:`term` are not deducible + from the unification. This is the case, for instance, when you want to apply a + transitivity property. In this case, you have to use one of the variants below: -.. cmd:: apply @term with {+ @term} + .. tacv:: apply @term with {+ @term} -Provides apply with explicit instantiations for all dependent premises of the -type of term that do not occur in the conclusion and consequently cannot be -found by unification. Notice that the collection :n:`{+ @term}` must be given -according to the order of these dependent premises of the type of term. + Provides apply with explicit instantiations for all dependent premises of the + type of term that do not occur in the conclusion and consequently cannot be + found by unification. Notice that the collection :n:`{+ @term}` must be given + according to the order of these dependent premises of the type of term. -.. exn:: Not the right number of missing arguments. + .. exn:: Not the right number of missing arguments. -.. tacv:: apply @term with @bindings_list + .. tacv:: apply @term with @bindings_list -This also provides apply with values for instantiating premises. Here, variables -are referred by names and non-dependent products by increasing numbers (see -:ref:`bindings list <bindingslist>`). + This also provides apply with values for instantiating premises. Here, variables + are referred by names and non-dependent products by increasing numbers (see + :ref:`bindings list <bindingslist>`). -.. tacv:: apply {+, @term} + .. tacv:: apply {+, @term} -This is a shortcut for ``apply term``:sub:`1` -``; [.. | ... ; [ .. | apply`` ``term``:sub:`n` ``] ... ]``, -i.e. for the successive applications of ``term``:sub:`i+1` on the last subgoal -generated by ``apply term``:sub:`i` , starting from the application of -``term``:sub:`1`. + This is a shortcut for :n:`apply @term`:sub:`1` + :n:`; [.. | ... ; [ .. | apply @term`:sub:`n` :n:`] ... ]`, + i.e. for the successive applications of :token:`term`:sub:`i+1` on the last subgoal + generated by :n:`apply @term`:sub:`i` , starting from the application of + :token:`term`:sub:`1`. -.. tacv:: eapply @term - :name: eapply + .. tacv:: eapply @term + :name: eapply -The tactic ``eapply`` behaves like ``apply`` but it does not fail when no -instantiations are deducible for some variables in the premises. Rather, it -turns these variables into existential variables which are variables still to -instantiate (see :ref:`TODO-2.11-ExistentialVariables`). The instantiation is -intended to be found later in the proof. + The tactic :tacn:`eapply` behaves like :tacn:`apply` but it does not fail when no + instantiations are deducible for some variables in the premises. Rather, it + turns these variables into existential variables which are variables still to + instantiate (see :ref:`Existential-Variables`). The instantiation is + intended to be found later in the proof. -.. tacv:: simple apply @term. + .. tacv:: simple apply @term. + :name: simple apply -This behaves like ``apply`` but it reasons modulo conversion only on subterms -that contain no variables to instantiate. For instance, the following example -does not succeed because it would require the conversion of ``id ?foo`` and -``O``. + This behaves like :tacn:`apply` but it reasons modulo conversion only on subterms + that contain no variables to instantiate. For instance, the following example + does not succeed because it would require the conversion of ``id ?foo`` and + :g:`O`. -.. example:: + .. example:: - .. coqtop:: all + .. coqtop:: all - Definition id (x : nat) := x. - Hypothesis H : forall y, id y = y. - Goal O = O. - Fail simple apply H. + Definition id (x : nat) := x. + Parameter H : forall y, id y = y. + Goal O = O. + Fail simple apply H. -Because it reasons modulo a limited amount of conversion, ``simple apply`` fails -quicker than ``apply`` and it is then well-suited for uses in user-defined -tactics that backtrack often. Moreover, it does not traverse tuples as ``apply`` -does. + Because it reasons modulo a limited amount of conversion, :tacn:`simple apply` fails + quicker than :tacn:`apply` and it is then well-suited for uses in user-defined + tactics that backtrack often. Moreover, it does not traverse tuples as :tacn:`apply` + does. -.. tacv:: {? simple} apply {+, @term {? with @bindings_list}} -.. tacv:: {? simple} eapply {+, @term {? with @bindings_list}} + .. tacv:: {? simple} apply {+, @term {? with @bindings_list}} + .. tacv:: {? simple} eapply {+, @term {? with @bindings_list}} + :name: simple eapply -This summarizes the different syntaxes for ``apply`` and ``eapply``. + This summarizes the different syntaxes for :tacn:`apply` and :tacn:`eapply`. -.. tacv:: lapply @term - :name: `lapply + .. tacv:: lapply @term + :name: lapply -This tactic applies to any goal, say :g:`G`. The argument term has to be -well-formed in the current context, its type being reducible to a non-dependent -product :g:`A -> B` with :g:`B` possibly containing products. Then it generates -two subgoals :g:`B->G` and :g:`A`. Applying ``lapply H`` (where :g:`H` has type -:g:`A->B` and :g:`B` does not start with a product) does the same as giving the -sequence ``cut B. 2:apply H.`` where ``cut`` is described below. + This tactic applies to any goal, say :g:`G`. The argument term has to be + well-formed in the current context, its type being reducible to a non-dependent + product :g:`A -> B` with :g:`B` possibly containing products. Then it generates + two subgoals :g:`B->G` and :g:`A`. Applying ``lapply H`` (where :g:`H` has type + :g:`A->B` and :g:`B` does not start with a product) does the same as giving the + sequence ``cut B. 2:apply H.`` where ``cut`` is described below. -.. warn:: When @term contains more than one non dependent product the tactic lapply only takes into account the first product. + .. warn:: When @term contains more than one non dependent product the tactic lapply only takes into account the first product. .. example:: Assume we have a transitive relation ``R`` on ``nat``: @@ -435,7 +445,7 @@ sequence ``cut B. 2:apply H.`` where ``cut`` is described below. ``forall A, ... -> A``. Excluding this kind of lemma can be avoided by setting the following option: -.. opt:: Set Universal Lemma Under Conjunction. +.. opt:: Universal Lemma Under Conjunction This option, which preserves compatibility with versions of Coq prior to 8.4 is also available for :n:`apply @term in @ident` (see :tacn:`apply ... in`). @@ -493,7 +503,7 @@ sequence ``cut B. 2:apply H.`` where ``cut`` is described below. .. tacv:: eapply {+, @term with @bindings_list} in @ident as @intro_pattern. - This works as :tacn:`apply ... in as` but using ``eapply``. + This works as :tacn:`apply ... in ... as` but using ``eapply``. .. tacv:: simple apply @term in @ident @@ -501,15 +511,15 @@ sequence ``cut B. 2:apply H.`` where ``cut`` is described below. on subterms that contain no variables to instantiate. For instance, if :g:`id := fun x:nat => x` and :g:`H: forall y, id y = y -> True` and :g:`H0 : O = O` then ``simple apply H in H0`` does not succeed because it - would require the conversion of :g:`id ?1234` and :g:`O` where :g:`?1234` is - a variable to instantiate. Tactic :n:`simple apply @term in @ident` does not + would require the conversion of :g:`id ?x` and :g:`O` where :g:`?x` is + an existential variable to instantiate. Tactic :n:`simple apply @term in @ident` does not either traverse tuples as :n:`apply @term in @ident` does. .. tacv:: {? simple} apply {+, @term {? with @bindings_list}} in @ident {? as @intro_pattern} .. tacv:: {? simple} eapply {+, @term {? with @bindings_list}} in @ident {? as @intro_pattern} - This summarizes the different syntactic variants of :n:`apply @term in - @ident` and :n:`eapply @term in @ident`. + This summarizes the different syntactic variants of :n:`apply @term in @ident` + and :n:`eapply @term in @ident`. .. tacn:: constructor @num :name: constructor @@ -539,14 +549,16 @@ sequence ``cut B. 2:apply H.`` where ``cut`` is described below. The terms in the @bindings_list are checked in the context where constructor is executed and not in the context where @apply is executed (the introductions are not taken into account). .. tacv:: split + :name: split This applies only if :g:`I` has a single constructor. It is then equivalent to :n:`constructor 1.`. It is typically used in the case of a conjunction :g:`A` :math:`\wedge` :g:`B`. -.. exn:: Not an inductive goal with 1 constructor. +.. exn:: Not an inductive goal with 1 constructor .. tacv:: exists @val + :name: exists This applies only if :g:`I` has a single constructor. It is then equivalent to :n:`intros; constructor 1 with @bindings_list.` It is typically used in @@ -559,7 +571,10 @@ sequence ``cut B. 2:apply H.`` where ``cut`` is described below. This iteratively applies :n:`exists @bindings_list`. .. tacv:: left + :name: left + .. tacv:: right + :name: right These tactics apply only if :g:`I` has two constructors, for instance in the case of a disjunction :g:`A` :math:`\vee` :g:`B`. @@ -577,15 +592,25 @@ sequence ``cut B. 2:apply H.`` where ``cut`` is described below. for the appropriate ``i``. .. tacv:: econstructor + :name: econstructor + .. tacv:: eexists + :name: eexists + .. tacv:: esplit + :name: esplit + .. tacv:: eleft + :name: eleft + .. tacv:: eright + :name: eright - These tactics and their variants behave like ``constructor``, ``exists``, - ``split``, ``left``, ``right`` and their variants but they introduce - existential variables instead of failing when the instantiation of a - variable cannot be found (cf. :tacn:`eapply` and :tacn:`apply`). + These tactics and their variants behave like :tacn:`constructor`, + :tacn:`exists`, :tacn:`split`, :tacn:`left`, :tacn:`right` and their variants + but they introduce existential variables instead of failing when the + instantiation of a variable cannot be found (cf. :tacn:`eapply` and + :tacn:`apply`). .. _managingthelocalcontext: @@ -598,48 +623,53 @@ Managing the local context This tactic applies to a goal that is either a product or starts with a let binder. If the goal is a product, the tactic implements the "Lam" rule given in -:ref:`TODO-4.2-Typing-rules` [1]_. If the goal starts with a let binder, then the +:ref:`Typing-rules` [1]_. If the goal starts with a let binder, then the tactic implements a mix of the "Let" and "Conv". -If the current goal is a dependent product :math:`\forall` :g:`x:T, U` (resp +If the current goal is a dependent product :g:`forall x:T, U` (resp :g:`let x:=t in U`) then ``intro`` puts :g:`x:T` (resp :g:`x:=t`) in the local context. The new subgoal is :g:`U`. If the goal is a non-dependent product :g:`T`:math:`\rightarrow`:g:`U`, then it puts in the local context either :g:`Hn:T` (if :g:`T` is of type :g:`Set` or -:g:`Prop`) or Xn:T (if the type of :g:`T` is :g:`Type`). The optional index +:g:`Prop`) or :g:`Xn:T` (if the type of :g:`T` is :g:`Type`). The optional index ``n`` is such that ``Hn`` or ``Xn`` is a fresh identifier. In both cases, the new subgoal is :g:`U`. -If the goal is neither a product nor starting with a let definition, +If the goal is an existential variable, ``intro`` forces the resolution of the +existential variable into a dependent product :math:`forall`:g:`x:?X, ?Y`, puts +:g:`x:?X` in the local context and leaves :g:`?Y` as a new subgoal allowed to +depend on :g:`x`. + the tactic ``intro`` applies the tactic ``hnf`` until the tactic ``intro`` can be applied or the goal is not head-reducible. .. exn:: No product even after head-reduction. -.. exn:: ident is already used. +.. exn:: @ident is already used. .. tacv:: intros + :name: intros This repeats ``intro`` until it meets the head-constant. It never reduces head-constants and it never fails. -.. tac:: intro @ident +.. tacn:: intro @ident This applies ``intro`` but forces :n:`@ident` to be the name of the introduced hypothesis. -.. exn:: name @ident is already used +.. exn:: Name @ident is already used. .. note:: If a name used by intro hides the base name of a global constant then the latter can still be referred to by a qualified name - (see :ref:`TODO-2.6.2-Qualified-names`). + (see :ref:`Qualified-names`). .. tacv:: intros {+ @ident}. This is equivalent to the composed tactic :n:`intro @ident; ... ; intro @ident`. More generally, the ``intros`` tactic takes a pattern as argument in order to introduce names for components of an inductive definition or to clear introduced hypotheses. This is - explained in :ref:`TODO-8.3.2`. + explained in :ref:`Managingthelocalcontext`. .. tacv:: intros until @ident @@ -647,7 +677,7 @@ be applied or the goal is not head-reducible. `(@ident:term)` and discharges the variable named `ident` of the current goal. -.. exn:: No such hypothesis in current goal +.. exn:: No such hypothesis in current goal. .. tacv:: intros until @num @@ -676,7 +706,7 @@ be applied or the goal is not head-reducible. too so as to respect the order of dependencies between hypotheses. Note that :n:`intro at bottom` is a synonym for :n:`intro` with no argument. -.. exn:: No such hypothesis : @ident. +.. exn:: No such hypothesis: @ident. .. tacv:: intro @ident after @ident .. tacv:: intro @ident before @ident @@ -685,7 +715,7 @@ be applied or the goal is not head-reducible. These tactics behave as previously but naming the introduced hypothesis :n:`@ident`. It is equivalent to :n:`intro @ident` followed by the - appropriate call to move (see :tacn:`move ... after`). + appropriate call to ``move`` (see :tacn:`move ... after ...`). .. tacn:: intros @intro_pattern_list :name: intros ... @@ -730,7 +760,7 @@ be applied or the goal is not head-reducible. Assuming a goal of type :g:`Q → P` (non-dependent product), or of type - :math:`\forall`:g:`x:T, P` (dependent product), the behavior of + :g:`forall x:T, P` (dependent product), the behavior of :n:`intros p` is defined inductively over the structure of the introduction pattern :n:`p`: @@ -827,15 +857,10 @@ quantification or an implication. so that all the arguments of the i-th constructors of the corresponding inductive type are introduced can be controlled with the following option: - .. cmd:: Set Bracketing Last Introduction Pattern. - - Force completion, if needed, when the last introduction pattern is a - disjunctive or conjunctive pattern (this is the default). + .. opt:: Bracketing Last Introduction Pattern - .. cmd:: Unset Bracketing Last Introduction Pattern. - - Deactivate completion when the last introduction pattern is a disjunctive or - conjunctive pattern. + Force completion, if needed, when the last introduction pattern is a + disjunctive or conjunctive pattern (on by default). .. tacn:: clear @ident :name: clear @@ -854,13 +879,6 @@ quantification or an implication. This is equivalent to :n:`clear @ident. ... clear @ident.` -.. tacv:: clearbody @ident - - This tactic expects :n:`@ident` to be a local definition then clears its - body. Otherwise said, this tactic turns a definition into an assumption. - -.. exn:: @ident is not a local definition - .. tacv:: clear - {+ @ident} This tactic clears all the hypotheses except the ones depending in the @@ -875,24 +893,33 @@ quantification or an implication. This clears the hypothesis :n:`@ident` and all the hypotheses that depend on it. +.. tacv:: clearbody {+ @ident} + :name: clearbody + + This tactic expects :n:`{+ @ident}` to be local definitions and clears their + respective bodies. + In other words, it turns the given definitions into assumptions. + +.. exn:: @ident is not a local definition. + .. tacn:: revert {+ @ident} - :name: revert ... + :name: revert -This applies to any goal with variables :n:`{+ @ident}`. It moves the hypotheses -(possibly defined) to the goal, if this respects dependencies. This tactic is -the inverse of :tacn:`intro`. + This applies to any goal with variables :n:`{+ @ident}`. It moves the hypotheses + (possibly defined) to the goal, if this respects dependencies. This tactic is + the inverse of :tacn:`intro`. .. exn:: No such hypothesis. .. exn:: @ident is used in the hypothesis @ident. -.. tac:: revert dependent @ident +.. tacn:: revert dependent @ident This moves to the goal the hypothesis :n:`@ident` and all the hypotheses that depend on it. .. tacn:: move @ident after @ident - :name: move .. after ... + :name: move ... after ... This moves the hypothesis named :n:`@ident` in the local context after the hypothesis named :n:`@ident`, where “after” is in reference to the @@ -926,9 +953,9 @@ the inverse of :tacn:`intro`. This moves ident at the bottom of the local context (at the end of the context). -.. exn:: No such hypothesis -.. exn:: Cannot move @ident after @ident : it occurs in the type of @ident -.. exn:: Cannot move @ident after @ident : it depends on @ident +.. exn:: No such hypothesis. +.. exn:: Cannot move @ident after @ident : it occurs in the type of @ident. +.. exn:: Cannot move @ident after @ident : it depends on @ident. .. example:: .. coqtop:: all @@ -944,7 +971,7 @@ the inverse of :tacn:`intro`. move H0 before H. .. tacn:: rename @ident into @ident - :name: rename ... into ... + :name: rename This renames hypothesis :n:`@ident` into :n:`@ident` in the current context. The name of the hypothesis in the proof-term, however, is left unchanged. @@ -955,8 +982,8 @@ The name of the hypothesis in the proof-term, however, is left unchanged. particular, the target identifiers may contain identifiers that exist in the source context, as long as the latter are also renamed by the same tactic. -.. exn:: No such hypothesis -.. exn:: @ident is already used +.. exn:: No such hypothesis. +.. exn:: @ident is already used. .. tacn:: set (@ident := @term) :name: set @@ -968,7 +995,7 @@ The name of the hypothesis in the proof-term, however, is left unchanged. first checks that all subterms matching the pattern are compatible before doing the replacement using the leftmost subterm matching the pattern. -.. exn:: The variable @ident is already defined +.. exn:: The variable @ident is already defined. .. tacv:: set (@ident := @term ) in @goal_occurrences @@ -992,6 +1019,7 @@ The name of the hypothesis in the proof-term, however, is left unchanged. .. tacv:: eset (@ident {+ @binder} := @term ) in @goal_occurrences .. tacv:: eset @term in @goal_occurrences + :name: eset While the different variants of :tacn:`set` expect that no existential variables are generated by the tactic, :n:`eset` removes this constraint. In @@ -999,6 +1027,7 @@ The name of the hypothesis in the proof-term, however, is left unchanged. :tacn:`epose`, i.e. when the :`@term` does not occur in the goal. .. tacv:: remember @term as @ident + :name: remember This behaves as :n:`set (@ident:= @term ) in *` and using a logical (Leibniz’s) equality instead of a local definition. @@ -1016,6 +1045,8 @@ The name of the hypothesis in the proof-term, however, is left unchanged. .. tacv:: eremember @term as @ident .. tacv:: eremember @term as @ident in @goal_occurrences .. tacv:: eremember @term as @ident eqn:@ident + :name: eremember + While the different variants of :n:`remember` expect that no existential variables are generated by the tactic, :n:`eremember` removes this constraint. @@ -1067,7 +1098,7 @@ The name of the hypothesis in the proof-term, however, is left unchanged. This decomposes record types (inductive types with one constructor, like "and" and "exists" and those defined with the Record macro, see - :ref:`TODO-2.1`). + :ref:`record-types`). .. _controllingtheproofflow: @@ -1082,24 +1113,25 @@ Controlling the proof flow :g:`U` [2]_. The subgoal :g:`U` comes first in the list of subgoals remaining to prove. -.. exn:: Not a proposition or a type +.. exn:: Not a proposition or a type. Arises when the argument form is neither of type :g:`Prop`, :g:`Set` nor :g:`Type`. .. tacv:: assert form - This behaves as :n:`assert (@ident : form ) but :n:`@ident` is generated by + This behaves as :n:`assert (@ident : form)` but :n:`@ident` is generated by Coq. -.. tacv:: assert form by tactic +.. tacv:: assert @form by @tactic This tactic behaves like :n:`assert` but applies tactic to solve the subgoals generated by assert. - .. exn:: Proof is not complete + .. exn:: Proof is not complete. + :name: Proof is not complete. (assert) -.. tacv:: assert form as intro_pattern +.. tacv:: assert @form as @intro_pattern If :n:`intro_pattern` is a naming introduction pattern (see :tacn:`intro`), the hypothesis is named after this introduction pattern (in particular, if @@ -1108,7 +1140,7 @@ Controlling the proof flow introduction pattern, the tactic behaves like :n:`assert form` followed by the action done by this introduction pattern. -.. tacv:: assert form as intro_pattern by tactic +.. tacv:: assert @form as @intro_pattern by @tactic This combines the two previous variants of :n:`assert`. @@ -1118,9 +1150,10 @@ Controlling the proof flow the type of :g:`term`. This is deprecated in favor of :n:`pose proof`. If the head of term is :n:`@ident`, the tactic behaves as :n:`specialize @term`. - .. exn:: Variable @ident is already declared + .. exn:: Variable @ident is already declared. .. tacv:: eassert form as intro_pattern by tactic + :name: eassert .. tacv:: assert (@ident := @term) @@ -1130,6 +1163,7 @@ Controlling the proof flow to prove it. .. tacv:: pose proof @term {? as intro_pattern} + :name: pose proof This tactic behaves like :n:`assert T {? as intro_pattern} by exact @term` where :g:`T` is the type of :g:`term`. In particular, @@ -1143,6 +1177,7 @@ Controlling the proof flow the tactic, :n:`epose proof` removes this constraint. .. tacv:: enough (@ident : form) + :name: enough This adds a new hypothesis of name :n:`@ident` asserting :n:`form` to the goal the tactic :n:`enough` is applied to. A new subgoal stating :n:`form` is @@ -1158,9 +1193,9 @@ Controlling the proof flow This behaves like :n:`enough form` using :n:`intro_pattern` to name or destruct the new hypothesis. -.. tacv:: enough (@ident : form) by tactic -.. tacv:: enough form by tactic -.. tacv:: enough form as intro_pattern by tactic +.. tacv:: enough (@ident : @form) by @tactic +.. tacv:: enough @form by @tactic +.. tacv:: enough @form as @intro_pattern by @tactic This behaves as above but with :n:`tactic` expected to solve the initial goal after the extra assumption :n:`form` is added and possibly destructed. If the @@ -1168,22 +1203,27 @@ Controlling the proof flow applied to all of them. .. tacv:: eenough (@ident : form) by tactic + :name: eenough + .. tacv:: eenough form by tactic + .. tacv:: eenough form as intro_pattern by tactic While the different variants of :n:`enough` expect that no existential variables are generated by the tactic, :n:`eenough` removes this constraint. -.. tacv:: cut form +.. tacv:: cut @form + :name: cut This tactic applies to any goal. It implements the non-dependent case of - the “App” rule given in :ref:`TODO-4.2`. (This is Modus Ponens inference + the “App” rule given in :ref:`typing-rules`. (This is Modus Ponens inference rule.) :n:`cut U` transforms the current goal :g:`T` into the two following subgoals: :g:`U -> T` and :g:`U`. The subgoal :g:`U -> T` comes first in the list of remaining subgoal to prove. .. tacv:: specialize (ident {* @term}) {? as intro_pattern} .. tacv:: specialize ident with @bindings_list {? as intro_pattern} + :name: specialize The tactic :n:`specialize` works on local hypothesis :n:`@ident`. The premises of this hypothesis (either universal quantifications or @@ -1202,8 +1242,8 @@ Controlling the proof flow the goal. The :n:`as` clause is especially useful in this case to immediately introduce the instantiated statement as a local hypothesis. - .. exn:: @ident is used in hypothesis @ident - .. exn:: @ident is used in conclusion + .. exn:: @ident is used in hypothesis @ident. + .. exn:: @ident is used in conclusion. .. tacn:: generalize @term :name: generalize @@ -1236,7 +1276,7 @@ name of the variable (here :g:`n`) is chosen based on :g:`T`. This is equivalent to :n:`generalize @term` but it generalizes only over the specified occurrences of :n:`@term` (counting from left to right on the - expression printed using option :g:`Set Printing All`). + expression printed using option :opt:`Printing All`). .. tacv:: generalize @term as @ident @@ -1268,7 +1308,7 @@ name of the variable (here :g:`n`) is chosen based on :g:`T`. :n:`refine @term` (preferred alternative). .. note:: To be able to refer to an existential variable by name, the user - must have given the name explicitly (see :ref:`TODO-2.11`). + must have given the name explicitly (see :ref:`Existential-Variables`). .. note:: When you are referring to hypotheses which you did not name explicitly, be aware that Coq may make a different decision on how to @@ -1327,7 +1367,7 @@ goals cannot be closed with :g:`Qed` but only with :g:`Admitted`. a singleton inductive type (e.g. :g:`True` or :g:`x=x`), or two contradictory hypotheses. -.. exn:: No such assumption +.. exn:: No such assumption. .. tacv:: contradiction @ident @@ -1353,11 +1393,13 @@ goals cannot be closed with :g:`Qed` but only with :g:`Admitted`. then required to prove that False is indeed provable in the current context. This tactic is a macro for :n:`elimtype False`. +.. _CaseAnalysisAndInduction: + Case analysis and induction ------------------------------- The tactics presented in this section implement induction or case -analysis on inductive or co-inductive objects (see :ref:`TODO-4.5`). +analysis on inductive or co-inductive objects (see :ref:`inductive-definitions`). .. tacn:: destruct @term :name: destruct @@ -1423,6 +1465,7 @@ analysis on inductive or co-inductive objects (see :ref:`TODO-4.5`). dependent premises of the type of :n:`@term` (see :ref:`syntax of bindings <bindingslist>`). .. tacv:: edestruct @term + :name: edestruct This tactic behaves like :n:`destruct @term` except that it does not fail if the instance of a dependent premises of the type of :n:`@term` is not @@ -1449,6 +1492,7 @@ analysis on inductive or co-inductive objects (see :ref:`TODO-4.5`). the effects of the `with`, `as`, `eqn:`, `using`, and `in` clauses. .. tacv:: case term + :name: case The tactic :n:`case` is a more basic tactic to perform case analysis without recursion. It behaves as :n:`elim @term` but using a case-analysis @@ -1458,14 +1502,15 @@ analysis on inductive or co-inductive objects (see :ref:`TODO-4.5`). Analogous to :n:`elim @term with @bindings_list` above. -.. tacv:: ecase @term -.. tacv:: ecase @term with @bindings_list +.. tacv:: ecase @term {? with @bindings_list } + :name: ecase In case the type of :n:`@term` has dependent premises, or dependent premises whose values are not inferable from the :n:`with @bindings_list` clause, :n:`ecase` turns them into existential variables to be resolved later on. .. tacv:: simple destruct @ident + :name: simple destruct This tactic behaves as :n:`intros until @ident; case @ident` when :n:`@ident` is a quantified variable of the goal. @@ -1528,9 +1573,9 @@ analysis on inductive or co-inductive objects (see :ref:`TODO-4.5`). intros n H. induction n. -.. exn:: Not an inductive product +.. exn:: Not an inductive product. -.. exn:: Unable to find an instance for the variables @ident ... @ident +.. exn:: Unable to find an instance for the variables @ident ... @ident. Use in this case the variant :tacn:`elim ... with` below. @@ -1556,6 +1601,7 @@ analysis on inductive or co-inductive objects (see :ref:`TODO-4.5`). premises of the type of :n:`term` (see :ref:`bindings list <bindingslist>`). .. tacv:: einduction @term + :name: einduction This tactic behaves like :tacn:`induction` except that it does not fail if some dependent premise of the type of :n:`@term` is not inferable. Instead, @@ -1628,6 +1674,7 @@ analysis on inductive or co-inductive objects (see :ref:`TODO-4.5`). (see :ref:`bindings list <bindingslist>`). .. tacv:: eelim @term + :name: eelim In case the type of :n:`@term` has dependent premises, this turns them into existential variables to be resolved later on. @@ -1635,7 +1682,7 @@ analysis on inductive or co-inductive objects (see :ref:`TODO-4.5`). .. tacv:: elim @term using @term .. tacv:: elim @term using @term with @bindings_list - Allows the user to give explicitly an elimination predicate :n:`@term` that + Allows the user to give explicitly an induction principle :n:`@term` that is not the standard one for the underlying inductive type of :n:`@term`. The :n:`@bindings_list` clause allows instantiating premises of the type of :n:`@term`. @@ -1646,7 +1693,8 @@ analysis on inductive or co-inductive objects (see :ref:`TODO-4.5`). These are the most general forms of ``elim`` and ``eelim``. It combines the effects of the ``using`` clause and of the two uses of the ``with`` clause. -.. tacv:: elimtype form +.. tacv:: elimtype @form + :name: elimtype The argument :n:`form` must be inductively defined. :n:`elimtype I` is equivalent to :n:`cut I. intro Hn; elim Hn; clear Hn.` Therefore the @@ -1656,6 +1704,7 @@ analysis on inductive or co-inductive objects (see :ref:`TODO-4.5`). :n:`elimtype I; 2:exact t.` .. tacv:: simple induction @ident + :name: simple induction This tactic behaves as :n:`intros until @ident; elim @ident` when :n:`@ident` is a quantified variable of the goal. @@ -1740,13 +1789,14 @@ analysis on inductive or co-inductive objects (see :ref:`TODO-4.5`). other ones need not be further generalized. .. tacv:: dependent destruction @ident + :name: dependent destruction This performs the generalization of the instance :n:`@ident` but uses ``destruct`` instead of induction on the generalized hypothesis. This gives results equivalent to ``inversion`` or ``dependent inversion`` if the hypothesis is dependent. -See also :ref:`TODO-10.1-dependentinduction` for a larger example of ``dependent induction`` +See also the larger example of :tacn:`dependent induction` and an explanation of the underlying technique. .. tacn:: function induction (@qualid {+ @term}) @@ -1754,8 +1804,8 @@ and an explanation of the underlying technique. The tactic functional induction performs case analysis and induction following the definition of a function. It makes use of a principle - generated by ``Function`` (see :ref:`TODO-2.3-Advancedrecursivefunctions`) or - ``Functional Scheme`` (see :ref:`TODO-13.2-Generationofinductionschemeswithfunctionalscheme`). + generated by ``Function`` (see :ref:`advanced-recursive-functions`) or + ``Functional Scheme`` (see :ref:`functional-scheme`). Note that this tactic is only available after a .. example:: @@ -1781,26 +1831,26 @@ and an explanation of the underlying technique. :n:`functional induction (f x1 x2 x3)` is actually a wrapper for :n:`induction x1, x2, x3, (f x1 x2 x3) using @qualid` followed by a cleaning phase, where :n:`@qualid` is the induction principle registered for :g:`f` - (by the ``Function`` (see :ref:`TODO-2.3-Advancedrecursivefunctions`) or - ``Functional Scheme`` (see :ref:`TODO-13.2-Generationofinductionschemeswithfunctionalscheme`) + (by the ``Function`` (see :ref:`advanced-recursive-functions`) or + ``Functional Scheme`` (see :ref:`functional-scheme`) command) corresponding to the sort of the goal. Therefore ``functional induction`` may fail if the induction scheme :n:`@qualid` is not - defined. See also :ref:`TODO-2.3-Advancedrecursivefunctions` for the function + defined. See also :ref:`advanced-recursive-functions` for the function terms accepted by ``Function``. .. note:: There is a difference between obtaining an induction scheme - for a function by using :g:`Function` (see :ref:`TODO-2.3-Advancedrecursivefunctions`) + for a function by using :g:`Function` (see :ref:`advanced-recursive-functions`) and by using :g:`Functional Scheme` after a normal definition using - :g:`Fixpoint` or :g:`Definition`. See :ref:`TODO-2.3-Advancedrecursivefunctions` + :g:`Fixpoint` or :g:`Definition`. See :ref:`advanced-recursive-functions` for details. -See also: :ref:`TODO-2.3-Advancedrecursivefunctions` - :ref:`TODO-13.2-Generationofinductionschemeswithfunctionalscheme` +See also: :ref:`advanced-recursive-functions` + :ref:`functional-scheme` :tacn:`inversion` -.. exn:: Cannot find induction information on @qualid -.. exn:: Not the right number of induction arguments +.. exn:: Cannot find induction information on @qualid. +.. exn:: Not the right number of induction arguments. .. tacv:: functional induction (@qualid {+ @term}) as @disj_conj_intro_pattern using @term with @bindings_list @@ -1833,8 +1883,8 @@ See also: :ref:`TODO-2.3-Advancedrecursivefunctions` :n:`@ident` is first introduced in the local context using :n:`intros until @ident`. -.. exn:: No primitive equality found -.. exn:: Not a discriminable equality +.. exn:: No primitive equality found. +.. exn:: Not a discriminable equality. .. tacv:: discriminate @num @@ -1849,6 +1899,7 @@ See also: :ref:`TODO-2.3-Advancedrecursivefunctions` .. tacv:: ediscriminate @num .. tacv:: ediscriminate @term {? with @bindings_list} + :name: ediscriminate This works the same as ``discriminate`` but if the type of :n:`@term`, or the type of the hypothesis referred to by :n:`@num`, has uninstantiated @@ -1861,7 +1912,7 @@ See also: :ref:`TODO-2.3-Advancedrecursivefunctions` the form :n:`@term <> @term`, this behaves as :n:`intro @ident; discriminate @ident`. - .. exn:: No discriminable equalities + .. exn:: No discriminable equalities. .. tacn:: injection @term :name: injection @@ -1872,7 +1923,7 @@ See also: :ref:`TODO-2.3-Advancedrecursivefunctions` :g:`t`:sub:`1` and :g:`t`:sub:`2` are equal too. If :n:`@term` is a proof of a statement of conclusion :n:`@term = @term`, - then ``injection`` applies the injectivity of constructors as deep as + then :tacn:`injection` applies the injectivity of constructors as deep as possible to derive the equality of all the subterms of :n:`@term` and :n:`@term` at positions where the terms start to differ. For example, from :g:`(S p, S n) = (q, S (S m))` we may derive :g:`S p = q` and @@ -1882,90 +1933,96 @@ See also: :ref:`TODO-2.3-Advancedrecursivefunctions` equality of all the subterms at positions where they differ and adds them as antecedents to the conclusion of the current goal. -.. example:: + .. example:: - Consider the following goal: + Consider the following goal: - .. coqtop:: reset all + .. coqtop:: in - Inductive list : Set := - | nil : list - | cons : nat -> list -> list. - Variable P : list -> Prop. - Goal forall l n, P nil -> cons n l = cons 0 nil -> P l. - intros. - injection H0. + Inductive list : Set := + | nil : list + | cons : nat -> list -> list. + Parameter P : list -> Prop. + Goal forall l n, P nil -> cons n l = cons 0 nil -> P l. + .. coqtop:: all -Beware that injection yields an equality in a sigma type whenever the -injected object has a dependent type :g:`P` with its two instances in -different types :g:`(P t`:sub:`1` :g:`... t`:sub:`n` :g:`)` and -:g:`(P u`:sub:`1` :g:`... u`:sub:`n` :sub:`)`. If :g:`t`:sub:`1` and -:g:`u`:sub:`1` are the same and have for type an inductive type for which a decidable -equality has been declared using the command ``Scheme Equality`` (see :ref:`TODO-13.1-GenerationofinductionprincipleswithScheme`), -the use of a sigma type is avoided. + intros. + injection H0. -.. note:: - If some quantified hypothesis of the goal is named :n:`@ident`, - then :n:`injection @ident` first introduces the hypothesis in the local - context using :n:`intros until @ident`. + Beware that injection yields an equality in a sigma type whenever the + injected object has a dependent type :g:`P` with its two instances in + different types :g:`(P t`:sub:`1` :g:`... t`:sub:`n` :g:`)` and + :g:`(P u`:sub:`1` :g:`... u`:sub:`n` :sub:`)`. If :g:`t`:sub:`1` and + :g:`u`:sub:`1` are the same and have for type an inductive type for which a decidable + equality has been declared using the command :cmd:`Scheme Equality` + (see :ref:`proofschemes-induction-principles`), + the use of a sigma type is avoided. -.. exn:: Not a projectable equality but a discriminable one -.. exn:: Nothing to do, it is an equality between convertible @terms -.. exn:: Not a primitive equality -.. exn:: Nothing to inject + .. note:: + If some quantified hypothesis of the goal is named :n:`@ident`, + then :n:`injection @ident` first introduces the hypothesis in the local + context using :n:`intros until @ident`. -.. tacv:: injection @num + .. exn:: Not a projectable equality but a discriminable one. + .. exn:: Nothing to do, it is an equality between convertible @terms. + .. exn:: Not a primitive equality. + .. exn:: Nothing to inject. - This does the same thing as :n:`intros until @num` followed by - :n:`injection @ident` where :n:`@ident` is the identifier for the last - introduced hypothesis. + .. tacv:: injection @num -.. tacv:: injection @term with @bindings_list + This does the same thing as :n:`intros until @num` followed by + :n:`injection @ident` where :n:`@ident` is the identifier for the last + introduced hypothesis. - This does the same as :n:`injection @term` but using the given bindings to - instantiate parameters or hypotheses of :n:`@term`. + .. tacv:: injection @term with @bindings_list -.. tacv:: einjection @num -.. tacv:: einjection @term {? with @bindings_list} + This does the same as :n:`injection @term` but using the given bindings to + instantiate parameters or hypotheses of :n:`@term`. - This works the same as :n:`injection` but if the type of :n:`@term`, or the - type of the hypothesis referred to by :n:`@num`, has uninstantiated - parameters, these parameters are left as existential variables. + .. tacv:: einjection @num + :name: einjection + .. tacv:: einjection @term {? with @bindings_list} + + This works the same as :n:`injection` but if the type of :n:`@term`, or the + type of the hypothesis referred to by :n:`@num`, has uninstantiated + parameters, these parameters are left as existential variables. -.. tacv:: injection + .. tacv:: injection - If the current goal is of the form :n:`@term <> @term` , this behaves as - :n:`intro @ident; injection @ident`. + If the current goal is of the form :n:`@term <> @term` , this behaves as + :n:`intro @ident; injection @ident`. - .. exn:: goal does not satisfy the expected preconditions + .. exn:: goal does not satisfy the expected preconditions. -.. tacv:: injection @term {? with @bindings_list} as {+ @intro_pattern} -.. tacv:: injection @num as {+ intro_pattern} -.. tacv:: injection as {+ intro_pattern} -.. tacv:: einjection @term {? with @bindings_list} as {+ intro_pattern} -.. tacv:: einjection @num as {+ intro_pattern} -.. tacv:: einjection as {+ intro_pattern} + .. tacv:: injection @term {? with @bindings_list} as {+ @intro_pattern} + .. tacv:: injection @num as {+ intro_pattern} + .. tacv:: injection as {+ intro_pattern} + .. tacv:: einjection @term {? with @bindings_list} as {+ intro_pattern} + .. tacv:: einjection @num as {+ intro_pattern} + .. tacv:: einjection as {+ intro_pattern} These variants apply :n:`intros {+ @intro_pattern}` after the call to - ``injection`` or ``einjection`` so that all equalities generated are moved in + :tacn:`injection` or :tacn:`einjection` so that all equalities generated are moved in the context of hypotheses. The number of :n:`@intro_pattern` must not exceed the number of equalities newly generated. If it is smaller, fresh names are automatically generated to adjust the list of :n:`@intro_pattern` to the number of new equalities. The original equality is erased if it corresponds to an hypothesis. -It is possible to ensure that :n:`injection @term` erases the original -hypothesis and leaves the generated equalities in the context rather -than putting them as antecedents of the current goal, as if giving -:n:`injection @term as` (with an empty list of names). To obtain this -behavior, the option ``Set Structural Injection`` must be activated. This -option is off by default. + .. opt:: Structural Injection -By default, ``injection`` only creates new equalities between :n:`@terms` whose -type is in sort :g:`Type` or :g:`Set`, thus implementing a special behavior for -objects that are proofs of a statement in :g:`Prop`. This behavior can be -turned off by setting the option ``Set Keep Proof Equalities``. + This option ensure that :n:`injection @term` erases the original hypothesis + and leaves the generated equalities in the context rather than putting them + as antecedents of the current goal, as if giving :n:`injection @term as` + (with an empty list of names). This option is off by default. + + .. opt:: Keep Proof Equalities + + By default, :tacn:`injection` only creates new equalities between :n:`@terms` + whose type is in sort :g:`Type` or :g:`Set`, thus implementing a special + behavior for objects that are proofs of a statement in :g:`Prop`. This option + controls this behavior. .. tacn:: inversion @ident :name: inversion @@ -1984,15 +2041,15 @@ turned off by setting the option ``Set Keep Proof Equalities``. .. note:: As ``inversion`` proofs may be large in size, we recommend the user to stock the lemmas whenever the same instance needs to be - inverted several times. See :ref:`TODO-13.3-Generationofinversionprincipleswithderiveinversion`. + inverted several times. See :ref:`derive-inversion`. .. note:: Part of the behavior of the ``inversion`` tactic is to generate equalities between expressions that appeared in the hypothesis that is being processed. By default, no equalities are generated if they relate two proofs (i.e. equalities between :n:`@terms` whose type is in sort - :g:`Prop`). This behavior can be turned off by using the option ``Set Keep - Proof Equalities``. + :g:`Prop`). This behavior can be turned off by using the option + :opt`Keep Proof Equalities`. .. tacv:: inversion @num @@ -2093,13 +2150,13 @@ turned off by setting the option ``Set Keep Proof Equalities``. :n:`dependent inversion_clear @ident`. .. tacv:: dependent inversion @ident with @term - :name: dependent inversion ... + :name: dependent inversion ... with ... This variant allows you to specify the generalization of the goal. It is useful when the system fails to generalize the goal automatically. If - :n:`@ident` has type :g:`(I t)` and :g:`I` has type :math:`\forall` - :g:`(x:T), s`, then :n:`@term` must be of type :g:`I:`:math:`\forall` - :g:`(x:T), I x -> s'` where :g:`s'` is the type of the goal. + :n:`@ident` has type :g:`(I t)` and :g:`I` has type :g:`forall (x:T), s`, + then :n:`@term` must be of type :g:`I:forall (x:T), I x -> s'` where + :g:`s'` is the type of the goal. .. tacv:: dependent inversion @ident as @intro_pattern with @term @@ -2108,7 +2165,7 @@ turned off by setting the option ``Set Keep Proof Equalities``. .. tacv:: dependent inversion_clear @ident with @term - Like :tacn:`dependent inversion ...` with but clears :n:`@ident` from the + Like :tacn:`dependent inversion ... with ...` with but clears :n:`@ident` from the local context. .. tacv:: dependent inversion_clear @ident as @intro_pattern with @term @@ -2117,6 +2174,7 @@ turned off by setting the option ``Set Keep Proof Equalities``. :n:`dependent inversion_clear @ident with @term`. .. tacv:: simple inversion @ident + :name: simple inversion It is a very primitive inversion tactic that derives all the necessary equalities but it does not simplify the constraints as ``inversion`` does. @@ -2300,7 +2358,7 @@ turned off by setting the option ``Set Keep Proof Equalities``. arguments are correct is done only at the time of registering the lemma in the environment. To know if the use of induction hypotheses is correct at some time of the interactive development of a proof, use - the command ``Guarded`` (see :ref:`TODO-7.3.2-Guarded`). + the command ``Guarded`` (see Section :ref:`requestinginformation`). .. tacv:: fix @ident @num with {+ (ident {+ @binder} [{struct @ident}] : @type)} @@ -2321,7 +2379,7 @@ turned off by setting the option ``Set Keep Proof Equalities``. done only at the time of registering the lemma in the environment. To know if the use of coinduction hypotheses is correct at some time of the interactive development of a proof, use the command ``Guarded`` - (see :ref:`TODO-7.3.2-Guarded`). + (see Section :ref:`requestinginformation`). .. tacv:: cofix @ident with {+ (@ident {+ @binder} : @type)} @@ -2335,41 +2393,41 @@ Rewriting expressions --------------------- These tactics use the equality :g:`eq:forall A:Type, A->A->Prop` defined in -file ``Logic.v`` (see :ref:`TODO-3.1.2-Logic`). The notation for :g:`eq T t u` is +file ``Logic.v`` (see :ref:`coq-library-logic`). The notation for :g:`eq T t u` is simply :g:`t=u` dropping the implicit type of :g:`t` and :g:`u`. .. tacn:: rewrite @term :name: rewrite -This tactic applies to any goal. The type of :n:`@term` must have the form + This tactic applies to any goal. The type of :token:`term` must have the form -``forall (x``:sub:`1` ``:A``:sub:`1` ``) ... (x``:sub:`n` ``:A``:sub:`n` ``). eq term``:sub:`1` ``term``:sub:`2` ``.`` + ``forall (x``:sub:`1` ``:A``:sub:`1` ``) ... (x``:sub:`n` ``:A``:sub:`n` ``). eq term``:sub:`1` ``term``:sub:`2` ``.`` -where :g:`eq` is the Leibniz equality or a registered setoid equality. + where :g:`eq` is the Leibniz equality or a registered setoid equality. -Then :n:`rewrite @term` finds the first subterm matching `term`\ :sub:`1` in the goal, -resulting in instances `term`:sub:`1`' and `term`:sub:`2`' and then -replaces every occurrence of `term`:subscript:`1`' by `term`:subscript:`2`'. -Hence, some of the variables :g:`x`\ :sub:`i` are solved by unification, -and some of the types :g:`A`\ :sub:`1`:g:`, ..., A`\ :sub:`n` become new -subgoals. + Then :n:`rewrite @term` finds the first subterm matching `term`\ :sub:`1` in the goal, + resulting in instances `term`:sub:`1`' and `term`:sub:`2`' and then + replaces every occurrence of `term`:subscript:`1`' by `term`:subscript:`2`'. + Hence, some of the variables :g:`x`\ :sub:`i` are solved by unification, + and some of the types :g:`A`\ :sub:`1`:g:`, ..., A`\ :sub:`n` become new + subgoals. -.. exn:: The @term provided does not end with an equation + .. exn:: The @term provided does not end with an equation. -.. exn:: Tactic generated a subgoal identical to the original goal. This happens if @term does not occur in the goal. + .. exn:: Tactic generated a subgoal identical to the original goal. This happens if @term does not occur in the goal. -.. tacv:: rewrite -> @term + .. tacv:: rewrite -> @term - Is equivalent to :n:`rewrite @term` + Is equivalent to :n:`rewrite @term` -.. tacv:: rewrite <- @term + .. tacv:: rewrite <- @term - Uses the equality :n:`@term`:sub:`1` :n:`= @term` :sub:`2` from right to left + Uses the equality :n:`@term`:sub:`1` :n:`= @term` :sub:`2` from right to left -.. tacv:: rewrite @term in clause + .. tacv:: rewrite @term in clause - Analogous to :n:`rewrite @term` but rewriting is done following clause - (similarly to :ref:`performing computations <performingcomputations>`). For instance: + Analogous to :n:`rewrite @term` but rewriting is done following clause + (similarly to :ref:`performing computations <performingcomputations>`). For instance: + :n:`rewrite H in H`:sub:`1` will rewrite `H` in the hypothesis `H`:sub:`1` instead of the current goal. @@ -2378,218 +2436,215 @@ subgoals. In particular a failure will happen if any of these three simpler tactics fails. + :n:`rewrite H in * |-` will do :n:`rewrite H in H`:sub:`i` for all hypotheses - :g:`H`:sub:`i` :g:`<> H`. A success will happen as soon as at least one of these - simpler tactics succeeds. + :g:`H`:sub:`i` different from :g:`H`. + A success will happen as soon as at least one of these simpler tactics succeeds. + :n:`rewrite H in *` is a combination of :n:`rewrite H` and :n:`rewrite H in * |-` that succeeds if at least one of these two tactics succeeds. - Orientation :g:`->` or :g:`<-` can be inserted before the :n:`@term` to rewrite. + Orientation :g:`->` or :g:`<-` can be inserted before the :token:`term` to rewrite. -.. tacv:: rewrite @term at occurrences + .. tacv:: rewrite @term at occurrences - Rewrite only the given occurrences of :n:`@term`. Occurrences are - specified from left to right as for pattern (:tacn:`pattern`). The rewrite is - always performed using setoid rewriting, even for Leibniz’s equality, so one - has to ``Import Setoid`` to use this variant. + Rewrite only the given occurrences of :token:`term`. Occurrences are + specified from left to right as for pattern (:tacn:`pattern`). The rewrite is + always performed using setoid rewriting, even for Leibniz’s equality, so one + has to ``Import Setoid`` to use this variant. -.. tacv:: rewrite @term by tactic + .. tacv:: rewrite @term by tactic - Use tactic to completely solve the side-conditions arising from the - :tacn:`rewrite`. + Use tactic to completely solve the side-conditions arising from the + :tacn:`rewrite`. -.. tacv:: rewrite {+ @term} + .. tacv:: rewrite {+, @term} - Is equivalent to the `n` successive tactics :n:`{+ rewrite @term}`, each one - working on the first subgoal generated by the previous one. Orientation - :g:`->` or :g:`<-` can be inserted before each :n:`@term` to rewrite. One - unique clause can be added at the end after the keyword in; it will then - affect all rewrite operations. + Is equivalent to the `n` successive tactics :n:`{+; rewrite @term}`, each one + working on the first subgoal generated by the previous one. Orientation + :g:`->` or :g:`<-` can be inserted before each :token:`term` to rewrite. One + unique clause can be added at the end after the keyword in; it will then + affect all rewrite operations. - In all forms of rewrite described above, a :n:`@term` to rewrite can be - immediately prefixed by one of the following modifiers: + In all forms of rewrite described above, a :token:`term` to rewrite can be + immediately prefixed by one of the following modifiers: - + `?` : the tactic rewrite :n:`?@term` performs the rewrite of :n:`@term` as many - times as possible (perhaps zero time). This form never fails. - + `n?` : works similarly, except that it will do at most `n` rewrites. - + `!` : works as ?, except that at least one rewrite should succeed, otherwise - the tactic fails. - + `n!` (or simply `n`) : precisely `n` rewrites of :n:`@term` will be done, - leading to failure if these n rewrites are not possible. + + `?` : the tactic :n:`rewrite ?@term` performs the rewrite of :token:`term` as many + times as possible (perhaps zero time). This form never fails. + + :n:`@num?` : works similarly, except that it will do at most :token:`num` rewrites. + + `!` : works as `?`, except that at least one rewrite should succeed, otherwise + the tactic fails. + + :n:`@num!` (or simply :n:`@num`) : precisely :token:`num` rewrites of :token:`term` will be done, + leading to failure if these :token:`num` rewrites are not possible. -.. tacv:: erewrite @term + .. tacv:: erewrite @term + :name: erewrite - This tactic works as :n:`rewrite @term` but turning - unresolved bindings into existential variables, if any, instead of - failing. It has the same variants as :tacn:`rewrite` has. + This tactic works as :n:`rewrite @term` but turning + unresolved bindings into existential variables, if any, instead of + failing. It has the same variants as :tacn:`rewrite` has. -.. tacn:: replace @term with @term +.. tacn:: replace @term with @term’ :name: replace This tactic applies to any goal. It replaces all free occurrences of :n:`@term` - in the current goal with :n:`@term` and generates the equality :n:`@term = - @term` as a subgoal. This equality is automatically solved if it occurs among - the assumption, or if its symmetric form occurs. It is equivalent to - :n:`cut @term = @term; [intro H`:sub:`n` :n:`; rewrite <- H`:sub:`n` :n:`; clear H`:sub:`n`:n:`|| assumption || symmetry; try assumption]`. + in the current goal with :n:`@term’` and generates an equality :n:`@term = @term’` + as a subgoal. This equality is automatically solved if it occurs among + the assumptions, or if its symmetric form occurs. It is equivalent to + :n:`cut @term = @term’; [intro H`:sub:`n` :n:`; rewrite <- H`:sub:`n` :n:`; clear H`:sub:`n`:n:`|| assumption || symmetry; try assumption]`. -.. exn:: @terms do not have convertible types + .. exn:: Terms do not have convertible types. -.. tacv:: replace @term with @term by tactic + .. tacv:: replace @term with @term’ by @tactic - This acts as :n:`replace @term` with :n:`@term` but applies tactic to solve the generated - subgoal :n:`@term = @term`. + This acts as :n:`replace @term with @term’` but applies :token:`tactic` to solve the generated + subgoal :n:`@term = @term’`. -.. tacv:: replace @term + .. tacv:: replace @term - Replaces :n:`@term` with :n:`@term’` using the first assumption whose type has - the form :n:`@term = @term’` or :n:`@term’ = @term`. + Replaces :n:`@term` with :n:`@term’` using the first assumption whose type has + the form :n:`@term = @term’` or :n:`@term’ = @term`. -.. tacv:: replace -> @term + .. tacv:: replace -> @term - Replaces :n:`@term` with :n:`@term’` using the first assumption whose type has - the form :n:`@term = @term’` + Replaces :n:`@term` with :n:`@term’` using the first assumption whose type has + the form :n:`@term = @term’` -.. tacv:: replace <- @term + .. tacv:: replace <- @term - Replaces :n:`@term` with :n:`@term’` using the first assumption whose type has - the form :n:`@term’ = @term` + Replaces :n:`@term` with :n:`@term’` using the first assumption whose type has + the form :n:`@term’ = @term` -.. tacv:: replace @term with @term in clause -.. tacv:: replace @term with @term in clause by tactic -.. tacv:: replace @term in clause replace -> @term in clause -.. tacv:: replace <- @term in clause + .. tacv:: replace @term {? with @term} in clause {? by @tactic} + .. tacv:: replace -> @term in clause + .. tacv:: replace <- @term in clause - Acts as before but the replacements take place inclause (see - :ref:`performingcomputations`) and not only in the conclusion of the goal. The - clause argument must not contain any type of nor value of. + Acts as before but the replacements take place in the specified clause (see + :ref:`performingcomputations`) and not only in the conclusion of the goal. The + clause argument must not contain any ``type of`` nor ``value of``. -.. tacv:: cutrewrite <- (@term = @term) + .. tacv:: cutrewrite <- (@term = @term’) + :name: cutrewrite - This tactic is deprecated. It acts like :n:`replace @term with @term`, or, - equivalently as :n:`enough (@term = @term) as <-`. + This tactic is deprecated. It can be replaced by :n:`enough (@term = @term’) as <-`. -.. tacv:: cutrewrite -> (@term = @term) + .. tacv:: cutrewrite -> (@term = @term’) - This tactic is deprecated. It can be replaced by enough :n:`(@term = @term) as ->`. + This tactic is deprecated. It can be replaced by :n:`enough (@term = @term’) as ->`. .. tacn:: subst @ident :name: subst + This tactic applies to a goal that has :n:`@ident` in its context and (at + least) one hypothesis, say :g:`H`, of type :n:`@ident = t` or :n:`t = @ident` + with :n:`@ident` not occurring in :g:`t`. Then it replaces :n:`@ident` by + :g:`t` everywhere in the goal (in the hypotheses and in the conclusion) and + clears :n:`@ident` and :g:`H` from the context. -This tactic applies to a goal that has :n:`@ident` in its context and (at -least) one hypothesis, say :g:`H`, of type :n:`@ident = t` or :n:`t = @ident` -with :n:`@ident` not occurring in :g:`t`. Then it replaces :n:`@ident` by -:g:`t` everywhere in the goal (in the hypotheses and in the conclusion) and -clears :n:`@ident` and :g:`H` from the context. - -If :n:`@ident` is a local definition of the form :n:`@ident := t`, it is also -unfolded and cleared. + If :n:`@ident` is a local definition of the form :n:`@ident := t`, it is also + unfolded and cleared. + .. note:: + + When several hypotheses have the form :n:`@ident = t` or :n:`t = @ident`, the + first one is used. -.. note:: - When several hypotheses have the form :n:`@ident = t` or :n:`t = @ident`, the - first one is used. + + If :g:`H` is itself dependent in the goal, it is replaced by the proof of + reflexivity of equality. + .. tacv:: subst {+ @ident} -.. note:: - If `H` is itself dependent in the goal, it is replaced by the proof of - reflexivity of equality. + This is equivalent to :n:`subst @ident`:sub:`1`:n:`; ...; subst @ident`:sub:`n`. + .. tacv:: subst -.. tacv:: subst {+ @ident} + This applies subst repeatedly from top to bottom to all identifiers of the + context for which an equality of the form :n:`@ident = t` or :n:`t = @ident` + or :n:`@ident := t` exists, with :n:`@ident` not occurring in ``t``. - This is equivalent to :n:`subst @ident`:sub:`1`:n:`; ...; subst @ident`:sub:`n`. + .. opt:: Regular Subst Tactic -.. tacv:: subst + This option controls the behavior of :tacn:`subst`. When it is + activated (it is by default), :tacn:`subst` also deals with the following corner cases: - This applies subst repeatedly from top to bottom to all identifiers of the - context for which an equality of the form :n:`@ident = t` or :n:`t = @ident` - or :n:`@ident := t` exists, with :n:`@ident` not occurring in `t`. + + A context with ordered hypotheses :n:`@ident`:sub:`1` :n:`= @ident`:sub:`2` + and :n:`@ident`:sub:`1` :n:`= t`, or :n:`t′ = @ident`:sub:`1`` with `t′` not + a variable, and no other hypotheses of the form :n:`@ident`:sub:`2` :n:`= u` + or :n:`u = @ident`:sub:`2`; without the option, a second call to + subst would be necessary to replace :n:`@ident`:sub:`2` by `t` or + `t′` respectively. + + The presence of a recursive equation which without the option would + be a cause of failure of :tacn:`subst`. + + A context with cyclic dependencies as with hypotheses :n:`@ident`:sub:`1` :n:`= f @ident`:sub:`2` + and :n:`@ident`:sub:`2` :n:`= g @ident`:sub:`1` which without the + option would be a cause of failure of :tacn:`subst`. - .. note:: + Additionally, it prevents a local definition such as :n:`@ident := t` to be + unfolded which otherwise it would exceptionally unfold in configurations + containing hypotheses of the form :n:`@ident = u`, or :n:`u′ = @ident` + with `u′` not a variable. Finally, it preserves the initial order of + hypotheses, which without the option it may break. + default. - The behavior of subst can be controlled using option ``Set Regular Subst - Tactic.`` When this option is activated, subst also deals with the - following corner cases: - + A context with ordered hypotheses :n:`@ident`:sub:`1` :n:`= @ident`:sub:`2` - and :n:`@ident`:sub:`1` :n:`= t`, or :n:`t′ = @ident`:sub:`1`` with `t′` not - a variable, and no other hypotheses of the form :n:`@ident`:sub:`2` :n:`= u` - or :n:`u = @ident`:sub:`2`; without the option, a second call to - subst would be necessary to replace :n:`@ident`:sub:`2` by `t` or - `t′` respectively. - + The presence of a recursive equation which without the option would - be a cause of failure of :tacn:`subst`. - + A context with cyclic dependencies as with hypotheses :n:`@ident`:sub:`1` :n:`= f @ident`:sub:`2` - and :n:`@ident`:sub:`2` :n:`= g @ident`:sub:`1` which without the - option would be a cause of failure of :tacn:`subst`. +.. tacn:: stepl @term + :name: stepl - Additionally, it prevents a local definition such as :n:`@ident := t` to be - unfolded which otherwise it would exceptionally unfold in configurations - containing hypotheses of the form :n:`@ident = u`, or :n:`u′ = @ident` - with `u′` not a variable. Finally, it preserves the initial order of - hypotheses, which without the option it may break. The option is on by - default. + This tactic is for chaining rewriting steps. It assumes a goal of the + form :n:`R @term @term` where ``R`` is a binary relation and relies on a + database of lemmas of the form :g:`forall x y z, R x y -> eq x z -> R z y` + where `eq` is typically a setoid equality. The application of :n:`stepl @term` + then replaces the goal by :n:`R @term @term` and adds a new goal stating + :n:`eq @term @term`. + .. cmd:: Declare Left Step @term -.. tacn:: stepl @term - :name: stepl + Adds :n:`@term` to the database used by :tacn:`stepl`. + The tactic is especially useful for parametric setoids which are not accepted + as regular setoids for :tacn:`rewrite` and :tacn:`setoid_replace` (see + :ref:`Generalizedrewriting`). -This tactic is for chaining rewriting steps. It assumes a goal of the -form :n:`R @term @term` where `R` is a binary relation and relies on a -database of lemmas of the form :g:`forall x y z, R x y -> eq x z -> R z y` -where `eq` is typically a setoid equality. The application of :n:`stepl @term` -then replaces the goal by :n:`R @term @term` and adds a new goal stating -:n:`eq @term @term`. + .. tacv:: stepl @term by @tactic -Lemmas are added to the database using the command ``Declare Left Step @term.`` -The tactic is especially useful for parametric setoids which are not accepted -as regular setoids for :tacn:`rewrite` and :tacn:`setoid_replace` (see -:ref:`TODO-27-Generalizedrewriting`). + This applies :n:`stepl @term` then applies :token:`tactic` to the second goal. -.. tacv:: stepl @term by tactic + .. tacv:: stepr @term stepr @term by tactic + :name: stepr - This applies :n:`stepl @term` then applies tactic to the second goal. + This behaves as :tacn:`stepl` but on the right-hand-side of the binary + relation. Lemmas are expected to be of the form + :g:`forall x y z, R x y -> eq y z -> R x z`. -.. tacv:: stepr @term stepr @term by tactic + .. cmd:: Declare Right Step @term - This behaves as :tacn:`stepl` but on the right-hand-side of the binary - relation. Lemmas are expected to be of the form :g:`forall x y z, R x y -> eq - y z -> R x z` and are registered using the command ``Declare Right Step - @term.`` + Adds :n:`@term` to the database used by :tacn:`stepr`. .. tacn:: change @term :name: change - This tactic applies to any goal. It implements the rule ``Conv`` given in - :ref:`TODO-4.4-Subtypingrules`. :g:`change U` replaces the current goal `T` - with `U` providing that `U` is well-formed and that `T` and `U` are - convertible. - -.. exn:: Not convertible + This tactic applies to any goal. It implements the rule ``Conv`` given in + :ref:`subtyping-rules`. :g:`change U` replaces the current goal `T` + with `U` providing that `U` is well-formed and that `T` and `U` are + convertible. + .. exn:: Not convertible. -.. tacv:: change @term with @term + .. tacv:: change @term with @term’ - This replaces the occurrences of :n:`@term` by :n:`@term` in the current goal. - The term :n:`@term` and :n:`@term` must be convertible. + This replaces the occurrences of :n:`@term` by :n:`@term’` in the current goal. + The term :n:`@term` and :n:`@term’` must be convertible. -.. tacv:: change @term at {+ @num} with @term + .. tacv:: change @term at {+ @num} with @term’ - This replaces the occurrences numbered :n:`{+ @num}` of :n:`@term by @term` - in the current goal. The terms :n:`@term` and :n:`@term` must be convertible. + This replaces the occurrences numbered :n:`{+ @num}` of :n:`@term` by :n:`@term’` + in the current goal. The terms :n:`@term` and :n:`@term’` must be convertible. -.. exn:: Too few occurrences + .. exn:: Too few occurrences. -.. tacv:: change @term in @ident -.. tacv:: change @term with @term in @ident -.. tacv:: change @term at {+ @num} with @term in @ident + .. tacv:: change @term {? {? at {+ @num}} with @term} in @ident - This applies the change tactic not to the goal but to the hypothesis :n:`@ident`. + This applies the :tacn:`change` tactic not to the goal but to the hypothesis :n:`@ident`. -See also: :ref:`Performing computations <performingcomputations>` + .. seealso:: :ref:`Performing computations <performingcomputations>` .. _performingcomputations: @@ -2637,7 +2692,7 @@ the conversion in hypotheses :n:`{+ @ident}`. the normalization of the goal according to the specified flags. In correspondence with the kinds of reduction considered in Coq namely :math:`\beta` (reduction of functional application), :math:`\delta` - (unfolding of transparent constants, see :ref:`TODO-6.10.2-Transparent`), + (unfolding of transparent constants, see :ref:`vernac-controlling-the-reduction-strategies`), :math:`\iota` (reduction of pattern-matching over a constructed term, and unfolding of :g:`fix` and :g:`cofix` expressions) and :math:`\zeta` (contraction of local definitions), the @@ -2649,7 +2704,7 @@ the conversion in hypotheses :n:`{+ @ident}`. second case the constant to unfold to all but the ones explicitly mentioned. Notice that the ``delta`` flag does not apply to variables bound by a let-in construction inside the :n:`@term` itself (use here the ``zeta`` flag). In - any cases, opaque constants are not unfolded (see :ref:`TODO-6.10.1-Opaque`). + any cases, opaque constants are not unfolded (see :ref:`vernac-controlling-the-reduction-strategies`). Normalization according to the flags is done by first evaluating the head of the expression into a *weak-head* normal form, i.e. until the @@ -2704,6 +2759,7 @@ the conversion in hypotheses :n:`{+ @ident}`. and :n:`lazy beta delta -{+ @qualid} iota zeta`. .. tacv:: vm_compute + :name: vm_compute This tactic evaluates the goal using the optimized call-by-value evaluation bytecode-based virtual machine described in :cite:`CompiledStrongReduction`. @@ -2713,6 +2769,7 @@ the conversion in hypotheses :n:`{+ @ident}`. reflection-based tactics. .. tacv:: native_compute + :name: native_compute This tactic evaluates the goal by compilation to Objective Caml as described in :cite:`FullReduction`. If Coq is running in native code, it can be @@ -2754,7 +2811,7 @@ the conversion in hypotheses :n:`{+ @ident}`. definition (say :g:`t`) and then reduces :g:`(t t`:sub:`1` :g:`... t`:sub:`n` :g:`)` according to :math:`\beta`:math:`\iota`:math:`\zeta`-reduction rules. -.. exn:: Not reducible +.. exn:: Not reducible. .. tacn:: hnf :name: hnf @@ -2768,7 +2825,7 @@ the conversion in hypotheses :n:`{+ @ident}`. :n:`hnf`. .. note:: - The :math:`\delta` rule only applies to transparent constants (see :ref:`TODO-6.10.1-Opaque` + The :math:`\delta` rule only applies to transparent constants (see :ref:`vernac-controlling-the-reduction-strategies` on transparency and opacity). .. tacn:: cbn @@ -2811,8 +2868,8 @@ the conversion in hypotheses :n:`{+ @ident}`. .. coqtop:: all Definition fcomp A B C f (g : A -> B) (x : A) : C := f (g x). - Notation "f \o g" := (fcomp f g) (at level 50). Arguments fcomp {A B C} f g x /. + Notation "f \o g" := (fcomp f g) (at level 50). After that command the expression :g:`(f \o g)` is left untouched by ``simpl`` while :g:`((f \o g) t)` is reduced to :g:`(f (g t))`. @@ -2881,7 +2938,7 @@ the conversion in hypotheses :n:`{+ @ident}`. This applies ``simpl`` only to the :n:`{+ @num}` occurrences of the subterms matching :n:`@pattern` in the current goal. - .. exn:: Too few occurrences + .. exn:: Too few occurrences. .. tacv:: simpl @qualid .. tacv:: simpl @string @@ -2906,12 +2963,12 @@ the conversion in hypotheses :n:`{+ @ident}`. This tactic applies to any goal. The argument qualid must denote a defined transparent constant or local definition (see - :ref:`TODO-1.3.2-Definitions` and :ref:`TODO-6.10.2-Transparent`). The tactic + :ref:`gallina-definitions` and :ref:`vernac-controlling-the-reduction-strategies`). The tactic ``unfold`` applies the :math:`\delta` rule to each occurrence of the constant to which :n:`@qualid` refers in the current goal and then replaces it with its :math:`\beta`:math:`\iota`-normal form. -.. exn:: @qualid does not denote an evaluable constant +.. exn:: @qualid does not denote an evaluable constant. .. tacv:: unfold @qualid in @ident @@ -2928,9 +2985,9 @@ the conversion in hypotheses :n:`{+ @ident}`. The lists :n:`{+, @num}` specify the occurrences of :n:`@qualid` to be unfolded. Occurrences are located from left to right. - .. exn:: bad occurrence number of @qualid + .. exn:: Bad occurrence number of @qualid. - .. exn:: @qualid does not occur + .. exn:: @qualid does not occur. .. tacv:: unfold @string @@ -2942,7 +2999,7 @@ the conversion in hypotheses :n:`{+ @ident}`. This is variant of :n:`unfold @string` where :n:`@string` gets its interpretation from the scope bound to the delimiting key :n:`key` - instead of its default interpretation (see :ref:`TODO-12.2.2-Localinterpretationrulesfornotations`). + instead of its default interpretation (see :ref:`Localinterpretationrulesfornotations`). .. tacv:: unfold {+, qualid_or_string at {+, @num}} This is the most general form, where :n:`qualid_or_string` is either a @@ -3020,7 +3077,7 @@ Conversion tactics applied to hypotheses Example: :n:`unfold not in (Type of H1) (Type of H3)`. -.. exn:: No such hypothesis : ident. +.. exn:: No such hypothesis: @ident. .. _automation: @@ -3071,6 +3128,7 @@ hints of the database named core. to know what lemmas/assumptions were used. .. tacv:: debug auto + :name: debug auto Behaves like :tacn:`auto` but shows the tactics it tries to solve the goal, including failing paths. @@ -3090,7 +3148,9 @@ hints of the database named core. .. tacv:: trivial with * .. tacv:: trivial using {+ @lemma} .. tacv:: debug trivial + :name: debug trivial .. tacv:: info_trivial + :name: info_trivial .. tacv:: {? info_}trivial {? using {+ @lemma}} {? with {+ @ident}} .. note:: @@ -3103,7 +3163,7 @@ the :tacn:`auto` and :tacn:`trivial` tactics: .. opt:: Info Auto .. opt:: Debug Auto .. opt:: Info Trivial -.. opt:: Info Trivial +.. opt:: Debug Trivial See also: :ref:`The Hints Databases for auto and eauto <thehintsdatabasesforautoandeauto>` @@ -3123,7 +3183,7 @@ can solve such a goal: Goal forall P:nat -> Prop, P 0 -> exists n, P n. eauto. -Note that :tacn:`ex_intro` should be declared as a hint. +Note that ``ex_intro`` should be declared as a hint. .. tacv:: {? info_}eauto {? @num} {? using {+ @lemma}} {? with {+ @ident}} @@ -3169,7 +3229,9 @@ the processing of the rewriting rules. The rewriting rule bases are built with the ``Hint Rewrite vernacular`` command. -.. warn:: This tactic may loop if you build non terminating rewriting systems. +.. warning:: + + This tactic may loop if you build non terminating rewriting systems. .. tacv:: autorewrite with {+ @ident} using @tactic @@ -3200,7 +3262,8 @@ See also: :tacn:`autorewrite` for examples showing the use of this tactic. This tactic tries to solve the current goal by a number of standard closing steps. In particular, it tries to close the current goal using the closing tactics - :tacn:`trivial`, reflexivity, symmetry, contradiction and inversion of hypothesis. + :tacn:`trivial`, :tacn:`reflexivity`, :tacn:`symmetry`, :tacn:`contradiction` + and :tacn:`inversion` of hypothesis. If this fails, it tries introducing variables and splitting and-hypotheses, using the closing tactics afterwards, and splitting the goal using :tacn:`split` and recursing. @@ -3211,7 +3274,7 @@ See also: :tacn:`autorewrite` for examples showing the use of this tactic. .. tacv:: now @tactic :name: now - Run :n:`@tac` followed by ``easy``. This is a notation for :n:`@tactic; easy`. + Run :n:`@tactic` followed by :tacn:`easy`. This is a notation for :n:`@tactic; easy`. Controlling automation -------------------------- @@ -3221,225 +3284,245 @@ Controlling automation The hints databases for auto and eauto ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The hints for ``auto`` and ``eauto`` are stored in databases. Each database -maps head symbols to a list of hints. One can use the command +The hints for :tacn:`auto` and :tacn:`eauto` are stored in databases. Each database +maps head symbols to a list of hints. .. cmd:: Print Hint @ident -to display the hints associated to the head symbol :n:`@ident` -(see :ref:`Print Hint <printhint>`). Each hint has a cost that is a nonnegative -integer, and an optional pattern. The hints with lower cost are tried first. A -hint is tried by ``auto`` when the conclusion of the current goal matches its -pattern or when it has no pattern. + Use this command + to display the hints associated to the head symbol :n:`@ident` + (see :ref:`Print Hint <printhint>`). Each hint has a cost that is a nonnegative + integer, and an optional pattern. The hints with lower cost are tried first. A + hint is tried by :tacn:`auto` when the conclusion of the current goal matches its + pattern or when it has no pattern. Creating Hint databases ``````````````````````` -One can optionally declare a hint database using the command ``Create -HintDb``. If a hint is added to an unknown database, it will be +One can optionally declare a hint database using the command +:cmd:`Create HintDb`. If a hint is added to an unknown database, it will be automatically created. -.. cmd:: Create HintDb @ident {? discriminated}. - -This command creates a new database named :n:`@ident`. The database is -implemented by a Discrimination Tree (DT) that serves as an index of -all the lemmas. The DT can use transparency information to decide if a -constant should be indexed or not (c.f. :ref:`The hints databases for auto and eauto <thehintsdatabasesforautoandeauto>`), -making the retrieval more efficient. The legacy implementation (the default one -for new databases) uses the DT only on goals without existentials (i.e., ``auto`` -goals), for non-Immediate hints and do not make use of transparency -hints, putting more work on the unification that is run after -retrieval (it keeps a list of the lemmas in case the DT is not used). -The new implementation enabled by the discriminated option makes use -of DTs in all cases and takes transparency information into account. -However, the order in which hints are retrieved from the DT may differ -from the order in which they were inserted, making this implementation -observationally different from the legacy one. +.. cmd:: Create HintDb @ident {? discriminated} + + This command creates a new database named :n:`@ident`. The database is + implemented by a Discrimination Tree (DT) that serves as an index of + all the lemmas. The DT can use transparency information to decide if a + constant should be indexed or not + (c.f. :ref:`The hints databases for auto and eauto <thehintsdatabasesforautoandeauto>`), + making the retrieval more efficient. The legacy implementation (the default one + for new databases) uses the DT only on goals without existentials (i.e., :tacn:`auto` + goals), for non-Immediate hints and do not make use of transparency + hints, putting more work on the unification that is run after + retrieval (it keeps a list of the lemmas in case the DT is not used). + The new implementation enabled by the discriminated option makes use + of DTs in all cases and takes transparency information into account. + However, the order in which hints are retrieved from the DT may differ + from the order in which they were inserted, making this implementation + observationally different from the legacy one. The general command to add a hint to some databases :n:`{+ @ident}` is -.. cmd:: Hint hint_definition : {+ @ident} +.. cmd:: Hint @hint_definition : {+ @ident} -**Variants:** + .. cmdv:: Hint @hint_definition + + No database name is given: the hint is registered in the core database. + + .. cmdv:: Local Hint @hint_definition : {+ @ident} + + This is used to declare hints that must not be exported to the other modules + that require and import the current module. Inside a section, the option + Local is useless since hints do not survive anyway to the closure of + sections. + + .. cmdv:: Local Hint @hint_definition -.. cmd:: Hint hint_definition + Idem for the core database. - No database name is given: the hint is registered in the core database. + .. cmdv:: Hint Resolve @term {? | {? @num} {? @pattern}} + :name: Hint Resolve -.. cmd:: Local Hint hint_definition : {+ @ident} + This command adds :n:`simple apply @term` to the hint list with the head + symbol of the type of :n:`@term`. The cost of that hint is the number of + subgoals generated by :n:`simple apply @term` or :n:`@num` if specified. The + associated :n:`@pattern` is inferred from the conclusion of the type of + :n:`@term` or the given :n:`@pattern` if specified. In case the inferred type + of :n:`@term` does not start with a product the tactic added in the hint list + is :n:`exact @term`. In case this type can however be reduced to a type + starting with a product, the tactic :n:`simple apply @term` is also stored in + the hints list. If the inferred type of :n:`@term` contains a dependent + quantification on a variable which occurs only in the premisses of the type + and not in its conclusion, no instance could be inferred for the variable by + unification with the goal. In this case, the hint is added to the hint list + of :tacn:`eauto` instead of the hint list of auto and a warning is printed. A + typical example of a hint that is used only by :tacn:`eauto` is a transitivity + lemma. - This is used to declare hints that must not be exported to the other modules - that require and import the current module. Inside a section, the option - Local is useless since hints do not survive anyway to the closure of - sections. + .. exn:: @term cannot be used as a hint -.. cmd:: Local Hint hint_definition + The head symbol of the type of :n:`@term` is a bound variable such that + this tactic cannot be associated to a constant. - Idem for the core database. + .. cmdv:: Hint Resolve {+ @term} -The ``hint_definition`` is one of the following expressions: + Adds each :n:`Hint Resolve @term`. -+ :n:`Resolve @term {? | {? @num} {? @pattern}}` - This command adds :n:`simple apply @term` to the hint list with the head symbol of the type of - :n:`@term`. The cost of that hint is the number of subgoals generated by - :n:`simple apply @term` or :n:`@num` if specified. The associated :n:`@pattern` - is inferred from the conclusion of the type of :n:`@term` or the given - :n:`@pattern` if specified. In case the inferred type of :n:`@term` does not - start with a product the tactic added in the hint list is :n:`exact @term`. - In case this type can however be reduced to a type starting with a product, - the tactic :n:`simple apply @term` is also stored in the hints list. If the - inferred type of :n:`@term` contains a dependent quantification on a variable - which occurs only in the premisses of the type and not in its conclusion, no - instance could be inferred for the variable by unification with the goal. In - this case, the hint is added to the hint list of :tacn:`eauto` instead of the - hint list of auto and a warning is printed. A typical example of a hint that - is used only by ``eauto`` is a transitivity lemma. + .. cmdv:: Hint Resolve -> @term - .. exn:: @term cannot be used as a hint + Adds the left-to-right implication of an equivalence as a hint (informally + the hint will be used as :n:`apply <- @term`, although as mentionned + before, the tactic actually used is a restricted version of + :tacn:`apply`). - The head symbol of the type of :n:`@term` is a bound variable such that - this tactic cannot be associated to a constant. + .. cmdv:: Resolve <- @term - **Variants:** + Adds the right-to-left implication of an equivalence as a hint. - + :n:`Resolve {+ @term}` - Adds each :n:`Resolve @term`. + .. cmdv:: Hint Immediate @term + :name: Hint Immediate - + :n:`Resolve -> @term` - Adds the left-to-right implication of an equivalence as a hint (informally - the hint will be used as :n:`apply <- @term`, although as mentionned - before, the tactic actually used is a restricted version of ``apply``). + This command adds :n:`simple apply @term; trivial` to the hint list associated + with the head symbol of the type of :n:`@ident` in the given database. This + tactic will fail if all the subgoals generated by :n:`simple apply @term` are + not solved immediately by the :tacn:`trivial` tactic (which only tries tactics + with cost 0).This command is useful for theorems such as the symmetry of + equality or :g:`n+1=m+1 -> n=m` that we may like to introduce with a limited + use in order to avoid useless proof-search. The cost of this tactic (which + never generates subgoals) is always 1, so that it is not used by :tacn:`trivial` + itself. - + :n:`Resolve <- @term` - Adds the right-to-left implication of an equivalence as a hint. + .. exn:: @term cannot be used as a hint -+ :n:`Immediate @term` - This command adds :n:`simple apply @term; trivial` to the hint list associated - with the head symbol of the type of :n:`@ident` in the given database. This - tactic will fail if all the subgoals generated by :n:`simple apply @term` are - not solved immediately by the ``trivial`` tactic (which only tries tactics - with cost 0).This command is useful for theorems such as the symmetry of - equality or :g:`n+1=m+1 -> n=m` that we may like to introduce with a limited - use in order to avoid useless proof-search.The cost of this tactic (which - never generates subgoals) is always 1, so that it is not used by ``trivial`` - itself. + .. cmdv:: Immediate {+ @term} - .. exn:: @term cannot be used as a hint + Adds each :n:`Hint Immediate @term`. - **Variants:** + .. cmdv:: Hint Constructors @ident + :name: Hint Constructors - + :n:`Immediate {+ @term}` - Adds each :n:`Immediate @term`. + If :n:`@ident` is an inductive type, this command adds all its constructors as + hints of type ``Resolve``. Then, when the conclusion of current goal has the form + :n:`(@ident ...)`, :tacn:`auto` will try to apply each constructor. -+ :n:`Constructors @ident` - If :n:`@ident` is an inductive type, this command adds all its constructors as - hints of type Resolve. Then, when the conclusion of current goal has the form - :n:`(@ident ...)`, ``auto`` will try to apply each constructor. + .. exn:: @ident is not an inductive type - .. exn:: @ident is not an inductive type + .. cmdv:: Hint Constructors {+ @ident} - **Variants:** + Adds each :n:`Hint Constructors @ident`. - + :n:`Constructors {+ @ident}` - Adds each :n:`Constructors @ident`. + .. cmdv:: Hint Unfold @qualid + :name: Hint Unfold -+ :n:`Unfold @qualid` - This adds the tactic :n:`unfold @qualid` to the hint list that will only be - used when the head constant of the goal is :n:`@ident`. - Its cost is 4. + This adds the tactic :n:`unfold @qualid` to the hint list that will only be + used when the head constant of the goal is :n:`@ident`. + Its cost is 4. - **Variants:** + .. cmdv:: Hint Unfold {+ @ident} - + :n:`Unfold {+ @ident}` - Adds each :n:`Unfold @ident`. + Adds each :n:`Hint Unfold @ident`. -+ :n:`Transparent`, :n:`Opaque @qualid` - This adds a transparency hint to the database, making :n:`@qualid` a - transparent or opaque constant during resolution. This information is used - during unification of the goal with any lemma in the database and inside the - discrimination network to relax or constrain it in the case of discriminated - databases. + .. cmdv:: Hint %( Transparent %| Opaque %) @qualid + :name: Hint ( Transparent | Opaque ) - **Variants:** + This adds a transparency hint to the database, making :n:`@qualid` a + transparent or opaque constant during resolution. This information is used + during unification of the goal with any lemma in the database and inside the + discrimination network to relax or constrain it in the case of discriminated + databases. + + .. cmdv:: Hint %( Transparent %| Opaque %) {+ @ident} - + :n:`Transparent`, :n:`Opaque {+ @ident}` Declares each :n:`@ident` as a transparent or opaque constant. -+ :n:`Extern @num {? @pattern} => tactic` - This hint type is to extend ``auto`` with tactics other than ``apply`` and - ``unfold``. For that, we must specify a cost, an optional :n:`@pattern` and a - :n:`tactic` to execute. Here is an example:: - - Hint Extern 4 (~(_ = _)) => discriminate. - - Now, when the head of the goal is a disequality, ``auto`` will try - discriminate if it does not manage to solve the goal with hints with a - cost less than 4. One can even use some sub-patterns of the pattern in - the tactic script. A sub-pattern is a question mark followed by an - identifier, like ``?X1`` or ``?X2``. Here is an example: - - .. example:: - .. coqtop:: reset all - - Require Import List. - Hint Extern 5 ({?X1 = ?X2} + {?X1 <> ?X2}) => generalize X1, X2; decide equality : eqdec. - Goal forall a b:list (nat * nat), {a = b} + {a <> b}. - Info 1 auto with eqdec. - -+ :n:`Cut @regexp` - - .. warning:: these hints currently only apply to typeclass - proof search and the ``typeclasses eauto`` tactic (:ref:`TODO-20.6.5-typeclasseseauto`). - - This command can be used to cut the proof-search tree according to a regular - expression matching paths to be cut. The grammar for regular expressions is - the following. Beware, there is no operator precedence during parsing, one can - check with ``Print HintDb`` to verify the current cut expression: - - .. productionlist:: `regexp` - e : ident hint or instance identifier - :|_ any hint - :| e\|e′ disjunction - :| e e′ sequence - :| e * Kleene star - :| emp empty - :| eps epsilon - :| ( e ) - - The `emp` regexp does not match any search path while `eps` - matches the empty path. During proof search, the path of - successive successful hints on a search branch is recorded, as a - list of identifiers for the hints (note Hint Extern’s do not have - an associated identifier). - Before applying any hint :n:`@ident` the current path `p` extended with - :n:`@ident` is matched against the current cut expression `c` associated to - the hint database. If matching succeeds, the hint is *not* applied. The - semantics of ``Hint Cut e`` is to set the cut expression to ``c | e``, the - initial cut expression being `emp`. - -+ :n:`Mode @qualid {* (+ | ! | -)}` - This sets an optional mode of use of the identifier :n:`@qualid`. When - proof-search faces a goal that ends in an application of :n:`@qualid` to - arguments :n:`@term ... @term`, the mode tells if the hints associated to - :n:`@qualid` can be applied or not. A mode specification is a list of n ``+``, - ``!`` or ``-`` items that specify if an argument of the identifier is to be - treated as an input (``+``), if its head only is an input (``!``) or an output - (``-``) of the identifier. For a mode to match a list of arguments, input - terms and input heads *must not* contain existential variables or be - existential variables respectively, while outputs can be any term. Multiple - modes can be declared for a single identifier, in that case only one mode - needs to match the arguments for the hints to be applied.The head of a term - is understood here as the applicative head, or the match or projection - scrutinee’s head, recursively, casts being ignored. ``Hint Mode`` is - especially useful for typeclasses, when one does not want to support default - instances and avoid ambiguity in general. Setting a parameter of a class as an - input forces proof-search to be driven by that index of the class, with ``!`` - giving more flexibility by allowing existentials to still appear deeper in the - index but not at its head. + .. cmdv:: Hint Extern @num {? @pattern} => @tactic + :name: Hint Extern -.. note:: - One can use an ``Extern`` hint with no pattern to do pattern-matching on - hypotheses using ``match goal`` with inside the tactic. + This hint type is to extend :tacn:`auto` with tactics other than :tacn:`apply` and + :tacn:`unfold`. For that, we must specify a cost, an optional :n:`@pattern` and a + :n:`@tactic` to execute. + + .. example:: + + .. coqtop:: in + + Hint Extern 4 (~(_ = _)) => discriminate. + + Now, when the head of the goal is a disequality, ``auto`` will try + discriminate if it does not manage to solve the goal with hints with a + cost less than 4. + + One can even use some sub-patterns of the pattern in + the tactic script. A sub-pattern is a question mark followed by an + identifier, like ``?X1`` or ``?X2``. Here is an example: + + .. example:: + + .. coqtop:: reset all + + Require Import List. + Hint Extern 5 ({?X1 = ?X2} + {?X1 <> ?X2}) => generalize X1, X2; decide equality : eqdec. + Goal forall a b:list (nat * nat), {a = b} + {a <> b}. + Info 1 auto with eqdec. + + .. cmdv:: Hint Cut @regexp + + .. warning:: + + These hints currently only apply to typeclass proof search and the + :tacn:`typeclasses eauto` tactic. + + This command can be used to cut the proof-search tree according to a regular + expression matching paths to be cut. The grammar for regular expressions is + the following. Beware, there is no operator precedence during parsing, one can + check with :cmd:`Print HintDb` to verify the current cut expression: + + .. productionlist:: `regexp` + e : ident hint or instance identifier + :| _ any hint + :| e\|e′ disjunction + :| e e′ sequence + :| e * Kleene star + :| emp empty + :| eps epsilon + :| ( e ) + + The `emp` regexp does not match any search path while `eps` + matches the empty path. During proof search, the path of + successive successful hints on a search branch is recorded, as a + list of identifiers for the hints (note Hint Extern’s do not have + an associated identifier). + Before applying any hint :n:`@ident` the current path `p` extended with + :n:`@ident` is matched against the current cut expression `c` associated to + the hint database. If matching succeeds, the hint is *not* applied. The + semantics of ``Hint Cut e`` is to set the cut expression to ``c | e``, the + initial cut expression being `emp`. + + .. cmdv:: Hint Mode @qualid {* (+ | ! | -)} + + This sets an optional mode of use of the identifier :n:`@qualid`. When + proof-search faces a goal that ends in an application of :n:`@qualid` to + arguments :n:`@term ... @term`, the mode tells if the hints associated to + :n:`@qualid` can be applied or not. A mode specification is a list of n ``+``, + ``!`` or ``-`` items that specify if an argument of the identifier is to be + treated as an input (``+``), if its head only is an input (``!``) or an output + (``-``) of the identifier. For a mode to match a list of arguments, input + terms and input heads *must not* contain existential variables or be + existential variables respectively, while outputs can be any term. Multiple + modes can be declared for a single identifier, in that case only one mode + needs to match the arguments for the hints to be applied.The head of a term + is understood here as the applicative head, or the match or projection + scrutinee’s head, recursively, casts being ignored. ``Hint Mode`` is + especially useful for typeclasses, when one does not want to support default + instances and avoid ambiguity in general. Setting a parameter of a class as an + input forces proof-search to be driven by that index of the class, with ``!`` + giving more flexibility by allowing existentials to still appear deeper in the + index but not at its head. + + .. note:: + + One can use an ``Extern`` hint with no pattern to do pattern-matching on + hypotheses using ``match goal`` with inside the tactic. Hint databases defined in the Coq standard library @@ -3521,7 +3604,7 @@ at every moment. (left to right). Notice that the rewriting bases are distinct from the ``auto`` hint bases and thatauto does not take them into account. - This command is synchronous with the section mechanism (see :ref:`TODO-2.4-Sectionmechanism`): + This command is synchronous with the section mechanism (see :ref:`section-mechanism`): when closing a section, all aliases created by ``Hint Rewrite`` in that section are lost. Conversely, when loading a module, all ``Hint Rewrite`` declarations at the global level of that module are loaded. @@ -3561,7 +3644,7 @@ described above: either they disappear at the end of a section scope, or they remain global forever. This causes a scalability issue, because hints coming from an unrelated part of the code may badly influence another development. It can be mitigated to some extent -thanks to the ``Remove Hints`` command (see :ref:`Remove Hints <removehints>`), +thanks to the :cmd:`Remove Hints` command, but this is a mere workaround and has some limitations (for instance, external hints cannot be removed). @@ -3569,73 +3652,75 @@ A proper way to fix this issue is to bind the hints to their module scope, as for most of the other objects Coq uses. Hints should only made available when the module they are defined in is imported, not just required. It is very difficult to change the historical behavior, as it would break a lot of scripts. -We propose a smooth transitional path by providing the ``Loose Hint Behavior`` +We propose a smooth transitional path by providing the :opt:`Loose Hint Behavior` option which accepts three flags allowing for a fine-grained handling of non-imported hints. -**Variants:** - -.. cmd:: Set Loose Hint Behavior "Lax" +.. opt:: Loose Hint Behavior %( "Lax" %| "Warn" %| "Strict" %) + :name: Loose Hint Behavior - This is the default, and corresponds to the historical behavior, that - is, hints defined outside of a section have a global scope. + This option accepts three values, which control the behavior of hints w.r.t. + :cmd:`Import`: -.. cmd:: Set Loose Hint Behavior "Warn" + - "Lax": this is the default, and corresponds to the historical behavior, + that is, hints defined outside of a section have a global scope. - When set, it outputs a warning when a non-imported hint is used. Note that - this is an over-approximation, because a hint may be triggered by a run that - will eventually fail and backtrack, resulting in the hint not being actually - useful for the proof. + - "Warn": outputs a warning when a non-imported hint is used. Note that this + is an over-approximation, because a hint may be triggered by a run that + will eventually fail and backtrack, resulting in the hint not being + actually useful for the proof. -.. cmd:: Set Loose Hint Behavior "Strict" + - "Strict": changes the behavior of an unloaded hint to a immediate fail + tactic, allowing to emulate an import-scoped hint mechanism. - When set, it changes the behavior of an unloaded hint to a immediate fail - tactic, allowing to emulate an import-scoped hint mechanism. +.. _tactics-implicit-automation: Setting implicit automation tactics ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -.. cmd:: Proof with tactic +.. cmd:: Proof with @tactic This command may be used to start a proof. It defines a default tactic to be used each time a tactic command ``tactic``:sub:`1` is ended by ``...``. In this case the tactic command typed by the user is equivalent to ``tactic``:sub:`1` ``;tactic``. -See also: Proof. in :ref:`TODO-7.1.4-Proofterm`. + See also: ``Proof.`` in :ref:`proof-editing-mode`. -**Variants:** -.. cmd:: Proof with tactic using {+ @ident} + .. cmdv:: Proof with tactic using {+ @ident} - Combines in a single line ``Proof with`` and ``Proof using``, see :ref:`TODO-7.1.5-Proofusing` + Combines in a single line ``Proof with`` and ``Proof using``, see :ref:`proof-editing-mode` -.. cmd:: Proof using {+ @ident} with tactic + .. cmdv:: Proof using {+ @ident} with @tactic - Combines in a single line ``Proof with`` and ``Proof using``, see :ref:`TODO-7.1.5-Proofusing` + Combines in a single line ``Proof with`` and ``Proof using``, see :ref:`proof-editing-mode` -.. cmd:: Declare Implicit Tactic tactic + .. cmd:: Declare Implicit Tactic @tactic - This command declares a tactic to be used to solve implicit arguments - that Coq does not know how to solve by unification. It is used every - time the term argument of a tactic has one of its holes not fully - resolved. + This command declares a tactic to be used to solve implicit arguments + that Coq does not know how to solve by unification. It is used every + time the term argument of a tactic has one of its holes not fully + resolved. -Here is an example: + .. deprecated:: 8.9 -.. example:: + This command is deprecated. Use :ref:`typeclasses <typeclasses>` or + :ref:`tactics-in-terms <tactics-in-terms>` instead. - .. coqtop:: all + .. example:: - Parameter quo : nat -> forall n:nat, n<>0 -> nat. - Notation "x // y" := (quo x y _) (at level 40). - Declare Implicit Tactic assumption. - Goal forall n m, m<>0 -> { q:nat & { r | q * m + r = n } }. - intros. - exists (n // m). + .. coqtop:: all - The tactic ``exists (n // m)`` did not fail. The hole was solved - by ``assumption`` so that it behaved as ``exists (quo n m H)``. + Parameter quo : nat -> forall n:nat, n<>0 -> nat. + Notation "x // y" := (quo x y _) (at level 40). + Declare Implicit Tactic assumption. + Goal forall n m, m<>0 -> { q:nat & { r | q * m + r = n } }. + intros. + exists (n // m). + + The tactic ``exists (n // m)`` did not fail. The hole was solved + by ``assumption`` so that it behaved as ``exists (quo n m H)``. .. _decisionprocedures: @@ -3680,11 +3765,12 @@ Therefore, the use of :tacn:`intros` in the previous proof is unnecessary. an instantiation of `x` is necessary. .. tacv:: dtauto + :name: dtauto - While :tacn:`tauto` recognizes inductively defined connectives isomorphic to - the standard connective ``and, prod, or, sum, False, Empty_set, unit, True``, - :tacn:`dtauto` recognizes also all inductive types with one constructors and - no indices, i.e. record-style connectives. + While :tacn:`tauto` recognizes inductively defined connectives isomorphic to + the standard connective ``and, prod, or, sum, False, Empty_set, unit, True``, + :tacn:`dtauto` recognizes also all inductive types with one constructors and + no indices, i.e. record-style connectives. .. tacn:: intuition @tactic :name: intuition @@ -3713,7 +3799,7 @@ and then uses :tacn:`auto` which completes the proof. Originally due to César Muñoz, these tactics (:tacn:`tauto` and :tacn:`intuition`) have been completely re-engineered by David Delahaye using -mainly the tactic language (see :ref:`TODO-9-thetacticlanguage`). The code is +mainly the tactic language (see :ref:`ltac`). The code is now much shorter and a significant increase in performance has been noticed. The general behavior with respect to dependent types, unfolding and introductions has slightly changed to get clearer semantics. This may lead to @@ -3721,26 +3807,20 @@ some incompatibilities. .. tacv:: intuition - Is equivalent to :g:`intuition auto with *`. + Is equivalent to :g:`intuition auto with *`. .. tacv:: dintuition + :name: dintuition - While :tacn:`intuition` recognizes inductively defined connectives - isomorphic to the standard connective ``and, prod, or, sum, False, - Empty_set, unit, True``, :tacn:`dintuition` recognizes also all inductive - types with one constructors and no indices, i.e. record-style connectives. - -Some aspects of the tactic :tacn:`intuition` can be controlled using options. -To avoid that inner negations which do not need to be unfolded are -unfolded, use: - -.. cmd:: Unset Intuition Negation Unfolding + While :tacn:`intuition` recognizes inductively defined connectives + isomorphic to the standard connective ``and``, ``prod``, ``or``, ``sum``, ``False``, + ``Empty_set``, ``unit``, ``True``, :tacn:`dintuition` recognizes also all inductive + types with one constructors and no indices, i.e. record-style connectives. +.. opt:: Intuition Negation Unfolding -To do that all negations of the goal are unfolded even inner ones -(this is the default), use: - -.. cmd:: Set Intuition Negation Unfolding + Controls whether :tacn:`intuition` unfolds inner negations which do not need + to be unfolded. This option is on by default. .. tacn:: rtauto :name: rtauto @@ -3764,14 +3844,18 @@ first- order reasoning, written by Pierre Corbineau. It is not restricted to usual logical connectives but instead may reason about any first-order class inductive definition. -The default tactic used by :tacn:`firstorder` when no rule applies is :g:`auto -with \*`, it can be reset locally or globally using the ``Set Firstorder -Solver`` tactic vernacular command and printed using ``Print Firstorder -Solver``. +.. opt:: Firstorder Solver @tactic + + The default tactic used by :tacn:`firstorder` when no rule applies is + :g:`auto with *`, it can be reset locally or globally using this option. + + .. cmd:: Print Firstorder Solver + + Prints the default tactic used by :tacn:`firstorder` when no rule applies. .. tacv:: firstorder @tactic - Tries to solve the goal with :n:`@tactic` when no logical rule may apply. + Tries to solve the goal with :n:`@tactic` when no logical rule may apply. .. tacv:: firstorder using {+ @qualid} @@ -3788,8 +3872,9 @@ Solver``. This combines the effects of the different variants of :tacn:`firstorder`. -Proof-search is bounded by a depth parameter which can be set by -typing the ``Set Firstorder Depth n`` vernacular command. +.. opt:: Firstorder Depth @num + + This option controls the proof-search depth bound. .. tacn:: congruence :name: congruence @@ -3830,11 +3915,12 @@ match against it. hypotheses using assert in order for :tacn:`congruence` to use them. .. tacv:: congruence with {+ @term} + :name: congruence with - Adds :n:`{+ @term}` to the pool of terms used by :tacn:`congruence`. This helps - in case you have partially applied constructors in your goal. + Adds :n:`{+ @term}` to the pool of terms used by :tacn:`congruence`. This helps + in case you have partially applied constructors in your goal. -.. exn:: I don’t know how to handle dependent equality +.. exn:: I don’t know how to handle dependent equality. The decision procedure managed to find a proof of the goal or of a discriminable equality but this proof could not be built in Coq because of @@ -3846,7 +3932,7 @@ match against it. arguments are supplied for some partially applied constructors. Any term of an appropriate type will allow the tactic to successfully solve the goal. Those additional arguments can be given to congruence by filling in the holes in the - terms given in the error message, using the with variant described above. + terms given in the error message, using the :tacn:`congruence with` variant described above. .. opt:: Congruence Verbose @@ -3865,7 +3951,7 @@ succeeds, and results in an error otherwise. This tactic checks whether its arguments are equal modulo alpha conversion and casts. -.. exn:: Not equal +.. exn:: Not equal. .. tacn:: unify @term @term :name: unify @@ -3873,12 +3959,12 @@ succeeds, and results in an error otherwise. This tactic checks whether its arguments are unifiable, potentially instantiating existential variables. -.. exn:: Not unifiable +.. exn:: Not unifiable. .. tacv:: unify @term @term with @ident Unification takes the transparency information defined in the hint database - :n:`@ident` into account (see :ref:`the hints databases for auto and eauto <the-hints-databases-for-auto-and-eauto>`). + :n:`@ident` into account (see :ref:`the hints databases for auto and eauto <thehintsdatabasesforautoandeauto>`). .. tacn:: is_evar @term :name: is_evar @@ -3887,7 +3973,7 @@ succeeds, and results in an error otherwise. variable. Existential variables are uninstantiated variables generated by :tacn:`eapply` and some other tactics. -.. exn:: Not an evar +.. exn:: Not an evar. .. tacn:: has_evar @term :name: has_evar @@ -3896,7 +3982,7 @@ succeeds, and results in an error otherwise. a subterm. Unlike context patterns combined with ``is_evar``, this tactic scans all subterms, including those under binders. -.. exn:: No evars +.. exn:: No evars. .. tacn:: is_var @term :name: is_var @@ -3904,7 +3990,7 @@ succeeds, and results in an error otherwise. This tactic checks whether its argument is a variable or hypothesis in the current goal context or in the opened sections. -.. exn:: Not a variable or hypothesis +.. exn:: Not a variable or hypothesis. .. _equality: @@ -3928,10 +4014,10 @@ solved by :tacn:`f_equal`. :name: reflexivity This tactic applies to a goal that has the form :g:`t=u`. It checks that `t` -and `u` are convertible and then solves the goal. It is equivalent to apply -:tacn:`refl_equal`. +and `u` are convertible and then solves the goal. It is equivalent to +``apply refl_equal``. -.. exn:: The conclusion is not a substitutive equation +.. exn:: The conclusion is not a substitutive equation. .. exn:: Unable to unify ... with ... @@ -4009,6 +4095,7 @@ symbol :g:`=`. .. tacv:: esimplify_eq @num .. tacv:: esimplify_eq @term {? with @bindings_list} + :name: esimplify_eq This works the same as ``simplify_eq`` but if the type of :n:`@term`, or the type of the hypothesis referred to by :n:`@num`, has uninstantiated @@ -4031,6 +4118,7 @@ symbol :g:`=`. :tacn:`injection` and :tacn:`inversion` tactics. .. tacv:: dependent rewrite <- @ident + :name: dependent rewrite <- Analogous to :tacn:`dependent rewrite ->` but uses the equality from right to left. @@ -4044,12 +4132,12 @@ Inversion :tacn:`functional inversion` is a tactic that performs inversion on hypothesis :n:`@ident` of the form :n:`@qualid {+ @term} = @term` or :n:`@term = @qualid {+ @term}` where :n:`@qualid` must have been defined using Function (see -:ref:`TODO-2.3-advancedrecursivefunctions`). Note that this tactic is only +:ref:`advanced-recursive-functions`). Note that this tactic is only available after a ``Require Import FunInd``. -.. exn:: Hypothesis @ident must contain at least one Function -.. exn:: Cannot find inversion information for hypothesis @ident +.. exn:: Hypothesis @ident must contain at least one Function. +.. exn:: Cannot find inversion information for hypothesis @ident. This error may be raised when some inversion lemma failed to be generated by Function. @@ -4077,10 +4165,10 @@ This kind of inversion has nothing to do with the tactic :tacn:`inversion` above. This tactic does :g:`change (@ident t)`, where `t` is a term built in order to ensure the convertibility. In other words, it does inversion of the function :n:`@ident`. This function must be a fixpoint on a simple recursive -datatype: see :ref:`TODO-10.3-quote` for the full details. +datatype: see :ref:`quote` for the full details. -.. exn:: quote: not a simple fixpoint +.. exn:: quote: not a simple fixpoint. Happens when quote is not able to perform inversion properly. @@ -4109,6 +4197,8 @@ using the ``Require Import`` command. Use ``classical_right`` to prove the right part of the disjunction with the assumption that the negation of left part holds. +.. _tactics-automatizing: + Automatizing ------------ @@ -4148,7 +4238,7 @@ formulas built with `~`, `\/`, `/\`, `->` on top of equalities, inequalities and disequalities on both the type :g:`nat` of natural numbers and :g:`Z` of binary integers. This tactic must be loaded by the command ``Require Import Omega``. See the additional documentation about omega -(see Chapter :ref:`TODO-21-omega`). +(see Chapter :ref:`omega`). .. tacn:: ring @@ -4168,7 +4258,7 @@ given in the conclusion of the goal by their normal forms. If no term is given, then the conclusion should be an equation and both hand sides are normalized. -See :ref:`TODO-Chapter-25-Theringandfieldtacticfamilies` for more information on +See :ref:`Theringandfieldtacticfamilies` for more information on the tactic and how to declare new ring structures. All declared field structures can be printed with the ``Print Rings`` command. @@ -4194,7 +4284,7 @@ denominators. So it produces an equation without division nor inverse. All of these 3 tactics may generate a subgoal in order to prove that denominators are different from zero. -See :ref:`TODO-Chapter-25-Theringandfieldtacticfamilies` for more information on the tactic and how to +See :ref:`Theringandfieldtacticfamilies` for more information on the tactic and how to declare new field structures. All declared field structures can be printed with the Print Fields command. @@ -4286,24 +4376,24 @@ This tactics reverses the list of the focused goals. This tactic moves all goals under focus to a shelf. While on the shelf, goals will not be focused on. They can be solved by unification, or they can be called back into focus with the command - :tacn:`Unshelve`. + :cmd:`Unshelve`. -.. tacv:: shelve_unifiable + .. tacv:: shelve_unifiable + :name: shelve_unifiable - Shelves only the goals under focus that are mentioned in other goals. - Goals that appear in the type of other goals can be solved by unification. + Shelves only the goals under focus that are mentioned in other goals. + Goals that appear in the type of other goals can be solved by unification. -.. example:: + .. example:: - .. coqtop:: all reset + .. coqtop:: all reset - Goal exists n, n=0. - refine (ex_intro _ _ _). - all:shelve_unifiable. - reflexivity. + Goal exists n, n=0. + refine (ex_intro _ _ _). + all: shelve_unifiable. + reflexivity. -.. tacn:: Unshelve - :name: Unshelve +.. cmd:: Unshelve This command moves all the goals on the shelf (see :tacn:`shelve`) from the shelf into focus, by appending them to the end of the current @@ -4334,11 +4424,11 @@ A simple example has more value than a long explanation: The tactics macros are synchronous with the Coq section mechanism: a tactic definition is deleted from the current environment when you -close the section (see also :ref:`TODO-2.4Sectionmechanism`) where it was +close the section (see also :ref:`section-mechanism`) where it was defined. If you want that a tactic macro defined in a module is usable in the modules that require it, you should put it outside of any section. -:ref:`TODO-9-Thetacticlanguage` gives examples of more complex +:ref:`ltac` gives examples of more complex user-defined tactics. .. [1] Actually, only the second subgoal will be generated since the diff --git a/doc/sphinx/proof-engine/vernacular-commands.rst b/doc/sphinx/proof-engine/vernacular-commands.rst new file mode 100644 index 000000000..c37233734 --- /dev/null +++ b/doc/sphinx/proof-engine/vernacular-commands.rst @@ -0,0 +1,1242 @@ +.. include:: ../preamble.rst +.. include:: ../replaces.rst + +.. _vernacularcommands: + +Vernacular commands +============================= + +.. _displaying: + +Displaying +-------------- + + +.. _Print: + +.. cmd:: Print @qualid + :name: Print + + This command displays on the screen information about the declared or + defined object referred by :n:`@qualid`. + + Error messages: + + .. exn:: @qualid not a defined object. + + .. exn:: Universe instance should have length @num. + + .. exn:: This object does not support universe names. + + + .. cmdv:: Print Term @qualid + :name: Print Term + + This is a synonym of :cmd:`Print` :n:`@qualid` when :n:`@qualid` + denotes a global constant. + + .. cmdv:: Print {? Term } @qualid\@@name + + This locally renames the polymorphic universes of :n:`@qualid`. + An underscore means the raw universe is printed. + + +.. cmd:: About @qualid + :name: About + + This displays various information about the object + denoted by :n:`@qualid`: its kind (module, constant, assumption, inductive, + constructor, abbreviation, …), long name, type, implicit arguments and + argument scopes. It does not print the body of definitions or proofs. + + .. cmdv:: About @qualid\@@name + + This locally renames the polymorphic universes of :n:`@qualid`. + An underscore means the raw universe is printed. + + +.. cmd:: Print All + + This command displays information about the current state of the + environment, including sections and modules. + + .. cmdv:: Inspect @num + :name: Inspect + + This command displays the :n:`@num` last objects of the + current environment, including sections and modules. + + .. cmdv:: Print Section @ident + + The name :n:`@ident` should correspond to a currently open section, + this command displays the objects defined since the beginning of this + section. + + +.. _flags-options-tables: + +Flags, Options and Tables +----------------------------- + +|Coq| configurability is based on flags (e.g. :opt:`Printing All`), options +(e.g. :opt:`Printing Width`), or tables (e.g. :cmd:`Add Printing Record`). The +names of flags, options and tables are made of non-empty sequences of +identifiers (conventionally with capital initial letter). The general commands +handling flags, options and tables are given below. + +.. TODO : flag is not a syntax entry + +.. cmd:: Set @flag + + This command switches :n:`@flag` on. The original state of :n:`@flag` + is restored when the current module ends. + + .. cmdv:: Local Set @flag + + This command switches :n:`@flag` on. The original state + of :n:`@flag` is restored when the current *section* ends. + + .. cmdv:: Global Set @flag + + This command switches :n:`@flag` on. The original state + of :n:`@flag` is *not* restored at the end of the module. Additionally, if + set in a file, :n:`@flag` is switched on when the file is `Require`-d. + + .. cmdv:: Export Set @flag + + This command switches :n:`@flag` on. The original state + of :n:`@flag` is restored at the end of the current module, but :n:`@flag` + is switched on when this module is imported. + + +.. cmd:: Unset @flag + + This command switches :n:`@flag` off. The original state of + :n:`@flag` is restored when the current module ends. + + .. cmdv:: Local Unset @flag + + This command switches :n:`@flag` off. The original + state of :n:`@flag` is restored when the current *section* ends. + + .. cmdv:: Global Unset @flag + + This command switches :n:`@flag` off. The original + state of :n:`@flag` is *not* restored at the end of the module. Additionally, + if set in a file, :n:`@flag` is switched off when the file is `Require`-d. + + .. cmdv:: Export Unset @flag + + This command switches :n:`@flag` off. The original state + of :n:`@flag` is restored at the end of the current module, but :n:`@flag` + is switched off when this module is imported. + + +.. cmd:: Test @flag + + This command prints whether :n:`@flag` is on or off. + + +.. cmd:: Set @option @value + + This command sets :n:`@option` to :n:`@value`. The original value of ` option` is + restored when the current module ends. + + .. TODO : option and value are not syntax entries + + .. cmdv:: Local Set @option @value + + This command sets :n:`@option` to :n:`@value`. The + original value of :n:`@option` is restored at the end of the module. + + .. cmdv:: Global Set @option @value + + This command sets :n:`@option` to :n:`@value`. The + original value of :n:`@option` is *not* restored at the end of the module. + Additionally, if set in a file, :n:`@option` is set to value when the file + is `Require`-d. + + .. cmdv:: Export Set @option + + This command set :n:`@option` to :n:`@value`. The original state + of :n:`@option` is restored at the end of the current module, but :n:`@option` + is set to :n:`@value` when this module is imported. + + +.. cmd:: Unset @option + + This command turns off :n:`@option`. + + .. cmdv:: Local Unset @option + + This command turns off :n:`@option`. The original state of :n:`@option` + is restored when the current *section* ends. + + .. cmdv:: Global Unset @option + + This command turns off :n:`@option`. The original state of :n:`@option` + is *not* restored at the end of the module. Additionally, if unset in a file, + :n:`@option` is reset to its default value when the file is `Require`-d. + + .. cmdv:: Export Unset @option + + This command turns off :n:`@option`. The original state of :n:`@option` + is restored at the end of the current module, but :n:`@option` is set to + its default value when this module is imported. + + +.. cmd:: Test @option + + This command prints the current value of :n:`@option`. + + +.. TODO : table is not a syntax entry + +.. cmd:: Add @table @value + :name: Add `table` `value` + +.. cmd:: Remove @table @value + :name: Remove `table` `value` + +.. cmd:: Test @table @value + :name: Test `table` `value` + +.. cmd:: Test @table for @value + :name: Test `table` for `value` + +.. cmd:: Print Table @table + +These are general commands for tables. + + +.. cmd:: Print Options + + This command lists all available flags, options and tables. + + .. cmdv:: Print Tables + + This is a synonymous of :cmd:`Print Options`. + + +.. _requests-to-the-environment: + +Requests to the environment +------------------------------- + +.. cmd:: Check @term + + This command displays the type of :n:`@term`. When called in proof mode, the + term is checked in the local context of the current subgoal. + + + .. TODO : selector is not a syntax entry + + .. cmdv:: @selector: Check @term + + This variant specifies on which subgoal to perform typing + (see Section :ref:`invocation-of-tactics`). + + +.. TODO : convtactic is not a syntax entry + +.. cmd:: Eval @convtactic in @term + + This command performs the specified reduction on :n:`@term`, and displays + the resulting term with its type. The term to be reduced may depend on + hypothesis introduced in the first subgoal (if a proof is in + progress). + + See also: Section :ref:`performingcomputations`. + + +.. cmd:: Compute @term + + This command performs a call-by-value evaluation of term by using the + bytecode-based virtual machine. It is a shortcut for ``Eval vm_compute in`` + :n:`@term`. + + See also: Section :ref:`performingcomputations`. + + +.. cmd:: Print Assumptions @qualid + + This commands display all the assumptions (axioms, parameters and + variables) a theorem or definition depends on. Especially, it informs + on the assumptions with respect to which the validity of a theorem + relies. + + .. cmdv:: Print Opaque Dependencies @qualid + :name: Print Opaque Dependencies + + Displays the set of opaque constants :n:`@qualid` relies on in addition to + the assumptions. + + .. cmdv:: Print Transparent Dependencies @qualid + :name: Print Transparent Dependencies + + Displays the set of transparent constants :n:`@qualid` relies on + in addition to the assumptions. + + .. cmdv:: Print All Dependencies @qualid + :name: Print All Dependencies + + Displays all assumptions and constants :n:`@qualid` relies on. + + +.. cmd:: Search @qualid + + This command displays the name and type of all objects (hypothesis of + the current goal, theorems, axioms, etc) of the current context whose + statement contains :n:`@qualid`. This command is useful to remind the user + of the name of library lemmas. + + .. exn:: The reference @qualid was not found in the current environment. + + There is no constant in the environment named qualid. + + .. cmdv:: Search @string + + If :n:`@string` is a valid identifier, this command + displays the name and type of all objects (theorems, axioms, etc) of + the current context whose name contains string. If string is a + notation’s string denoting some reference :n:`@qualid` (referred to by its + main symbol as in `"+"` or by its notation’s string as in `"_ + _"` or + `"_ 'U' _"`, see Section :ref:`notations`), the command works like ``Search`` :n:`@qualid`. + + .. cmdv:: Search @string%@key + + The string string must be a notation or the main + symbol of a notation which is then interpreted in the scope bound to + the delimiting key :n:`@key` (see Section :ref:`LocalInterpretationRulesForNotations`). + + .. cmdv:: Search @term_pattern + + This searches for all statements or types of + definition that contains a subterm that matches the pattern + `term_pattern` (holes of the pattern are either denoted by `_` or by + `?ident` when non linear patterns are expected). + + .. cmdv:: Search { + [-]@term_pattern_string } + + where + :n:`@term_pattern_string` is a term_pattern, a string, or a string followed + by a scope delimiting key `%key`. This generalization of ``Search`` searches + for all objects whose statement or type contains a subterm matching + :n:`@term_pattern` (or :n:`@qualid` if :n:`@string` is the notation for a reference + qualid) and whose name contains all string of the request that + correspond to valid identifiers. If a term_pattern or a string is + prefixed by `-`, the search excludes the objects that mention that + term_pattern or that string. + + .. cmdv:: Search @term_pattern_string … @term_pattern_string inside {+ @qualid } + + This restricts the search to constructions defined in the modules + named by the given :n:`qualid` sequence. + + .. cmdv:: Search @term_pattern_string … @term_pattern_string outside {+ @qualid } + + This restricts the search to constructions not defined in the modules + named by the given :n:`qualid` sequence. + + .. cmdv:: @selector: Search [-]@term_pattern_string … [-]@term_pattern_string + + This specifies the goal on which to search hypothesis (see + Section :ref:`invocation-of-tactics`). + By default the 1st goal is searched. This variant can + be combined with other variants presented here. + + .. example:: + + .. coqtop:: in + + Require Import ZArith. + + .. coqtop:: all + + Search Z.mul Z.add "distr". + + Search "+"%Z "*"%Z "distr" -positive -Prop. + + Search (?x * _ + ?x * _)%Z outside OmegaLemmas. + + .. cmdv:: SearchAbout + :name: SearchAbout + + .. deprecated:: 8.5 + + Up to |Coq| version 8.4, :cmd:`Search` had the behavior of current + :cmd:`SearchHead` and the behavior of current :cmd:`Search` was obtained with + command :cmd:`SearchAbout`. For compatibility, the deprecated name + :cmd:`SearchAbout` can still be used as a synonym of :cmd:`Search`. For + compatibility, the list of objects to search when using :cmd:`SearchAbout` + may also be enclosed by optional ``[ ]`` delimiters. + + +.. cmd:: SearchHead @term + + This command displays the name and type of all hypothesis of the + current goal (if any) and theorems of the current context whose + statement’s conclusion has the form `(term t1 .. tn)`. This command is + useful to remind the user of the name of library lemmas. + + .. example:: + + .. coqtop:: reset all + + SearchHead le. + + SearchHead (@eq bool). + + .. cmdv:: SearchHead @term inside {+ @qualid } + + This restricts the search to constructions defined in the modules named + by the given :n:`qualid` sequence. + + .. cmdv:: SearchHead term outside {+ @qualid } + + This restricts the search to constructions not defined in the modules + named by the given :n:`qualid` sequence. + + .. exn:: Module/section @qualid not found. + + No module :n:`@qualid` has been required (see Section :ref:`compiled-files`). + + .. cmdv:: @selector: SearchHead @term + + This specifies the goal on which to + search hypothesis (see Section :ref:`invocation-of-tactics`). + By default the 1st goal is searched. This variant can be combined + with other variants presented here. + + .. note:: Up to |Coq| version 8.4, ``SearchHead`` was named ``Search``. + + +.. cmd:: SearchPattern @term + + This command displays the name and type of all hypothesis of the + current goal (if any) and theorems of the current context whose + statement’s conclusion or last hypothesis and conclusion matches the + expressionterm where holes in the latter are denoted by `_`. + It is a variant of :n:`Search @term_pattern` that does not look for subterms + but searches for statements whose conclusion has exactly the expected + form, or whose statement finishes by the given series of + hypothesis/conclusion. + + .. example:: + + .. coqtop:: in + + Require Import Arith. + + .. coqtop:: all + + SearchPattern (_ + _ = _ + _). + + SearchPattern (nat -> bool). + + SearchPattern (forall l : list _, _ l l). + + Patterns need not be linear: you can express that the same expression + must occur in two places by using pattern variables `?ident`. + + + .. example:: + + .. coqtop:: all + + SearchPattern (?X1 + _ = _ + ?X1). + + .. cmdv:: SearchPattern @term inside {+ @qualid } + + This restricts the search to constructions defined in the modules + named by the given :n:`qualid` sequence. + + .. cmdv:: SearchPattern @term outside {+ @qualid } + + This restricts the search to constructions not defined in the modules + named by the given :n:`qualid` sequence. + + .. cmdv:: @selector: SearchPattern @term + + This specifies the goal on which to + search hypothesis (see Section :ref:`invocation-of-tactics`). + By default the 1st goal is + searched. This variant can be combined with other variants presented + here. + + +.. cmd:: SearchRewrite @term + + This command displays the name and type of all hypothesis of the + current goal (if any) and theorems of the current context whose + statement’s conclusion is an equality of which one side matches the + expression term. Holes in term are denoted by “_”. + + .. example:: + + .. coqtop:: in + + Require Import Arith. + + .. coqtop:: all + + SearchRewrite (_ + _ + _). + + .. cmdv:: SearchRewrite term inside {+ @qualid } + + This restricts the search to constructions defined in the modules + named by the given :n:`qualid` sequence. + + .. cmdv:: SearchRewrite @term outside {+ @qualid } + + This restricts the search to constructions not defined in the modules + named by the given :n:`qualid` sequence. + + .. cmdv:: @selector: SearchRewrite @term + + This specifies the goal on which to + search hypothesis (see Section :ref:`invocation-of-tactics`). + By default the 1st goal is + searched. This variant can be combined with other variants presented + here. + +.. note:: + + .. cmd:: Add Search Blacklist @string + + For the ``Search``, ``SearchHead``, ``SearchPattern`` and ``SearchRewrite`` + queries, it is possible to globally filter the search results using this + command. A lemma whose fully-qualified name + contains any of the declared strings will be removed from the + search results. The default blacklisted substrings are ``_subproof`` and + ``Private_``. + + .. cmd:: Remove Search Blacklist @string + + This command allows expunging this blacklist. + + +.. cmd:: Locate @qualid + + This command displays the full name of objects whose name is a prefix + of the qualified identifier :n:`@qualid`, and consequently the |Coq| module in + which they are defined. It searches for objects from the different + qualified name spaces of |Coq|: terms, modules, Ltac, etc. + + .. example:: + + .. coqtop:: all + + Locate nat. + + Locate Datatypes.O. + + Locate Init.Datatypes.O. + + Locate Coq.Init.Datatypes.O. + + Locate I.Dont.Exist. + + .. cmdv:: Locate Term @qualid + + As Locate but restricted to terms. + + .. cmdv:: Locate Module @qualid + + As Locate but restricted to modules. + + .. cmdv:: Locate Ltac @qualid + + As Locate but restricted to tactics. + +See also: Section :ref:`locating-notations` + + +.. _loading-files: + +Loading files +----------------- + +|Coq| offers the possibility of loading different parts of a whole +development stored in separate files. Their contents will be loaded as +if they were entered from the keyboard. This means that the loaded +files are ASCII files containing sequences of commands for |Coq|’s +toplevel. This kind of file is called a *script* for |Coq|. The standard +(and default) extension of |Coq|’s script files is .v. + + +.. cmd:: Load @ident + + This command loads the file named :n:`ident`.v, searching successively in + each of the directories specified in the *loadpath*. (see Section + :ref:`libraries-and-filesystem`) + + Files loaded this way cannot leave proofs open, and the ``Load`` + command cannot be used inside a proof either. + + .. cmdv:: Load @string + + Loads the file denoted by the string :n:`@string`, where + string is any complete filename. Then the `~` and .. abbreviations are + allowed as well as shell variables. If no extension is specified, |Coq| + will use the default extension ``.v``. + + .. cmdv:: Load Verbose @ident + + .. cmdv:: Load Verbose @string + + Display, while loading, + the answers of |Coq| to each command (including tactics) contained in + the loaded file See also: Section :ref:`controlling-display`. + + .. exn:: Can’t find file @ident on loadpath. + + .. exn:: Load is not supported inside proofs. + + .. exn:: Files processed by Load cannot leave open proofs. + +.. _compiled-files: + +Compiled files +------------------ + +This section describes the commands used to load compiled files (see +Chapter :ref:`thecoqcommands` for documentation on how to compile a file). A compiled +file is a particular case of module called *library file*. + + +.. cmd:: Require @qualid + + This command looks in the loadpath for a file containing module :n:`@qualid` + and adds the corresponding module to the environment of |Coq|. As + library files have dependencies in other library files, the command + :cmd:`Require` :n:`@qualid` recursively requires all library files the module + qualid depends on and adds the corresponding modules to the + environment of |Coq| too. |Coq| assumes that the compiled files have been + produced by a valid |Coq| compiler and their contents are then not + replayed nor rechecked. + + To locate the file in the file system, :n:`@qualid` is decomposed under the + form `dirpath.ident` and the file `ident.vo` is searched in the physical + directory of the file system that is mapped in |Coq| loadpath to the + logical path dirpath (see Section :ref:`libraries-and-filesystem`). The mapping between + physical directories and logical names at the time of requiring the + file must be consistent with the mapping used to compile the file. If + several files match, one of them is picked in an unspecified fashion. + + + .. cmdv:: Require Import @qualid + :name: Require Import + + This loads and declares the module :n:`@qualid` + and its dependencies then imports the contents of :n:`@qualid` as described + :ref:`here <import_qualid>`. It does not import the modules on which + qualid depends unless these modules were themselves required in module + :n:`@qualid` + using :cmd:`Require Export`, as described below, or recursively required + through a sequence of :cmd:`Require Export`. If the module required has + already been loaded, :cmd:`Require Import` :n:`@qualid` simply imports it, as + :cmd:`Import` :n:`@qualid` would. + + .. cmdv:: Require Export @qualid + :name: Require Export + + This command acts as :cmd:`Require Import` :n:`@qualid`, + but if a further module, say `A`, contains a command :cmd:`Require Export` `B`, + then the command :cmd:`Require Import` `A` also imports the module `B.` + + .. cmdv:: Require [Import | Export] {+ @qualid } + + This loads the + modules named by the :n:`qualid` sequence and their recursive + dependencies. If + ``Import`` or ``Export`` is given, it also imports these modules and + all the recursive dependencies that were marked or transitively marked + as ``Export``. + + .. cmdv:: From @dirpath Require @qualid + + This command acts as :cmd:`Require`, but picks + any library whose absolute name is of the form dirpath.dirpath’.qualid + for some `dirpath’`. This is useful to ensure that the :n:`@qualid` library + comes from a given package by making explicit its absolute root. + + .. exn:: Cannot load qualid: no physical path bound to dirpath. + + .. exn:: Cannot find library foo in loadpath. + + The command did not find the + file foo.vo. Either foo.v exists but is not compiled or foo.vo is in a + directory which is not in your LoadPath (see Section :ref:`libraries-and-filesystem`). + + .. exn:: Compiled library @ident.vo makes inconsistent assumptions over library qualid. + + The command tried to load library file :n:`@ident`.vo that + depends on some specific version of library :n:`@qualid` which is not the + one already loaded in the current |Coq| session. Probably `ident.v` was + not properly recompiled with the last version of the file containing + module :n:`@qualid`. + + .. exn:: Bad magic number. + + The file `ident.vo` was found but either it is not a + |Coq| compiled module, or it was compiled with an incompatible + version of |Coq|. + + .. exn:: The file `ident.vo` contains library dirpath and not library dirpath’. + + The library file `dirpath’` is indirectly required by the + ``Require`` command but it is bound in the current loadpath to the + file `ident.vo` which was bound to a different library name `dirpath` at + the time it was compiled. + + + .. exn:: Require is not allowed inside a module or a module type. + + This command + is not allowed inside a module or a module type being defined. It is + meant to describe a dependency between compilation units. Note however + that the commands ``Import`` and ``Export`` alone can be used inside modules + (see Section :ref:`Import <import_qualid>`). + + + +See also: Chapter :ref:`thecoqcommands` + + +.. cmd:: Print Libraries + + This command displays the list of library files loaded in the + current |Coq| session. For each of these libraries, it also tells if it + is imported. + + +.. cmd:: Declare ML Module {+ @string } + + This commands loads the OCaml compiled files + with names given by the :n:`@string` sequence + (dynamic link). It is mainly used to load tactics dynamically. The + files are searched into the current OCaml loadpath (see the + command ``Add ML Path`` in Section :ref:`libraries-and-filesystem`). + Loading of OCaml files is only possible under the bytecode version of + ``coqtop`` (i.e. ``coqtop`` called with option ``-byte``, see chapter + :ref:`thecoqcommands`), or when |Coq| has been compiled with a + version of OCaml that supports native Dynlink (≥ 3.11). + + .. cmdv:: Local Declare ML Module {+ @string } + + This variant is not exported to the modules that import the module + where they occur, even if outside a section. + + .. exn:: File not found on loadpath: @string. + + .. exn:: Loading of ML object file forbidden in a native Coq. + + +.. cmd:: Print ML Modules + + This prints the name of all OCaml modules loaded with ``Declare + ML Module``. To know from where these module were loaded, the user + should use the command ``Locate File`` (see :ref:`here <locate-file>`) + + +.. _loadpath: + +Loadpath +------------ + +Loadpaths are preferably managed using |Coq| command line options (see +Section `libraries-and-filesystem`) but there remain vernacular commands to manage them +for practical purposes. Such commands are only meant to be issued in +the toplevel, and using them in source files is discouraged. + + +.. cmd:: Pwd + + This command displays the current working directory. + + +.. cmd:: Cd @string + + This command changes the current directory according to :n:`@string` which + can be any valid path. + + .. cmdv:: Cd + + Is equivalent to Pwd. + + +.. cmd:: Add LoadPath @string as @dirpath + + This command is equivalent to the command line option + ``-Q`` :n:`@string` :n:`@dirpath`. It adds the physical directory string to the current + |Coq| loadpath and maps it to the logical directory dirpath. + + .. cmdv:: Add LoadPath @string + + Performs as Add LoadPath :n:`@string` as :n:`@dirpath` but + for the empty directory path. + + +.. cmd:: Add Rec LoadPath @string as @dirpath + + This command is equivalent to the command line option + ``-R`` :n:`@string` :n:`@dirpath`. It adds the physical directory string and all its + subdirectories to the current |Coq| loadpath. + + .. cmdv:: Add Rec LoadPath @string + + Works as :cmd:`Add Rec LoadPath` :n:`@string` as :n:`@dirpath` but for the empty + logical directory path. + + +.. cmd:: Remove LoadPath @string + + This command removes the path :n:`@string` from the current |Coq| loadpath. + + +.. cmd:: Print LoadPath + + This command displays the current |Coq| loadpath. + + .. cmdv:: Print LoadPath @dirpath + + Works as :cmd:`Print LoadPath` but displays only + the paths that extend the :n:`@dirpath` prefix. + + +.. cmd:: Add ML Path @string + + This command adds the path :n:`@string` to the current OCaml + loadpath (see the command `Declare ML Module`` in Section :ref:`compiled-files`). + + +.. cmd:: Add Rec ML Path @string + + This command adds the directory :n:`@string` and all its subdirectories to + the current OCaml loadpath (see the command :cmd:`Declare ML Module`). + + +.. cmd:: Print ML Path @string + + This command displays the current OCaml loadpath. This + command makes sense only under the bytecode version of ``coqtop``, i.e. + using option ``-byte`` + (see the command Declare ML Module in Section :ref:`compiled-files`). + +.. _locate-file: + +.. cmd:: Locate File @string + + This command displays the location of file string in the current + loadpath. Typically, string is a .cmo or .vo or .v file. + + +.. cmd:: Locate Library @dirpath + + This command gives the status of the |Coq| module dirpath. It tells if + the module is loaded and if not searches in the load path for a module + of logical name :n:`@dirpath`. + + +.. _backtracking: + +Backtracking +---------------- + +The backtracking commands described in this section can only be used +interactively, they cannot be part of a vernacular file loaded via +``Load`` or compiled by ``coqc``. + + +.. cmd:: Reset @ident + + This command removes all the objects in the environment since :n:`@ident` + was introduced, including :n:`@ident`. :n:`@ident` may be the name of a defined or + declared object as well as the name of a section. One cannot reset + over the name of a module or of an object inside a module. + + .. exn:: @ident: no such entry. + + .. cmdv:: Reset Initial + + Goes back to the initial state, just after the start + of the interactive session. + + +.. cmd:: Back + + This command undoes all the effects of the last vernacular command. + Commands read from a vernacular file via a :cmd:`Load` are considered as a + single command. Proof management commands are also handled by this + command (see Chapter :ref:`proofhandling`). For that, Back may have to undo more than + one command in order to reach a state where the proof management + information is available. For instance, when the last command is a + :cmd:`Qed`, the management information about the closed proof has been + discarded. In this case, :cmd:`Back` will then undo all the proof steps up to + the statement of this proof. + + .. cmdv:: Back @num + + Undo :n:`@num` vernacular commands. As for Back, some extra + commands may be undone in order to reach an adequate state. For + instance Back :n:`@num` will not re-enter a closed proof, but rather go just + before that proof. + + .. exn:: Invalid backtrack. + + The user wants to undo more commands than available in the history. + +.. cmd:: BackTo @num + + This command brings back the system to the state labeled :n:`@num`, + forgetting the effect of all commands executed after this state. The + state label is an integer which grows after each successful command. + It is displayed in the prompt when in -emacs mode. Just as :cmd:`Back` (see + above), the :cmd:`BackTo` command now handles proof states. For that, it may + have to undo some extra commands and end on a state `num′ ≤ num` if + necessary. + + .. cmdv:: Backtrack @num @num @num + :name: Backtrack + + .. deprecated:: 8.4 + + :cmd:`Backtrack` is a *deprecated* form of + :cmd:`BackTo` which allows explicitly manipulating the proof environment. The + three numbers represent the following: + + + *first number* : State label to reach, as for :cmd:`BackTo`. + + *second number* : *Proof state number* to unbury once aborts have been done. + |Coq| will compute the number of :cmd:`Undo` to perform (see Chapter :ref:`proofhandling`). + + *third number* : Number of :cmd:`Abort` to perform, i.e. the number of currently + opened nested proofs that must be canceled (see Chapter :ref:`proofhandling`). + + .. exn:: Invalid backtrack. + + The destination state label is unknown. + + +.. _quitting-and-debugging: + +Quitting and debugging +-------------------------- + + +.. cmd:: Quit + + This command permits to quit |Coq|. + + +.. cmd:: Drop + + This is used mostly as a debug facility by |Coq|’s implementors and does + not concern the casual user. This command permits to leave |Coq| + temporarily and enter the OCaml toplevel. The OCaml + command: + + :: + + #use "include";; + + adds the right loadpaths and loads some toplevel printers for all + abstract types of |Coq|- section_path, identifiers, terms, judgments, …. + You can also use the file base_include instead, that loads only the + pretty-printers for section_paths and identifiers. You can return back + to |Coq| with the command: + + :: + + go();; + + .. warning:: + + #. It only works with the bytecode version of |Coq| (i.e. `coqtop.byte`, + see Section `interactive-use`). + #. You must have compiled |Coq| from the source package and set the + environment variable COQTOP to the root of your copy of the sources + (see Section `customization-by-environment-variables`). + + +.. TODO : command is not a syntax entry + +.. cmd:: Time @command + + This command executes the vernacular command :n:`@command` and displays the + time needed to execute it. + + +.. cmd:: Redirect @string @command + + This command executes the vernacular command :n:`@command`, redirecting its + output to ":n:`@string`.out". + + +.. cmd:: Timeout @num @command + + This command executes the vernacular command :n:`@command`. If the command + has not terminated after the time specified by the :n:`@num` (time + expressed in seconds), then it is interrupted and an error message is + displayed. + + .. opt:: Default Timeout @num + + This option controls a default timeout for subsequent commands, as if they + were passed to a :cmd:`Timeout` command. Commands already starting by a + :cmd:`Timeout` are unaffected. + + +.. cmd:: Fail @command + + For debugging scripts, sometimes it is desirable to know + whether a command or a tactic fails. If the given :n:`@command` + fails, the ``Fail`` statement succeeds, without changing the proof + state, and in interactive mode, the system + prints a message confirming the failure. + If the given :n:`@command` succeeds, the statement is an error, and + it prints a message indicating that the failure did not occur. + + .. exn:: The command has not failed! + + +.. _controlling-display: + +Controlling display +----------------------- + +.. opt:: Silent + + This option controls the normal displaying. + +.. opt:: Warnings "{+, {? %( - %| + %) } @ident }" + + This option configures the display of warnings. It is experimental, and + expects, between quotes, a comma-separated list of warning names or + categories. Adding - in front of a warning or category disables it, adding + + makes it an error. It is possible to use the special categories all and + default, the latter containing the warnings enabled by default. The flags are + interpreted from left to right, so in case of an overlap, the flags on the + right have higher priority, meaning that `A,-A` is equivalent to `-A`. + +.. opt:: Search Output Name Only + + This option restricts the output of search commands to identifier names; + turning it on causes invocations of :cmd:`Search`, :cmd:`SearchHead`, + :cmd:`SearchPattern`, :cmd:`SearchRewrite` etc. to omit types from their + output, printing only identifiers. + +.. opt:: Printing Width @num + :name: Printing Width + + This command sets which left-aligned part of the width of the screen is used + for display. At the time of writing this documentation, the default value + is 78. + +.. opt:: Printing Depth @num + :name: Printing Depth + + This option controls the nesting depth of the formatter used for pretty- + printing. Beyond this depth, display of subterms is replaced by dots. At the + time of writing this documentation, the default value is 50. + +.. opt:: Printing Compact Contexts + + This option controls the compact display mode for goals contexts. When on, + the printer tries to reduce the vertical size of goals contexts by putting + several variables (even if of different types) on the same line provided it + does not exceed the printing width (see :opt:`Printing Width`). At the time + of writing this documentation, it is off by default. + +.. opt:: Printing Unfocused + + This option controls whether unfocused goals are displayed. Such goals are + created by focusing other goals with bullets (see :ref:`bullets` or + :ref:`curly braces <curly-braces>`). It is off by default. + +.. opt:: Printing Dependent Evars Line + + This option controls the printing of the “(dependent evars: …)” line when + ``-emacs`` is passed. + + +.. _vernac-controlling-the-reduction-strategies: + +Controlling the reduction strategies and the conversion algorithm +---------------------------------------------------------------------- + + +|Coq| provides reduction strategies that the tactics can invoke and two +different algorithms to check the convertibility of types. The first +conversion algorithm lazily compares applicative terms while the other +is a brute-force but efficient algorithm that first normalizes the +terms before comparing them. The second algorithm is based on a +bytecode representation of terms similar to the bytecode +representation used in the ZINC virtual machine :cite:`Leroy90`. It is +especially useful for intensive computation of algebraic values, such +as numbers, and for reflection-based tactics. The commands to fine- +tune the reduction strategies and the lazy conversion algorithm are +described first. + +.. cmd:: Opaque {+ @qualid } + + This command has an effect on unfoldable constants, i.e. on constants + defined by :cmd:`Definition` or :cmd:`Let` (with an explicit body), or by a command + assimilated to a definition such as :cmd:`Fixpoint`, :cmd:`Program Definition`, etc, + or by a proof ended by :cmd:`Defined`. The command tells not to unfold the + constants in the :n:`@qualid` sequence in tactics using δ-conversion (unfolding + a constant is replacing it by its definition). + + :cmd:`Opaque` has also an effect on the conversion algorithm of |Coq|, telling + it to delay the unfolding of a constant as much as possible when |Coq| + has to check the conversion (see Section :ref:`conversion-rules`) of two distinct + applied constants. + + .. cmdv:: Global Opaque {+ @qualid } + :name: Global Opaque + + The scope of :cmd:`Opaque` is limited to the current section, or current + file, unless the variant :cmd:`Global Opaque` is used. + + See also: sections :ref:`performingcomputations`, :ref:`tactics-automatizing`, + :ref:`proof-editing-mode` + + .. exn:: The reference @qualid was not found in the current environment. + + There is no constant referred by :n:`@qualid` in the environment. + Nevertheless, if you asked :cmd:`Opaque` `foo` `bar` and if `bar` does + not exist, `foo` is set opaque. + +.. cmd:: Transparent {+ @qualid } + + This command is the converse of :cmd:`Opaque` and it applies on unfoldable + constants to restore their unfoldability after an Opaque command. + + Note in particular that constants defined by a proof ended by Qed are + not unfoldable and Transparent has no effect on them. This is to keep + with the usual mathematical practice of *proof irrelevance*: what + matters in a mathematical development is the sequence of lemma + statements, not their actual proofs. This distinguishes lemmas from + the usual defined constants, whose actual values are of course + relevant in general. + + .. cmdv:: Global Transparent {+ @qualid } + :name: Global Transparent + + The scope of Transparent is limited to the current section, or current + file, unless the variant :cmd:`Global Transparent` is + used. + + .. exn:: The reference @qualid was not found in the current environment. + + There is no constant referred by :n:`@qualid` in the environment. + + See also: sections :ref:`performingcomputations`, + :ref:`tactics-automatizing`, :ref:`proof-editing-mode` + +.. _vernac-strategy: + +.. cmd:: Strategy @level [ {+ @qualid } ] + + This command generalizes the behavior of Opaque and Transparent + commands. It is used to fine-tune the strategy for unfolding + constants, both at the tactic level and at the kernel level. This + command associates a level to the qualified names in the :n:`@qualid` + sequence. Whenever two + expressions with two distinct head constants are compared (for + instance, this comparison can be triggered by a type cast), the one + with lower level is expanded first. In case of a tie, the second one + (appearing in the cast type) is expanded. + + Levels can be one of the following (higher to lower): + + + ``opaque`` : level of opaque constants. They cannot be expanded by + tactics (behaves like +∞, see next item). + + :n:`@num` : levels indexed by an integer. Level 0 corresponds to the + default behavior, which corresponds to transparent constants. This + level can also be referred to as transparent. Negative levels + correspond to constants to be expanded before normal transparent + constants, while positive levels correspond to constants to be + expanded after normal transparent constants. + + ``expand`` : level of constants that should be expanded first (behaves + like −∞) + + .. cmdv:: Local Strategy @level [ {+ @qualid } ] + + These directives survive section and module closure, unless the + command is prefixed by ``Local``. In the latter case, the behavior + regarding sections and modules is the same as for the :cmd:`Transparent` and + :cmd:`Opaque` commands. + + +.. cmd:: Print Strategy @qualid + + This command prints the strategy currently associated to :n:`@qualid`. It + fails if :n:`@qualid` is not an unfoldable reference, that is, neither a + variable nor a constant. + + .. exn:: The reference is not unfoldable. + + .. cmdv:: Print Strategies + + Print all the currently non-transparent strategies. + + +.. cmd:: Declare Reduction @ident := @convtactic + + This command allows giving a short name to a reduction expression, for + instance lazy beta delta [foo bar]. This short name can then be used + in ``Eval`` :n:`@ident` ``in`` ... or ``eval`` directives. This command + accepts the + Local modifier, for discarding this reduction name at the end of the + file or module. For the moment the name cannot be qualified. In + particular declaring the same name in several modules or in several + functor applications will be refused if these declarations are not + local. The name :n:`@ident` cannot be used directly as an Ltac tactic, but + nothing prevents the user to also perform a + ``Ltac`` `ident` ``:=`` `convtactic`. + + See also: sections :ref:`performingcomputations` + + +.. _controlling-locality-of-commands: + +Controlling the locality of commands +----------------------------------------- + + +.. cmd:: Local @command +.. cmd:: Global @command + +Some commands support a Local or Global prefix modifier to control the +scope of their effect. There are four kinds of commands: + + ++ Commands whose default is to extend their effect both outside the + section and the module or library file they occur in. For these + commands, the Local modifier limits the effect of the command to the + current section or module it occurs in. As an example, the :cmd:`Coercion` + and :cmd:`Strategy` commands belong to this category. ++ Commands whose default behavior is to stop their effect at the end + of the section they occur in but to extent their effect outside the module or + library file they occur in. For these commands, the Local modifier limits the + effect of the command to the current module if the command does not occur in a + section and the Global modifier extends the effect outside the current + sections and current module if the command occurs in a section. As an example, + the :cmd:`Arguments`, :cmd:`Ltac` or :cmd:`Notation` commands belong + to this category. Notice that a subclass of these commands do not support + extension of their scope outside sections at all and the Global is not + applicable to them. ++ Commands whose default behavior is to stop their effect at the end + of the section or module they occur in. For these commands, the ``Global`` + modifier extends their effect outside the sections and modules they + occurs in. The :cmd:`Transparent` and :cmd:`Opaque` + (see Section :ref:`vernac-controlling-the-reduction-strategies`) commands + belong to this category. ++ Commands whose default behavior is to extend their effect outside + sections but not outside modules when they occur in a section and to + extend their effect outside the module or library file they occur in + when no section contains them.For these commands, the Local modifier + limits the effect to the current section or module while the Global + modifier extends the effect outside the module even when the command + occurs in a section. The :cmd:`Set` and :cmd:`Unset` commands belong to this + category. diff --git a/doc/sphinx/replaces.rst b/doc/sphinx/replaces.rst index 1b2e17221..28a04f90c 100644 --- a/doc/sphinx/replaces.rst +++ b/doc/sphinx/replaces.rst @@ -35,7 +35,9 @@ .. |ident_n,1| replace:: `ident`\ :math:`_{n,1}` .. |ident_n,k_n| replace:: `ident`\ :math:`_{n,k_n}` .. |ident_n| replace:: `ident`\ :math:`_{n}` +.. |Latex| replace:: :smallcaps:`LaTeX` .. |L_tac| replace:: `L`:sub:`tac` +.. |Ltac| replace:: `L`:sub:`tac` .. |ML| replace:: :smallcaps:`ML` .. |mod_0| replace:: `mod`\ :math:`_{0}` .. |mod_1| replace:: `mod`\ :math:`_{1}` @@ -54,7 +56,7 @@ .. |module_type_n| replace:: `module_type`\ :math:`_{n}` .. |N| replace:: ``N`` .. |nat| replace:: ``nat`` -.. |Ocaml| replace:: :smallcaps:`OCaml` +.. |OCaml| replace:: :smallcaps:`OCaml` .. |p_1| replace:: `p`\ :math:`_{1}` .. |p_i| replace:: `p`\ :math:`_{i}` .. |p_n| replace:: `p`\ :math:`_{n}` diff --git a/doc/sphinx/user-extensions/proof-schemes.rst b/doc/sphinx/user-extensions/proof-schemes.rst index 583b73e53..838926d65 100644 --- a/doc/sphinx/user-extensions/proof-schemes.rst +++ b/doc/sphinx/user-extensions/proof-schemes.rst @@ -3,6 +3,8 @@ Proof schemes =============== +.. _proofschemes-induction-principles: + Generation of induction principles with ``Scheme`` -------------------------------------------------------- @@ -10,7 +12,7 @@ The ``Scheme`` command is a high-level tool for generating automatically (possibly mutual) induction principles for given types and sorts. Its syntax follows the schema: -.. cmd:: Scheme ident := Induction for ident' Sort sort {* with ident := Induction for ident' Sort sort} +.. cmd:: Scheme @ident := Induction for @ident Sort sort {* with @ident := Induction for @ident Sort sort} where each `ident'ᵢ` is a different inductive type identifier belonging to the same package of mutual inductive definitions. This @@ -18,17 +20,18 @@ command generates the `identᵢ`s to be mutually recursive definitions. Each term `identᵢ` proves a general principle of mutual induction for objects in type `identᵢ`. -.. cmdv:: Scheme ident := Minimality for ident' Sort sort {* with ident := Minimality for ident' Sort sort} +.. cmdv:: Scheme @ident := Minimality for @ident Sort sort {* with @ident := Minimality for @ident' Sort sort} Same as before but defines a non-dependent elimination principle more natural in case of inductively defined relations. -.. cmdv:: Scheme Equality for ident +.. cmdv:: Scheme Equality for @ident + :name: Scheme Equality Tries to generate a Boolean equality and a proof of the decidability of the usual equality. If `ident` involves some other inductive types, their equality has to be defined first. -.. cmdv:: Scheme Induction for ident Sort sort {* with Induction for ident Sort sort} +.. cmdv:: Scheme Induction for @ident Sort sort {* with Induction for @ident Sort sort} If you do not provide the name of the schemes, they will be automatically computed from the sorts involved (works also with Minimality). @@ -101,26 +104,34 @@ induction for objects in type `identᵢ`. Automatic declaration of schemes ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -It is possible to deactivate the automatic declaration of the -induction principles when defining a new inductive type with the -``Unset Elimination Schemes`` command. It may be reactivated at any time with -``Set Elimination Schemes``. - -The types declared with the keywords ``Variant`` (see :ref:`TODO-1.3.3`) and ``Record`` -(see :ref:`Record Types <record-types>`) do not have an automatic declaration of the induction -principles. It can be activated with the command -``Set Nonrecursive Elimination Schemes``. It can be deactivated again with -``Unset Nonrecursive Elimination Schemes``. - -In addition, the ``Case Analysis Schemes`` flag governs the generation of -case analysis lemmas for inductive types, i.e. corresponding to the -pattern-matching term alone and without fixpoint. -You can also activate the automatic declaration of those Boolean -equalities (see the second variant of ``Scheme``) with respectively the -commands ``Set Boolean Equality Schemes`` and ``Set Decidable Equality -Schemes``. However you have to be careful with this option since Coq may -now reject well-defined inductive types because it cannot compute a -Boolean equality for them. +.. opt:: Elimination Schemes + + It is possible to deactivate the automatic declaration of the + induction principles when defining a new inductive type with the + ``Unset Elimination Schemes`` command. It may be reactivated at any time with + ``Set Elimination Schemes``. + +.. opt:: Nonrecursive Elimination Schemes + + This option controls whether types declared with the keywords :cmd:`Variant` and + :cmd:`Record` get an automatic declaration of the induction principles. + +.. opt:: Case Analysis Schemes + + This flag governs the generation of case analysis lemmas for inductive types, + i.e. corresponding to the pattern-matching term alone and without fixpoint. + +.. opt:: Boolean Equality Schemes + +.. opt:: Decidable Equality Schemes + + These flags control the automatic declaration of those Boolean equalities (see + the second variant of ``Scheme``). + +.. warning:: + + You have to be careful with this option since Coq may now reject well-defined + inductive types because it cannot compute a Boolean equality for them. .. opt:: Rewriting Schemes @@ -133,7 +144,7 @@ The ``Combined Scheme`` command is a tool for combining induction principles generated by the ``Scheme command``. Its syntax follows the schema : -.. cmd:: Combined Scheme ident from {+, ident} +.. cmd:: Combined Scheme @ident from {+, ident} where each identᵢ after the ``from`` is a different inductive principle that must belong to the same package of mutual inductive principle definitions. @@ -163,6 +174,8 @@ concluded by the conjunction of their conclusions. Check tree_forest_mutind. +.. _functional-scheme: + Generation of induction principles with ``Functional`` ``Scheme`` ----------------------------------------------------------------- @@ -172,7 +185,7 @@ generating automatically induction principles corresponding to available via ``Require Import FunInd``. Its syntax then follows the schema: -.. cmd:: Functional Scheme ident := Induction for ident' Sort sort {* with ident := Induction for ident' Sort sort} +.. cmd:: Functional Scheme @ident := Induction for ident' Sort sort {* with @ident := Induction for @ident Sort sort} where each `ident'ᵢ` is a different mutually defined function name (the names must be in the same order as when they were defined). This @@ -229,7 +242,7 @@ definition written by the user. simpl; auto with arith. Qed. - We can use directly the functional induction (:ref:`TODO-8.5.5`) tactic instead + We can use directly the functional induction (:tacn:`function induction`) tactic instead of the pattern/apply trick: .. coqtop:: all @@ -305,13 +318,15 @@ definition written by the user. .. coqtop:: all Check tree_size_ind2. + +.. _derive-inversion: Generation of inversion principles with ``Derive`` ``Inversion`` ----------------------------------------------------------------- The syntax of ``Derive`` ``Inversion`` follows the schema: -.. cmd:: Derive Inversion ident with forall (x : T), I t Sort sort +.. cmd:: Derive Inversion @ident with forall (x : T), I t Sort sort This command generates an inversion principle for the `inversion … using` tactic. Let `I` be an inductive predicate and `x` the variables occurring @@ -320,17 +335,17 @@ sort `sort` corresponding to the instance `∀ (x:T), I t` with the name `ident` in the global environment. When applied, it is equivalent to having inverted the instance with the tactic `inversion`. -.. cmdv:: Derive Inversion_clear ident with forall (x:T), I t Sort sort +.. cmdv:: Derive Inversion_clear @ident with forall (x:T), I t Sort sort When applied, it is equivalent to having inverted the instance with the tactic inversion replaced by the tactic `inversion_clear`. -.. cmdv:: Derive Dependent Inversion ident with forall (x:T), I t Sort sort +.. cmdv:: Derive Dependent Inversion @ident with forall (x:T), I t Sort sort When applied, it is equivalent to having inverted the instance with the tactic `dependent inversion`. -.. cmdv:: Derive Dependent Inversion_clear ident with forall(x:T), I t Sort sort +.. cmdv:: Derive Dependent Inversion_clear @ident with forall(x:T), I t Sort sort When applied, it is equivalent to having inverted the instance with the tactic `dependent inversion_clear`. diff --git a/doc/sphinx/user-extensions/syntax-extensions.rst b/doc/sphinx/user-extensions/syntax-extensions.rst index 6e6d66447..3b95a37ed 100644 --- a/doc/sphinx/user-extensions/syntax-extensions.rst +++ b/doc/sphinx/user-extensions/syntax-extensions.rst @@ -10,12 +10,12 @@ parses and prints objects, i.e. the translations between the concrete and internal representations of terms and commands. The main commands to provide custom symbolic notations for terms are -``Notation`` and ``Infix``. They are described in section 12.1. There is also a +``Notation`` and ``Infix``. They are described in section :ref:`Notations`. There is also a variant of ``Notation`` which does not modify the parser. This provides with a form of abbreviation and it is described in Section :ref:`Abbreviations`. It is sometimes expected that the same symbolic notation has different meanings in different contexts. To achieve this form of overloading, |Coq| offers a notion -of interpretation scope. This is described in Section :ref:`scopes`. +of interpretation scope. This is described in Section :ref:`Scopes`. The main command to provide custom notations for tactics is ``Tactic Notation``. It is described in Section :ref:`TacticNotation`. @@ -24,12 +24,16 @@ It is described in Section :ref:`TacticNotation`. Set Printing Depth 50. +.. _Notations: + Notations --------- Basic notations ~~~~~~~~~~~~~~~ +.. cmd:: Notation + A *notation* is a symbolic expression denoting some term or term pattern. @@ -68,7 +72,7 @@ have to be given. .. note:: The right-hand side of a notation is interpreted at the time the notation is - given. In particular, disambiguiation of constants, implicit arguments (see + given. In particular, disambiguation of constants, implicit arguments (see Section :ref:`ImplicitArguments`), coercions (see Section :ref:`Coercions`), etc. are resolved at the time of the declaration of the notation. @@ -196,7 +200,7 @@ need to force the parsing level of y, as follows. For the sake of factorization with Coq predefined rules, simple rules have to be observed for notations starting with a symbol: e.g. rules starting with “{” or “(” should be put at level 0. The list of Coq -predefined notations can be found in Chapter 3. +predefined notations can be found in Chapter :ref:`thecoqlibrary`. .. cmd:: Print Grammar constr. @@ -343,13 +347,13 @@ inductive type or a recursive constant and a notation for it. Simultaneous definition of terms and notations ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Thanks to reserved notations, the inductive, co-inductive, record, recursive -and corecursive definitions can benefit of customized notations. To do -this, insert a ``where`` notation clause after the definition of the -(co)inductive type or (co)recursive term (or after the definition of -each of them in case of mutual definitions). The exact syntax is given -on Figure 12.1 for inductive, co-inductive, recursive and corecursive -definitions and on Figure :ref:`record-syntax` for records. Here are examples: +Thanks to reserved notations, the inductive, co-inductive, record, recursive and +corecursive definitions can benefit of customized notations. To do this, insert +a ``where`` notation clause after the definition of the (co)inductive type or +(co)recursive term (or after the definition of each of them in case of mutual +definitions). The exact syntax is given by :token:`decl_notation` for inductive, +co-inductive, recursive and corecursive definitions and in :ref:`record-types` +for records. Here are examples: .. coqtop:: in @@ -379,23 +383,21 @@ Displaying informations about notations :opt:`Printing All` To disable other elements in addition to notations. +.. _locating-notations: + Locating notations ~~~~~~~~~~~~~~~~~~ -.. cmd:: Locate @symbol - - To know to which notations a given symbol belongs to, use the command - ``Locate symbol``, where symbol is any (composite) symbol surrounded by double - quotes. To locate a particular notation, use a string where the variables of the - notation are replaced by “_” and where possible single quotes inserted around - identifiers or tokens starting with a single quote are dropped. +To know to which notations a given symbol belongs to, use the :cmd:`Locate` +command. You can call it on any (composite) symbol surrounded by double quotes. +To locate a particular notation, use a string where the variables of the +notation are replaced by “_” and where possible single quotes inserted around +identifiers or tokens starting with a single quote are dropped. - .. coqtop:: all - - Locate "exists". - Locate "exists _ .. _ , _". +.. coqtop:: all - .. todo:: See also: Section 6.3.10. + Locate "exists". + Locate "exists _ .. _ , _". Notations and binders ~~~~~~~~~~~~~~~~~~~~~ @@ -433,8 +435,7 @@ Binders bound in the notation and parsed as patterns In the same way as patterns can be used as binders, as in :g:`fun '(x,y) => x+y` or :g:`fun '(existT _ x _) => x`, notations can be -defined so that any pattern (in the sense of the entry :n:`@pattern` of -Figure :ref:`term-syntax-aux`) can be used in place of the +defined so that any :n:`@pattern` can be used in place of the binder. Here is an example: .. coqtop:: in reset @@ -473,7 +474,7 @@ variable. Here is an example showing the difference: The default level for a ``pattern`` is 0. One can use a different level by using ``pattern at level`` :math:`n` where the scale is the same as the one for -terms (Figure :ref:`init-notations`). +terms (see :ref:`init-notations`). Binders bound in the notation and parsed as terms +++++++++++++++++++++++++++++++++++++++++++++++++ @@ -489,7 +490,7 @@ the following: This is so because the grammar also contains rules starting with :g:`{}` and followed by a term, such as the rule for the notation :g:`{ A } + { B }` for the -constant :g:`sumbool` (see Section :ref:`sumbool`). +constant :g:`sumbool` (see Section :ref:`specification`). Then, in the rule, ``x ident`` is replaced by ``x at level 99 as ident`` meaning that ``x`` is parsed as a term at level 99 (as done in the notation for @@ -689,8 +690,7 @@ side. E.g.: Summary ~~~~~~~ -Syntax of notations -~~~~~~~~~~~~~~~~~~~ +**Syntax of notations** The different syntactic variants of the command Notation are given on the following figure. The optional :token:`scope` is described in the Section 12.2. @@ -743,8 +743,7 @@ following figure. The optional :token:`scope` is described in the Section 12.2. given to some notation, say ``"{ y } & { z }"`` in fact applies to the underlying ``"{ x }"``\-free rule which is ``"y & z"``). -Persistence of notations -~~~~~~~~~~~~~~~~~~~~~~~~ +**Persistence of notations** Notations do not survive the end of sections. @@ -753,6 +752,8 @@ Notations do not survive the end of sections. Notations survive modules unless the command ``Local Notation`` is used instead of ``Notation``. +.. _Scopes: + Interpretation scopes ---------------------- @@ -827,6 +828,8 @@ lonely notations. These scopes, in opening order, are ``core_scope``, These variants survive sections. They behave as if Global were absent when not inside a section. +.. _LocalInterpretationRulesForNotations: + Local interpretation rules for notations ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -857,6 +860,7 @@ Binding arguments of a constant to an interpretation scope +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ .. cmd:: Arguments @qualid {+ @name%@scope} + :name: Arguments (scopes) It is possible to set in advance that some arguments of a given constant have to be interpreted in a given scope. The command is @@ -895,7 +899,7 @@ Binding arguments of a constant to an interpretation scope .. cmdv:: Arguments @qualid {+ @name%scope} : extra scopes Defines extra argument scopes, to be used in case of coercion to Funclass - (see Chapter :ref:`Coercions-full`) or with a computed type. + (see Chapter :ref:`implicitcoercions`) or with a computed type. .. cmdv:: Global Arguments @qualid {+ @name%@scope} @@ -912,9 +916,8 @@ Binding arguments of a constant to an interpretation scope .. seealso:: - :cmd:`About @qualid` - The command to show the scopes bound to the arguments of a - function is described in Section 2. + The command :cmd:`About` can be used to show the scopes bound to the + arguments of a function. .. note:: @@ -955,7 +958,7 @@ Binding types of arguments to an interpretation scope type :g:`t` in :g:`f t a` is not recognized as an argument to be interpreted in scope ``scope``. - More generally, any coercion :n:`@class` (see Chapter :ref:`Coercions-full`) + More generally, any coercion :n:`@class` (see Chapter :ref:`implicitcoercions`) can be bound to an interpretation scope. The command to do it is :n:`Bind Scope @scope with @class` @@ -1125,6 +1128,8 @@ Displaying informations about scopes class of all the existing interpretation scopes. It also displays the lonely notations. +.. _Abbreviations: + Abbreviations -------------- @@ -1187,6 +1192,8 @@ Abbreviations denoted expression is performed at definition time. Type-checking is done only at the time of use of the abbreviation. +.. _TacticNotation: + Tactic Notations ----------------- @@ -1194,7 +1201,7 @@ Tactic notations allow to customize the syntax of the tactics of the tactic language. Tactic notations obey the following syntax: .. productionlist:: coq - tacn : [Local] Tactic Notation [`tactic_level`] [`prod_item` … `prod_item`] := `tactic`. + tacn : Tactic Notation [`tactic_level`] [`prod_item` … `prod_item`] := `tactic`. prod_item : `string` | `tactic_argument_type`(`ident`) tactic_level : (at level `natural`) tactic_argument_type : ident | simple_intropattern | reference @@ -1205,7 +1212,7 @@ tactic language. Tactic notations obey the following syntax: : | tactic | tactic0 | tactic1 | tactic2 | tactic3 : | tactic4 | tactic5 -.. cmd:: {? Local} Tactic Notation {? (at level @level)} {+ @prod_item} := @tactic. +.. cmd:: Tactic Notation {? (at level @level)} {+ @prod_item} := @tactic. A tactic notation extends the parser and pretty-printer of tactics with a new rule made of the list of production items. It then evaluates into the diff --git a/doc/tools/coqrst/coqdoc/main.py b/doc/tools/coqrst/coqdoc/main.py index d464f75bb..cedd60d3b 100644 --- a/doc/tools/coqrst/coqdoc/main.py +++ b/doc/tools/coqrst/coqdoc/main.py @@ -32,14 +32,15 @@ COQDOC_OPTIONS = ['--body-only', '--no-glob', '--no-index', '--no-externals', COQDOC_SYMBOLS = ["->", "<-", "<->", "=>", "<=", ">=", "<>", "~", "/\\", "\\/", "|-", "*", "forall", "exists"] COQDOC_HEADER = "".join("(** remove printing {} *)".format(s) for s in COQDOC_SYMBOLS) -def coqdoc(coq_code, coqdoc_bin = os.path.join(os.getenv("COQBIN"),"coqdoc")): +def coqdoc(coq_code, coqdoc_bin=None): """Get the output of coqdoc on coq_code.""" + coqdoc_bin = coqdoc_bin or os.path.join(os.getenv("COQBIN"), "coqdoc") fd, filename = mkstemp(prefix="coqdoc-", suffix=".v") try: os.write(fd, COQDOC_HEADER.encode("utf-8")) os.write(fd, coq_code.encode("utf-8")) os.close(fd) - return check_output([coqdoc_bin] + COQDOC_OPTIONS + [filename], timeout = 2).decode("utf-8") + return check_output([coqdoc_bin] + COQDOC_OPTIONS + [filename], timeout = 10).decode("utf-8") finally: os.remove(filename) diff --git a/doc/tools/coqrst/coqdomain.py b/doc/tools/coqrst/coqdomain.py index 663ab9d37..ab3a485b2 100644 --- a/doc/tools/coqrst/coqdomain.py +++ b/doc/tools/coqrst/coqdomain.py @@ -1,3 +1,4 @@ +# -*- coding: utf-8 -*- ########################################################################## ## # The Coq Proof Assistant / The Coq Development Team ## ## v # INRIA, CNRS and contributors - Copyright 1999-2018 ## @@ -57,30 +58,37 @@ def make_target(objtype, targetid): return "coq:{}.{}".format(objtype, targetid) class CoqObject(ObjectDescription): - """A generic Coq object; all Coq objects are subclasses of this. + """A generic Coq object for Sphinx; all Coq objects are subclasses of this. The fields and methods to override are listed at the top of this class' implementation. Each object supports the :name: option, which gives an explicit name to link to. - See the documentation of CoqDomain for high-level information. + See the comments and docstrings in CoqObject for more information. """ - # The semantic domain in which this object lives. + # The semantic domain in which this object lives (eg. “tac”, “cmd”, “chm”…). # It matches exactly one of the roles used for cross-referencing. - subdomain = None + subdomain = None # type: str - # The suffix to use in indices for objects of this type - index_suffix = None + # The suffix to use in indices for objects of this type (eg. “(tac)”) + index_suffix = None # type: str # The annotation to add to headers of objects of this type - annotation = None + # (eg. “Command”, “Theorem”) + annotation = None # type: str def _name_from_signature(self, signature): # pylint: disable=no-self-use, unused-argument """Convert a signature into a name to link to. + ‘Signature’ is Sphinx parlance for an object's header (think “type + signature”); for example, the signature of the simplest form of the + ``exact`` tactic is ``exact @id``. + Returns None by default, in which case no name will be automatically - generated. + generated. This is a convenient way to automatically generate names + (link targets) without having to write explicit names everywhere. + """ return None @@ -89,8 +97,10 @@ class CoqObject(ObjectDescription): raise NotImplementedError(self) option_spec = { - # One can give an explicit name to each documented object - 'name': directives.unchanged + # Explicit object naming + 'name': directives.unchanged, + # Silence warnings produced by report_undocumented_coq_objects + 'undocumented': directives.flag } def _subdomain(self): @@ -100,7 +110,7 @@ class CoqObject(ObjectDescription): def handle_signature(self, signature, signode): """Prefix signature with the proper annotation, then render it using - _render_signature. + ``_render_signature`` (for example, add “Command” in front of commands). :returns: the name given to the resulting node, if any """ @@ -108,12 +118,7 @@ class CoqObject(ObjectDescription): annotation = self.annotation + ' ' signode += addnodes.desc_annotation(annotation, annotation) self._render_signature(signature, signode) - return self._name_from_signature(signature) - - @property - def _index_suffix(self): - if self.index_suffix: - return " " + self.index_suffix + return self._names.get(signature) or self._name_from_signature(signature) def _record_name(self, name, target_id): """Record a name, mapping it to target_id @@ -141,20 +146,14 @@ class CoqObject(ObjectDescription): return targetid def _add_index_entry(self, name, target): - """Add name (with target) to the main index.""" - index_text = name + self._index_suffix + """Add `name` (pointing to `target`) to the main index.""" + index_text = name + if self.index_suffix: + index_text += " " + self.index_suffix self.indexnode['entries'].append(('single', index_text, target, '', None)) - def run(self): - """Small extension of the parent's run method, handling user-provided names.""" - [idx, node] = super().run() - custom_name = self.options.get("name") - if custom_name: - self.add_target_and_index(custom_name, "", node.children[0]) - return [idx, node] - def add_target_and_index(self, name, _, signode): - """Create a target and an index entry for name""" + """Attach a link target to `signode` and an index entry for `name`.""" if name: target = self._add_target(signode, name) # remove trailing . , found in commands, but not ... (ellipsis) @@ -163,57 +162,151 @@ class CoqObject(ObjectDescription): self._add_index_entry(name, target) return target + def _warn_if_undocumented(self): + document = self.state.document + config = document.settings.env.config + report = config.report_undocumented_coq_objects + if report and not self.content and "undocumented" not in self.options: + # This is annoyingly convoluted, but we don't want to raise warnings + # or interrupt the generation of the current node. For more details + # see https://github.com/sphinx-doc/sphinx/issues/4976. + msg = 'No contents in directive {}'.format(self.name) + node = document.reporter.info(msg, line=self.lineno) + getLogger(__name__).info(node.astext()) + if report == "warning": + raise self.warning(msg) + + def _prepare_names(self): + sigs = self.get_signatures() + names = self.options.get("name") + if names is None: + self._names = {} + else: + names = [n.strip() for n in names.split(";")] + if len(names) != len(sigs): + ERR = ("Expected {} semicolon-separated names, got {}. " + + "Please provide one name per signature line.") + raise self.error(ERR.format(len(names), len(sigs))) + self._names = dict(zip(sigs, names)) + + def run(self): + self._warn_if_undocumented() + self._prepare_names() + return super().run() + class PlainObject(CoqObject): - """A base class for objects whose signatures should be rendered literaly.""" + """A base class for objects whose signatures should be rendered literally.""" def _render_signature(self, signature, signode): signode += addnodes.desc_name(signature, signature) class NotationObject(CoqObject): - """A base class for objects whose signatures should be rendered as nested boxes.""" + """A base class for objects whose signatures should be rendered as nested boxes. + + Objects that inherit from this class can use the notation grammar (“{+ …}”, + “@…”, etc.) in their signature. + """ def _render_signature(self, signature, signode): position = self.state_machine.get_source_and_line(self.lineno) tacn_node = parse_notation(signature, *position) signode += addnodes.desc_name(signature, '', tacn_node) -class TacticObject(PlainObject): - """An object to represent Coq tactics""" - subdomain = "tac" - index_suffix = "(tac)" - annotation = None - class GallinaObject(PlainObject): - """An object to represent Coq theorems""" + r"""A theorem. + + Example:: + + .. thm:: Bound on the ceiling function + + Let :math:`p` be an integer and :math:`c` a rational constant. Then + :math:`p \ge c \rightarrow p \ge \lceil{c}\rceil`. + """ subdomain = "thm" index_suffix = "(thm)" annotation = "Theorem" class VernacObject(NotationObject): - """An object to represent Coq commands""" + """A Coq command. + + Example:: + + .. cmd:: Infix "@symbol" := @term ({+, @modifier}). + + This command is equivalent to :n:`…`. + """ subdomain = "cmd" index_suffix = "(cmd)" annotation = "Command" def _name_from_signature(self, signature): - return stringify_with_ellipses(signature) + m = re.match(r"[a-zA-Z ]+", signature) + if m: + return m.group(0).strip() class VernacVariantObject(VernacObject): - """An object to represent variants of Coq commands""" + """A variant of a Coq command. + + Example:: + + .. cmd:: Axiom @ident : @term. + + This command links :token:`term` to the name :token:`term` as its specification in + the global context. The fact asserted by :token:`term` is thus assumed as a + postulate. + + .. cmdv:: Parameter @ident : @term. + + This is equivalent to :n:`Axiom @ident : @term`. + """ index_suffix = "(cmdv)" annotation = "Variant" + def _name_from_signature(self, signature): + return None + class TacticNotationObject(NotationObject): - """An object to represent Coq tactic notations""" + """A tactic, or a tactic notation. + + Example:: + + .. tacn:: do @num @expr + + :token:`expr` is evaluated to ``v`` which must be a tactic value. … + """ subdomain = "tacn" index_suffix = "(tacn)" annotation = None class TacticNotationVariantObject(TacticNotationObject): - """An object to represent variants of Coq tactic notations""" + """A variant of a tactic. + + Example:: + + .. tacn:: fail + + This is the always-failing tactic: it does not solve any goal. It is + useful for defining other tacticals since it can be caught by + :tacn:`try`, :tacn:`repeat`, :tacn:`match goal`, or the branching + tacticals. … + + .. tacv:: fail @natural + + The number is the failure level. If no level is specified, it + defaults to 0. … + """ index_suffix = "(tacnv)" annotation = "Variant" class OptionObject(NotationObject): - """An object to represent Coq options""" + """A Coq option. + + Example:: + + .. opt:: Nonrecursive Elimination Schemes + + This option controls whether types declared with the keywords + :cmd:`Variant` and :cmd:`Record` get an automatic declaration of the + induction principles. + """ subdomain = "opt" index_suffix = "(opt)" annotation = "Option" @@ -222,7 +315,13 @@ class OptionObject(NotationObject): return stringify_with_ellipses(signature) class ProductionObject(NotationObject): - """An object to represent grammar productions""" + """Grammar productions. + + This is useful if you intend to document individual grammar productions. + Otherwise, use Sphinx's `production lists + <http://www.sphinx-doc.org/en/stable/markup/para.html#directive-productionlist>`_. + """ + # FIXME (CPC): I have no idea what this does :/ Someone should add an example. subdomain = "prodn" index_suffix = None annotation = None @@ -261,7 +360,22 @@ class ProductionObject(NotationObject): return [idx, node] class ExceptionObject(NotationObject): - """An object to represent Coq errors.""" + """An error raised by a Coq command or tactic. + + This commonly appears nested in the ``.. tacn::`` that raises the + exception. + + Example:: + + .. tacv:: assert @form by @tactic + + This tactic applies :n:`@tactic` to solve the subgoals generated by + ``assert``. + + .. exn:: Proof is not complete + + Raised if :n:`@tactic` does not fully solve the goal. + """ subdomain = "exn" index_suffix = "(err)" annotation = "Error" @@ -272,7 +386,19 @@ class ExceptionObject(NotationObject): return stringify_with_ellipses(signature) class WarningObject(NotationObject): - """An object to represent Coq warnings.""" + """An warning raised by a Coq command or tactic.. + + Do not mistake this for ``.. warning::``; this directive is for warning + messages produced by Coq. + + + Example:: + + .. warn:: Ambiguous path + + When the coercion :token:`qualid` is added to the inheritance graph, non + valid coercion paths are ignored. + """ subdomain = "warn" index_suffix = "(warn)" annotation = "Warning" @@ -283,14 +409,33 @@ class WarningObject(NotationObject): def NotationRole(role, rawtext, text, lineno, inliner, options={}, content=[]): #pylint: disable=unused-argument, dangerous-default-value - """And inline role for notations""" + """Any text using the notation syntax (``@id``, ``{+, …}``, etc.). + + Use this to explain tactic equivalences. For example, you might write + this:: + + :n:`generalize @term as @ident` is just like :n:`generalize @term`, but + it names the introduced hypothesis :token:`ident`. + + Note that this example also uses ``:token:``. That's because ``ident`` is + defined in the the Coq manual as a grammar production, and ``:token:`` + creates a link to that. When referring to a placeholder that happens to be + a grammar production, ``:token:`…``` is typically preferable to ``:n:`@…```. + """ notation = utils.unescape(text, 1) position = inliner.reporter.get_source_and_line(lineno) return [nodes.literal(rawtext, '', parse_notation(notation, *position, rawtext=rawtext))], [] def coq_code_role(role, rawtext, text, lineno, inliner, options={}, content=[]): #pylint: disable=dangerous-default-value - """And inline role for Coq source code""" + """Coq code. + + Use this for Gallina and Ltac snippets:: + + :g:`apply plus_comm; reflexivity` + :g:`Set Printing All.` + :g:`forall (x: t), P(x)` + """ options['language'] = 'Coq' return code_role(role, rawtext, text, lineno, inliner, options, content) ## Too heavy: @@ -303,15 +448,14 @@ def coq_code_role(role, rawtext, text, lineno, inliner, options={}, content=[]): # node = nodes.literal(rawtext, '', *highlight_using_coqdoc(code), classes=classes) # return [node], [] -# TODO pass different languages? -LtacRole = GallinaRole = VernacRole = coq_code_role +CoqCodeRole = coq_code_role class CoqtopDirective(Directive): """A reST directive to describe interactions with Coqtop. Usage:: - .. coqtop:: (options)+ + .. coqtop:: options… Coq code to send to coqtop @@ -324,20 +468,28 @@ class CoqtopDirective(Directive): Here is a list of permissible options: - Display - - ‘all’: Display input and output - - ‘in’: Display only input - - ‘out’: Display only output - - ‘none’: Display neither (useful for setup commands) - Behaviour - - ‘reset’: Send a `Reset Initial` command before running this block - - ‘undo’: Send an `Undo n` (n=number of sentences) command after running - all the commands in this block + - Display options + + - ``all``: Display input and output + - ``in``: Display only input + - ``out``: Display only output + - ``none``: Display neither (useful for setup commands) + + - Behavior options + + - ``reset``: Send a ``Reset Initial`` command before running this block + - ``undo``: Send an ``Undo n`` (``n`` = number of sentences) command after + running all the commands in this block + + ``coqtop``\ 's state is preserved across consecutive ``.. coqtop::`` blocks + of the same document (``coqrst`` creates a single ``coqtop`` process per + reST source file). Use the ``reset`` option to reset Coq's state. """ has_content = True required_arguments = 0 optional_arguments = 1 final_argument_whitespace = True + directive_name = "coqtop" def run(self): # Uses a ‘container’ instead of a ‘literal_block’ to disable @@ -352,12 +504,26 @@ class CoqtopDirective(Directive): return [node] class CoqdocDirective(Directive): - """A reST directive to display Coqtop-formatted source code""" + """A reST directive to display Coqtop-formatted source code. + + Usage:: + + .. coqdoc:: + + Coq code to highlight + + Example:: + + .. coqdoc:: + + Definition test := 1. + """ # TODO implement this as a Pygments highlighter? has_content = True required_arguments = 0 optional_arguments = 0 final_argument_whitespace = True + directive_name = "coqdoc" def run(self): # Uses a ‘container’ instead of a ‘literal_block’ to disable @@ -368,8 +534,24 @@ class CoqdocDirective(Directive): return [wrapper] class ExampleDirective(BaseAdmonition): - """A reST directive for examples""" + """A reST directive for examples. + + This behaves like a generic admonition; see + http://docutils.sourceforge.net/docs/ref/rst/directives.html#generic-admonition + for more details. + + Example:: + + .. example:: Adding a hint to a database + + The following adds ``plus_comm`` to the ``plu`` database: + + .. coqdoc:: + + Hint Resolve plus_comm : plu. + """ node_class = nodes.admonition + directive_name = "example" def run(self): # ‘BaseAdmonition’ checks whether ‘node_class’ is ‘nodes.admonition’, @@ -383,8 +565,17 @@ class ExampleDirective(BaseAdmonition): class PreambleDirective(MathDirective): r"""A reST directive for hidden math. - Mostly useful to let MathJax know about `\def`s and `\newcommand`s + Mostly useful to let MathJax know about `\def`\ s and `\newcommand`\ s. + + Example:: + + .. preamble:: + + \newcommand{\paren}[#1]{\left(#1\right)} """ + + directive_name = "preamble" + def run(self): self.options['nowrap'] = True [node] = super().run() @@ -392,14 +583,17 @@ class PreambleDirective(MathDirective): return [node] class InferenceDirective(Directive): - r"""A small example of what directives let you do in Sphinx. + r"""A reST directive to format inference rules. + + This also serves as a small illustration of the way to create new Sphinx + directives. Usage:: .. inference:: name - \n-separated premisses - ---------------------- + newline-separated premisses + ------------------------ conclusion Example:: @@ -416,6 +610,7 @@ class InferenceDirective(Directive): optional_arguments = 0 has_content = True final_argument_whitespace = True + directive_name = "inference" def make_math_node(self, latex): node = displaymath() @@ -616,7 +811,7 @@ class CoqSubdomainsIndex(Index): Just as in the original manual, we want to have separate indices for each Coq subdomain (tactics, commands, options, etc)""" - name, localname, shortname, subdomains = None, None, None, None # Must be overwritten + name, localname, shortname, subdomains = None, None, None, [] # Must be overwritten def generate(self, docnames=None): content = defaultdict(list) @@ -638,7 +833,7 @@ class CoqVernacIndex(CoqSubdomainsIndex): name, localname, shortname, subdomains = "cmdindex", "Command Index", "commands", ["cmd"] class CoqTacticIndex(CoqSubdomainsIndex): - name, localname, shortname, subdomains = "tacindex", "Tactic Index", "tactics", ["tac", "tacn"] + name, localname, shortname, subdomains = "tacindex", "Tactic Index", "tactics", ["tacn"] class CoqOptionIndex(CoqSubdomainsIndex): name, localname, shortname, subdomains = "optindex", "Option Index", "options", ["opt"] @@ -668,10 +863,18 @@ class IndexXRefRole(XRefRole): return title, target def GrammarProductionRole(typ, rawtext, text, lineno, inliner, options={}, content=[]): - """An inline role to declare grammar productions that are not in fact included - in a `productionlist` directive. + """A grammar production not included in a ``productionlist`` directive. + + Useful to informally introduce a production, as part of running text. - Useful to informally introduce a production, as part of running text + Example:: + + :production:`string` indicates a quoted string. + + You're not likely to use this role very commonly; instead, use a + `production list + <http://www.sphinx-doc.org/en/stable/markup/para.html#directive-productionlist>`_ + and reference its tokens using ``:token:`…```. """ #pylint: disable=dangerous-default-value, unused-argument env = inliner.document.settings.env @@ -684,6 +887,8 @@ def GrammarProductionRole(typ, rawtext, text, lineno, inliner, options={}, conte env.domaindata['std']['objects']['token', text] = env.docname, targetid return [node], [] +GrammarProductionRole.role_name = "production" + class CoqDomain(Domain): """A domain to document Coq code. @@ -706,7 +911,6 @@ class CoqDomain(Domain): # ObjType (= directive type) → (Local name, *xref-roles) 'cmd': ObjType('cmd', 'cmd'), 'cmdv': ObjType('cmdv', 'cmd'), - 'tac': ObjType('tac', 'tac'), 'tacn': ObjType('tacn', 'tacn'), 'tacv': ObjType('tacv', 'tacn'), 'opt': ObjType('opt', 'opt'), @@ -723,7 +927,6 @@ class CoqDomain(Domain): # the same role. 'cmd': VernacObject, 'cmdv': VernacVariantObject, - 'tac': TacticObject, 'tacn': TacticNotationObject, 'tacv': TacticNotationVariantObject, 'opt': OptionObject, @@ -735,23 +938,18 @@ class CoqDomain(Domain): roles = { # Each of these roles lives in a different semantic “subdomain” - 'cmd': XRefRole(), - 'tac': XRefRole(), - 'tacn': XRefRole(), - 'opt': XRefRole(), - 'thm': XRefRole(), - 'prodn' : XRefRole(), - 'exn': XRefRole(), - 'warn': XRefRole(), + 'cmd': XRefRole(warn_dangling=True), + 'tacn': XRefRole(warn_dangling=True), + 'opt': XRefRole(warn_dangling=True), + 'thm': XRefRole(warn_dangling=True), + 'prodn' : XRefRole(warn_dangling=True), + 'exn': XRefRole(warn_dangling=True), + 'warn': XRefRole(warn_dangling=True), # This one is special 'index': IndexXRefRole(), # These are used for highlighting - 'notation': NotationRole, - 'gallina': GallinaRole, - 'ltac': LtacRole, 'n': NotationRole, - 'g': GallinaRole, - 'l': LtacRole, #FIXME unused? + 'g': CoqCodeRole } indices = [CoqVernacIndex, CoqTacticIndex, CoqOptionIndex, CoqGallinaIndex, CoqProductionIndex, CoqExceptionIndex] @@ -762,7 +960,6 @@ class CoqDomain(Domain): # others, such as “version” 'objects' : { # subdomain → name → docname, objtype, targetid 'cmd': {}, - 'tac': {}, 'tacn': {}, 'opt': {}, 'thm': {}, @@ -832,11 +1029,18 @@ def simplify_source_code_blocks_for_latex(app, doctree, fromdocname): # pylint: for node in doctree.traverse(is_coqtop_or_coqdoc_block): if is_html: node.rawsource = '' # Prevent pygments from kicking in + elif 'coqtop-hidden' in node['classes']: + node.parent.remove(node) else: - if 'coqtop-hidden' in node['classes']: - node.parent.remove(node) - else: - node.replace_self(nodes.literal_block(node.rawsource, node.rawsource, language="Coq")) + node.replace_self(nodes.literal_block(node.rawsource, node.rawsource, language="Coq")) + +COQ_ADDITIONAL_DIRECTIVES = [CoqtopDirective, + CoqdocDirective, + ExampleDirective, + InferenceDirective, + PreambleDirective] + +COQ_ADDITIONAL_ROLES = [GrammarProductionRole] def setup(app): """Register the Coq domain""" @@ -848,12 +1052,13 @@ def setup(app): # Add domain, directives, and roles app.add_domain(CoqDomain) - app.add_role("production", GrammarProductionRole) - app.add_directive("coqtop", CoqtopDirective) - app.add_directive("coqdoc", CoqdocDirective) - app.add_directive("example", ExampleDirective) - app.add_directive("inference", InferenceDirective) - app.add_directive("preamble", PreambleDirective) + + for role in COQ_ADDITIONAL_ROLES: + app.add_role(role.role_name, role) + + for directive in COQ_ADDITIONAL_DIRECTIVES: + app.add_directive(directive.directive_name, directive) + app.add_transform(CoqtopBlocksTransform) app.connect('doctree-resolved', simplify_source_code_blocks_for_latex) @@ -865,4 +1070,7 @@ def setup(app): app.add_stylesheet("notations.css") app.add_stylesheet("pre-text.css") + # Tell Sphinx about extra settings + app.add_config_value("report_undocumented_coq_objects", None, 'env') + return {'version': '0.1', "parallel_read_safe": True} diff --git a/doc/tools/coqrst/notations/CoqNotations.ttf b/doc/tools/coqrst/notations/CoqNotations.ttf Binary files differnew file mode 100644 index 000000000..da8f2850d --- /dev/null +++ b/doc/tools/coqrst/notations/CoqNotations.ttf diff --git a/doc/tools/coqrst/notations/TacticNotations.g b/doc/tools/coqrst/notations/TacticNotations.g index 5176c51d2..a889ebda7 100644 --- a/doc/tools/coqrst/notations/TacticNotations.g +++ b/doc/tools/coqrst/notations/TacticNotations.g @@ -20,13 +20,14 @@ repeat: LGROUP (ATOM)? WHITESPACE blocks (WHITESPACE)? RBRACE; curlies: LBRACE (whitespace)? blocks (whitespace)? RBRACE; whitespace: WHITESPACE; meta: METACHAR; -atomic: ATOM; -hole: ID; +atomic: ATOM (SUB)?; +hole: ID (SUB)?; LGROUP: '{' [+*?]; LBRACE: '{'; RBRACE: '}'; -METACHAR: '%' [|()]; -ATOM: '@' | ~[@{} ]+; -ID: '@' [a-zA-Z0-9_]+; +METACHAR: '%' [|(){}]; +ATOM: '@' | '_' | ~[@_{} ]+; +ID: '@' ('_'? [a-zA-Z0-9])+; +SUB: '_' '_' [a-zA-Z0-9]+; WHITESPACE: ' '+; diff --git a/doc/tools/coqrst/notations/TacticNotations.tokens b/doc/tools/coqrst/notations/TacticNotations.tokens index 76ed2b065..88b38f97a 100644 --- a/doc/tools/coqrst/notations/TacticNotations.tokens +++ b/doc/tools/coqrst/notations/TacticNotations.tokens @@ -4,6 +4,7 @@ RBRACE=3 METACHAR=4 ATOM=5 ID=6 -WHITESPACE=7 +SUB=7 +WHITESPACE=8 '{'=2 '}'=3 diff --git a/doc/tools/coqrst/notations/TacticNotationsLexer.py b/doc/tools/coqrst/notations/TacticNotationsLexer.py index ffa774b9b..27293e7e0 100644 --- a/doc/tools/coqrst/notations/TacticNotationsLexer.py +++ b/doc/tools/coqrst/notations/TacticNotationsLexer.py @@ -7,24 +7,28 @@ import sys def serializedATN(): with StringIO() as buf: - buf.write("\3\u608b\ua72a\u8133\ub9ed\u417c\u3be7\u7786\u5964\2\t") - buf.write(".\b\1\4\2\t\2\4\3\t\3\4\4\t\4\4\5\t\5\4\6\t\6\4\7\t\7") - buf.write("\4\b\t\b\3\2\3\2\3\2\3\3\3\3\3\4\3\4\3\5\3\5\3\5\3\6\3") - buf.write("\6\6\6\36\n\6\r\6\16\6\37\5\6\"\n\6\3\7\3\7\6\7&\n\7\r") - buf.write("\7\16\7\'\3\b\6\b+\n\b\r\b\16\b,\2\2\t\3\3\5\4\7\5\t\6") - buf.write("\13\7\r\b\17\t\3\2\6\4\2,-AA\4\2*+~~\6\2\"\"BB}}\177\177") - buf.write("\6\2\62;C\\aac|\2\61\2\3\3\2\2\2\2\5\3\2\2\2\2\7\3\2\2") - buf.write("\2\2\t\3\2\2\2\2\13\3\2\2\2\2\r\3\2\2\2\2\17\3\2\2\2\3") - buf.write("\21\3\2\2\2\5\24\3\2\2\2\7\26\3\2\2\2\t\30\3\2\2\2\13") - buf.write("!\3\2\2\2\r#\3\2\2\2\17*\3\2\2\2\21\22\7}\2\2\22\23\t") - buf.write("\2\2\2\23\4\3\2\2\2\24\25\7}\2\2\25\6\3\2\2\2\26\27\7") - buf.write("\177\2\2\27\b\3\2\2\2\30\31\7\'\2\2\31\32\t\3\2\2\32\n") - buf.write("\3\2\2\2\33\"\7B\2\2\34\36\n\4\2\2\35\34\3\2\2\2\36\37") - buf.write("\3\2\2\2\37\35\3\2\2\2\37 \3\2\2\2 \"\3\2\2\2!\33\3\2") - buf.write("\2\2!\35\3\2\2\2\"\f\3\2\2\2#%\7B\2\2$&\t\5\2\2%$\3\2") - buf.write("\2\2&\'\3\2\2\2\'%\3\2\2\2\'(\3\2\2\2(\16\3\2\2\2)+\7") - buf.write("\"\2\2*)\3\2\2\2+,\3\2\2\2,*\3\2\2\2,-\3\2\2\2-\20\3\2") - buf.write("\2\2\7\2\37!\',\2") + buf.write("\3\u608b\ua72a\u8133\ub9ed\u417c\u3be7\u7786\u5964\2\n") + buf.write(":\b\1\4\2\t\2\4\3\t\3\4\4\t\4\4\5\t\5\4\6\t\6\4\7\t\7") + buf.write("\4\b\t\b\4\t\t\t\3\2\3\2\3\2\3\3\3\3\3\4\3\4\3\5\3\5\3") + buf.write("\5\3\6\3\6\6\6 \n\6\r\6\16\6!\5\6$\n\6\3\7\3\7\5\7(\n") + buf.write("\7\3\7\6\7+\n\7\r\7\16\7,\3\b\3\b\3\b\6\b\62\n\b\r\b\16") + buf.write("\b\63\3\t\6\t\67\n\t\r\t\16\t8\2\2\n\3\3\5\4\7\5\t\6\13") + buf.write("\7\r\b\17\t\21\n\3\2\7\4\2,-AA\4\2*+}\177\4\2BBaa\7\2") + buf.write("\"\"BBaa}}\177\177\5\2\62;C\\c|\2?\2\3\3\2\2\2\2\5\3\2") + buf.write("\2\2\2\7\3\2\2\2\2\t\3\2\2\2\2\13\3\2\2\2\2\r\3\2\2\2") + buf.write("\2\17\3\2\2\2\2\21\3\2\2\2\3\23\3\2\2\2\5\26\3\2\2\2\7") + buf.write("\30\3\2\2\2\t\32\3\2\2\2\13#\3\2\2\2\r%\3\2\2\2\17.\3") + buf.write("\2\2\2\21\66\3\2\2\2\23\24\7}\2\2\24\25\t\2\2\2\25\4\3") + buf.write("\2\2\2\26\27\7}\2\2\27\6\3\2\2\2\30\31\7\177\2\2\31\b") + buf.write("\3\2\2\2\32\33\7\'\2\2\33\34\t\3\2\2\34\n\3\2\2\2\35$") + buf.write("\t\4\2\2\36 \n\5\2\2\37\36\3\2\2\2 !\3\2\2\2!\37\3\2\2") + buf.write("\2!\"\3\2\2\2\"$\3\2\2\2#\35\3\2\2\2#\37\3\2\2\2$\f\3") + buf.write("\2\2\2%*\7B\2\2&(\7a\2\2\'&\3\2\2\2\'(\3\2\2\2()\3\2\2") + buf.write("\2)+\t\6\2\2*\'\3\2\2\2+,\3\2\2\2,*\3\2\2\2,-\3\2\2\2") + buf.write("-\16\3\2\2\2./\7a\2\2/\61\7a\2\2\60\62\t\6\2\2\61\60\3") + buf.write("\2\2\2\62\63\3\2\2\2\63\61\3\2\2\2\63\64\3\2\2\2\64\20") + buf.write("\3\2\2\2\65\67\7\"\2\2\66\65\3\2\2\2\678\3\2\2\28\66\3") + buf.write("\2\2\289\3\2\2\29\22\3\2\2\2\t\2!#\',\638\2") return buf.getvalue() @@ -40,7 +44,8 @@ class TacticNotationsLexer(Lexer): METACHAR = 4 ATOM = 5 ID = 6 - WHITESPACE = 7 + SUB = 7 + WHITESPACE = 8 channelNames = [ u"DEFAULT_TOKEN_CHANNEL", u"HIDDEN" ] @@ -50,10 +55,11 @@ class TacticNotationsLexer(Lexer): "'{'", "'}'" ] symbolicNames = [ "<INVALID>", - "LGROUP", "LBRACE", "RBRACE", "METACHAR", "ATOM", "ID", "WHITESPACE" ] + "LGROUP", "LBRACE", "RBRACE", "METACHAR", "ATOM", "ID", "SUB", + "WHITESPACE" ] ruleNames = [ "LGROUP", "LBRACE", "RBRACE", "METACHAR", "ATOM", "ID", - "WHITESPACE" ] + "SUB", "WHITESPACE" ] grammarFileName = "TacticNotations.g" diff --git a/doc/tools/coqrst/notations/TacticNotationsLexer.tokens b/doc/tools/coqrst/notations/TacticNotationsLexer.tokens index 76ed2b065..88b38f97a 100644 --- a/doc/tools/coqrst/notations/TacticNotationsLexer.tokens +++ b/doc/tools/coqrst/notations/TacticNotationsLexer.tokens @@ -4,6 +4,7 @@ RBRACE=3 METACHAR=4 ATOM=5 ID=6 -WHITESPACE=7 +SUB=7 +WHITESPACE=8 '{'=2 '}'=3 diff --git a/doc/tools/coqrst/notations/TacticNotationsParser.py b/doc/tools/coqrst/notations/TacticNotationsParser.py index c7e28af52..645f07897 100644 --- a/doc/tools/coqrst/notations/TacticNotationsParser.py +++ b/doc/tools/coqrst/notations/TacticNotationsParser.py @@ -7,29 +7,31 @@ import sys def serializedATN(): with StringIO() as buf: - buf.write("\3\u608b\ua72a\u8133\ub9ed\u417c\u3be7\u7786\u5964\3\t") - buf.write("F\4\2\t\2\4\3\t\3\4\4\t\4\4\5\t\5\4\6\t\6\4\7\t\7\4\b") + buf.write("\3\u608b\ua72a\u8133\ub9ed\u417c\u3be7\u7786\u5964\3\n") + buf.write("J\4\2\t\2\4\3\t\3\4\4\t\4\4\5\t\5\4\6\t\6\4\7\t\7\4\b") buf.write("\t\b\4\t\t\t\4\n\t\n\3\2\3\2\3\2\3\3\3\3\5\3\32\n\3\3") buf.write("\3\7\3\35\n\3\f\3\16\3 \13\3\3\4\3\4\3\4\3\4\3\4\5\4\'") buf.write("\n\4\3\5\3\5\5\5+\n\5\3\5\3\5\3\5\5\5\60\n\5\3\5\3\5\3") buf.write("\6\3\6\5\6\66\n\6\3\6\3\6\5\6:\n\6\3\6\3\6\3\7\3\7\3\b") - buf.write("\3\b\3\t\3\t\3\n\3\n\3\n\2\2\13\2\4\6\b\n\f\16\20\22\2") - buf.write("\2\2F\2\24\3\2\2\2\4\27\3\2\2\2\6&\3\2\2\2\b(\3\2\2\2") - buf.write("\n\63\3\2\2\2\f=\3\2\2\2\16?\3\2\2\2\20A\3\2\2\2\22C\3") - buf.write("\2\2\2\24\25\5\4\3\2\25\26\7\2\2\3\26\3\3\2\2\2\27\36") - buf.write("\5\6\4\2\30\32\5\f\7\2\31\30\3\2\2\2\31\32\3\2\2\2\32") - buf.write("\33\3\2\2\2\33\35\5\6\4\2\34\31\3\2\2\2\35 \3\2\2\2\36") - buf.write("\34\3\2\2\2\36\37\3\2\2\2\37\5\3\2\2\2 \36\3\2\2\2!\'") - buf.write("\5\20\t\2\"\'\5\16\b\2#\'\5\22\n\2$\'\5\b\5\2%\'\5\n\6") - buf.write("\2&!\3\2\2\2&\"\3\2\2\2&#\3\2\2\2&$\3\2\2\2&%\3\2\2\2") - buf.write("\'\7\3\2\2\2(*\7\3\2\2)+\7\7\2\2*)\3\2\2\2*+\3\2\2\2+") - buf.write(",\3\2\2\2,-\7\t\2\2-/\5\4\3\2.\60\7\t\2\2/.\3\2\2\2/\60") - buf.write("\3\2\2\2\60\61\3\2\2\2\61\62\7\5\2\2\62\t\3\2\2\2\63\65") - buf.write("\7\4\2\2\64\66\5\f\7\2\65\64\3\2\2\2\65\66\3\2\2\2\66") - buf.write("\67\3\2\2\2\679\5\4\3\28:\5\f\7\298\3\2\2\29:\3\2\2\2") - buf.write(":;\3\2\2\2;<\7\5\2\2<\13\3\2\2\2=>\7\t\2\2>\r\3\2\2\2") - buf.write("?@\7\6\2\2@\17\3\2\2\2AB\7\7\2\2B\21\3\2\2\2CD\7\b\2\2") - buf.write("D\23\3\2\2\2\t\31\36&*/\659") + buf.write("\3\b\3\t\3\t\5\tD\n\t\3\n\3\n\5\nH\n\n\3\n\2\2\13\2\4") + buf.write("\6\b\n\f\16\20\22\2\2\2L\2\24\3\2\2\2\4\27\3\2\2\2\6&") + buf.write("\3\2\2\2\b(\3\2\2\2\n\63\3\2\2\2\f=\3\2\2\2\16?\3\2\2") + buf.write("\2\20A\3\2\2\2\22E\3\2\2\2\24\25\5\4\3\2\25\26\7\2\2\3") + buf.write("\26\3\3\2\2\2\27\36\5\6\4\2\30\32\5\f\7\2\31\30\3\2\2") + buf.write("\2\31\32\3\2\2\2\32\33\3\2\2\2\33\35\5\6\4\2\34\31\3\2") + buf.write("\2\2\35 \3\2\2\2\36\34\3\2\2\2\36\37\3\2\2\2\37\5\3\2") + buf.write("\2\2 \36\3\2\2\2!\'\5\20\t\2\"\'\5\16\b\2#\'\5\22\n\2") + buf.write("$\'\5\b\5\2%\'\5\n\6\2&!\3\2\2\2&\"\3\2\2\2&#\3\2\2\2") + buf.write("&$\3\2\2\2&%\3\2\2\2\'\7\3\2\2\2(*\7\3\2\2)+\7\7\2\2*") + buf.write(")\3\2\2\2*+\3\2\2\2+,\3\2\2\2,-\7\n\2\2-/\5\4\3\2.\60") + buf.write("\7\n\2\2/.\3\2\2\2/\60\3\2\2\2\60\61\3\2\2\2\61\62\7\5") + buf.write("\2\2\62\t\3\2\2\2\63\65\7\4\2\2\64\66\5\f\7\2\65\64\3") + buf.write("\2\2\2\65\66\3\2\2\2\66\67\3\2\2\2\679\5\4\3\28:\5\f\7") + buf.write("\298\3\2\2\29:\3\2\2\2:;\3\2\2\2;<\7\5\2\2<\13\3\2\2\2") + buf.write("=>\7\n\2\2>\r\3\2\2\2?@\7\6\2\2@\17\3\2\2\2AC\7\7\2\2") + buf.write("BD\7\t\2\2CB\3\2\2\2CD\3\2\2\2D\21\3\2\2\2EG\7\b\2\2F") + buf.write("H\7\t\2\2GF\3\2\2\2GH\3\2\2\2H\23\3\2\2\2\13\31\36&*/") + buf.write("\659CG") return buf.getvalue() @@ -46,7 +48,7 @@ class TacticNotationsParser ( Parser ): literalNames = [ "<INVALID>", "<INVALID>", "'{'", "'}'" ] symbolicNames = [ "<INVALID>", "LGROUP", "LBRACE", "RBRACE", "METACHAR", - "ATOM", "ID", "WHITESPACE" ] + "ATOM", "ID", "SUB", "WHITESPACE" ] RULE_top = 0 RULE_blocks = 1 @@ -68,7 +70,8 @@ class TacticNotationsParser ( Parser ): METACHAR=4 ATOM=5 ID=6 - WHITESPACE=7 + SUB=7 + WHITESPACE=8 def __init__(self, input:TokenStream, output:TextIO = sys.stdout): super().__init__(input, output) @@ -502,6 +505,9 @@ class TacticNotationsParser ( Parser ): def ATOM(self): return self.getToken(TacticNotationsParser.ATOM, 0) + def SUB(self): + return self.getToken(TacticNotationsParser.SUB, 0) + def getRuleIndex(self): return TacticNotationsParser.RULE_atomic @@ -518,10 +524,19 @@ class TacticNotationsParser ( Parser ): localctx = TacticNotationsParser.AtomicContext(self, self._ctx, self.state) self.enterRule(localctx, 14, self.RULE_atomic) + self._la = 0 # Token type try: self.enterOuterAlt(localctx, 1) self.state = 63 self.match(TacticNotationsParser.ATOM) + self.state = 65 + self._errHandler.sync(self) + _la = self._input.LA(1) + if _la==TacticNotationsParser.SUB: + self.state = 64 + self.match(TacticNotationsParser.SUB) + + except RecognitionException as re: localctx.exception = re self._errHandler.reportError(self, re) @@ -539,6 +554,9 @@ class TacticNotationsParser ( Parser ): def ID(self): return self.getToken(TacticNotationsParser.ID, 0) + def SUB(self): + return self.getToken(TacticNotationsParser.SUB, 0) + def getRuleIndex(self): return TacticNotationsParser.RULE_hole @@ -555,10 +573,19 @@ class TacticNotationsParser ( Parser ): localctx = TacticNotationsParser.HoleContext(self, self._ctx, self.state) self.enterRule(localctx, 16, self.RULE_hole) + self._la = 0 # Token type try: self.enterOuterAlt(localctx, 1) - self.state = 65 + self.state = 67 self.match(TacticNotationsParser.ID) + self.state = 69 + self._errHandler.sync(self) + _la = self._input.LA(1) + if _la==TacticNotationsParser.SUB: + self.state = 68 + self.match(TacticNotationsParser.SUB) + + except RecognitionException as re: localctx.exception = re self._errHandler.reportError(self, re) diff --git a/doc/tools/coqrst/notations/UbuntuMono-Square.ttf b/doc/tools/coqrst/notations/UbuntuMono-Square.ttf Binary files differdeleted file mode 100644 index a53a9a0f0..000000000 --- a/doc/tools/coqrst/notations/UbuntuMono-Square.ttf +++ /dev/null diff --git a/doc/tools/coqrst/notations/fontsupport.py b/doc/tools/coqrst/notations/fontsupport.py index 3402ea2aa..a3efd97f5 100755 --- a/doc/tools/coqrst/notations/fontsupport.py +++ b/doc/tools/coqrst/notations/fontsupport.py @@ -63,8 +63,7 @@ def trim_font(fnt): def center_glyphs(src_font_path, dst_font_path, dst_name): fnt = trim_font(fontforge.open(src_font_path)) - size = max(max(g.width for g in fnt.glyphs()), - max(glyph_height(g) for g in fnt.glyphs())) + size = max(g.width for g in fnt.glyphs()) fnt.ascent, fnt.descent = size, 0 for glyph in fnt.glyphs(): scale_single_glyph(glyph, size, size) @@ -77,5 +76,5 @@ if __name__ == '__main__': from os.path import dirname, join, abspath curdir = dirname(abspath(__file__)) ubuntumono_path = join(curdir, "UbuntuMono-B.ttf") - ubuntumono_mod_path = join(curdir, "UbuntuMono-Square.ttf") - center_glyphs(ubuntumono_path, ubuntumono_mod_path, "UbuntuMono-Square") + ubuntumono_mod_path = join(curdir, "CoqNotations.ttf") + center_glyphs(ubuntumono_path, ubuntumono_mod_path, "CoqNotations") diff --git a/doc/tools/coqrst/notations/html.py b/doc/tools/coqrst/notations/html.py index 44212d788..87a41cf9f 100644 --- a/doc/tools/coqrst/notations/html.py +++ b/doc/tools/coqrst/notations/html.py @@ -41,9 +41,16 @@ class TacticNotationsToHTMLVisitor(TacticNotationsVisitor): def visitHole(self, ctx:TacticNotationsParser.HoleContext): tags.span(ctx.ID().getText()[1:], _class="hole") + sub = ctx.SUB() + if sub: + tags.sub(sub.getText()[1:]) def visitMeta(self, ctx:TacticNotationsParser.MetaContext): - tags.span(ctx.METACHAR().getText()[1:], _class="meta") + txt = ctx.METACHAR().getText()[1:] + if (txt == "{") or (txt == "}"): + tags.span(txt) + else: + tags.span(txt, _class="meta") def visitWhitespace(self, ctx:TacticNotationsParser.WhitespaceContext): tags.span(" ") # TODO: no need for a <span> here diff --git a/doc/tools/coqrst/notations/sphinx.py b/doc/tools/coqrst/notations/sphinx.py index 26a5f6968..e05b83418 100644 --- a/doc/tools/coqrst/notations/sphinx.py +++ b/doc/tools/coqrst/notations/sphinx.py @@ -56,19 +56,36 @@ class TacticNotationsToSphinxVisitor(TacticNotationsVisitor): def visitAtomic(self, ctx:TacticNotationsParser.AtomicContext): atom = ctx.ATOM().getText() - return [nodes.inline(atom, atom)] + sub = ctx.SUB() + node = nodes.inline(atom, atom) + + if sub: + sub_index = sub.getText()[2:] + node += nodes.subscript(sub_index, sub_index) + + return [node] def visitHole(self, ctx:TacticNotationsParser.HoleContext): hole = ctx.ID().getText() token_name = hole[1:] node = nodes.inline(hole, token_name, classes=["hole"]) + + sub = ctx.SUB() + if sub: + sub_index = sub.getText()[2:] + node += nodes.subscript(sub_index, sub_index) + return [addnodes.pending_xref(token_name, node, reftype='token', refdomain='std', reftarget=token_name)] def visitMeta(self, ctx:TacticNotationsParser.MetaContext): meta = ctx.METACHAR().getText() metachar = meta[1:] # remove escape char token_name = metachar - return [nodes.inline(metachar, token_name, classes=["meta"])] + if (metachar == "{") or (metachar == "}"): + classes=[] + else: + classes=["meta"] + return [nodes.inline(metachar, token_name, classes=classes)] def visitWhitespace(self, ctx:TacticNotationsParser.WhitespaceContext): return [nodes.Text(" ")] diff --git a/doc/tools/coqrst/regen_readme.py b/doc/tools/coqrst/regen_readme.py new file mode 100755 index 000000000..e56882a52 --- /dev/null +++ b/doc/tools/coqrst/regen_readme.py @@ -0,0 +1,58 @@ +#!/usr/bin/env python3 +# -*- coding: utf-8 -*- + +"""Rebuild sphinx/README.rst from sphinx/README.template.rst.""" + +import re +from os import sys, path + +SCRIPT_DIR = path.dirname(path.abspath(__file__)) +if __name__ == "__main__" and __package__ is None: + sys.path.append(path.dirname(SCRIPT_DIR)) + +import sphinx +from coqrst import coqdomain + +README_ROLES_MARKER = "[ROLES]" +README_OBJECTS_MARKER = "[OBJECTS]" +README_DIRECTIVES_MARKER = "[DIRECTIVES]" + +FIRST_LINE_BLANKS = re.compile("^(.*)\n *\n") +def format_docstring(template, obj, *strs): + docstring = obj.__doc__.strip() + strs = strs + (FIRST_LINE_BLANKS.sub(r"\1\n", docstring),) + return template.format(*strs) + +SPHINX_DIR = path.join(SCRIPT_DIR, "../../sphinx/") +README_PATH = path.join(SPHINX_DIR, "README.rst") +README_TEMPLATE_PATH = path.join(SPHINX_DIR, "README.template.rst") + +def notation_symbol(d): + return " :black_nib:" if issubclass(d, coqdomain.NotationObject) else "" + +def regen_readme(): + objects_docs = [format_docstring("``.. {}::``{} {}", obj, objname, notation_symbol(obj)) + for objname, obj in sorted(coqdomain.CoqDomain.directives.items())] + + roles = ([(name, cls) + for name, cls in sorted(coqdomain.CoqDomain.roles.items()) + if not isinstance(cls, (sphinx.roles.XRefRole, coqdomain.IndexXRefRole))] + + [(fn.role_name, fn) + for fn in coqdomain.COQ_ADDITIONAL_ROLES]) + roles_docs = [format_docstring("``:{}:`` {}", role, name) + for (name, role) in roles] + + directives_docs = [format_docstring("``.. {}::`` {}", d, d.directive_name) + for d in coqdomain.COQ_ADDITIONAL_DIRECTIVES] + + with open(README_TEMPLATE_PATH, encoding="utf-8") as readme: + contents = readme.read() + + with open(README_PATH, mode="w", encoding="utf-8") as readme: + readme.write(contents + .replace(README_ROLES_MARKER, "\n\n".join(roles_docs)) + .replace(README_OBJECTS_MARKER, "\n\n".join(objects_docs)) + .replace(README_DIRECTIVES_MARKER, "\n\n".join(directives_docs))) + +if __name__ == '__main__': + regen_readme() diff --git a/doc/tools/coqrst/repl/coqtop.py b/doc/tools/coqrst/repl/coqtop.py index efb5cb550..3ff00eaaf 100644 --- a/doc/tools/coqrst/repl/coqtop.py +++ b/doc/tools/coqrst/repl/coqtop.py @@ -41,8 +41,13 @@ class CoqTop: the ansicolors module) :param args: Additional arugments to coqtop. """ - self.coqtop_bin = coqtop_bin or os.path.join(os.getenv('COQBIN'),"coqtop") - self.args = (args or []) + ["-boot", "-color", "on"] * color + BOOT = True + if os.getenv('COQBOOT') == "no": + BOOT = False + self.coqtop_bin = coqtop_bin or os.path.join(os.getenv('COQBIN', ""), "coqtop") + if not pexpect.utils.which(self.coqtop_bin): + raise ValueError("coqtop binary not found: '{}'".format(self.coqtop_bin)) + self.args = (args or []) + ["-boot"] * BOOT + ["-color", "on"] * color self.coqtop = None def __enter__(self): diff --git a/doc/tutorial/Tutorial.tex b/doc/tutorial/Tutorial.tex deleted file mode 100644 index 77ce8574f..000000000 --- a/doc/tutorial/Tutorial.tex +++ /dev/null @@ -1,1575 +0,0 @@ -\documentclass[11pt,a4paper]{book} -\usepackage[T1]{fontenc} -\usepackage[utf8]{inputenc} -\usepackage{textcomp} -\usepackage{pslatex} -\usepackage{hyperref} - -\input{../common/version.tex} -\input{../common/macros.tex} -\input{../common/title.tex} - -%\makeindex - -\begin{document} -\coverpage{A Tutorial}{Gérard Huet, Gilles Kahn and Christine Paulin-Mohring}{} - -%\tableofcontents - -\chapter*{Getting started} - -\Coq{} is a Proof Assistant for a Logical Framework known as the Calculus -of Inductive Constructions. It allows the interactive construction of -formal proofs, and also the manipulation of functional programs -consistently with their specifications. It runs as a computer program -on many architectures. - -It is available with a variety of user interfaces. The present -document does not attempt to present a comprehensive view of all the -possibilities of \Coq, but rather to present in the most elementary -manner a tutorial on the basic specification language, called Gallina, -in which formal axiomatisations may be developed, and on the main -proof tools. For more advanced information, the reader could refer to -the \Coq{} Reference Manual or the \textit{Coq'Art}, a book by Y. -Bertot and P. Castéran on practical uses of the \Coq{} system. - -Instructions on installation procedures, as well as more comprehensive -documentation, may be found in the standard distribution of \Coq, -which may be obtained from \Coq{} web site -\url{https://coq.inria.fr/}\footnote{You can report any bug you find -while using \Coq{} at \url{https://coq.inria.fr/bugs}. Make sure to -always provide a way to reproduce it and to specify the exact version -you used. You can get this information by running \texttt{coqc -v}}. -\Coq{} is distributed together with a graphical user interface called -CoqIDE. Alternative interfaces exist such as -Proof General\footnote{See \url{https://proofgeneral.github.io/}.}. - -In the following examples, lines preceded by the prompt \verb:Coq < : -represent user input, terminated by a period. -The following lines usually show \Coq's answer. -When used from a graphical user interface such as -CoqIDE, the prompt is not displayed: user input is given in one window -and \Coq's answers are displayed in a different window. - -\chapter{Basic Predicate Calculus} - -\section{An overview of the specification language Gallina} - -A formal development in Gallina consists in a sequence of {\sl declarations} -and {\sl definitions}. - -\subsection{Declarations} - -A declaration associates a {\sl name} with a {\sl specification}. -A name corresponds roughly to an identifier in a programming -language, i.e. to a string of letters, digits, and a few ASCII symbols like -underscore (\verb"_") and prime (\verb"'"), starting with a letter. -We use case distinction, so that the names \verb"A" and \verb"a" are distinct. -Certain strings are reserved as key-words of \Coq, and thus are forbidden -as user identifiers. - -A specification is a formal expression which classifies the notion which is -being declared. There are basically three kinds of specifications: -{\sl logical propositions}, {\sl mathematical collections}, and -{\sl abstract types}. They are classified by the three basic sorts -of the system, called respectively \verb:Prop:, \verb:Set:, and -\verb:Type:, which are themselves atomic abstract types. - -Every valid expression $e$ in Gallina is associated with a specification, -itself a valid expression, called its {\sl type} $\tau(E)$. We write -$e:\tau(E)$ for the judgment that $e$ is of type $E$. -You may request \Coq{} to return to you the type of a valid expression by using -the command \verb:Check:: - -\begin{coq_eval} -Set Printing Width 60. -\end{coq_eval} - -\begin{coq_example} -Check O. -\end{coq_example} - -Thus we know that the identifier \verb:O: (the name `O', not to be -confused with the numeral `0' which is not a proper identifier!) is -known in the current context, and that its type is the specification -\verb:nat:. This specification is itself classified as a mathematical -collection, as we may readily check: - -\begin{coq_example} -Check nat. -\end{coq_example} - -The specification \verb:Set: is an abstract type, one of the basic -sorts of the Gallina language, whereas the notions $nat$ and $O$ are -notions which are defined in the arithmetic prelude, -automatically loaded when running the \Coq{} system. - -We start by introducing a so-called section name. The role of sections -is to structure the modelisation by limiting the scope of parameters, -hypotheses and definitions. It will also give a convenient way to -reset part of the development. - -\begin{coq_example} -Section Declaration. -\end{coq_example} -With what we already know, we may now enter in the system a declaration, -corresponding to the informal mathematics {\sl let n be a natural - number}. - -\begin{coq_example} -Variable n : nat. -\end{coq_example} - -If we want to translate a more precise statement, such as -{\sl let n be a positive natural number}, -we have to add another declaration, which will declare explicitly the -hypothesis \verb:Pos_n:, with specification the proper logical -proposition: -\begin{coq_example} -Hypothesis Pos_n : (gt n 0). -\end{coq_example} - -Indeed we may check that the relation \verb:gt: is known with the right type -in the current context: - -\begin{coq_example} -Check gt. -\end{coq_example} - -which tells us that \texttt{gt} is a function expecting two arguments of -type \texttt{nat} in order to build a logical proposition. -What happens here is similar to what we are used to in a functional -programming language: we may compose the (specification) type \texttt{nat} -with the (abstract) type \texttt{Prop} of logical propositions through the -arrow function constructor, in order to get a functional type -\texttt{nat -> Prop}: -\begin{coq_example} -Check (nat -> Prop). -\end{coq_example} -which may be composed once more with \verb:nat: in order to obtain the -type \texttt{nat -> nat -> Prop} of binary relations over natural numbers. -Actually the type \texttt{nat -> nat -> Prop} is an abbreviation for -\texttt{nat -> (nat -> Prop)}. - -Functional notions may be composed in the usual way. An expression $f$ -of type $A\ra B$ may be applied to an expression $e$ of type $A$ in order -to form the expression $(f~e)$ of type $B$. Here we get that -the expression \verb:(gt n): is well-formed of type \texttt{nat -> Prop}, -and thus that the expression \verb:(gt n O):, which abbreviates -\verb:((gt n) O):, is a well-formed proposition. -\begin{coq_example} -Check gt n O. -\end{coq_example} - -\subsection{Definitions} - -The initial prelude contains a few arithmetic definitions: -\texttt{nat} is defined as a mathematical collection (type \texttt{Set}), -constants \texttt{O}, \texttt{S}, \texttt{plus}, are defined as objects of -types respectively \texttt{nat}, \texttt{nat -> nat}, and \texttt{nat -> -nat -> nat}. -You may introduce new definitions, which link a name to a well-typed value. -For instance, we may introduce the constant \texttt{one} as being defined -to be equal to the successor of zero: -\begin{coq_example} -Definition one := (S O). -\end{coq_example} -We may optionally indicate the required type: -\begin{coq_example} -Definition two : nat := S one. -\end{coq_example} - -Actually \Coq{} allows several possible syntaxes: -\begin{coq_example} -Definition three := S two : nat. -\end{coq_example} - -Here is a way to define the doubling function, which expects an -argument \verb:m: of type \verb:nat: in order to build its result as -\verb:(plus m m):: - -\begin{coq_example} -Definition double (m : nat) := plus m m. -\end{coq_example} -This introduces the constant \texttt{double} defined as the -expression \texttt{fun m : nat => plus m m}. -The abstraction introduced by \texttt{fun} is explained as follows. -The expression \texttt{fun x : A => e} is well formed of type -\texttt{A -> B} in a context whenever the expression \texttt{e} is -well-formed of type \texttt{B} in the given context to which we add the -declaration that \texttt{x} is of type \texttt{A}. Here \texttt{x} is a -bound, or dummy variable in the expression \texttt{fun x : A => e}. -For instance we could as well have defined \texttt{double} as -\texttt{fun n : nat => (plus n n)}. - -Bound (local) variables and free (global) variables may be mixed. -For instance, we may define the function which adds the constant \verb:n: -to its argument as -\begin{coq_example} -Definition add_n (m:nat) := plus m n. -\end{coq_example} -However, note that here we may not rename the formal argument $m$ into $n$ -without capturing the free occurrence of $n$, and thus changing the meaning -of the defined notion. - -Binding operations are well known for instance in logic, where they -are called quantifiers. Thus we may universally quantify a -proposition such as $m>0$ in order to get a universal proposition -$\forall m\cdot m>0$. Indeed this operator is available in \Coq, with -the following syntax: \texttt{forall m : nat, gt m O}. Similarly to the -case of the functional abstraction binding, we are obliged to declare -explicitly the type of the quantified variable. We check: -\begin{coq_example} -Check (forall m : nat, gt m 0). -\end{coq_example} - -\begin{coq_eval} -Reset Initial. -Set Printing Width 60. -Set Printing Compact Contexts. -\end{coq_eval} - -\section{Introduction to the proof engine: Minimal Logic} - -In the following, we are going to consider various propositions, built -from atomic propositions $A, B, C$. This may be done easily, by -introducing these atoms as global variables declared of type \verb:Prop:. -It is easy to declare several names with the same specification: -\begin{coq_example} -Section Minimal_Logic. -Variables A B C : Prop. -\end{coq_example} - -We shall consider simple implications, such as $A\ra B$, read as -``$A$ implies $B$''. Note that we overload the arrow symbol, which -has been used above as the functionality type constructor, and which -may be used as well as propositional connective: -\begin{coq_example} -Check (A -> B). -\end{coq_example} - -Let us now embark on a simple proof. We want to prove the easy tautology -$((A\ra (B\ra C))\ra (A\ra B)\ra (A\ra C)$. -We enter the proof engine by the command -\verb:Goal:, followed by the conjecture we want to verify: -\begin{coq_example} -Goal (A -> B -> C) -> (A -> B) -> A -> C. -\end{coq_example} - -The system displays the current goal below a double line, local hypotheses -(there are none initially) being displayed above the line. We call -the combination of local hypotheses with a goal a {\sl judgment}. -We are now in an inner -loop of the system, in proof mode. -New commands are available in this -mode, such as {\sl tactics}, which are proof combining primitives. -A tactic operates on the current goal by attempting to construct a proof -of the corresponding judgment, possibly from proofs of some -hypothetical judgments, which are then added to the current -list of conjectured judgments. -For instance, the \verb:intro: tactic is applicable to any judgment -whose goal is an implication, by moving the proposition to the left -of the application to the list of local hypotheses: -\begin{coq_example} -intro H. -\end{coq_example} - -Several introductions may be done in one step: -\begin{coq_example} -intros H' HA. -\end{coq_example} - -We notice that $C$, the current goal, may be obtained from hypothesis -\verb:H:, provided the truth of $A$ and $B$ are established. -The tactic \verb:apply: implements this piece of reasoning: -\begin{coq_example} -apply H. -\end{coq_example} - -We are now in the situation where we have two judgments as conjectures -that remain to be proved. Only the first is listed in full, for the -others the system displays only the corresponding subgoal, without its -local hypotheses list. Note that \verb:apply: has kept the local -hypotheses of its father judgment, which are still available for -the judgments it generated. - -In order to solve the current goal, we just have to notice that it is -exactly available as hypothesis $HA$: -\begin{coq_example} -exact HA. -\end{coq_example} - -Now $H'$ applies: -\begin{coq_example} -apply H'. -\end{coq_example} - -And we may now conclude the proof as before, with \verb:exact HA.: -Actually, we may not bother with the name \verb:HA:, and just state that -the current goal is solvable from the current local assumptions: -\begin{coq_example} -assumption. -\end{coq_example} - -The proof is now finished. We are now going to ask \Coq{}'s kernel -to check and save the proof. -\begin{coq_example} -Qed. -\end{coq_example} - -Let us redo the same proof with a few variations. First of all we may name -the initial goal as a conjectured lemma: -\begin{coq_example} -Lemma distr_impl : (A -> B -> C) -> (A -> B) -> A -> C. -\end{coq_example} - -Next, we may omit the names of local assumptions created by the introduction -tactics, they can be automatically created by the proof engine as new -non-clashing names. -\begin{coq_example} -intros. -\end{coq_example} - -The \verb:intros: tactic, with no arguments, effects as many individual -applications of \verb:intro: as is legal. - -Then, we may compose several tactics together in sequence, or in parallel, -through {\sl tacticals}, that is tactic combinators. The main constructions -are the following: -\begin{itemize} -\item $T_1 ; T_2$ (read $T_1$ then $T_2$) applies tactic $T_1$ to the current -goal, and then tactic $T_2$ to all the subgoals generated by $T_1$. -\item $T; [T_1 | T_2 | ... | T_n]$ applies tactic $T$ to the current -goal, and then tactic $T_1$ to the first newly generated subgoal, -..., $T_n$ to the nth. -\end{itemize} - -We may thus complete the proof of \verb:distr_impl: with one composite tactic: -\begin{coq_example} -apply H; [ assumption | apply H0; assumption ]. -\end{coq_example} - -You should be aware however that relying on automatically generated names is -not robust to slight updates to this proof script. Consequently, it is -discouraged in finished proof scripts. As for the composition of tactics with -\texttt{:} it may hinder the readability of the proof script and it is also -harder to see what's going on when replaying the proof because composed -tactics are evaluated in one go. - -Actually, such an easy combination of tactics \verb:intro:, \verb:apply: -and \verb:assumption: may be found completely automatically by an automatic -tactic, called \verb:auto:, without user guidance: - -\begin{coq_eval} -Abort. -\end{coq_eval} -\begin{coq_example} -Lemma distr_impl : (A -> B -> C) -> (A -> B) -> A -> C. -auto. -\end{coq_example} - -Let us now save lemma \verb:distr_impl:: -\begin{coq_example} -Qed. -\end{coq_example} - -\section{Propositional Calculus} - -\subsection{Conjunction} - -We have seen how \verb:intro: and \verb:apply: tactics could be combined -in order to prove implicational statements. More generally, \Coq{} favors a style -of reasoning, called {\sl Natural Deduction}, which decomposes reasoning into -so called {\sl introduction rules}, which tell how to prove a goal whose main -operator is a given propositional connective, and {\sl elimination rules}, -which tell how to use an hypothesis whose main operator is the propositional -connective. Let us show how to use these ideas for the propositional connectives -\verb:/\: and \verb:\/:. - -\begin{coq_example} -Lemma and_commutative : A /\ B -> B /\ A. -intro H. -\end{coq_example} - -We make use of the conjunctive hypothesis \verb:H: with the \verb:elim: tactic, -which breaks it into its components: -\begin{coq_example} -elim H. -\end{coq_example} - -We now use the conjunction introduction tactic \verb:split:, which splits the -conjunctive goal into the two subgoals: -\begin{coq_example} -split. -\end{coq_example} -and the proof is now trivial. Indeed, the whole proof is obtainable as follows: -\begin{coq_eval} -Abort. -\end{coq_eval} -\begin{coq_example} -Lemma and_commutative : A /\ B -> B /\ A. -intro H; elim H; auto. -Qed. -\end{coq_example} - -The tactic \verb:auto: succeeded here because it knows as a hint the -conjunction introduction operator \verb+conj+ -\begin{coq_example} -Check conj. -\end{coq_example} - -Actually, the tactic \verb+split+ is just an abbreviation for \verb+apply conj.+ - -What we have just seen is that the \verb:auto: tactic is more powerful than -just a simple application of local hypotheses; it tries to apply as well -lemmas which have been specified as hints. A -\verb:Hint Resolve: command registers a -lemma as a hint to be used from now on by the \verb:auto: tactic, whose power -may thus be incrementally augmented. - -\subsection{Disjunction} - -In a similar fashion, let us consider disjunction: - -\begin{coq_example} -Lemma or_commutative : A \/ B -> B \/ A. -intro H; elim H. -\end{coq_example} - -Let us prove the first subgoal in detail. We use \verb:intro: in order to -be left to prove \verb:B\/A: from \verb:A:: - -\begin{coq_example} -intro HA. -\end{coq_example} - -Here the hypothesis \verb:H: is not needed anymore. We could choose to -actually erase it with the tactic \verb:clear:; in this simple proof it -does not really matter, but in bigger proof developments it is useful to -clear away unnecessary hypotheses which may clutter your screen. -\begin{coq_example} -clear H. -\end{coq_example} - -The tactic \verb:destruct: combines the effects of \verb:elim:, \verb:intros:, -and \verb:clear:: - -\begin{coq_eval} -Abort. -\end{coq_eval} -\begin{coq_example} -Lemma or_commutative : A \/ B -> B \/ A. -intros H; destruct H. -\end{coq_example} - -The disjunction connective has two introduction rules, since \verb:P\/Q: -may be obtained from \verb:P: or from \verb:Q:; the two corresponding -proof constructors are called respectively \verb:or_introl: and -\verb:or_intror:; they are applied to the current goal by tactics -\verb:left: and \verb:right: respectively. For instance: -\begin{coq_example} -right. -trivial. -\end{coq_example} -The tactic \verb:trivial: works like \verb:auto: with the hints -database, but it only tries those tactics that can solve the goal in one -step. - -As before, all these tedious elementary steps may be performed automatically, -as shown for the second symmetric case: - -\begin{coq_example} -auto. -\end{coq_example} - -However, \verb:auto: alone does not succeed in proving the full lemma, because -it does not try any elimination step. -It is a bit disappointing that \verb:auto: is not able to prove automatically -such a simple tautology. The reason is that we want to keep -\verb:auto: efficient, so that it is always effective to use. - -\subsection{Tauto} - -A complete tactic for propositional -tautologies is indeed available in \Coq{} as the \verb:tauto: tactic. -\begin{coq_eval} -Abort. -\end{coq_eval} -\begin{coq_example} -Lemma or_commutative : A \/ B -> B \/ A. -tauto. -Qed. -\end{coq_example} - -It is possible to inspect the actual proof tree constructed by \verb:tauto:, -using a standard command of the system, which prints the value of any notion -currently defined in the context: -\begin{coq_example} -Print or_commutative. -\end{coq_example} - -It is not easy to understand the notation for proof terms without some -explanations. The \texttt{fun} prefix, such as \verb+fun H : A\/B =>+, -corresponds -to \verb:intro H:, whereas a subterm such as -\verb:(or_intror: \verb:B H0): -corresponds to the sequence of tactics \verb:apply or_intror; exact H0:. -The generic combinator \verb:or_intror: needs to be instantiated by -the two properties \verb:B: and \verb:A:. Because \verb:A: can be -deduced from the type of \verb:H0:, only \verb:B: is printed. -The two instantiations are effected automatically by the tactic -\verb:apply: when pattern-matching a goal. The specialist will of course -recognize our proof term as a $\lambda$-term, used as notation for the -natural deduction proof term through the Curry-Howard isomorphism. The -naive user of \Coq{} may safely ignore these formal details. - -Let us exercise the \verb:tauto: tactic on a more complex example: -\begin{coq_example} -Lemma distr_and : A -> B /\ C -> (A -> B) /\ (A -> C). -tauto. -Qed. -\end{coq_example} - -\subsection{Classical reasoning} - -The tactic \verb:tauto: always comes back with an answer. Here is an example where it -fails: -\begin{coq_example} -Lemma Peirce : ((A -> B) -> A) -> A. -try tauto. -\end{coq_example} - -Note the use of the \verb:try: tactical, which does nothing if its tactic -argument fails. - -This may come as a surprise to someone familiar with classical reasoning. -Peirce's lemma is true in Boolean logic, i.e. it evaluates to \verb:true: for -every truth-assignment to \verb:A: and \verb:B:. Indeed the double negation -of Peirce's law may be proved in \Coq{} using \verb:tauto:: -\begin{coq_eval} -Abort. -\end{coq_eval} -\begin{coq_example} -Lemma NNPeirce : ~ ~ (((A -> B) -> A) -> A). -tauto. -Qed. -\end{coq_example} - -In classical logic, the double negation of a proposition is equivalent to this -proposition, but in the constructive logic of \Coq{} this is not so. If you -want to use classical logic in \Coq, you have to import explicitly the -\verb:Classical: module, which will declare the axiom \verb:classic: -of excluded middle, and classical tautologies such as de Morgan's laws. -The \verb:Require: command is used to import a module from \Coq's library: -\begin{coq_example} -Require Import Classical. -Check NNPP. -\end{coq_example} - -and it is now easy (although admittedly not the most direct way) to prove -a classical law such as Peirce's: -\begin{coq_example} -Lemma Peirce : ((A -> B) -> A) -> A. -apply NNPP; tauto. -Qed. -\end{coq_example} - -Here is one more example of propositional reasoning, in the shape of -a Scottish puzzle. A private club has the following rules: -\begin{enumerate} -\item Every non-scottish member wears red socks -\item Every member wears a kilt or doesn't wear red socks -\item The married members don't go out on Sunday -\item A member goes out on Sunday if and only if he is Scottish -\item Every member who wears a kilt is Scottish and married -\item Every scottish member wears a kilt -\end{enumerate} -Now, we show that these rules are so strict that no one can be accepted. -\begin{coq_example} -Section club. -Variables Scottish RedSocks WearKilt Married GoOutSunday : Prop. -Hypothesis rule1 : ~ Scottish -> RedSocks. -Hypothesis rule2 : WearKilt \/ ~ RedSocks. -Hypothesis rule3 : Married -> ~ GoOutSunday. -Hypothesis rule4 : GoOutSunday <-> Scottish. -Hypothesis rule5 : WearKilt -> Scottish /\ Married. -Hypothesis rule6 : Scottish -> WearKilt. -Lemma NoMember : False. -tauto. -Qed. -\end{coq_example} -At that point \verb:NoMember: is a proof of the absurdity depending on -hypotheses. -We may end the section, in that case, the variables and hypotheses -will be discharged, and the type of \verb:NoMember: will be -generalised. - -\begin{coq_example} -End club. -Check NoMember. -\end{coq_example} - -\section{Predicate Calculus} - -Let us now move into predicate logic, and first of all into first-order -predicate calculus. The essence of predicate calculus is that to try to prove -theorems in the most abstract possible way, without using the definitions of -the mathematical notions, but by formal manipulations of uninterpreted -function and predicate symbols. - -\subsection{Sections and signatures} - -Usually one works in some domain of discourse, over which range the individual -variables and function symbols. In \Coq{}, we speak in a language with a rich -variety of types, so we may mix several domains of discourse, in our -multi-sorted language. For the moment, we just do a few exercises, over a -domain of discourse \verb:D: axiomatised as a \verb:Set:, and we consider two -predicate symbols \verb:P: and \verb:R: over \verb:D:, of arities -1 and 2, respectively. - -\begin{coq_eval} -Reset Initial. -Set Printing Width 60. -Set Printing Compact Contexts. -\end{coq_eval} - -We start by assuming a domain of -discourse \verb:D:, and a binary relation \verb:R: over \verb:D:: -\begin{coq_example} -Section Predicate_calculus. -Variable D : Set. -Variable R : D -> D -> Prop. -\end{coq_example} - -As a simple example of predicate calculus reasoning, let us assume -that relation \verb:R: is symmetric and transitive, and let us show that -\verb:R: is reflexive in any point \verb:x: which has an \verb:R: successor. -Since we do not want to make the assumptions about \verb:R: global axioms of -a theory, but rather local hypotheses to a theorem, we open a specific -section to this effect. -\begin{coq_example} -Section R_sym_trans. -Hypothesis R_symmetric : forall x y : D, R x y -> R y x. -Hypothesis R_transitive : - forall x y z : D, R x y -> R y z -> R x z. -\end{coq_example} - -Note the syntax \verb+forall x : D,+ which stands for universal quantification -$\forall x : D$. - -\subsection{Existential quantification} - -We now state our lemma, and enter proof mode. -\begin{coq_example} -Lemma refl_if : forall x : D, (exists y, R x y) -> R x x. -\end{coq_example} - -The hypotheses that are local to the currently opened sections -are listed as local hypotheses to the current goals. -That is because these hypotheses are going to be discharged, as -we shall see, when we shall close the corresponding sections. - -Note the functional syntax for existential quantification. The existential -quantifier is built from the operator \verb:ex:, which expects a -predicate as argument: -\begin{coq_example} -Check ex. -\end{coq_example} -and the notation \verb+(exists x : D, P x)+ is just concrete syntax for -the expression \verb+(ex D (fun x : D => P x))+. -Existential quantification is handled in \Coq{} in a similar -fashion to the connectives \verb:/\: and \verb:\/:: it is introduced by -the proof combinator \verb:ex_intro:, which is invoked by the specific -tactic \verb:exists:, and its elimination provides a witness \verb+a : D+ to -\verb:P:, together with an assumption \verb+h : (P a)+ that indeed \verb+a+ -verifies \verb:P:. Let us see how this works on this simple example. -\begin{coq_example} -intros x x_Rlinked. -\end{coq_example} - -Note that \verb:intros: treats universal quantification in the same way -as the premises of implications. Renaming of bound variables occurs -when it is needed; for instance, had we started with \verb:intro y:, -we would have obtained the goal: -\begin{coq_eval} -Undo. -\end{coq_eval} -\begin{coq_example} -intro y. -\end{coq_example} -\begin{coq_eval} -Undo. -intros x x_Rlinked. -\end{coq_eval} - -Let us now use the existential hypothesis \verb:x_Rlinked: to -exhibit an R-successor y of x. This is done in two steps, first with -\verb:elim:, then with \verb:intros: - -\begin{coq_example} -elim x_Rlinked. -intros y Rxy. -\end{coq_example} - -Now we want to use \verb:R_transitive:. The \verb:apply: tactic will know -how to match \verb:x: with \verb:x:, and \verb:z: with \verb:x:, but needs -help on how to instantiate \verb:y:, which appear in the hypotheses of -\verb:R_transitive:, but not in its conclusion. We give the proper hint -to \verb:apply: in a \verb:with: clause, as follows: -\begin{coq_example} -apply R_transitive with y. -\end{coq_example} - -The rest of the proof is routine: -\begin{coq_example} -assumption. -apply R_symmetric; assumption. -\end{coq_example} -\begin{coq_example*} -Qed. -\end{coq_example*} - -Let us now close the current section. -\begin{coq_example} -End R_sym_trans. -\end{coq_example} - -All the local hypotheses have been -discharged in the statement of \verb:refl_if:, which now becomes a general -theorem in the first-order language declared in section -\verb:Predicate_calculus:. In this particular example, section -\verb:R_sym_trans: has not been really useful, since we could have -instead stated theorem \verb:refl_if: in its general form, and done -basically the same proof, obtaining \verb:R_symmetric: and -\verb:R_transitive: as local hypotheses by initial \verb:intros: rather -than as global hypotheses in the context. But if we had pursued the -theory by proving more theorems about relation \verb:R:, -we would have obtained all general statements at the closing of the section, -with minimal dependencies on the hypotheses of symmetry and transitivity. - -\subsection{Paradoxes of classical predicate calculus} - -Let us illustrate this feature by pursuing our \verb:Predicate_calculus: -section with an enrichment of our language: we declare a unary predicate -\verb:P: and a constant \verb:d:: -\begin{coq_example} -Variable P : D -> Prop. -Variable d : D. -\end{coq_example} - -We shall now prove a well-known fact from first-order logic: a universal -predicate is non-empty, or in other terms existential quantification -follows from universal quantification. -\begin{coq_example} -Lemma weird : (forall x:D, P x) -> exists a, P a. - intro UnivP. -\end{coq_example} - -First of all, notice the pair of parentheses around -\verb+forall x : D, P x+ in -the statement of lemma \verb:weird:. -If we had omitted them, \Coq's parser would have interpreted the -statement as a truly trivial fact, since we would -postulate an \verb:x: verifying \verb:(P x):. Here the situation is indeed -more problematic. If we have some element in \verb:Set: \verb:D:, we may -apply \verb:UnivP: to it and conclude, otherwise we are stuck. Indeed -such an element \verb:d: exists, but this is just by virtue of our -new signature. This points out a subtle difference between standard -predicate calculus and \Coq. In standard first-order logic, -the equivalent of lemma \verb:weird: always holds, -because such a rule is wired in the inference rules for quantifiers, the -semantic justification being that the interpretation domain is assumed to -be non-empty. Whereas in \Coq, where types are not assumed to be -systematically inhabited, lemma \verb:weird: only holds in signatures -which allow the explicit construction of an element in the domain of -the predicate. - -Let us conclude the proof, in order to show the use of the \verb:exists: -tactic: -\begin{coq_example} -exists d; trivial. -Qed. -\end{coq_example} - -Another fact which illustrates the sometimes disconcerting rules of -classical -predicate calculus is Smullyan's drinkers' paradox: ``In any non-empty -bar, there is a person such that if she drinks, then everyone drinks''. -We modelize the bar by Set \verb:D:, drinking by predicate \verb:P:. -We shall need classical reasoning. Instead of loading the \verb:Classical: -module as we did above, we just state the law of excluded middle as a -local hypothesis schema at this point: -\begin{coq_example} -Hypothesis EM : forall A : Prop, A \/ ~ A. -Lemma drinker : exists x : D, P x -> forall x : D, P x. -\end{coq_example} -The proof goes by cases on whether or not -there is someone who does not drink. Such reasoning by cases proceeds -by invoking the excluded middle principle, via \verb:elim: of the -proper instance of \verb:EM:: -\begin{coq_example} -elim (EM (exists x, ~ P x)). -\end{coq_example} - -We first look at the first case. Let Tom be the non-drinker. -The following combines at once the effect of \verb:intros: and -\verb:destruct:: -\begin{coq_example} -intros (Tom, Tom_does_not_drink). -\end{coq_example} - -We conclude in that case by considering Tom, since his drinking leads to -a contradiction: -\begin{coq_example} -exists Tom; intro Tom_drinks. -\end{coq_example} - -There are several ways in which we may eliminate a contradictory case; -in this case, we use \verb:contradiction: to let \Coq{} find out the -two contradictory hypotheses: -\begin{coq_example} -contradiction. -\end{coq_example} - -We now proceed with the second case, in which actually any person will do; -such a John Doe is given by the non-emptiness witness \verb:d:: -\begin{coq_example} -intro No_nondrinker; exists d; intro d_drinks. -\end{coq_example} - -Now we consider any Dick in the bar, and reason by cases according to its -drinking or not: -\begin{coq_example} -intro Dick; elim (EM (P Dick)); trivial. -\end{coq_example} - -The only non-trivial case is again treated by contradiction: -\begin{coq_example} -intro Dick_does_not_drink; absurd (exists x, ~ P x); trivial. -exists Dick; trivial. -Qed. -\end{coq_example} - -Now, let us close the main section and look at the complete statements -we proved: -\begin{coq_example} -End Predicate_calculus. -Check refl_if. -Check weird. -Check drinker. -\end{coq_example} - -Note how the three theorems are completely generic in the most general -fashion; -the domain \verb:D: is discharged in all of them, \verb:R: is discharged in -\verb:refl_if: only, \verb:P: is discharged only in \verb:weird: and -\verb:drinker:, along with the hypothesis that \verb:D: is inhabited. -Finally, the excluded middle hypothesis is discharged only in -\verb:drinker:. - -Note, too, that the name \verb:d: has vanished from -the statements of \verb:weird: and \verb:drinker:, -since \Coq's pretty-printer replaces -systematically a quantification such as \texttt{forall d : D, E}, -where \texttt{d} does not occur in \texttt{E}, -by the functional notation \texttt{D -> E}. -Similarly the name \texttt{EM} does not appear in \texttt{drinker}. - -Actually, universal quantification, implication, -as well as function formation, are -all special cases of one general construct of type theory called -{\sl dependent product}. This is the mathematical construction -corresponding to an indexed family of functions. A function -$f\in \Pi x:D\cdot Cx$ maps an element $x$ of its domain $D$ to its -(indexed) codomain $Cx$. Thus a proof of $\forall x:D\cdot Px$ is -a function mapping an element $x$ of $D$ to a proof of proposition $Px$. - - -\subsection{Flexible use of local assumptions} - -Very often during the course of a proof we want to retrieve a local -assumption and reintroduce it explicitly in the goal, for instance -in order to get a more general induction hypothesis. The tactic -\verb:generalize: is what is needed here: - -\begin{coq_example} -Section Predicate_Calculus. -Variables P Q : nat -> Prop. -Variable R : nat -> nat -> Prop. -Lemma PQR : - forall x y:nat, (R x x -> P x -> Q x) -> P x -> R x y -> Q x. -intros. -generalize H0. -\end{coq_example} - -Sometimes it may be convenient to state an intermediate fact. -The tactic \verb:assert: does this and introduces a new subgoal -for this fact to be proved first. The tactic \verb:enough: does -the same while keeping this goal for later. -\begin{coq_example} -enough (R x x) by auto. -\end{coq_example} -We clean the goal by doing an \verb:Abort: command. -\begin{coq_example*} -Abort. -\end{coq_example*} - - -\subsection{Equality} - -The basic equality provided in \Coq{} is Leibniz equality, noted infix like -\texttt{x = y}, when \texttt{x} and \texttt{y} are two expressions of -type the same Set. The replacement of \texttt{x} by \texttt{y} in any -term is effected by a variety of tactics, such as \texttt{rewrite} -and \texttt{replace}. - -Let us give a few examples of equality replacement. Let us assume that -some arithmetic function \verb:f: is null in zero: -\begin{coq_example} -Variable f : nat -> nat. -Hypothesis foo : f 0 = 0. -\end{coq_example} - -We want to prove the following conditional equality: -\begin{coq_example*} -Lemma L1 : forall k:nat, k = 0 -> f k = k. -\end{coq_example*} - -As usual, we first get rid of local assumptions with \verb:intro:: -\begin{coq_example} -intros k E. -\end{coq_example} - -Let us now use equation \verb:E: as a left-to-right rewriting: -\begin{coq_example} -rewrite E. -\end{coq_example} -This replaced both occurrences of \verb:k: by \verb:O:. - -Now \verb:apply foo: will finish the proof: - -\begin{coq_example} -apply foo. -Qed. -\end{coq_example} - -When one wants to rewrite an equality in a right to left fashion, we should -use \verb:rewrite <- E: rather than \verb:rewrite E: or the equivalent -\verb:rewrite -> E:. -Let us now illustrate the tactic \verb:replace:. -\begin{coq_example} -Hypothesis f10 : f 1 = f 0. -Lemma L2 : f (f 1) = 0. -replace (f 1) with 0. -\end{coq_example} -What happened here is that the replacement left the first subgoal to be -proved, but another proof obligation was generated by the \verb:replace: -tactic, as the second subgoal. The first subgoal is solved immediately -by applying lemma \verb:foo:; the second one transitivity and then -symmetry of equality, for instance with tactics \verb:transitivity: and -\verb:symmetry:: -\begin{coq_example} -apply foo. -transitivity (f 0); symmetry; trivial. -\end{coq_example} -In case the equality $t=u$ generated by \verb:replace: $u$ \verb:with: -$t$ is an assumption -(possibly modulo symmetry), it will be automatically proved and the -corresponding goal will not appear. For instance: - -\begin{coq_eval} -Restart. -\end{coq_eval} -\begin{coq_example} -Lemma L2 : f (f 1) = 0. -replace (f 1) with (f 0). -replace (f 0) with 0; trivial. -Qed. -\end{coq_example} - -\section{Using definitions} - -The development of mathematics does not simply proceed by logical -argumentation from first principles: definitions are used in an essential way. -A formal development proceeds by a dual process of abstraction, where one -proves abstract statements in predicate calculus, and use of definitions, -which in the contrary one instantiates general statements with particular -notions in order to use the structure of mathematical values for the proof of -more specialised properties. - -\subsection{Unfolding definitions} - -Assume that we want to develop the theory of sets represented as characteristic -predicates over some universe \verb:U:. For instance: -\begin{coq_example} -Variable U : Type. -Definition set := U -> Prop. -Definition element (x : U) (S : set) := S x. -Definition subset (A B : set) := - forall x : U, element x A -> element x B. -\end{coq_example} - -Now, assume that we have loaded a module of general properties about -relations over some abstract type \verb:T:, such as transitivity: - -\begin{coq_example} -Definition transitive (T : Type) (R : T -> T -> Prop) := - forall x y z : T, R x y -> R y z -> R x z. -\end{coq_example} - -We want to prove that \verb:subset: is a \verb:transitive: -relation. -\begin{coq_example} -Lemma subset_transitive : transitive set subset. -\end{coq_example} - -In order to make any progress, one needs to use the definition of -\verb:transitive:. The \verb:unfold: tactic, which replaces all -occurrences of a defined notion by its definition in the current goal, -may be used here. -\begin{coq_example} -unfold transitive. -\end{coq_example} - -Now, we must unfold \verb:subset:: -\begin{coq_example} -unfold subset. -\end{coq_example} -Now, unfolding \verb:element: would be a mistake, because indeed a simple proof -can be found by \verb:auto:, keeping \verb:element: an abstract predicate: -\begin{coq_example} -auto. -\end{coq_example} - -Many variations on \verb:unfold: are provided in \Coq. For instance, -instead of unfolding all occurrences of \verb:subset:, we may want to -unfold only one designated occurrence: -\begin{coq_eval} -Undo 2. -\end{coq_eval} -\begin{coq_example} -unfold subset at 2. -\end{coq_example} - -One may also unfold a definition in a given local hypothesis, using the -\verb:in: notation: -\begin{coq_example} -intros. -unfold subset in H. -\end{coq_example} - -Finally, the tactic \verb:red: does only unfolding of the head occurrence -of the current goal: -\begin{coq_example} -red. -auto. -Qed. -\end{coq_example} - - -\subsection{Principle of proof irrelevance} - -Even though in principle the proof term associated with a verified lemma -corresponds to a defined value of the corresponding specification, such -definitions cannot be unfolded in \Coq: a lemma is considered an {\sl opaque} -definition. This conforms to the mathematical tradition of {\sl proof -irrelevance}: the proof of a logical proposition does not matter, and the -mathematical justification of a logical development relies only on -{\sl provability} of the lemmas used in the formal proof. - -Conversely, ordinary mathematical definitions can be unfolded at will, they -are {\sl transparent}. - -\chapter{Induction} - -\begin{coq_eval} -Reset Initial. -Set Printing Width 60. -Set Printing Compact Contexts. -\end{coq_eval} - -\section{Data Types as Inductively Defined Mathematical Collections} - -All the notions which were studied until now pertain to traditional -mathematical logic. Specifications of objects were abstract properties -used in reasoning more or less constructively; we are now entering -the realm of inductive types, which specify the existence of concrete -mathematical constructions. - -\subsection{Booleans} - -Let us start with the collection of booleans, as they are specified -in the \Coq's \verb:Prelude: module: -\begin{coq_example} -Inductive bool : Set := true | false. -\end{coq_example} - -Such a declaration defines several objects at once. First, a new -\verb:Set: is declared, with name \verb:bool:. Then the {\sl constructors} -of this \verb:Set: are declared, called \verb:true: and \verb:false:. -Those are analogous to introduction rules of the new Set \verb:bool:. -Finally, a specific elimination rule for \verb:bool: is now available, which -permits to reason by cases on \verb:bool: values. Three instances are -indeed defined as new combinators in the global context: \verb:bool_ind:, -a proof combinator corresponding to reasoning by cases, -\verb:bool_rec:, an if-then-else programming construct, -and \verb:bool_rect:, a similar combinator at the level of types. -Indeed: -\begin{coq_example} -Check bool_ind. -Check bool_rec. -Check bool_rect. -\end{coq_example} - -Let us for instance prove that every Boolean is true or false. -\begin{coq_example} -Lemma duality : forall b:bool, b = true \/ b = false. -intro b. -\end{coq_example} - -We use the knowledge that \verb:b: is a \verb:bool: by calling tactic -\verb:elim:, which is this case will appeal to combinator \verb:bool_ind: -in order to split the proof according to the two cases: -\begin{coq_example} -elim b. -\end{coq_example} - -It is easy to conclude in each case: -\begin{coq_example} -left; trivial. -right; trivial. -\end{coq_example} - -Indeed, the whole proof can be done with the combination of the - \verb:destruct:, which combines \verb:intro: and \verb:elim:, -with good old \verb:auto:: -\begin{coq_eval} -Abort. -\end{coq_eval} -\begin{coq_example} -Lemma duality : forall b:bool, b = true \/ b = false. -destruct b; auto. -Qed. -\end{coq_example} - -\subsection{Natural numbers} - -Similarly to Booleans, natural numbers are defined in the \verb:Prelude: -module with constructors \verb:S: and \verb:O:: -\begin{coq_example} -Inductive nat : Set := - | O : nat - | S : nat -> nat. -\end{coq_example} - -The elimination principles which are automatically generated are Peano's -induction principle, and a recursion operator: -\begin{coq_example} -Check nat_ind. -Check nat_rec. -\end{coq_example} - -Let us start by showing how to program the standard primitive recursion -operator \verb:prim_rec: from the more general \verb:nat_rec:: -\begin{coq_example} -Definition prim_rec := nat_rec (fun i : nat => nat). -\end{coq_example} - -That is, instead of computing for natural \verb:i: an element of the indexed -\verb:Set: \verb:(P i):, \verb:prim_rec: computes uniformly an element of -\verb:nat:. Let us check the type of \verb:prim_rec:: -\begin{coq_example} -About prim_rec. -\end{coq_example} - -Oops! Instead of the expected type \verb+nat->(nat->nat->nat)->nat->nat+ we -get an apparently more complicated expression. -In fact, the two types are convertible and one way of having the proper -type would be to do some computation before actually defining \verb:prim_rec: -as such: - -\begin{coq_eval} -Reset Initial. -Set Printing Width 60. -Set Printing Compact Contexts. -\end{coq_eval} - -\begin{coq_example} -Definition prim_rec := - Eval compute in nat_rec (fun i : nat => nat). -About prim_rec. -\end{coq_example} - -Let us now show how to program addition with primitive recursion: -\begin{coq_example} -Definition addition (n m:nat) := - prim_rec m (fun p rec : nat => S rec) n. -\end{coq_example} - -That is, we specify that \verb+(addition n m)+ computes by cases on \verb:n: -according to its main constructor; when \verb:n = O:, we get \verb:m:; - when \verb:n = S p:, we get \verb:(S rec):, where \verb:rec: is the result -of the recursive computation \verb+(addition p m)+. Let us verify it by -asking \Coq{} to compute for us say $2+3$: -\begin{coq_example} -Eval compute in (addition (S (S O)) (S (S (S O)))). -\end{coq_example} - -Actually, we do not have to do all explicitly. {\Coq} provides a -special syntax {\tt Fixpoint/match} for generic primitive recursion, -and we could thus have defined directly addition as: - -\begin{coq_example} -Fixpoint plus (n m:nat) {struct n} : nat := - match n with - | O => m - | S p => S (plus p m) - end. -\end{coq_example} - -\begin{coq_eval} -\begin{coq_example} -Reset Initial. -Set Printing Width 60. -Set Printing Compact Contexts. -\end{coq_eval} - -\subsection{Simple proofs by induction} - -Let us now show how to do proofs by structural induction. We start with easy -properties of the \verb:plus: function we just defined. Let us first -show that $n=n+0$. -\begin{coq_example} -Lemma plus_n_O : forall n : nat, n = n + 0. -intro n; elim n. -\end{coq_example} - -What happened was that \texttt{elim n}, in order to construct a \texttt{Prop} -(the initial goal) from a \texttt{nat} (i.e. \texttt{n}), appealed to the -corresponding induction principle \texttt{nat\_ind} which we saw was indeed -exactly Peano's induction scheme. Pattern-matching instantiated the -corresponding predicate \texttt{P} to \texttt{fun n : nat => n = n + 0}, -and we get as subgoals the corresponding instantiations of the base case -\texttt{(P O)}, and of the inductive step -\texttt{forall y : nat, P y -> P (S y)}. -In each case we get an instance of function \texttt{plus} in which its second -argument starts with a constructor, and is thus amenable to simplification -by primitive recursion. The \Coq{} tactic \texttt{simpl} can be used for -this purpose: -\begin{coq_example} -simpl. -auto. -\end{coq_example} - -We proceed in the same way for the base step: -\begin{coq_example} -simpl; auto. -Qed. -\end{coq_example} - -Here \verb:auto: succeeded, because it used as a hint lemma \verb:eq_S:, -which say that successor preserves equality: -\begin{coq_example} -Check eq_S. -\end{coq_example} - -Actually, let us see how to declare our lemma \verb:plus_n_O: as a hint -to be used by \verb:auto:: -\begin{coq_example} -Hint Resolve plus_n_O . -\end{coq_example} - -We now proceed to the similar property concerning the other constructor -\verb:S:: -\begin{coq_example} -Lemma plus_n_S : forall n m:nat, S (n + m) = n + S m. -\end{coq_example} - -We now go faster, using the tactic \verb:induction:, which does the -necessary \verb:intros: before applying \verb:elim:. Factoring simplification -and automation in both cases thanks to tactic composition, we prove this -lemma in one line: -\begin{coq_example} -induction n; simpl; auto. -Qed. -Hint Resolve plus_n_S . -\end{coq_example} - -Let us end this exercise with the commutativity of \verb:plus:: - -\begin{coq_example} -Lemma plus_com : forall n m:nat, n + m = m + n. -\end{coq_example} - -Here we have a choice on doing an induction on \verb:n: or on \verb:m:, the -situation being symmetric. For instance: -\begin{coq_example} -induction m as [ | m IHm ]; simpl; auto. -\end{coq_example} - -Here \verb:auto: succeeded on the base case, thanks to our hint -\verb:plus_n_O:, but the induction step requires rewriting, which -\verb:auto: does not handle: - -\begin{coq_example} -rewrite <- IHm; auto. -Qed. -\end{coq_example} - -\subsection{Discriminate} - -It is also possible to define new propositions by primitive recursion. -Let us for instance define the predicate which discriminates between -the constructors \verb:O: and \verb:S:: it computes to \verb:False: -when its argument is \verb:O:, and to \verb:True: when its argument is -of the form \verb:(S n):: -\begin{coq_example} -Definition Is_S (n : nat) := match n with - | O => False - | S p => True - end. -\end{coq_example} - -Now we may use the computational power of \verb:Is_S: to prove -trivially that \verb:(Is_S (S n)):: -\begin{coq_example} -Lemma S_Is_S : forall n:nat, Is_S (S n). -simpl; trivial. -Qed. -\end{coq_example} - -But we may also use it to transform a \verb:False: goal into -\verb:(Is_S O):. Let us show a particularly important use of this feature; -we want to prove that \verb:O: and \verb:S: construct different values, one -of Peano's axioms: -\begin{coq_example} -Lemma no_confusion : forall n:nat, 0 <> S n. -\end{coq_example} - -First of all, we replace negation by its definition, by reducing the -goal with tactic \verb:red:; then we get contradiction by successive -\verb:intros:: -\begin{coq_example} -red; intros n H. -\end{coq_example} - -Now we use our trick: -\begin{coq_example} -change (Is_S 0). -\end{coq_example} - -Now we use equality in order to get a subgoal which computes out to -\verb:True:, which finishes the proof: -\begin{coq_example} -rewrite H; trivial. -simpl; trivial. -\end{coq_example} - -Actually, a specific tactic \verb:discriminate: is provided -to produce mechanically such proofs, without the need for the user to define -explicitly the relevant discrimination predicates: - -\begin{coq_eval} -Abort. -\end{coq_eval} -\begin{coq_example} -Lemma no_confusion : forall n:nat, 0 <> S n. -intro n; discriminate. -Qed. -\end{coq_example} - - -\section{Logic programming} - -In the same way as we defined standard data-types above, we -may define inductive families, and for instance inductive predicates. -Here is the definition of predicate $\le$ over type \verb:nat:, as -given in \Coq's \verb:Prelude: module: -\begin{coq_example*} -Inductive le (n : nat) : nat -> Prop := - | le_n : le n n - | le_S : forall m : nat, le n m -> le n (S m). -\end{coq_example*} - -This definition introduces a new predicate -\verb+le : nat -> nat -> Prop+, -and the two constructors \verb:le_n: and \verb:le_S:, which are the -defining clauses of \verb:le:. That is, we get not only the ``axioms'' -\verb:le_n: and \verb:le_S:, but also the converse property, that -\verb:(le n m): if and only if this statement can be obtained as a -consequence of these defining clauses; that is, \verb:le: is the -minimal predicate verifying clauses \verb:le_n: and \verb:le_S:. This is -insured, as in the case of inductive data types, by an elimination principle, -which here amounts to an induction principle \verb:le_ind:, stating this -minimality property: -\begin{coq_example} -Check le. -Check le_ind. -\end{coq_example} - -Let us show how proofs may be conducted with this principle. -First we show that $n\le m \Rightarrow n+1\le m+1$: -\begin{coq_example} -Lemma le_n_S : forall n m : nat, le n m -> le (S n) (S m). -intros n m n_le_m. -elim n_le_m. -\end{coq_example} - -What happens here is similar to the behaviour of \verb:elim: on natural -numbers: it appeals to the relevant induction principle, here \verb:le_ind:, -which generates the two subgoals, which may then be solved easily -with the help of the defining clauses of \verb:le:. -\begin{coq_example} -apply le_n; trivial. -intros; apply le_S; trivial. -\end{coq_example} - -Now we know that it is a good idea to give the defining clauses as hints, -so that the proof may proceed with a simple combination of -\verb:induction: and \verb:auto:. \verb:Hint Constructors le: -is just an abbreviation for \verb:Hint Resolve le_n le_S:. -\begin{coq_eval} -Abort. -\end{coq_eval} -\begin{coq_example} -Hint Constructors le. -Lemma le_n_S : forall n m : nat, le n m -> le (S n) (S m). -\end{coq_example} - -We have a slight problem however. We want to say ``Do an induction on -hypothesis \verb:(le n m):'', but we have no explicit name for it. What we -do in this case is to say ``Do an induction on the first unnamed hypothesis'', -as follows. -\begin{coq_example} -induction 1; auto. -Qed. -\end{coq_example} - -Here is a more tricky problem. Assume we want to show that -$n\le 0 \Rightarrow n=0$. This reasoning ought to follow simply from the -fact that only the first defining clause of \verb:le: applies. -\begin{coq_example} -Lemma tricky : forall n:nat, le n 0 -> n = 0. -\end{coq_example} - -However, here trying something like \verb:induction 1: would lead -nowhere (try it and see what happens). -An induction on \verb:n: would not be convenient either. -What we must do here is analyse the definition of \verb"le" in order -to match hypothesis \verb:(le n O): with the defining clauses, to find -that only \verb:le_n: applies, whence the result. -This analysis may be performed by the ``inversion'' tactic -\verb:inversion_clear: as follows: -\begin{coq_example} -intros n H; inversion_clear H. -trivial. -Qed. -\end{coq_example} - -\chapter{Modules} - -\begin{coq_eval} -Reset Initial. -Set Printing Width 60. -Set Printing Compact Contexts. -\end{coq_eval} - -\section{Opening library modules} - -When you start \Coq{} without further requirements in the command line, -you get a bare system with few libraries loaded. As we saw, a standard -prelude module provides the standard logic connectives, and a few -arithmetic notions. If you want to load and open other modules from -the library, you have to use the \verb"Require" command, as we saw for -classical logic above. For instance, if you want more arithmetic -constructions, you should request: -\begin{coq_example*} -Require Import Arith. -\end{coq_example*} - -Such a command looks for a (compiled) module file \verb:Arith.vo: in -the libraries registered by \Coq. Libraries inherit the structure of -the file system of the operating system and are registered with the -command \verb:Add LoadPath:. Physical directories are mapped to -logical directories. Especially the standard library of \Coq{} is -pre-registered as a library of name \verb=Coq=. Modules have absolute -unique names denoting their place in \Coq{} libraries. An absolute -name is a sequence of single identifiers separated by dots. E.g. the -module \verb=Arith= has full name \verb=Coq.Arith.Arith= and because -it resides in eponym subdirectory \verb=Arith= of the standard -library, it can be as well required by the command - -\begin{coq_example*} -Require Import Coq.Arith.Arith. -\end{coq_example*} - -This may be useful to avoid ambiguities if somewhere, in another branch -of the libraries known by Coq, another module is also called -\verb=Arith=. Notice that by default, when a library is registered, -all its contents, and all the contents of its subdirectories recursively are -visible and accessible by a short (relative) name as \verb=Arith=. -Notice also that modules or definitions not explicitly registered in -a library are put in a default library called \verb=Top=. - -The loading of a compiled file is quick, because the corresponding -development is not type-checked again. - -\section{Creating your own modules} - -You may create your own module files, by writing {\Coq} commands in a file, -say \verb:my_module.v:. Such a module may be simply loaded in the current -context, with command \verb:Load my_module:. It may also be compiled, -in ``batch'' mode, using the UNIX command -\verb:coqc:. Compiling the module \verb:my_module.v: creates a -file \verb:my_module.vo:{} that can be reloaded with command -\verb:Require: \verb:Import: \verb:my_module:. - -If a required module depends on other modules then the latters are -automatically required beforehand. However their contents is not -automatically visible. If you want a module \verb=M= required in a -module \verb=N= to be automatically visible when \verb=N= is required, -you should use \verb:Require Export M: in your module \verb:N:. - -\section{Managing the context} - -It is often difficult to remember the names of all lemmas and -definitions available in the current context, especially if large -libraries have been loaded. A convenient \verb:Search: command -is available to lookup all known facts -concerning a given predicate. For instance, if you want to know all the -known lemmas about both the successor and the less or equal relation, just ask: -\begin{coq_eval} -Reset Initial. -Set Printing Width 60. -Set Printing Compact Contexts. -\end{coq_eval} -\begin{coq_example} -Search S le. -\end{coq_example} -Another command \verb:SearchHead: displays only lemmas where the searched -predicate appears at the head position in the conclusion. -\begin{coq_example} -SearchHead le. -\end{coq_example} - -The \verb:Search: commands also allows finding the theorems -containing a given pattern, where \verb:_: can be used in -place of an arbitrary term. As shown in this example, \Coq{} -provides usual infix notations for arithmetic operators. - -\begin{coq_example} -Search (_ + _ = _). -\end{coq_example} - -\section{Now you are on your own} - -This tutorial is necessarily incomplete. If you wish to pursue serious -proving in \Coq, you should now get your hands on \Coq's Reference Manual, -which contains a complete description of all the tactics we saw, -plus many more. -You also should look in the library of developed theories which is distributed -with \Coq, in order to acquaint yourself with various proof techniques. - - -\end{document} - diff --git a/engine/eConstr.ml b/engine/eConstr.ml index bd47a04f1..6810626ad 100644 --- a/engine/eConstr.ml +++ b/engine/eConstr.ml @@ -13,132 +13,8 @@ open Util open Names open Constr open Context -open Evd - -module API : -sig -module ESorts : -sig -type t -val make : Sorts.t -> t -val kind : Evd.evar_map -> t -> Sorts.t -val unsafe_to_sorts : t -> Sorts.t -end -module EInstance : -sig -type t -val make : Univ.Instance.t -> t -val kind : Evd.evar_map -> t -> Univ.Instance.t -val empty : t -val is_empty : t -> bool -val unsafe_to_instance : t -> Univ.Instance.t -end -type t -val kind : Evd.evar_map -> t -> (t, t, ESorts.t, EInstance.t) Constr.kind_of_term -val kind_upto : Evd.evar_map -> constr -> (constr, types, Sorts.t, Univ.Instance.t) Constr.kind_of_term -val kind_of_type : Evd.evar_map -> t -> (t, t) Term.kind_of_type -val whd_evar : Evd.evar_map -> t -> t -val of_kind : (t, t, ESorts.t, EInstance.t) Constr.kind_of_term -> t -val of_constr : Constr.t -> t -val to_constr : evar_map -> t -> Constr.t -val unsafe_to_constr : t -> Constr.t -val unsafe_eq : (t, Constr.t) eq -val of_named_decl : (Constr.t, Constr.types) Context.Named.Declaration.pt -> (t, t) Context.Named.Declaration.pt -val unsafe_to_named_decl : (t, t) Context.Named.Declaration.pt -> (Constr.t, Constr.types) Context.Named.Declaration.pt -val unsafe_to_rel_decl : (t, t) Context.Rel.Declaration.pt -> (Constr.t, Constr.types) Context.Rel.Declaration.pt -val of_rel_decl : (Constr.t, Constr.types) Context.Rel.Declaration.pt -> (t, t) Context.Rel.Declaration.pt -val to_rel_decl : Evd.evar_map -> (t, t) Context.Rel.Declaration.pt -> (Constr.t, Constr.types) Context.Rel.Declaration.pt -end = -struct - -module ESorts = -struct - type t = Sorts.t - let make s = s - let kind sigma = function - | Sorts.Type u -> Sorts.sort_of_univ (Evd.normalize_universe sigma u) - | s -> s - let unsafe_to_sorts s = s -end - -module EInstance = -struct - type t = Univ.Instance.t - let make i = i - let kind sigma i = - if Univ.Instance.is_empty i then i - else Evd.normalize_universe_instance sigma i - let empty = Univ.Instance.empty - let is_empty = Univ.Instance.is_empty - let unsafe_to_instance t = t -end -type t = Constr.t - -let safe_evar_value sigma ev = - try Some (Evd.existential_value sigma ev) - with NotInstantiatedEvar | Not_found -> None - -let rec whd_evar sigma c = - match Constr.kind c with - | Evar ev -> - begin match safe_evar_value sigma ev with - | Some c -> whd_evar sigma c - | None -> c - end - | App (f, args) when isEvar f -> - (** Enforce smart constructor invariant on applications *) - let ev = destEvar f in - begin match safe_evar_value sigma ev with - | None -> c - | Some f -> whd_evar sigma (mkApp (f, args)) - end - | Cast (c0, k, t) when isEvar c0 -> - (** Enforce smart constructor invariant on casts. *) - let ev = destEvar c0 in - begin match safe_evar_value sigma ev with - | None -> c - | Some c -> whd_evar sigma (mkCast (c, k, t)) - end - | _ -> c - -let kind sigma c = Constr.kind (whd_evar sigma c) -let kind_upto = kind -let kind_of_type sigma c = Term.kind_of_type (whd_evar sigma c) -let of_kind = Constr.of_kind -let of_constr c = c -let unsafe_to_constr c = c -let unsafe_eq = Refl - -let rec to_constr sigma c = match Constr.kind c with -| Evar ev -> - begin match safe_evar_value sigma ev with - | Some c -> to_constr sigma c - | None -> Constr.map (fun c -> to_constr sigma c) c - end -| Sort (Sorts.Type u) -> - let u' = Evd.normalize_universe sigma u in - if u' == u then c else mkSort (Sorts.sort_of_univ u') -| Const (c', u) when not (Univ.Instance.is_empty u) -> - let u' = Evd.normalize_universe_instance sigma u in - if u' == u then c else mkConstU (c', u') -| Ind (i, u) when not (Univ.Instance.is_empty u) -> - let u' = Evd.normalize_universe_instance sigma u in - if u' == u then c else mkIndU (i, u') -| Construct (co, u) when not (Univ.Instance.is_empty u) -> - let u' = Evd.normalize_universe_instance sigma u in - if u' == u then c else mkConstructU (co, u') -| _ -> Constr.map (fun c -> to_constr sigma c) c - -let of_named_decl d = d -let unsafe_to_named_decl d = d -let of_rel_decl d = d -let unsafe_to_rel_decl d = d -let to_rel_decl sigma d = Context.Rel.Declaration.map_constr (to_constr sigma) d - -end - -include API +include Evd.MiniEConstr type types = t type constr = t @@ -381,8 +257,7 @@ let decompose_prod_n_assum sigma n c = in prodec_rec Context.Rel.empty n c -let existential_type sigma (evk, args) = - of_constr (existential_type sigma (evk, Array.map unsafe_to_constr args)) +let existential_type = Evd.existential_type let map sigma f c = match kind sigma c with | (Rel _ | Meta _ | Var _ | Sort _ | Const _ | Ind _ @@ -410,7 +285,7 @@ let map sigma f c = match kind sigma c with else mkLetIn (na, b', t', k') | App (b,l) -> let b' = f b in - let l' = Array.smartmap f l in + let l' = Array.Smart.map f l in if b'==b && l'==l then c else mkApp (b', l') | Proj (p,t) -> @@ -418,23 +293,23 @@ let map sigma f c = match kind sigma c with if t' == t then c else mkProj (p, t') | Evar (e,l) -> - let l' = Array.smartmap f l in + let l' = Array.Smart.map f l in if l'==l then c else mkEvar (e, l') | Case (ci,p,b,bl) -> let b' = f b in let p' = f p in - let bl' = Array.smartmap f bl in + let bl' = Array.Smart.map f bl in if b'==b && p'==p && bl'==bl then c else mkCase (ci, p', b', bl') | Fix (ln,(lna,tl,bl)) -> - let tl' = Array.smartmap f tl in - let bl' = Array.smartmap f bl in + let tl' = Array.Smart.map f tl in + let bl' = Array.Smart.map f bl in if tl'==tl && bl'==bl then c else mkFix (ln,(lna,tl',bl')) | CoFix(ln,(lna,tl,bl)) -> - let tl' = Array.smartmap f tl in - let bl' = Array.smartmap f bl in + let tl' = Array.Smart.map f tl in + let bl' = Array.Smart.map f bl in if tl'==tl && bl'==bl then c else mkCoFix (ln,(lna,tl',bl')) @@ -464,7 +339,7 @@ let map_with_binders sigma g f l c0 = match kind sigma c0 with else mkLetIn (na, b', t', c') | App (c, al) -> let c' = f l c in - let al' = CArray.Fun1.smartmap f l al in + let al' = Array.Fun1.Smart.map f l al in if c' == c && al' == al then c0 else mkApp (c', al') | Proj (p, t) -> @@ -472,25 +347,25 @@ let map_with_binders sigma g f l c0 = match kind sigma c0 with if t' == t then c0 else mkProj (p, t') | Evar (e, al) -> - let al' = CArray.Fun1.smartmap f l al in + let al' = Array.Fun1.Smart.map f l al in if al' == al then c0 else mkEvar (e, al') | Case (ci, p, c, bl) -> let p' = f l p in let c' = f l c in - let bl' = CArray.Fun1.smartmap f l bl in + let bl' = Array.Fun1.Smart.map f l bl in if p' == p && c' == c && bl' == bl then c0 else mkCase (ci, p', c', bl') | Fix (ln, (lna, tl, bl)) -> - let tl' = CArray.Fun1.smartmap f l tl in + let tl' = Array.Fun1.Smart.map f l tl in let l' = iterate g (Array.length tl) l in - let bl' = CArray.Fun1.smartmap f l' bl in + let bl' = Array.Fun1.Smart.map f l' bl in if tl' == tl && bl' == bl then c0 else mkFix (ln,(lna,tl',bl')) | CoFix(ln,(lna,tl,bl)) -> - let tl' = CArray.Fun1.smartmap f l tl in + let tl' = Array.Fun1.Smart.map f l tl in let l' = iterate g (Array.length tl) l in - let bl' = CArray.Fun1.smartmap f l' bl in + let bl' = Array.Fun1.Smart.map f l' bl in mkCoFix (ln,(lna,tl',bl')) let iter sigma f c = match kind sigma c with @@ -516,9 +391,9 @@ let iter_with_full_binders sigma g f n c = | Prod (na,t,c) -> f n t; f (g (LocalAssum (na, t)) n) c | Lambda (na,t,c) -> f n t; f (g (LocalAssum (na, t)) n) c | LetIn (na,b,t,c) -> f n b; f n t; f (g (LocalDef (na, b, t)) n) c - | App (c,l) -> f n c; CArray.Fun1.iter f n l - | Evar (_,l) -> CArray.Fun1.iter f n l - | Case (_,p,c,bl) -> f n p; f n c; CArray.Fun1.iter f n bl + | App (c,l) -> f n c; Array.Fun1.iter f n l + | Evar (_,l) -> Array.Fun1.iter f n l + | Case (_,p,c,bl) -> f n p; f n c; Array.Fun1.iter f n bl | Proj (p,c) -> f n c | Fix (_,(lna,tl,bl)) -> Array.iter (f n) tl; @@ -571,28 +446,28 @@ let compare_constr sigma cmp c1 c2 = compare_gen kind (fun _ _ -> Univ.Instance.equal) Sorts.equal cmp 0 (unsafe_to_constr c1) (unsafe_to_constr c2) let compare_cumulative_instances cv_pb nargs_ok variances u u' cstrs = - let open Universes in + let open UnivProblem in if not nargs_ok then enforce_eq_instances_univs false u u' cstrs else CArray.fold_left3 (fun cstrs v u u' -> let open Univ.Variance in match v with - | Irrelevant -> Constraints.add (UWeak (u,u')) cstrs + | Irrelevant -> Set.add (UWeak (u,u')) cstrs | Covariant -> let u = Univ.Universe.make u in let u' = Univ.Universe.make u' in (match cv_pb with - | Reduction.CONV -> Constraints.add (UEq (u,u')) cstrs - | Reduction.CUMUL -> Constraints.add (ULe (u,u')) cstrs) + | Reduction.CONV -> Set.add (UEq (u,u')) cstrs + | Reduction.CUMUL -> Set.add (ULe (u,u')) cstrs) | Invariant -> let u = Univ.Universe.make u in let u' = Univ.Universe.make u' in - Constraints.add (UEq (u,u')) cstrs) + Set.add (UEq (u,u')) cstrs) cstrs variances (Univ.Instance.to_array u) (Univ.Instance.to_array u') let cmp_inductives cv_pb (mind,ind as spec) nargs u1 u2 cstrs = - let open Universes in + let open UnivProblem in match mind.Declarations.mind_universes with | Declarations.Monomorphic_ind _ -> assert (Univ.Instance.length u1 = 0 && Univ.Instance.length u2 = 0); @@ -605,7 +480,7 @@ let cmp_inductives cv_pb (mind,ind as spec) nargs u1 u2 cstrs = compare_cumulative_instances cv_pb (Int.equal num_param_arity nargs) variances u1 u2 cstrs let cmp_constructors (mind, ind, cns as spec) nargs u1 u2 cstrs = - let open Universes in + let open UnivProblem in match mind.Declarations.mind_universes with | Declarations.Monomorphic_ind _ -> cstrs @@ -616,7 +491,7 @@ let cmp_constructors (mind, ind, cns as spec) nargs u1 u2 cstrs = if not (Int.equal num_cnstr_args nargs) then enforce_eq_instances_univs false u1 u2 cstrs else - Array.fold_left2 (fun cstrs u1 u2 -> Universes.(Constraints.add (UWeak (u1,u2)) cstrs)) + Array.fold_left2 (fun cstrs u1 u2 -> UnivProblem.(Set.add (UWeak (u1,u2)) cstrs)) cstrs (Univ.Instance.to_array u1) (Univ.Instance.to_array u2) let eq_universes env sigma cstrs cv_pb ref nargs l l' = @@ -624,7 +499,8 @@ let eq_universes env sigma cstrs cv_pb ref nargs l l' = else let l = Evd.normalize_universe_instance sigma l and l' = Evd.normalize_universe_instance sigma l' in - let open Universes in + let open GlobRef in + let open UnivProblem in match ref with | VarRef _ -> assert false (* variables don't have instances *) | ConstRef _ -> @@ -639,11 +515,11 @@ let eq_universes env sigma cstrs cv_pb ref nargs l l' = true let test_constr_universes env sigma leq m n = - let open Universes in + let open UnivProblem in let kind c = kind_upto sigma c in - if m == n then Some Constraints.empty + if m == n then Some Set.empty else - let cstrs = ref Constraints.empty in + let cstrs = ref Set.empty in let cv_pb = if leq then Reduction.CUMUL else Reduction.CONV in let eq_universes ref nargs l l' = eq_universes env sigma cstrs Reduction.CONV ref nargs l l' and leq_universes ref nargs l l' = eq_universes env sigma cstrs cv_pb ref nargs l l' in @@ -651,7 +527,7 @@ let test_constr_universes env sigma leq m n = let s1 = ESorts.kind sigma (ESorts.make s1) in let s2 = ESorts.kind sigma (ESorts.make s2) in if Sorts.equal s1 s2 then true - else (cstrs := Constraints.add + else (cstrs := Set.add (UEq (Sorts.univ_of_sort s1,Sorts.univ_of_sort s2)) !cstrs; true) in @@ -660,7 +536,7 @@ let test_constr_universes env sigma leq m n = let s2 = ESorts.kind sigma (ESorts.make s2) in if Sorts.equal s1 s2 then true else - (cstrs := Constraints.add + (cstrs := Set.add (ULe (Sorts.univ_of_sort s1,Sorts.univ_of_sort s2)) !cstrs; true) in @@ -698,15 +574,15 @@ let compare_head_gen_proj env sigma equ eqs eqc' nargs m n = | _ -> Constr.compare_head_gen_with kind kind equ eqs eqc' nargs m n let eq_constr_universes_proj env sigma m n = - let open Universes in - if m == n then Some Constraints.empty + let open UnivProblem in + if m == n then Some Set.empty else - let cstrs = ref Constraints.empty in + let cstrs = ref Set.empty in let eq_universes ref l l' = eq_universes env sigma cstrs Reduction.CONV ref l l' in let eq_sorts s1 s2 = if Sorts.equal s1 s2 then true else - (cstrs := Constraints.add + (cstrs := Set.add (UEq (Sorts.univ_of_sort s1, Sorts.univ_of_sort s2)) !cstrs; true) in @@ -743,7 +619,7 @@ let universes_of_constr env sigma c = LSet.fold LSet.add (Universe.levels u) s | Evar (k, args) -> let concl = Evd.evar_concl (Evd.find sigma k) in - fold sigma aux (aux s (of_constr concl)) c + fold sigma aux (aux s concl) c | _ -> fold sigma aux s c in aux LSet.empty c @@ -901,9 +777,13 @@ let named_context e = cast_named_context (sym unsafe_eq) (named_context e) let val_of_named_context e = val_of_named_context (cast_named_context unsafe_eq e) let named_context_of_val e = cast_named_context (sym unsafe_eq) (named_context_of_val e) +let of_existential : Constr.existential -> existential = + let gen : type a b. (a,b) eq -> 'c * b array -> 'c * a array = fun Refl x -> x in + gen unsafe_eq + let lookup_rel i e = cast_rel_decl (sym unsafe_eq) (lookup_rel i e) let lookup_named n e = cast_named_decl (sym unsafe_eq) (lookup_named n e) -let lookup_named_val n e = cast_named_decl (sym unsafe_eq) (lookup_named_val n e) +let lookup_named_val n e = cast_named_decl (sym unsafe_eq) (lookup_named_ctxt n e) let map_rel_context_in_env f env sign = let rec aux env acc = function @@ -916,7 +796,7 @@ let map_rel_context_in_env f env sign = let fresh_global ?loc ?rigid ?names env sigma reference = let (evd,t) = Evd.fresh_global ?loc ?rigid ?names env sigma reference in - evd, of_constr t + evd, t let is_global sigma gr c = Globnames.is_global gr (to_constr sigma c) @@ -928,5 +808,10 @@ let to_instance = EInstance.unsafe_to_instance let to_constr = unsafe_to_constr let to_rel_decl = unsafe_to_rel_decl let to_named_decl = unsafe_to_named_decl +let to_named_context = + let gen : type a b. (a, b) eq -> (a,a) Context.Named.pt -> (b,b) Context.Named.pt + = fun Refl x -> x + in + gen unsafe_eq let eq = unsafe_eq end diff --git a/engine/eConstr.mli b/engine/eConstr.mli index 28c9dd3c2..e9d3e782b 100644 --- a/engine/eConstr.mli +++ b/engine/eConstr.mli @@ -13,7 +13,7 @@ open Names open Constr open Environ -type t +type t = Evd.econstr (** Type of incomplete terms. Essentially a wrapper around {!Constr.t} ensuring that {!Constr.kind} does not observe defined evars. *) @@ -68,11 +68,14 @@ val kind : Evd.evar_map -> t -> (t, t, ESorts.t, EInstance.t) Constr.kind_of_ter val kind_upto : Evd.evar_map -> Constr.t -> (Constr.t, Constr.t, Sorts.t, Univ.Instance.t) Constr.kind_of_term -val to_constr : Evd.evar_map -> t -> Constr.t -(** Returns the evar-normal form of the argument, and cast it as a theoretically - evar-free term. In practice this function does not check that the result - is actually evar-free, it is currently the duty of the caller to do so. - This might change in the future. *) +val to_constr : ?abort_on_undefined_evars:bool -> Evd.evar_map -> t -> Constr.t +(** Returns the evar-normal form of the argument. Note that this + function is supposed to be called when the original term has not + more free-evars anymore. If you need compatibility with the old + semantics, set [abort_on_undefined_evars] to [false]. + + For getting the evar-normal form of a term with evars see + {!Evarutil.nf_evar}. *) val kind_of_type : Evd.evar_map -> t -> (t, t) Term.kind_of_type @@ -108,7 +111,7 @@ val mkLetIn : Name.t * t * t * t -> t val mkApp : t * t array -> t val mkConst : Constant.t -> t val mkConstU : Constant.t * EInstance.t -> t -val mkProj : (projection * t) -> t +val mkProj : (Projection.t * t) -> t val mkInd : inductive -> t val mkIndU : inductive * EInstance.t -> t val mkConstruct : constructor -> t @@ -173,15 +176,27 @@ val destEvar : Evd.evar_map -> t -> t pexistential val destInd : Evd.evar_map -> t -> inductive * EInstance.t val destConstruct : Evd.evar_map -> t -> constructor * EInstance.t val destCase : Evd.evar_map -> t -> case_info * t * t * t array -val destProj : Evd.evar_map -> t -> projection * t +val destProj : Evd.evar_map -> t -> Projection.t * t val destFix : Evd.evar_map -> t -> (t, t) pfixpoint val destCoFix : Evd.evar_map -> t -> (t, t) pcofixpoint 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 + +(** Pops lambda abstractions and letins until there are no more, skipping casts. *) val decompose_lam_assum : Evd.evar_map -> t -> rel_context * t + +(** Pops [n] lambda abstractions, and pop letins only if needed to + expose enough lambdas, skipping casts. + + @raise UserError if the term doesn't have enough lambdas. *) val decompose_lam_n_assum : Evd.evar_map -> int -> t -> rel_context * t + +(** Pops [n] lambda abstractions and letins, skipping casts. + + @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 @@ -198,11 +213,11 @@ val whd_evar : Evd.evar_map -> constr -> constr val eq_constr : Evd.evar_map -> t -> t -> bool val eq_constr_nounivs : Evd.evar_map -> t -> t -> bool -val eq_constr_universes : Environ.env -> Evd.evar_map -> t -> t -> Universes.Constraints.t option -val leq_constr_universes : Environ.env -> Evd.evar_map -> t -> t -> Universes.Constraints.t option +val eq_constr_universes : Environ.env -> Evd.evar_map -> t -> t -> UnivProblem.Set.t option +val leq_constr_universes : Environ.env -> Evd.evar_map -> t -> t -> UnivProblem.Set.t option (** [eq_constr_universes_proj] can equate projections and their eta-expanded constant form. *) -val eq_constr_universes_proj : Environ.env -> Evd.evar_map -> t -> t -> Universes.Constraints.t option +val eq_constr_universes_proj : Environ.env -> Evd.evar_map -> t -> t -> UnivProblem.Set.t option val compare_constr : Evd.evar_map -> (t -> t -> bool) -> t -> t -> bool @@ -281,12 +296,13 @@ val map_rel_context_in_env : (* XXX Missing Sigma proxy *) val fresh_global : ?loc:Loc.t -> ?rigid:Evd.rigid -> ?names:Univ.Instance.t -> Environ.env -> - Evd.evar_map -> Globnames.global_reference -> Evd.evar_map * t + Evd.evar_map -> GlobRef.t -> Evd.evar_map * t -val is_global : Evd.evar_map -> Globnames.global_reference -> t -> bool +val is_global : Evd.evar_map -> GlobRef.t -> t -> bool (** {5 Extra} *) +val of_existential : Constr.existential -> existential val of_named_decl : (Constr.t, Constr.types) Context.Named.Declaration.pt -> (t, types) Context.Named.Declaration.pt val of_rel_decl : (Constr.t, Constr.types) Context.Rel.Declaration.pt -> (t, types) Context.Rel.Declaration.pt @@ -305,6 +321,8 @@ sig val to_named_decl : (t, types) Context.Named.Declaration.pt -> (Constr.t, Constr.types) Context.Named.Declaration.pt (** Physical identity. Does not care for defined evars. *) + val to_named_context : (t, types) Context.Named.pt -> Context.Named.t + val to_sorts : ESorts.t -> Sorts.t (** Physical identity. Does not care for normalization. *) diff --git a/engine/engine.mllib b/engine/engine.mllib index a3614f6c4..37e83b623 100644 --- a/engine/engine.mllib +++ b/engine/engine.mllib @@ -1,7 +1,13 @@ +UnivNames +UnivGen +UnivSubst +UnivProblem +UnivMinim Universes Univops UState Nameops +Evar_kinds Evd EConstr Namegen diff --git a/intf/evar_kinds.ml b/engine/evar_kinds.ml index c964ecf1f..12e2fda8e 100644 --- a/intf/evar_kinds.ml +++ b/engine/evar_kinds.ml @@ -9,8 +9,6 @@ (************************************************************************) open Names -open Globnames -open Misctypes (** The kinds of existential variable *) @@ -19,12 +17,12 @@ open Misctypes type obligation_definition_status = Define of bool | Expand -type matching_var_kind = FirstOrderPatVar of patvar | SecondOrderPatVar of patvar +type matching_var_kind = FirstOrderPatVar of Id.t | SecondOrderPatVar of Id.t type subevar_kind = Domain | Codomain | Body type t = - | ImplicitArg of global_reference * (int * Id.t option) + | ImplicitArg of GlobRef.t * (int * Id.t option) * bool (** Force inference *) | BinderType of Name.t | NamedHole of Id.t (* coming from some ?[id] syntax *) diff --git a/engine/evarutil.ml b/engine/evarutil.ml index 45760c6b4..82be4791f 100644 --- a/engine/evarutil.ml +++ b/engine/evarutil.ml @@ -13,7 +13,6 @@ open Util open Names open Term open Constr -open Pre_env open Environ open Evd open Termops @@ -23,7 +22,8 @@ module RelDecl = Context.Rel.Declaration module NamedDecl = Context.Named.Declaration let safe_evar_value sigma ev = - try Some (Evd.existential_value sigma ev) + let ev = EConstr.of_existential ev in + try Some (EConstr.Unsafe.to_constr @@ Evd.existential_value sigma ev) with NotInstantiatedEvar | Not_found -> None (** Combinators *) @@ -44,11 +44,11 @@ let evd_comb2 f evdref x y = z let e_new_global evdref x = - EConstr.of_constr (evd_comb1 (Evd.fresh_global (Global.env())) evdref x) + evd_comb1 (Evd.fresh_global (Global.env())) evdref x let new_global evd x = let (evd, c) = Evd.fresh_global (Global.env()) evd x in - (evd, EConstr.of_constr c) + (evd, c) (****************************************************) (* Expanding/testing/exposing existential variables *) @@ -61,7 +61,7 @@ exception Uninstantiated_evar of Evar.t let rec flush_and_check_evars sigma c = match kind c with | Evar (evk,_ as ev) -> - (match existential_opt_value sigma ev with + (match existential_opt_value0 sigma ev with | None -> raise (Uninstantiated_evar evk) | Some c -> flush_and_check_evars sigma c) | _ -> Constr.map (flush_and_check_evars sigma) c @@ -72,9 +72,9 @@ let flush_and_check_evars sigma c = (** Term exploration up to instantiation. *) let kind_of_term_upto = EConstr.kind_upto -let nf_evar0 sigma t = EConstr.to_constr sigma (EConstr.of_constr t) +let nf_evar0 sigma t = EConstr.to_constr ~abort_on_undefined_evars:false sigma (EConstr.of_constr t) let whd_evar = EConstr.whd_evar -let nf_evar sigma c = EConstr.of_constr (EConstr.to_constr sigma c) +let nf_evar sigma c = EConstr.of_constr (EConstr.to_constr ~abort_on_undefined_evars:false sigma c) let j_nf_evar sigma j = { uj_val = nf_evar sigma j.uj_val; @@ -85,7 +85,7 @@ let tj_nf_evar sigma {utj_val=v;utj_type=t} = {utj_val=nf_evar sigma v;utj_type=t} let nf_evars_universes evm = - Universes.nf_evars_and_universes_opt_subst (safe_evar_value evm) + UnivSubst.nf_evars_and_universes_opt_subst (safe_evar_value evm) (Evd.universe_subst evm) let nf_evars_and_universes evm = @@ -102,7 +102,8 @@ let nf_evar_map_universes evm = if Univ.LMap.is_empty subst then evm, nf_evar0 evm else let f = nf_evars_universes evm in - Evd.raw_map (fun _ -> map_evar_info f) evm, f + let f' c = EConstr.of_constr (f (EConstr.Unsafe.to_constr c)) in + Evd.raw_map (fun _ -> map_evar_info f') evm, f let nf_named_context_evar sigma ctx = Context.Named.map (nf_evar0 sigma) ctx @@ -115,7 +116,7 @@ let nf_env_evar sigma env = let rel' = nf_rel_context_evar sigma (EConstr.rel_context env) in EConstr.push_rel_context rel' (reset_with_named_context (val_of_named_context nc') env) -let nf_evar_info evc info = map_evar_info (nf_evar0 evc) info +let nf_evar_info evc info = map_evar_info (nf_evar evc) info let nf_evar_map evm = Evd.raw_map (fun _ evi -> nf_evar_info evm evi) evm @@ -212,7 +213,7 @@ let mk_new_meta () = EConstr.mkMeta(new_meta()) let non_instantiated sigma = let listev = Evd.undefined_map sigma in - Evar.Map.smartmap (fun evi -> nf_evar_info sigma evi) listev + Evar.Map.Smart.map (fun evi -> nf_evar_info sigma evi) listev (************************) (* Manipulating filters *) @@ -340,7 +341,15 @@ let update_var src tgt subst = let csubst_var = Id.Map.add id (Constr.mkVar tgt) subst.csubst_var in { subst with csubst_var; csubst_rev } -let push_rel_decl_to_named_context sigma decl (subst, avoid, nc) = +type naming_mode = + | KeepUserNameAndRenameExistingButSectionNames + | KeepUserNameAndRenameExistingEvenSectionNames + | KeepExistingNames + | FailIfConflict + +let push_rel_decl_to_named_context + ?(hypnaming=KeepUserNameAndRenameExistingButSectionNames) + sigma decl (subst, avoid, nc) = let open EConstr in let open Vars in let map_decl f d = @@ -371,7 +380,9 @@ let push_rel_decl_to_named_context sigma decl (subst, avoid, nc) = next_ident_away (id_of_name_using_hdchar empty_env sigma (RelDecl.get_type decl) na) avoid in match extract_if_neq id na with - | Some id0 when not (is_section_variable id0) -> + | Some id0 when hypnaming = KeepUserNameAndRenameExistingEvenSectionNames || + hypnaming = KeepUserNameAndRenameExistingButSectionNames && + not (is_section_variable id0) -> (* spiwack: if [id<>id0], rather than introducing a new binding named [id], we will keep [id0] (the name given by the user) and rename [id0] into [id] in the named @@ -380,6 +391,8 @@ let push_rel_decl_to_named_context sigma decl (subst, avoid, nc) = let d = decl |> NamedDecl.of_rel_decl (fun _ -> id0) |> map_decl (csubst_subst subst) in let nc = List.map (replace_var_named_declaration id0 id) nc in (push_var id0 subst, Id.Set.add id avoid, d :: nc) + | Some id0 when hypnaming = FailIfConflict -> + user_err Pp.(Id.print id0 ++ str " is already used.") | _ -> (* spiwack: if [id0] is a section variable renaming it is incorrect. We revert to a less robust behaviour where @@ -388,7 +401,7 @@ let push_rel_decl_to_named_context sigma decl (subst, avoid, nc) = let d = decl |> NamedDecl.of_rel_decl (fun _ -> id) |> map_decl (csubst_subst subst) in (push_var id subst, Id.Set.add id avoid, d :: nc) -let push_rel_context_to_named_context env sigma typ = +let push_rel_context_to_named_context ?hypnaming env sigma typ = (* compute the instances relative to the named context and rel_context *) let open Context.Named.Declaration in let open EConstr in @@ -403,7 +416,7 @@ let push_rel_context_to_named_context env sigma typ = (* with vars of the rel context *) (* We do keep the instances corresponding to local definition (see above) *) let (subst, _, env) = - Context.Rel.fold_outside (fun d acc -> push_rel_decl_to_named_context sigma d acc) + Context.Rel.fold_outside (fun d acc -> push_rel_decl_to_named_context ?hypnaming sigma d acc) (rel_context env) ~init:(empty_csubst, avoid, named_context env) in (val_of_named_context env, csubst_subst subst typ, inst_rels@inst_vars, subst) @@ -414,7 +427,6 @@ let push_rel_context_to_named_context env sigma typ = let default_source = Loc.tag @@ Evar_kinds.InternalHole let restrict_evar evd evk filter ?src candidates = - let candidates = Option.map (fun l -> List.map EConstr.Unsafe.to_constr l) candidates in let evd, evk' = Evd.restrict evk filter ?candidates ?src evd in Evd.declare_future_goal evk' evd, evk' @@ -423,15 +435,13 @@ let new_pure_evar_full evd evi = let evd = Evd.declare_future_goal evk evd in (evd, evk) -let new_pure_evar sign evd ?(src=default_source) ?(filter = Filter.identity) ?candidates ?(store = Store.empty) ?naming ?(principal=false) typ = - let typ = EConstr.Unsafe.to_constr typ in - let candidates = Option.map (fun l -> List.map EConstr.Unsafe.to_constr l) candidates in - let default_naming = Misctypes.IntroAnonymous in +let new_pure_evar?(src=default_source) ?(filter = Filter.identity) ?candidates ?(store = Store.empty) ?naming ?(principal=false) sign evd typ = + let default_naming = IntroAnonymous in let naming = Option.default default_naming naming in let name = match naming with - | Misctypes.IntroAnonymous -> None - | Misctypes.IntroIdentifier id -> Some id - | Misctypes.IntroFresh id -> + | IntroAnonymous -> None + | IntroIdentifier id -> Some id + | IntroFresh id -> let has_name id = try let _ = Evd.evar_key id evd in true with Not_found -> false in let id = Namegen.next_ident_away_from id has_name in Some id @@ -452,14 +462,14 @@ let new_pure_evar sign evd ?(src=default_source) ?(filter = Filter.identity) ?ca in (evd, newevk) -let new_evar_instance sign evd typ ?src ?filter ?candidates ?store ?naming ?principal instance = +let new_evar_instance ?src ?filter ?candidates ?store ?naming ?principal sign evd typ instance = let open EConstr in assert (not !Flags.debug || List.distinct (ids_of_named_context (named_context_of_val sign))); let (evd, newevk) = new_pure_evar sign evd ?src ?filter ?candidates ?store ?naming ?principal typ in evd, mkEvar (newevk,Array.of_list instance) -let new_evar_from_context sign evd ?src ?filter ?candidates ?store ?naming ?principal typ = +let new_evar_from_context ?src ?filter ?candidates ?store ?naming ?principal sign evd typ = let instance = List.map (NamedDecl.get_id %> EConstr.mkVar) (named_context_of_val sign) in let instance = match filter with @@ -469,8 +479,8 @@ let new_evar_from_context sign evd ?src ?filter ?candidates ?store ?naming ?prin (* [new_evar] declares a new existential in an env env with type typ *) (* Converting the env into the sign of the evar to define *) -let new_evar env evd ?src ?filter ?candidates ?store ?naming ?principal typ = - let sign,typ',instance,subst = push_rel_context_to_named_context env evd typ in +let new_evar ?src ?filter ?candidates ?store ?naming ?principal ?hypnaming env evd typ = + let sign,typ',instance,subst = push_rel_context_to_named_context ?hypnaming env evd typ in let map c = csubst_subst subst c in let candidates = Option.map (fun l -> List.map map l) candidates in let instance = @@ -479,13 +489,13 @@ let new_evar env evd ?src ?filter ?candidates ?store ?naming ?principal typ = | Some filter -> Filter.filter_list filter instance in new_evar_instance sign evd typ' ?src ?filter ?candidates ?store ?naming ?principal instance -let new_type_evar env evd ?src ?filter ?naming ?principal rigid = +let new_type_evar ?src ?filter ?naming ?principal ?hypnaming env evd rigid = let (evd', s) = new_sort_variable rigid evd in - let (evd', e) = new_evar env evd' ?src ?filter ?naming ?principal (EConstr.mkSort s) in + let (evd', e) = new_evar env evd' ?src ?filter ?naming ?principal ?hypnaming (EConstr.mkSort s) in evd', (e, s) -let e_new_type_evar env evdref ?src ?filter ?naming ?principal rigid = - let (evd, c) = new_type_evar env !evdref ?src ?filter ?naming ?principal rigid in +let e_new_type_evar env evdref ?src ?filter ?naming ?principal ?hypnaming rigid = + let (evd, c) = new_type_evar env !evdref ?src ?filter ?naming ?principal ?hypnaming rigid in evdref := evd; c @@ -499,8 +509,8 @@ let e_new_Type ?(rigid=Evd.univ_flexible) env evdref = evdref := evd'; EConstr.mkSort s (* The same using side-effect *) -let e_new_evar env evdref ?(src=default_source) ?filter ?candidates ?store ?naming ?principal ty = - let (evd',ev) = new_evar env !evdref ~src:src ?filter ?candidates ?store ?naming ?principal ty in +let e_new_evar env evdref ?(src=default_source) ?filter ?candidates ?store ?naming ?principal ?hypnaming ty = + let (evd',ev) = new_evar env !evdref ~src:src ?filter ?candidates ?store ?naming ?principal ?hypnaming ty in evdref := evd'; ev @@ -513,7 +523,7 @@ let generalize_evar_over_rels sigma (ev,args) = List.fold_left2 (fun (c,inst as x) a d -> if isRel sigma a then (mkNamedProd_or_LetIn d c,a::inst) else x) - (EConstr.of_constr evi.evar_concl,[]) (Array.to_list args) sign + (evi.evar_concl,[]) (Array.to_list args) sign (************************************) (* Removing a dependency in an evar *) @@ -523,7 +533,7 @@ type clear_dependency_error = | OccurHypInSimpleClause of Id.t option | EvarTypingBreak of existential -exception ClearDependencyError of Id.t * clear_dependency_error +exception ClearDependencyError of Id.t * clear_dependency_error * GlobRef.t option exception Depends of Id.t @@ -534,13 +544,13 @@ let rec check_and_clear_in_constr env evdref err ids global c = is a section variable *) match kind c with | Var id' -> - if Id.Set.mem id' ids then raise (ClearDependencyError (id', err)) else c + if Id.Set.mem id' ids then raise (ClearDependencyError (id', err, None)) else c | ( Const _ | Ind _ | Construct _ ) -> let () = if global then let check id' = if Id.Set.mem id' ids then - raise (ClearDependencyError (id',err)) + raise (ClearDependencyError (id',err,Some (Globnames.global_of_constr c))) in Id.Set.iter check (Environ.vars_of_global env c) in @@ -549,7 +559,8 @@ let rec check_and_clear_in_constr env evdref err ids global c = | Evar (evk,l as ev) -> if Evd.is_defined !evdref evk then (* If evk is already defined we replace it by its definition *) - let nc = Evd.existential_value !evdref ev in + let nc = Evd.existential_value !evdref (EConstr.of_existential ev) in + let nc = EConstr.Unsafe.to_constr nc in (check_and_clear_in_constr env evdref err ids global nc) else (* We check for dependencies to elements of ids in the @@ -559,8 +570,7 @@ let rec check_and_clear_in_constr env evdref err ids global c = removed *) let evi = Evd.find_undefined !evdref evk in let ctxt = Evd.evar_filtered_context evi in - let ctxt = List.map (fun d -> map_named_decl EConstr.of_constr d) ctxt in - let (rids,filter) = + let (rids,filter) = List.fold_right2 (fun h a (ri,filter) -> try @@ -586,9 +596,10 @@ let rec check_and_clear_in_constr env evdref err ids global c = try let nids = Id.Map.domain rids in let global = Id.Set.exists is_section_variable nids in - check_and_clear_in_constr env evdref (EvarTypingBreak ev) nids global (evar_concl evi) - with ClearDependencyError (rid,err) -> - raise (ClearDependencyError (Id.Map.find rid rids,err)) in + let concl = EConstr.Unsafe.to_constr (evar_concl evi) in + check_and_clear_in_constr env evdref (EvarTypingBreak ev) nids global concl + with ClearDependencyError (rid,err,where) -> + raise (ClearDependencyError (Id.Map.find rid rids,err,where)) in if Id.Map.is_empty rids then c else @@ -597,14 +608,15 @@ let rec check_and_clear_in_constr env evdref err ids global c = let evd = !evdref in let (evd,_) = restrict_evar evd evk filter None in evdref := evd; - Evd.existential_value !evdref ev + Evd.existential_value0 !evdref ev | _ -> Constr.map (check_and_clear_in_constr env evdref err ids global) c -let clear_hyps_in_evi_main env evdref hyps terms ids = +let clear_hyps_in_evi_main env sigma hyps terms ids = (* clear_hyps_in_evi erases hypotheses ids in hyps, checking if some hypothesis does not depend on a element of ids, and erases ids in the contexts of the evars occurring in evi *) + let evdref = ref sigma in let terms = List.map EConstr.Unsafe.to_constr terms in let global = Id.Set.exists is_section_variable ids in let terms = @@ -627,23 +639,23 @@ let clear_hyps_in_evi_main env evdref hyps terms ids = in remove_hyps ids check_context check_value hyps in - (nhyps,List.map EConstr.of_constr terms) + (!evdref, nhyps,List.map EConstr.of_constr terms) -let clear_hyps_in_evi env evdref hyps concl ids = - match clear_hyps_in_evi_main env evdref hyps [concl] ids with - | (nhyps,[nconcl]) -> (nhyps,nconcl) +let clear_hyps_in_evi env sigma hyps concl ids = + match clear_hyps_in_evi_main env sigma hyps [concl] ids with + | (sigma,nhyps,[nconcl]) -> (sigma,nhyps,nconcl) | _ -> assert false -let clear_hyps2_in_evi env evdref hyps t concl ids = - match clear_hyps_in_evi_main env evdref hyps [t;concl] ids with - | (nhyps,[t;nconcl]) -> (nhyps,t,nconcl) +let clear_hyps2_in_evi env sigma hyps t concl ids = + match clear_hyps_in_evi_main env sigma hyps [t;concl] ids with + | (sigma,nhyps,[t;nconcl]) -> (sigma,nhyps,t,nconcl) | _ -> assert false (* spiwack: a few functions to gather evars on which goals depend. *) let queue_set q is_dependent set = Evar.Set.iter (fun a -> Queue.push (is_dependent,a) q) set let queue_term q is_dependent c = - queue_set q is_dependent (evars_of_term c) + queue_set q is_dependent (evars_of_term (EConstr.Unsafe.to_constr c)) let process_dependent_evar q acc evm is_dependent e = let evi = Evd.find evm e in @@ -656,12 +668,12 @@ let process_dependent_evar q acc evm is_dependent e = match decl with | LocalAssum _ -> () | LocalDef (_,b,_) -> queue_term q true b - end (Environ.named_context_of_val evi.evar_hyps); + end (EConstr.named_context_of_val evi.evar_hyps); match evi.evar_body with | Evar_empty -> if is_dependent then Evar.Map.add e None acc else acc | Evar_defined b -> - let subevars = evars_of_term b in + let subevars = evars_of_term (EConstr.Unsafe.to_constr b) in (* evars appearing in the definition of an evar [e] are marked as dependent when [e] is dependent itself: if [e] is a non-dependent goal, then, unless they are reach from another @@ -729,11 +741,11 @@ let undefined_evars_of_named_context evd nc = ~init:Evar.Set.empty let undefined_evars_of_evar_info evd evi = - Evar.Set.union (undefined_evars_of_term evd (EConstr.of_constr evi.evar_concl)) + Evar.Set.union (undefined_evars_of_term evd evi.evar_concl) (Evar.Set.union (match evi.evar_body with | Evar_empty -> Evar.Set.empty - | Evar_defined b -> undefined_evars_of_term evd (EConstr.of_constr b)) + | Evar_defined b -> undefined_evars_of_term evd b) (undefined_evars_of_named_context evd (named_context_of_val evi.evar_hyps))) @@ -781,10 +793,11 @@ let filtered_undefined_evars_of_evar_info ?cache sigma evi = in let accu = match evi.evar_body with | Evar_empty -> Evar.Set.empty - | Evar_defined b -> evars_of_term b + | Evar_defined b -> evars_of_term (EConstr.Unsafe.to_constr b) in - let accu = Evar.Set.union (undefined_evars_of_term sigma (EConstr.of_constr evi.evar_concl)) accu in - evars_of_named_context cache accu (evar_filtered_context evi) + let accu = Evar.Set.union (undefined_evars_of_term sigma evi.evar_concl) accu in + let ctxt = EConstr.Unsafe.to_named_context (evar_filtered_context evi) in + evars_of_named_context cache accu ctxt (* spiwack: this is a more complete version of {!Termops.occur_evar}. The latter does not look recursively into an @@ -794,7 +807,7 @@ let occur_evar_upto sigma n c = let c = EConstr.Unsafe.to_constr c in let rec occur_rec c = match kind c with | Evar (sp,_) when Evar.equal sp n -> raise Occur - | Evar e -> Option.iter occur_rec (existential_opt_value sigma e) + | Evar e -> Option.iter occur_rec (existential_opt_value0 sigma e) | _ -> Constr.iter occur_rec c in try occur_rec c; false with Occur -> true @@ -816,13 +829,13 @@ let subterm_source evk ?where (loc,k) = (* Add equality constraints for covariant/invariant positions. For irrelevant positions, unify universes when flexible. *) let compare_cumulative_instances cv_pb variances u u' sigma = - let open Universes in + let open UnivProblem in let cstrs = Univ.Constraint.empty in - let soft = Constraints.empty in + let soft = Set.empty in let cstrs, soft = Array.fold_left3 (fun (cstrs, soft) v u u' -> let open Univ.Variance in match v with - | Irrelevant -> cstrs, Constraints.add (UWeak (u,u')) soft + | Irrelevant -> cstrs, Set.add (UWeak (u,u')) soft | Covariant when cv_pb == Reduction.CUMUL -> Univ.Constraint.add (u,Univ.Le,u') cstrs, soft | Covariant | Invariant -> Univ.Constraint.add (u,Univ.Eq,u') cstrs, soft) @@ -834,10 +847,10 @@ let compare_cumulative_instances cv_pb variances u u' sigma = | exception Univ.UniverseInconsistency p -> Inr p let compare_constructor_instances evd u u' = - let open Universes in + let open UnivProblem in let soft = - Array.fold_left2 (fun cs u u' -> Constraints.add (UWeak (u,u')) cs) - Constraints.empty (Univ.Instance.to_array u) (Univ.Instance.to_array u') + Array.fold_left2 (fun cs u u' -> Set.add (UWeak (u,u')) cs) + Set.empty (Univ.Instance.to_array u) (Univ.Instance.to_array u') in Evd.add_universe_constraints evd soft @@ -849,17 +862,16 @@ let compare_constructor_instances evd u u' = let eq_constr_univs_test sigma1 sigma2 t u = (* spiwack: mild code duplication with {!Evd.eq_constr_univs}. *) let open Evd in + let t = EConstr.Unsafe.to_constr t + and u = EConstr.Unsafe.to_constr u in let fold cstr sigma = try Some (add_universe_constraints sigma cstr) with Univ.UniverseInconsistency _ | UniversesDiffer -> None in let ans = - Universes.eq_constr_univs_infer_with + UnivProblem.eq_constr_univs_infer_with (fun t -> kind_of_term_upto sigma1 t) (fun u -> kind_of_term_upto sigma2 u) (universes sigma2) fold t u sigma2 in match ans with None -> false | Some _ -> true - -type type_constraint = EConstr.types option -type val_constraint = EConstr.constr option diff --git a/engine/evarutil.mli b/engine/evarutil.mli index 972b0b9e1..c17f3d168 100644 --- a/engine/evarutil.mli +++ b/engine/evarutil.mli @@ -12,6 +12,7 @@ open Names open Constr open Evd open Environ +open Namegen open EConstr (** This module provides useful higher-level functions for evar manipulation. *) @@ -25,53 +26,51 @@ val mk_new_meta : unit -> constr (** {6 Creating a fresh evar given their type and context} *) val new_evar_from_context : - named_context_val -> evar_map -> ?src:Evar_kinds.t Loc.located -> ?filter:Filter.t -> + ?src:Evar_kinds.t Loc.located -> ?filter:Filter.t -> ?candidates:constr list -> ?store:Store.t -> - ?naming:Misctypes.intro_pattern_naming_expr -> - ?principal:bool -> types -> evar_map * EConstr.t + ?naming:intro_pattern_naming_expr -> + ?principal:bool -> + named_context_val -> evar_map -> types -> evar_map * EConstr.t + +type naming_mode = + | KeepUserNameAndRenameExistingButSectionNames + | KeepUserNameAndRenameExistingEvenSectionNames + | KeepExistingNames + | FailIfConflict val new_evar : - env -> evar_map -> ?src:Evar_kinds.t Loc.located -> ?filter:Filter.t -> + ?src:Evar_kinds.t Loc.located -> ?filter:Filter.t -> ?candidates:constr list -> ?store:Store.t -> - ?naming:Misctypes.intro_pattern_naming_expr -> - ?principal:bool -> types -> evar_map * EConstr.t + ?naming:intro_pattern_naming_expr -> + ?principal:bool -> ?hypnaming:naming_mode -> + env -> evar_map -> types -> evar_map * EConstr.t val new_pure_evar : - named_context_val -> evar_map -> ?src:Evar_kinds.t Loc.located -> ?filter:Filter.t -> + ?src:Evar_kinds.t Loc.located -> ?filter:Filter.t -> ?candidates:constr list -> ?store:Store.t -> - ?naming:Misctypes.intro_pattern_naming_expr -> - ?principal:bool -> types -> evar_map * Evar.t + ?naming:intro_pattern_naming_expr -> + ?principal:bool -> + named_context_val -> evar_map -> types -> evar_map * Evar.t val new_pure_evar_full : evar_map -> evar_info -> evar_map * Evar.t -(** the same with side-effects *) -val e_new_evar : - env -> evar_map ref -> ?src:Evar_kinds.t Loc.located -> ?filter:Filter.t -> - ?candidates:constr list -> ?store:Store.t -> - ?naming:Misctypes.intro_pattern_naming_expr -> - ?principal:bool -> types -> constr - (** Create a new Type existential variable, as we keep track of them during type-checking and unification. *) val new_type_evar : - env -> evar_map -> ?src:Evar_kinds.t Loc.located -> ?filter:Filter.t -> - ?naming:Misctypes.intro_pattern_naming_expr -> ?principal:bool -> rigid -> - evar_map * (constr * Sorts.t) - -val e_new_type_evar : env -> evar_map ref -> ?src:Evar_kinds.t Loc.located -> ?filter:Filter.t -> - ?naming:Misctypes.intro_pattern_naming_expr -> ?principal:bool -> rigid -> constr * Sorts.t + ?naming:intro_pattern_naming_expr -> + ?principal:bool -> ?hypnaming:naming_mode -> + env -> evar_map -> rigid -> + evar_map * (constr * Sorts.t) val new_Type : ?rigid:rigid -> env -> evar_map -> evar_map * constr -val e_new_Type : ?rigid:rigid -> env -> evar_map ref -> constr val restrict_evar : evar_map -> Evar.t -> Filter.t -> ?src:Evar_kinds.t Loc.located -> constr list option -> evar_map * Evar.t (** Polymorphic constants *) -val new_global : evar_map -> Globnames.global_reference -> evar_map * constr -val e_new_global : evar_map ref -> Globnames.global_reference -> constr +val new_global : evar_map -> GlobRef.t -> evar_map * constr (** Create a fresh evar in a context different from its definition context: [new_evar_instance sign evd ty inst] creates a new evar of context @@ -80,10 +79,10 @@ val e_new_global : evar_map ref -> Globnames.global_reference -> constr of [inst] are typed in the occurrence context and their type (seen as a telescope) is [sign] *) val new_evar_instance : - named_context_val -> evar_map -> types -> ?src:Evar_kinds.t Loc.located -> ?filter:Filter.t -> ?candidates:constr list -> - ?store:Store.t -> ?naming:Misctypes.intro_pattern_naming_expr -> + ?store:Store.t -> ?naming:intro_pattern_naming_expr -> ?principal:bool -> + named_context_val -> evar_map -> types -> constr list -> evar_map * constr val make_pure_subst : evar_info -> 'a array -> (Id.t * 'a) list @@ -178,11 +177,12 @@ val nf_evar_map_undefined : evar_map -> evar_map val nf_evars_universes : evar_map -> Constr.constr -> Constr.constr val nf_evars_and_universes : evar_map -> evar_map * (Constr.constr -> Constr.constr) -val e_nf_evars_and_universes : evar_map ref -> (Constr.constr -> Constr.constr) * Universes.universe_opt_subst +[@@ocaml.deprecated "Use Evd.minimize_universes and nf_evars_universes"] (** Normalize the evar map w.r.t. universes, after simplification of constraints. Return the substitution function for constrs as well. *) val nf_evar_map_universes : evar_map -> evar_map * (Constr.constr -> Constr.constr) +[@@ocaml.deprecated "Use Evd.minimize_universes and nf_evar_map and nf_evars_universes"] (** Replacing all evars, possibly raising [Uninstantiated_evar] *) exception Uninstantiated_evar of Evar.t @@ -201,7 +201,7 @@ val kind_of_term_upto : evar_map -> Constr.constr -> universes. The term [t] is interpreted in [sigma1] while [u] is interpreted in [sigma2]. The universe constraints in [sigma2] are assumed to be an extention of those in [sigma1]. *) -val eq_constr_univs_test : evar_map -> evar_map -> Constr.constr -> Constr.constr -> bool +val eq_constr_univs_test : evar_map -> evar_map -> constr -> constr -> bool (** [compare_cumulative_instances cv_pb variance u1 u2 sigma] Returns [Inl sigma'] where [sigma'] is [sigma] augmented with universe @@ -224,13 +224,13 @@ type clear_dependency_error = | OccurHypInSimpleClause of Id.t option | EvarTypingBreak of Constr.existential -exception ClearDependencyError of Id.t * clear_dependency_error +exception ClearDependencyError of Id.t * clear_dependency_error * GlobRef.t option -val clear_hyps_in_evi : env -> evar_map ref -> named_context_val -> types -> - Id.Set.t -> named_context_val * types +val clear_hyps_in_evi : env -> evar_map -> named_context_val -> types -> + Id.Set.t -> evar_map * named_context_val * types -val clear_hyps2_in_evi : env -> evar_map ref -> named_context_val -> types -> types -> - Id.Set.t -> named_context_val * types * types +val clear_hyps2_in_evi : env -> evar_map -> named_context_val -> types -> types -> + Id.Set.t -> evar_map * named_context_val * types * types type csubst @@ -240,10 +240,11 @@ val csubst_subst : csubst -> constr -> constr type ext_named_context = csubst * Id.Set.t * named_context -val push_rel_decl_to_named_context : +val push_rel_decl_to_named_context : ?hypnaming:naming_mode -> evar_map -> rel_declaration -> ext_named_context -> ext_named_context -val push_rel_context_to_named_context : Environ.env -> evar_map -> types -> +val push_rel_context_to_named_context : ?hypnaming:naming_mode -> + Environ.env -> evar_map -> types -> named_context_val * types * constr list * csubst val generalize_evar_over_rels : evar_map -> existential -> types * constr list @@ -259,8 +260,24 @@ val subterm_source : Evar.t -> ?where:Evar_kinds.subevar_kind -> Evar_kinds.t Lo val meta_counter_summary_tag : int Summary.Dyn.tag -(** Deprecated *) -type type_constraint = types option -[@@ocaml.deprecated "use the version in Evardefine"] -type val_constraint = constr option -[@@ocaml.deprecated "use the version in Evardefine"] +val e_new_evar : + env -> evar_map ref -> ?src:Evar_kinds.t Loc.located -> ?filter:Filter.t -> + ?candidates:constr list -> ?store:Store.t -> + ?naming:intro_pattern_naming_expr -> + ?principal:bool -> ?hypnaming:naming_mode -> types -> constr +[@@ocaml.deprecated "Use [Evarutil.new_evar]"] + +val e_new_type_evar : env -> evar_map ref -> + ?src:Evar_kinds.t Loc.located -> ?filter:Filter.t -> + ?naming:intro_pattern_naming_expr -> + ?principal:bool -> ?hypnaming:naming_mode -> rigid -> constr * Sorts.t +[@@ocaml.deprecated "Use [Evarutil.new_type_evar]"] + +val e_new_Type : ?rigid:rigid -> env -> evar_map ref -> constr +[@@ocaml.deprecated "Use [Evarutil.new_Type]"] + +val e_new_global : evar_map ref -> GlobRef.t -> constr +[@@ocaml.deprecated "Use [Evarutil.new_global]"] + +val e_nf_evars_and_universes : evar_map ref -> (Constr.constr -> Constr.constr) * UnivSubst.universe_opt_subst +[@@ocaml.deprecated "Use Evd.minimize_universes and nf_evars_universes"] diff --git a/engine/evd.ml b/engine/evd.ml index f6e13e1f4..0c9c3a29b 100644 --- a/engine/evd.ml +++ b/engine/evd.ml @@ -21,6 +21,9 @@ open Environ (* module RelDecl = Context.Rel.Declaration *) module NamedDecl = Context.Named.Declaration +type econstr = constr +type etypes = types + (** Generic filters *) module Filter : sig @@ -129,8 +132,6 @@ end module Store = Store.Make () -type evar = Evar.t - let string_of_existential evk = "?X" ^ string_of_int (Evar.repr evk) type evar_body = @@ -507,8 +508,8 @@ let raw_map f d = in ans in - let defn_evars = EvMap.smartmapi f d.defn_evars in - let undf_evars = EvMap.smartmapi f d.undf_evars in + let defn_evars = EvMap.Smart.mapi f d.defn_evars in + let undf_evars = EvMap.Smart.mapi f d.undf_evars in { d with defn_evars; undf_evars; } let raw_map_undefined f d = @@ -521,7 +522,7 @@ let raw_map_undefined f d = in ans in - { d with undf_evars = EvMap.smartmapi f d.undf_evars; } + { d with undf_evars = EvMap.Smart.mapi f d.undf_evars; } let is_evar = mem @@ -537,10 +538,14 @@ let existential_value d (n, args) = | Evar_empty -> raise NotInstantiatedEvar +let existential_value0 = existential_value + let existential_opt_value d ev = try Some (existential_value d ev) with NotInstantiatedEvar -> None +let existential_opt_value0 = existential_opt_value + let existential_type d (n, args) = let info = try find d n @@ -548,6 +553,8 @@ let existential_type d (n, args) = anomaly (str "Evar " ++ str (string_of_existential n) ++ str " was not declared.") in instantiate_evar_array info info.evar_concl args +let existential_type0 = existential_type + let add_constraints d c = { d with universes = UState.add_constraints d.universes c } @@ -795,19 +802,19 @@ let make_flexible_variable evd ~algebraic u = (****************************************) let fresh_sort_in_family ?loc ?(rigid=univ_flexible) env evd s = - with_context_set ?loc rigid evd (Universes.fresh_sort_in_family env s) + with_context_set ?loc rigid evd (UnivGen.fresh_sort_in_family env s) let fresh_constant_instance ?loc env evd c = - with_context_set ?loc univ_flexible evd (Universes.fresh_constant_instance env c) + with_context_set ?loc univ_flexible evd (UnivGen.fresh_constant_instance env c) let fresh_inductive_instance ?loc env evd i = - with_context_set ?loc univ_flexible evd (Universes.fresh_inductive_instance env i) + with_context_set ?loc univ_flexible evd (UnivGen.fresh_inductive_instance env i) let fresh_constructor_instance ?loc env evd c = - with_context_set ?loc univ_flexible evd (Universes.fresh_constructor_instance env c) + with_context_set ?loc univ_flexible evd (UnivGen.fresh_constructor_instance env c) let fresh_global ?loc ?(rigid=univ_flexible) ?names env evd gr = - with_context_set ?loc rigid evd (Universes.fresh_global_instance ?names env gr) + with_context_set ?loc rigid evd (UnivGen.fresh_global_instance ?names env gr) let whd_sort_variable evd t = t @@ -833,13 +840,13 @@ let universe_rigidity evd l = else UnivRigid let normalize_universe evd = - let vars = ref (UState.subst evd.universes) in - let normalize = Universes.normalize_universe_opt_subst vars in + let vars = UState.subst evd.universes in + let normalize = UnivSubst.normalize_universe_opt_subst vars in normalize let normalize_universe_instance evd l = - let vars = ref (UState.subst evd.universes) in - let normalize = Universes.level_subst_of (Universes.normalize_univ_variable_opt_subst vars) in + let vars = UState.subst evd.universes in + let normalize = UnivSubst.level_subst_of (UnivSubst.normalize_univ_variable_opt_subst vars) in Univ.Instance.subst_fn normalize l let normalize_sort evars s = @@ -857,7 +864,7 @@ let set_eq_sort env d s1 s2 = | Some (u1, u2) -> if not (type_in_type env) then add_universe_constraints d - (Universes.Constraints.singleton (Universes.UEq (u1,u2))) + (UnivProblem.Set.singleton (UnivProblem.UEq (u1,u2))) else d @@ -869,7 +876,7 @@ let set_leq_level d u1 u2 = let set_eq_instances ?(flex=false) d u1 u2 = add_universe_constraints d - (Universes.enforce_eq_instances_univs flex u1 u2 Universes.Constraints.empty) + (UnivProblem.enforce_eq_instances_univs flex u1 u2 UnivProblem.Set.empty) let set_leq_sort env evd s1 s2 = let s1 = normalize_sort evd s1 @@ -878,7 +885,7 @@ let set_leq_sort env evd s1 s2 = | None -> evd | Some (u1, u2) -> if not (type_in_type env) then - add_universe_constraints evd (Universes.Constraints.singleton (Universes.ULe (u1,u2))) + add_universe_constraints evd (UnivProblem.Set.singleton (UnivProblem.ULe (u1,u2))) else evd let check_eq evd s s' = @@ -1031,11 +1038,11 @@ let map_metas_fvalue f evd = | Clval(id,(c,s),typ) -> Clval(id,(mk_freelisted (f c.rebus),s),typ) | x -> x in - set_metas evd (Metamap.smartmap map evd.metas) + set_metas evd (Metamap.Smart.map map evd.metas) let map_metas f evd = let map cl = map_clb f cl in - set_metas evd (Metamap.smartmap map evd.metas) + set_metas evd (Metamap.Smart.map map evd.metas) let meta_opt_fvalue evd mv = match Metamap.find mv evd.metas with @@ -1065,6 +1072,7 @@ let meta_ftype evd mv = | Clval(_,_,b) -> b let meta_type evd mv = (meta_ftype evd mv).rebus +let meta_type0 = meta_type let meta_declare mv v ?(name=Anonymous) evd = let metas = Metamap.add mv (Cltyp(name,mk_freelisted v)) evd.metas in @@ -1110,7 +1118,7 @@ let retract_coercible_metas evd = Cltyp (na, typ) | v -> v in - let metas = Metamap.smartmapi map evd.metas in + let metas = Metamap.Smart.mapi map evd.metas in !mc, set_metas evd metas let evar_source_of_meta mv evd = @@ -1196,24 +1204,81 @@ module Monad = type unsolvability_explanation = SeveralInstancesFound of int -(** Deprecated *) -type evar_universe_context = UState.t -let empty_evar_universe_context = UState.empty -let union_evar_universe_context = UState.union -let evar_universe_context_set = UState.context_set -let evar_universe_context_constraints = UState.constraints -let evar_context_universe_context = UState.context -let evar_universe_context_of = UState.of_context_set -let evar_universe_context_subst = UState.subst -let add_constraints_context = UState.add_constraints -let constrain_variables = UState.constrain_variables -let evar_universe_context_of_binders = UState.of_binders -let make_evar_universe_context e l = - let g = Environ.universes e in - match l with - | None -> UState.make g - | Some l -> UState.make_with_initial_binders g l -let normalize_evar_universe_context_variables = UState.normalize_variables -let abstract_undefined_variables = UState.abstract_undefined_variables -let normalize_evar_universe_context = UState.minimize -let nf_constraints = minimize_universes +module MiniEConstr = struct + + module ESorts = + struct + type t = Sorts.t + let make s = s + let kind sigma = function + | Sorts.Type u -> Sorts.sort_of_univ (normalize_universe sigma u) + | s -> s + let unsafe_to_sorts s = s + end + + module EInstance = + struct + type t = Univ.Instance.t + let make i = i + let kind sigma i = + if Univ.Instance.is_empty i then i + else normalize_universe_instance sigma i + let empty = Univ.Instance.empty + let is_empty = Univ.Instance.is_empty + let unsafe_to_instance t = t + end + + type t = econstr + + let safe_evar_value sigma ev = + try Some (existential_value sigma ev) + with NotInstantiatedEvar | Not_found -> None + + let rec whd_evar sigma c = + match Constr.kind c with + | Evar ev -> + begin match safe_evar_value sigma ev with + | Some c -> whd_evar sigma c + | None -> c + end + | App (f, args) when isEvar f -> + (** Enforce smart constructor invariant on applications *) + let ev = destEvar f in + begin match safe_evar_value sigma ev with + | None -> c + | Some f -> whd_evar sigma (mkApp (f, args)) + end + | Cast (c0, k, t) when isEvar c0 -> + (** Enforce smart constructor invariant on casts. *) + let ev = destEvar c0 in + begin match safe_evar_value sigma ev with + | None -> c + | Some c -> whd_evar sigma (mkCast (c, k, t)) + end + | _ -> c + + let kind sigma c = Constr.kind (whd_evar sigma c) + let kind_upto = kind + let kind_of_type sigma c = Term.kind_of_type (whd_evar sigma c) + let of_kind = Constr.of_kind + let of_constr c = c + let unsafe_to_constr c = c + let unsafe_eq = Refl + + let to_constr ?(abort_on_undefined_evars=true) sigma c = + let evar_value = + if not abort_on_undefined_evars then fun ev -> safe_evar_value sigma ev + else fun ev -> + match safe_evar_value sigma ev with + | Some _ as v -> v + | None -> anomaly ~label:"econstr" Pp.(str "grounding a non evar-free term") + in + UnivSubst.nf_evars_and_universes_opt_subst evar_value (universe_subst sigma) c + + let of_named_decl d = d + let unsafe_to_named_decl d = d + let of_rel_decl d = d + let unsafe_to_rel_decl d = d + let to_rel_decl sigma d = Context.Rel.Declaration.map_constr (to_constr sigma) d + +end diff --git a/engine/evd.mli b/engine/evd.mli index 911799c44..c40e925d8 100644 --- a/engine/evd.mli +++ b/engine/evd.mli @@ -28,15 +28,10 @@ open Environ It also contains conversion constraints, debugging information and information about meta variables. *) -(** {5 Existential variables and unification states} *) - -type evar = Evar.t -[@@ocaml.deprecated "use Evar.t"] -(** Existential variables. *) +type econstr +type etypes = econstr -(** {6 Evars} *) -val string_of_existential : Evar.t -> string -[@@ocaml.deprecated "use Evar.print"] +(** {5 Existential variables and unification states} *) (** {6 Evar filters} *) @@ -86,16 +81,16 @@ end type evar_body = | Evar_empty - | Evar_defined of constr + | Evar_defined of econstr module Store : Store.S (** Datatype used to store additional information in evar maps. *) type evar_info = { - evar_concl : constr; + evar_concl : econstr; (** Type of the evar. *) - evar_hyps : named_context_val; + evar_hyps : named_context_val; (** TODO econstr? *) (** Context of the evar. *) evar_body : evar_body; (** Optional content of the evar. *) @@ -105,16 +100,16 @@ type evar_info = { in the solution *) evar_source : Evar_kinds.t located; (** Information about the evar. *) - evar_candidates : constr list option; + evar_candidates : econstr list option; (** List of possible solutions when known that it is a finite list *) evar_extra : Store.t (** Extra store, used for clever hacks. *) } -val make_evar : named_context_val -> types -> evar_info -val evar_concl : evar_info -> constr -val evar_context : evar_info -> Context.Named.t -val evar_filtered_context : evar_info -> Context.Named.t +val make_evar : named_context_val -> etypes -> evar_info +val evar_concl : evar_info -> econstr +val evar_context : evar_info -> (econstr, etypes) Context.Named.pt +val evar_filtered_context : evar_info -> (econstr, etypes) Context.Named.pt val evar_hyps : evar_info -> named_context_val val evar_filtered_hyps : evar_info -> named_context_val val evar_body : evar_info -> evar_body @@ -122,15 +117,11 @@ val evar_filter : evar_info -> Filter.t val evar_env : evar_info -> env val evar_filtered_env : evar_info -> env -val map_evar_body : (constr -> constr) -> evar_body -> evar_body -val map_evar_info : (constr -> constr) -> evar_info -> evar_info +val map_evar_body : (econstr -> econstr) -> evar_body -> evar_body +val map_evar_info : (econstr -> econstr) -> evar_info -> evar_info (** {6 Unification state} **) -type evar_universe_context = UState.t -[@@ocaml.deprecated "Alias of UState.t"] -(** The universe context associated to an evar map *) - type evar_map (** Type of unification state. Essentially a bunch of state-passing data needed to handle incremental term construction. *) @@ -190,7 +181,7 @@ val raw_map_undefined : (Evar.t -> evar_info -> evar_info) -> evar_map -> evar_m (** Same as {!raw_map}, but restricted to undefined evars. For efficiency reasons. *) -val define : Evar.t-> constr -> evar_map -> evar_map +val define : Evar.t-> econstr -> evar_map -> evar_map (** Set the body of an evar to the given constr. It is expected that: {ul {- The evar is already present in the evarmap.} @@ -198,7 +189,7 @@ val define : Evar.t-> constr -> evar_map -> evar_map {- All the evars present in the constr should be present in the evar map.} } *) -val cmap : (constr -> constr) -> evar_map -> evar_map +val cmap : (econstr -> econstr) -> evar_map -> evar_map (** Map the function on all terms in the evar map. *) val is_evar : evar_map -> Evar.t-> bool @@ -222,20 +213,26 @@ val drop_all_defined : evar_map -> evar_map exception NotInstantiatedEvar -val existential_value : evar_map -> existential -> constr +val existential_value : evar_map -> econstr pexistential -> econstr (** [existential_value sigma ev] raises [NotInstantiatedEvar] if [ev] has no body and [Not_found] if it does not exist in [sigma] *) -val existential_type : evar_map -> existential -> types +val existential_value0 : evar_map -> existential -> constr + +val existential_type : evar_map -> econstr pexistential -> etypes + +val existential_type0 : evar_map -> existential -> types -val existential_opt_value : evar_map -> existential -> constr option +val existential_opt_value : evar_map -> econstr pexistential -> econstr option (** Same as {!existential_value} but returns an option instead of raising an exception. *) +val existential_opt_value0 : evar_map -> existential -> constr option + val evar_instance_array : (Context.Named.Declaration.t -> 'a -> bool) -> evar_info -> 'a array -> (Id.t * 'a) list -val instantiate_evar_array : evar_info -> constr -> constr array -> constr +val instantiate_evar_array : evar_info -> econstr -> econstr array -> econstr val evars_reset_evd : ?with_conv_pbs:bool -> ?with_univs:bool -> evar_map -> evar_map -> evar_map @@ -243,7 +240,7 @@ val evars_reset_evd : ?with_conv_pbs:bool -> ?with_univs:bool -> (** {6 Misc} *) -val restrict : Evar.t-> Filter.t -> ?candidates:constr list -> +val restrict : Evar.t-> Filter.t -> ?candidates:econstr list -> ?src:Evar_kinds.t located -> evar_map -> evar_map * Evar.t (** Restrict an undefined evar into a new evar by filtering context and possibly limiting the instances to a set of candidates *) @@ -251,7 +248,7 @@ val restrict : Evar.t-> Filter.t -> ?candidates:constr list -> val is_restricted_evar : evar_info -> Evar.t option (** Tell if an evar comes from restriction of another evar, and if yes, which *) -val downcast : Evar.t-> types -> evar_map -> evar_map +val downcast : Evar.t-> etypes -> evar_map -> evar_map (** Change the type of an undefined evar to a new type assumed to be a subtype of its current type; subtyping must be ensured by caller *) @@ -341,11 +338,11 @@ val shelve_on_future_goals : Evar.t list -> future_goals -> future_goals Evar maps also keep track of the universe constraints defined at a given point. This section defines the relevant manipulation functions. *) -val whd_sort_variable : evar_map -> constr -> constr +val whd_sort_variable : evar_map -> econstr -> econstr exception UniversesDiffer -val add_universe_constraints : evar_map -> Universes.Constraints.t -> evar_map +val add_universe_constraints : evar_map -> UnivProblem.Set.t -> evar_map (** Add the given universe unification constraints to the evar map. @raise UniversesDiffer in case a first-order unification fails. @raise UniverseInconsistency . @@ -397,8 +394,8 @@ type 'a freelisted = { rebus : 'a; freemetas : Metaset.t } -val metavars_of : constr -> Metaset.t -val mk_freelisted : constr -> constr freelisted +val metavars_of : econstr -> Metaset.t +val mk_freelisted : econstr -> econstr freelisted val map_fl : ('a -> 'b) -> 'a freelisted -> 'b freelisted (** Status of an instance found by unification wrt to the meta it solves: @@ -436,12 +433,12 @@ type instance_status = instance_constraint * instance_typing_status (** Clausal environments *) type clbinding = - | Cltyp of Name.t * constr freelisted - | Clval of Name.t * (constr freelisted * instance_status) * constr freelisted + | Cltyp of Name.t * econstr freelisted + | Clval of Name.t * (econstr freelisted * instance_status) * econstr freelisted (** Unification constraints *) type conv_pb = Reduction.conv_pb -type evar_constraint = conv_pb * env * constr * constr +type evar_constraint = conv_pb * env * econstr * econstr val add_conv_pb : ?tail:bool -> evar_constraint -> evar_map -> evar_map val extract_changed_conv_pbs : evar_map -> @@ -457,7 +454,7 @@ val loc_of_conv_pb : evar_map -> evar_constraint -> Loc.t option val evars_of_term : constr -> Evar.Set.t (** including evars in instances of evars *) -val evars_of_named_context : Context.Named.t -> Evar.Set.t +val evars_of_named_context : (econstr, etypes) Context.Named.pt -> Evar.Set.t val evars_of_filtered_evar_info : evar_info -> Evar.Set.t @@ -465,19 +462,20 @@ val evars_of_filtered_evar_info : evar_info -> Evar.Set.t val meta_list : evar_map -> (metavariable * clbinding) list val meta_defined : evar_map -> metavariable -> bool -val meta_value : evar_map -> metavariable -> constr +val meta_value : evar_map -> metavariable -> econstr (** [meta_fvalue] raises [Not_found] if meta not in map or [Anomaly] if meta has no value *) -val meta_fvalue : evar_map -> metavariable -> constr freelisted * instance_status -val meta_opt_fvalue : evar_map -> metavariable -> (constr freelisted * instance_status) option -val meta_type : evar_map -> metavariable -> types -val meta_ftype : evar_map -> metavariable -> types freelisted +val meta_fvalue : evar_map -> metavariable -> econstr freelisted * instance_status +val meta_opt_fvalue : evar_map -> metavariable -> (econstr freelisted * instance_status) option +val meta_type : evar_map -> metavariable -> etypes +val meta_type0 : evar_map -> metavariable -> types +val meta_ftype : evar_map -> metavariable -> etypes freelisted val meta_name : evar_map -> metavariable -> Name.t val meta_declare : - metavariable -> types -> ?name:Name.t -> evar_map -> evar_map -val meta_assign : metavariable -> constr * instance_status -> evar_map -> evar_map -val meta_reassign : metavariable -> constr * instance_status -> evar_map -> evar_map + metavariable -> etypes -> ?name:Name.t -> evar_map -> evar_map +val meta_assign : metavariable -> econstr * instance_status -> evar_map -> evar_map +val meta_reassign : metavariable -> econstr * instance_status -> evar_map -> evar_map val clear_metas : evar_map -> evar_map @@ -485,10 +483,10 @@ val clear_metas : evar_map -> evar_map val meta_merge : ?with_univs:bool -> evar_map -> evar_map -> evar_map val undefined_metas : evar_map -> metavariable list -val map_metas_fvalue : (constr -> constr) -> evar_map -> evar_map -val map_metas : (constr -> constr) -> evar_map -> evar_map +val map_metas_fvalue : (econstr -> econstr) -> evar_map -> evar_map +val map_metas : (econstr -> econstr) -> evar_map -> evar_map -type metabinding = metavariable * constr * instance_status +type metabinding = metavariable * econstr * instance_status val retract_coercible_metas : evar_map -> metabinding list * evar_map @@ -519,48 +517,11 @@ val univ_flexible_alg : rigid type 'a in_evar_universe_context = 'a * UState.t -val evar_universe_context_set : UState.t -> Univ.ContextSet.t -[@@ocaml.deprecated "Alias of UState.context_set"] -val evar_universe_context_constraints : UState.t -> Univ.Constraint.t -[@@ocaml.deprecated "Alias of UState.constraints"] -val evar_context_universe_context : UState.t -> Univ.UContext.t -[@@ocaml.deprecated "alias of UState.context"] - -val evar_universe_context_of : Univ.ContextSet.t -> UState.t -[@@ocaml.deprecated "Alias of UState.of_context_set"] -val empty_evar_universe_context : UState.t -[@@ocaml.deprecated "Alias of UState.empty"] -val union_evar_universe_context : UState.t -> UState.t -> - UState.t -[@@ocaml.deprecated "Alias of UState.union"] -val evar_universe_context_subst : UState.t -> Universes.universe_opt_subst -[@@ocaml.deprecated "Alias of UState.subst"] -val constrain_variables : Univ.LSet.t -> UState.t -> UState.t -[@@ocaml.deprecated "Alias of UState.constrain_variables"] - - -val evar_universe_context_of_binders : - Universes.universe_binders -> UState.t -[@@ocaml.deprecated "Alias of UState.of_binders"] - -val make_evar_universe_context : env -> Misctypes.lident list option -> UState.t -[@@ocaml.deprecated "Use UState.make or UState.make_with_initial_binders"] val restrict_universe_context : evar_map -> Univ.LSet.t -> evar_map (** Raises Not_found if not a name for a universe in this map. *) val universe_of_name : evar_map -> Id.t -> Univ.Level.t -val universe_binders : evar_map -> Universes.universe_binders -val add_constraints_context : UState.t -> - Univ.Constraint.t -> UState.t -[@@ocaml.deprecated "Alias of UState.add_constraints"] - - -val normalize_evar_universe_context_variables : UState.t -> - Univ.universe_subst in_evar_universe_context -[@@ocaml.deprecated "Alias of UState.normalize_variables"] - -val normalize_evar_universe_context : UState.t -> UState.t -[@@ocaml.deprecated "Alias of UState.minimize"] +val universe_binders : evar_map -> UnivNames.universe_binders val new_univ_level_variable : ?loc:Loc.t -> ?name:Id.t -> rigid -> evar_map -> evar_map * Univ.Level.t val new_univ_variable : ?loc:Loc.t -> ?name:Id.t -> rigid -> evar_map -> evar_map * Univ.Universe.t @@ -593,7 +554,7 @@ val check_leq : evar_map -> Univ.Universe.t -> Univ.Universe.t -> bool val evar_universe_context : evar_map -> UState.t val universe_context_set : evar_map -> Univ.ContextSet.t -val universe_subst : evar_map -> Universes.universe_opt_subst +val universe_subst : evar_map -> UnivSubst.universe_opt_subst val universes : evar_map -> UGraph.t (** [to_universe_context evm] extracts the local universes and @@ -612,13 +573,11 @@ val merge_universe_context : evar_map -> UState.t -> evar_map val set_universe_context : evar_map -> UState.t -> evar_map val merge_context_set : ?loc:Loc.t -> ?sideff:bool -> rigid -> evar_map -> Univ.ContextSet.t -> evar_map -val merge_universe_subst : evar_map -> Universes.universe_opt_subst -> evar_map +val merge_universe_subst : evar_map -> UnivSubst.universe_opt_subst -> evar_map val with_context_set : ?loc:Loc.t -> rigid -> evar_map -> 'a Univ.in_universe_context_set -> evar_map * 'a val nf_univ_variables : evar_map -> evar_map * Univ.universe_subst -val abstract_undefined_variables : UState.t -> UState.t -[@@ocaml.deprecated "Alias of UState.abstract_undefined_variables"] val fix_undefined_variables : evar_map -> evar_map @@ -626,8 +585,6 @@ val refresh_undefined_universes : evar_map -> evar_map * Univ.universe_level_sub (** Universe minimization *) val minimize_universes : evar_map -> evar_map -val nf_constraints : evar_map -> evar_map -[@@ocaml.deprecated "Alias of Evd.minimize_universes"] val update_sigma_env : evar_map -> env -> evar_map @@ -639,13 +596,13 @@ val fresh_inductive_instance : ?loc:Loc.t -> env -> evar_map -> inductive -> eva val fresh_constructor_instance : ?loc:Loc.t -> env -> evar_map -> constructor -> evar_map * pconstructor val fresh_global : ?loc:Loc.t -> ?rigid:rigid -> ?names:Univ.Instance.t -> env -> - evar_map -> Globnames.global_reference -> evar_map * constr + evar_map -> GlobRef.t -> evar_map * econstr (********************************************************************) (* constr with holes and pending resolution of classes, conversion *) (* problems, candidates, etc. *) -type open_constr = evar_map * constr (* Special case when before is empty *) +type open_constr = evar_map * econstr (* Special case when before is empty *) (** Partially constructed constrs. *) @@ -665,3 +622,50 @@ val create_evar_defs : evar_map -> evar_map (** Create an [evar_map] with empty meta map: *) +(** Use this module only to bootstrap EConstr *) +module MiniEConstr : sig + module ESorts : sig + type t + val make : Sorts.t -> t + val kind : evar_map -> t -> Sorts.t + val unsafe_to_sorts : t -> Sorts.t + end + + module EInstance : sig + type t + val make : Univ.Instance.t -> t + val kind : evar_map -> t -> Univ.Instance.t + val empty : t + val is_empty : t -> bool + val unsafe_to_instance : t -> Univ.Instance.t + end + + type t = econstr + + val kind : evar_map -> t -> (t, t, ESorts.t, EInstance.t) Constr.kind_of_term + val kind_upto : evar_map -> constr -> (constr, types, Sorts.t, Univ.Instance.t) Constr.kind_of_term + val kind_of_type : evar_map -> t -> (t, t) Term.kind_of_type + + val whd_evar : evar_map -> t -> t + + val of_kind : (t, t, ESorts.t, EInstance.t) Constr.kind_of_term -> t + + val of_constr : Constr.t -> t + + val to_constr : ?abort_on_undefined_evars:bool -> evar_map -> t -> Constr.t + + val unsafe_to_constr : t -> Constr.t + + val unsafe_eq : (t, Constr.t) eq + + val of_named_decl : (Constr.t, Constr.types) Context.Named.Declaration.pt -> + (t, t) Context.Named.Declaration.pt + val unsafe_to_named_decl : (t, t) Context.Named.Declaration.pt -> + (Constr.t, Constr.types) Context.Named.Declaration.pt + val unsafe_to_rel_decl : (t, t) Context.Rel.Declaration.pt -> + (Constr.t, Constr.types) Context.Rel.Declaration.pt + val of_rel_decl : (Constr.t, Constr.types) Context.Rel.Declaration.pt -> + (t, t) Context.Rel.Declaration.pt + val to_rel_decl : evar_map -> (t, t) Context.Rel.Declaration.pt -> + (Constr.t, Constr.types) Context.Rel.Declaration.pt +end diff --git a/engine/namegen.ml b/engine/namegen.ml index d66b77b57..23c691139 100644 --- a/engine/namegen.ml +++ b/engine/namegen.ml @@ -17,6 +17,7 @@ open Util open Names open Term +open Constr open Environ open EConstr open Vars @@ -28,6 +29,18 @@ open Context.Rel.Declaration module RelDecl = Context.Rel.Declaration +(** General evar naming using intro patterns *) +type intro_pattern_naming_expr = + | IntroIdentifier of Id.t + | IntroFresh of Id.t + | IntroAnonymous + +let intro_pattern_naming_eq nam1 nam2 = match nam1, nam2 with +| IntroAnonymous, IntroAnonymous -> true +| IntroIdentifier id1, IntroIdentifier id2 -> Names.Id.equal id1 id2 +| IntroFresh id1, IntroFresh id2 -> Names.Id.equal id1 id2 +| _ -> false + (**********************************************************************) (* Conventional names *) diff --git a/engine/namegen.mli b/engine/namegen.mli index 1b70ef68d..a53c3a0d1 100644 --- a/engine/namegen.mli +++ b/engine/namegen.mli @@ -15,6 +15,16 @@ open Environ open Evd open EConstr +(** General evar naming using intro patterns *) +type intro_pattern_naming_expr = + | IntroIdentifier of Id.t + | IntroFresh of Id.t + | IntroAnonymous + +(** Equalities on [intro_pattern_naming] *) +val intro_pattern_naming_eq : + intro_pattern_naming_expr -> intro_pattern_naming_expr -> bool + (********************************************************************* Conventional default names *) diff --git a/engine/nameops.ml b/engine/nameops.ml index 53969cafa..735a59fe5 100644 --- a/engine/nameops.ml +++ b/engine/nameops.ml @@ -11,10 +11,6 @@ open Util open Names -(* Identifiers *) - -let pr_id id = Id.print id - (* Utilities *) let code_of_0 = Char.code '0' @@ -191,28 +187,6 @@ struct end -open Name - -(* Compatibility *) -let out_name = get_id -let name_fold = fold_right -let name_iter = iter -let name_app = map -let name_fold_map = fold_left_map -let name_cons = cons -let name_max = pick -let pr_name = print - -let pr_lab l = Label.print l - (* Metavariables *) let pr_meta = Pp.int let string_of_meta = string_of_int - -(* Deprecated *) -open Libnames -let default_library = default_library -let coq_string = coq_string -let coq_root = coq_root -let default_root_prefix = default_root_prefix - diff --git a/engine/nameops.mli b/engine/nameops.mli index 96842dfb9..8a93fad8c 100644 --- a/engine/nameops.mli +++ b/engine/nameops.mli @@ -94,47 +94,3 @@ end (** Metavariables *) val pr_meta : Constr.metavariable -> Pp.t val string_of_meta : Constr.metavariable -> string - -val out_name : Name.t -> Id.t -[@@ocaml.deprecated "Same as [Name.get_id]"] - -val name_fold : (Id.t -> 'a -> 'a) -> Name.t -> 'a -> 'a -[@@ocaml.deprecated "Same as [Name.fold_right]"] - -val name_iter : (Id.t -> unit) -> Name.t -> unit -[@@ocaml.deprecated "Same as [Name.iter]"] - -val name_app : (Id.t -> Id.t) -> Name.t -> Name.t -[@@ocaml.deprecated "Same as [Name.map]"] - -val name_fold_map : ('a -> Id.t -> 'a * Id.t) -> 'a -> Name.t -> 'a * Name.t -[@@ocaml.deprecated "Same as [Name.fold_left_map]"] - -val name_max : Name.t -> Name.t -> Name.t -[@@ocaml.deprecated "Same as [Name.pick]"] - -val name_cons : Name.t -> Id.t list -> Id.t list -[@@ocaml.deprecated "Same as [Name.cons]"] - -val pr_name : Name.t -> Pp.t -[@@ocaml.deprecated "Same as [Name.print]"] - -val pr_id : Id.t -> Pp.t -[@@ocaml.deprecated "Same as [Names.Id.print]"] - -val pr_lab : Label.t -> Pp.t -[@@ocaml.deprecated "Same as [Names.Label.print]"] - -(** Deprecated stuff to libnames *) -val default_library : DirPath.t -[@@ocaml.deprecated "Same as [Libnames.default_library]"] - -val coq_root : module_ident (** "Coq" *) -[@@ocaml.deprecated "Same as [Libnames.coq_root]"] - -val coq_string : string (** "Coq" *) -[@@ocaml.deprecated "Same as [Libnames.coq_string]"] - -val default_root_prefix : DirPath.t -[@@ocaml.deprecated "Same as [Libnames.default_root_prefix]"] - diff --git a/engine/proofview.ml b/engine/proofview.ml index 639f48e77..b4afb6415 100644 --- a/engine/proofview.ml +++ b/engine/proofview.ml @@ -39,15 +39,15 @@ let proofview p = let compact el ({ solution } as pv) = let nf c = Evarutil.nf_evar solution c in - let nf0 c = EConstr.Unsafe.to_constr (Evarutil.nf_evar solution (EConstr.of_constr c)) in + let nf0 c = EConstr.(to_constr solution (of_constr c)) in let size = Evd.fold (fun _ _ i -> i+1) solution 0 in let new_el = List.map (fun (t,ty) -> nf t, nf ty) el in let pruned_solution = Evd.drop_all_defined solution in let apply_subst_einfo _ ei = Evd.({ ei with - evar_concl = nf0 ei.evar_concl; + evar_concl = nf ei.evar_concl; evar_hyps = Environ.map_named_val nf0 ei.evar_hyps; - evar_candidates = Option.map (List.map nf0) ei.evar_candidates }) in + evar_candidates = Option.map (List.map nf) ei.evar_candidates }) in let new_solution = Evd.raw_map_undefined apply_subst_einfo pruned_solution in let new_size = Evd.fold (fun _ _ i -> i+1) new_solution 0 in Feedback.msg_info (Pp.str (Printf.sprintf "Evars: %d -> %d\n" size new_size)); @@ -875,8 +875,7 @@ module Progress = struct (** equality function on hypothesis contexts *) let eq_named_context_val sigma1 sigma2 ctx1 ctx2 = - let open Environ in - let c1 = named_context_of_val ctx1 and c2 = named_context_of_val ctx2 in + let c1 = EConstr.named_context_of_val ctx1 and c2 = EConstr.named_context_of_val ctx2 in let eq_named_declaration d1 d2 = match d1, d2 with | LocalAssum (i1,t1), LocalAssum (i2,t2) -> @@ -1086,8 +1085,6 @@ module Goal = struct self : Evar.t ; (* for compatibility with old-style definitions *) } - let assume (gl : t) = (gl : t) - let print { sigma; self } = { Evd.it = self; sigma } let state { state=state } = state @@ -1101,7 +1098,7 @@ module Goal = struct let gmake_with info env sigma goal state = { env = Environ.reset_with_named_context (Evd.evar_filtered_hyps info) env ; sigma = sigma ; - concl = EConstr.of_constr (Evd.evar_concl info); + concl = Evd.evar_concl info; state = state ; self = goal } @@ -1275,11 +1272,6 @@ module V82 = struct - (* Returns the open goals of the proofview together with the evar_map to - interpret them. *) - let goals { comb = comb ; solution = solution; } = - { Evd.it = List.map drop_state comb ; sigma = solution } - let top_goals initial { solution=solution; } = let goals = CList.map (fun (t,_) -> fst (Constr.destEvar (EConstr.Unsafe.to_constr t))) initial in { Evd.it = goals ; sigma=solution; } diff --git a/engine/proofview.mli b/engine/proofview.mli index 1905686fe..970bf6773 100644 --- a/engine/proofview.mli +++ b/engine/proofview.mli @@ -495,10 +495,6 @@ module Goal : sig (** Type of goals. *) type t - (** Assume that you do not need the goal to be normalized. *) - val assume : t -> t - [@@ocaml.deprecated "Normalization is enforced by EConstr, [assume] is not needed anymore"] - (** Normalises the argument goal. *) val normalize : t -> t tactic @@ -589,11 +585,6 @@ module V82 : sig (in chronological order of insertion). *) val grab : proofview -> proofview - (* Returns the open goals of the proofview together with the evar_map to - interpret them. *) - val goals : proofview -> Evar.t list Evd.sigma - [@@ocaml.deprecated "Use [Proofview.proofview]"] - val top_goals : entry -> proofview -> Evar.t list Evd.sigma (* returns the existential variable used to start the proof *) diff --git a/engine/termops.ml b/engine/termops.ml index b7531f6fc..eacc36107 100644 --- a/engine/termops.ml +++ b/engine/termops.ml @@ -47,7 +47,7 @@ let pr_fix pr_constr ((t,i),(lna,tl,bl)) = let pr_puniverses p u = if Univ.Instance.is_empty u then p - else p ++ str"(*" ++ Univ.Instance.pr Universes.pr_with_global_universes u ++ str"*)" + else p ++ str"(*" ++ Univ.Instance.pr UnivNames.pr_with_global_universes u ++ str"*)" let rec pr_constr c = match kind c with | Rel n -> str "#"++int n @@ -98,7 +98,10 @@ let rec pr_constr c = match kind c with let term_printer = ref (fun _env _sigma c -> pr_constr (EConstr.Unsafe.to_constr c)) let print_constr_env env sigma t = !term_printer env sigma t -let print_constr t = !term_printer (Global.env()) Evd.empty t +let print_constr t = + let env = Global.env () in + let evd = Evd.from_env env in + !term_printer env evd t let set_print_constr f = term_printer := f module EvMap = Evar.Map @@ -115,7 +118,7 @@ let pr_evar_suggested_name evk sigma = | _,Evar_kinds.GoalEvar -> Id.of_string "Goal" | _ -> let env = reset_with_named_context evi.evar_hyps (Global.env()) in - Namegen.id_of_name_using_hdchar env sigma (EConstr.of_constr evi.evar_concl) Anonymous + Namegen.id_of_name_using_hdchar env sigma evi.evar_concl Anonymous in let names = EvMap.mapi base_id (undefined_map sigma) in let id = EvMap.find evk names in @@ -154,7 +157,7 @@ let protect f x = with e -> str "EXCEPTION: " ++ str (Printexc.to_string e) let print_kconstr a = - protect (fun c -> print_constr (EConstr.of_constr c)) a + protect (fun c -> print_constr c) a let pr_meta_map evd = let open Evd in @@ -197,11 +200,11 @@ let pr_evar_source = function let print_constr = print_kconstr in let id = Option.get ido in str "parameter " ++ Id.print id ++ spc () ++ str "of" ++ - spc () ++ print_constr (printable_constr_of_global c) + spc () ++ print_constr (EConstr.of_constr @@ printable_constr_of_global c) | Evar_kinds.InternalHole -> str "internal placeholder" | Evar_kinds.TomatchTypeParameter (ind,n) -> let print_constr = print_kconstr in - pr_nth n ++ str " argument of type " ++ print_constr (mkInd ind) + pr_nth n ++ str " argument of type " ++ print_constr (EConstr.mkInd ind) | Evar_kinds.GoalEvar -> str "goal evar" | Evar_kinds.ImpossibleCase -> str "type of impossible pattern-matching clause" | Evar_kinds.MatchingVar _ -> str "matching variable" @@ -256,7 +259,7 @@ let compute_evar_dependency_graph sigma = in match evar_body evi with | Evar_empty -> acc - | Evar_defined c -> Evar.Set.fold fold_ev (evars_of_term c) acc + | Evar_defined c -> Evar.Set.fold fold_ev (evars_of_term (EConstr.Unsafe.to_constr c)) acc in Evd.fold fold sigma EvMap.empty @@ -306,7 +309,7 @@ let pr_evar_universe_context ctx = str"ALGEBRAIC UNIVERSES:"++brk(0,1)++ h 0 (Univ.LSet.pr prl (UState.algebraics ctx)) ++ fnl() ++ str"UNDEFINED UNIVERSES:"++brk(0,1)++ - h 0 (Universes.pr_universe_opt_subst (UState.subst ctx)) ++ fnl() ++ + h 0 (UnivSubst.pr_universe_opt_subst (UState.subst ctx)) ++ fnl() ++ str "WEAK CONSTRAINTS:"++brk(0,1)++ h 0 (UState.pr_weak prl ctx) ++ fnl ()) @@ -314,7 +317,8 @@ let print_env_short env = 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 " := " ++ print_constr b ++ str ")" + | RelDecl.LocalDef (n,b,_) -> str "(" ++ Name.print n ++ str " := " + ++ print_constr (EConstr.of_constr b) ++ str ")" in let pr_named_decl = NamedDecl.to_rel_decl %> pr_rel_decl in let nc = List.rev (named_context env) in @@ -335,11 +339,11 @@ let pr_evar_constraints sigma pbs = Namegen.make_all_name_different env sigma in print_env_short env ++ spc () ++ str "|-" ++ spc () ++ - protect (print_constr_env env sigma) (EConstr.of_constr t1) ++ spc () ++ + protect (print_constr_env env sigma) t1 ++ spc () ++ str (match pbty with | Reduction.CONV -> "==" | Reduction.CUMUL -> "<=") ++ - spc () ++ protect (print_constr_env env Evd.empty) (EConstr.of_constr t2) + spc () ++ protect (print_constr_env env @@ Evd.from_env env) t2 in prlist_with_sep fnl pr_evconstr pbs @@ -433,27 +437,29 @@ let pr_metaset metas = let pr_var_decl env decl = let open NamedDecl in + let evd = Evd.from_env env in let pbody = match decl with | LocalAssum _ -> mt () | LocalDef (_,c,_) -> (* Force evaluation *) let c = EConstr.of_constr c in - let pb = print_constr_env env Evd.empty c in + let pb = print_constr_env env evd c in (str" := " ++ pb ++ cut () ) in - let pt = print_constr_env env Evd.empty (EConstr.of_constr (get_type decl)) in + let pt = print_constr_env env evd (EConstr.of_constr (get_type decl)) in let ptyp = (str" : " ++ pt) in (Id.print (get_id decl) ++ hov 0 (pbody ++ ptyp)) let pr_rel_decl env decl = let open RelDecl in + let evd = Evd.from_env env in let pbody = match decl with | LocalAssum _ -> mt () | LocalDef (_,c,_) -> (* Force evaluation *) let c = EConstr.of_constr c in - let pb = print_constr_env env Evd.empty c in + let pb = print_constr_env env evd c in (str":=" ++ spc () ++ pb ++ spc ()) in - let ptyp = print_constr_env env Evd.empty (EConstr.of_constr (get_type decl)) in + let ptyp = print_constr_env env evd (EConstr.of_constr (get_type decl)) in match get_name decl with | Anonymous -> hov 0 (str"<>" ++ spc () ++ pbody ++ str":" ++ spc () ++ ptyp) | Name id -> hov 0 (Id.print id ++ spc () ++ pbody ++ str":" ++ spc () ++ ptyp) @@ -775,24 +781,23 @@ let map_constr_with_full_binders sigma g f l cstr = let fold_constr_with_full_binders sigma g f n acc c = let open RelDecl in - let inj c = EConstr.Unsafe.to_constr c in match EConstr.kind sigma c with | (Rel _ | Meta _ | Var _ | Sort _ | Const _ | Ind _ | Construct _) -> acc | Cast (c,_, t) -> f n (f n acc c) t - | Prod (na,t,c) -> f (g (LocalAssum (na, inj t)) n) (f n acc t) c - | Lambda (na,t,c) -> f (g (LocalAssum (na, inj t)) n) (f n acc t) c - | LetIn (na,b,t,c) -> f (g (LocalDef (na, inj b, inj t)) n) (f n (f n acc b) t) c + | Prod (na,t,c) -> f (g (LocalAssum (na, t)) n) (f n acc t) c + | Lambda (na,t,c) -> f (g (LocalAssum (na, t)) n) (f n acc t) c + | LetIn (na,b,t,c) -> f (g (LocalDef (na, b, t)) n) (f n (f n acc b) t) c | App (c,l) -> Array.fold_left (f n) (f n acc c) l | Proj (p,c) -> f n acc c | Evar (_,l) -> Array.fold_left (f n) acc l | Case (_,p,c,bl) -> Array.fold_left (f n) (f n (f n acc p) c) bl | Fix (_,(lna,tl,bl)) -> - let n' = CArray.fold_left2 (fun c n t -> g (LocalAssum (n, inj t)) c) n lna tl in + let n' = CArray.fold_left2 (fun c n t -> g (LocalAssum (n, t)) c) n lna tl in let fd = Array.map2 (fun t b -> (t,b)) tl bl in Array.fold_left (fun acc (t,b) -> f n' (f n acc t) b) acc fd | CoFix (_,(lna,tl,bl)) -> - let n' = CArray.fold_left2 (fun c n t -> g (LocalAssum (n, inj t)) c) n lna tl in + let n' = CArray.fold_left2 (fun c n t -> g (LocalAssum (n, t)) c) n lna tl in let fd = Array.map2 (fun t b -> (t,b)) tl bl in Array.fold_left (fun acc (t,b) -> f n' (f n acc t) b) acc fd @@ -851,6 +856,13 @@ let occur_meta_or_existential sigma c = | _ -> EConstr.iter sigma occrec c in try occrec c; false with Occur -> true +let occur_metavariable sigma m c = + let rec occrec c = match EConstr.kind sigma c with + | Meta m' -> if Int.equal m m' then raise Occur + | _ -> EConstr.iter sigma occrec c + in + try occrec c; false with Occur -> true + let occur_evar sigma n c = let rec occur_rec c = match EConstr.kind sigma c with | Evar (sp,_) when Evar.equal sp n -> raise Occur @@ -930,7 +942,7 @@ let dependent_main noevar sigma m t = match EConstr.kind sigma m, EConstr.kind sigma t with | App (fm,lm), App (ft,lt) when Array.length lm < Array.length lt -> deprec m (mkApp (ft,Array.sub lt 0 (Array.length lm))); - CArray.Fun1.iter deprec m + Array.Fun1.iter deprec m (Array.sub lt (Array.length lm) ((Array.length lt) - (Array.length lm))) | _, Cast (c,_,_) when noevar && isMeta sigma c -> () @@ -968,9 +980,6 @@ let count_occurrences sigma m t = countrec m t; !n -(* Synonymous *) -let occur_term = dependent - let pop t = EConstr.Vars.lift (-1) t (***************************) @@ -1373,7 +1382,7 @@ let smash_rel_context sign = let fold_named_context_both_sides f l ~init = List.fold_right_and_left f l init let mem_named_context_val id ctxt = - try ignore(Environ.lookup_named_val id ctxt); true with Not_found -> false + try ignore(Environ.lookup_named_ctxt id ctxt); true with Not_found -> false let map_rel_decl f = function | RelDecl.LocalAssum (id, t) -> RelDecl.LocalAssum (id, f t) diff --git a/engine/termops.mli b/engine/termops.mli index 3b0c4bba6..255494031 100644 --- a/engine/termops.mli +++ b/engine/termops.mli @@ -75,8 +75,9 @@ val fold_constr_with_binders : Evd.evar_map -> ('a -> 'a) -> ('a -> 'b -> constr -> 'b) -> 'a -> 'b -> constr -> 'b val fold_constr_with_full_binders : Evd.evar_map -> - (Context.Rel.Declaration.t -> 'a -> 'a) -> ('a -> 'b -> constr -> 'b) -> - 'a -> 'b -> constr -> 'b + (rel_declaration -> 'a -> 'a) -> + ('a -> 'b -> constr -> 'b) -> + 'a -> 'b -> constr -> 'b val iter_constr_with_full_binders : Evd.evar_map -> (rel_declaration -> 'a -> 'a) -> @@ -94,6 +95,7 @@ exception Occur val occur_meta : Evd.evar_map -> constr -> bool val occur_existential : Evd.evar_map -> constr -> bool val occur_meta_or_existential : Evd.evar_map -> constr -> bool +val occur_metavariable : Evd.evar_map -> metavariable -> constr -> bool val occur_evar : Evd.evar_map -> Evar.t -> constr -> bool val occur_var : env -> Evd.evar_map -> Id.t -> constr -> bool val occur_var_in_decl : @@ -112,9 +114,7 @@ val dependent_in_decl : Evd.evar_map -> constr -> named_declaration -> bool val count_occurrences : Evd.evar_map -> constr -> constr -> int val collect_metas : Evd.evar_map -> constr -> int list val collect_vars : Evd.evar_map -> constr -> Id.Set.t (** for visible vars only *) -val vars_of_global_reference : env -> Globnames.global_reference -> Id.Set.t -val occur_term : Evd.evar_map -> constr -> constr -> bool (** Synonymous of dependent *) -[@@ocaml.deprecated "alias of Termops.dependent"] +val vars_of_global_reference : env -> GlobRef.t -> Id.Set.t (* Substitution of metavariables *) type meta_value_map = (metavariable * Constr.constr) list @@ -261,7 +261,7 @@ val clear_named_body : Id.t -> env -> env val global_vars : env -> Evd.evar_map -> constr -> Id.t list val global_vars_set : env -> Evd.evar_map -> constr -> Id.Set.t val global_vars_set_of_decl : env -> Evd.evar_map -> named_declaration -> Id.Set.t -val global_app_of_constr : Evd.evar_map -> constr -> (Globnames.global_reference * EInstance.t) * constr option +val global_app_of_constr : Evd.evar_map -> constr -> (GlobRef.t * EInstance.t) * constr option (** Gives an ordered list of hypotheses, closed by dependencies, containing a given set *) @@ -270,9 +270,9 @@ val dependency_closure : env -> Evd.evar_map -> named_context -> Id.Set.t -> Id. (** Test if an identifier is the basename of a global reference *) val is_section_variable : Id.t -> bool -val global_of_constr : Evd.evar_map -> constr -> Globnames.global_reference * EInstance.t +val global_of_constr : Evd.evar_map -> constr -> GlobRef.t * EInstance.t -val is_global : Evd.evar_map -> Globnames.global_reference -> constr -> bool +val is_global : Evd.evar_map -> GlobRef.t -> constr -> bool val isGlobalRef : Evd.evar_map -> constr -> bool diff --git a/engine/uState.ml b/engine/uState.ml index 6c8dbe3f4..0e3ecdbf5 100644 --- a/engine/uState.ml +++ b/engine/uState.ml @@ -20,14 +20,14 @@ type uinfo = { uloc : Loc.t option; } -module UPairSet = Universes.UPairSet +module UPairSet = UnivMinim.UPairSet (* 2nd part used to check consistency on the fly. *) type t = - { uctx_names : Universes.universe_binders * uinfo Univ.LMap.t; + { uctx_names : UnivNames.universe_binders * uinfo Univ.LMap.t; uctx_local : Univ.ContextSet.t; (** The local context of variables *) uctx_seff_univs : Univ.LSet.t; (** Local universes used through private constants *) - uctx_univ_variables : Universes.universe_opt_subst; + uctx_univ_variables : UnivSubst.universe_opt_subst; (** The local universes that are unification variables *) uctx_univ_algebraic : Univ.LSet.t; (** The subset of unification variables that can be instantiated with @@ -152,11 +152,12 @@ let drop_weak_constraints = ref false let process_universe_constraints ctx cstrs = let open Univ in - let open Universes in + let open UnivSubst in + let open UnivProblem in let univs = ctx.uctx_universes in let vars = ref ctx.uctx_univ_variables in let weak = ref ctx.uctx_weak_constraints in - let normalize = normalize_univ_variable_opt_subst vars in + let normalize u = normalize_univ_variable_opt_subst !vars u in let nf_constraint = function | ULub (u, v) -> ULub (level_subst_of normalize u, level_subst_of normalize v) | UWeak (u, v) -> UWeak (level_subst_of normalize u, level_subst_of normalize v) @@ -203,7 +204,7 @@ let process_universe_constraints ctx cstrs = in let unify_universes cst local = let cst = nf_constraint cst in - if Constraints.is_trivial cst then local + if UnivProblem.is_trivial cst then local else match cst with | ULe (l, r) -> @@ -241,7 +242,7 @@ let process_universe_constraints ctx cstrs = | UEq (l, r) -> equalize_universes l r local in let local = - Constraints.fold unify_universes cstrs Univ.Constraint.empty + UnivProblem.Set.fold unify_universes cstrs Univ.Constraint.empty in !vars, !weak, local @@ -249,13 +250,14 @@ let add_constraints ctx cstrs = let univs, local = ctx.uctx_local in let cstrs' = Univ.Constraint.fold (fun (l,d,r) acc -> let l = Univ.Universe.make l and r = Univ.Universe.make r in - let cstr' = match d with + let cstr' = let open UnivProblem in + match d with | Univ.Lt -> - Universes.ULe (Univ.Universe.super l, r) - | Univ.Le -> Universes.ULe (l, r) - | Univ.Eq -> Universes.UEq (l, r) - in Universes.Constraints.add cstr' acc) - cstrs Universes.Constraints.empty + ULe (Univ.Universe.super l, r) + | Univ.Le -> ULe (l, r) + | Univ.Eq -> UEq (l, r) + in UnivProblem.Set.add cstr' acc) + cstrs UnivProblem.Set.empty in let vars, weak, local' = process_universe_constraints ctx cstrs' in { ctx with @@ -298,13 +300,25 @@ let reference_of_level uctx = fun l -> try CAst.make @@ Libnames.Ident (Option.get (Univ.LMap.find l map_rev).uname) with Not_found | Option.IsNone -> - Universes.reference_of_level l + UnivNames.reference_of_level l let pr_uctx_level uctx l = Libnames.pr_reference (reference_of_level uctx l) +type ('a, 'b) gen_universe_decl = { + univdecl_instance : 'a; (* Declared universes *) + univdecl_extensible_instance : bool; (* Can new universes be added *) + univdecl_constraints : 'b; (* Declared constraints *) + univdecl_extensible_constraints : bool (* Can new constraints be added *) } + type universe_decl = - (Misctypes.lident list, Univ.Constraint.t) Misctypes.gen_universe_decl + (lident list, Univ.Constraint.t) gen_universe_decl + +let default_univ_decl = + { univdecl_instance = []; + univdecl_extensible_instance = true; + univdecl_constraints = Univ.Constraint.empty; + univdecl_extensible_constraints = true } let error_unbound_universes left uctx = let open Univ in @@ -365,7 +379,6 @@ let check_implication uctx cstrs cstrs' = (str "Universe constraints are not implied by the ones declared.") let check_mono_univ_decl uctx decl = - let open Misctypes in let () = let names = decl.univdecl_instance in let extensible = decl.univdecl_extensible_instance in @@ -378,7 +391,6 @@ let check_mono_univ_decl uctx decl = uctx.uctx_local let check_univ_decl ~poly uctx decl = - let open Misctypes in let ctx = let names = decl.univdecl_instance in let extensible = decl.univdecl_extensible_instance in @@ -471,7 +483,7 @@ let emit_side_effects eff u = let new_univ_variable ?loc rigid name ({ uctx_local = ctx; uctx_univ_variables = uvars; uctx_univ_algebraic = avars} as uctx) = - let u = Universes.new_univ_level () in + let u = UnivGen.new_univ_level () in let ctx' = Univ.ContextSet.add_universe u ctx in let uctx', pred = match rigid with @@ -549,14 +561,33 @@ let is_sort_variable uctx s = | _ -> None let subst_univs_context_with_def def usubst (ctx, cst) = - (Univ.LSet.diff ctx def, Universes.subst_univs_constraints usubst cst) + (Univ.LSet.diff ctx def, UnivSubst.subst_univs_constraints usubst cst) + +let is_trivial_leq (l,d,r) = + Univ.Level.is_prop l && (d == Univ.Le || (d == Univ.Lt && Univ.Level.is_set r)) + +(* Prop < i <-> Set+1 <= i <-> Set < i *) +let translate_cstr (l,d,r as cstr) = + let open Univ in + if Level.equal Level.prop l && d == Univ.Lt && not (Level.equal Level.set r) then + (Level.set, d, r) + else cstr + +let refresh_constraints univs (ctx, cstrs) = + let cstrs', univs' = + Univ.Constraint.fold (fun c (cstrs', univs as acc) -> + let c = translate_cstr c in + if is_trivial_leq c then acc + else (Univ.Constraint.add c cstrs', UGraph.enforce_constraint c univs)) + cstrs (Univ.Constraint.empty, univs) + in ((ctx, cstrs'), univs') let normalize_variables uctx = let normalized_variables, undef, def, subst = - Universes.normalize_univ_variables uctx.uctx_univ_variables + UnivSubst.normalize_univ_variables uctx.uctx_univ_variables in let ctx_local = subst_univs_context_with_def def (Univ.make_subst subst) uctx.uctx_local in - let ctx_local', univs = Universes.refresh_constraints uctx.uctx_initial_universes ctx_local in + let ctx_local', univs = refresh_constraints uctx.uctx_initial_universes ctx_local in subst, { uctx with uctx_local = ctx_local'; uctx_univ_variables = normalized_variables; uctx_universes = univs } @@ -582,7 +613,7 @@ let fix_undefined_variables uctx = uctx_univ_algebraic = algs' } let refresh_undefined_univ_variables uctx = - let subst, ctx' = Universes.fresh_universe_context_set_instance uctx.uctx_local in + let subst, ctx' = UnivGen.fresh_universe_context_set_instance uctx.uctx_local in let subst_fn u = Univ.subst_univs_level_level subst u in let alg = Univ.LSet.fold (fun u acc -> Univ.LSet.add (subst_fn u) acc) uctx.uctx_univ_algebraic Univ.LSet.empty @@ -609,7 +640,7 @@ let refresh_undefined_univ_variables uctx = uctx', subst let minimize uctx = - let open Universes in + let open UnivMinim in let ((vars',algs'), us') = normalize_context_set uctx.uctx_universes uctx.uctx_local uctx.uctx_univ_variables uctx.uctx_univ_algebraic uctx.uctx_weak_constraints @@ -642,6 +673,3 @@ let update_sigma_env uctx env = let pr_weak prl {uctx_weak_constraints=weak} = let open Pp in prlist_with_sep fnl (fun (u,v) -> prl u ++ str " ~ " ++ prl v) (UPairSet.elements weak) - -(** Deprecated *) -let normalize = minimize diff --git a/engine/uState.mli b/engine/uState.mli index 48c38fafc..e7e5b39e0 100644 --- a/engine/uState.mli +++ b/engine/uState.mli @@ -26,7 +26,7 @@ val empty : t val make : UGraph.t -> t -val make_with_initial_binders : UGraph.t -> Misctypes.lident list -> t +val make_with_initial_binders : UGraph.t -> lident list -> t val is_empty : t -> bool @@ -34,9 +34,9 @@ val union : t -> t -> t val of_context_set : Univ.ContextSet.t -> t -val of_binders : Universes.universe_binders -> t +val of_binders : UnivNames.universe_binders -> t -val universe_binders : t -> Universes.universe_binders +val universe_binders : t -> UnivNames.universe_binders (** {5 Projections} *) @@ -44,7 +44,7 @@ val context_set : t -> Univ.ContextSet.t (** The local context of the state, i.e. a set of bound variables together with their associated constraints. *) -val subst : t -> Universes.universe_opt_subst +val subst : t -> UnivSubst.universe_opt_subst (** The local universes that are unification variables *) val ugraph : t -> UGraph.t @@ -79,7 +79,7 @@ val add_constraints : t -> Univ.Constraint.t -> t @raise UniversesDiffer when universes differ *) -val add_universe_constraints : t -> Universes.Constraints.t -> t +val add_universe_constraints : t -> UnivProblem.Set.t -> t (** @raise UniversesDiffer when universes differ *) @@ -104,7 +104,7 @@ val univ_flexible : rigid val univ_flexible_alg : rigid val merge : ?loc:Loc.t -> bool -> rigid -> t -> Univ.ContextSet.t -> t -val merge_subst : t -> Universes.universe_opt_subst -> t +val merge_subst : t -> UnivSubst.universe_opt_subst -> t val emit_side_effects : Safe_typing.private_constants -> t -> t val new_univ_variable : ?loc:Loc.t -> rigid -> Id.t option -> t -> t * Univ.Level.t @@ -137,11 +137,17 @@ val refresh_undefined_univ_variables : t -> t * Univ.universe_level_subst (** Universe minimization *) val minimize : t -> t -val normalize : t -> t -[@@ocaml.deprecated "Alias of UState.minimize"] + +type ('a, 'b) gen_universe_decl = { + univdecl_instance : 'a; (* Declared universes *) + univdecl_extensible_instance : bool; (* Can new universes be added *) + univdecl_constraints : 'b; (* Declared constraints *) + univdecl_extensible_constraints : bool (* Can new constraints be added *) } type universe_decl = - (Misctypes.lident list, Univ.Constraint.t) Misctypes.gen_universe_decl + (lident list, Univ.Constraint.t) gen_universe_decl + +val default_univ_decl : universe_decl (** [check_univ_decl ctx decl] diff --git a/engine/univGen.ml b/engine/univGen.ml new file mode 100644 index 000000000..796a1bcc1 --- /dev/null +++ b/engine/univGen.ml @@ -0,0 +1,246 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +open Sorts +open Names +open Constr +open Environ +open Univ + +(* Generator of levels *) +type universe_id = DirPath.t * int + +let new_univ_id, set_remote_new_univ_id = + RemoteCounter.new_counter ~name:"Universes" 0 ~incr:((+) 1) + ~build:(fun n -> Global.current_dirpath (), n) + +let new_univ_level () = + let dp, id = new_univ_id () in + Univ.Level.make dp id + +let fresh_level () = new_univ_level () + +(* TODO: remove *) +let new_univ dp = Univ.Universe.make (new_univ_level dp) +let new_Type dp = mkType (new_univ dp) +let new_Type_sort dp = Type (new_univ dp) + +let fresh_universe_instance ctx = + let init _ = new_univ_level () in + Instance.of_array (Array.init (AUContext.size ctx) init) + +let fresh_instance_from_context ctx = + let inst = fresh_universe_instance ctx in + let constraints = AUContext.instantiate inst ctx in + inst, constraints + +let fresh_instance ctx = + let ctx' = ref LSet.empty in + let init _ = + let u = new_univ_level () in + ctx' := LSet.add u !ctx'; u + in + let inst = Instance.of_array (Array.init (AUContext.size ctx) init) + in !ctx', inst + +let existing_instance ctx inst = + let () = + let len1 = Array.length (Instance.to_array inst) + and len2 = AUContext.size ctx in + if not (len1 == len2) then + CErrors.user_err ~hdr:"Universes" + Pp.(str "Polymorphic constant expected " ++ int len2 ++ + str" levels but was given " ++ int len1) + else () + in LSet.empty, inst + +let fresh_instance_from ctx inst = + let ctx', inst = + match inst with + | Some inst -> existing_instance ctx inst + | None -> fresh_instance ctx + in + let constraints = AUContext.instantiate inst ctx in + inst, (ctx', constraints) + +(** Fresh universe polymorphic construction *) + +let fresh_constant_instance env c inst = + let cb = lookup_constant c env in + match cb.Declarations.const_universes with + | Declarations.Monomorphic_const _ -> ((c,Instance.empty), ContextSet.empty) + | Declarations.Polymorphic_const auctx -> + let inst, ctx = + fresh_instance_from auctx inst + in + ((c, inst), ctx) + +let fresh_inductive_instance env ind inst = + let mib, mip = Inductive.lookup_mind_specif env ind in + match mib.Declarations.mind_universes with + | Declarations.Monomorphic_ind _ -> + ((ind,Instance.empty), ContextSet.empty) + | Declarations.Polymorphic_ind uactx -> + let inst, ctx = (fresh_instance_from uactx) inst in + ((ind,inst), ctx) + | Declarations.Cumulative_ind acumi -> + let inst, ctx = + fresh_instance_from (Univ.ACumulativityInfo.univ_context acumi) inst + in ((ind,inst), ctx) + +let fresh_constructor_instance env (ind,i) inst = + let mib, mip = Inductive.lookup_mind_specif env ind in + match mib.Declarations.mind_universes with + | Declarations.Monomorphic_ind _ -> (((ind,i),Instance.empty), ContextSet.empty) + | Declarations.Polymorphic_ind auctx -> + let inst, ctx = fresh_instance_from auctx inst in + (((ind,i),inst), ctx) + | Declarations.Cumulative_ind acumi -> + let inst, ctx = fresh_instance_from (ACumulativityInfo.univ_context acumi) inst in + (((ind,i),inst), ctx) + +open Globnames + +let fresh_global_instance ?names env gr = + match gr with + | VarRef id -> mkVar id, ContextSet.empty + | ConstRef sp -> + let c, ctx = fresh_constant_instance env sp names in + mkConstU c, ctx + | ConstructRef sp -> + let c, ctx = fresh_constructor_instance env sp names in + mkConstructU c, ctx + | IndRef sp -> + let c, ctx = fresh_inductive_instance env sp names in + mkIndU c, ctx + +let fresh_constant_instance env sp = + fresh_constant_instance env sp None + +let fresh_inductive_instance env sp = + fresh_inductive_instance env sp None + +let fresh_constructor_instance env sp = + fresh_constructor_instance env sp None + +let constr_of_global gr = + let c, ctx = fresh_global_instance (Global.env ()) gr in + if not (Univ.ContextSet.is_empty ctx) then + if Univ.LSet.is_empty (Univ.ContextSet.levels ctx) then + (* Should be an error as we might forget constraints, allow for now + to make firstorder work with "using" clauses *) + c + else CErrors.user_err ~hdr:"constr_of_global" + Pp.(str "globalization of polymorphic reference " ++ Nametab.pr_global_env Id.Set.empty gr ++ + str " would forget universes.") + else c + +let constr_of_global_univ (gr,u) = + match gr with + | VarRef id -> mkVar id + | ConstRef sp -> mkConstU (sp,u) + | ConstructRef sp -> mkConstructU (sp,u) + | IndRef sp -> mkIndU (sp,u) + +let fresh_global_or_constr_instance env = function + | IsConstr c -> c, ContextSet.empty + | IsGlobal gr -> fresh_global_instance env gr + +let global_of_constr c = + match kind c with + | Const (c, u) -> ConstRef c, u + | Ind (i, u) -> IndRef i, u + | Construct (c, u) -> ConstructRef c, u + | Var id -> VarRef id, Instance.empty + | _ -> raise Not_found + +open Declarations + +let type_of_reference env r = + match r with + | VarRef id -> Environ.named_type id env, ContextSet.empty + | ConstRef c -> + let cb = Environ.lookup_constant c env in + let ty = cb.const_type in + begin + match cb.const_universes with + | Monomorphic_const _ -> ty, ContextSet.empty + | Polymorphic_const auctx -> + let inst, ctx = fresh_instance_from auctx None in + Vars.subst_instance_constr inst ty, ctx + end + | IndRef ind -> + let (mib, oib as specif) = Inductive.lookup_mind_specif env ind in + begin + match mib.mind_universes with + | Monomorphic_ind _ -> + let ty = Inductive.type_of_inductive env (specif, Univ.Instance.empty) in + ty, ContextSet.empty + | Polymorphic_ind auctx -> + let inst, ctx = fresh_instance_from auctx None in + let ty = Inductive.type_of_inductive env (specif, inst) in + ty, ctx + | Cumulative_ind cumi -> + let inst, ctx = + fresh_instance_from (ACumulativityInfo.univ_context cumi) None + in + let ty = Inductive.type_of_inductive env (specif, inst) in + ty, ctx + end + + | ConstructRef cstr -> + let (mib,oib as specif) = + Inductive.lookup_mind_specif env (inductive_of_constructor cstr) + in + begin + match mib.mind_universes with + | Monomorphic_ind _ -> + Inductive.type_of_constructor (cstr,Instance.empty) specif, ContextSet.empty + | Polymorphic_ind auctx -> + let inst, ctx = fresh_instance_from auctx None in + Inductive.type_of_constructor (cstr,inst) specif, ctx + | Cumulative_ind cumi -> + let inst, ctx = + fresh_instance_from (ACumulativityInfo.univ_context cumi) None + in + Inductive.type_of_constructor (cstr,inst) specif, ctx + end + +let type_of_global t = type_of_reference (Global.env ()) t + +let fresh_sort_in_family env = function + | InProp -> Sorts.prop, ContextSet.empty + | InSet -> Sorts.set, ContextSet.empty + | InType -> + let u = fresh_level () in + Type (Univ.Universe.make u), ContextSet.singleton u + +let new_sort_in_family sf = + fst (fresh_sort_in_family (Global.env ()) sf) + +let extend_context (a, ctx) (ctx') = + (a, ContextSet.union ctx ctx') + +let new_global_univ () = + let u = fresh_level () in + (Univ.Universe.make u, ContextSet.singleton u) + +let fresh_universe_context_set_instance ctx = + if ContextSet.is_empty ctx then LMap.empty, ctx + else + let (univs, cst) = ContextSet.levels ctx, ContextSet.constraints ctx in + let univs',subst = LSet.fold + (fun u (univs',subst) -> + let u' = fresh_level () in + (LSet.add u' univs', LMap.add u u' subst)) + univs (LSet.empty, LMap.empty) + in + let cst' = subst_univs_level_constraints subst cst in + subst, (univs', cst') diff --git a/engine/univGen.mli b/engine/univGen.mli new file mode 100644 index 000000000..8169dbda4 --- /dev/null +++ b/engine/univGen.mli @@ -0,0 +1,80 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +open Names +open Constr +open Environ +open Univ + + +(** The global universe counter *) +type universe_id = DirPath.t * int + +val set_remote_new_univ_id : universe_id RemoteCounter.installer + +(** Side-effecting functions creating new universe levels. *) + +val new_univ_id : unit -> universe_id +val new_univ_level : unit -> Level.t +val new_univ : unit -> Universe.t +val new_Type : unit -> types +val new_Type_sort : unit -> Sorts.t + +val new_global_univ : unit -> Universe.t in_universe_context_set +val new_sort_in_family : Sorts.family -> Sorts.t + +(** Build a fresh instance for a given context, its associated substitution and + the instantiated constraints. *) + +val fresh_instance_from_context : AUContext.t -> + Instance.t constrained + +val fresh_instance_from : AUContext.t -> Instance.t option -> + Instance.t in_universe_context_set + +val fresh_sort_in_family : env -> Sorts.family -> + Sorts.t in_universe_context_set +val fresh_constant_instance : env -> Constant.t -> + pconstant in_universe_context_set +val fresh_inductive_instance : env -> inductive -> + pinductive in_universe_context_set +val fresh_constructor_instance : env -> constructor -> + pconstructor in_universe_context_set + +val fresh_global_instance : ?names:Univ.Instance.t -> env -> GlobRef.t -> + constr in_universe_context_set + +val fresh_global_or_constr_instance : env -> Globnames.global_reference_or_constr -> + constr in_universe_context_set + +(** Get fresh variables for the universe context. + Useful to make tactics that manipulate constrs in universe contexts polymorphic. *) +val fresh_universe_context_set_instance : ContextSet.t -> + universe_level_subst * ContextSet.t + +(** Raises [Not_found] if not a global reference. *) +val global_of_constr : constr -> GlobRef.t puniverses + +val constr_of_global_univ : GlobRef.t puniverses -> constr + +val extend_context : 'a in_universe_context_set -> ContextSet.t -> + 'a in_universe_context_set + +(** Create a fresh global in the global environment, without side effects. + BEWARE: this raises an ANOMALY on polymorphic constants/inductives: + the constraints should be properly added to an evd. + See Evd.fresh_global, Evarutil.new_global, and pf_constr_of_global for + the proper way to get a fresh copy of a global reference. *) +val constr_of_global : GlobRef.t -> constr + +(** Returns the type of the global reference, by creating a fresh instance of polymorphic + references and computing their instantiated universe context. (side-effect on the + universe counter, use with care). *) +val type_of_global : GlobRef.t -> types in_universe_context_set diff --git a/engine/univMinim.ml b/engine/univMinim.ml new file mode 100644 index 000000000..f10e6d2ec --- /dev/null +++ b/engine/univMinim.ml @@ -0,0 +1,383 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +open Univ +open UnivSubst + +(* To disallow minimization to Set *) +let set_minimization = ref true +let is_set_minimization () = !set_minimization + +let _ = + Goptions.(declare_bool_option + { optdepr = false; + optname = "minimization to Set"; + optkey = ["Universe";"Minimization";"ToSet"]; + optread = is_set_minimization; + optwrite = (:=) set_minimization }) + + +(** Simplification *) + +let add_list_map u t map = + try + let l = LMap.find u map in + LMap.set u (t :: l) map + with Not_found -> + LMap.add u [t] map + +(** Precondition: flexible <= ctx *) +let choose_canonical ctx flexible algs s = + let global = LSet.diff s ctx in + let flexible, rigid = LSet.partition flexible (LSet.inter s ctx) in + (** If there is a global universe in the set, choose it *) + if not (LSet.is_empty global) then + let canon = LSet.choose global in + canon, (LSet.remove canon global, rigid, flexible) + else (** No global in the equivalence class, choose a rigid one *) + if not (LSet.is_empty rigid) then + let canon = LSet.choose rigid in + canon, (global, LSet.remove canon rigid, flexible) + else (** There are only flexible universes in the equivalence + class, choose a non-algebraic. *) + let algs, nonalgs = LSet.partition (fun x -> LSet.mem x algs) flexible in + if not (LSet.is_empty nonalgs) then + let canon = LSet.choose nonalgs in + canon, (global, rigid, LSet.remove canon flexible) + else + let canon = LSet.choose algs in + canon, (global, rigid, LSet.remove canon flexible) + +(* Eq < Le < Lt *) +let compare_constraint_type d d' = + match d, d' with + | Eq, Eq -> 0 + | Eq, _ -> -1 + | _, Eq -> 1 + | Le, Le -> 0 + | Le, _ -> -1 + | _, Le -> 1 + | Lt, Lt -> 0 + +type lowermap = constraint_type LMap.t + +let lower_union = + let merge k a b = + match a, b with + | Some _, None -> a + | None, Some _ -> b + | None, None -> None + | Some l, Some r -> + if compare_constraint_type l r >= 0 then a + else b + in LMap.merge merge + +let lower_add l c m = + try let c' = LMap.find l m in + if compare_constraint_type c c' > 0 then + LMap.add l c m + else m + with Not_found -> LMap.add l c m + +let lower_of_list l = + List.fold_left (fun acc (d,l) -> LMap.add l d acc) LMap.empty l + +type lbound = { enforce : bool; alg : bool; lbound: Universe.t; lower : lowermap } + +exception Found of Level.t * lowermap +let find_inst insts v = + try LMap.iter (fun k {enforce;alg;lbound=v';lower} -> + if not alg && enforce && Universe.equal v' v then raise (Found (k, lower))) + insts; raise Not_found + with Found (f,l) -> (f,l) + +let compute_lbound left = + (** The universe variable was not fixed yet. + Compute its level using its lower bound. *) + let sup l lbound = + match lbound with + | None -> Some l + | Some l' -> Some (Universe.sup l l') + in + List.fold_left (fun lbound (d, l) -> + if d == Le (* l <= ?u *) then sup l lbound + else (* l < ?u *) + (assert (d == Lt); + if not (Universe.level l == None) then + sup (Universe.super l) lbound + else None)) + None left + +let instantiate_with_lbound u lbound lower ~alg ~enforce (ctx, us, algs, insts, cstrs) = + if enforce then + let inst = Universe.make u in + let cstrs' = enforce_leq lbound inst cstrs in + (ctx, us, LSet.remove u algs, + LMap.add u {enforce;alg;lbound;lower} insts, cstrs'), + {enforce; alg; lbound=inst; lower} + else (* Actually instantiate *) + (Univ.LSet.remove u ctx, Univ.LMap.add u (Some lbound) us, algs, + LMap.add u {enforce;alg;lbound;lower} insts, cstrs), + {enforce; alg; lbound; lower} + +type constraints_map = (Univ.constraint_type * Univ.LMap.key) list Univ.LMap.t + +let _pr_constraints_map (cmap:constraints_map) = + let open Pp in + LMap.fold (fun l cstrs acc -> + Level.pr l ++ str " => " ++ + prlist_with_sep spc (fun (d,r) -> pr_constraint_type d ++ Level.pr r) cstrs ++ + fnl () ++ acc) + cmap (mt ()) + +let remove_alg l (ctx, us, algs, insts, cstrs) = + (ctx, us, LSet.remove l algs, insts, cstrs) + +let not_lower lower (d,l) = + (* We're checking if (d,l) is already implied by the lower + constraints on some level u. If it represents l < u (d is Lt + or d is Le and i > 0, the i < 0 case is impossible due to + invariants of Univ), and the lower constraints only have l <= + u then it is not implied. *) + Univ.Universe.exists + (fun (l,i) -> + let d = + if i == 0 then d + else match d with + | Le -> Lt + | d -> d + in + try let d' = LMap.find l lower in + (* If d is stronger than the already implied lower + * constraints we must keep it. *) + compare_constraint_type d d' > 0 + with Not_found -> + (** No constraint existing on l *) true) l + +exception UpperBoundedAlg +(** [enforce_uppers upper lbound cstrs] interprets [upper] as upper + constraints to [lbound], adding them to [cstrs]. + + @raise UpperBoundedAlg if any [upper] constraints are strict and + [lbound] algebraic. *) +let enforce_uppers upper lbound cstrs = + List.fold_left (fun cstrs (d, r) -> + if d == Univ.Le then + enforce_leq lbound (Universe.make r) cstrs + else + match Universe.level lbound with + | Some lev -> Constraint.add (lev, d, r) cstrs + | None -> raise UpperBoundedAlg) + cstrs upper + +let minimize_univ_variables ctx us algs left right cstrs = + let left, lbounds = + Univ.LMap.fold (fun r lower (left, lbounds as acc) -> + if Univ.LMap.mem r us || not (Univ.LSet.mem r ctx) then acc + else (* Fixed universe, just compute its glb for sharing *) + let lbounds = + match compute_lbound (List.map (fun (d,l) -> d, Universe.make l) lower) with + | None -> lbounds + | Some lbound -> LMap.add r {enforce=true; alg=false; lbound; lower=lower_of_list lower} + lbounds + in (Univ.LMap.remove r left, lbounds)) + left (left, Univ.LMap.empty) + in + let rec instance (ctx, us, algs, insts, cstrs as acc) u = + let acc, left, lower = + match LMap.find u left with + | exception Not_found -> acc, [], LMap.empty + | l -> + let acc, left, newlow, lower = + List.fold_left + (fun (acc, left, newlow, lower') (d, l) -> + let acc', {enforce=enf;alg;lbound=l';lower} = aux acc l in + let l' = + if enf then Universe.make l + else l' + in acc', (d, l') :: left, + lower_add l d newlow, lower_union lower lower') + (acc, [], LMap.empty, LMap.empty) l + in + let left = CList.uniquize (List.filter (not_lower lower) left) in + (acc, left, LMap.union newlow lower) + in + let instantiate_lbound lbound = + let alg = LSet.mem u algs in + if alg then + (* u is algebraic: we instantiate it with its lower bound, if any, + or enforce the constraints if it is bounded from the top. *) + let lower = LSet.fold LMap.remove (Universe.levels lbound) lower in + instantiate_with_lbound u lbound lower ~alg:true ~enforce:false acc + else (* u is non algebraic *) + match Universe.level lbound with + | Some l -> (* The lowerbound is directly a level *) + (* u is not algebraic but has no upper bounds, + we instantiate it with its lower bound if it is a + different level, otherwise we keep it. *) + let lower = LMap.remove l lower in + if not (Level.equal l u) then + (* Should check that u does not + have upper constraints that are not already in right *) + let acc = remove_alg l acc in + instantiate_with_lbound u lbound lower ~alg:false ~enforce:false acc + else acc, {enforce=true; alg=false; lbound; lower} + | None -> + begin match find_inst insts lbound with + | can, lower -> + (* Another universe represents the same lower bound, + we can share them with no harm. *) + let lower = LMap.remove can lower in + instantiate_with_lbound u (Universe.make can) lower ~alg:false ~enforce:false acc + | exception Not_found -> + (* We set u as the canonical universe representing lbound *) + instantiate_with_lbound u lbound lower ~alg:false ~enforce:true acc + end + in + let enforce_uppers ((ctx,us,algs,insts,cstrs), b as acc) = + match LMap.find u right with + | exception Not_found -> acc + | upper -> + let upper = List.filter (fun (d, r) -> not (LMap.mem r us)) upper in + let cstrs = enforce_uppers upper b.lbound cstrs in + (ctx, us, algs, insts, cstrs), b + in + if not (LSet.mem u ctx) + then enforce_uppers (acc, {enforce=true; alg=false; lbound=Universe.make u; lower}) + else + let lbound = compute_lbound left in + match lbound with + | None -> (* Nothing to do *) + enforce_uppers (acc, {enforce=true;alg=false;lbound=Universe.make u; lower}) + | Some lbound -> + try enforce_uppers (instantiate_lbound lbound) + with UpperBoundedAlg -> + enforce_uppers (acc, {enforce=true; alg=false; lbound=Universe.make u; lower}) + and aux (ctx, us, algs, seen, cstrs as acc) u = + try acc, LMap.find u seen + with Not_found -> instance acc u + in + LMap.fold (fun u v (ctx, us, algs, seen, cstrs as acc) -> + if v == None then fst (aux acc u) + else LSet.remove u ctx, us, LSet.remove u algs, seen, cstrs) + us (ctx, us, algs, lbounds, cstrs) + +module UPairs = OrderedType.UnorderedPair(Univ.Level) +module UPairSet = Set.Make (UPairs) + +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 *) + let smallles, csts = + Constraint.partition (fun (l,d,r) -> d == Le && Level.is_small l) csts + in + let smallles = if is_set_minimization () + then Constraint.filter (fun (l,d,r) -> LSet.mem r ctx) smallles + else Constraint.empty + in + let csts, partition = + (* We first put constraints in a normal-form: all self-loops are collapsed + to equalities. *) + let g = LSet.fold (fun v g -> UGraph.add_universe v false g) + ctx UGraph.initial_universes + in + let add_soft u g = + if not (Level.is_small u || LSet.mem u ctx) + then try UGraph.add_universe u false g with UGraph.AlreadyDeclared -> g + else g + in + let g = Constraint.fold + (fun (l, d, r) g -> add_soft r (add_soft l g)) + csts g + in + let g = UGraph.merge_constraints csts g in + UGraph.constraints_of_universes g + in + (* We ignore the trivial Prop/Set <= i constraints. *) + let noneqs = + Constraint.filter + (fun (l,d,r) -> not ((d == Le && Level.is_small l) || + (Level.is_prop l && d == Lt && Level.is_set r))) + csts + in + let noneqs = Constraint.union noneqs smallles in + let flex x = LMap.mem x us in + let ctx, us, eqs = List.fold_left (fun (ctx, us, cstrs) s -> + let canon, (global, rigid, flexible) = choose_canonical ctx flex algs s in + (* Add equalities for globals which can't be merged anymore. *) + let cstrs = LSet.fold (fun g cst -> + Constraint.add (canon, Eq, g) cst) global + cstrs + in + (* Also add equalities for rigid variables *) + let cstrs = LSet.fold (fun g cst -> + Constraint.add (canon, Eq, g) cst) rigid + cstrs + in + let canonu = Some (Universe.make canon) in + let us = LSet.fold (fun f -> LMap.add f canonu) flexible us in + (LSet.diff ctx flexible, us, cstrs)) + (ctx, us, Constraint.empty) partition + in + (* Process weak constraints: when one side is flexible and the 2 + universes are unrelated unify them. *) + let ctx, us, g = UPairSet.fold (fun (u,v) (ctx, us, g as acc) -> + let norm = level_subst_of (normalize_univ_variable_opt_subst us) in + let u = norm u and v = norm v in + let set_to a b = + (LSet.remove a ctx, + LMap.add a (Some (Universe.make b)) us, + UGraph.enforce_constraint (a,Eq,b) g) + in + if UGraph.check_constraint g (u,Le,v) || UGraph.check_constraint g (v,Le,u) + then acc + else + if LMap.mem u us + then set_to u v + else if LMap.mem v us + then set_to v u + else acc) + weak (ctx, us, g) in + (* Noneqs is now in canonical form w.r.t. equality constraints, + and contains only inequality constraints. *) + let noneqs = + let norm = level_subst_of (normalize_univ_variable_opt_subst us) in + Constraint.fold (fun (u,d,v) noneqs -> + let u = norm u and v = norm v in + if d != Lt && Level.equal u v then noneqs + else Constraint.add (u,d,v) noneqs) + noneqs Constraint.empty + in + (* Compute the left and right set of flexible variables, constraints + mentionning other variables remain in noneqs. *) + let noneqs, ucstrsl, ucstrsr = + Constraint.fold (fun (l,d,r as cstr) (noneq, ucstrsl, ucstrsr) -> + let lus = LMap.mem l us and rus = LMap.mem r us in + let ucstrsl' = + if lus then add_list_map l (d, r) ucstrsl + else ucstrsl + and ucstrsr' = + add_list_map r (d, l) ucstrsr + in + let noneqs = + if lus || rus then noneq + else Constraint.add cstr noneq + in (noneqs, ucstrsl', ucstrsr')) + noneqs (Constraint.empty, LMap.empty, LMap.empty) + in + (* Now we construct the instantiation of each variable. *) + let ctx', us, algs, inst, noneqs = + minimize_univ_variables ctx us algs ucstrsr ucstrsl noneqs + in + let us = normalize_opt_subst us in + (us, algs), (ctx', Constraint.union noneqs eqs) + +(* let normalize_conkey = CProfile.declare_profile "normalize_context_set" *) +(* let normalize_context_set a b c = CProfile.profile3 normalize_conkey normalize_context_set a b c *) diff --git a/engine/univMinim.mli b/engine/univMinim.mli new file mode 100644 index 000000000..9f80b7acb --- /dev/null +++ b/engine/univMinim.mli @@ -0,0 +1,32 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +open Univ +open UnivSubst + +(** Unordered pairs of universe levels (ie (u,v) = (v,u)) *) +module UPairSet : CSet.S with type elt = (Level.t * Level.t) + +(** Simplification and pruning of constraints: + [normalize_context_set ctx us] + + - Instantiate the variables in [us] with their most precise + universe levels respecting the constraints. + + - Normalizes the context [ctx] w.r.t. equality constraints, + choosing a canonical universe in each equivalence class + (a global one if there is one) and transitively saturate + the constraints w.r.t to the equalities. *) + +val normalize_context_set : UGraph.t -> ContextSet.t -> + universe_opt_subst (* The defined and undefined variables *) -> + LSet.t (* univ variables that can be substituted by algebraics *) -> + UPairSet.t (* weak equality constraints *) -> + (universe_opt_subst * LSet.t) in_universe_context_set diff --git a/engine/univNames.ml b/engine/univNames.ml new file mode 100644 index 000000000..6ffb4bcf0 --- /dev/null +++ b/engine/univNames.ml @@ -0,0 +1,105 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +open Names +open Univ +open Globnames +open Nametab + + +let reference_of_level l = CAst.make @@ + match Level.name l with + | Some (d, n as na) -> + let qid = + try Nametab.shortest_qualid_of_universe na + with Not_found -> + let name = Id.of_string_soft (string_of_int n) in + Libnames.make_qualid d name + in Libnames.Qualid qid + | None -> Libnames.Ident Id.(of_string_soft (Level.to_string l)) + +let pr_with_global_universes l = Libnames.pr_reference (reference_of_level l) + +(** Global universe information outside the kernel, to handle + polymorphic universe names in sections that have to be discharged. *) + +let universe_map = (Summary.ref UnivIdMap.empty ~name:"global universe info" : bool Nametab.UnivIdMap.t ref) + +let add_global_universe u p = + match Level.name u with + | Some n -> universe_map := Nametab.UnivIdMap.add n p !universe_map + | None -> () + +let is_polymorphic l = + match Level.name l with + | Some n -> + (try Nametab.UnivIdMap.find n !universe_map + with Not_found -> false) + | None -> false + +(** Local universe names of polymorphic references *) + +type universe_binders = Univ.Level.t Names.Id.Map.t + +let empty_binders = Id.Map.empty + +let universe_binders_table = Summary.ref Refmap.empty ~name:"universe binders" + +let universe_binders_of_global ref : universe_binders = + try + let l = Refmap.find ref !universe_binders_table in l + with Not_found -> Names.Id.Map.empty + +let cache_ubinder (_,(ref,l)) = + universe_binders_table := Refmap.add ref l !universe_binders_table + +let subst_ubinder (subst,(ref,l as orig)) = + let ref' = fst (Globnames.subst_global subst ref) in + if ref == ref' then orig else ref', l + +let discharge_ubinder (_,(ref,l)) = + Some (Lib.discharge_global ref, l) + +let ubinder_obj : GlobRef.t * universe_binders -> Libobject.obj = + let open Libobject in + declare_object { (default_object "universe binder") with + cache_function = cache_ubinder; + load_function = (fun _ x -> cache_ubinder x); + classify_function = (fun x -> Substitute x); + subst_function = subst_ubinder; + discharge_function = discharge_ubinder; + rebuild_function = (fun x -> x); } + +let register_universe_binders ref ubinders = + (* Add the polymorphic (section) universes *) + let ubinders = UnivIdMap.fold (fun lvl poly ubinders -> + let qid = Nametab.shortest_qualid_of_universe lvl in + let level = Level.make (fst lvl) (snd lvl) in + if poly then Id.Map.add (snd (Libnames.repr_qualid qid)) level ubinders + else ubinders) + !universe_map ubinders + in + if not (Id.Map.is_empty ubinders) + then Lib.add_anonymous_leaf (ubinder_obj (ref,ubinders)) + +type univ_name_list = Names.lname list + +let universe_binders_with_opt_names ref levels = function + | None -> universe_binders_of_global ref + | Some udecl -> + if Int.equal(List.length levels) (List.length udecl) + then + List.fold_left2 (fun acc { CAst.v = na} lvl -> match na with + | Anonymous -> acc + | Name na -> Names.Id.Map.add na lvl acc) + empty_binders udecl levels + else + CErrors.user_err ~hdr:"universe_binders_with_opt_names" + Pp.(str "Universe instance should have length " ++ int (List.length levels)) diff --git a/engine/univNames.mli b/engine/univNames.mli new file mode 100644 index 000000000..c19aa19d5 --- /dev/null +++ b/engine/univNames.mli @@ -0,0 +1,41 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +open Univ + +val pr_with_global_universes : Level.t -> Pp.t +val reference_of_level : Level.t -> Libnames.reference + +(** Global universe information outside the kernel, to handle + polymorphic universes in sections that have to be discharged. *) +val add_global_universe : Level.t -> Decl_kinds.polymorphic -> unit + +(** Is [lvl] a global polymorphic universe? (ie section polymorphic universe) *) +val is_polymorphic : Level.t -> bool + +(** Local universe name <-> level mapping *) + +type universe_binders = Univ.Level.t Names.Id.Map.t + +val empty_binders : universe_binders + +val register_universe_binders : Names.GlobRef.t -> universe_binders -> unit +val universe_binders_of_global : Names.GlobRef.t -> universe_binders + +type univ_name_list = Names.lname list + +(** [universe_binders_with_opt_names ref u l] + + If [l] is [Some univs] return the universe binders naming the levels of [u] by [univs] (skipping Anonymous). + May error if the lengths mismatch. + + Otherwise return [universe_binders_of_global ref]. *) +val universe_binders_with_opt_names : Names.GlobRef.t -> + Univ.Level.t list -> univ_name_list option -> universe_binders diff --git a/engine/univProblem.ml b/engine/univProblem.ml new file mode 100644 index 000000000..bc2edc13d --- /dev/null +++ b/engine/univProblem.ml @@ -0,0 +1,166 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +open Univ +open UnivSubst + +type t = + | ULe of Universe.t * Universe.t + | UEq of Universe.t * Universe.t + | ULub of Level.t * Level.t + | UWeak of Level.t * Level.t + + +let is_trivial = function + | ULe (u, v) | UEq (u, v) -> Universe.equal u v + | ULub (u, v) | UWeak (u, v) -> Level.equal u v + +let subst_univs fn = function + | ULe (u, v) -> + let u' = subst_univs_universe fn u and v' = subst_univs_universe fn v in + if Universe.equal u' v' then None + else Some (ULe (u',v')) + | UEq (u, v) -> + let u' = subst_univs_universe fn u and v' = subst_univs_universe fn v in + if Universe.equal u' v' then None + else Some (ULe (u',v')) + | ULub (u, v) -> + let u' = level_subst_of fn u and v' = level_subst_of fn v in + if Level.equal u' v' then None + else Some (ULub (u',v')) + | UWeak (u, v) -> + let u' = level_subst_of fn u and v' = level_subst_of fn v in + if Level.equal u' v' then None + else Some (UWeak (u',v')) + +module Set = struct + module S = Set.Make( + struct + type nonrec t = t + + let compare x y = + match x, y with + | ULe (u, v), ULe (u', v') -> + let i = Universe.compare u u' in + if Int.equal i 0 then Universe.compare v v' + else i + | UEq (u, v), UEq (u', v') -> + let i = Universe.compare u u' in + if Int.equal i 0 then Universe.compare v v' + else if Universe.equal u v' && Universe.equal v u' then 0 + else i + | ULub (u, v), ULub (u', v') | UWeak (u, v), UWeak (u', v') -> + let i = Level.compare u u' in + if Int.equal i 0 then Level.compare v v' + else if Level.equal u v' && Level.equal v u' then 0 + else i + | ULe _, _ -> -1 + | _, ULe _ -> 1 + | UEq _, _ -> -1 + | _, UEq _ -> 1 + | ULub _, _ -> -1 + | _, ULub _ -> 1 + end) + + include S + + let add cst s = + if is_trivial cst then s + else add cst s + + let pr_one = let open Pp in function + | ULe (u, v) -> Universe.pr u ++ str " <= " ++ Universe.pr v + | UEq (u, v) -> Universe.pr u ++ str " = " ++ Universe.pr v + | ULub (u, v) -> Level.pr u ++ str " /\\ " ++ Level.pr v + | UWeak (u, v) -> Level.pr u ++ str " ~ " ++ Level.pr v + + let pr c = + let open Pp in + fold (fun cst pp_std -> + pp_std ++ pr_one cst ++ fnl ()) c (str "") + + let equal x y = + x == y || equal x y + + let subst_univs subst csts = + fold + (fun c -> Option.fold_right add (subst_univs subst c)) + csts empty +end + +type 'a accumulator = Set.t -> 'a -> 'a option +type 'a constrained = 'a * Set.t + +type 'a constraint_function = 'a -> 'a -> Set.t -> Set.t + +let enforce_eq_instances_univs strict x y c = + let mk u v = if strict then ULub (u, v) else UEq (Universe.make u, Universe.make v) in + let ax = Instance.to_array x and ay = Instance.to_array y in + if Array.length ax != Array.length ay then + CErrors.anomaly Pp.(str "Invalid argument: enforce_eq_instances_univs called with" ++ + str " instances of different lengths."); + CArray.fold_right2 + (fun x y -> Set.add (mk x y)) + ax ay c + +let to_constraints ~force_weak g s = + let invalid () = + raise (Invalid_argument "to_constraints: non-trivial algebraic constraint between universes") + in + let tr cst acc = + match cst with + | ULub (l, l') -> Constraint.add (l, Eq, l') acc + | UWeak (l, l') when force_weak -> Constraint.add (l, Eq, l') acc + | UWeak _-> acc + | ULe (l, l') -> + begin match Universe.level l, Universe.level l' with + | Some l, Some l' -> Constraint.add (l, Le, l') acc + | None, Some _ -> enforce_leq l l' acc + | _, None -> + if UGraph.check_leq g l l' + then acc + else invalid () + end + | UEq (l, l') -> + begin match Universe.level l, Universe.level l' with + | Some l, Some l' -> Constraint.add (l, Eq, l') acc + | None, _ | _, None -> + if UGraph.check_eq g l l' + then acc + else invalid () + end + in + Set.fold tr s Constraint.empty + + +(** Variant of [eq_constr_univs_infer] taking kind-of-term functions, + to expose subterms of [m] and [n], arguments. *) +let eq_constr_univs_infer_with kind1 kind2 univs fold m n accu = + (* spiwack: duplicates the code of [eq_constr_univs_infer] because I + haven't find a way to factor the code without destroying + pointer-equality optimisations in [eq_constr_univs_infer]. + Pointer equality is not sufficient to ensure equality up to + [kind1,kind2], because [kind1] and [kind2] may be different, + typically evaluating [m] and [n] in different evar maps. *) + let cstrs = ref accu in + let eq_universes _ _ = UGraph.check_eq_instances univs in + let eq_sorts s1 s2 = + if Sorts.equal s1 s2 then true + else + let u1 = Sorts.univ_of_sort s1 and u2 = Sorts.univ_of_sort s2 in + match fold (Set.singleton (UEq (u1, u2))) !cstrs with + | None -> false + | Some accu -> cstrs := accu; true + in + let rec eq_constr' nargs m n = + Constr.compare_head_gen_with kind1 kind2 eq_universes eq_sorts eq_constr' nargs m n + in + let res = Constr.compare_head_gen_with kind1 kind2 eq_universes eq_sorts eq_constr' 0 m n in + if res then Some !cstrs else None diff --git a/engine/univProblem.mli b/engine/univProblem.mli new file mode 100644 index 000000000..ffaebe15a --- /dev/null +++ b/engine/univProblem.mli @@ -0,0 +1,55 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +open Constr +open Univ + +(** {6 Constraints for type inference} + + When doing conversion of universes, not only do we have =/<= constraints but + also Lub constraints which correspond to unification of two levels which might + not be necessary if unfolding is performed. + + UWeak constraints come from irrelevant universes in cumulative polymorphism. +*) + +type t = + | ULe of Universe.t * Universe.t + | UEq of Universe.t * Universe.t + | ULub of Level.t * Level.t + | UWeak of Level.t * Level.t + +val is_trivial : t -> bool + +module Set : sig + include Set.S with type elt = t + + val pr : t -> Pp.t + + val subst_univs : universe_subst_fn -> t -> t +end + +type 'a accumulator = Set.t -> 'a -> 'a option +type 'a constrained = 'a * Set.t +type 'a constraint_function = 'a -> 'a -> Set.t -> Set.t + +val enforce_eq_instances_univs : bool -> Instance.t constraint_function + +(** With [force_weak] UWeak constraints are turned into equalities, + otherwise they're forgotten. *) +val to_constraints : force_weak:bool -> UGraph.t -> Set.t -> Constraint.t + +(** [eq_constr_univs_infer_With kind1 kind2 univs m n] is a variant of + {!eq_constr_univs_infer} taking kind-of-term functions, to expose + subterms of [m] and [n], arguments. *) +val eq_constr_univs_infer_with : + (constr -> (constr, types, Sorts.t, Univ.Instance.t) kind_of_term) -> + (constr -> (constr, types, Sorts.t, Univ.Instance.t) kind_of_term) -> + UGraph.t -> 'a accumulator -> constr -> constr -> 'a -> 'a option diff --git a/engine/univSubst.ml b/engine/univSubst.ml new file mode 100644 index 000000000..6a433d9fb --- /dev/null +++ b/engine/univSubst.ml @@ -0,0 +1,177 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +open Sorts +open Util +open Pp +open Constr +open Univ + +let enforce_univ_constraint (u,d,v) = + match d with + | Eq -> enforce_eq u v + | Le -> enforce_leq u v + | Lt -> enforce_leq (super u) v + +let subst_univs_level fn l = + try Some (fn l) + with Not_found -> None + +let subst_univs_constraint fn (u,d,v as c) cstrs = + let u' = subst_univs_level fn u in + let v' = subst_univs_level fn v in + match u', v' with + | None, None -> Constraint.add c cstrs + | Some u, None -> enforce_univ_constraint (u,d,Universe.make v) cstrs + | None, Some v -> enforce_univ_constraint (Universe.make u,d,v) cstrs + | Some u, Some v -> enforce_univ_constraint (u,d,v) cstrs + +let subst_univs_constraints subst csts = + Constraint.fold + (fun c cstrs -> subst_univs_constraint subst c cstrs) + csts Constraint.empty + +let level_subst_of f = + fun l -> + try let u = f l in + match Universe.level u with + | None -> l + | Some l -> l + with Not_found -> l + +let subst_univs_fn_constr f c = + let changed = ref false in + let fu = Univ.subst_univs_universe f in + let fi = Univ.Instance.subst_fn (level_subst_of f) in + let rec aux t = + match kind t with + | Sort (Sorts.Type u) -> + let u' = fu u in + if u' == u then t else + (changed := true; mkSort (Sorts.sort_of_univ u')) + | Const (c, u) -> + let u' = fi u in + if u' == u then t + else (changed := true; mkConstU (c, u')) + | Ind (i, u) -> + let u' = fi u in + if u' == u then t + else (changed := true; mkIndU (i, u')) + | Construct (c, u) -> + let u' = fi u in + if u' == u then t + else (changed := true; mkConstructU (c, u')) + | _ -> map aux t + in + let c' = aux c in + if !changed then c' else c + +let subst_univs_constr subst c = + if Univ.is_empty_subst subst then c + else + let f = Univ.make_subst subst in + subst_univs_fn_constr f c + +let subst_univs_constr = + if Flags.profile then + let subst_univs_constr_key = CProfile.declare_profile "subst_univs_constr" in + CProfile.profile2 subst_univs_constr_key subst_univs_constr + else subst_univs_constr + +let normalize_univ_variable ~find = + let rec aux cur = + let b = find cur in + let b' = subst_univs_universe aux b in + if Universe.equal b' b then b + else b' + in aux + +let normalize_univ_variable_opt_subst ectx = + let find l = + match Univ.LMap.find l ectx with + | Some b -> b + | None -> raise Not_found + in + normalize_univ_variable ~find + +let normalize_univ_variable_subst subst = + let find l = Univ.LMap.find l subst in + normalize_univ_variable ~find + +let normalize_universe_opt_subst subst = + let normlevel = normalize_univ_variable_opt_subst subst in + subst_univs_universe normlevel + +let normalize_universe_subst subst = + let normlevel = normalize_univ_variable_subst subst in + subst_univs_universe normlevel + +let normalize_opt_subst ctx = + let normalize = normalize_universe_opt_subst ctx in + Univ.LMap.mapi (fun u -> function + | None -> None + | Some v -> Some (normalize v)) ctx + +type universe_opt_subst = Universe.t option universe_map + +let subst_univs_fn_puniverses f (c, u as cu) = + let u' = Instance.subst_fn f u in + if u' == u then cu else (c, u') + +let nf_evars_and_universes_opt_subst f subst = + let subst = normalize_univ_variable_opt_subst subst in + let lsubst = level_subst_of subst in + let rec aux c = + match kind c with + | Evar (evk, args) -> + let args = Array.map aux args in + (match try f (evk, args) with Not_found -> None with + | None -> mkEvar (evk, args) + | Some c -> aux c) + | Const pu -> + let pu' = subst_univs_fn_puniverses lsubst pu in + if pu' == pu then c else mkConstU pu' + | Ind pu -> + let pu' = subst_univs_fn_puniverses lsubst pu in + if pu' == pu then c else mkIndU pu' + | Construct pu -> + let pu' = subst_univs_fn_puniverses lsubst pu in + if pu' == pu then c else mkConstructU pu' + | Sort (Type u) -> + let u' = Univ.subst_univs_universe subst u in + if u' == u then c else mkSort (sort_of_univ u') + | _ -> Constr.map aux c + in aux + +let make_opt_subst s = + fun x -> + (match Univ.LMap.find x s with + | Some u -> u + | None -> raise Not_found) + +let subst_opt_univs_constr s = + let f = make_opt_subst s in + subst_univs_fn_constr f + +let normalize_univ_variables ctx = + let ctx = normalize_opt_subst ctx in + let undef, def, subst = + Univ.LMap.fold (fun u v (undef, def, subst) -> + match v with + | None -> (Univ.LSet.add u undef, def, subst) + | Some b -> (undef, Univ.LSet.add u def, Univ.LMap.add u b subst)) + ctx (Univ.LSet.empty, Univ.LSet.empty, Univ.LMap.empty) + in ctx, undef, def, subst + +let pr_universe_body = function + | None -> mt () + | Some v -> str" := " ++ Univ.Universe.pr v + +let pr_universe_opt_subst = Univ.LMap.pr pr_universe_body diff --git a/engine/univSubst.mli b/engine/univSubst.mli new file mode 100644 index 000000000..26e8d1db9 --- /dev/null +++ b/engine/univSubst.mli @@ -0,0 +1,53 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +open Constr +open Univ + +val level_subst_of : universe_subst_fn -> universe_level_subst_fn +val subst_univs_constraints : universe_subst_fn -> Constraint.t -> Constraint.t + +val subst_univs_constr : universe_subst -> constr -> constr + +type universe_opt_subst = Universe.t option universe_map + +val make_opt_subst : universe_opt_subst -> universe_subst_fn + +val subst_opt_univs_constr : universe_opt_subst -> constr -> constr + +val normalize_univ_variables : universe_opt_subst -> + universe_opt_subst * LSet.t * LSet.t * universe_subst + +val normalize_univ_variable : + find:(Level.t -> Universe.t) -> + Level.t -> Universe.t + +val normalize_univ_variable_opt_subst : universe_opt_subst -> + (Level.t -> Universe.t) + +val normalize_univ_variable_subst : universe_subst -> + (Level.t -> Universe.t) + +val normalize_universe_opt_subst : universe_opt_subst -> + (Universe.t -> Universe.t) + +val normalize_universe_subst : universe_subst -> + (Universe.t -> Universe.t) + +val normalize_opt_subst : universe_opt_subst -> universe_opt_subst + +(** Full universes substitutions into terms *) + +val nf_evars_and_universes_opt_subst : (existential -> constr option) -> + universe_opt_subst -> constr -> constr + +(** Pretty-printing *) + +val pr_universe_opt_subst : universe_opt_subst -> Pp.t diff --git a/engine/universes.ml b/engine/universes.ml index e5f9212a7..70601987c 100644 --- a/engine/universes.ml +++ b/engine/universes.ml @@ -8,1129 +8,90 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) -open Sorts -open Util -open Pp -open Names -open Constr -open Environ open Univ -open Globnames -open Nametab -module UPairs = OrderedType.UnorderedPair(Univ.Level) -module UPairSet = Set.Make (UPairs) - -let reference_of_level l = CAst.make @@ - match Level.name l with - | Some (d, n as na) -> - let qid = - try Nametab.shortest_qualid_of_universe na - with Not_found -> - let name = Id.of_string_soft (string_of_int n) in - Libnames.make_qualid d name - in Libnames.Qualid qid - | None -> Libnames.Ident Id.(of_string_soft (Level.to_string l)) - -let pr_with_global_universes l = Libnames.pr_reference (reference_of_level l) - -(** Global universe information outside the kernel, to handle - polymorphic universe names in sections that have to be discharged. *) - -let universe_map = (Summary.ref UnivIdMap.empty ~name:"global universe info" : bool Nametab.UnivIdMap.t ref) - -let add_global_universe u p = - match Level.name u with - | Some n -> universe_map := Nametab.UnivIdMap.add n p !universe_map - | None -> () - -let is_polymorphic l = - match Level.name l with - | Some n -> - (try Nametab.UnivIdMap.find n !universe_map - with Not_found -> false) - | None -> false - -(** Local universe names of polymorphic references *) - -type universe_binders = Univ.Level.t Names.Id.Map.t - -let empty_binders = Id.Map.empty - -let universe_binders_table = Summary.ref Refmap.empty ~name:"universe binders" - -let universe_binders_of_global ref : universe_binders = - try - let l = Refmap.find ref !universe_binders_table in l - with Not_found -> Names.Id.Map.empty - -let cache_ubinder (_,(ref,l)) = - universe_binders_table := Refmap.add ref l !universe_binders_table - -let subst_ubinder (subst,(ref,l as orig)) = - let ref' = fst (Globnames.subst_global subst ref) in - if ref == ref' then orig else ref', l - -let discharge_ubinder (_,(ref,l)) = - Some (Lib.discharge_global ref, l) - -let ubinder_obj : Globnames.global_reference * universe_binders -> Libobject.obj = - let open Libobject in - declare_object { (default_object "universe binder") with - cache_function = cache_ubinder; - load_function = (fun _ x -> cache_ubinder x); - classify_function = (fun x -> Substitute x); - subst_function = subst_ubinder; - discharge_function = discharge_ubinder; - rebuild_function = (fun x -> x); } - -let register_universe_binders ref ubinders = - let open Names in - (* Add the polymorphic (section) universes *) - let ubinders = UnivIdMap.fold (fun lvl poly ubinders -> - let qid = Nametab.shortest_qualid_of_universe lvl in - let level = Level.make (fst lvl) (snd lvl) in - if poly then Id.Map.add (snd (Libnames.repr_qualid qid)) level ubinders - else ubinders) - !universe_map ubinders - in - if not (Id.Map.is_empty ubinders) - then Lib.add_anonymous_leaf (ubinder_obj (ref,ubinders)) - -type univ_name_list = Misctypes.lname list - -let universe_binders_with_opt_names ref levels = function - | None -> universe_binders_of_global ref - | Some udecl -> - if Int.equal(List.length levels) (List.length udecl) - then - List.fold_left2 (fun acc { CAst.v = na} lvl -> match na with - | Anonymous -> acc - | Name na -> Names.Id.Map.add na lvl acc) - empty_binders udecl levels - else - CErrors.user_err ~hdr:"universe_binders_with_opt_names" - Pp.(str "Universe instance should have length " ++ int (List.length levels)) - -(* To disallow minimization to Set *) - -let set_minimization = ref true -let is_set_minimization () = !set_minimization - -type universe_constraint = +(** Deprecated *) + +(** UnivNames *) +type universe_binders = UnivNames.universe_binders +type univ_name_list = UnivNames.univ_name_list + +let pr_with_global_universes = UnivNames.pr_with_global_universes +let reference_of_level = UnivNames.reference_of_level + +let add_global_universe = UnivNames.add_global_universe + +let is_polymorphic = UnivNames.is_polymorphic + +let empty_binders = UnivNames.empty_binders + +let register_universe_binders = UnivNames.register_universe_binders +let universe_binders_of_global = UnivNames.universe_binders_of_global + +let universe_binders_with_opt_names = UnivNames.universe_binders_with_opt_names + +(** UnivGen *) +type universe_id = UnivGen.universe_id + +let set_remote_new_univ_id = UnivGen.set_remote_new_univ_id +let new_univ_id = UnivGen.new_univ_id +let new_univ_level = UnivGen.new_univ_level +let new_univ = UnivGen.new_univ +let new_Type = UnivGen.new_Type +let new_Type_sort = UnivGen.new_Type_sort +let new_global_univ = UnivGen.new_global_univ +let new_sort_in_family = UnivGen.new_sort_in_family +let fresh_instance_from_context = UnivGen.fresh_instance_from_context +let fresh_instance_from = UnivGen.fresh_instance_from +let fresh_sort_in_family = UnivGen.fresh_sort_in_family +let fresh_constant_instance = UnivGen.fresh_constant_instance +let fresh_inductive_instance = UnivGen.fresh_inductive_instance +let fresh_constructor_instance = UnivGen.fresh_constructor_instance +let fresh_global_instance = UnivGen.fresh_global_instance +let fresh_global_or_constr_instance = UnivGen.fresh_global_or_constr_instance +let fresh_universe_context_set_instance = UnivGen.fresh_universe_context_set_instance +let global_of_constr = UnivGen.global_of_constr +let constr_of_global_univ = UnivGen.constr_of_global_univ +let extend_context = UnivGen.extend_context +let constr_of_global = UnivGen.constr_of_global +let constr_of_reference = UnivGen.constr_of_global +let type_of_global = UnivGen.type_of_global + +(** UnivSubst *) + +let level_subst_of = UnivSubst.level_subst_of +let subst_univs_constraints = UnivSubst.subst_univs_constraints +let subst_univs_constr = UnivSubst.subst_univs_constr +type universe_opt_subst = UnivSubst.universe_opt_subst +let make_opt_subst = UnivSubst.make_opt_subst +let subst_opt_univs_constr = UnivSubst.subst_opt_univs_constr +let normalize_univ_variables = UnivSubst.normalize_univ_variables +let normalize_univ_variable = UnivSubst.normalize_univ_variable +let normalize_univ_variable_opt_subst = UnivSubst.normalize_univ_variable_opt_subst +let normalize_univ_variable_subst = UnivSubst.normalize_univ_variable_subst +let normalize_universe_opt_subst = UnivSubst.normalize_universe_opt_subst +let normalize_universe_subst = UnivSubst.normalize_universe_subst +let nf_evars_and_universes_opt_subst = UnivSubst.nf_evars_and_universes_opt_subst +let pr_universe_opt_subst = UnivSubst.pr_universe_opt_subst + +(** UnivProblem *) + +type universe_constraint = UnivProblem.t = | ULe of Universe.t * Universe.t | UEq of Universe.t * Universe.t | ULub of Level.t * Level.t | UWeak of Level.t * Level.t -module Constraints = struct - module S = Set.Make( - struct - type t = universe_constraint - - let compare x y = - match x, y with - | ULe (u, v), ULe (u', v') -> - let i = Universe.compare u u' in - if Int.equal i 0 then Universe.compare v v' - else i - | UEq (u, v), UEq (u', v') -> - let i = Universe.compare u u' in - if Int.equal i 0 then Universe.compare v v' - else if Universe.equal u v' && Universe.equal v u' then 0 - else i - | ULub (u, v), ULub (u', v') | UWeak (u, v), UWeak (u', v') -> - let i = Level.compare u u' in - if Int.equal i 0 then Level.compare v v' - else if Level.equal u v' && Level.equal v u' then 0 - else i - | ULe _, _ -> -1 - | _, ULe _ -> 1 - | UEq _, _ -> -1 - | _, UEq _ -> 1 - | ULub _, _ -> -1 - | _, ULub _ -> 1 - end) - - include S - - let is_trivial = function - | ULe (u, v) | UEq (u, v) -> Universe.equal u v - | ULub (u, v) | UWeak (u, v) -> Level.equal u v - - let add cst s = - if is_trivial cst then s - else add cst s - - let pr_one = function - | ULe (u, v) -> Universe.pr u ++ str " <= " ++ Universe.pr v - | UEq (u, v) -> Universe.pr u ++ str " = " ++ Universe.pr v - | ULub (u, v) -> Level.pr u ++ str " /\\ " ++ Level.pr v - | UWeak (u, v) -> Level.pr u ++ str " ~ " ++ Level.pr v - - let pr c = - fold (fun cst pp_std -> - pp_std ++ pr_one cst ++ fnl ()) c (str "") - - let equal x y = - x == y || equal x y - -end - -type universe_constraints = Constraints.t -type 'a constraint_accumulator = universe_constraints -> 'a -> 'a option -type 'a universe_constrained = 'a * universe_constraints - -type 'a universe_constraint_function = 'a -> 'a -> universe_constraints -> universe_constraints - -let enforce_eq_instances_univs strict x y c = - let mk u v = if strict then ULub (u, v) else UEq (Universe.make u, Universe.make v) in - let ax = Instance.to_array x and ay = Instance.to_array y in - if Array.length ax != Array.length ay then - CErrors.anomaly (Pp.str "Invalid argument: enforce_eq_instances_univs called with" ++ - Pp.str " instances of different lengths."); - CArray.fold_right2 - (fun x y -> Constraints.add (mk x y)) - ax ay c - -let enforce_univ_constraint (u,d,v) = - match d with - | Eq -> enforce_eq u v - | Le -> enforce_leq u v - | Lt -> enforce_leq (super u) v - -let subst_univs_level fn l = - try Some (fn l) - with Not_found -> None - -let subst_univs_constraint fn (u,d,v as c) cstrs = - let u' = subst_univs_level fn u in - let v' = subst_univs_level fn v in - match u', v' with - | None, None -> Constraint.add c cstrs - | Some u, None -> enforce_univ_constraint (u,d,Universe.make v) cstrs - | None, Some v -> enforce_univ_constraint (Universe.make u,d,v) cstrs - | Some u, Some v -> enforce_univ_constraint (u,d,v) cstrs - -let subst_univs_constraints subst csts = - Constraint.fold - (fun c cstrs -> subst_univs_constraint subst c cstrs) - csts Constraint.empty - -let level_subst_of f = - fun l -> - try let u = f l in - match Universe.level u with - | None -> l - | Some l -> l - with Not_found -> l - -let subst_univs_universe_constraint fn = function - | ULe (u, v) -> - let u' = subst_univs_universe fn u and v' = subst_univs_universe fn v in - if Universe.equal u' v' then None - else Some (ULe (u',v')) - | UEq (u, v) -> - let u' = subst_univs_universe fn u and v' = subst_univs_universe fn v in - if Universe.equal u' v' then None - else Some (ULe (u',v')) - | ULub (u, v) -> - let u' = level_subst_of fn u and v' = level_subst_of fn v in - if Level.equal u' v' then None - else Some (ULub (u',v')) - | UWeak (u, v) -> - let u' = level_subst_of fn u and v' = level_subst_of fn v in - if Level.equal u' v' then None - else Some (UWeak (u',v')) - -let subst_univs_universe_constraints subst csts = - Constraints.fold - (fun c -> Option.fold_right Constraints.add (subst_univs_universe_constraint subst c)) - csts Constraints.empty - -let to_constraints ~force_weak g s = - let invalid () = - raise (Invalid_argument "to_constraints: non-trivial algebraic constraint between universes") - in - let tr cst acc = - match cst with - | ULub (l, l') -> Constraint.add (l, Eq, l') acc - | UWeak (l, l') when force_weak -> Constraint.add (l, Eq, l') acc - | UWeak _-> acc - | ULe (l, l') -> - begin match Universe.level l, Universe.level l' with - | Some l, Some l' -> Constraint.add (l, Le, l') acc - | None, Some _ -> enforce_leq l l' acc - | _, None -> - if UGraph.check_leq g l l' - then acc - else invalid () - end - | UEq (l, l') -> - begin match Universe.level l, Universe.level l' with - | Some l, Some l' -> Constraint.add (l, Eq, l') acc - | None, _ | _, None -> - if UGraph.check_eq g l l' - then acc - else invalid () - end - in - Constraints.fold tr s Constraint.empty - -(** Variant of [eq_constr_univs_infer] taking kind-of-term functions, - to expose subterms of [m] and [n], arguments. *) -let eq_constr_univs_infer_with kind1 kind2 univs fold m n accu = - (* spiwack: duplicates the code of [eq_constr_univs_infer] because I - haven't find a way to factor the code without destroying - pointer-equality optimisations in [eq_constr_univs_infer]. - Pointer equality is not sufficient to ensure equality up to - [kind1,kind2], because [kind1] and [kind2] may be different, - typically evaluating [m] and [n] in different evar maps. *) - let cstrs = ref accu in - let eq_universes _ _ = UGraph.check_eq_instances univs in - let eq_sorts s1 s2 = - if Sorts.equal s1 s2 then true - else - let u1 = Sorts.univ_of_sort s1 and u2 = Sorts.univ_of_sort s2 in - match fold (Constraints.singleton (UEq (u1, u2))) !cstrs with - | None -> false - | Some accu -> cstrs := accu; true - in - let rec eq_constr' nargs m n = - Constr.compare_head_gen_with kind1 kind2 eq_universes eq_sorts eq_constr' nargs m n - in - let res = Constr.compare_head_gen_with kind1 kind2 eq_universes eq_sorts eq_constr' 0 m n in - if res then Some !cstrs else None - -(* Generator of levels *) -type universe_id = DirPath.t * int - -let new_univ_id, set_remote_new_univ_id = - RemoteCounter.new_counter ~name:"Universes" 0 ~incr:((+) 1) - ~build:(fun n -> Global.current_dirpath (), n) - -let new_univ_level () = - let dp, id = new_univ_id () in - Univ.Level.make dp id - -let fresh_level () = new_univ_level () - -(* TODO: remove *) -let new_univ dp = Univ.Universe.make (new_univ_level dp) -let new_Type dp = mkType (new_univ dp) -let new_Type_sort dp = Type (new_univ dp) - -let fresh_universe_instance ctx = - let init _ = new_univ_level () in - Instance.of_array (Array.init (AUContext.size ctx) init) - -let fresh_instance_from_context ctx = - let inst = fresh_universe_instance ctx in - let constraints = AUContext.instantiate inst ctx in - inst, constraints - -let fresh_instance ctx = - let ctx' = ref LSet.empty in - let init _ = - let u = new_univ_level () in - ctx' := LSet.add u !ctx'; u - in - let inst = Instance.of_array (Array.init (AUContext.size ctx) init) - in !ctx', inst - -let existing_instance ctx inst = - let () = - let len1 = Array.length (Instance.to_array inst) - and len2 = AUContext.size ctx in - if not (len1 == len2) then - CErrors.user_err ~hdr:"Universes" - (str "Polymorphic constant expected " ++ int len2 ++ - str" levels but was given " ++ int len1) - else () - in LSet.empty, inst - -let fresh_instance_from ctx inst = - let ctx', inst = - match inst with - | Some inst -> existing_instance ctx inst - | None -> fresh_instance ctx - in - let constraints = AUContext.instantiate inst ctx in - inst, (ctx', constraints) - -(** Fresh universe polymorphic construction *) - -let fresh_constant_instance env c inst = - let cb = lookup_constant c env in - match cb.Declarations.const_universes with - | Declarations.Monomorphic_const _ -> ((c,Instance.empty), ContextSet.empty) - | Declarations.Polymorphic_const auctx -> - let inst, ctx = - fresh_instance_from auctx inst - in - ((c, inst), ctx) - -let fresh_inductive_instance env ind inst = - let mib, mip = Inductive.lookup_mind_specif env ind in - match mib.Declarations.mind_universes with - | Declarations.Monomorphic_ind _ -> - ((ind,Instance.empty), ContextSet.empty) - | Declarations.Polymorphic_ind uactx -> - let inst, ctx = (fresh_instance_from uactx) inst in - ((ind,inst), ctx) - | Declarations.Cumulative_ind acumi -> - let inst, ctx = - fresh_instance_from (Univ.ACumulativityInfo.univ_context acumi) inst - in ((ind,inst), ctx) - -let fresh_constructor_instance env (ind,i) inst = - let mib, mip = Inductive.lookup_mind_specif env ind in - match mib.Declarations.mind_universes with - | Declarations.Monomorphic_ind _ -> (((ind,i),Instance.empty), ContextSet.empty) - | Declarations.Polymorphic_ind auctx -> - let inst, ctx = fresh_instance_from auctx inst in - (((ind,i),inst), ctx) - | Declarations.Cumulative_ind acumi -> - let inst, ctx = fresh_instance_from (ACumulativityInfo.univ_context acumi) inst in - (((ind,i),inst), ctx) - -open Globnames - -let fresh_global_instance ?names env gr = - match gr with - | VarRef id -> mkVar id, ContextSet.empty - | ConstRef sp -> - let c, ctx = fresh_constant_instance env sp names in - mkConstU c, ctx - | ConstructRef sp -> - let c, ctx = fresh_constructor_instance env sp names in - mkConstructU c, ctx - | IndRef sp -> - let c, ctx = fresh_inductive_instance env sp names in - mkIndU c, ctx - -let fresh_constant_instance env sp = - fresh_constant_instance env sp None - -let fresh_inductive_instance env sp = - fresh_inductive_instance env sp None - -let fresh_constructor_instance env sp = - fresh_constructor_instance env sp None - -let constr_of_global gr = - let c, ctx = fresh_global_instance (Global.env ()) gr in - if not (Univ.ContextSet.is_empty ctx) then - if Univ.LSet.is_empty (Univ.ContextSet.levels ctx) then - (* Should be an error as we might forget constraints, allow for now - to make firstorder work with "using" clauses *) - c - else CErrors.user_err ~hdr:"constr_of_global" - Pp.(str "globalization of polymorphic reference " ++ Nametab.pr_global_env Id.Set.empty gr ++ - str " would forget universes.") - else c - -let constr_of_reference = constr_of_global - -let constr_of_global_univ (gr,u) = - match gr with - | VarRef id -> mkVar id - | ConstRef sp -> mkConstU (sp,u) - | ConstructRef sp -> mkConstructU (sp,u) - | IndRef sp -> mkIndU (sp,u) - -let fresh_global_or_constr_instance env = function - | IsConstr c -> c, ContextSet.empty - | IsGlobal gr -> fresh_global_instance env gr - -let global_of_constr c = - match kind c with - | Const (c, u) -> ConstRef c, u - | Ind (i, u) -> IndRef i, u - | Construct (c, u) -> ConstructRef c, u - | Var id -> VarRef id, Instance.empty - | _ -> raise Not_found - -open Declarations - -let type_of_reference env r = - match r with - | VarRef id -> Environ.named_type id env, ContextSet.empty - | ConstRef c -> - let cb = Environ.lookup_constant c env in - let ty = cb.const_type in - begin - match cb.const_universes with - | Monomorphic_const _ -> ty, ContextSet.empty - | Polymorphic_const auctx -> - let inst, ctx = fresh_instance_from auctx None in - Vars.subst_instance_constr inst ty, ctx - end - | IndRef ind -> - let (mib, oib as specif) = Inductive.lookup_mind_specif env ind in - begin - match mib.mind_universes with - | Monomorphic_ind _ -> - let ty = Inductive.type_of_inductive env (specif, Univ.Instance.empty) in - ty, ContextSet.empty - | Polymorphic_ind auctx -> - let inst, ctx = fresh_instance_from auctx None in - let ty = Inductive.type_of_inductive env (specif, inst) in - ty, ctx - | Cumulative_ind cumi -> - let inst, ctx = - fresh_instance_from (ACumulativityInfo.univ_context cumi) None - in - let ty = Inductive.type_of_inductive env (specif, inst) in - ty, ctx - end - - | ConstructRef cstr -> - let (mib,oib as specif) = - Inductive.lookup_mind_specif env (inductive_of_constructor cstr) - in - begin - match mib.mind_universes with - | Monomorphic_ind _ -> - Inductive.type_of_constructor (cstr,Instance.empty) specif, ContextSet.empty - | Polymorphic_ind auctx -> - let inst, ctx = fresh_instance_from auctx None in - Inductive.type_of_constructor (cstr,inst) specif, ctx - | Cumulative_ind cumi -> - let inst, ctx = - fresh_instance_from (ACumulativityInfo.univ_context cumi) None - in - Inductive.type_of_constructor (cstr,inst) specif, ctx - end - -let type_of_global t = type_of_reference (Global.env ()) t - -let fresh_sort_in_family env = function - | InProp -> Sorts.prop, ContextSet.empty - | InSet -> Sorts.set, ContextSet.empty - | InType -> - let u = fresh_level () in - Type (Univ.Universe.make u), ContextSet.singleton u - -let new_sort_in_family sf = - fst (fresh_sort_in_family (Global.env ()) sf) - -let extend_context (a, ctx) (ctx') = - (a, ContextSet.union ctx ctx') - -let new_global_univ () = - let u = fresh_level () in - (Univ.Universe.make u, ContextSet.singleton u) - -(** Simplification *) - -module LevelUnionFind = Unionfind.Make (Univ.LSet) (Univ.LMap) - -let add_list_map u t map = - try - let l = LMap.find u map in - LMap.set u (t :: l) map - with Not_found -> - LMap.add u [t] map - -module UF = LevelUnionFind - -(** Precondition: flexible <= ctx *) -let choose_canonical ctx flexible algs s = - let global = LSet.diff s ctx in - let flexible, rigid = LSet.partition flexible (LSet.inter s ctx) in - (** If there is a global universe in the set, choose it *) - if not (LSet.is_empty global) then - let canon = LSet.choose global in - canon, (LSet.remove canon global, rigid, flexible) - else (** No global in the equivalence class, choose a rigid one *) - if not (LSet.is_empty rigid) then - let canon = LSet.choose rigid in - canon, (global, LSet.remove canon rigid, flexible) - else (** There are only flexible universes in the equivalence - class, choose a non-algebraic. *) - let algs, nonalgs = LSet.partition (fun x -> LSet.mem x algs) flexible in - if not (LSet.is_empty nonalgs) then - let canon = LSet.choose nonalgs in - canon, (global, rigid, LSet.remove canon flexible) - else - let canon = LSet.choose algs in - canon, (global, rigid, LSet.remove canon flexible) - -let subst_univs_fn_constr f c = - let changed = ref false in - let fu = Univ.subst_univs_universe f in - let fi = Univ.Instance.subst_fn (level_subst_of f) in - let rec aux t = - match kind t with - | Sort (Sorts.Type u) -> - let u' = fu u in - if u' == u then t else - (changed := true; mkSort (Sorts.sort_of_univ u')) - | Const (c, u) -> - let u' = fi u in - if u' == u then t - else (changed := true; mkConstU (c, u')) - | Ind (i, u) -> - let u' = fi u in - if u' == u then t - else (changed := true; mkIndU (i, u')) - | Construct (c, u) -> - let u' = fi u in - if u' == u then t - else (changed := true; mkConstructU (c, u')) - | _ -> map aux t - in - let c' = aux c in - if !changed then c' else c - -let subst_univs_constr subst c = - if Univ.is_empty_subst subst then c - else - let f = Univ.make_subst subst in - subst_univs_fn_constr f c - -let subst_univs_constr = - if Flags.profile then - let subst_univs_constr_key = CProfile.declare_profile "subst_univs_constr" in - CProfile.profile2 subst_univs_constr_key subst_univs_constr - else subst_univs_constr - -let subst_univs_fn_puniverses lsubst (c, u as cu) = - let u' = Instance.subst_fn lsubst u in - if u' == u then cu else (c, u') - -let nf_evars_and_universes_opt_subst f subst = - let subst = fun l -> match LMap.find l subst with None -> raise Not_found | Some l' -> l' in - let lsubst = level_subst_of subst in - let rec aux c = - match kind c with - | Evar (evk, args) -> - let args = Array.map aux args in - (match try f (evk, args) with Not_found -> None with - | None -> c - | Some c -> aux c) - | Const pu -> - let pu' = subst_univs_fn_puniverses lsubst pu in - if pu' == pu then c else mkConstU pu' - | Ind pu -> - let pu' = subst_univs_fn_puniverses lsubst pu in - if pu' == pu then c else mkIndU pu' - | Construct pu -> - let pu' = subst_univs_fn_puniverses lsubst pu in - if pu' == pu then c else mkConstructU pu' - | Sort (Type u) -> - let u' = Univ.subst_univs_universe subst u in - if u' == u then c else mkSort (sort_of_univ u') - | _ -> Constr.map aux c - in aux - -let fresh_universe_context_set_instance ctx = - if ContextSet.is_empty ctx then LMap.empty, ctx - else - let (univs, cst) = ContextSet.levels ctx, ContextSet.constraints ctx in - let univs',subst = LSet.fold - (fun u (univs',subst) -> - let u' = fresh_level () in - (LSet.add u' univs', LMap.add u u' subst)) - univs (LSet.empty, LMap.empty) - in - let cst' = subst_univs_level_constraints subst cst in - subst, (univs', cst') - -let normalize_univ_variable ~find ~update = - let rec aux cur = - let b = find cur in - let b' = subst_univs_universe aux b in - if Universe.equal b' b then b - else update cur b' - in aux - -let normalize_univ_variable_opt_subst ectx = - let find l = - match Univ.LMap.find l !ectx with - | Some b -> b - | None -> raise Not_found - in - let update l b = - assert (match Universe.level b with Some l' -> not (Level.equal l l') | None -> true); - try ectx := Univ.LMap.add l (Some b) !ectx; b with Not_found -> assert false - in normalize_univ_variable ~find ~update - -let normalize_univ_variable_subst subst = - let find l = Univ.LMap.find l !subst in - let update l b = - assert (match Universe.level b with Some l' -> not (Level.equal l l') | None -> true); - try subst := Univ.LMap.set l b !subst; b with Not_found -> assert false in - normalize_univ_variable ~find ~update - -let normalize_universe_opt_subst subst = - let normlevel = normalize_univ_variable_opt_subst subst in - subst_univs_universe normlevel - -let normalize_universe_subst subst = - let normlevel = normalize_univ_variable_subst subst in - subst_univs_universe normlevel - -let normalize_opt_subst ctx = - let ectx = ref ctx in - let normalize = normalize_univ_variable_opt_subst ectx in - let () = - Univ.LMap.iter (fun u v -> - if Option.is_empty v then () - else try ignore(normalize u) with Not_found -> assert(false)) ctx - in !ectx - -type universe_opt_subst = Universe.t option universe_map - -let make_opt_subst s = - fun x -> - (match Univ.LMap.find x s with - | Some u -> u - | None -> raise Not_found) - -let subst_opt_univs_constr s = - let f = make_opt_subst s in - subst_univs_fn_constr f - -let normalize_univ_variables ctx = - let ctx = normalize_opt_subst ctx in - let undef, def, subst = - Univ.LMap.fold (fun u v (undef, def, subst) -> - match v with - | None -> (Univ.LSet.add u undef, def, subst) - | Some b -> (undef, Univ.LSet.add u def, Univ.LMap.add u b subst)) - ctx (Univ.LSet.empty, Univ.LSet.empty, Univ.LMap.empty) - in ctx, undef, def, subst - -let pr_universe_body = function - | None -> mt () - | Some v -> str" := " ++ Univ.Universe.pr v - -let pr_universe_opt_subst = Univ.LMap.pr pr_universe_body - -let compare_constraint_type d d' = - match d, d' with - | Eq, Eq -> 0 - | Eq, _ -> -1 - | _, Eq -> 1 - | Le, Le -> 0 - | Le, _ -> -1 - | _, Le -> 1 - | Lt, Lt -> 0 - -type lowermap = constraint_type LMap.t - -let lower_union = - let merge k a b = - match a, b with - | Some _, None -> a - | None, Some _ -> b - | None, None -> None - | Some l, Some r -> - if compare_constraint_type l r >= 0 then a - else b - in LMap.merge merge - -let lower_add l c m = - try let c' = LMap.find l m in - if compare_constraint_type c c' > 0 then - LMap.add l c m - else m - with Not_found -> LMap.add l c m - -let lower_of_list l = - List.fold_left (fun acc (d,l) -> LMap.add l d acc) LMap.empty l - -exception Found of Level.t * lowermap -let find_inst insts v = - try LMap.iter (fun k (enf,alg,v',lower) -> - if not alg && enf && Universe.equal v' v then raise (Found (k, lower))) - insts; raise Not_found - with Found (f,l) -> (f,l) - -let compute_lbound left = - (** The universe variable was not fixed yet. - Compute its level using its lower bound. *) - let sup l lbound = - match lbound with - | None -> Some l - | Some l' -> Some (Universe.sup l l') - in - List.fold_left (fun lbound (d, l) -> - if d == Le (* l <= ?u *) then sup l lbound - else (* l < ?u *) - (assert (d == Lt); - if not (Universe.level l == None) then - sup (Universe.super l) lbound - else None)) - None left - -let instantiate_with_lbound u lbound lower alg enforce (ctx, us, algs, insts, cstrs) = - if enforce then - let inst = Universe.make u in - let cstrs' = enforce_leq lbound inst cstrs in - (ctx, us, LSet.remove u algs, - LMap.add u (enforce,alg,lbound,lower) insts, cstrs'), - (enforce, alg, inst, lower) - else (* Actually instantiate *) - (Univ.LSet.remove u ctx, Univ.LMap.add u (Some lbound) us, algs, - LMap.add u (enforce,alg,lbound,lower) insts, cstrs), - (enforce, alg, lbound, lower) - -type constraints_map = (Univ.constraint_type * Univ.LMap.key) list Univ.LMap.t - -let _pr_constraints_map (cmap:constraints_map) = - LMap.fold (fun l cstrs acc -> - Level.pr l ++ str " => " ++ - prlist_with_sep spc (fun (d,r) -> pr_constraint_type d ++ Level.pr r) cstrs ++ - fnl () ++ acc) - cmap (mt ()) - -let remove_alg l (ctx, us, algs, insts, cstrs) = - (ctx, us, LSet.remove l algs, insts, cstrs) - -let remove_lower u lower = - let levels = Universe.levels u in - LSet.fold (fun l acc -> LMap.remove l acc) levels lower - -let minimize_univ_variables ctx us algs left right cstrs = - let left, lbounds = - Univ.LMap.fold (fun r lower (left, lbounds as acc) -> - if Univ.LMap.mem r us || not (Univ.LSet.mem r ctx) then acc - else (* Fixed universe, just compute its glb for sharing *) - let lbounds' = - match compute_lbound (List.map (fun (d,l) -> d, Universe.make l) lower) with - | None -> lbounds - | Some lbound -> LMap.add r (true, false, lbound, lower_of_list lower) - lbounds - in (Univ.LMap.remove r left, lbounds')) - left (left, Univ.LMap.empty) - in - let rec instance (ctx', us, algs, insts, cstrs as acc) u = - let acc, left, lower = - try - let l = LMap.find u left in - let acc, left, newlow, lower = - List.fold_left - (fun (acc, left', newlow, lower') (d, l) -> - let acc', (enf,alg,l',lower) = aux acc l in - let l' = - if enf then Universe.make l - else l' - in acc', (d, l') :: left', - lower_add l d newlow, lower_union lower lower') - (acc, [], LMap.empty, LMap.empty) l - in - let not_lower (d,l) = - (* We're checking if (d,l) is already implied by the lower - constraints on some level u. If it represents l < u (d is Lt - or d is Le and i > 0, the i < 0 case is impossible due to - invariants of Univ), and the lower constraints only have l <= - u then it is not implied. *) - Univ.Universe.exists - (fun (l,i) -> - let d = - if i == 0 then d - else match d with - | Le -> Lt - | d -> d - in - try let d' = LMap.find l lower in - (* If d is stronger than the already implied lower - * constraints we must keep it. *) - compare_constraint_type d d' > 0 - with Not_found -> - (** No constraint existing on l *) true) l - in - let left = List.uniquize (List.filter not_lower left) in - (acc, left, LMap.union newlow lower) - with Not_found -> acc, [], LMap.empty - and right = - try Some (LMap.find u right) - with Not_found -> None - in - let instantiate_lbound lbound = - let alg = LSet.mem u algs in - if alg then - (* u is algebraic: we instantiate it with its lower bound, if any, - or enforce the constraints if it is bounded from the top. *) - let lower = remove_lower lbound lower in - instantiate_with_lbound u lbound lower true false acc - else (* u is non algebraic *) - match Universe.level lbound with - | Some l -> (* The lowerbound is directly a level *) - (* u is not algebraic but has no upper bounds, - we instantiate it with its lower bound if it is a - different level, otherwise we keep it. *) - let lower = LMap.remove l lower in - if not (Level.equal l u) then - (* Should check that u does not - have upper constraints that are not already in right *) - let acc' = remove_alg l acc in - instantiate_with_lbound u lbound lower false false acc' - else acc, (true, false, lbound, lower) - | None -> - try - (* Another universe represents the same lower bound, - we can share them with no harm. *) - let can, lower = find_inst insts lbound in - let lower = LMap.remove can lower in - instantiate_with_lbound u (Universe.make can) lower false false acc - with Not_found -> - (* We set u as the canonical universe representing lbound *) - instantiate_with_lbound u lbound lower false true acc - in - let acc' acc = - match right with - | None -> acc - | Some cstrs -> - let dangling = List.filter (fun (d, r) -> not (LMap.mem r us)) cstrs in - if List.is_empty dangling then acc - else - let ((ctx', us, algs, insts, cstrs), (enf,_,inst,lower as b)) = acc in - let cstrs' = List.fold_left (fun cstrs (d, r) -> - if d == Univ.Le then - enforce_leq inst (Universe.make r) cstrs - else - try let lev = Option.get (Universe.level inst) in - Constraint.add (lev, d, r) cstrs - with Option.IsNone -> failwith "") - cstrs dangling - in - (ctx', us, algs, insts, cstrs'), b - in - if not (LSet.mem u ctx) then acc' (acc, (true, false, Universe.make u, lower)) - else - let lbound = compute_lbound left in - match lbound with - | None -> (* Nothing to do *) - acc' (acc, (true, false, Universe.make u, lower)) - | Some lbound -> - try acc' (instantiate_lbound lbound) - with Failure _ -> acc' (acc, (true, false, Universe.make u, lower)) - and aux (ctx', us, algs, seen, cstrs as acc) u = - try acc, LMap.find u seen - with Not_found -> instance acc u - in - LMap.fold (fun u v (ctx', us, algs, seen, cstrs as acc) -> - if v == None then fst (aux acc u) - else LSet.remove u ctx', us, LSet.remove u algs, seen, cstrs) - us (ctx, us, algs, lbounds, cstrs) - -let normalize_context_set g ctx us algs weak = - let (ctx, csts) = ContextSet.levels ctx, ContextSet.constraints ctx in - let uf = UF.create () in - (** Keep the Prop/Set <= i constraints separate for minimization *) - let smallles, csts = - Constraint.fold (fun (l,d,r as cstr) (smallles, noneqs) -> - if d == Le then - if Univ.Level.is_small l then - if is_set_minimization () && LSet.mem r ctx then - (Constraint.add cstr smallles, noneqs) - else (smallles, noneqs) - else if Level.is_small r then - if Level.is_prop r then - raise (Univ.UniverseInconsistency - (Le,Universe.make l,Universe.make r,None)) - else (smallles, Constraint.add (l,Eq,r) noneqs) - else (smallles, Constraint.add cstr noneqs) - else (smallles, Constraint.add cstr noneqs)) - csts (Constraint.empty, Constraint.empty) - in - let csts = - (* We first put constraints in a normal-form: all self-loops are collapsed - to equalities. *) - let g = Univ.LSet.fold (fun v g -> UGraph.add_universe v false g) - ctx UGraph.initial_universes - in - let g = - Univ.Constraint.fold - (fun (l, d, r) g -> - let g = - if not (Level.is_small l || LSet.mem l ctx) then - try UGraph.add_universe l false g - with UGraph.AlreadyDeclared -> g - else g - in - let g = - if not (Level.is_small r || LSet.mem r ctx) then - try UGraph.add_universe r false g - with UGraph.AlreadyDeclared -> g - else g - in g) csts g - in - let g = Univ.Constraint.fold UGraph.enforce_constraint csts g in - UGraph.constraints_of_universes g - in - let noneqs = - Constraint.fold (fun (l,d,r as cstr) noneqs -> - if d == Eq then (UF.union l r uf; noneqs) - else (* We ignore the trivial Prop/Set <= i constraints. *) - if d == Le && Univ.Level.is_small l then noneqs - else if Univ.Level.is_prop l && d == Lt && Univ.Level.is_set r - then noneqs - else Constraint.add cstr noneqs) - csts Constraint.empty - in - let noneqs = Constraint.union noneqs smallles in - let partition = UF.partition uf in - let flex x = LMap.mem x us in - let ctx, us, eqs = List.fold_left (fun (ctx, us, cstrs) s -> - let canon, (global, rigid, flexible) = choose_canonical ctx flex algs s in - (* Add equalities for globals which can't be merged anymore. *) - let cstrs = LSet.fold (fun g cst -> - Constraint.add (canon, Univ.Eq, g) cst) global - cstrs - in - (* Also add equalities for rigid variables *) - let cstrs = LSet.fold (fun g cst -> - Constraint.add (canon, Univ.Eq, g) cst) rigid - cstrs - in - let canonu = Some (Universe.make canon) in - let us = LSet.fold (fun f -> LMap.add f canonu) flexible us in - (LSet.diff ctx flexible, us, cstrs)) - (ctx, us, Constraint.empty) partition - in - (* Process weak constraints: when one side is flexible and the 2 - universes are unrelated unify them. *) - let ctx, us, g = UPairSet.fold (fun (u,v) (ctx, us, g as acc) -> - let norm = let us = ref us in level_subst_of (normalize_univ_variable_opt_subst us) in - let u = norm u and v = norm v in - let set_to a b = - (LSet.remove a ctx, - LMap.add a (Some (Universe.make b)) us, - UGraph.enforce_constraint (a,Eq,b) g) - in - if UGraph.check_constraint g (u,Le,v) || UGraph.check_constraint g (v,Le,u) - then acc - else - if LMap.mem u us - then set_to u v - else if LMap.mem v us - then set_to v u - else acc) - weak (ctx, us, g) in - (* Noneqs is now in canonical form w.r.t. equality constraints, - and contains only inequality constraints. *) - let noneqs = - let us = ref us in - let norm = level_subst_of (normalize_univ_variable_opt_subst us) in - Constraint.fold (fun (u,d,v) noneqs -> - let u = norm u and v = norm v in - if d != Lt && Level.equal u v then noneqs - else Constraint.add (u,d,v) noneqs) - noneqs Constraint.empty - in - (* Compute the left and right set of flexible variables, constraints - mentionning other variables remain in noneqs. *) - let noneqs, ucstrsl, ucstrsr = - Constraint.fold (fun (l,d,r as cstr) (noneq, ucstrsl, ucstrsr) -> - let lus = LMap.mem l us and rus = LMap.mem r us in - let ucstrsl' = - if lus then add_list_map l (d, r) ucstrsl - else ucstrsl - and ucstrsr' = - add_list_map r (d, l) ucstrsr - in - let noneqs = - if lus || rus then noneq - else Constraint.add cstr noneq - in (noneqs, ucstrsl', ucstrsr')) - noneqs (Constraint.empty, LMap.empty, LMap.empty) - in - (* Now we construct the instantiation of each variable. *) - let ctx', us, algs, inst, noneqs = - minimize_univ_variables ctx us algs ucstrsr ucstrsl noneqs - in - let us = normalize_opt_subst us in - (us, algs), (ctx', Constraint.union noneqs eqs) - -(* let normalize_conkey = CProfile.declare_profile "normalize_context_set" *) -(* let normalize_context_set a b c = CProfile.profile3 normalize_conkey normalize_context_set a b c *) - -let is_trivial_leq (l,d,r) = - Univ.Level.is_prop l && (d == Univ.Le || (d == Univ.Lt && Univ.Level.is_set r)) - -(* Prop < i <-> Set+1 <= i <-> Set < i *) -let translate_cstr (l,d,r as cstr) = - if Level.equal Level.prop l && d == Univ.Lt && not (Level.equal Level.set r) then - (Level.set, d, r) - else cstr - -let refresh_constraints univs (ctx, cstrs) = - let cstrs', univs' = - Univ.Constraint.fold (fun c (cstrs', univs as acc) -> - let c = translate_cstr c in - if is_trivial_leq c then acc - else (Univ.Constraint.add c cstrs', UGraph.enforce_constraint c univs)) - cstrs (Univ.Constraint.empty, univs) - in ((ctx, cstrs'), univs') - - -(**********************************************************************) -(* Tools for sort-polymorphic inductive types *) - -(* Miscellaneous functions to remove or test local univ assumed to - occur only in the le constraints *) - -(* - Solve a system of universe constraint of the form - - u_s11, ..., u_s1p1, w1 <= u1 - ... - u_sn1, ..., u_snpn, wn <= un - -where - - - the ui (1 <= i <= n) are universe variables, - - the sjk select subsets of the ui for each equations, - - the wi are arbitrary complex universes that do not mention the ui. -*) +module Constraints = UnivProblem.Set +type 'a constraint_accumulator = 'a UnivProblem.accumulator +type 'a universe_constrained = 'a UnivProblem.constrained +type 'a universe_constraint_function = 'a UnivProblem.constraint_function +let subst_univs_universe_constraints = UnivProblem.Set.subst_univs +let enforce_eq_instances_univs = UnivProblem.enforce_eq_instances_univs +let to_constraints = UnivProblem.to_constraints +let eq_constr_univs_infer_with = UnivProblem.eq_constr_univs_infer_with -let is_direct_sort_constraint s v = match s with - | Some u -> univ_level_mem u v - | None -> false +(** UnivMinim *) +module UPairSet = UnivMinim.UPairSet -let solve_constraints_system levels level_bounds level_min = - let open Univ in - let levels = - Array.mapi (fun i o -> - match o with - | Some u -> - (match Universe.level u with - | Some u -> Some u - | _ -> level_bounds.(i) <- Universe.sup level_bounds.(i) u; None) - | None -> None) - levels in - let v = Array.copy level_bounds in - let nind = Array.length v in - let clos = Array.map (fun _ -> Int.Set.empty) levels in - (* First compute the transitive closure of the levels dependencies *) - for i=0 to nind-1 do - for j=0 to nind-1 do - if not (Int.equal i j) && is_direct_sort_constraint levels.(j) v.(i) then - clos.(i) <- Int.Set.add j clos.(i); - done; - done; - let rec closure () = - let continue = ref false in - Array.iteri (fun i deps -> - let deps' = - Int.Set.fold (fun j acc -> Int.Set.union acc clos.(j)) deps deps - in - if Int.Set.equal deps deps' then () - else (clos.(i) <- deps'; continue := true)) - clos; - if !continue then closure () - else () - in - closure (); - for i=0 to nind-1 do - for j=0 to nind-1 do - if not (Int.equal i j) && Int.Set.mem j clos.(i) then - (v.(i) <- Universe.sup v.(i) level_bounds.(j)); - done; - done; - v +let normalize_context_set = UnivMinim.normalize_context_set diff --git a/engine/universes.mli b/engine/universes.mli index 4823c5746..46ff33a47 100644 --- a/engine/universes.mli +++ b/engine/universes.mli @@ -8,227 +8,231 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) -open Util open Names open Constr open Environ open Univ -(** Unordered pairs of universe levels (ie (u,v) = (v,u)) *) -module UPairSet : CSet.S with type elt = (Level.t * Level.t) +(** ************************************** *) +(** This entire module is deprecated. **** *) +(** ************************************** *) +[@@@ocaml.warning "-3"] -val set_minimization : bool ref -val is_set_minimization : unit -> bool - -(** Universes *) +(** ****** Deprecated: moved to [UnivNames] *) val pr_with_global_universes : Level.t -> Pp.t +[@@ocaml.deprecated "Use [UnivNames.pr_with_global_universes]"] val reference_of_level : Level.t -> Libnames.reference +[@@ocaml.deprecated "Use [UnivNames.reference_of_level]"] -(** Global universe information outside the kernel, to handle - polymorphic universes in sections that have to be discharged. *) val add_global_universe : Level.t -> Decl_kinds.polymorphic -> unit +[@@ocaml.deprecated "Use [UnivNames.add_global_universe]"] val is_polymorphic : Level.t -> bool +[@@ocaml.deprecated "Use [UnivNames.is_polymorphic]"] -(** Local universe name <-> level mapping *) - -type universe_binders = Univ.Level.t Names.Id.Map.t +type universe_binders = UnivNames.universe_binders +[@@ocaml.deprecated "Use [UnivNames.universe_binders]"] val empty_binders : universe_binders +[@@ocaml.deprecated "Use [UnivNames.empty_binders]"] val register_universe_binders : Globnames.global_reference -> universe_binders -> unit +[@@ocaml.deprecated "Use [UnivNames.register_universe_binders]"] val universe_binders_of_global : Globnames.global_reference -> universe_binders +[@@ocaml.deprecated "Use [UnivNames.universe_binders_of_global]"] -type univ_name_list = Misctypes.lname list - -(** [universe_binders_with_opt_names ref u l] +type univ_name_list = UnivNames.univ_name_list +[@@ocaml.deprecated "Use [UnivNames.univ_name_list]"] - If [l] is [Some univs] return the universe binders naming the levels of [u] by [univs] (skipping Anonymous). - May error if the lengths mismatch. - - Otherwise return [universe_binders_of_global ref]. *) val universe_binders_with_opt_names : Globnames.global_reference -> Univ.Level.t list -> univ_name_list option -> universe_binders +[@@ocaml.deprecated "Use [UnivNames.universe_binders_with_opt_names]"] -(** The global universe counter *) -type universe_id = DirPath.t * int +(** ****** Deprecated: moved to [UnivGen] *) -val set_remote_new_univ_id : universe_id RemoteCounter.installer +type universe_id = UnivGen.universe_id +[@@ocaml.deprecated "Use [UnivGen.universe_id]"] -(** Side-effecting functions creating new universe levels. *) +val set_remote_new_univ_id : universe_id RemoteCounter.installer +[@@ocaml.deprecated "Use [UnivGen.set_remote_new_univ_id]"] val new_univ_id : unit -> universe_id +[@@ocaml.deprecated "Use [UnivGen.new_univ_id]"] + val new_univ_level : unit -> Level.t +[@@ocaml.deprecated "Use [UnivGen.new_univ_level]"] + val new_univ : unit -> Universe.t +[@@ocaml.deprecated "Use [UnivGen.new_univ]"] + val new_Type : unit -> types +[@@ocaml.deprecated "Use [UnivGen.new_Type]"] + val new_Type_sort : unit -> Sorts.t +[@@ocaml.deprecated "Use [UnivGen.new_Type_sort]"] val new_global_univ : unit -> Universe.t in_universe_context_set -val new_sort_in_family : Sorts.family -> Sorts.t - -(** {6 Constraints for type inference} - - When doing conversion of universes, not only do we have =/<= constraints but - also Lub constraints which correspond to unification of two levels which might - not be necessary if unfolding is performed. - - UWeak constraints come from irrelevant universes in cumulative polymorphism. -*) - -type universe_constraint = - | ULe of Universe.t * Universe.t - | UEq of Universe.t * Universe.t - | ULub of Level.t * Level.t - | UWeak of Level.t * Level.t - -module Constraints : sig - include Set.S with type elt = universe_constraint - - val is_trivial : universe_constraint -> bool - - val pr : t -> Pp.t -end - -type universe_constraints = Constraints.t -[@@ocaml.deprecated "Use Constraints.t"] - -type 'a constraint_accumulator = Constraints.t -> 'a -> 'a option -type 'a universe_constrained = 'a * Constraints.t -type 'a universe_constraint_function = 'a -> 'a -> Constraints.t -> Constraints.t +[@@ocaml.deprecated "Use [UnivGen.new_global_univ]"] -val subst_univs_universe_constraints : universe_subst_fn -> - Constraints.t -> Constraints.t - -val enforce_eq_instances_univs : bool -> Instance.t universe_constraint_function - -(** With [force_weak] UWeak constraints are turned into equalities, - otherwise they're forgotten. *) -val to_constraints : force_weak:bool -> UGraph.t -> Constraints.t -> Constraint.t - -(** [eq_constr_univs_infer_With kind1 kind2 univs m n] is a variant of - {!eq_constr_univs_infer} taking kind-of-term functions, to expose - subterms of [m] and [n], arguments. *) -val eq_constr_univs_infer_with : - (constr -> (constr, types, Sorts.t, Univ.Instance.t) kind_of_term) -> - (constr -> (constr, types, Sorts.t, Univ.Instance.t) kind_of_term) -> - UGraph.t -> 'a constraint_accumulator -> constr -> constr -> 'a -> 'a option - -(** Build a fresh instance for a given context, its associated substitution and - the instantiated constraints. *) +val new_sort_in_family : Sorts.family -> Sorts.t +[@@ocaml.deprecated "Use [UnivGen.new_sort_in_family]"] -val fresh_instance_from_context : AUContext.t -> +val fresh_instance_from_context : AUContext.t -> Instance.t constrained +[@@ocaml.deprecated "Use [UnivGen.fresh_instance_from_context]"] val fresh_instance_from : AUContext.t -> Instance.t option -> Instance.t in_universe_context_set +[@@ocaml.deprecated "Use [UnivGen.fresh_instance_from]"] -val fresh_sort_in_family : env -> Sorts.family -> +val fresh_sort_in_family : env -> Sorts.family -> Sorts.t in_universe_context_set +[@@ocaml.deprecated "Use [UnivGen.fresh_sort_in_family]"] + val fresh_constant_instance : env -> Constant.t -> pconstant in_universe_context_set +[@@ocaml.deprecated "Use [UnivGen.fresh_constant_instance]"] + val fresh_inductive_instance : env -> inductive -> pinductive in_universe_context_set +[@@ocaml.deprecated "Use [UnivGen.fresh_inductive_instance]"] + val fresh_constructor_instance : env -> constructor -> pconstructor in_universe_context_set +[@@ocaml.deprecated "Use [UnivGen.fresh_constructor_instance]"] -val fresh_global_instance : ?names:Univ.Instance.t -> env -> Globnames.global_reference -> +val fresh_global_instance : ?names:Univ.Instance.t -> env -> Globnames.global_reference -> constr in_universe_context_set +[@@ocaml.deprecated "Use [UnivGen.fresh_global_instance]"] -val fresh_global_or_constr_instance : env -> Globnames.global_reference_or_constr -> +val fresh_global_or_constr_instance : env -> Globnames.global_reference_or_constr -> constr in_universe_context_set +[@@ocaml.deprecated "Use [UnivGen.fresh_global_or_constr_instance]"] -(** Get fresh variables for the universe context. - Useful to make tactics that manipulate constrs in universe contexts polymorphic. *) -val fresh_universe_context_set_instance : ContextSet.t -> +val fresh_universe_context_set_instance : ContextSet.t -> universe_level_subst * ContextSet.t +[@@ocaml.deprecated "Use [UnivGen.fresh_universe_context_set_instance]"] -(** Raises [Not_found] if not a global reference. *) val global_of_constr : constr -> Globnames.global_reference puniverses +[@@ocaml.deprecated "Use [UnivGen.global_of_constr]"] val constr_of_global_univ : Globnames.global_reference puniverses -> constr +[@@ocaml.deprecated "Use [UnivGen.constr_of_global_univ]"] -val extend_context : 'a in_universe_context_set -> ContextSet.t -> +val extend_context : 'a in_universe_context_set -> ContextSet.t -> 'a in_universe_context_set +[@@ocaml.deprecated "Use [UnivGen.extend_context]"] -(** Simplification and pruning of constraints: - [normalize_context_set ctx us] +val constr_of_global : Globnames.global_reference -> constr +[@@ocaml.deprecated "Use [UnivGen.constr_of_global]"] - - Instantiate the variables in [us] with their most precise - universe levels respecting the constraints. +val constr_of_reference : Globnames.global_reference -> constr +[@@ocaml.deprecated "Use [UnivGen.constr_of_global]"] - - Normalizes the context [ctx] w.r.t. equality constraints, - choosing a canonical universe in each equivalence class - (a global one if there is one) and transitively saturate - the constraints w.r.t to the equalities. *) +val type_of_global : Globnames.global_reference -> types in_universe_context_set +[@@ocaml.deprecated "Use [UnivGen.type_of_global]"] -module UF : Unionfind.PartitionSig with type elt = Level.t +(** ****** Deprecated: moved to [UnivSubst] *) val level_subst_of : universe_subst_fn -> universe_level_subst_fn +[@@ocaml.deprecated "Use [UnivSubst.level_subst_of]"] + val subst_univs_constraints : universe_subst_fn -> Constraint.t -> Constraint.t +[@@ocaml.deprecated "Use [UnivSubst.subst_univs_constraints]"] val subst_univs_constr : universe_subst -> constr -> constr +[@@ocaml.deprecated "Use [UnivSubst.subst_univs_constr]"] -type universe_opt_subst = Universe.t option universe_map +type universe_opt_subst = UnivSubst.universe_opt_subst +[@@ocaml.deprecated "Use [UnivSubst.universe_opt_subst]"] val make_opt_subst : universe_opt_subst -> universe_subst_fn +[@@ocaml.deprecated "Use [UnivSubst.make_opt_subst]"] val subst_opt_univs_constr : universe_opt_subst -> constr -> constr +[@@ocaml.deprecated "Use [UnivSubst.subst_opt_univs_constr]"] -val normalize_context_set : UGraph.t -> ContextSet.t -> - universe_opt_subst (* The defined and undefined variables *) -> - LSet.t (* univ variables that can be substituted by algebraics *) -> - UPairSet.t (* weak equality constraints *) -> - (universe_opt_subst * LSet.t) in_universe_context_set - -val normalize_univ_variables : universe_opt_subst -> +val normalize_univ_variables : universe_opt_subst -> universe_opt_subst * LSet.t * LSet.t * universe_subst +[@@ocaml.deprecated "Use [UnivSubst.normalize_univ_variables]"] -val normalize_univ_variable : +val normalize_univ_variable : find:(Level.t -> Universe.t) -> - update:(Level.t -> Universe.t -> Universe.t) -> Level.t -> Universe.t +[@@ocaml.deprecated "Use [UnivSubst.normalize_univ_variable]"] -val normalize_univ_variable_opt_subst : universe_opt_subst ref -> +val normalize_univ_variable_opt_subst : universe_opt_subst -> (Level.t -> Universe.t) +[@@ocaml.deprecated "Use [UnivSubst.normalize_univ_variable_opt_subst]"] -val normalize_univ_variable_subst : universe_subst ref -> +val normalize_univ_variable_subst : universe_subst -> (Level.t -> Universe.t) +[@@ocaml.deprecated "Use [UnivSubst.normalize_univ_variable_subst]"] -val normalize_universe_opt_subst : universe_opt_subst ref -> +val normalize_universe_opt_subst : universe_opt_subst -> (Universe.t -> Universe.t) +[@@ocaml.deprecated "Use [UnivSubst.normalize_universe_opt_subst]"] -val normalize_universe_subst : universe_subst ref -> +val normalize_universe_subst : universe_subst -> (Universe.t -> Universe.t) +[@@ocaml.deprecated "Use [UnivSubst.normalize_universe_subst]"] -(** Create a fresh global in the global environment, without side effects. - BEWARE: this raises an ANOMALY on polymorphic constants/inductives: - the constraints should be properly added to an evd. - See Evd.fresh_global, Evarutil.new_global, and pf_constr_of_global for - the proper way to get a fresh copy of a global reference. *) -val constr_of_global : Globnames.global_reference -> constr +val nf_evars_and_universes_opt_subst : (existential -> constr option) -> + universe_opt_subst -> constr -> constr +[@@ocaml.deprecated "Use [UnivSubst.nf_evars_and_universes_opt_subst]"] -(** ** DEPRECATED ** synonym of [constr_of_global] *) -val constr_of_reference : Globnames.global_reference -> constr -[@@ocaml.deprecated "synonym of [constr_of_global]"] +val pr_universe_opt_subst : universe_opt_subst -> Pp.t +[@@ocaml.deprecated "Use [UnivSubst.pr_universe_opt_subst]"] -(** Returns the type of the global reference, by creating a fresh instance of polymorphic - references and computing their instantiated universe context. (side-effect on the - universe counter, use with care). *) -val type_of_global : Globnames.global_reference -> types in_universe_context_set +(** ****** Deprecated: moved to [UnivProblem] *) -(** Full universes substitutions into terms *) +type universe_constraint = UnivProblem.t = + | ULe of Universe.t * Universe.t [@ocaml.deprecated "Use [UnivProblem.ULe]"] + | UEq of Universe.t * Universe.t [@ocaml.deprecated "Use [UnivProblem.UEq]"] + | ULub of Level.t * Level.t [@ocaml.deprecated "Use [UnivProblem.ULub]"] + | UWeak of Level.t * Level.t [@ocaml.deprecated "Use [UnivProblem.UWeak]"] +[@@ocaml.deprecated "Use [UnivProblem.t]"] -val nf_evars_and_universes_opt_subst : (existential -> constr option) -> - universe_opt_subst -> constr -> constr +module Constraints = UnivProblem.Set +[@@ocaml.deprecated "Use [UnivProblem.Set]"] -val refresh_constraints : UGraph.t -> ContextSet.t -> ContextSet.t * UGraph.t +type 'a constraint_accumulator = 'a UnivProblem.accumulator +[@@ocaml.deprecated "Use [UnivProblem.accumulator]"] +type 'a universe_constrained = 'a UnivProblem.constrained +[@@ocaml.deprecated "Use [UnivProblem.constrained]"] +type 'a universe_constraint_function = 'a UnivProblem.constraint_function +[@@ocaml.deprecated "Use [UnivProblem.constraint_function]"] -(** Pretty-printing *) +val subst_univs_universe_constraints : universe_subst_fn -> + Constraints.t -> Constraints.t +[@@ocaml.deprecated "Use [UnivProblem.Set.subst_univs]"] -val pr_universe_opt_subst : universe_opt_subst -> Pp.t +val enforce_eq_instances_univs : bool -> Instance.t universe_constraint_function +[@@ocaml.deprecated "Use [UnivProblem.enforce_eq_instances_univs]"] -(** {6 Support for template polymorphism } *) +(** With [force_weak] UWeak constraints are turned into equalities, + otherwise they're forgotten. *) +val to_constraints : force_weak:bool -> UGraph.t -> Constraints.t -> Constraint.t +[@@ocaml.deprecated "Use [UnivProblem.to_constraints]"] -val solve_constraints_system : Universe.t option array -> Universe.t array -> Universe.t array -> - Universe.t array +(** [eq_constr_univs_infer_With kind1 kind2 univs m n] is a variant of + {!eq_constr_univs_infer} taking kind-of-term functions, to expose + subterms of [m] and [n], arguments. *) +val eq_constr_univs_infer_with : + (constr -> (constr, types, Sorts.t, Univ.Instance.t) kind_of_term) -> + (constr -> (constr, types, Sorts.t, Univ.Instance.t) kind_of_term) -> + UGraph.t -> 'a constraint_accumulator -> constr -> constr -> 'a -> 'a option +[@@ocaml.deprecated "Use [UnivProblem.eq_constr_univs_infer_with]"] + +(** ****** Deprecated: moved to [UnivMinim] *) + +module UPairSet = UnivMinim.UPairSet +[@@ocaml.deprecated "Use [UnivMinim.UPairSet]"] + +val normalize_context_set : UGraph.t -> ContextSet.t -> + universe_opt_subst (* The defined and undefined variables *) -> + LSet.t (* univ variables that can be substituted by algebraics *) -> + UPairSet.t (* weak equality constraints *) -> + (universe_opt_subst * LSet.t) in_universe_context_set +[@@ocaml.deprecated "Use [UnivMinim.normalize_context_set]"] diff --git a/engine/univops.ml b/engine/univops.ml index 76dbaa250..3fd518490 100644 --- a/engine/univops.ml +++ b/engine/univops.ml @@ -35,79 +35,14 @@ let universes_of_constr env c = | _ -> Constr.fold aux s c in aux LSet.empty c -type graphnode = { - mutable up : constraint_type LMap.t; - mutable visited : bool -} - -let merge_types d d0 = - match d, d0 with - | _, Lt | Lt, _ -> Lt - | Le, _ | _, Le -> Le - | Eq, Eq -> Eq - -let merge_up d b up = - let find = try Some (LMap.find b up) with Not_found -> None in - match find with - | Some d0 -> - let d = merge_types d d0 in - if d == d0 then up else LMap.add b d up - | None -> LMap.add b d up - -let add_up a d b graph = - let node, graph = - try LMap.find a graph, graph - with Not_found -> - let node = { up = LMap.empty; visited = false } in - node, LMap.add a node graph - in - node.up <- merge_up d b node.up; - graph - -(* for each node transitive close until you find a non removable, discard the rest *) -let transitive_close removable graph = - let rec do_node a node = - if not node.visited - then - let keepup = - LMap.fold (fun b d keepup -> - if not (LSet.mem b removable) - then merge_up d b keepup - else - begin - match LMap.find b graph with - | bnode -> - do_node b bnode; - LMap.fold (fun k d' keepup -> - merge_up (merge_types d d') k keepup) - bnode.up keepup - | exception Not_found -> keepup - end - ) - node.up LMap.empty - in - node.up <- keepup; - node.visited <- true - in - LMap.iter do_node graph - -let restrict_universe_context (univs,csts) keep = - let removable = LSet.diff univs keep in - let (csts, rem) = - Constraint.fold (fun (a,d,b as cst) (csts, rem) -> - if LSet.mem a removable || LSet.mem b removable - then (csts, add_up a d b rem) - else (Constraint.add cst csts, rem)) - csts (Constraint.empty, LMap.empty) - in - transitive_close removable rem; - let csts = - LMap.fold (fun a node csts -> - if LSet.mem a removable - then csts - else - LMap.fold (fun b d csts -> Constraint.add (a,d,b) csts) - node.up csts) - rem csts - in +let restrict_universe_context (univs, csts) keep = + let removed = LSet.diff univs keep in + if LSet.is_empty removed then univs, csts + else + let allunivs = Constraint.fold (fun (u,_,v) all -> LSet.add u (LSet.add v all)) csts univs in + let g = UGraph.empty_universes in + let g = LSet.fold UGraph.add_universe_unconstrained allunivs g in + let g = UGraph.merge_constraints csts g in + let allkept = LSet.diff allunivs removed in + let csts = UGraph.constraints_for ~kept:allkept g in (LSet.inter univs keep, csts) diff --git a/engine/univops.mli b/engine/univops.mli index d1585414c..0b37ab975 100644 --- a/engine/univops.mli +++ b/engine/univops.mli @@ -14,5 +14,8 @@ open Univ (** The universes of monomorphic constants appear. *) val universes_of_constr : Environ.env -> constr -> LSet.t -(** Shrink a universe context to a restricted set of variables *) +(** [restrict_universe_context (univs,csts) keep] restricts [univs] to + the universes in [keep]. The constraints [csts] are adjusted so + that transitive constraints between remaining universes (those in + [keep] and those not in [univs]) are preserved. *) val restrict_universe_context : ContextSet.t -> LSet.t -> ContextSet.t diff --git a/ide/utils/configwin.ml b/ide/configwin.ml index 69e8b647a..69e8b647a 100644 --- a/ide/utils/configwin.ml +++ b/ide/configwin.ml diff --git a/ide/utils/configwin.mli b/ide/configwin.mli index 7616e471d..7616e471d 100644 --- a/ide/utils/configwin.mli +++ b/ide/configwin.mli diff --git a/ide/utils/configwin_ihm.ml b/ide/configwin_ihm.ml index d16efa603..d16efa603 100644 --- a/ide/utils/configwin_ihm.ml +++ b/ide/configwin_ihm.ml diff --git a/ide/utils/configwin_ihm.mli b/ide/configwin_ihm.mli index c867ad912..c867ad912 100644 --- a/ide/utils/configwin_ihm.mli +++ b/ide/configwin_ihm.mli diff --git a/ide/utils/configwin_messages.ml b/ide/configwin_messages.ml index de1b4721d..de1b4721d 100644 --- a/ide/utils/configwin_messages.ml +++ b/ide/configwin_messages.ml diff --git a/ide/utils/configwin_types.mli b/ide/configwin_types.ml index 9e339d135..9e339d135 100644 --- a/ide/utils/configwin_types.mli +++ b/ide/configwin_types.ml diff --git a/ide/coq.ml b/ide/coq.ml index 65456d685..63986935a 100644 --- a/ide/coq.ml +++ b/ide/coq.ml @@ -152,7 +152,7 @@ let print_status = function let check_connection args = let lines = ref [] in let argstr = String.concat " " (List.map Filename.quote args) in - let cmd = Filename.quote (coqtop_path ()) ^ " -batch -ideslave " ^ argstr in + let cmd = Filename.quote (coqtop_path ()) ^ " -batch " ^ argstr in let cmd = requote cmd in try let oc,ic,ec = Unix.open_process_full cmd (Unix.environment ()) in @@ -377,7 +377,7 @@ let spawn_handle args respawner feedback_processor = else "on" in - let args = Array.of_list ("--xml_format=Ppcmds" :: "-async-proofs" :: async_default :: "-ideslave" :: args) in + let args = Array.of_list ("--xml_format=Ppcmds" :: "-async-proofs" :: async_default :: args) in let env = match !ideslave_coqtop_flags with | None -> None diff --git a/ide/coqOps.ml b/ide/coqOps.ml index 78fbce5c8..6c3438a4b 100644 --- a/ide/coqOps.ml +++ b/ide/coqOps.ml @@ -362,7 +362,12 @@ object(self) let query = Coq.query (route_id,(phrase,sid)) in Coq.bind (Coq.seq action query) next + method private still_valid { edit_id = id } = + try ignore(Doc.find_id document (fun _ { edit_id = id1 } -> id = id1)); true + with Not_found -> false + method private mark_as_needed sentence = + if self#still_valid sentence then begin Minilib.log_pp Pp.(str "Marking " ++ dbg_to_string buffer false None sentence); let start = buffer#get_iter_at_mark sentence.start in let stop = buffer#get_iter_at_mark sentence.stop in @@ -383,6 +388,7 @@ object(self) in List.iter (fun t -> buffer#remove_tag t ~start ~stop) all_tags; List.iter (fun t -> buffer#apply_tag t ~start ~stop) tags + end method private attach_tooltip ?loc sentence text = let start_sentence, stop_sentence, phrase = self#get_sentence sentence in diff --git a/ide/ide.mllib b/ide/ide.mllib index 96ea8c410..a7ade7130 100644 --- a/ide/ide.mllib +++ b/ide/ide.mllib @@ -9,15 +9,7 @@ Config_lexer Utf8_convert Preferences Project_file -Serialize -Richprinter -Xml_lexer -Xml_parser -Xml_printer -Serialize -Richpp Topfmt -Xmlprotocol Ideutils Coq Coq_lex diff --git a/ide/coqidetop.mllib b/ide/ide_common.mllib index df988d8f1..050c282ef 100644 --- a/ide/coqidetop.mllib +++ b/ide/ide_common.mllib @@ -5,4 +5,3 @@ Serialize Richpp Xmlprotocol Document -Ide_slave diff --git a/ide/ide_slave.ml b/ide/idetop.ml index 2e552b60b..ba69c4185 100644 --- a/ide/ide_slave.ml +++ b/ide/idetop.ml @@ -18,9 +18,8 @@ open Printer module NamedDecl = Context.Named.Declaration module CompactedDecl = Context.Compacted.Declaration -(** Ide_slave : an implementation of [Interface], i.e. mainly an interp - function and a rewind function. This specialized loop is triggered - when the -ideslave option is passed to Coqtop. *) +(** Idetop : an implementation of [Interface], i.e. mainly an interp + function and a rewind function. *) (** Signal handling: we postpone ^C during input and output phases, @@ -273,7 +272,10 @@ let status force = let export_coq_object t = { Interface.coq_object_prefix = t.Search.coq_object_prefix; Interface.coq_object_qualid = t.Search.coq_object_qualid; - Interface.coq_object_object = Pp.string_of_ppcmds (pr_lconstr_env (Global.env ()) Evd.empty t.Search.coq_object_object) + Interface.coq_object_object = + let env = Global.env () in + let sigma = Evd.from_env env in + Pp.string_of_ppcmds (pr_lconstr_env env sigma t.Search.coq_object_object) } let pattern_of_string ?env s = @@ -283,7 +285,7 @@ let pattern_of_string ?env s = | Some e -> e in let constr = Pcoq.parse_string Pcoq.Constr.lconstr_pattern s in - let (_, pat) = Constrintern.intern_constr_pattern env Evd.empty constr in + let (_, pat) = Constrintern.intern_constr_pattern env (Evd.from_env env) constr in pat let dirpath_of_string_list s = @@ -352,7 +354,6 @@ let about () = { } let handle_exn (e, info) = - let (e, info) = ExplainErr.process_vernac_interp_error (e, info) in let dummy = Stateid.dummy in let loc_of e = match Loc.get_loc e with | Some loc -> Some (Loc.unloc loc) @@ -430,7 +431,7 @@ let eval_call c = Xmlprotocol.abstract_eval_call handler c (** Message dispatching. - Since coqtop -ideslave starts 1 thread per slave, and each + Since [coqidetop] starts 1 thread per slave, and each thread forwards feedback messages from the slave to the GUI on the same xml channel, we need mutual exclusion. The mutex should be per-channel, but here we only use 1 channel. *) @@ -458,7 +459,7 @@ let msg_format = ref (fun () -> (* The loop ignores the command line arguments as the current model delegates its handing to the toplevel container. *) -let loop _args ~state = +let loop ~opts:_ ~state = let open Vernac.State in set_doc state.doc; init_signal_handler (); @@ -507,14 +508,16 @@ let rec parse = function | x :: rest -> x :: parse rest | [] -> [] -let () = Coqtop.toploop_init := (fun coq_args extra_args -> - let args = parse extra_args in - Flags.quiet := true; - CoqworkmgrApi.(init High); - args) - -let () = Coqtop.toploop_run := loop - let () = Usage.add_to_usage "coqidetop" " --xml_format=Ppcmds serialize pretty printing messages using the std_ppcmds format\ \n --help-XML-protocol print documentation of the Coq XML protocol\n" + +let islave_init ~opts extra_args = + let args = parse extra_args in + CoqworkmgrApi.(init High); + opts, args + +let () = + let open Coqtop in + let custom = { init = islave_init; run = loop; } in + start_coq custom diff --git a/ide/ideutils.ml b/ide/ideutils.ml index bdb39e94a..e96b99299 100644 --- a/ide/ideutils.ml +++ b/ide/ideutils.ml @@ -289,16 +289,10 @@ let coqtop_path () = | Some s -> s | None -> match cmd_coqtop#get with - | Some s -> s - | None -> - try - let old_prog = Sys.executable_name in - let pos = String.length old_prog - 6 in - let i = Str.search_backward (Str.regexp_string "coqide") old_prog pos - in - let new_prog = Bytes.of_string old_prog in - Bytes.blit_string "coqtop" 0 new_prog i 6; - let new_prog = Bytes.to_string new_prog in + | Some s -> s + | None -> + try + let new_prog = System.get_toplevel_path "coqidetop" in if Sys.file_exists new_prog then new_prog else let in_macos_bundle = @@ -306,8 +300,8 @@ let coqtop_path () = (Filename.dirname new_prog) (Filename.concat "../Resources/bin" (Filename.basename new_prog)) in if Sys.file_exists in_macos_bundle then in_macos_bundle - else "coqtop" - with Not_found -> "coqtop" + else "coqidetop" + with Not_found -> "coqidetop" in file (* In win32, when a command-line is to be executed via cmd.exe diff --git a/ide/protocol/ideprotocol.mllib b/ide/protocol/ideprotocol.mllib new file mode 100644 index 000000000..8317a0868 --- /dev/null +++ b/ide/protocol/ideprotocol.mllib @@ -0,0 +1,7 @@ +Xml_lexer +Xml_parser +Xml_printer +Serialize +Richpp +Interface +Xmlprotocol diff --git a/ide/interface.mli b/ide/protocol/interface.ml index debbc8301..debbc8301 100644 --- a/ide/interface.mli +++ b/ide/protocol/interface.ml diff --git a/ide/richpp.ml b/ide/protocol/richpp.ml index 19e9799c1..19e9799c1 100644 --- a/ide/richpp.ml +++ b/ide/protocol/richpp.ml diff --git a/ide/richpp.mli b/ide/protocol/richpp.mli index 31fc7b56f..31fc7b56f 100644 --- a/ide/richpp.mli +++ b/ide/protocol/richpp.mli diff --git a/ide/serialize.ml b/ide/protocol/serialize.ml index 86074d44d..86074d44d 100644 --- a/ide/serialize.ml +++ b/ide/protocol/serialize.ml diff --git a/ide/serialize.mli b/ide/protocol/serialize.mli index af082f25b..af082f25b 100644 --- a/ide/serialize.mli +++ b/ide/protocol/serialize.mli diff --git a/ide/xml_lexer.mli b/ide/protocol/xml_lexer.mli index e61cb055f..e61cb055f 100644 --- a/ide/xml_lexer.mli +++ b/ide/protocol/xml_lexer.mli diff --git a/ide/xml_lexer.mll b/ide/protocol/xml_lexer.mll index 4a52147e1..4a52147e1 100644 --- a/ide/xml_lexer.mll +++ b/ide/protocol/xml_lexer.mll diff --git a/ide/xml_parser.ml b/ide/protocol/xml_parser.ml index 8db3f9e8b..8db3f9e8b 100644 --- a/ide/xml_parser.ml +++ b/ide/protocol/xml_parser.ml diff --git a/ide/xml_parser.mli b/ide/protocol/xml_parser.mli index ac2eab352..ac2eab352 100644 --- a/ide/xml_parser.mli +++ b/ide/protocol/xml_parser.mli diff --git a/ide/xml_printer.ml b/ide/protocol/xml_printer.ml index 488ef7bf5..488ef7bf5 100644 --- a/ide/xml_printer.ml +++ b/ide/protocol/xml_printer.ml diff --git a/ide/xml_printer.mli b/ide/protocol/xml_printer.mli index 178f7c808..178f7c808 100644 --- a/ide/xml_printer.mli +++ b/ide/protocol/xml_printer.mli diff --git a/ide/xmlprotocol.ml b/ide/protocol/xmlprotocol.ml index e18219210..e18219210 100644 --- a/ide/xmlprotocol.ml +++ b/ide/protocol/xmlprotocol.ml diff --git a/ide/xmlprotocol.mli b/ide/protocol/xmlprotocol.mli index ba6000f0a..ba6000f0a 100644 --- a/ide/xmlprotocol.mli +++ b/ide/protocol/xmlprotocol.mli diff --git a/intf/constrexpr.ml b/interp/constrexpr.ml index fda31756a..d725f5afa 100644 --- a/intf/constrexpr.ml +++ b/interp/constrexpr.ml @@ -10,20 +10,27 @@ open Names open Libnames -open Misctypes open Decl_kinds (** {6 Concrete syntax for terms } *) (** [constr_expr] is the abstract syntax tree produced by the parser *) - -type universe_decl_expr = (lident list, glob_constraint list) gen_universe_decl +type universe_decl_expr = (lident list, Glob_term.glob_constraint list) UState.gen_universe_decl type ident_decl = lident * universe_decl_expr option type name_decl = lname * universe_decl_expr option type notation = string +type 'a or_by_notation_r = + | AN of 'a + | ByNotation of (string * string option) + +type 'a or_by_notation = 'a or_by_notation_r CAst.t + +(* NB: the last string in [ByNotation] is actually a [Notation.delimiters], + but this formulation avoids a useless dependency. *) + type explicitation = | ExplByPos of int * Id.t option (* a reference to the n-th product starting from left *) | ExplByName of Id.t @@ -50,7 +57,7 @@ type prim_token = | Numeral of raw_natural_number * sign | String of string -type instance_expr = Misctypes.glob_level list +type instance_expr = Glob_term.glob_level list type cases_pattern_expr_r = | CPatAlias of cases_pattern_expr * lname @@ -95,11 +102,11 @@ and constr_expr_r = constr_expr * constr_expr | CIf of constr_expr * (lname option * constr_expr option) * constr_expr * constr_expr - | CHole of Evar_kinds.t option * intro_pattern_naming_expr * Genarg.raw_generic_argument option - | CPatVar of patvar + | CHole of Evar_kinds.t option * Namegen.intro_pattern_naming_expr * Genarg.raw_generic_argument option + | CPatVar of Pattern.patvar | CEvar of Glob_term.existential_name * (Id.t * constr_expr) list - | CSort of glob_sort - | CCast of constr_expr * constr_expr cast_type + | CSort of Glob_term.glob_sort + | CCast of constr_expr * constr_expr Glob_term.cast_type | CNotation of notation * constr_notation_substitution | CGeneralization of binding_kind * abstraction_kind option * constr_expr | CPrim of prim_token diff --git a/interp/constrexpr_ops.ml b/interp/constrexpr_ops.ml index 4ee13c961..d626630ef 100644 --- a/interp/constrexpr_ops.ml +++ b/interp/constrexpr_ops.ml @@ -14,8 +14,9 @@ open CAst open Names open Nameops open Libnames +open Namegen +open Glob_term open Constrexpr -open Misctypes open Decl_kinds (***********************) @@ -161,7 +162,7 @@ let rec constr_expr_eq e1 e2 = | CEvar (id1, c1), CEvar (id2, c2) -> Id.equal id1 id2 && List.equal instance_eq c1 c2 | CSort s1, CSort s2 -> - Miscops.glob_sort_eq s1 s2 + Glob_ops.glob_sort_eq s1 s2 | CCast(t1,c1), CCast(t2,c2) -> constr_expr_eq t1 t2 && cast_expr_eq c1 c2 | CNotation(n1, s1), CNotation(n2, s2) -> @@ -395,7 +396,7 @@ let map_constr_expr_with_binders g f e = CAst.map (function let (e,bl) = map_local_binders f g e bl in CLambdaN (bl,f e b) | CLetIn (na,a,t,b) -> CLetIn (na,f e a,Option.map (f e) t,f (Name.fold_right g (na.CAst.v) e) b) - | CCast (a,c) -> CCast (f e a, Miscops.map_cast_type (f e) c) + | CCast (a,c) -> CCast (f e a, Glob_ops.map_cast_type (f e) c) | CNotation (n,(l,ll,bl,bll)) -> (* This is an approximation because we don't know what binds what *) CNotation (n,(List.map (f e) l,List.map (List.map (f e)) ll, bl, @@ -545,7 +546,7 @@ let coerce_to_id = function let coerce_to_name = function | { CAst.loc; v = CRef ({v=Ident id},None) } -> CAst.make ?loc @@ Name id - | { CAst.loc; v = CHole (None,Misctypes.IntroAnonymous,None) } -> CAst.make ?loc Anonymous + | { CAst.loc; v = CHole (None,IntroAnonymous,None) } -> CAst.make ?loc Anonymous | { CAst.loc; _ } -> CErrors.user_err ?loc ~hdr:"coerce_to_name" (str "This expression should be a name.") @@ -569,7 +570,7 @@ let mkAppPattern ?loc p lp = let rec coerce_to_cases_pattern_expr c = CAst.map_with_loc (fun ?loc -> function | CRef (r,None) -> CPatAtom (Some r) - | CHole (None,Misctypes.IntroAnonymous,None) -> + | CHole (None,IntroAnonymous,None) -> CPatAtom None | CLetIn ({CAst.loc;v=Name id},b,None,{ CAst.v = CRef ({v=Ident id'},None) }) when Id.equal id id' -> CPatAlias (coerce_to_cases_pattern_expr b, CAst.(make ?loc @@ Name id)) @@ -601,7 +602,34 @@ let _ = Goptions.declare_bool_option { Goptions.optwrite = (fun a -> asymmetric_patterns:=a); } -(************************************************************************) -(* Deprecated *) -let abstract_constr_expr c bl = mkCLambdaN ?loc:(local_binders_loc bl) bl c -let prod_constr_expr c bl = mkCProdN ?loc:(local_binders_loc bl) bl c +(** Local universe and constraint declarations. *) + +let interp_univ_constraints env evd cstrs = + let interp (evd,cstrs) (u, d, u') = + let ul = Pretyping.interp_known_glob_level evd u in + let u'l = Pretyping.interp_known_glob_level evd u' in + let cstr = (ul,d,u'l) in + let cstrs' = Univ.Constraint.add cstr cstrs in + try let evd = Evd.add_constraints evd (Univ.Constraint.singleton cstr) in + evd, cstrs' + with Univ.UniverseInconsistency e -> + CErrors.user_err ~hdr:"interp_constraint" + (Univ.explain_universe_inconsistency (Termops.pr_evd_level evd) e) + in + List.fold_left interp (evd,Univ.Constraint.empty) cstrs + +let interp_univ_decl env decl = + let open UState in + let pl : lident list = decl.univdecl_instance in + let evd = Evd.from_ctx (UState.make_with_initial_binders (Environ.universes env) pl) in + let evd, cstrs = interp_univ_constraints env evd decl.univdecl_constraints in + let decl = { univdecl_instance = pl; + univdecl_extensible_instance = decl.univdecl_extensible_instance; + univdecl_constraints = cstrs; + univdecl_extensible_constraints = decl.univdecl_extensible_constraints } + in evd, decl + +let interp_univ_decl_opt env l = + match l with + | None -> Evd.from_env env, UState.default_univ_decl + | Some decl -> interp_univ_decl env decl diff --git a/interp/constrexpr_ops.mli b/interp/constrexpr_ops.mli index d038bd71a..1c2348457 100644 --- a/interp/constrexpr_ops.mli +++ b/interp/constrexpr_ops.mli @@ -10,7 +10,6 @@ open Names open Libnames -open Misctypes open Constrexpr (** Constrexpr_ops: utilities on [constr_expr] *) @@ -44,7 +43,7 @@ val local_binders_loc : local_binder_expr list -> Loc.t option val mkIdentC : Id.t -> constr_expr val mkRefC : reference -> constr_expr val mkAppC : constr_expr * constr_expr list -> constr_expr -val mkCastC : constr_expr * constr_expr cast_type -> constr_expr +val mkCastC : constr_expr * constr_expr Glob_term.cast_type -> constr_expr val mkLambdaC : lname list * binder_kind * constr_expr * constr_expr -> constr_expr val mkLetInC : lname * constr_expr * constr_expr option * constr_expr -> constr_expr val mkProdC : lname list * binder_kind * constr_expr * constr_expr -> constr_expr @@ -60,14 +59,6 @@ val mkCPatOr : ?loc:Loc.t -> cases_pattern_expr list -> cases_pattern_expr val mkAppPattern : ?loc:Loc.t -> cases_pattern_expr -> cases_pattern_expr list -> cases_pattern_expr (** Apply a list of pattern arguments to a pattern *) -(** @deprecated variant of mkCLambdaN *) -val abstract_constr_expr : constr_expr -> local_binder_expr list -> constr_expr -[@@ocaml.deprecated "deprecated variant of mkCLambdaN"] - -(** @deprecated variant of mkCProdN *) -val prod_constr_expr : constr_expr -> local_binder_expr list -> constr_expr -[@@ocaml.deprecated "deprecated variant of mkCProdN"] - (** {6 Destructors}*) val coerce_reference_to_id : reference -> Id.t @@ -124,3 +115,10 @@ val error_invalid_pattern_notation : ?loc:Loc.t -> unit -> 'a (** Placeholder for global option, should be moved to a parameter *) val asymmetric_patterns : bool ref + +(** Local universe and constraint declarations. *) +val interp_univ_decl : Environ.env -> universe_decl_expr -> + Evd.evar_map * UState.universe_decl + +val interp_univ_decl_opt : Environ.env -> universe_decl_expr option -> + Evd.evar_map * UState.universe_decl diff --git a/interp/constrextern.ml b/interp/constrextern.ml index bb5fd5294..c613effcd 100644 --- a/interp/constrextern.ml +++ b/interp/constrextern.ml @@ -17,6 +17,7 @@ open Nameops open Termops open Libnames open Globnames +open Namegen open Impargs open CAst open Constrexpr @@ -28,7 +29,6 @@ open Pattern open Nametab open Notation open Detyping -open Misctypes open Decl_kinds module NamedDecl = Context.Named.Declaration @@ -478,7 +478,8 @@ and extern_notation_pattern (tmp_scope,scopes as allscopes) vars t = function if is_inactive_rule keyrule then raise No_match; let loc = t.loc in match DAst.get t with - | PatCstr (cstr,_,na) -> + | PatCstr (cstr,args,na) -> + let t = if na = Anonymous then t else DAst.make ?loc (PatCstr (cstr,args,Anonymous)) in let p = apply_notation_to_pattern ?loc (ConstructRef cstr) (match_notation_constr_cases_pattern t pat) allscopes vars keyrule in insert_pat_alias ?loc p na @@ -719,7 +720,7 @@ let extended_glob_local_binder_of_decl loc = function | (p,bk,None,t) -> GLocalAssum (p,bk,t) | (p,bk,Some x, t) -> match DAst.get t with - | GHole (_, Misctypes.IntroAnonymous, None) -> GLocalDef (p,bk,x,None) + | GHole (_, IntroAnonymous, None) -> GLocalDef (p,bk,x,None) | _ -> GLocalDef (p,bk,x,Some t) let extended_glob_local_binder_of_decl ?loc u = DAst.make ?loc (extended_glob_local_binder_of_decl loc u) @@ -754,13 +755,13 @@ let rec extern inctx scopes vars r = | GVar id -> CRef (make ?loc @@ Ident id,None) - | GEvar (n,[]) when !print_meta_as_hole -> CHole (None, Misctypes.IntroAnonymous, None) + | GEvar (n,[]) when !print_meta_as_hole -> CHole (None, IntroAnonymous, None) | GEvar (n,l) -> extern_evar n (List.map (on_snd (extern false scopes vars)) l) | GPatVar kind -> - if !print_meta_as_hole then CHole (None, Misctypes.IntroAnonymous, None) else + if !print_meta_as_hole then CHole (None, IntroAnonymous, None) else (match kind with | Evar_kinds.SecondOrderPatVar n -> CPatVar n | Evar_kinds.FirstOrderPatVar n -> CEvar (n,[])) @@ -916,7 +917,7 @@ let rec extern inctx scopes vars r = | GCast (c, c') -> CCast (sub_extern true scopes vars c, - Miscops.map_cast_type (extern_typ scopes vars) c') + map_cast_type (extern_typ scopes vars) c') | GProj (p, c) -> let pr = extern_reference ?loc Id.Set.empty (ConstRef (Projection.constant p)) in CProj (pr, sub_extern inctx scopes vars c) @@ -930,7 +931,7 @@ and sub_extern inctx (_,scopes) = extern inctx (None,scopes) and factorize_prod scopes vars na bk aty c = let store, get = set_temporary_memory () in match na, DAst.get c with - | Name id, GCases (LetPatternStyle, None, [(e,(Anonymous,None))],(_::_ as eqns)) + | Name id, GCases (Constr.LetPatternStyle, None, [(e,(Anonymous,None))],(_::_ as eqns)) when is_gvar id e && List.length (store (factorize_eqns eqns)) = 1 -> (match get () with | [{CAst.v=(ids,disj_of_patl,b)}] -> @@ -958,7 +959,7 @@ and factorize_prod scopes vars na bk aty c = and factorize_lambda inctx scopes vars na bk aty c = let store, get = set_temporary_memory () in match na, DAst.get c with - | Name id, GCases (LetPatternStyle, None, [(e,(Anonymous,None))],(_::_ as eqns)) + | Name id, GCases (Constr.LetPatternStyle, None, [(e,(Anonymous,None))],(_::_ as eqns)) when is_gvar id e && List.length (store (factorize_eqns eqns)) = 1 -> (match get () with | [{CAst.v=(ids,disj_of_patl,b)}] -> @@ -1159,7 +1160,7 @@ let extern_closed_glob ?lax goal_concl_style env sigma t = let any_any_branch = (* | _ => _ *) - CAst.make ([],[DAst.make @@ PatVar Anonymous], DAst.make @@ GHole (Evar_kinds.InternalHole,Misctypes.IntroAnonymous,None)) + CAst.make ([],[DAst.make @@ PatVar Anonymous], DAst.make @@ GHole (Evar_kinds.InternalHole,IntroAnonymous,None)) let compute_displayed_name_in_pattern sigma avoid na c = let open Namegen in @@ -1183,7 +1184,7 @@ let rec glob_of_pat avoid env sigma pat = DAst.make @@ match pat with anomaly ~label:"glob_constr_of_pattern" (Pp.str "index to an anonymous variable.") with Not_found -> Id.of_string ("_UNBOUND_REL_"^(string_of_int n)) in GVar id - | PMeta None -> GHole (Evar_kinds.InternalHole, Misctypes.IntroAnonymous,None) + | PMeta None -> GHole (Evar_kinds.InternalHole, IntroAnonymous,None) | PMeta (Some n) -> GPatVar (Evar_kinds.FirstOrderPatVar n) | PProj (p,c) -> GApp (DAst.make @@ GRef (ConstRef (Projection.constant p),None), [glob_of_pat avoid env sigma c]) @@ -1208,7 +1209,7 @@ let rec glob_of_pat avoid env sigma pat = DAst.make @@ match pat with | PIf (c,b1,b2) -> GIf (glob_of_pat avoid env sigma c, (Anonymous,None), glob_of_pat avoid env sigma b1, glob_of_pat avoid env sigma b2) - | PCase ({cip_style=LetStyle; cip_ind_tags=None},PMeta None,tm,[(0,n,b)]) -> + | PCase ({cip_style=Constr.LetStyle; cip_ind_tags=None},PMeta None,tm,[(0,n,b)]) -> let nal,b = it_destRLambda_or_LetIn_names n (glob_of_pat avoid env sigma b) in GLetTuple (nal,(Anonymous,None),glob_of_pat avoid env sigma tm,b) | PCase (info,p,tm,bl) -> @@ -1227,7 +1228,7 @@ let rec glob_of_pat avoid env sigma pat = DAst.make @@ match pat with return_type_of_predicate ind nargs (glob_of_pat avoid env sigma p) | _ -> anomaly (Pp.str "PCase with non-trivial predicate but unknown inductive.") in - GCases (RegularStyle,rtn,[glob_of_pat avoid env sigma tm,indnames],mat) + GCases (Constr.RegularStyle,rtn,[glob_of_pat avoid env sigma tm,indnames],mat) | PFix ((ln,i),(lna,tl,bl)) -> let def_avoid, def_env, lfi = Array.fold_left diff --git a/interp/constrextern.mli b/interp/constrextern.mli index 8ab70283c..73c108319 100644 --- a/interp/constrextern.mli +++ b/interp/constrextern.mli @@ -13,13 +13,11 @@ open Termops open EConstr open Environ open Libnames -open Globnames open Glob_term open Pattern open Constrexpr open Notation_term open Notation -open Misctypes open Ltac_pretype (** Translation of pattern, cases pattern, glob_constr and term into syntax @@ -40,7 +38,7 @@ val extern_closed_glob : ?lax:bool -> bool -> env -> Evd.evar_map -> closed_glob val extern_constr : ?lax:bool -> bool -> env -> Evd.evar_map -> constr -> constr_expr val extern_constr_in_scope : bool -> scope_name -> env -> Evd.evar_map -> constr -> constr_expr -val extern_reference : ?loc:Loc.t -> Id.Set.t -> global_reference -> reference +val extern_reference : ?loc:Loc.t -> Id.Set.t -> GlobRef.t -> reference val extern_type : bool -> env -> Evd.evar_map -> types -> constr_expr val extern_sort : Evd.evar_map -> Sorts.t -> glob_sort val extern_rel_context : constr option -> env -> Evd.evar_map -> @@ -58,9 +56,9 @@ val print_projections : bool ref (** Customization of the global_reference printer *) val set_extern_reference : - (?loc:Loc.t -> Id.Set.t -> global_reference -> reference) -> unit + (?loc:Loc.t -> Id.Set.t -> GlobRef.t -> reference) -> unit val get_extern_reference : - unit -> (?loc:Loc.t -> Id.Set.t -> global_reference -> reference) + unit -> (?loc:Loc.t -> Id.Set.t -> GlobRef.t -> reference) (** WARNING: The following functions are evil due to side-effects. Think of the following case as used in the printer: diff --git a/interp/constrintern.ml b/interp/constrintern.ml index f2cd07c94..d7345b701 100644 --- a/interp/constrintern.ml +++ b/interp/constrintern.ml @@ -15,6 +15,7 @@ open CAst open Names open Nameops open Namegen +open Constr open Libnames open Globnames open Impargs @@ -393,7 +394,7 @@ let intern_generalized_binder ?(global_level=false) intern_type ntnvars env fvs in let bl = List.map CAst.(map (fun id -> - (Name id, b, DAst.make ?loc @@ GHole (Evar_kinds.BinderType (Name id), Misctypes.IntroAnonymous, None)))) + (Name id, b, DAst.make ?loc @@ GHole (Evar_kinds.BinderType (Name id), IntroAnonymous, None)))) fvs in let na = match na with @@ -430,10 +431,10 @@ let glob_local_binder_of_extended = DAst.with_loc_val (fun ?loc -> function | GLocalAssum (na,bk,t) -> (na,bk,None,t) | GLocalDef (na,bk,c,Some t) -> (na,bk,Some c,t) | GLocalDef (na,bk,c,None) -> - let t = DAst.make ?loc @@ GHole(Evar_kinds.BinderType na,Misctypes.IntroAnonymous,None) in + let t = DAst.make ?loc @@ GHole(Evar_kinds.BinderType na,IntroAnonymous,None) in (na,bk,Some c,t) | GLocalPattern (_,_,_,_) -> - Loc.raise ?loc (Stream.Error "pattern with quote not allowed here.") + Loc.raise ?loc (Stream.Error "pattern with quote not allowed here") ) let intern_cases_pattern_fwd = ref (fun _ -> failwith "intern_cases_pattern_fwd") @@ -471,7 +472,7 @@ let intern_local_binder_aux ?(global_level=false) intern ntnvars (env,bl) = func let tyc = match ty with | Some ty -> ty - | None -> CAst.make ?loc @@ CHole(None,Misctypes.IntroAnonymous,None) + | None -> CAst.make ?loc @@ CHole(None,IntroAnonymous,None) in let env, ((disjpat,il),id),na = intern_cases_pattern_as_binder ?loc ntnvars env p in let bk = Default Explicit in @@ -501,11 +502,11 @@ let intern_generalization intern env ntnvars loc bk ak c = if pi then (fun {loc=loc';v=id} acc -> DAst.make ?loc:(Loc.merge_opt loc' loc) @@ - GProd (Name id, bk, DAst.make ?loc:loc' @@ GHole (Evar_kinds.BinderType (Name id), Misctypes.IntroAnonymous, None), acc)) + GProd (Name id, bk, DAst.make ?loc:loc' @@ GHole (Evar_kinds.BinderType (Name id), IntroAnonymous, None), acc)) else (fun {loc=loc';v=id} acc -> DAst.make ?loc:(Loc.merge_opt loc' loc) @@ - GLambda (Name id, bk, DAst.make ?loc:loc' @@ GHole (Evar_kinds.BinderType (Name id), Misctypes.IntroAnonymous, None), acc)) + GLambda (Name id, bk, DAst.make ?loc:loc' @@ GHole (Evar_kinds.BinderType (Name id), IntroAnonymous, None), acc)) in List.fold_right (fun ({loc;v=id} as lid) (env, acc) -> let env' = push_name_env ntnvars (Variable,[],[],[]) env CAst.(make @@ Name id) in @@ -525,7 +526,7 @@ let rec expand_binders ?loc mk bl c = let tm = DAst.make ?loc (GVar id) in (* Distribute the disjunctive patterns over the shared right-hand side *) let eqnl = List.map (fun pat -> CAst.make ?loc (ids,[pat],c)) disjpat in - let c = DAst.make ?loc @@ GCases (Misctypes.LetPatternStyle, None, [tm,(Anonymous,None)], eqnl) in + let c = DAst.make ?loc @@ GCases (LetPatternStyle, None, [tm,(Anonymous,None)], eqnl) in expand_binders ?loc mk bl (mk ?loc (Name id,Explicit,ty) c) (**********************************************************************) @@ -563,7 +564,7 @@ let term_of_name = function | Name id -> DAst.make (GVar id) | Anonymous -> let st = Evar_kinds.Define (not (Program.get_proofs_transparency ())) in - DAst.make (GHole (Evar_kinds.QuestionMark (st,Anonymous), Misctypes.IntroAnonymous, None)) + DAst.make (GHole (Evar_kinds.QuestionMark (st,Anonymous), IntroAnonymous, None)) let traverse_binder intern_pat ntnvars (terms,_,binders,_ as subst) avoid (renaming,env) = function | Anonymous -> (renaming,env), None, Anonymous @@ -605,7 +606,7 @@ let traverse_binder intern_pat ntnvars (terms,_,binders,_ as subst) avoid (renam (renaming',env), None, Name id' type binder_action = -| AddLetIn of Misctypes.lname * constr_expr * constr_expr option +| AddLetIn of lname * constr_expr * constr_expr option | AddTermIter of (constr_expr * subscopes) Names.Id.Map.t | AddPreBinderIter of Id.t * local_binder_expr (* A binder to be internalized *) | AddBinderIter of Id.t * extended_glob_local_binder (* A binder already internalized - used for generalized binders *) @@ -625,7 +626,7 @@ let terms_of_binders bl = | PatVar (Anonymous) -> error_cannot_coerce_wildcard_term ?loc () | PatCstr (c,l,_) -> let r = make ?loc @@ Qualid (qualid_of_path (path_of_global (ConstructRef c))) in - let hole = CAst.make ?loc @@ CHole (None,Misctypes.IntroAnonymous,None) in + let hole = CAst.make ?loc @@ CHole (None,IntroAnonymous,None) in let params = List.make (Inductiveops.inductive_nparams (fst c)) hole in CAppExpl ((None,r,None),params @ List.map term_of_pat l)) pt in let rec extract_variables l = match l with @@ -819,11 +820,11 @@ let split_by_type ids subst = | NtnTypeConstr -> let terms,terms' = bind id scl terms terms' in (terms,termlists,binders,binderlists),(terms',termlists',binders',binderlists') - | NtnTypeBinder NtnBinderParsedAsConstr (Extend.AsIdentOrPattern | Extend.AsStrictPattern) -> + | NtnTypeBinder NtnBinderParsedAsConstr (AsIdentOrPattern | AsStrictPattern) -> let a,terms = match terms with a::terms -> a,terms | _ -> assert false in let binders' = Id.Map.add id (coerce_to_cases_pattern_expr a,(false,scl)) binders' in (terms,termlists,binders,binderlists),(terms',termlists',binders',binderlists') - | NtnTypeBinder NtnBinderParsedAsConstr Extend.AsIdent -> + | NtnTypeBinder NtnBinderParsedAsConstr AsIdent -> let a,terms = match terms with a::terms -> a,terms | _ -> assert false in let binders' = Id.Map.add id (cases_pattern_of_name (coerce_to_name a),(true,scl)) binders' in (terms,termlists,binders,binderlists),(terms',termlists',binders',binderlists') @@ -980,25 +981,28 @@ let intern_reference ref = in Smartlocate.global_of_extended_global r -let sort_info_of_level_info (info: Misctypes.level_info) : (Libnames.reference * int) option = +let sort_info_of_level_info (info: level_info) : (Libnames.reference * int) option = match info with - | Misctypes.UAnonymous -> None - | Misctypes.UUnknown -> None - | Misctypes.UNamed id -> Some (id, 0) + | UAnonymous -> None + | UUnknown -> None + | UNamed id -> Some (id, 0) -let glob_sort_of_level (level: Misctypes.glob_level) : Misctypes.glob_sort = +let glob_sort_of_level (level: glob_level) : glob_sort = match level with - | Misctypes.GProp -> Misctypes.GProp - | Misctypes.GSet -> Misctypes.GSet - | Misctypes.GType info -> Misctypes.GType [sort_info_of_level_info info] + | GProp -> GProp + | GSet -> GSet + | GType info -> GType [sort_info_of_level_info info] (* Is it a global reference or a syntactic definition? *) -let intern_qualid qid intern env ntnvars us args = +let intern_qualid ?(no_secvar=false) qid intern env ntnvars us args = let loc = qid.loc in match intern_extended_global_of_qualid qid with + | TrueGlobal (VarRef _) when no_secvar -> + (* Rule out section vars since these should have been found by intern_var *) + raise Not_found | TrueGlobal ref -> (DAst.make ?loc @@ GRef (ref, us)), true, args | SynDef sp -> - let (ids,c) = Syntax_def.search_syntactic_definition sp in + let (ids,c) = Syntax_def.search_syntactic_definition ?loc sp in let nids = List.length ids in if List.length args < nids then error_not_enough_arguments ?loc; let args1,args2 = List.chop nids args in @@ -1024,7 +1028,7 @@ let intern_qualid qid intern env ntnvars us args = DAst.make ?loc @@ GApp (DAst.make ?loc:loc' @@ GRef (ref, us), arg) | _ -> err () end - | Some [s], GSort (Misctypes.GType []) -> DAst.make ?loc @@ GSort (glob_sort_of_level s) + | Some [s], GSort (GType []) -> DAst.make ?loc @@ GSort (glob_sort_of_level s) | Some [_old_level], GSort _new_sort -> (* TODO: add old_level and new_sort to the error message *) user_err ?loc (str "Cannot change universe level of notation " ++ pr_qualid qid.v) @@ -1032,13 +1036,6 @@ let intern_qualid qid intern env ntnvars us args = in c, projapp, args2 -(* Rule out section vars since these should have been found by intern_var *) -let intern_non_secvar_qualid qid intern env ntnvars us args = - let c, _, _ as r = intern_qualid qid intern env ntnvars us args in - match DAst.get c with - | GRef (VarRef _, _) -> raise Not_found - | _ -> r - let intern_applied_reference intern env namedctx (_, ntnvars as lvar) us args = function | {loc; v=Qualid qid} -> @@ -1054,7 +1051,7 @@ function with Not_found -> let qid = make ?loc @@ qualid_of_ident id in try - let r, projapp, args2 = intern_non_secvar_qualid qid intern env ntnvars us args in + let r, projapp, args2 = intern_qualid ~no_secvar:true qid intern env ntnvars us args in let x, imp, scopes, l = find_appl_head_data r in (x,imp,scopes,l), args2 with Not_found -> @@ -1076,11 +1073,11 @@ let interp_reference vars r = (** Private internalization patterns *) type 'a raw_cases_pattern_expr_r = - | RCPatAlias of 'a raw_cases_pattern_expr * Misctypes.lname - | RCPatCstr of Globnames.global_reference + | RCPatAlias of 'a raw_cases_pattern_expr * lname + | RCPatCstr of GlobRef.t * 'a raw_cases_pattern_expr list * 'a raw_cases_pattern_expr list (** [RCPatCstr (loc, c, l1, l2)] represents [((@ c l1) l2)] *) - | RCPatAtom of (Misctypes.lident * (Notation_term.tmp_scope_name option * Notation_term.scope_name list)) option + | RCPatAtom of (lident * (Notation_term.tmp_scope_name option * Notation_term.scope_name list)) option | RCPatOr of 'a raw_cases_pattern_expr list and 'a raw_cases_pattern_expr = ('a raw_cases_pattern_expr_r, 'a) DAst.t @@ -1140,9 +1137,18 @@ let check_number_of_pattern loc n l = if not (Int.equal n p) then raise (InternalizationError (loc,BadPatternsNumber (n,p))) let check_or_pat_variables loc ids idsl = - if List.exists (fun ids' -> not (List.eq_set (fun {loc;v=id} {v=id'} -> Id.equal id id') ids ids')) idsl then - user_err ?loc (str - "The components of this disjunctive pattern must bind the same variables.") + let eq_id {v=id} {v=id'} = Id.equal id id' in + (* Collect remaining patterns which do not have the same variables as the first pattern *) + let idsl = List.filter (fun ids' -> not (List.eq_set eq_id ids ids')) idsl in + match idsl with + | ids'::_ -> + (* Look for an [id] which is either in [ids] and not in [ids'] or in [ids'] and not in [ids] *) + let ids'' = List.subtract eq_id ids ids' in + let ids'' = if ids'' = [] then List.subtract eq_id ids' ids else ids'' in + user_err ?loc + (strbrk "The components of this disjunctive pattern must bind the same variables (" ++ + Id.print (List.hd ids'').v ++ strbrk " is not bound in all patterns).") + | [] -> () (** Use only when params were NOT asked to the user. @return if letin are included *) @@ -1314,7 +1320,7 @@ let sort_fields ~complete loc fields completer = | [] -> (idx, acc_first_idx, acc) | (Some field_glob_id) :: projs -> let field_glob_ref = ConstRef field_glob_id in - let first_field = eq_gr field_glob_ref first_field_glob_ref in + let first_field = GlobRef.equal field_glob_ref first_field_glob_ref in begin match proj_kinds with | [] -> anomaly (Pp.str "Number of projections mismatch.") | (_, regular) :: proj_kinds -> @@ -1352,7 +1358,7 @@ let sort_fields ~complete loc fields completer = user_err ?loc ~hdr:"intern" (str "The field \"" ++ pr_reference field_ref ++ str "\" does not exist.") in let remaining_projs, (field_index, _) = - let the_proj (idx, glob_id) = eq_gr field_glob_ref (ConstRef glob_id) in + let the_proj (idx, glob_id) = GlobRef.equal field_glob_ref (ConstRef glob_id) in try CList.extract_first the_proj remaining_projs with Not_found -> user_err ?loc @@ -1379,7 +1385,7 @@ let sort_fields ~complete loc fields completer = (** {6 Manage multiple aliases} *) type alias = { - alias_ids : Misctypes.lident list; + alias_ids : lident list; alias_map : Id.t Id.Map.t; } @@ -1719,15 +1725,15 @@ let get_implicit_name n imps = let set_hole_implicit i b c = let loc = c.CAst.loc in match DAst.get c with - | GRef (r, _) -> Loc.tag ?loc (Evar_kinds.ImplicitArg (r,i,b),Misctypes.IntroAnonymous,None) + | GRef (r, _) -> Loc.tag ?loc (Evar_kinds.ImplicitArg (r,i,b),IntroAnonymous,None) | GApp (r, _) -> let loc = r.CAst.loc in begin match DAst.get r with | GRef (r, _) -> - Loc.tag ?loc (Evar_kinds.ImplicitArg (r,i,b),Misctypes.IntroAnonymous,None) + Loc.tag ?loc (Evar_kinds.ImplicitArg (r,i,b),IntroAnonymous,None) | _ -> anomaly (Pp.str "Only refs have implicits.") end - | GVar id -> Loc.tag ?loc (Evar_kinds.ImplicitArg (VarRef id,i,b),Misctypes.IntroAnonymous,None) + | GVar id -> Loc.tag ?loc (Evar_kinds.ImplicitArg (VarRef id,i,b),IntroAnonymous,None) | _ -> anomaly (Pp.str "Only refs have implicits.") let exists_implicit_name id = @@ -1913,13 +1919,13 @@ let internalize globalenv env pattern_mode (_, ntnvars as lvar) c = let fields = sort_fields ~complete:true loc fs (fun _idx -> CAst.make ?loc @@ CHole (Some (Evar_kinds.QuestionMark (st,Anonymous)), - Misctypes.IntroAnonymous, None)) + IntroAnonymous, None)) in begin match fields with | None -> user_err ?loc ~hdr:"intern" (str"No constructor inference.") | Some (n, constrname, args) -> - let pars = List.make n (CAst.make ?loc @@ CHole (None, Misctypes.IntroAnonymous, None)) in + let pars = List.make n (CAst.make ?loc @@ CHole (None, IntroAnonymous, None)) in let app = CAst.make ?loc @@ CAppExpl ((None, constrname,None), List.rev_append pars args) in intern env app end @@ -1959,13 +1965,13 @@ let internalize globalenv env pattern_mode (_, ntnvars as lvar) c = let main_sub_eqn = CAst.make @@ ([],thepats, (* "|p1,..,pn" *) Option.cata (intern_type env') - (DAst.make ?loc @@ GHole(Evar_kinds.CasesType false,Misctypes.IntroAnonymous,None)) + (DAst.make ?loc @@ GHole(Evar_kinds.CasesType false,IntroAnonymous,None)) rtnpo) (* "=> P" if there were a return predicate P, and "=> _" otherwise *) in let catch_all_sub_eqn = if List.for_all (irrefutable globalenv) thepats then [] else [CAst.make @@ ([],List.make (List.length thepats) (DAst.make @@ PatVar Anonymous), (* "|_,..,_" *) - DAst.make @@ GHole(Evar_kinds.ImpossibleCase,Misctypes.IntroAnonymous,None))] (* "=> _" *) in - Some (DAst.make @@ GCases(Term.RegularStyle,sub_rtn,sub_tms,main_sub_eqn::catch_all_sub_eqn)) + DAst.make @@ GHole(Evar_kinds.ImpossibleCase,IntroAnonymous,None))] (* "=> _" *) in + Some (DAst.make @@ GCases(RegularStyle,sub_rtn,sub_tms,main_sub_eqn::catch_all_sub_eqn)) in let eqns' = List.map (intern_eqn (List.length tms) env) eqns in DAst.make ?loc @@ @@ -1995,7 +2001,7 @@ let internalize globalenv env pattern_mode (_, ntnvars as lvar) c = | None -> let st = Evar_kinds.Define (not (Program.get_proofs_transparency ())) in (match naming with - | Misctypes.IntroIdentifier id -> Evar_kinds.NamedHole id + | IntroIdentifier id -> Evar_kinds.NamedHole id | _ -> Evar_kinds.QuestionMark (st,Anonymous)) | Some k -> k in @@ -2040,7 +2046,7 @@ let internalize globalenv env pattern_mode (_, ntnvars as lvar) c = GSort s | CCast (c1, c2) -> DAst.make ?loc @@ - GCast (intern env c1, Miscops.map_cast_type (intern_type env) c2) + GCast (intern env c1, map_cast_type (intern_type env) c2) | CProj (pr, c) -> match intern_reference pr with | ConstRef p -> diff --git a/interp/constrintern.mli b/interp/constrintern.mli index f5e32dc4c..12f77af30 100644 --- a/interp/constrintern.mli +++ b/interp/constrintern.mli @@ -11,9 +11,7 @@ open Names open Evd open Environ -open Misctypes open Libnames -open Globnames open Glob_term open Pattern open EConstr @@ -143,7 +141,7 @@ val intern_constr_pattern : constr_pattern_expr -> patvar list * constr_pattern (** Raise Not_found if syndef not bound to a name and error if unexisting ref *) -val intern_reference : reference -> global_reference +val intern_reference : reference -> GlobRef.t (** Expands abbreviations (syndef); raise an error if not existing *) val interp_reference : ltac_sign -> reference -> glob_constr @@ -175,11 +173,11 @@ val interp_context_evars : (** Locating references of constructions, possibly via a syntactic definition (these functions do not modify the glob file) *) -val locate_reference : Libnames.qualid -> Globnames.global_reference +val locate_reference : Libnames.qualid -> GlobRef.t val is_global : Id.t -> bool -val construct_reference : ('c, 't) Context.Named.pt -> Id.t -> Globnames.global_reference -val global_reference : Id.t -> Globnames.global_reference -val global_reference_in_absolute_module : DirPath.t -> Id.t -> Globnames.global_reference +val construct_reference : ('c, 't) Context.Named.pt -> Id.t -> GlobRef.t +val global_reference : Id.t -> GlobRef.t +val global_reference_in_absolute_module : DirPath.t -> Id.t -> GlobRef.t (** Interprets a term as the left-hand side of a notation. The returned map is guaranteed to have the same domain as the input one. *) diff --git a/interp/declare.ml b/interp/declare.ml index c55a6c69b..bc2d2068a 100644 --- a/interp/declare.ml +++ b/interp/declare.ml @@ -487,7 +487,7 @@ let add_universe src (dp, i) = Option.iter (fun poly -> let ctx = Univ.ContextSet.add_universe level Univ.ContextSet.empty in Global.push_context_set poly ctx; - Universes.add_global_universe level poly; + UnivNames.add_global_universe level poly; if poly then Lib.add_section_context ctx) optpoly @@ -538,7 +538,7 @@ let input_universe : universe_decl -> Libobject.obj = let declare_univ_binders gr pl = if Global.is_polymorphic gr then - Universes.register_universe_binders gr pl + UnivNames.register_universe_binders gr pl else let l = match gr with | ConstRef c -> Label.to_id @@ Constant.label c @@ -564,7 +564,7 @@ let do_universe poly l = in let l = List.map (fun {CAst.v=id} -> - let lev = Universes.new_univ_id () in + let lev = UnivGen.new_univ_id () in (id, lev)) l in let src = if poly then BoundUniv else UnqualifiedUniv in @@ -595,7 +595,7 @@ let input_constraints : constraint_decl -> Libobject.obj = let do_constraint poly l = let u_of_id x = let level = Pretyping.interp_known_glob_level (Evd.from_env (Global.env ())) x in - Universes.is_polymorphic level, level + UnivNames.is_polymorphic level, level in let in_section = Lib.sections_are_opened () in let () = diff --git a/interp/declare.mli b/interp/declare.mli index 084d746e6..02e73cd66 100644 --- a/interp/declare.mli +++ b/interp/declare.mli @@ -83,10 +83,10 @@ val recursive_message : bool (** true = fixpoint *) -> val exists_name : Id.t -> bool (** Global universe contexts, names and constraints *) -val declare_univ_binders : Globnames.global_reference -> Universes.universe_binders -> unit +val declare_univ_binders : GlobRef.t -> UnivNames.universe_binders -> unit val declare_universe_context : polymorphic -> Univ.ContextSet.t -> unit -val do_universe : polymorphic -> Misctypes.lident list -> unit -val do_constraint : polymorphic -> (Misctypes.glob_level * Univ.constraint_type * Misctypes.glob_level) list -> +val do_universe : polymorphic -> lident list -> unit +val do_constraint : polymorphic -> (Glob_term.glob_level * Univ.constraint_type * Glob_term.glob_level) list -> unit diff --git a/interp/dumpglob.ml b/interp/dumpglob.ml index bc6a1ef3a..74618a290 100644 --- a/interp/dumpglob.ml +++ b/interp/dumpglob.ml @@ -254,7 +254,7 @@ let dump_def ?loc ty secpath id = Option.iter (fun loc -> let dump_definition {CAst.loc;v=id} sec s = dump_def ?loc s (Names.DirPath.to_string (Lib.current_dirpath sec)) (Names.Id.to_string id) -let dump_constraint (({ CAst.loc; v = n },_), _, _) sec ty = +let dump_constraint { CAst.loc; v = n } sec ty = match n with | Names.Name id -> dump_definition CAst.(make ?loc id) sec ty | Names.Anonymous -> () diff --git a/interp/dumpglob.mli b/interp/dumpglob.mli index 43c100008..931d05a97 100644 --- a/interp/dumpglob.mli +++ b/interp/dumpglob.mli @@ -24,10 +24,10 @@ val feedback_glob : unit -> unit val pause : unit -> unit val continue : unit -> unit -val add_glob : ?loc:Loc.t -> Globnames.global_reference -> unit +val add_glob : ?loc:Loc.t -> Names.GlobRef.t -> unit val add_glob_kn : ?loc:Loc.t -> Names.KerName.t -> unit -val dump_definition : Misctypes.lident -> bool -> string -> unit +val dump_definition : Names.lident -> bool -> string -> unit val dump_moddef : ?loc:Loc.t -> Names.ModPath.t -> string -> unit val dump_modref : ?loc:Loc.t -> Names.ModPath.t -> string -> unit val dump_reference : ?loc:Loc.t -> string -> string -> string -> unit @@ -38,9 +38,9 @@ val dump_binding : ?loc:Loc.t -> Names.Id.Set.elt -> unit val dump_notation : (Constrexpr.notation * Notation.notation_location) Loc.located -> Notation_term.scope_name option -> bool -> unit -val dump_constraint : - Vernacexpr.typeclass_constraint -> bool -> string -> unit + +val dump_constraint : Names.lname -> bool -> string -> unit val dump_string : string -> unit -val type_of_global_ref : Globnames.global_reference -> string +val type_of_global_ref : Names.GlobRef.t -> string diff --git a/interp/genintern.ml b/interp/genintern.ml index 161201c44..d9a0db040 100644 --- a/interp/genintern.ml +++ b/interp/genintern.ml @@ -26,9 +26,15 @@ let empty_glob_sign env = { extra = Store.empty; } +(** In globalize tactics, we need to keep the initial [constr_expr] to recompute + in the environment by the effective calls to Intro, Inversion, etc + The [constr_expr] field is [None] in TacDef though *) +type glob_constr_and_expr = Glob_term.glob_constr * Constrexpr.constr_expr option +type glob_constr_pattern_and_expr = Id.Set.t * glob_constr_and_expr * Pattern.constr_pattern + type ('raw, 'glb) intern_fun = glob_sign -> 'raw -> glob_sign * 'glb type 'glb subst_fun = substitution -> 'glb -> 'glb -type 'glb ntn_subst_fun = Tactypes.glob_constr_and_expr Id.Map.t -> 'glb -> 'glb +type 'glb ntn_subst_fun = glob_constr_and_expr Id.Map.t -> 'glb -> 'glb module InternObj = struct diff --git a/interp/genintern.mli b/interp/genintern.mli index d818713fc..f4f064bca 100644 --- a/interp/genintern.mli +++ b/interp/genintern.mli @@ -22,6 +22,12 @@ type glob_sign = { val empty_glob_sign : Environ.env -> glob_sign +(** In globalize tactics, we need to keep the initial [constr_expr] to recompute + in the environment by the effective calls to Intro, Inversion, etc + The [constr_expr] field is [None] in TacDef though *) +type glob_constr_and_expr = Glob_term.glob_constr * Constrexpr.constr_expr option +type glob_constr_pattern_and_expr = Id.Set.t * glob_constr_and_expr * Pattern.constr_pattern + (** {5 Internalization functions} *) type ('raw, 'glb) intern_fun = glob_sign -> 'raw -> glob_sign * 'glb @@ -42,7 +48,7 @@ val generic_substitute : glob_generic_argument subst_fun (** {5 Notation functions} *) -type 'glb ntn_subst_fun = Tactypes.glob_constr_and_expr Id.Map.t -> 'glb -> 'glb +type 'glb ntn_subst_fun = glob_constr_and_expr Id.Map.t -> 'glb -> 'glb val substitute_notation : ('raw, 'glb, 'top) genarg_type -> 'glb ntn_subst_fun diff --git a/intf/genredexpr.ml b/interp/genredexpr.ml index 80697461a..42c1fe429 100644 --- a/intf/genredexpr.ml +++ b/interp/genredexpr.ml @@ -52,12 +52,11 @@ type ('a,'b,'c) red_expr_gen = type ('a,'b,'c) may_eval = | ConstrTerm of 'a | ConstrEval of ('a,'b,'c) red_expr_gen * 'a - | ConstrContext of Misctypes.lident * 'a + | ConstrContext of Names.lident * 'a | ConstrTypeOf of 'a open Libnames open Constrexpr -open Misctypes type r_trm = constr_expr type r_pat = constr_pattern_expr diff --git a/interp/impargs.ml b/interp/impargs.ml index b424f73de..8aa1e6250 100644 --- a/interp/impargs.ml +++ b/interp/impargs.ml @@ -237,11 +237,11 @@ let is_rigid env sigma t = is_rigid_head sigma t | _ -> true -let find_displayed_name_in all avoid na (env, b) = +let find_displayed_name_in sigma all avoid na (env, b) = let envnames_b = (env, b) in let flag = RenamingElsewhereFor envnames_b in - if all then compute_and_force_displayed_name_in Evd.empty flag avoid na b - else compute_displayed_name_in Evd.empty flag avoid na b + if all then compute_and_force_displayed_name_in sigma flag avoid na b + else compute_displayed_name_in sigma flag avoid na b let compute_implicits_names_gen all env sigma t = let open Context.Rel.Declaration in @@ -249,7 +249,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 all avoid na (names,b) in + let na',avoid' = find_displayed_name_in sigma all avoid na (names,b) in aux (push_rel (LocalAssum (na,a)) env) avoid' (na'::names) b | _ -> List.rev names in aux env Id.Set.empty [] t @@ -505,7 +505,7 @@ type implicit_discharge_request = | ImplLocal | ImplConstant of Constant.t * implicits_flags | ImplMutualInductive of MutInd.t * implicits_flags - | ImplInteractive of global_reference * implicits_flags * + | ImplInteractive of GlobRef.t * implicits_flags * implicit_interactive_request let implicits_table = Summary.ref Refmap.empty ~name:"implicits" @@ -538,7 +538,7 @@ let subst_implicits_decl subst (r,imps as o) = let r' = fst (subst_global subst r) in if r==r' then o else (r',imps) let subst_implicits (subst,(req,l)) = - (ImplLocal,List.smartmap (subst_implicits_decl subst) l) + (ImplLocal,List.Smart.map (subst_implicits_decl subst) l) let impls_of_context ctx = let map (decl, impl) = match impl with @@ -626,7 +626,7 @@ let classify_implicits (req,_ as obj) = match req with type implicits_obj = implicit_discharge_request * - (global_reference * implicits_list list) list + (GlobRef.t * implicits_list list) list let inImplicits : implicits_obj -> obj = declare_object {(default_object "IMPLICITS") with diff --git a/interp/impargs.mli b/interp/impargs.mli index 1eeb8e41a..ea5aa90f6 100644 --- a/interp/impargs.mli +++ b/interp/impargs.mli @@ -10,7 +10,6 @@ open Names open EConstr -open Globnames open Environ (** {6 Implicit Arguments } *) @@ -103,7 +102,7 @@ val declare_var_implicits : variable -> unit val declare_constant_implicits : Constant.t -> unit val declare_mib_implicits : MutInd.t -> unit -val declare_implicits : bool -> global_reference -> unit +val declare_implicits : bool -> GlobRef.t -> unit (** [declare_manual_implicits local ref enriching l] Manual declaration of which arguments are expected implicit. @@ -111,15 +110,15 @@ val declare_implicits : bool -> global_reference -> unit implicits depending on the current state. Unsets implicits if [l] is empty. *) -val declare_manual_implicits : bool -> global_reference -> ?enriching:bool -> +val declare_manual_implicits : bool -> GlobRef.t -> ?enriching:bool -> manual_implicits list -> unit (** If the list is empty, do nothing, otherwise declare the implicits. *) -val maybe_declare_manual_implicits : bool -> global_reference -> ?enriching:bool -> +val maybe_declare_manual_implicits : bool -> GlobRef.t -> ?enriching:bool -> manual_implicits -> unit -val implicits_of_global : global_reference -> implicits_list list +val implicits_of_global : GlobRef.t -> implicits_list list val extract_impargs_data : implicits_list list -> ((int * int) option * implicit_status list) list @@ -130,7 +129,7 @@ val make_implicits_list : implicit_status list -> implicits_list list val drop_first_implicits : int -> implicits_list -> implicits_list -val projection_implicits : env -> projection -> implicit_status list -> +val projection_implicits : env -> Projection.t -> implicit_status list -> implicit_status list val select_impargs_size : int -> implicits_list list -> implicit_status list diff --git a/interp/implicit_quantifiers.ml b/interp/implicit_quantifiers.ml index 58df9abc4..b54e2badd 100644 --- a/interp/implicit_quantifiers.ml +++ b/interp/implicit_quantifiers.ml @@ -17,12 +17,14 @@ open Glob_term open Constrexpr open Libnames open Typeclasses -open Typeclasses_errors open Pp open Libobject open Nameops open Context.Rel.Declaration +exception MismatchedContextInstance of Environ.env * Typeclasses_errors.contexts * constr_expr list * Context.Rel.t (* found, expected *) +let mismatched_ctx_inst_err env c n m = raise (MismatchedContextInstance (env, c, n, m)) + module RelDecl = Context.Rel.Declaration (*i*) @@ -51,14 +53,14 @@ let cache_generalizable_type (_,(local,cmd)) = let load_generalizable_type _ (_,(local,cmd)) = generalizable_table := add_generalizable cmd !generalizable_table -let in_generalizable : bool * Misctypes.lident list option -> obj = +let in_generalizable : bool * lident list option -> obj = declare_object {(default_object "GENERALIZED-IDENT") with load_function = load_generalizable_type; cache_function = cache_generalizable_type; classify_function = (fun (local, _ as obj) -> if local then Dispose else Keep obj) } -let declare_generalizable local gen = +let declare_generalizable ~local gen = Lib.add_anonymous_leaf (in_generalizable (local, gen)) let find_generalizable_ident id = Id.Pred.mem (root_of_id id) !generalizable_table @@ -238,7 +240,7 @@ let implicit_application env ?(allow_partial=true) f ty = let applen = List.fold_left (fun acc (x, y) -> opt_succ y acc) 0 par in let needlen = List.fold_left (fun acc x -> opt_succ x acc) 0 ci in if not (Int.equal needlen applen) then - Typeclasses_errors.mismatched_ctx_inst (Global.env ()) Parameters (List.map fst par) rd + mismatched_ctx_inst_err (Global.env ()) Typeclasses_errors.Parameters (List.map fst par) rd end; let pars = List.rev (List.combine ci rd) in let args, avoid = combine_params avoid f par pars in diff --git a/interp/implicit_quantifiers.mli b/interp/implicit_quantifiers.mli index b9815f34d..25394fc0d 100644 --- a/interp/implicit_quantifiers.mli +++ b/interp/implicit_quantifiers.mli @@ -12,9 +12,8 @@ open Names open Glob_term open Constrexpr open Libnames -open Globnames -val declare_generalizable : Vernacexpr.locality_flag -> Misctypes.lident list option -> unit +val declare_generalizable : local:bool -> lident list option -> unit val ids_of_list : Id.t list -> Id.Set.t val destClassApp : constr_expr -> (reference * constr_expr list * instance_expr option) CAst.t @@ -32,17 +31,21 @@ val free_vars_of_binders : order with the location of their first occurrence *) val generalizable_vars_of_glob_constr : ?bound:Id.Set.t -> ?allowed:Id.Set.t -> - glob_constr -> Misctypes.lident list + glob_constr -> lident list val make_fresh : Id.Set.t -> Environ.env -> Id.t -> Id.t val implicits_of_glob_constr : ?with_products:bool -> Glob_term.glob_constr -> Impargs.manual_implicits val combine_params_freevar : - Id.Set.t -> global_reference option * Context.Rel.Declaration.t -> + Id.Set.t -> GlobRef.t option * Context.Rel.Declaration.t -> Constrexpr.constr_expr * Id.Set.t val implicit_application : Id.Set.t -> ?allow_partial:bool -> - (Id.Set.t -> global_reference option * Context.Rel.Declaration.t -> + (Id.Set.t -> GlobRef.t option * Context.Rel.Declaration.t -> Constrexpr.constr_expr * Id.Set.t) -> constr_expr -> constr_expr * Id.Set.t + +(* Should be likely located elsewhere *) +exception MismatchedContextInstance of Environ.env * Typeclasses_errors.contexts * constr_expr list * Context.Rel.t (* found, expected *) +val mismatched_ctx_inst_err : Environ.env -> Typeclasses_errors.contexts -> constr_expr list -> Context.Rel.t -> 'a diff --git a/interp/interp.mllib b/interp/interp.mllib index bb22cf468..3668455ae 100644 --- a/interp/interp.mllib +++ b/interp/interp.mllib @@ -1,14 +1,16 @@ +Constrexpr +Genredexpr +Redops Tactypes Stdarg Genintern +Notation_term Notation_ops Notation Syntax_def Smartlocate Constrexpr_ops -Ppextend Dumpglob -Topconstr Reserve Impargs Implicit_quantifiers diff --git a/interp/modintern.ml b/interp/modintern.ml index dc93d8dc4..33c07d551 100644 --- a/interp/modintern.ml +++ b/interp/modintern.ml @@ -12,7 +12,7 @@ open Declarations open Libnames open Constrexpr open Constrintern -open Misctypes +open Declaremods type module_internalization_error = | NotAModuleNorModtype of string @@ -23,7 +23,7 @@ exception ModuleInternalizationError of module_internalization_error let error_not_a_module_loc kind loc qid = let s = string_of_qualid qid in - let e = match kind with + let e = let open Declaremods in match kind with | Module -> Modops.ModuleTypingError (Modops.NotAModule s) | ModType -> Modops.ModuleTypingError (Modops.NotAModuleType s) | ModAny -> ModuleInternalizationError (NotAModuleNorModtype s) @@ -46,6 +46,7 @@ let error_application_to_module_type loc = it is equal to the input kind when this one isn't ModAny. *) let lookup_module_or_modtype kind {CAst.loc;v=qid} = + let open Declaremods in try if kind == ModType then raise Not_found; let mp = Nametab.locate_module qid in @@ -63,7 +64,7 @@ let transl_with_decl env = function | CWith_Module ({CAst.v=fqid},qid) -> WithMod (fqid,lookup_module qid), Univ.ContextSet.empty | CWith_Definition ({CAst.v=fqid},udecl,c) -> - let sigma, udecl = Univdecls.interp_univ_decl_opt env udecl in + let sigma, udecl = Constrexpr_ops.interp_univ_decl_opt env udecl in let c, ectx = interp_constr env sigma c in begin match UState.check_univ_decl ~poly:(Flags.is_universe_polymorphism()) ectx udecl with | Entries.Polymorphic_const_entry ctx -> diff --git a/interp/modintern.mli b/interp/modintern.mli index ef37aead8..529c438c1 100644 --- a/interp/modintern.mli +++ b/interp/modintern.mli @@ -11,7 +11,6 @@ open Environ open Entries open Constrexpr -open Misctypes (** Module internalization errors *) @@ -30,4 +29,4 @@ exception ModuleInternalizationError of module_internalization_error isn't ModAny. *) val interp_module_ast : - env -> module_kind -> module_ast -> module_struct_entry * module_kind * Univ.ContextSet.t + env -> Declaremods.module_kind -> module_ast -> module_struct_entry * Declaremods.module_kind * Univ.ContextSet.t diff --git a/interp/notation.ml b/interp/notation.ml index 47d648135..05fcd0e7f 100644 --- a/interp/notation.ml +++ b/interp/notation.ml @@ -20,7 +20,6 @@ open Constrexpr open Notation_term open Glob_term open Glob_ops -open Ppextend open Context.Named.Declaration (*i*) @@ -49,7 +48,6 @@ type notation_location = (DirPath.t * DirPath.t) * string type notation_data = { not_interp : interpretation; not_location : notation_location; - not_onlyprinting : bool; } type scope = { @@ -57,9 +55,6 @@ type scope = { delimiters: delimiters option } -(* Uninterpreted notation map: notation -> level * DirPath.t *) -let notation_level_map = ref String.Map.empty - (* Scopes table: scope_name -> symbol_interpretation *) let scope_map = ref String.Map.empty @@ -76,44 +71,6 @@ let default_scope = "" (* empty name, not available from outside *) let init_scope_map () = scope_map := String.Map.add default_scope empty_scope !scope_map -(**********************************************************************) -(* Operations on scopes *) - -let parenRelation_eq t1 t2 = match t1, t2 with -| L, L | E, E | Any, Any -> true -| Prec l1, Prec l2 -> Int.equal l1 l2 -| _ -> false - -open Extend - -let production_level_eq l1 l2 = true (* (l1 = l2) *) - -let production_position_eq pp1 pp2 = true (* pp1 = pp2 *) (* match pp1, pp2 with -| NextLevel, NextLevel -> true -| NumLevel n1, NumLevel n2 -> Int.equal n1 n2 -| (NextLevel | NumLevel _), _ -> false *) - -let constr_entry_key_eq eq v1 v2 = match v1, v2 with -| ETName, ETName -> true -| ETReference, ETReference -> true -| ETBigint, ETBigint -> true -| ETBinder b1, ETBinder b2 -> b1 == b2 -| ETConstr lev1, ETConstr lev2 -> eq lev1 lev2 -| ETConstrAsBinder (bk1,lev1), ETConstrAsBinder (bk2,lev2) -> eq lev1 lev2 && bk1 = bk2 -| ETPattern (b1,n1), ETPattern (b2,n2) -> b1 = b2 && Option.equal Int.equal n1 n2 -| ETOther (s1,s1'), ETOther (s2,s2') -> String.equal s1 s2 && String.equal s1' s2' -| (ETName | ETReference | ETBigint | ETBinder _ | ETConstr _ | ETPattern _ | ETOther _ | ETConstrAsBinder _), _ -> false - -let level_eq_gen strict (l1, t1, u1) (l2, t2, u2) = - let tolerability_eq (i1, r1) (i2, r2) = Int.equal i1 i2 && parenRelation_eq r1 r2 in - let prod_eq (l1,pp1) (l2,pp2) = - if strict then production_level_eq l1 l2 && production_position_eq pp1 pp2 - else production_level_eq l1 l2 in - Int.equal l1 l2 && List.equal tolerability_eq t1 t2 - && List.equal (constr_entry_key_eq prod_eq) u1 u2 - -let level_eq = level_eq_gen false - let declare_scope scope = try let _ = String.Map.find scope !scope_map in () with Not_found -> @@ -259,7 +216,7 @@ type interp_rule = according to the key of the pattern (adapted from Chet Murthy by HH) *) type key = - | RefKey of global_reference + | RefKey of GlobRef.t | Oth let key_compare k1 k2 = match k1, k2 with @@ -428,16 +385,6 @@ let rec find_without_delimiters find (ntn_scope,ntn) = function (* Can we switch to [scope]? Yes if it has defined delimiters *) find_with_delimiters ntn_scope -(* Uninterpreted notation levels *) - -let declare_notation_level ntn level = - if String.Map.mem ntn !notation_level_map then - anomaly (str "Notation " ++ str ntn ++ str " is already assigned a level."); - notation_level_map := String.Map.add ntn level !notation_level_map - -let level_of_notation ntn = - String.Map.find ntn !notation_level_map - (* The mapping between notations and their interpretation *) let warn_notation_overridden = @@ -449,20 +396,21 @@ let warn_notation_overridden = let declare_notation_interpretation ntn scopt pat df ~onlyprint = let scope = match scopt with Some s -> s | None -> default_scope in let sc = find_scope scope in - let () = - if String.Map.mem ntn sc.notations then - let which_scope = match scopt with - | None -> mt () - | Some _ -> spc () ++ strbrk "in scope" ++ spc () ++ str scope in - warn_notation_overridden (ntn,which_scope) - in - let notdata = { - not_interp = pat; - not_location = df; - not_onlyprinting = onlyprint; - } in - let sc = { sc with notations = String.Map.add ntn notdata sc.notations } in - let () = scope_map := String.Map.add scope sc !scope_map in + if not onlyprint then begin + let () = + if String.Map.mem ntn sc.notations then + let which_scope = match scopt with + | None -> mt () + | Some _ -> spc () ++ strbrk "in scope" ++ spc () ++ str scope in + warn_notation_overridden (ntn,which_scope) + in + let notdata = { + not_interp = pat; + not_location = df; + } in + let sc = { sc with notations = String.Map.add ntn notdata sc.notations } in + scope_map := String.Map.add scope sc !scope_map + end; begin match scopt with | None -> scope_stack := SingleNotation ntn :: !scope_stack | Some _ -> () @@ -487,7 +435,6 @@ let rec find_interpretation ntn find = function let find_notation ntn sc = let n = String.Map.find ntn (find_scope sc).notations in - let () = if n.not_onlyprinting then raise Not_found in (n.not_interp, n.not_location) let notation_of_prim_token = function @@ -631,7 +578,6 @@ let exists_notation_in_scope scopt ntn onlyprint r = try let sc = String.Map.find scope !scope_map in let n = String.Map.find ntn sc.notations in - onlyprint = n.not_onlyprinting && interpretation_eq n.not_interp r with Not_found -> false @@ -741,7 +687,7 @@ let subst_arguments_scope (subst,(req,r,n,scl,cls)) = match subst_scope_class subst cl with | Some cl' as ocl' when cl' != cl -> ocl' | _ -> ocl in - let cls' = List.smartmap subst_cl cls in + let cls' = List.Smart.map subst_cl cls in (ArgsScopeNoDischarge,r',n,scl,cls') let discharge_arguments_scope (_,(req,r,n,l,_)) = @@ -778,7 +724,7 @@ let rebuild_arguments_scope sigma (req,r,n,l,_) = (req,r,0,l1@l,cls1) type arguments_scope_obj = - arguments_scope_discharge_request * global_reference * + arguments_scope_discharge_request * GlobRef.t * (* Used to communicate information from discharge to rebuild *) (* set to 0 otherwise *) int * scope_name option list * scope_class option list @@ -1051,7 +997,7 @@ let locate_notation prglob ntn scope = | [] -> str "Unknown notation" | _ -> str "Notation" ++ fnl () ++ - prlist (fun (ntn,l) -> + prlist_with_sep fnl (fun (ntn,l) -> let scope = find_default ntn scopes in prlist (fun (sc,r,(_,df)) -> @@ -1060,8 +1006,7 @@ let locate_notation prglob ntn scope = (if String.equal sc default_scope then mt () else (spc () ++ str ": " ++ str sc)) ++ (if Option.equal String.equal (Some sc) scope - then spc () ++ str "(default interpretation)" else mt ()) - ++ fnl ())) + then spc () ++ str "(default interpretation)" else mt ()))) l) ntns let collect_notation_in_scope scope sc known = @@ -1114,63 +1059,24 @@ let pr_visibility prglob = function | None -> pr_scope_stack prglob !scope_stack (**********************************************************************) -(* Mapping notations to concrete syntax *) - -type unparsing_rule = unparsing list * precedence -type extra_unparsing_rules = (string * string) list -(* Concrete syntax for symbolic-extension table *) -let notation_rules = - ref (String.Map.empty : (unparsing_rule * extra_unparsing_rules * notation_grammar) String.Map.t) - -let declare_notation_rule ntn ~extra unpl gram = - notation_rules := String.Map.add ntn (unpl,extra,gram) !notation_rules - -let find_notation_printing_rule ntn = - try pi1 (String.Map.find ntn !notation_rules) - with Not_found -> anomaly (str "No printing rule found for " ++ str ntn ++ str ".") -let find_notation_extra_printing_rules ntn = - try pi2 (String.Map.find ntn !notation_rules) - with Not_found -> [] -let find_notation_parsing_rules ntn = - try pi3 (String.Map.find ntn !notation_rules) - with Not_found -> anomaly (str "No parsing rule found for " ++ str ntn ++ str ".") - -let get_defined_notations () = - String.Set.elements @@ String.Map.domain !notation_rules - -let add_notation_extra_printing_rule ntn k v = - try - notation_rules := - let p, pp, gr = String.Map.find ntn !notation_rules in - String.Map.add ntn (p, (k,v) :: pp, gr) !notation_rules - with Not_found -> - user_err ~hdr:"add_notation_extra_printing_rule" - (str "No such Notation.") - -(**********************************************************************) (* Synchronisation with reset *) let freeze _ = - (!scope_map, !notation_level_map, !scope_stack, !arguments_scope, - !delimiters_map, !notations_key_table, !notation_rules, - !scope_class_map) + (!scope_map, !scope_stack, !arguments_scope, + !delimiters_map, !notations_key_table, !scope_class_map) -let unfreeze (scm,nlm,scs,asc,dlm,fkm,pprules,clsc) = +let unfreeze (scm,scs,asc,dlm,fkm,clsc) = scope_map := scm; - notation_level_map := nlm; scope_stack := scs; delimiters_map := dlm; arguments_scope := asc; notations_key_table := fkm; - notation_rules := pprules; scope_class_map := clsc let init () = init_scope_map (); - notation_level_map := String.Map.empty; delimiters_map := String.Map.empty; notations_key_table := KeyMap.empty; - notation_rules := String.Map.empty; scope_class_map := initial_scope_class_map let _ = diff --git a/interp/notation.mli b/interp/notation.mli index 6803a7e51..b177b7f1e 100644 --- a/interp/notation.mli +++ b/interp/notation.mli @@ -11,11 +11,9 @@ open Bigint open Names open Libnames -open Globnames open Constrexpr open Glob_term open Notation_term -open Ppextend (** Notations *) @@ -33,8 +31,6 @@ val declare_scope : scope_name -> unit val current_scopes : unit -> scopes -val level_eq : level -> level -> bool - (** Check where a scope is opened or not in a scope list, or in * the current opened scopes *) val scope_is_open_in_scopes : scope_name -> scopes -> bool @@ -91,7 +87,7 @@ val declare_string_interpreter : scope_name -> required_module -> val interp_prim_token : ?loc:Loc.t -> prim_token -> local_scopes -> glob_constr * (notation_location * scope_name option) (* This function returns a glob_const representing a pattern *) -val interp_prim_token_cases_pattern_expr : ?loc:Loc.t -> (global_reference -> unit) -> prim_token -> +val interp_prim_token_cases_pattern_expr : ?loc:Loc.t -> (GlobRef.t -> unit) -> prim_token -> local_scopes -> glob_constr * (notation_location * scope_name option) (** Return the primitive token associated to a [term]/[cases_pattern]; @@ -136,15 +132,10 @@ val uninterp_ind_pattern_notations : inductive -> notation_rule list val availability_of_notation : scope_name option * notation -> local_scopes -> (scope_name option * delimiters option) option -(** {6 Declare and test the level of a (possibly uninterpreted) notation } *) - -val declare_notation_level : notation -> level -> unit -val level_of_notation : notation -> level (** raise [Not_found] if no level *) - (** {6 Miscellaneous} *) -val interp_notation_as_global_reference : ?loc:Loc.t -> (global_reference -> bool) -> - notation -> delimiters option -> global_reference +val interp_notation_as_global_reference : ?loc:Loc.t -> (GlobRef.t -> bool) -> + notation -> delimiters option -> GlobRef.t (** Checks for already existing notations *) val exists_notation_in_scope : scope_name option -> notation -> @@ -152,9 +143,9 @@ val exists_notation_in_scope : scope_name option -> notation -> (** Declares and looks for scopes associated to arguments of a global ref *) val declare_arguments_scope : - bool (** true=local *) -> global_reference -> scope_name option list -> unit + bool (** true=local *) -> GlobRef.t -> scope_name option list -> unit -val find_arguments_scope : global_reference -> scope_name option list +val find_arguments_scope : GlobRef.t -> scope_name option list type scope_class @@ -165,7 +156,7 @@ val subst_scope_class : Mod_subst.substitution -> scope_class -> scope_class option val declare_scope_class : scope_name -> scope_class -> unit -val declare_ref_arguments_scope : Evd.evar_map -> global_reference -> unit +val declare_ref_arguments_scope : Evd.evar_map -> GlobRef.t -> unit val compute_arguments_scope : Evd.evar_map -> EConstr.types -> scope_name option list val compute_type_scope : Evd.evar_map -> EConstr.types -> scope_name option @@ -201,21 +192,6 @@ val locate_notation : (glob_constr -> Pp.t) -> notation -> val pr_visibility: (glob_constr -> Pp.t) -> scope_name option -> Pp.t -(** {6 Printing rules for notations} *) - -(** Declare and look for the printing rule for symbolic notations *) -type unparsing_rule = unparsing list * precedence -type extra_unparsing_rules = (string * string) list -val declare_notation_rule : - notation -> extra:extra_unparsing_rules -> unparsing_rule -> notation_grammar -> unit -val find_notation_printing_rule : notation -> unparsing_rule -val find_notation_extra_printing_rules : notation -> extra_unparsing_rules -val find_notation_parsing_rules : notation -> notation_grammar -val add_notation_extra_printing_rule : notation -> string -> string -> unit - -(** Returns notations with defined parsing/printing rules *) -val get_defined_notations : unit -> notation list - (** Rem: printing rules for primitive token are canonical *) val with_notation_protection : ('a -> 'b) -> 'a -> 'b diff --git a/interp/notation_ops.ml b/interp/notation_ops.ml index a0d69ce79..ab0bf9c6f 100644 --- a/interp/notation_ops.ml +++ b/interp/notation_ops.ml @@ -13,9 +13,10 @@ open CErrors open Util open Names open Nameops +open Constr open Globnames open Decl_kinds -open Misctypes +open Namegen open Glob_term open Glob_ops open Mod_subst @@ -28,7 +29,7 @@ open Notation_term let get_var_ndx id vs = try Some (List.index Id.equal id vs) with Not_found -> None let rec eq_notation_constr (vars1,vars2 as vars) t1 t2 = match t1, t2 with -| NRef gr1, NRef gr2 -> eq_gr gr1 gr2 +| NRef gr1, NRef gr2 -> GlobRef.equal gr1 gr2 | NVar id1, NVar id2 -> ( match (get_var_ndx id1 vars1,get_var_ndx id2 vars2) with | Some n,Some m -> Int.equal n m @@ -85,7 +86,7 @@ let rec eq_notation_constr (vars1,vars2 as vars) t1 t2 = match t1, t2 with Array.equal (eq_notation_constr vars) us1 us2 && Array.equal (eq_notation_constr vars) rs1 rs2 | NSort s1, NSort s2 -> - Miscops.glob_sort_eq s1 s2 + glob_sort_eq s1 s2 | NCast (t1, c1), NCast (t2, c2) -> (eq_notation_constr vars) t1 t2 && cast_type_eq (eq_notation_constr vars) c1 c2 | NProj (p1, c1), NProj (p2, c2) -> @@ -157,7 +158,7 @@ let protect g e na = let apply_cases_pattern ?loc ((ids,disjpat),id) c = let tm = DAst.make ?loc (GVar id) in let eqns = List.map (fun pat -> (CAst.make ?loc (ids,[pat],c))) disjpat in - DAst.make ?loc @@ GCases (LetPatternStyle, None, [tm,(Anonymous,None)], eqns) + DAst.make ?loc @@ GCases (Constr.LetPatternStyle, None, [tm,(Anonymous,None)], eqns) let glob_constr_of_notation_constr_with_binders ?loc g f e nc = let lt x = DAst.make ?loc x in lt @@ match nc with @@ -165,15 +166,15 @@ let glob_constr_of_notation_constr_with_binders ?loc g f e nc = | NApp (a,args) -> GApp (f e a, List.map (f e) args) | NList (x,y,iter,tail,swap) -> let t = f e tail in let it = f e iter in - let innerl = (ldots_var,t)::(if swap then [] else [x, lt @@ GVar y]) in + let innerl = (ldots_var,t)::(if swap then [y, lt @@ GVar x] else []) in let inner = lt @@ GApp (lt @@ GVar (ldots_var),[subst_glob_vars innerl it]) in - let outerl = (ldots_var,inner)::(if swap then [x, lt @@ GVar y] else []) in + let outerl = (ldots_var,inner)::(if swap then [] else [y, lt @@ GVar x]) in DAst.get (subst_glob_vars outerl it) | NBinderList (x,y,iter,tail,swap) -> let t = f e tail in let it = f e iter in - let innerl = (ldots_var,t)::(if swap then [] else [x, lt @@ GVar y]) in + let innerl = (ldots_var,t)::(if swap then [y, lt @@ GVar x] else []) in let inner = lt @@ GApp (lt @@ GVar ldots_var,[subst_glob_vars innerl it]) in - let outerl = (ldots_var,inner)::(if swap then [x, lt @@ GVar y] else []) in + let outerl = (ldots_var,inner)::(if swap then [] else [y, lt @@ GVar x]) in DAst.get (subst_glob_vars outerl it) | NLambda (na,ty,c) -> let e',disjpat,na = g e na in GLambda (na,Explicit,f e ty,Option.fold_right (apply_cases_pattern ?loc) disjpat (f e' c)) @@ -210,12 +211,12 @@ let glob_constr_of_notation_constr_with_binders ?loc g f e nc = let e',na = protect g e na in GIf (f e c,(na,Option.map (f e') po),f e b1,f e b2) | NRec (fk,idl,dll,tl,bl) -> - let e,dll = Array.fold_left_map (List.fold_map (fun e (na,oc,b) -> + let e,dll = Array.fold_left_map (List.fold_left_map (fun e (na,oc,b) -> let e,na = protect g e na in (e,(na,Explicit,Option.map (f e) oc,f e b)))) e dll in let e',idl = Array.fold_left_map (to_id (protect g)) e idl in GRec (fk,idl,dll,Array.map (f e) tl,Array.map (f e') bl) - | NCast (c,k) -> GCast (f e c,Miscops.map_cast_type (f e) k) + | NCast (c,k) -> GCast (f e c,map_cast_type (f e) k) | NSort x -> GSort x | NHole (x, naming, arg) -> GHole (x, naming, arg) | NRef x -> GRef (x,None) @@ -433,7 +434,7 @@ let notation_constr_and_vars_of_glob_constr recvars a = user_err Pp.(str "Binders marked as implicit not allowed in notations."); add_name found na; (na,Option.map aux oc,aux b))) dll in NRec (fk,idl,dll,Array.map aux tl,Array.map aux bl) - | GCast (c,k) -> NCast (aux c,Miscops.map_cast_type aux k) + | GCast (c,k) -> NCast (aux c,map_cast_type aux k) | GSort s -> NSort s | GHole (w,naming,arg) -> if arg != None then has_ltac := true; @@ -509,7 +510,9 @@ let notation_constr_of_glob_constr nenv a = let notation_constr_of_constr avoiding t = let t = EConstr.of_constr t in - let t = Detyping.detype Detyping.Now false avoiding (Global.env()) Evd.empty t in + let env = Global.env () in + let evd = Evd.from_env env in + let t = Detyping.detype Detyping.Now false avoiding env evd t in let nenv = { ninterp_var_type = Id.Map.empty; ninterp_rec_vars = Id.Map.empty; @@ -521,7 +524,7 @@ let rec subst_pat subst pat = | PatVar _ -> pat | PatCstr (((kn,i),j),cpl,n) -> let kn' = subst_mind subst kn - and cpl' = List.smartmap (subst_pat subst) cpl in + and cpl' = List.Smart.map (subst_pat subst) cpl in if kn' == kn && cpl' == cpl then pat else DAst.make ?loc:pat.CAst.loc @@ PatCstr (((kn',i),j),cpl',n) @@ -536,7 +539,7 @@ let rec subst_notation_constr subst bound raw = | NApp (r,rl) -> let r' = subst_notation_constr subst bound r - and rl' = List.smartmap (subst_notation_constr subst bound) rl in + and rl' = List.Smart.map (subst_notation_constr subst bound) rl in if r' == r && rl' == rl then raw else NApp(r',rl') @@ -566,14 +569,14 @@ let rec subst_notation_constr subst bound raw = | NLetIn (n,r1,t,r2) -> let r1' = subst_notation_constr subst bound r1 in - let t' = Option.smartmap (subst_notation_constr subst bound) t in + let t' = Option.Smart.map (subst_notation_constr subst bound) t in let r2' = subst_notation_constr subst bound r2 in if r1' == r1 && t == t' && r2' == r2 then raw else NLetIn (n,r1',t',r2') | NCases (sty,rtntypopt,rl,branches) -> - let rtntypopt' = Option.smartmap (subst_notation_constr subst bound) rtntypopt - and rl' = List.smartmap + let rtntypopt' = Option.Smart.map (subst_notation_constr subst bound) rtntypopt + and rl' = List.Smart.map (fun (a,(n,signopt) as x) -> let a' = subst_notation_constr subst bound a in let signopt' = Option.map (fun ((indkn,i),nal as z) -> @@ -581,9 +584,9 @@ let rec subst_notation_constr subst bound raw = if indkn == indkn' then z else ((indkn',i),nal)) signopt in if a' == a && signopt' == signopt then x else (a',(n,signopt'))) rl - and branches' = List.smartmap + and branches' = List.Smart.map (fun (cpl,r as branch) -> - let cpl' = List.smartmap (subst_pat subst) cpl + let cpl' = List.Smart.map (subst_pat subst) cpl and r' = subst_notation_constr subst bound r in if cpl' == cpl && r' == r then branch else (cpl',r')) @@ -594,14 +597,14 @@ let rec subst_notation_constr subst bound raw = NCases (sty,rtntypopt',rl',branches') | NLetTuple (nal,(na,po),b,c) -> - let po' = Option.smartmap (subst_notation_constr subst bound) po + let po' = Option.Smart.map (subst_notation_constr subst bound) po and b' = subst_notation_constr subst bound b and c' = subst_notation_constr subst bound c in if po' == po && b' == b && c' == c then raw else NLetTuple (nal,(na,po'),b',c') | NIf (c,(na,po),b1,b2) -> - let po' = Option.smartmap (subst_notation_constr subst bound) po + let po' = Option.Smart.map (subst_notation_constr subst bound) po and b1' = subst_notation_constr subst bound b1 and b2' = subst_notation_constr subst bound b2 and c' = subst_notation_constr subst bound c in @@ -610,12 +613,12 @@ let rec subst_notation_constr subst bound raw = | NRec (fk,idl,dll,tl,bl) -> let dll' = - Array.smartmap (List.smartmap (fun (na,oc,b as x) -> - let oc' = Option.smartmap (subst_notation_constr subst bound) oc in + Array.Smart.map (List.Smart.map (fun (na,oc,b as x) -> + let oc' = Option.Smart.map (subst_notation_constr subst bound) oc in let b' = subst_notation_constr subst bound b in if oc' == oc && b' == b then x else (na,oc',b'))) dll in - let tl' = Array.smartmap (subst_notation_constr subst bound) tl in - let bl' = Array.smartmap (subst_notation_constr subst bound) bl in + let tl' = Array.Smart.map (subst_notation_constr subst bound) tl in + let bl' = Array.Smart.map (subst_notation_constr subst bound) bl in if dll' == dll && tl' == tl && bl' == bl then raw else NRec (fk,idl,dll',tl',bl') @@ -628,13 +631,13 @@ let rec subst_notation_constr subst bound raw = if nref == ref then knd else Evar_kinds.ImplicitArg (nref, i, b) | _ -> knd in - let nsolve = Option.smartmap (Genintern.generic_substitute subst) solve in + let nsolve = Option.Smart.map (Genintern.generic_substitute subst) solve in if nsolve == solve && nknd == knd then raw else NHole (nknd, naming, nsolve) | NCast (r1,k) -> let r1' = subst_notation_constr subst bound r1 in - let k' = Miscops.smartmap_cast_type (subst_notation_constr subst bound) k in + let k' = smartmap_cast_type (subst_notation_constr subst bound) k in if r1' == r1 && k' == k then raw else NCast(r1',k') | NProj (p, c) -> @@ -663,11 +666,11 @@ let abstract_return_type_context pi mklam tml rtno = let abstract_return_type_context_glob_constr tml rtn = abstract_return_type_context (fun {CAst.v=(_,nal)} -> nal) (fun na c -> DAst.make @@ - GLambda(na,Explicit,DAst.make @@ GHole(Evar_kinds.InternalHole,Misctypes.IntroAnonymous,None),c)) tml rtn + GLambda(na,Explicit,DAst.make @@ GHole(Evar_kinds.InternalHole,IntroAnonymous,None),c)) tml rtn let abstract_return_type_context_notation_constr tml rtn = abstract_return_type_context snd - (fun na c -> NLambda(na,NHole (Evar_kinds.InternalHole, Misctypes.IntroAnonymous, None),c)) tml rtn + (fun na c -> NLambda(na,NHole (Evar_kinds.InternalHole, IntroAnonymous, None),c)) tml rtn let is_term_meta id metas = try match Id.List.assoc id metas with _,(NtnTypeConstr | NtnTypeConstrList) -> true | _ -> false @@ -684,7 +687,7 @@ let is_onlybinding_meta id metas = let is_onlybinding_pattern_like_meta isvar id metas = try match Id.List.assoc id metas with | _,NtnTypeBinder (NtnBinderParsedAsConstr - (Extend.AsIdentOrPattern | Extend.AsStrictPattern)) -> true + (AsIdentOrPattern | AsStrictPattern)) -> true | _,NtnTypeBinder (NtnParsedAsPattern strict) -> not (strict && isvar) | _ -> false with Not_found -> false @@ -1123,7 +1126,7 @@ let rec match_ inner u alp metas sigma a1 a2 = (* Matching compositionally *) | GVar id1, NVar id2 when alpha_var id1 id2 (fst alp) -> sigma - | GRef (r1,_), NRef r2 when (eq_gr r1 r2) -> sigma + | GRef (r1,_), NRef r2 when (GlobRef.equal r1 r2) -> sigma | GApp (f1,l1), NApp (f2,l2) -> let n1 = List.length l1 and n2 = List.length l2 in let f1,l1,f2,l2 = @@ -1191,7 +1194,7 @@ let rec match_ inner u alp metas sigma a1 a2 = | GCast(t1, c1), NCast(t2, c2) -> match_cast (match_in u alp metas) (match_in u alp metas sigma t1 t2) c1 c2 | GSort (GType _), NSort (GType _) when not u -> sigma - | GSort s1, NSort s2 when Miscops.glob_sort_eq s1 s2 -> sigma + | GSort s1, NSort s2 when glob_sort_eq s1 s2 -> sigma | GPatVar _, NHole _ -> (*Don't hide Metas, they bind in ltac*) raise No_match | a, NHole _ -> sigma @@ -1205,7 +1208,7 @@ let rec match_ inner u alp metas sigma a1 a2 = let avoid = Id.Set.union (free_glob_vars a1) (* as in Namegen: *) (glob_visible_short_qualid a1) in let id' = Namegen.next_ident_away id avoid in - let t1 = DAst.make @@ GHole(Evar_kinds.BinderType (Name id'),Misctypes.IntroAnonymous,None) in + let t1 = DAst.make @@ GHole(Evar_kinds.BinderType (Name id'),IntroAnonymous,None) in let sigma = match t2 with | NHole _ -> sigma | NVar id2 -> bind_term_env alp sigma id2 t1 @@ -1238,7 +1241,7 @@ and match_extended_binders ?loc isprod u alp metas na1 na2 bk t sigma b1 b2 = let store, get = set_temporary_memory () in match na1, DAst.get b1, na2 with (* Matching individual binders as part of a recursive pattern *) - | Name p, GCases (LetPatternStyle,None,[(e,_)],(_::_ as eqns)), Name id + | Name p, GCases (Constr.LetPatternStyle,None,[(e,_)],(_::_ as eqns)), Name id when is_gvar p e && is_bindinglist_meta id metas && List.length (store (Detyping.factorize_eqns eqns)) = 1 -> (match get () with | [{CAst.v=(ids,disj_of_patl,b1)}] -> @@ -1335,10 +1338,10 @@ let rec match_cases_pattern metas (terms,termlists,(),() as sigma) a1 a2 = match DAst.get a1, a2 with | r1, NVar id2 when Id.List.mem_assoc id2 metas -> (bind_env_cases_pattern sigma id2 a1),(0,[]) | PatVar Anonymous, NHole _ -> sigma,(0,[]) - | PatCstr ((ind,_ as r1),largs,_), NRef (ConstructRef r2) when eq_constructor r1 r2 -> + | PatCstr ((ind,_ as r1),largs,Anonymous), NRef (ConstructRef r2) when eq_constructor r1 r2 -> let l = try add_patterns_for_params_remove_local_defs r1 largs with Not_found -> raise No_match in sigma,(0,l) - | PatCstr ((ind,_ as r1),args1,_), NApp (NRef (ConstructRef r2),l2) + | PatCstr ((ind,_ as r1),args1,Anonymous), NApp (NRef (ConstructRef r2),l2) when eq_constructor r1 r2 -> let l1 = try add_patterns_for_params_remove_local_defs r1 args1 with Not_found -> raise No_match in let le2 = List.length l2 in diff --git a/intf/notation_term.ml b/interp/notation_term.ml index a9c2e2a53..6d9effcef 100644 --- a/intf/notation_term.ml +++ b/interp/notation_term.ml @@ -9,8 +9,6 @@ (************************************************************************) open Names -open Globnames -open Misctypes open Glob_term (** [notation_constr] *) @@ -23,10 +21,10 @@ open Glob_term type notation_constr = (** Part common to [glob_constr] and [cases_pattern] *) - | NRef of global_reference + | NRef of GlobRef.t | NVar of Id.t | NApp of notation_constr * notation_constr list - | NHole of Evar_kinds.t * Misctypes.intro_pattern_naming_expr * Genarg.glob_generic_argument option + | NHole of Evar_kinds.t * Namegen.intro_pattern_naming_expr * Genarg.glob_generic_argument option | NList of Id.t * Id.t * notation_constr * notation_constr * (* associativity: *) bool (** Part only in [glob_constr] *) | NLambda of Name.t * notation_constr * notation_constr @@ -63,6 +61,11 @@ type subscopes = tmp_scope_name option * scope_name list (** Type of the meta-variables of an notation_constr: in a recursive pattern x..y, x carries the sequence of objects bound to the list x..y *) +type constr_as_binder_kind = + | AsIdent + | AsIdentOrPattern + | AsStrictPattern + type notation_binder_source = (* This accepts only pattern *) (* NtnParsedAsPattern true means only strict pattern (no single variable) at printing *) @@ -70,7 +73,7 @@ type notation_binder_source = (* This accepts only ident *) | NtnParsedAsIdent (* This accepts ident, or pattern, or both *) - | NtnBinderParsedAsConstr of Extend.constr_as_binder_kind + | NtnBinderParsedAsConstr of constr_as_binder_kind type notation_var_instance_type = | NtnTypeConstr | NtnTypeBinder of notation_binder_source | NtnTypeConstrList | NtnTypeBinderList @@ -92,33 +95,3 @@ type notation_interp_env = { ninterp_var_type : notation_var_internalization_type Id.Map.t; ninterp_rec_vars : Id.t Id.Map.t; } - -type grammar_constr_prod_item = - | GramConstrTerminal of Tok.t - | GramConstrNonTerminal of Extend.constr_prod_entry_key * Id.t option - | GramConstrListMark of int * bool * int - (* tells action rule to make a list of the n previous parsed items; - concat with last parsed list when true; additionally release - the p last items as if they were parsed autonomously *) - -(** Dealing with precedences *) - -type precedence = int -type parenRelation = L | E | Any | Prec of precedence -type tolerability = precedence * parenRelation - -type level = precedence * tolerability list * Extend.constr_entry_key list - -(** Grammar rules for a notation *) - -type one_notation_grammar = { - notgram_level : level; - notgram_assoc : Extend.gram_assoc option; - notgram_notation : Constrexpr.notation; - notgram_prods : grammar_constr_prod_item list list; -} - -type notation_grammar = { - notgram_onlyprinting : bool; - notgram_rules : one_notation_grammar list -} diff --git a/pretyping/redops.ml b/interp/redops.ml index 90c3bdfae..b9a74136e 100644 --- a/pretyping/redops.ml +++ b/interp/redops.ml @@ -42,3 +42,23 @@ let make_red_flag l = let all_flags = {rBeta = true; rMatch = true; rFix = true; rCofix = true; rZeta = true; rDelta = true; rConst = []} + +(** Mapping [red_expr_gen] *) + +let map_flags f flags = + { flags with rConst = List.map f flags.rConst } + +let map_occs f (occ,e) = (occ,f e) + +let map_red_expr_gen f g h = function + | Fold l -> Fold (List.map f l) + | Pattern occs_l -> Pattern (List.map (map_occs f) occs_l) + | Simpl (flags,occs_o) -> + Simpl (map_flags g flags, Option.map (map_occs (Util.map_union g h)) occs_o) + | Unfold occs_l -> Unfold (List.map (map_occs g) occs_l) + | Cbv flags -> Cbv (map_flags g flags) + | Lazy flags -> Lazy (map_flags g flags) + | CbvVm occs_o -> CbvVm (Option.map (map_occs (Util.map_union g h)) occs_o) + | CbvNative occs_o -> CbvNative (Option.map (map_occs (Util.map_union g h)) occs_o) + | Cbn flags -> Cbn (map_flags g flags) + | ExtraRedExpr _ | Red _ | Hnf as x -> x diff --git a/pretyping/redops.mli b/interp/redops.mli index 285931ecd..7254f29b2 100644 --- a/pretyping/redops.mli +++ b/interp/redops.mli @@ -13,3 +13,8 @@ open Genredexpr val make_red_flag : 'a red_atom list -> 'a glob_red_flag val all_flags : 'a glob_red_flag + +(** Mapping [red_expr_gen] *) + +val map_red_expr_gen : ('a -> 'd) -> ('b -> 'e) -> ('c -> 'f) -> + ('a,'b,'c) red_expr_gen -> ('d,'e,'f) red_expr_gen diff --git a/interp/reserve.ml b/interp/reserve.ml index 36005121b..071248f01 100644 --- a/interp/reserve.ml +++ b/interp/reserve.ml @@ -22,7 +22,7 @@ open Notation_ops open Globnames type key = - | RefKey of global_reference + | RefKey of GlobRef.t | Oth (** TODO: share code from Notation *) @@ -112,7 +112,9 @@ let revert_reserved_type t = let t = EConstr.Unsafe.to_constr t in let reserved = KeyMap.find (constr_key t) !reserve_revtable in let t = EConstr.of_constr t in - let t = Detyping.detype Detyping.Now false Id.Set.empty (Global.env()) Evd.empty t in + let env = Global.env () in + let evd = Evd.from_env env in + let t = Detyping.detype Detyping.Now false Id.Set.empty env evd t in (* pedrot: if [Notation_ops.match_notation_constr] may raise [Failure _] then I've introduced a bug... *) let filter _ pat = diff --git a/interp/reserve.mli b/interp/reserve.mli index daee58639..a10858e71 100644 --- a/interp/reserve.mli +++ b/interp/reserve.mli @@ -11,5 +11,5 @@ open Names open Notation_term -val declare_reserved_type : Misctypes.lident list -> notation_constr -> unit +val declare_reserved_type : lident list -> notation_constr -> unit val find_reserved_type : Id.t -> notation_constr diff --git a/interp/smartlocate.ml b/interp/smartlocate.ml index 1f4a93a6f..e1fbdba87 100644 --- a/interp/smartlocate.ml +++ b/interp/smartlocate.ml @@ -18,7 +18,6 @@ open Pp open CErrors open Libnames open Globnames -open Misctypes open Syntax_def open Notation_term @@ -65,13 +64,13 @@ let global_with_alias ?head r = try locate_global_with_alias ?head qid with Not_found -> Nametab.error_global_not_found qid -let smart_global ?head = CAst.with_loc_val (fun ?loc -> function +let smart_global ?head = let open Constrexpr in CAst.with_loc_val (fun ?loc -> function | AN r -> global_with_alias ?head r | ByNotation (ntn,sc) -> Notation.interp_notation_as_global_reference ?loc (fun _ -> true) ntn sc) -let smart_global_inductive = CAst.with_loc_val (fun ?loc -> function +let smart_global_inductive = let open Constrexpr in CAst.with_loc_val (fun ?loc -> function | AN r -> global_inductive_with_alias r | ByNotation (ntn,sc) -> diff --git a/interp/smartlocate.mli b/interp/smartlocate.mli index 7ff7e899e..6b574d7b5 100644 --- a/interp/smartlocate.mli +++ b/interp/smartlocate.mli @@ -11,29 +11,28 @@ open Names open Libnames open Globnames -open Misctypes (** [locate_global_with_alias] locates global reference possibly following a notation if this notation has a role of aliasing; raise [Not_found] if not bound in the global env; raise a [UserError] if bound to a syntactic def that does not denote a reference *) -val locate_global_with_alias : ?head:bool -> qualid CAst.t -> global_reference +val locate_global_with_alias : ?head:bool -> qualid CAst.t -> GlobRef.t (** Extract a global_reference from a reference that can be an "alias" *) -val global_of_extended_global : extended_global_reference -> global_reference +val global_of_extended_global : extended_global_reference -> GlobRef.t (** Locate a reference taking into account possible "alias" notations. May raise [Nametab.GlobalizationError _] for an unknown reference, or a [UserError] if bound to a syntactic def that does not denote a reference. *) -val global_with_alias : ?head:bool -> reference -> global_reference +val global_with_alias : ?head:bool -> reference -> GlobRef.t (** The same for inductive types *) val global_inductive_with_alias : reference -> inductive (** Locate a reference taking into account notations and "aliases" *) -val smart_global : ?head:bool -> reference or_by_notation -> global_reference +val smart_global : ?head:bool -> reference Constrexpr.or_by_notation -> GlobRef.t (** The same for inductive types *) -val smart_global_inductive : reference or_by_notation -> inductive +val smart_global_inductive : reference Constrexpr.or_by_notation -> inductive diff --git a/interp/stdarg.ml b/interp/stdarg.ml index e5ed58be6..7b01b6dc1 100644 --- a/interp/stdarg.ml +++ b/interp/stdarg.ml @@ -11,6 +11,8 @@ open Genarg open Geninterp +type 'a and_short_name = 'a * Names.lident option + let make0 ?dyn name = let wit = Genarg.make0 name in let () = register_val0 wit dyn in @@ -34,9 +36,6 @@ let wit_pre_ident : string uniform_genarg_type = let wit_int_or_var = make0 ~dyn:(val_tag (topwit wit_int)) "int_or_var" -let wit_intro_pattern = - make0 "intropattern" - let wit_ident = make0 "ident" @@ -45,8 +44,6 @@ let wit_var = let wit_ref = make0 "ref" -let wit_quant_hyp = make0 "quant_hyp" - let wit_sort_family = make0 "sort_family" let wit_constr = @@ -56,12 +53,6 @@ let wit_uconstr = make0 "uconstr" let wit_open_constr = make0 ~dyn:(val_tag (topwit wit_constr)) "open_constr" -let wit_constr_with_bindings = make0 "constr_with_bindings" - -let wit_open_constr_with_bindings = make0 "open_constr_with_bindings" - -let wit_bindings = make0 "bindings" - let wit_red_expr = make0 "redexpr" let wit_clause_dft_concl = @@ -74,6 +65,4 @@ let wit_preident = wit_pre_ident let wit_reference = wit_ref let wit_global = wit_ref let wit_clause = wit_clause_dft_concl -let wit_quantified_hypothesis = wit_quant_hyp -let wit_intropattern = wit_intro_pattern let wit_redexpr = wit_red_expr diff --git a/interp/stdarg.mli b/interp/stdarg.mli index 53d1a522d..4792cda08 100644 --- a/interp/stdarg.mli +++ b/interp/stdarg.mli @@ -14,13 +14,14 @@ open Loc open Names open EConstr open Libnames -open Globnames open Genredexpr open Pattern open Constrexpr -open Misctypes -open Tactypes open Genarg +open Genintern +open Locus + +type 'a and_short_name = 'a * lident option val wit_unit : unit uniform_genarg_type @@ -36,15 +37,11 @@ val wit_pre_ident : string uniform_genarg_type val wit_int_or_var : (int or_var, int or_var, int) genarg_type -val wit_intro_pattern : (constr_expr intro_pattern_expr CAst.t, glob_constr_and_expr intro_pattern_expr CAst.t, intro_pattern) genarg_type - val wit_ident : Id.t uniform_genarg_type val wit_var : (lident, lident, Id.t) genarg_type -val wit_ref : (reference, global_reference located or_var, global_reference) genarg_type - -val wit_quant_hyp : quantified_hypothesis uniform_genarg_type +val wit_ref : (reference, GlobRef.t located or_var, GlobRef.t) genarg_type val wit_sort_family : (Sorts.family, unit, unit) genarg_type @@ -55,21 +52,6 @@ val wit_uconstr : (constr_expr , glob_constr_and_expr, Ltac_pretype.closed_glob_ val wit_open_constr : (constr_expr, glob_constr_and_expr, constr) genarg_type -val wit_constr_with_bindings : - (constr_expr with_bindings, - glob_constr_and_expr with_bindings, - constr with_bindings delayed_open) genarg_type - -val wit_open_constr_with_bindings : - (constr_expr with_bindings, - glob_constr_and_expr with_bindings, - constr with_bindings delayed_open) genarg_type - -val wit_bindings : - (constr_expr bindings, - glob_constr_and_expr bindings, - constr bindings delayed_open) genarg_type - val wit_red_expr : ((constr_expr,reference or_by_notation,constr_expr) red_expr_gen, (glob_constr_and_expr,evaluable_global_reference and_short_name or_var,glob_constr_pattern_and_expr) red_expr_gen, @@ -81,11 +63,9 @@ val wit_clause_dft_concl : (lident Locus.clause_expr, lident Locus.clause_expr, val wit_integer : int uniform_genarg_type val wit_preident : string uniform_genarg_type -val wit_reference : (reference, global_reference located or_var, global_reference) genarg_type -val wit_global : (reference, global_reference located or_var, global_reference) genarg_type +val wit_reference : (reference, GlobRef.t located or_var, GlobRef.t) genarg_type +val wit_global : (reference, GlobRef.t located or_var, GlobRef.t) genarg_type val wit_clause : (lident Locus.clause_expr, lident Locus.clause_expr, Names.Id.t Locus.clause_expr) genarg_type -val wit_quantified_hypothesis : quantified_hypothesis uniform_genarg_type -val wit_intropattern : (constr_expr intro_pattern_expr CAst.t, glob_constr_and_expr intro_pattern_expr CAst.t, intro_pattern) genarg_type val wit_redexpr : ((constr_expr,reference or_by_notation,constr_expr) red_expr_gen, (glob_constr_and_expr,evaluable_global_reference and_short_name or_var,glob_constr_pattern_and_expr) red_expr_gen, diff --git a/interp/syntax_def.ml b/interp/syntax_def.ml index 47faa5885..a4f20fd73 100644 --- a/interp/syntax_def.ml +++ b/interp/syntax_def.ml @@ -96,13 +96,13 @@ let warn_compatibility_notation = CWarnings.(create ~name:"compatibility-notation" ~category:"deprecated" ~default:Enabled pr_compat_warning) -let verbose_compat kn def = function +let verbose_compat ?loc kn def = function | Some v when Flags.version_strictly_greater v -> - warn_compatibility_notation (kn, def, v) + warn_compatibility_notation ?loc (kn, def, v) | _ -> () -let search_syntactic_definition kn = +let search_syntactic_definition ?loc kn = let pat,v = KNmap.find kn !syntax_table in let def = out_pat pat in - verbose_compat kn def v; + verbose_compat ?loc kn def v; def diff --git a/interp/syntax_def.mli b/interp/syntax_def.mli index 1933b8a9a..c5b6655ff 100644 --- a/interp/syntax_def.mli +++ b/interp/syntax_def.mli @@ -18,4 +18,4 @@ type syndef_interpretation = (Id.t * subscopes) list * notation_constr val declare_syntactic_definition : bool -> Id.t -> Flags.compat_version option -> syndef_interpretation -> unit -val search_syntactic_definition : KerName.t -> syndef_interpretation +val search_syntactic_definition : ?loc:Loc.t -> KerName.t -> syndef_interpretation diff --git a/interp/topconstr.ml b/interp/topconstr.ml deleted file mode 100644 index 7d2d75d9c..000000000 --- a/interp/topconstr.ml +++ /dev/null @@ -1,23 +0,0 @@ -(************************************************************************) -(* * The Coq Proof Assistant / The Coq Development Team *) -(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) -(* <O___,, * (see CREDITS file for the list of authors) *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(* * (see LICENSE file for the text of the license) *) -(************************************************************************) - -open Constrexpr_ops - -let asymmetric_patterns = asymmetric_patterns -let error_invalid_pattern_notation = error_invalid_pattern_notation -let split_at_annot = split_at_annot -let ntn_loc = ntn_loc -let patntn_loc = patntn_loc -let map_constr_expr_with_binders = map_constr_expr_with_binders -let fold_constr_expr_with_binders = fold_constr_expr_with_binders -let ids_of_cases_indtype = ids_of_cases_indtype -let occur_var_constr_expr = occur_var_constr_expr -let free_vars_of_constr_expr = free_vars_of_constr_expr -let replace_vars_constr_expr = replace_vars_constr_expr diff --git a/interp/topconstr.mli b/interp/topconstr.mli deleted file mode 100644 index c86502015..000000000 --- a/interp/topconstr.mli +++ /dev/null @@ -1,53 +0,0 @@ -(************************************************************************) -(* * The Coq Proof Assistant / The Coq Development Team *) -(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) -(* <O___,, * (see CREDITS file for the list of authors) *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(* * (see LICENSE file for the text of the license) *) -(************************************************************************) - -open Names -open Constrexpr - -(** Topconstr: This whole module is deprecated in favor of Constrexpr_ops *) -val asymmetric_patterns : bool ref -[@@ocaml.deprecated "use Constrexpr_ops.asymmetric_patterns"] - -(** Utilities on constr_expr *) -val split_at_annot : local_binder_expr list -> Misctypes.lident option -> local_binder_expr list * local_binder_expr list -[@@ocaml.deprecated "use Constrexpr_ops.split_at_annot"] - -val ntn_loc : ?loc:Loc.t -> constr_notation_substitution -> string -> (int * int) list -[@@ocaml.deprecated "use Constrexpr_ops.ntn_loc"] -val patntn_loc : ?loc:Loc.t -> cases_pattern_notation_substitution -> string -> (int * int) list -[@@ocaml.deprecated "use Constrexpr_ops.patntn_loc"] - -(** For cases pattern parsing errors *) -val error_invalid_pattern_notation : ?loc:Loc.t -> unit -> 'a -[@@ocaml.deprecated "use Constrexpr_ops.error_invalid_pattern_notation"] - -(*************************************************************************) -val replace_vars_constr_expr : Id.t Id.Map.t -> constr_expr -> constr_expr -[@@ocaml.deprecated "use Constrexpr_ops.free_vars_of_constr_expr"] - -val free_vars_of_constr_expr : constr_expr -> Id.Set.t -[@@ocaml.deprecated "use Constrexpr_ops.free_vars_of_constr_expr"] - -val occur_var_constr_expr : Id.t -> constr_expr -> bool -[@@ocaml.deprecated "use Constrexpr_ops.occur_var_constr_expr"] - -(** Specific function for interning "in indtype" syntax of "match" *) -val ids_of_cases_indtype : cases_pattern_expr -> Id.Set.t -[@@ocaml.deprecated "use Constrexpr_ops.ids_of_cases_indtype"] - -(** Used in typeclasses *) -val fold_constr_expr_with_binders : (Id.t -> 'a -> 'a) -> - ('a -> 'b -> constr_expr -> 'b) -> 'a -> 'b -> constr_expr -> 'b -[@@ocaml.deprecated "use Constrexpr_ops.fold_constr_expr_with_binders"] - -val map_constr_expr_with_binders : - (Id.t -> 'a -> 'a) -> ('a -> constr_expr -> constr_expr) -> - 'a -> constr_expr -> constr_expr -[@@ocaml.deprecated "use Constrexpr_ops.map_constr_expr_with_binders"] diff --git a/intf/intf.mllib b/intf/intf.mllib deleted file mode 100644 index 2b8960d3f..000000000 --- a/intf/intf.mllib +++ /dev/null @@ -1,11 +0,0 @@ -Constrexpr -Evar_kinds -Genredexpr -Locus -Extend -Notation_term -Decl_kinds -Glob_term -Misctypes -Pattern -Vernacexpr diff --git a/intf/misctypes.ml b/intf/misctypes.ml deleted file mode 100644 index 72db3b31c..000000000 --- a/intf/misctypes.ml +++ /dev/null @@ -1,149 +0,0 @@ -(************************************************************************) -(* * The Coq Proof Assistant / The Coq Development Team *) -(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) -(* <O___,, * (see CREDITS file for the list of authors) *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(* * (see LICENSE file for the text of the license) *) -(************************************************************************) - -open Names - -(** Basic types used both in [constr_expr], [glob_constr], and [vernacexpr] *) - -(** Located identifiers and objects with syntax. *) - -type lident = Id.t CAst.t -type lname = Name.t CAst.t -type lstring = string CAst.t - -(** Cases pattern variables *) - -type patvar = Id.t - -(** Introduction patterns *) - -type 'constr intro_pattern_expr = - | IntroForthcoming of bool - | IntroNaming of intro_pattern_naming_expr - | IntroAction of 'constr intro_pattern_action_expr -and intro_pattern_naming_expr = - | IntroIdentifier of Id.t - | IntroFresh of Id.t - | IntroAnonymous -and 'constr intro_pattern_action_expr = - | IntroWildcard - | IntroOrAndPattern of 'constr or_and_intro_pattern_expr - | IntroInjection of ('constr intro_pattern_expr) CAst.t list - | IntroApplyOn of 'constr CAst.t * 'constr intro_pattern_expr CAst.t - | IntroRewrite of bool -and 'constr or_and_intro_pattern_expr = - | IntroOrPattern of ('constr intro_pattern_expr) CAst.t list list - | IntroAndPattern of ('constr intro_pattern_expr) CAst.t list - -(** Move destination for hypothesis *) - -type 'id move_location = - | MoveAfter of 'id - | MoveBefore of 'id - | MoveFirst - | MoveLast (** can be seen as "no move" when doing intro *) - -(** Sorts *) - -type 'a glob_sort_gen = - | GProp (** representation of [Prop] literal *) - | GSet (** representation of [Set] literal *) - | GType of 'a (** representation of [Type] literal *) - -type 'a universe_kind = - | UAnonymous - | UUnknown - | UNamed of 'a - -type level_info = Libnames.reference universe_kind -type glob_level = level_info glob_sort_gen -type glob_constraint = glob_level * Univ.constraint_type * glob_level - -type sort_info = (Libnames.reference * int) option list -type glob_sort = sort_info glob_sort_gen - -(** A synonym of [Evar.t], also defined in Term *) - -type existential_key = Evar.t - -(** Case style, shared with Term *) - -type case_style = Constr.case_style = - | LetStyle - | IfStyle - | LetPatternStyle - | MatchStyle - | RegularStyle (** infer printing form from number of constructor *) -[@@ocaml.deprecated "Alias for Constr.case_style"] - -(** Casts *) - -type 'a cast_type = - | CastConv of 'a - | CastVM of 'a - | CastCoerce (** Cast to a base type (eg, an underlying inductive type) *) - | CastNative of 'a - -(** Bindings *) - -type quantified_hypothesis = AnonHyp of int | NamedHyp of Id.t - -type 'a explicit_bindings = (quantified_hypothesis * 'a) CAst.t list - -type 'a bindings = - | ImplicitBindings of 'a list - | ExplicitBindings of 'a explicit_bindings - | NoBindings - -type 'a with_bindings = 'a * 'a bindings - - -(** Some utility types for parsing *) - -type 'a or_var = - | ArgArg of 'a - | ArgVar of lident - -type 'a and_short_name = 'a * lident option - -type 'a or_by_notation_r = - | AN of 'a - | ByNotation of (string * string option) - -type 'a or_by_notation = 'a or_by_notation_r CAst.t - -(* NB: the last string in [ByNotation] is actually a [Notation.delimiters], - but this formulation avoids a useless dependency. *) - - -(** Kinds of modules *) - -type module_kind = Module | ModType | ModAny - -(** Various flags *) - -type direction_flag = bool (* true = Left-to-right false = right-to-right *) -type evars_flag = bool (* true = pose evars false = fail on evars *) -type rec_flag = bool (* true = recursive false = not recursive *) -type advanced_flag = bool (* true = advanced false = basic *) -type letin_flag = bool (* true = use local def false = use Leibniz *) -type clear_flag = bool option (* true = clear hyp, false = keep hyp, None = use default *) - -type multi = - | Precisely of int - | UpTo of int - | RepeatStar - | RepeatPlus - -type ('a, 'b) gen_universe_decl = { - univdecl_instance : 'a; (* Declared universes *) - univdecl_extensible_instance : bool; (* Can new universes be added *) - univdecl_constraints : 'b; (* Declared constraints *) - univdecl_extensible_constraints : bool (* Can new constraints be added *) } diff --git a/kernel/byterun/coq_fix_code.c b/kernel/byterun/coq_fix_code.c index d5feafbf9..be2b05da8 100644 --- a/kernel/byterun/coq_fix_code.c +++ b/kernel/byterun/coq_fix_code.c @@ -18,6 +18,7 @@ #include <caml/misc.h> #include <caml/mlvalues.h> #include <caml/fail.h> +#include <caml/alloc.h> #include <caml/memory.h> #include "coq_instruct.h" #include "coq_fix_code.h" @@ -78,38 +79,41 @@ void * coq_stat_alloc (asize_t sz) } value coq_makeaccu (value i) { - code_t q; - code_t res = coq_stat_alloc(2 * sizeof(opcode_t)); - q = res; + CAMLparam1(i); + CAMLlocal1(res); + code_t q = coq_stat_alloc(2 * sizeof(opcode_t)); + res = caml_alloc_small(1, Abstract_tag); + Code_val(res) = q; *q++ = VALINSTR(MAKEACCU); *q = (opcode_t)Int_val(i); - return (value)res; + CAMLreturn(res); } value coq_pushpop (value i) { - code_t res; - int n; - n = Int_val(i); + CAMLparam1(i); + CAMLlocal1(res); + code_t q; + res = caml_alloc_small(1, Abstract_tag); + int n = Int_val(i); if (n == 0) { - res = coq_stat_alloc(sizeof(opcode_t)); - *res = VALINSTR(STOP); - return (value)res; + q = coq_stat_alloc(sizeof(opcode_t)); + Code_val(res) = q; + *q = VALINSTR(STOP); + CAMLreturn(res); } else { - code_t q; - res = coq_stat_alloc(3 * sizeof(opcode_t)); - q = res; + q = coq_stat_alloc(3 * sizeof(opcode_t)); + Code_val(res) = q; *q++ = VALINSTR(POP); *q++ = (opcode_t)n; *q = VALINSTR(STOP); - return (value)res; + CAMLreturn(res); } } value coq_is_accumulate_code(value code){ - code_t q; + code_t q = Code_val(code); int res; - q = (code_t)code; res = Is_instruction(q,ACCUMULATE); return Val_bool(res); } @@ -132,11 +136,14 @@ value coq_is_accumulate_code(value code){ #define COPY32(dst,src) (*dst=*src) #endif /* ARCH_BIG_ENDIAN */ -value coq_tcode_of_code (value code, value size) { - code_t p, q, res; - asize_t len = (asize_t) Long_val(size); - res = coq_stat_alloc(len); - q = res; +value coq_tcode_of_code (value code) { + CAMLparam1 (code); + CAMLlocal1 (res); + code_t p, q; + asize_t len = (asize_t) caml_string_length(code); + res = caml_alloc_small(1, Abstract_tag); + q = coq_stat_alloc(len); + Code_val(res) = q; len /= sizeof(opcode_t); for (p = (code_t)code; p < (code_t)code + len; /*nothing*/) { opcode_t instr; @@ -166,5 +173,5 @@ value coq_tcode_of_code (value code, value size) { for(i=0; i<ar; i++) { COPY32(q,p); p++; q++; }; } } - return (value)res; + CAMLreturn(res); } diff --git a/kernel/byterun/coq_fix_code.h b/kernel/byterun/coq_fix_code.h index 5c85389dd..638d6b5ab 100644 --- a/kernel/byterun/coq_fix_code.h +++ b/kernel/byterun/coq_fix_code.h @@ -26,7 +26,7 @@ void init_arity(); #define Is_instruction(pc,instr) (*pc == VALINSTR(instr)) -value coq_tcode_of_code(value code, value len); +value coq_tcode_of_code(value code); value coq_makeaccu (value i); value coq_pushpop (value i); value coq_is_accumulate_code(value code); diff --git a/kernel/byterun/coq_interp.c b/kernel/byterun/coq_interp.c index af89712d5..a944dbb06 100644 --- a/kernel/byterun/coq_interp.c +++ b/kernel/byterun/coq_interp.c @@ -16,6 +16,7 @@ #include <stdio.h> #include <signal.h> #include <stdint.h> +#include <caml/memory.h> #include "coq_gc.h" #include "coq_instruct.h" #include "coq_fix_code.h" @@ -163,8 +164,11 @@ extern void caml_process_pending_signals(void); /* The interpreter itself */ value coq_interprete -(code_t coq_pc, value coq_accu, value coq_env, long coq_extra_args) +(code_t coq_pc, value coq_accu, value coq_atom_tbl, value coq_global_data, value coq_env, long coq_extra_args) { + /* coq_accu is not allocated on the OCaml heap */ + CAMLparam2(coq_atom_tbl, coq_global_data); + /*Declaration des variables */ #ifdef PC_REG register code_t pc PC_REG; @@ -196,7 +200,7 @@ value coq_interprete coq_instr_table = (char **) coq_jumptable; coq_instr_base = coq_Jumptbl_base; #endif - return Val_unit; + CAMLreturn(Val_unit); } #if defined(THREADED_CODE) && defined(ARCH_SIXTYFOUR) && !defined(ARCH_CODE32) coq_jumptbl_base = coq_Jumptbl_base; @@ -626,7 +630,7 @@ value coq_interprete print_instr("CLOSUREREC"); if (nvars > 0) *--sp = accu; /* construction du vecteur de type */ - Alloc_small(accu, nfuncs, 0); + Alloc_small(accu, nfuncs, Abstract_tag); for(i = 0; i < nfuncs; i++) { Field(accu,i) = (value)(pc+pc[i]); } @@ -662,7 +666,7 @@ value coq_interprete print_instr("CLOSURECOFIX"); if (nvars > 0) *--sp = accu; /* construction du vecteur de type */ - Alloc_small(accu, nfunc, 0); + Alloc_small(accu, nfunc, Abstract_tag); for(i = 0; i < nfunc; i++) { Field(accu,i) = (value)(pc+pc[i]); } @@ -1028,7 +1032,7 @@ value coq_interprete CHECK_STACK(nargs+1); sp -= nargs; for (i = 0; i < nargs; i++) sp[i] = Field(accu, i + 2); - *--sp = accu; // Last argument is the pointer to the suspension + *--sp = accu; // Leftmost argument is the pointer to the suspension print_lint(nargs); coq_extra_args = nargs; pc = Code_val(coq_env); // Trigger evaluation @@ -1068,12 +1072,22 @@ value coq_interprete } } *--sp = accu; - /* We create the switch zipper */ - Alloc_small(accu, 5, Default_tag); - Field(accu, 0) = (value)typlbl; Field(accu, 1) = (value)swlbl; - Field(accu, 2) = sp[1]; Field(accu, 3) = sp[0]; - Field(accu, 4) = coq_env; - sp++;sp[0] = accu; + /* Create bytecode wrappers */ + Alloc_small(accu, 1, Abstract_tag); + Code_val(accu) = typlbl; + *--sp = accu; + Alloc_small(accu, 1, Abstract_tag); + Code_val(accu) = swlbl; + *--sp = accu; + /* We create the switch zipper */ + Alloc_small(accu, 5, Default_tag); + Field(accu, 0) = sp[1]; + Field(accu, 1) = sp[0]; + Field(accu, 2) = sp[3]; + Field(accu, 3) = sp[2]; + Field(accu, 4) = coq_env; + sp += 3; + sp[0] = accu; /* We create the atom */ Alloc_small(accu, 2, ATOM_SWITCH_TAG); Field(accu, 0) = sp[1]; Field(accu, 1) = sp[0]; @@ -1460,7 +1474,7 @@ value coq_interprete Instruct(STOP){ print_instr("STOP"); coq_sp = sp; - return accu; + CAMLreturn(accu); } @@ -1473,7 +1487,8 @@ value coq_interprete #endif } -value coq_push_ra(value tcode) { +value coq_push_ra(value code) { + code_t tcode = Code_val(code); print_instr("push_ra"); coq_sp -= 3; coq_sp[0] = (value) tcode; @@ -1512,12 +1527,18 @@ value coq_push_vstack(value stk, value max_stack_size) { return Val_unit; } -value coq_interprete_ml(value tcode, value a, value e, value ea) { +value coq_interprete_ml(value tcode, value a, value t, value g, value e, value ea) { + // Registering the other arguments w.r.t. the OCaml GC is done by coq_interprete + CAMLparam1(tcode); print_instr("coq_interprete"); - return coq_interprete((code_t)tcode, a, e, Long_val(ea)); + CAMLreturn (coq_interprete(Code_val(tcode), a, t, g, e, Long_val(ea))); print_instr("end coq_interprete"); } -value coq_eval_tcode (value tcode, value e) { - return coq_interprete_ml(tcode, Val_unit, e, 0); +value coq_interprete_byte(value* argv, int argn){ + return coq_interprete_ml(argv[0], argv[1], argv[2], argv[3], argv[4], argv[5]); +} + +value coq_eval_tcode (value tcode, value t, value g, value e) { + return coq_interprete_ml(tcode, Val_unit, t, g, e, 0); } diff --git a/kernel/byterun/coq_interp.h b/kernel/byterun/coq_interp.h index 60865c32e..c04e9e00b 100644 --- a/kernel/byterun/coq_interp.h +++ b/kernel/byterun/coq_interp.h @@ -17,11 +17,10 @@ value coq_push_arguments(value args); value coq_push_vstack(value stk); -value coq_interprete_ml(value tcode, value a, value e, value ea); +value coq_interprete_ml(value tcode, value a, value t, value g, value e, value ea); +value coq_interprete_byte(value* argv, int argn); value coq_interprete - (code_t coq_pc, value coq_accu, value coq_env, long coq_extra_args); - -value coq_eval_tcode (value tcode, value e); - + (code_t coq_pc, value coq_accu, value coq_atom_tbl, value coq_global_data, value coq_env, long coq_extra_args); +value coq_eval_tcode (value tcode, value t, value g, value e); diff --git a/kernel/byterun/coq_memory.c b/kernel/byterun/coq_memory.c index 45cfae509..542a05fd2 100644 --- a/kernel/byterun/coq_memory.c +++ b/kernel/byterun/coq_memory.c @@ -10,6 +10,8 @@ #include <stdio.h> #include <string.h> +#include <caml/alloc.h> +#include <caml/address_class.h> #include "coq_gc.h" #include "coq_instruct.h" #include "coq_fix_code.h" @@ -24,10 +26,6 @@ value * coq_stack_threshold; asize_t coq_max_stack_size = Coq_max_stack_size; /* global_data */ - -value coq_global_data; -value coq_atom_tbl; - int drawinstr; /* interp state */ @@ -50,7 +48,11 @@ value coq_static_alloc(value size) /* ML */ value accumulate_code(value unit) /* ML */ { - return (value) accumulate; + CAMLparam1(unit); + CAMLlocal1(res); + res = caml_alloc_small(1, Abstract_tag); + Code_val(res) = accumulate; + CAMLreturn(res); } static void (*coq_prev_scan_roots_hook) (scanning_action); @@ -58,11 +60,12 @@ static void (*coq_prev_scan_roots_hook) (scanning_action); static void coq_scan_roots(scanning_action action) { register value * i; - /* Scan the global variables */ - (*action)(coq_global_data, &coq_global_data); - (*action)(coq_atom_tbl, &coq_atom_tbl); /* Scan the stack */ for (i = coq_sp; i < coq_stack_high; i++) { +#ifdef NO_NAKED_POINTERS + /* The VM stack may contain C-allocated bytecode */ + if (Is_block(*i) && !Is_in_heap_or_young(*i)) continue; +#endif (*action) (*i, i); }; /* Hook */ @@ -79,24 +82,10 @@ void init_coq_stack() coq_max_stack_size = Coq_max_stack_size; } -void init_coq_global_data(long requested_size) -{ - int i; - coq_global_data = alloc_shr(requested_size, 0); - for (i = 0; i < requested_size; i++) - Field (coq_global_data, i) = Val_unit; -} - -void init_coq_atom_tbl(long requested_size){ - int i; - coq_atom_tbl = alloc_shr(requested_size, 0); - for (i = 0; i < requested_size; i++) Field (coq_atom_tbl, i) = Val_unit; -} - void init_coq_interpreter() { coq_sp = coq_stack_high; - coq_interprete(NULL, Val_unit, Val_unit, 0); + coq_interprete(NULL, Val_unit, Atom(0), Atom(0), Val_unit, 0); } static int coq_vm_initialized = 0; @@ -112,13 +101,15 @@ value init_coq_vm(value unit) /* ML */ #endif /* THREADED_CODE */ /* Allocate the table of global and the stack */ init_coq_stack(); - init_coq_global_data(Coq_global_data_Size); - init_coq_atom_tbl(40); /* Initialing the interpreter */ init_coq_interpreter(); - /* Some predefined pointer code */ - accumulate = (code_t) coq_stat_alloc(sizeof(opcode_t)); + /* Some predefined pointer code. + * It is typically contained in accumlator blocks whose tag is 0 and thus + * scanned by the GC, so make it look like an OCaml block. */ + value accu_block = (value) coq_stat_alloc(2 * sizeof(value)); + Hd_hp (accu_block) = Make_header (1, Abstract_tag, Caml_black); \ + accumulate = (code_t) Val_hp(accu_block); *accumulate = VALINSTR(ACCUMULATE); /* Initialize GC */ @@ -157,53 +148,6 @@ void realloc_coq_stack(asize_t required_space) #undef shift } -value get_coq_global_data(value unit) /* ML */ -{ - return coq_global_data; -} - -value get_coq_atom_tbl(value unit) /* ML */ -{ - return coq_atom_tbl; -} - -value realloc_coq_global_data(value size) /* ML */ -{ - mlsize_t requested_size, actual_size, i; - value new_global_data; - requested_size = Long_val(size); - actual_size = Wosize_val(coq_global_data); - if (requested_size >= actual_size) { - requested_size = (requested_size + 0x100) & 0xFFFFFF00; - new_global_data = alloc_shr(requested_size, 0); - for (i = 0; i < actual_size; i++) - initialize(&Field(new_global_data, i), Field(coq_global_data, i)); - for (i = actual_size; i < requested_size; i++){ - Field (new_global_data, i) = Val_long (0); - } - coq_global_data = new_global_data; - } - return Val_unit; -} - -value realloc_coq_atom_tbl(value size) /* ML */ -{ - mlsize_t requested_size, actual_size, i; - value new_atom_tbl; - requested_size = Long_val(size); - actual_size = Wosize_val(coq_atom_tbl); - if (requested_size >= actual_size) { - requested_size = (requested_size + 0x100) & 0xFFFFFF00; - new_atom_tbl = alloc_shr(requested_size, 0); - for (i = 0; i < actual_size; i++) - initialize(&Field(new_atom_tbl, i), Field(coq_atom_tbl, i)); - for (i = actual_size; i < requested_size; i++) - Field (new_atom_tbl, i) = Val_long (0); - coq_atom_tbl = new_atom_tbl; - } - return Val_unit; -} - value coq_set_drawinstr(value unit) { drawinstr = 1; diff --git a/kernel/byterun/coq_memory.h b/kernel/byterun/coq_memory.h index cec34f566..9375b15de 100644 --- a/kernel/byterun/coq_memory.h +++ b/kernel/byterun/coq_memory.h @@ -20,7 +20,6 @@ #define Coq_stack_size (4096 * sizeof(value)) #define Coq_stack_threshold (256 * sizeof(value)) -#define Coq_global_data_Size (4096 * sizeof(value)) #define Coq_max_stack_size (256 * 1024) #define TRANSP 0 @@ -34,9 +33,7 @@ extern value * coq_stack_threshold; /* global_data */ -extern value coq_global_data; extern int coq_all_transp; -extern value coq_atom_tbl; extern int drawinstr; /* interp state */ @@ -53,10 +50,6 @@ value init_coq_vm(value unit); /* ML */ value re_init_coq_vm(value unit); /* ML */ void realloc_coq_stack(asize_t required_space); -value get_coq_global_data(value unit); /* ML */ -value realloc_coq_global_data(value size); /* ML */ -value get_coq_atom_tbl(value unit); /* ML */ -value realloc_coq_atom_tbl(value size); /* ML */ value coq_set_transp_value(value transp); /* ML */ value get_coq_transp_value(value unit); /* ML */ #endif /* _COQ_MEMORY_ */ diff --git a/kernel/byterun/coq_values.c b/kernel/byterun/coq_values.c index 528babebf..e05f3fb82 100644 --- a/kernel/byterun/coq_values.c +++ b/kernel/byterun/coq_values.c @@ -9,6 +9,7 @@ /***********************************************************************/ #include <stdio.h> +#include <caml/memory.h> #include "coq_fix_code.h" #include "coq_instruct.h" #include "coq_memory.h" @@ -58,10 +59,36 @@ value coq_offset_closure(value v, value offset){ return (value)&Field(v, Int_val(offset)); } +value coq_set_bytecode_field(value v, value i, value code) { + // No write barrier because the bytecode does not live on the OCaml heap + Field(v, Long_val(i)) = (value) Code_val(code); + return Val_unit; +} + value coq_offset_tcode(value code,value offset){ - return((value)((code_t)code + Int_val(offset))); + CAMLparam1(code); + CAMLlocal1(res); + res = caml_alloc_small(1, Abstract_tag); + Code_val(res) = Code_val(code) + Int_val(offset); + CAMLreturn(res); } -value coq_int_tcode(value code, value offset) { +value coq_int_tcode(value pc, value offset) { + code_t code = Code_val(pc); return Val_int(*((code_t) code + Int_val(offset))); } + +value coq_tcode_array(value tcodes) { + CAMLparam1(tcodes); + CAMLlocal2(res, tmp); + int i; + /* Assumes that the vector of types is small. This was implicit in the + previous code which was building the type array using Alloc_small. */ + res = caml_alloc_small(Wosize_val(tcodes), Default_tag); + for (i = 0; i < Wosize_val(tcodes); i++) { + tmp = caml_alloc_small(1, Abstract_tag); + Code_val(tmp) = (code_t) Field(tcodes, i); + Store_field(res, i, tmp); + } + CAMLreturn(res); +} diff --git a/kernel/cClosure.ml b/kernel/cClosure.ml index 5f683790c..1d8861cbc 100644 --- a/kernel/cClosure.ml +++ b/kernel/cClosure.ml @@ -96,7 +96,7 @@ module type RedFlagsSig = sig val red_transparent : reds -> transparent_state val mkflags : red_kind list -> reds val red_set : reds -> red_kind -> bool - val red_projection : reds -> projection -> bool + val red_projection : reds -> Projection.t -> bool end module RedFlags = (struct @@ -265,7 +265,7 @@ type 'a infos_cache = { i_repr : 'a infos -> 'a infos_tab -> constr -> 'a; i_env : env; i_sigma : existential -> constr option; - i_rels : (Context.Rel.Declaration.t * Pre_env.lazy_val) Range.t; + i_rels : (Context.Rel.Declaration.t * lazy_val) Range.t; } and 'a infos = { @@ -314,12 +314,11 @@ let evar_value cache ev = cache.i_sigma ev let create mk_cl flgs env evars = - let open Pre_env in let cache = { i_repr = mk_cl; i_env = env; i_sigma = evars; - i_rels = (Environ.pre_env env).env_rel_context.env_rel_map; + i_rels = env.env_rel_context.env_rel_map; } in { i_flags = flgs; i_cache = cache } @@ -364,7 +363,7 @@ and fterm = | FInd of pinductive | FConstruct of pconstructor | FApp of fconstr * fconstr array - | FProj of projection * fconstr + | FProj of Projection.t * fconstr | 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 *) @@ -482,7 +481,7 @@ let rec lft_fconstr 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 = - if Int.equal k 0 then v else CArray.Fun1.map lft_fconstr k v + if Int.equal k 0 then v else Array.Fun1.map lft_fconstr k v let clos_rel e i = match expand_rel i e with @@ -547,7 +546,7 @@ let mk_clos_vect env v = match v with | [|v0; v1; v2|] -> [|mk_clos env v0; mk_clos env v1; mk_clos env v2|] | [|v0; v1; v2; v3|] -> [|mk_clos env v0; mk_clos env v1; mk_clos env v2; mk_clos env v3|] -| v -> CArray.Fun1.map mk_clos env v +| v -> Array.Fun1.map mk_clos env v (* Translate the head constructor of t from constr to fconstr. This function is parameterized by the function to apply on the direct @@ -562,7 +561,7 @@ let mk_clos_deep clos_fun env t = term = FCast (clos_fun env a, k, clos_fun env b)} | App (f,v) -> { norm = Red; - term = FApp (clos_fun env f, CArray.Fun1.map clos_fun env v) } + term = FApp (clos_fun env f, Array.Fun1.map clos_fun env v) } | Proj (p,c) -> { norm = Red; term = FProj (p, clos_fun env c) } @@ -605,21 +604,21 @@ let rec to_constr constr_fun lfts v = Array.map (fun b -> constr_fun lfts (mk_clos env b)) ve) | FFix ((op,(lna,tys,bds)),e) -> let n = Array.length bds in - let ftys = CArray.Fun1.map mk_clos e tys in - let fbds = CArray.Fun1.map mk_clos (subs_liftn n e) bds in + let ftys = Array.Fun1.map mk_clos e tys in + let fbds = Array.Fun1.map mk_clos (subs_liftn n e) bds in let lfts' = el_liftn n lfts in - mkFix (op, (lna, CArray.Fun1.map constr_fun lfts ftys, - CArray.Fun1.map constr_fun lfts' fbds)) + mkFix (op, (lna, Array.Fun1.map constr_fun lfts ftys, + Array.Fun1.map constr_fun lfts' fbds)) | FCoFix ((op,(lna,tys,bds)),e) -> let n = Array.length bds in - let ftys = CArray.Fun1.map mk_clos e tys in - let fbds = CArray.Fun1.map mk_clos (subs_liftn n e) bds in + let ftys = Array.Fun1.map mk_clos e tys in + let fbds = Array.Fun1.map mk_clos (subs_liftn n e) bds in let lfts' = el_liftn (Array.length bds) lfts in - mkCoFix (op, (lna, CArray.Fun1.map constr_fun lfts ftys, - CArray.Fun1.map constr_fun lfts' fbds)) + mkCoFix (op, (lna, Array.Fun1.map constr_fun lfts ftys, + Array.Fun1.map constr_fun lfts' fbds)) | FApp (f,ve) -> mkApp (constr_fun lfts f, - CArray.Fun1.map constr_fun lfts ve) + Array.Fun1.map constr_fun lfts ve) | FProj (p,c) -> mkProj (p,constr_fun lfts c) @@ -1024,14 +1023,14 @@ and norm_head info tab m = | FProd(na,dom,rng) -> mkProd(na, kl info tab dom, kl info tab rng) | FCoFix((n,(na,tys,bds)),e) -> - let ftys = CArray.Fun1.map mk_clos e tys in + let ftys = Array.Fun1.map mk_clos e tys in let fbds = - CArray.Fun1.map mk_clos (subs_liftn (Array.length na) e) bds in + Array.Fun1.map mk_clos (subs_liftn (Array.length na) e) bds in mkCoFix(n,(na, CArray.map (kl info tab) ftys, CArray.map (kl info tab) fbds)) | FFix((n,(na,tys,bds)),e) -> - let ftys = CArray.Fun1.map mk_clos e tys in + let ftys = Array.Fun1.map mk_clos e tys in let fbds = - CArray.Fun1.map mk_clos (subs_liftn (Array.length na) e) bds in + Array.Fun1.map mk_clos (subs_liftn (Array.length na) e) bds in mkFix(n,(na, CArray.map (kl info tab) ftys, CArray.map (kl info tab) fbds)) | FEvar((i,args),env) -> mkEvar(i, Array.map (fun a -> kl info tab (mk_clos env a)) args) @@ -1052,7 +1051,12 @@ let norm_val info tab v = let inject c = mk_clos (subs_id 0) c -let whd_stack infos tab m stk = +let whd_stack infos tab m stk = match m.norm with +| Whnf | Norm -> + (** No need to perform [kni] nor to unlock updates because + every head subterm of [m] is [Whnf] or [Norm] *) + knh infos m stk +| Red | Cstr -> let k = kni infos tab m stk in let () = if !share then ignore (fapp_stack k) in (* to unlock Zupdates! *) k diff --git a/kernel/cClosure.mli b/kernel/cClosure.mli index 3a7f77d52..63daa4a7c 100644 --- a/kernel/cClosure.mli +++ b/kernel/cClosure.mli @@ -74,7 +74,7 @@ module type RedFlagsSig = sig (** This tests if the projection is in unfolded state already or is unfodable due to delta. *) - val red_projection : reds -> projection -> bool + val red_projection : reds -> Projection.t -> bool end module RedFlags : RedFlagsSig @@ -132,7 +132,7 @@ type fterm = | FInd of inductive Univ.puniverses | FConstruct of constructor Univ.puniverses | FApp of fconstr * fconstr array - | FProj of projection * fconstr + | FProj of Projection.t * fconstr | 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 *) @@ -239,9 +239,6 @@ val lift_fconstr_vect : int -> fconstr array -> fconstr array val mk_clos : fconstr subs -> constr -> fconstr val mk_clos_vect : fconstr subs -> constr array -> fconstr array -val mk_clos_deep : - (fconstr subs -> constr -> fconstr) -> - fconstr subs -> constr -> fconstr val kni: clos_infos -> fconstr infos_tab -> fconstr -> stack -> fconstr * stack val knr: clos_infos -> fconstr infos_tab -> fconstr -> stack -> fconstr * stack diff --git a/kernel/cbytecodes.ml b/kernel/cbytecodes.ml index 5ed9b6c67..521f540d2 100644 --- a/kernel/cbytecodes.ml +++ b/kernel/cbytecodes.ml @@ -36,7 +36,6 @@ let last_variant_tag = 245 type structured_constant = | Const_sort of Sorts.t | Const_ind of inductive - | Const_proj of Constant.t | Const_b0 of tag | Const_bn of tag * structured_constant array | Const_univ_level of Univ.Level.t @@ -51,8 +50,6 @@ let rec eq_structured_constant c1 c2 = match c1, c2 with | Const_sort _, _ -> false | Const_ind i1, Const_ind i2 -> eq_ind i1 i2 | Const_ind _, _ -> false -| Const_proj p1, Const_proj p2 -> Constant.equal p1 p2 -| Const_proj _, _ -> false | Const_b0 t1, Const_b0 t2 -> Int.equal t1 t2 | Const_b0 _, _ -> false | Const_bn (t1, a1), Const_bn (t2, a2) -> @@ -66,13 +63,12 @@ let rec hash_structured_constant c = match c with | Const_sort s -> combinesmall 1 (Sorts.hash s) | Const_ind i -> combinesmall 2 (ind_hash i) - | Const_proj p -> combinesmall 3 (Constant.hash p) - | Const_b0 t -> combinesmall 4 (Int.hash t) + | Const_b0 t -> combinesmall 3 (Int.hash t) | Const_bn (t, a) -> let fold h c = combine h (hash_structured_constant c) in let h = Array.fold_left fold 0 a in - combinesmall 5 (combine (Int.hash t) h) - | Const_univ_level l -> combinesmall 6 (Univ.Level.hash l) + combinesmall 4 (combine (Int.hash t) h) + | Const_univ_level l -> combinesmall 5 (Univ.Level.hash l) let eq_annot_switch asw1 asw2 = let eq_ci ci1 ci2 = @@ -246,7 +242,6 @@ let pp_sort s = let rec pp_struct_const = function | Const_sort s -> pp_sort s | Const_ind (mind, i) -> MutInd.print mind ++ str"#" ++ int i - | Const_proj p -> Constant.print p | Const_b0 i -> int i | Const_bn (i,t) -> int i ++ surround (prvect_with_sep pr_comma pp_struct_const t) @@ -309,7 +304,7 @@ let rec pp_instr i = prlist_with_sep spc pp_lbl (Array.to_list lblb)) | Kpushfields n -> str "pushfields " ++ int n | Kfield n -> str "field " ++ int n - | Ksetfield n -> str "set field" ++ int n + | Ksetfield n -> str "setfield " ++ int n | Kstop -> str "stop" diff --git a/kernel/cbytecodes.mli b/kernel/cbytecodes.mli index 03b6bc619..238edc0af 100644 --- a/kernel/cbytecodes.mli +++ b/kernel/cbytecodes.mli @@ -30,7 +30,6 @@ val last_variant_tag : tag type structured_constant = | Const_sort of Sorts.t | Const_ind of inductive - | Const_proj of Constant.t | Const_b0 of tag | Const_bn of tag * structured_constant array | Const_univ_level of Univ.Level.t diff --git a/kernel/cbytegen.ml b/kernel/cbytegen.ml index 0766f49b3..7a27a3d20 100644 --- a/kernel/cbytegen.ml +++ b/kernel/cbytegen.ml @@ -20,7 +20,7 @@ open Cinstr open Clambda open Constr open Declarations -open Pre_env +open Environ (* Compilation of variables + computing free variables *) @@ -77,6 +77,7 @@ open Pre_env (* ai' = [A_t | accumulate | [Cfx_t | fcofixi] | arg1 | ... | argp ] *) (* If such a block is matched against, we have to force evaluation, *) (* function [fcofixi] is then applied to [ai'] [arg1] ... [argp] *) +(* (note that [ai'] is a pointer to the closure, passed as argument) *) (* Once evaluation is completed [ai'] is updated with the result: *) (* ai' <-- *) (* [A_t | accumulate | [Cfxe_t |fcofixi|result] | arg1 | ... | argp ] *) @@ -398,55 +399,55 @@ let code_makeblock ~stack_size ~arity ~tag cont = Kpush :: nest_block tag arity cont end -let compile_structured_constant reloc sc sz cont = +let compile_structured_constant cenv sc sz cont = set_max_stack_size sz; Kconst sc :: cont (* compiling application *) -let comp_args comp_expr reloc args sz cont = +let comp_args comp_expr cenv args sz cont = let nargs_m_1 = Array.length args - 1 in - let c = ref (comp_expr reloc args.(0) (sz + nargs_m_1) cont) in + let c = ref (comp_expr cenv args.(0) (sz + nargs_m_1) cont) in for i = 1 to nargs_m_1 do - c := comp_expr reloc args.(i) (sz + nargs_m_1 - i) (Kpush :: !c) + c := comp_expr cenv args.(i) (sz + nargs_m_1 - i) (Kpush :: !c) done; !c -let comp_app comp_fun comp_arg reloc f args sz cont = +let comp_app comp_fun comp_arg cenv f args sz cont = let nargs = Array.length args in - if Int.equal nargs 0 then comp_fun reloc f sz cont + if Int.equal nargs 0 then comp_fun cenv f sz cont else match is_tailcall cont with | Some k -> - comp_args comp_arg reloc args sz + comp_args comp_arg cenv args sz (Kpush :: - comp_fun reloc f (sz + nargs) + comp_fun cenv f (sz + nargs) (Kappterm(nargs, k + nargs) :: (discard_dead_code cont))) | None -> if nargs < 4 then - comp_args comp_arg reloc args sz - (Kpush :: (comp_fun reloc f (sz+nargs) (Kapply nargs :: cont))) + comp_args comp_arg cenv args sz + (Kpush :: (comp_fun cenv f (sz+nargs) (Kapply nargs :: cont))) else let lbl,cont1 = label_code cont in Kpush_retaddr lbl :: - (comp_args comp_arg reloc args (sz + 3) - (Kpush :: (comp_fun reloc f (sz+3+nargs) (Kapply nargs :: cont1)))) + (comp_args comp_arg cenv args (sz + 3) + (Kpush :: (comp_fun cenv f (sz+3+nargs) (Kapply nargs :: cont1)))) (* Compiling free variables *) -let compile_fv_elem reloc fv sz cont = +let compile_fv_elem cenv fv sz cont = match fv with - | FVrel i -> pos_rel i reloc sz :: cont - | FVnamed id -> pos_named id reloc :: cont - | FVuniv_var i -> pos_universe_var i reloc sz :: cont - | FVevar evk -> pos_evar evk reloc :: cont + | FVrel i -> pos_rel i cenv sz :: cont + | FVnamed id -> pos_named id cenv :: cont + | FVuniv_var i -> pos_universe_var i cenv sz :: cont + | FVevar evk -> pos_evar evk cenv :: cont -let rec compile_fv reloc l sz cont = +let rec compile_fv cenv l sz cont = match l with | [] -> cont - | [fvn] -> set_max_stack_size (sz + 1); compile_fv_elem reloc fvn sz cont + | [fvn] -> set_max_stack_size (sz + 1); compile_fv_elem cenv fvn sz cont | fvn :: tl -> - compile_fv_elem reloc fvn sz - (Kpush :: compile_fv reloc tl (sz + 1) cont) + compile_fv_elem cenv fvn sz + (Kpush :: compile_fv cenv tl (sz + 1) cont) (* Compiling constants *) @@ -471,61 +472,58 @@ let make_areconst n else_lbl cont = Kareconst (n, else_lbl)::cont (* sz is the size of the local stack *) -let rec compile_lam env reloc lam sz cont = +let rec compile_lam env cenv lam sz cont = set_max_stack_size sz; match lam with - | Lrel(_, i) -> pos_rel i reloc sz :: cont + | Lrel(_, i) -> pos_rel i cenv sz :: cont - | Lval v -> compile_structured_constant reloc v sz cont + | Lval v -> compile_structured_constant cenv v sz cont | Lproj (n,kn,arg) -> - compile_lam env reloc arg sz (Kproj (n,kn) :: cont) + compile_lam env cenv arg sz (Kproj (n,kn) :: cont) - | Lvar id -> pos_named id reloc :: cont + | Lvar id -> pos_named id cenv :: cont | Levar (evk, args) -> if Array.is_empty args then - compile_fv_elem reloc (FVevar evk) sz cont + compile_fv_elem cenv (FVevar evk) sz cont else - comp_app compile_fv_elem (compile_lam env) reloc (FVevar evk) args sz cont + comp_app compile_fv_elem (compile_lam env) cenv (FVevar evk) args sz cont - | Lconst (kn,u) -> compile_constant env reloc kn u [||] sz cont + | Lconst (kn,u) -> compile_constant env cenv kn u [||] sz cont | Lind (ind,u) -> if Univ.Instance.is_empty u then - compile_structured_constant reloc (Const_ind ind) sz cont - else comp_app compile_structured_constant compile_universe reloc + compile_structured_constant cenv (Const_ind ind) sz cont + else comp_app compile_structured_constant compile_universe cenv (Const_ind ind) (Univ.Instance.to_array u) sz cont | Lsort (Sorts.Prop _ as s) -> - compile_structured_constant reloc (Const_sort s) sz cont + compile_structured_constant cenv (Const_sort s) sz cont | Lsort (Sorts.Type u) -> - (* We separate global and local universes in [u]. The former will be part - of the structured constant, while the later (if any) will be applied as - arguments. *) - let open Univ in begin - let u,s = Universe.compact u in - (* We assume that [Universe.type0m] is a neutral element for [Universe.sup] *) - let compile_get_univ reloc idx sz cont = - set_max_stack_size sz; - compile_fv_elem reloc (FVuniv_var idx) sz cont - in - if List.is_empty s then - compile_structured_constant reloc (Const_sort (Sorts.Type u)) sz cont - else - comp_app compile_structured_constant compile_get_univ reloc + (* We represent universes as a global constant with local universes + "compacted", i.e. as [u arg0 ... argn] where we will substitute (after + evaluation) [Var 0,...,Var n] with values of [arg0,...,argn] *) + let u,s = Univ.compact_univ u in + let compile_get_univ cenv idx sz cont = + set_max_stack_size sz; + 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 + else + comp_app compile_structured_constant compile_get_univ cenv (Const_sort (Sorts.Type u)) (Array.of_list s) sz cont - end | Llet (id,def,body) -> - compile_lam env reloc def sz + compile_lam env cenv def sz (Kpush :: - compile_lam env (push_local sz reloc) body (sz+1) (add_pop 1 cont)) + compile_lam env (push_local sz cenv) body (sz+1) (add_pop 1 cont)) | Lprod (dom,codom) -> let cont1 = - Kpush :: compile_lam env reloc dom (sz+1) (Kmakeprod :: cont) in - compile_lam env reloc codom sz cont1 + Kpush :: compile_lam env cenv dom (sz+1) (Kmakeprod :: cont) in + compile_lam env cenv codom sz cont1 | Llam (ids,body) -> let arity = Array.length ids in @@ -536,12 +534,12 @@ let rec compile_lam env reloc lam sz cont = in fun_code := [Ksequence(add_grab arity lbl_fun cont_fun,!fun_code)]; let fv = fv r_fun in - compile_fv reloc fv.fv_rev sz (Kclosure(lbl_fun,fv.size) :: cont) + compile_fv cenv fv.fv_rev sz (Kclosure(lbl_fun,fv.size) :: cont) | Lapp (f, args) -> begin match f with - | Lconst (kn,u) -> compile_constant env reloc kn u args sz cont - | _ -> comp_app (compile_lam env) (compile_lam env) reloc f args sz cont + | Lconst (kn,u) -> compile_constant env cenv kn u args sz cont + | _ -> comp_app (compile_lam env) (compile_lam env) cenv f args sz cont end | Lfix ((rec_args, init), (decl, types, bodies)) -> @@ -573,7 +571,7 @@ let rec compile_lam env reloc lam sz cont = fun_code := [Ksequence(fcode,!fun_code)] done; let fv = !rfv in - compile_fv reloc fv.fv_rev sz + compile_fv cenv fv.fv_rev sz (Kclosurerec(fv.size,init,lbl_types,lbl_bodies) :: cont) @@ -609,7 +607,7 @@ let rec compile_lam env reloc lam sz cont = done; let fv = !rfv in set_max_stack_size (sz + fv.size + ndef + 2); - compile_fv reloc fv.fv_rev sz + compile_fv cenv fv.fv_rev sz (Kclosurecofix(fv.size, init, lbl_types, lbl_bodies) :: cont) @@ -627,7 +625,7 @@ let rec compile_lam env reloc lam sz cont = let branch1, cont = make_branch cont in (* Compilation of the return type *) let fcode = - ensure_stack_capacity (compile_lam env reloc t sz) [Kpop sz; Kstop] + ensure_stack_capacity (compile_lam env cenv t sz) [Kpop sz; Kstop] in let lbl_typ,fcode = label_code fcode in fun_code := [Ksequence(fcode,!fun_code)]; @@ -655,7 +653,7 @@ let rec compile_lam env reloc lam sz cont = (* Compilation of constant branches *) for i = nconst - 1 downto 0 do let aux = - compile_lam env reloc branches.constant_branches.(i) sz_b (branch::!c) + compile_lam env cenv branches.constant_branches.(i) sz_b (branch::!c) in let lbl_b,code_b = label_code aux in lbl_consts.(i) <- lbl_b; @@ -667,7 +665,7 @@ let rec compile_lam env reloc lam sz cont = let (ids, body) = branches.nonconstant_branches.(i) in let arity = Array.length ids in let code_b = - compile_lam env (push_param arity sz_b reloc) + compile_lam env (push_param arity sz_b cenv) body (sz_b+arity) (add_pop arity (branch::!c)) in let code_b = if tag < last_variant_tag then begin @@ -705,25 +703,25 @@ let rec compile_lam env reloc lam sz cont = | Kbranch lbl -> Kpush_retaddr lbl :: !c | _ -> !c in - compile_lam env reloc a sz code_sw + compile_lam env cenv a sz code_sw | Lmakeblock (tag,args) -> let arity = Array.length args in let cont = code_makeblock ~stack_size:(sz+arity-1) ~arity ~tag cont in - comp_args (compile_lam env) reloc args sz cont + comp_args (compile_lam env) cenv args sz cont | Lprim (kn, ar, op, args) -> - op_compilation env ar op kn reloc args sz cont + op_compilation env ar op kn cenv args sz cont | Luint v -> (match v with - | UintVal i -> compile_structured_constant reloc (Const_b0 (Uint31.to_int i)) sz cont + | UintVal i -> compile_structured_constant cenv (Const_b0 (Uint31.to_int i)) sz cont | UintDigits ds -> let nargs = Array.length ds in if Int.equal nargs 31 then let (escape,labeled_cont) = make_branch cont in let else_lbl = Label.create() in - comp_args (compile_lam env) reloc ds sz + comp_args (compile_lam env) cenv ds sz ( Kisconst else_lbl::Kareconst(30,else_lbl)::Kcompint31::escape::Klabel else_lbl::Kmakeblock(31, 1)::labeled_cont) else let code_construct cont = (* spiwack: variant of the global code_construct @@ -739,40 +737,40 @@ let rec compile_lam env reloc lam sz cont = Kclosure(lbl,0) :: cont in comp_app (fun _ _ _ cont -> code_construct cont) - (compile_lam env) reloc () ds sz cont + (compile_lam env) cenv () ds sz cont | UintDecomp t -> let escape_lbl, labeled_cont = label_code cont in - compile_lam env reloc t sz ((Kisconst escape_lbl)::Kdecompint31::labeled_cont)) + compile_lam env cenv t sz ((Kisconst escape_lbl)::Kdecompint31::labeled_cont)) (* spiwack : compilation of constants with their arguments. Makes a special treatment with 31-bit integer addition *) -and compile_get_global reloc (kn,u) sz cont = +and compile_get_global cenv (kn,u) sz cont = set_max_stack_size sz; if Univ.Instance.is_empty u then Kgetglobal kn :: cont else comp_app (fun _ _ _ cont -> Kgetglobal kn :: cont) - compile_universe reloc () (Univ.Instance.to_array u) sz cont + compile_universe cenv () (Univ.Instance.to_array u) sz cont -and compile_universe reloc uni sz cont = +and compile_universe cenv uni sz cont = set_max_stack_size sz; match Univ.Level.var_index uni with - | None -> compile_structured_constant reloc (Const_univ_level uni) sz cont - | Some idx -> pos_universe_var idx reloc sz :: cont + | None -> compile_structured_constant cenv (Const_univ_level uni) sz cont + | Some idx -> pos_universe_var idx cenv sz :: cont -and compile_constant env reloc kn u args sz cont = +and compile_constant env cenv kn u args sz cont = set_max_stack_size sz; if Univ.Instance.is_empty u then (* normal compilation *) comp_app (fun _ _ sz cont -> - compile_get_global reloc (kn,u) sz cont) - (compile_lam env) reloc () args sz cont + compile_get_global cenv (kn,u) sz cont) + (compile_lam env) cenv () args sz cont else - let compile_arg reloc constr_or_uni sz cont = + let compile_arg cenv constr_or_uni sz cont = match constr_or_uni with - | ArgLambda t -> compile_lam env reloc t sz cont - | ArgUniv uni -> compile_universe reloc uni sz cont + | ArgLambda t -> compile_lam env cenv t sz cont + | ArgUniv uni -> compile_universe cenv uni sz cont in let u = Univ.Instance.to_array u in let lu = Array.length u in @@ -781,7 +779,7 @@ and compile_constant env reloc kn u args sz cont = (fun i -> if i < lu then ArgUniv u.(i) else ArgLambda args.(i-lu)) in comp_app (fun _ _ _ cont -> Kgetglobal kn :: cont) - compile_arg reloc () all sz cont + compile_arg cenv () all sz cont (*template for n-ary operation, invariant: n>=1, the operations does the following : @@ -790,34 +788,34 @@ and compile_constant env reloc kn u args sz cont = 3/ if at least one is not, branches to the normal behavior: Kgetglobal (get_alias !global_env kn) *) and op_compilation env n op = - let code_construct reloc kn sz cont = + let code_construct cenv kn sz cont = let f_cont = let else_lbl = Label.create () in Kareconst(n, else_lbl):: Kacc 0:: Kpop 1:: op:: Kreturn 0:: Klabel else_lbl:: (* works as comp_app with nargs = n and tailcall cont [Kreturn 0]*) - compile_get_global reloc kn sz ( + compile_get_global cenv kn sz ( Kappterm(n, n):: []) (* = discard_dead_code [Kreturn 0] *) in let lbl = Label.create () in fun_code := [Ksequence (add_grab n lbl f_cont, !fun_code)]; Kclosure(lbl, 0)::cont in - fun kn reloc args sz cont -> + fun kn cenv args sz cont -> let nargs = Array.length args in if Int.equal nargs n then (*if it is a fully applied addition*) let (escape, labeled_cont) = make_branch cont in let else_lbl = Label.create () in assert (n < 4); - comp_args (compile_lam env) reloc args sz + comp_args (compile_lam env) cenv args sz (Kisconst else_lbl::(make_areconst (n-1) else_lbl (*Kaddint31::escape::Klabel else_lbl::Kpush::*) (op::escape::Klabel else_lbl::Kpush:: (* works as comp_app with nargs < 4 and non-tailcall cont*) - compile_get_global reloc kn (sz+n) (Kapply n::labeled_cont)))) + compile_get_global cenv kn (sz+n) (Kapply n::labeled_cont)))) else - comp_app (fun reloc _ sz cont -> code_construct reloc kn sz cont) - (compile_lam env) reloc () args sz cont + comp_app (fun cenv _ sz cont -> code_construct cenv kn sz cont) + (compile_lam env) cenv () args sz cont let is_univ_copy max u = @@ -832,6 +830,8 @@ let is_univ_copy max u = else false +let dump_bytecode = ref false + let dump_bytecodes init code fvs = let open Pp in (str "code =" ++ fnl () ++ @@ -846,11 +846,11 @@ let compile ~fail_on_error ?universes:(universes=0) env c = Label.reset_label_counter (); let cont = [Kstop] in try - let reloc, init_code = + let cenv, init_code = if Int.equal universes 0 then let lam = lambda_of_constr ~optimize:true env c in - let reloc = empty_comp_env () in - reloc, ensure_stack_capacity (compile_lam env reloc lam 0) cont + let cenv = empty_comp_env () in + cenv, ensure_stack_capacity (compile_lam env cenv lam 0) cont else (* We are going to generate a lambda, but merge the universe closure * with the function closure if it exists. @@ -858,7 +858,7 @@ let compile ~fail_on_error ?universes:(universes=0) env c = let lam = lambda_of_constr ~optimize:true env c in let params, body = decompose_Llam lam in let arity = Array.length params in - let reloc = empty_comp_env () in + let cenv = empty_comp_env () in let full_arity = arity + universes in let r_fun = comp_env_fun ~univs:universes arity in let lbl_fun = Label.create () in @@ -869,13 +869,13 @@ let compile ~fail_on_error ?universes:(universes=0) env c = fun_code := [Ksequence(add_grab full_arity lbl_fun cont_fun,!fun_code)]; let fv = fv r_fun in let init_code = - ensure_stack_capacity (compile_fv reloc fv.fv_rev 0) + ensure_stack_capacity (compile_fv cenv fv.fv_rev 0) (Kclosure(lbl_fun,fv.size) :: cont) in - reloc, init_code + cenv, init_code in - let fv = List.rev (!(reloc.in_env).fv_rev) in - (if !Flags.dump_bytecode then + let fv = List.rev (!(cenv.in_env).fv_rev) in + (if !dump_bytecode then Feedback.msg_debug (dump_bytecodes init_code !fun_code fv)) ; Some (init_code,!fun_code, Array.of_list fv) with TooLargeInductive msg -> @@ -922,13 +922,13 @@ let op2_compilation op = fun_code := [Ksequence (add_grab 2 lbl f_cont, !fun_code)]; Kclosure(lbl, 0)::cont in - fun normal fc _ reloc args sz cont -> + fun normal fc _ cenv args sz cont -> if not fc then raise Not_found else let nargs = Array.length args in if nargs=2 then (*if it is a fully applied addition*) let (escape, labeled_cont) = make_branch cont in let else_lbl = Label.create () in - comp_args compile_constr reloc args sz + comp_args compile_constr cenv args sz (Kisconst else_lbl::(make_areconst 1 else_lbl (*Kaddint31::escape::Klabel else_lbl::Kpush::*) (op::escape::Klabel else_lbl::Kpush:: @@ -940,5 +940,5 @@ let op2_compilation op = code_construct normal cont else comp_app (fun _ _ _ cont -> code_construct normal cont) - compile_constr reloc () args sz cont *) + compile_constr cenv () args sz cont *) diff --git a/kernel/cbytegen.mli b/kernel/cbytegen.mli index abab58b60..57d3e6fc2 100644 --- a/kernel/cbytegen.mli +++ b/kernel/cbytegen.mli @@ -12,7 +12,7 @@ open Cbytecodes open Cemitcodes open Constr open Declarations -open Pre_env +open Environ (** Should only be used for monomorphic terms *) val compile : fail_on_error:bool -> @@ -25,3 +25,6 @@ val compile_constant_body : fail_on_error:bool -> (** Shortcut of the previous function used during module strengthening *) val compile_alias : Names.Constant.t -> body_code + +(** Dump the bytecode after compilation (for debugging purposes) *) +val dump_bytecode : bool ref diff --git a/kernel/cemitcodes.ml b/kernel/cemitcodes.ml index 14f4f27c0..2426255e4 100644 --- a/kernel/cemitcodes.ml +++ b/kernel/cemitcodes.ml @@ -13,20 +13,21 @@ (* Extension: Arnaud Spiwack (support for native arithmetic), May 2005 *) open Names -open Term +open Constr open Cbytecodes open Copcodes open Mod_subst type emitcodes = String.t -external tcode_of_code : Bytes.t -> int -> Vmvalues.tcode = "coq_tcode_of_code" +external tcode_of_code : Bytes.t -> Vmvalues.tcode = "coq_tcode_of_code" (* Relocation information *) type reloc_info = | Reloc_annot of annot_switch | Reloc_const of structured_constant | Reloc_getglobal of Names.Constant.t + | Reloc_proj_name of Constant.t let eq_reloc_info r1 r2 = match r1, r2 with | Reloc_annot sw1, Reloc_annot sw2 -> eq_annot_switch sw1 sw2 @@ -35,6 +36,8 @@ let eq_reloc_info r1 r2 = match r1, r2 with | Reloc_const _, _ -> false | Reloc_getglobal c1, Reloc_getglobal c2 -> Constant.equal c1 c2 | Reloc_getglobal _, _ -> false +| Reloc_proj_name p1, Reloc_proj_name p2 -> Constant.equal p1 p2 +| Reloc_proj_name _, _ -> false let hash_reloc_info r = let open Hashset.Combine in @@ -42,6 +45,7 @@ let hash_reloc_info r = | Reloc_annot sw -> combinesmall 1 (hash_annot_switch sw) | Reloc_const c -> combinesmall 2 (hash_structured_constant c) | Reloc_getglobal c -> combinesmall 3 (Constant.hash c) + | Reloc_proj_name p -> combinesmall 4 (Constant.hash p) module RelocTable = Hashtbl.Make(struct type t = reloc_info @@ -82,7 +86,7 @@ let patch buff pl f = (** Order seems important here? *) let reloc = CArray.map (fun (r, pos) -> (f r, pos)) pl.reloc_infos in let buff = patch_int buff reloc in - tcode_of_code buff (Bytes.length buff) + tcode_of_code buff (* Buffering of bytecode *) @@ -187,6 +191,9 @@ let slot_for_getglobal env p = enter env (Reloc_getglobal p); out_int env 0 +let slot_for_proj_name env p = + enter env (Reloc_proj_name p); + out_int env 0 (* Emission of one instruction *) @@ -277,7 +284,7 @@ let emit_instr env = function if n <= 1 then out env (opSETFIELD0+n) else (out env opSETFIELD;out_int env n) | Ksequence _ -> invalid_arg "Cemitcodes.emit_instr" - | Kproj (n,p) -> out env opPROJ; out_int env n; slot_for_const env (Const_proj p) + | Kproj (n,p) -> out env opPROJ; out_int env n; slot_for_proj_name env p | Kensurestackcapacity size -> out env opENSURESTACKCAPACITY; out_int env size (* spiwack *) | Kbranch lbl -> out env opBRANCH; out_label env lbl @@ -353,7 +360,6 @@ type to_patch = emitcodes * patches * fv let rec subst_strcst s sc = match sc with | Const_sort _ | Const_b0 _ | Const_univ_level _ -> sc - | Const_proj p -> Const_proj (subst_constant s p) | Const_bn(tag,args) -> Const_bn(tag,Array.map (subst_strcst s) args) | Const_ind ind -> let kn,i = ind in Const_ind (subst_mind s kn, i) @@ -365,6 +371,7 @@ let subst_reloc s ri = Reloc_annot {a with ci = ci} | Reloc_const sc -> Reloc_const (subst_strcst s sc) | Reloc_getglobal kn -> Reloc_getglobal (subst_constant s kn) + | Reloc_proj_name p -> Reloc_proj_name (subst_constant s p) let subst_patches subst p = let infos = CArray.map (fun (r, pos) -> (subst_reloc subst r, pos)) p.reloc_infos in diff --git a/kernel/cemitcodes.mli b/kernel/cemitcodes.mli index 03920dc1a..696721c37 100644 --- a/kernel/cemitcodes.mli +++ b/kernel/cemitcodes.mli @@ -5,6 +5,7 @@ type reloc_info = | Reloc_annot of annot_switch | Reloc_const of structured_constant | Reloc_getglobal of Constant.t + | Reloc_proj_name of Constant.t type patches type emitcodes diff --git a/kernel/cinstr.mli b/kernel/cinstr.mli index 4a3c03d85..f42c46175 100644 --- a/kernel/cinstr.mli +++ b/kernel/cinstr.mli @@ -31,7 +31,7 @@ and lambda = | Lprim of pconstant * int (* arity *) * instruction * lambda array | Lcase of case_info * reloc_table * lambda * lambda * lam_branches | Lfix of (int array * int) * fix_decl - | Lcofix of int * fix_decl + | Lcofix of int * fix_decl (* must be in eta-expanded form *) | Lmakeblock of int * lambda array | Lval of structured_constant | Lsort of Sorts.t @@ -39,6 +39,10 @@ and lambda = | Lproj of int * Constant.t * lambda | Luint of uint +(* Cofixpoints have to be in eta-expanded form for their call-by-need evaluation +to be correct. Otherwise, memoization of previous evaluations will be applied +again to extra arguments (see #7333). *) + and lam_branches = { constant_branches : lambda array; nonconstant_branches : (Name.t array * lambda) array } diff --git a/kernel/clambda.ml b/kernel/clambda.ml index 7b637c20e..b722e4200 100644 --- a/kernel/clambda.ml +++ b/kernel/clambda.ml @@ -6,7 +6,7 @@ open Constr open Declarations open Cbytecodes open Cinstr -open Pre_env +open Environ open Pp let pr_con sp = str(Names.Label.to_string (Constant.label sp)) @@ -152,7 +152,7 @@ let rec map_lam_with_binders g f n lam = match lam with | Lrel _ | Lvar _ | Lconst _ | Lval _ | Lsort _ | Lind _ -> lam | Levar (evk, args) -> - let args' = Array.smartmap (f n) args in + let args' = Array.Smart.map (f n) args in if args == args' then lam else Levar (evk, args') | Lprod(dom,codom) -> let dom' = f n dom in @@ -167,19 +167,19 @@ let rec map_lam_with_binders g f n lam = if body == body' && def == def' then lam else Llet(id,def',body') | Lapp(fct,args) -> let fct' = f n fct in - let args' = Array.smartmap (f n) args in + let args' = Array.Smart.map (f n) args in if fct == fct' && args == args' then lam else mkLapp fct' args' | Lcase(ci,rtbl,t,a,branches) -> let const = branches.constant_branches in let nonconst = branches.nonconstant_branches in let t' = f n t in let a' = f n a in - let const' = Array.smartmap (f n) const in + let const' = Array.Smart.map (f n) const in let on_b b = let (ids,body) = b in let body' = f (g (Array.length ids) n) body in if body == body' then b else (ids,body') in - let nonconst' = Array.smartmap on_b nonconst in + let nonconst' = Array.Smart.map on_b nonconst in let branches' = if const == const' && nonconst == nonconst' then branches @@ -190,20 +190,20 @@ let rec map_lam_with_binders g f n lam = if t == t' && a == a' && branches == branches' then lam else Lcase(ci,rtbl,t',a',branches') | Lfix(init,(ids,ltypes,lbodies)) -> - let ltypes' = Array.smartmap (f n) ltypes in - let lbodies' = Array.smartmap (f (g (Array.length ids) n)) lbodies in + let ltypes' = Array.Smart.map (f n) ltypes in + let lbodies' = Array.Smart.map (f (g (Array.length ids) n)) lbodies in if ltypes == ltypes' && lbodies == lbodies' then lam else Lfix(init,(ids,ltypes',lbodies')) | Lcofix(init,(ids,ltypes,lbodies)) -> - let ltypes' = Array.smartmap (f n) ltypes in - let lbodies' = Array.smartmap (f (g (Array.length ids) n)) lbodies in + let ltypes' = Array.Smart.map (f n) ltypes in + let lbodies' = Array.Smart.map (f (g (Array.length ids) n)) lbodies in if ltypes == ltypes' && lbodies == lbodies' then lam else Lcofix(init,(ids,ltypes',lbodies')) | Lmakeblock(tag,args) -> - let args' = Array.smartmap (f n) args in + let args' = Array.Smart.map (f n) args in if args == args' then lam else Lmakeblock(tag,args') | Lprim(kn,ar,op,args) -> - let args' = Array.smartmap (f n) args in + let args' = Array.Smart.map (f n) args in if args == args' then lam else Lprim(kn,ar,op,args') | Lproj(i,kn,arg) -> let arg' = f n arg in @@ -216,7 +216,7 @@ and map_uint g f n u = match u with | UintVal _ -> u | UintDigits(args) -> - let args' = Array.smartmap (f n) args in + let args' = Array.Smart.map (f n) args in if args == args' then u else UintDigits(args') | UintDecomp(a) -> let a' = f n a in @@ -250,7 +250,7 @@ let rec lam_exsubst subst lam = let lam_subst_args subst args = if is_subs_id subst then args - else Array.smartmap (lam_exsubst subst) args + else Array.Smart.map (lam_exsubst subst) args (** Simplification of lambda expression *) @@ -316,7 +316,7 @@ and simplify_app substf f substa args = simplify_app substf f subst_id args | _ -> mkLapp (simplify substf f) (simplify_args substa args) -and simplify_args subst args = Array.smartmap (simplify subst) args +and simplify_args subst args = Array.Smart.map (simplify subst) args and reduce_lapp substf lids body substa largs = match lids, largs with @@ -700,6 +700,7 @@ let rec lambda_of_constr env c = Lfix(rec_init, (names, ltypes, lbodies)) | CoFix(init,(names,type_bodies,rec_bodies)) -> + let rec_bodies = Array.map2 (Reduction.eta_expand env.global_env) rec_bodies type_bodies in let ltypes = lambda_of_args env 0 type_bodies in Renv.push_rels env names; let lbodies = lambda_of_args env 0 rec_bodies in @@ -707,12 +708,10 @@ let rec lambda_of_constr env c = Lcofix(init, (names, ltypes, lbodies)) | Proj (p,c) -> - let kn = Projection.constant p in - let cb = lookup_constant kn env.global_env in - let pb = Option.get cb.const_proj in + let pb = lookup_projection p env.global_env in let n = pb.proj_arg in let lc = lambda_of_constr env c in - Lproj (n,kn,lc) + Lproj (n,Projection.constant p,lc) and lambda_of_app env f args = match Constr.kind f with @@ -807,7 +806,7 @@ and lambda_of_args env start args = (*********************************) - +let dump_lambda = ref false let optimize_lambda lam = let lam = simplify subst_id lam in @@ -819,7 +818,7 @@ let lambda_of_constr ~optimize genv c = 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 - if !Flags.dump_lambda then + if !dump_lambda then Feedback.msg_debug (pp_lam lam); lam diff --git a/kernel/clambda.mli b/kernel/clambda.mli index 89b7fd8e3..8ff10b454 100644 --- a/kernel/clambda.mli +++ b/kernel/clambda.mli @@ -1,13 +1,14 @@ open Names open Cinstr +open Environ exception TooLargeInductive of Pp.t -val lambda_of_constr : optimize:bool -> Pre_env.env -> Constr.t -> lambda +val lambda_of_constr : optimize:bool -> env -> Constr.t -> lambda val decompose_Llam : lambda -> Name.t array * lambda -val get_alias : Pre_env.env -> Constant.t -> Constant.t +val get_alias : env -> Constant.t -> Constant.t val compile_prim : int -> Cbytecodes.instruction -> Constr.pconstant -> bool -> lambda array -> lambda @@ -25,3 +26,6 @@ val dynamic_int31_compilation : bool -> lambda array -> lambda (*spiwack: compiling function to insert dynamic decompilation before matching integers (in case they are in processor representation) *) val int31_escape_before_match : bool -> lambda -> lambda + +(** Dump the VM lambda code after compilation (for debugging purposes) *) +val dump_lambda : bool ref diff --git a/kernel/constr.ml b/kernel/constr.ml index ba7fecadf..c11b9ebf4 100644 --- a/kernel/constr.ml +++ b/kernel/constr.ml @@ -100,7 +100,7 @@ type ('constr, 'types, 'sort, 'univs) kind_of_term = | Case of case_info * 'constr * 'constr * 'constr array | Fix of ('constr, 'types) pfixpoint | CoFix of ('constr, 'types) pcofixpoint - | Proj of projection * 'constr + | Proj of Projection.t * 'constr (* constr is the fixpoint of the previous type. Requires option -rectypes of the Caml compiler to be set *) type t = (t, t, Sorts.t, Instance.t) kind_of_term @@ -468,16 +468,44 @@ let iter_with_binders g f n c = match kind c with | Prod (_,t,c) -> f n t; f (g n) c | Lambda (_,t,c) -> f n t; f (g n) c | LetIn (_,b,t,c) -> f n b; f n t; f (g n) c - | App (c,l) -> f n c; CArray.Fun1.iter f n l - | Evar (_,l) -> CArray.Fun1.iter f n l - | Case (_,p,c,bl) -> f n p; f n c; CArray.Fun1.iter f n bl + | App (c,l) -> f n c; Array.Fun1.iter f n l + | Evar (_,l) -> Array.Fun1.iter f n l + | Case (_,p,c,bl) -> f n p; f n c; Array.Fun1.iter f n bl | Proj (p,c) -> f n c | Fix (_,(_,tl,bl)) -> - CArray.Fun1.iter f n tl; - CArray.Fun1.iter f (iterate g (Array.length tl) n) bl + Array.Fun1.iter f n tl; + Array.Fun1.iter f (iterate g (Array.length tl) n) bl | CoFix (_,(_,tl,bl)) -> - CArray.Fun1.iter f n tl; - CArray.Fun1.iter f (iterate g (Array.length tl) n) bl + Array.Fun1.iter f n tl; + Array.Fun1.iter f (iterate g (Array.length tl) n) bl + +(* [fold_constr_with_binders g f n acc c] folds [f n] on the immediate + subterms of [c] starting from [acc] and proceeding from left to + right according to the usual representation of the constructions as + [fold_constr] but it carries an extra data [n] (typically a lift + index) which is processed by [g] (which typically add 1 to [n]) at + each binder traversal; it is not recursive *) + +let fold_constr_with_binders g f n acc c = + match kind c with + | (Rel _ | Meta _ | Var _ | Sort _ | Const _ | Ind _ + | Construct _) -> acc + | Cast (c,_, t) -> f n (f n acc c) t + | Prod (na,t,c) -> f (g n) (f n acc t) c + | Lambda (na,t,c) -> f (g n) (f n acc t) c + | LetIn (na,b,t,c) -> f (g n) (f n (f n acc b) t) c + | App (c,l) -> Array.fold_left (f n) (f n acc c) l + | Proj (p,c) -> f n acc c + | Evar (_,l) -> Array.fold_left (f n) acc l + | Case (_,p,c,bl) -> Array.fold_left (f n) (f n (f n acc p) c) bl + | Fix (_,(lna,tl,bl)) -> + let n' = CArray.fold_left2 (fun c n t -> g c) n lna tl in + let fd = Array.map2 (fun t b -> (t,b)) tl bl in + Array.fold_left (fun acc (t,b) -> f n' (f n acc t) b) acc fd + | CoFix (_,(lna,tl,bl)) -> + let n' = CArray.fold_left2 (fun c n t -> g c) n lna tl in + let fd = Array.map2 (fun t b -> (t,b)) tl bl in + Array.fold_left (fun acc (t,b) -> f n' (f n acc t) b) acc fd (* [map f c] maps [f] on the immediate subterms of [c]; it is not recursive and the order with which subterms are processed is @@ -509,7 +537,7 @@ let map f c = match kind c with else mkLetIn (na, b', t', k') | App (b,l) -> let b' = f b in - let l' = Array.smartmap f l in + let l' = Array.Smart.map f l in if b'==b && l'==l then c else mkApp (b', l') | Proj (p,t) -> @@ -517,23 +545,23 @@ let map f c = match kind c with if t' == t then c else mkProj (p, t') | Evar (e,l) -> - let l' = Array.smartmap f l in + let l' = Array.Smart.map f l in if l'==l then c else mkEvar (e, l') | Case (ci,p,b,bl) -> let b' = f b in let p' = f p in - let bl' = Array.smartmap f bl in + let bl' = Array.Smart.map f bl in if b'==b && p'==p && bl'==bl then c else mkCase (ci, p', b', bl') | Fix (ln,(lna,tl,bl)) -> - let tl' = Array.smartmap f tl in - let bl' = Array.smartmap f bl in + let tl' = Array.Smart.map f tl in + let bl' = Array.Smart.map f bl in if tl'==tl && bl'==bl then c else mkFix (ln,(lna,tl',bl')) | CoFix(ln,(lna,tl,bl)) -> - let tl' = Array.smartmap f tl in - let bl' = Array.smartmap f bl in + let tl' = Array.Smart.map f tl in + let bl' = Array.Smart.map f bl in if tl'==tl && bl'==bl then c else mkCoFix (ln,(lna,tl',bl')) @@ -565,7 +593,7 @@ let fold_map f accu c = match kind c with else accu, mkLetIn (na, b', t', k') | App (b,l) -> let accu, b' = f accu b in - let accu, l' = Array.smartfoldmap f accu l in + let accu, l' = Array.Smart.fold_left_map f accu l in if b'==b && l'==l then accu, c else accu, mkApp (b', l') | Proj (p,t) -> @@ -573,23 +601,23 @@ let fold_map f accu c = match kind c with if t' == t then accu, c else accu, mkProj (p, t') | Evar (e,l) -> - let accu, l' = Array.smartfoldmap f accu l in + let accu, l' = Array.Smart.fold_left_map f accu l in if l'==l then accu, c else accu, mkEvar (e, l') | Case (ci,p,b,bl) -> let accu, b' = f accu b in let accu, p' = f accu p in - let accu, bl' = Array.smartfoldmap f accu bl in + let accu, bl' = Array.Smart.fold_left_map f accu bl in if b'==b && p'==p && bl'==bl then accu, c else accu, mkCase (ci, p', b', bl') | Fix (ln,(lna,tl,bl)) -> - let accu, tl' = Array.smartfoldmap f accu tl in - let accu, bl' = Array.smartfoldmap f accu bl in + let accu, tl' = Array.Smart.fold_left_map f accu tl in + let accu, bl' = Array.Smart.fold_left_map f accu bl in if tl'==tl && bl'==bl then accu, c else accu, mkFix (ln,(lna,tl',bl')) | CoFix(ln,(lna,tl,bl)) -> - let accu, tl' = Array.smartfoldmap f accu tl in - let accu, bl' = Array.smartfoldmap f accu bl in + let accu, tl' = Array.Smart.fold_left_map f accu tl in + let accu, bl' = Array.Smart.fold_left_map f accu bl in if tl'==tl && bl'==bl then accu, c else accu, mkCoFix (ln,(lna,tl',bl')) @@ -625,7 +653,7 @@ let map_with_binders g f l c0 = match kind c0 with else mkLetIn (na, b', t', c') | App (c, al) -> let c' = f l c in - let al' = CArray.Fun1.smartmap f l al in + let al' = Array.Fun1.Smart.map f l al in if c' == c && al' == al then c0 else mkApp (c', al') | Proj (p, t) -> @@ -633,28 +661,28 @@ let map_with_binders g f l c0 = match kind c0 with if t' == t then c0 else mkProj (p, t') | Evar (e, al) -> - let al' = CArray.Fun1.smartmap f l al in + let al' = Array.Fun1.Smart.map f l al in if al' == al then c0 else mkEvar (e, al') | Case (ci, p, c, bl) -> let p' = f l p in let c' = f l c in - let bl' = CArray.Fun1.smartmap f l bl in + let bl' = Array.Fun1.Smart.map f l bl in if p' == p && c' == c && bl' == bl then c0 else mkCase (ci, p', c', bl') | Fix (ln, (lna, tl, bl)) -> - let tl' = CArray.Fun1.smartmap f l tl in + let tl' = Array.Fun1.Smart.map f l tl in let l' = iterate g (Array.length tl) l in - let bl' = CArray.Fun1.smartmap f l' bl in + let bl' = Array.Fun1.Smart.map f l' bl in if tl' == tl && bl' == bl then c0 else mkFix (ln,(lna,tl',bl')) | CoFix(ln,(lna,tl,bl)) -> - let tl' = CArray.Fun1.smartmap f l tl in + let tl' = Array.Fun1.Smart.map f l tl in let l' = iterate g (Array.length tl) l in - let bl' = CArray.Fun1.smartmap f l' bl in + let bl' = Array.Fun1.Smart.map f l' bl in mkCoFix (ln,(lna,tl',bl')) -type instance_compare_fn = global_reference -> int -> +type instance_compare_fn = GlobRef.t -> int -> Univ.Instance.t -> Univ.Instance.t -> bool type constr_compare_fn = int -> constr -> constr -> bool @@ -692,10 +720,10 @@ let compare_head_gen_leq_with kind1 kind2 leq_universes leq_sorts eq leq nargs t | Evar (e1,l1), Evar (e2,l2) -> Evar.equal e1 e2 && Array.equal (eq 0) l1 l2 | Const (c1,u1), Const (c2,u2) -> (* The args length currently isn't used but may as well pass it. *) - Constant.equal c1 c2 && leq_universes (ConstRef c1) nargs u1 u2 - | Ind (c1,u1), Ind (c2,u2) -> eq_ind c1 c2 && leq_universes (IndRef c1) nargs u1 u2 + Constant.equal c1 c2 && leq_universes (GlobRef.ConstRef c1) nargs u1 u2 + | Ind (c1,u1), Ind (c2,u2) -> eq_ind c1 c2 && leq_universes (GlobRef.IndRef c1) nargs u1 u2 | Construct (c1,u1), Construct (c2,u2) -> - eq_constructor c1 c2 && leq_universes (ConstructRef c1) nargs u1 u2 + eq_constructor c1 c2 && leq_universes (GlobRef.ConstructRef c1) nargs u1 u2 | Case (_,p1,c1,bl1), Case (_,p2,c2,bl2) -> eq 0 p1 p2 && eq 0 c1 c2 && Array.equal (eq 0) bl1 bl2 | Fix ((ln1, i1),(_,tl1,bl1)), Fix ((ln2, i2),(_,tl2,bl2)) -> diff --git a/kernel/constr.mli b/kernel/constr.mli index 98c0eaa28..742a13919 100644 --- a/kernel/constr.mli +++ b/kernel/constr.mli @@ -122,7 +122,7 @@ val mkConst : Constant.t -> constr val mkConstU : pconstant -> constr (** Constructs a projection application *) -val mkProj : (projection * constr) -> constr +val mkProj : (Projection.t * constr) -> constr (** Inductive types *) @@ -220,7 +220,7 @@ type ('constr, 'types, 'sort, 'univs) kind_of_term = | Case of case_info * 'constr * 'constr * 'constr array | Fix of ('constr, 'types) pfixpoint | CoFix of ('constr, 'types) pcofixpoint - | Proj of projection * 'constr + | Proj of Projection.t * 'constr (** User view of [constr]. For [App], it is ensured there is at least one argument and the function is not itself an applicative @@ -318,7 +318,7 @@ where [info] is pretty-printing information *) val destCase : constr -> case_info * constr * constr * constr array (** Destructs a projection *) -val destProj : constr -> projection * constr +val destProj : constr -> Projection.t * constr (** Destructs the {% $ %}i{% $ %}th function of the block [Fixpoint f{_ 1} ctx{_ 1} = b{_ 1} @@ -402,6 +402,15 @@ val iter : (constr -> unit) -> constr -> unit val iter_with_binders : ('a -> 'a) -> ('a -> constr -> unit) -> 'a -> constr -> unit +(** [iter_with_binders g f n c] iters [f n] on the immediate + subterms of [c]; it carries an extra data [n] (typically a lift + index) which is processed by [g] (which typically add 1 to [n]) at + each binder traversal; it is not recursive and the order with which + subterms are processed is not specified *) + +val fold_constr_with_binders : + ('a -> 'a) -> ('a -> 'b -> constr -> 'b) -> 'a -> 'b -> constr -> 'b + type constr_compare_fn = int -> constr -> constr -> bool (** [compare_head f c1 c2] compare [c1] and [c2] using [f] to compare @@ -413,7 +422,7 @@ val compare_head : constr_compare_fn -> constr_compare_fn (** Convert a global reference applied to 2 instances. The int says how many arguments are given (as we can only use cumulativity for fully applied inductives/constructors) .*) -type instance_compare_fn = global_reference -> int -> +type instance_compare_fn = GlobRef.t -> int -> Univ.Instance.t -> Univ.Instance.t -> bool (** [compare_head_gen u s f c1 c2] compare [c1] and [c2] using [f] to diff --git a/kernel/context.ml b/kernel/context.ml index 4f3f649c1..5d4a10184 100644 --- a/kernel/context.ml +++ b/kernel/context.ml @@ -192,7 +192,7 @@ struct let equal eq l = List.equal (fun c -> Declaration.equal eq c) l (** Map all terms in a given rel-context. *) - let map f = List.smartmap (Declaration.map_constr f) + let map f = List.Smart.map (Declaration.map_constr f) (** Perform a given action on every declaration in a given rel-context. *) let iter f = List.iter (Declaration.iter_constr f) @@ -392,7 +392,7 @@ struct let equal eq l = List.equal (fun c -> Declaration.equal eq c) l (** Map all terms in a given named-context. *) - let map f = List.smartmap (Declaration.map_constr f) + let map f = List.Smart.map (Declaration.map_constr f) (** Perform a given action on every declaration in a given named-context. *) let iter f = List.iter (Declaration.iter_constr f) diff --git a/kernel/cooking.ml b/kernel/cooking.ml index 6f4541e95..5783453e6 100644 --- a/kernel/cooking.ml +++ b/kernel/cooking.ml @@ -156,7 +156,7 @@ type inline = bool type result = { cook_body : constant_def; cook_type : types; - cook_proj : projection_body option; + cook_proj : bool; cook_universes : constant_universes; cook_inline : inline; cook_context : Context.Named.t option; @@ -227,28 +227,10 @@ let cook_constant ~hcons env { from = cb; info } = hyps) hyps ~init:cb.const_hyps in let typ = abstract_constant_type (expmod cb.const_type) hyps in - let projection pb = - let c' = abstract_constant_body (expmod pb.proj_body) hyps in - let etab = abstract_constant_body (expmod (fst pb.proj_eta)) hyps in - let etat = abstract_constant_body (expmod (snd pb.proj_eta)) hyps in - let ((mind, _), _), n' = - try - let c' = share_univs cache (IndRef (pb.proj_ind,0)) Univ.Instance.empty modlist in - match kind c' with - | App (f,l) -> (destInd f, Array.length l) - | Ind ind -> ind, 0 - | _ -> assert false - with Not_found -> (((pb.proj_ind,0),Univ.Instance.empty), 0) - in - let ctx, ty' = decompose_prod_n (n' + pb.proj_npars + 1) typ in - { proj_ind = mind; proj_npars = pb.proj_npars + n'; proj_arg = pb.proj_arg; - proj_eta = etab, etat; - proj_type = ty'; proj_body = c' } - in { cook_body = body; cook_type = typ; - cook_proj = Option.map projection cb.const_proj; + cook_proj = cb.const_proj; cook_universes = univs; cook_inline = cb.const_inline_code; cook_context = Some const_hyps; diff --git a/kernel/cooking.mli b/kernel/cooking.mli index 7bd0ae566..0d907f3de 100644 --- a/kernel/cooking.mli +++ b/kernel/cooking.mli @@ -21,7 +21,7 @@ type inline = bool type result = { cook_body : constant_def; cook_type : types; - cook_proj : projection_body option; + cook_proj : bool; cook_universes : constant_universes; cook_inline : inline; cook_context : Context.Named.t option; diff --git a/kernel/csymtable.ml b/kernel/csymtable.ml index 012948954..bbe093782 100644 --- a/kernel/csymtable.ml +++ b/kernel/csymtable.ml @@ -20,13 +20,15 @@ open Vmvalues open Cemitcodes open Cbytecodes open Declarations -open Pre_env +open Environ open Cbytegen module NamedDecl = Context.Named.Declaration module RelDecl = Context.Rel.Declaration -external eval_tcode : tcode -> values array -> values = "coq_eval_tcode" +external eval_tcode : tcode -> atom array -> vm_global -> values array -> values = "coq_eval_tcode" + +type global_data = { mutable glob_len : int; mutable glob_val : values array } (*******************) (* Linkage du code *) @@ -37,21 +39,28 @@ external eval_tcode : tcode -> values array -> values = "coq_eval_tcode" (* [global_data] contient les valeurs des constantes globales (axiomes,definitions), les annotations des switch et les structured constant *) -external global_data : unit -> values array = "get_coq_global_data" +let global_data = { + glob_len = 0; + glob_val = Array.make 4096 crazy_val; +} -(* [realloc_global_data n] augmente de n la taille de [global_data] *) -external realloc_global_data : int -> unit = "realloc_coq_global_data" +let get_global_data () = Vmvalues.vm_global global_data.glob_val -let check_global_data n = - if n >= Array.length (global_data()) then realloc_global_data n +let realloc_global_data n = + let n = min (2 * n + 0x100) Sys.max_array_length in + let ans = Array.make n crazy_val in + let src = global_data.glob_val in + let () = Array.blit src 0 ans 0 (Array.length src) in + global_data.glob_val <- ans -let num_global = ref 0 +let check_global_data n = + if n >= Array.length global_data.glob_val then realloc_global_data n let set_global v = - let n = !num_global in + let n = global_data.glob_len in check_global_data n; - (global_data()).(n) <- v; - incr num_global; + global_data.glob_val.(n) <- v; + global_data.glob_len <- global_data.glob_len + 1; n (* table pour les structured_constant et les annotations des switchs *) @@ -68,11 +77,19 @@ module AnnotTable = Hashtbl.Make (struct let hash = hash_annot_switch end) +module ProjNameTable = Hashtbl.Make (struct + type t = Constant.t + let equal = Constant.equal + let hash = Constant.hash +end) + let str_cst_tbl : int SConstTable.t = SConstTable.create 31 let annot_tbl : int AnnotTable.t = AnnotTable.create 31 (* (annot_switch * int) Hashtbl.t *) +let proj_name_tbl : int ProjNameTable.t = ProjNameTable.create 31 + (*************************************************************) (*** Mise a jour des valeurs des variables et des constantes *) (*************************************************************) @@ -106,6 +123,13 @@ let slot_for_annot key = AnnotTable.add annot_tbl key n; n +let slot_for_proj_name key = + try ProjNameTable.find proj_name_tbl key + with Not_found -> + let n = set_global (val_of_proj_name key) in + ProjNameTable.add proj_name_tbl key n; + n + let rec slot_for_getglobal env kn = let (cb,(_,rk)) = lookup_constant_key kn env in try key rk @@ -133,23 +157,23 @@ and slot_for_fv env fv = | None -> v_of_id id, Id.Set.empty | Some c -> val_of_constr (env_of_id id env) c, - Environ.global_vars_set (Environ.env_of_pre_env env) c in + Environ.global_vars_set env c in build_lazy_val cache (v, d); v in let val_of_rel i = val_of_rel (nb_rel env - i) in let idfun _ x = x in match fv with | FVnamed id -> - let nv = Pre_env.lookup_named_val id env in + let nv = lookup_named_val id env in begin match force_lazy_val nv with | None -> - env |> Pre_env.lookup_named id |> NamedDecl.get_value |> fill_fv_cache nv id val_of_named idfun + env |> lookup_named id |> NamedDecl.get_value |> fill_fv_cache nv id val_of_named idfun | Some (v, _) -> v end | FVrel i -> - let rv = Pre_env.lookup_rel_val i env in + let rv = lookup_rel_val i env in begin match force_lazy_val rv with | None -> - env |> Pre_env.lookup_rel i |> RelDecl.get_value |> fill_fv_cache rv i val_of_rel env_of_rel + env |> lookup_rel i |> RelDecl.get_value |> fill_fv_cache rv i val_of_rel env_of_rel | Some (v, _) -> v end | FVevar evk -> val_of_evar evk @@ -161,10 +185,11 @@ and eval_to_patch env (buff,pl,fv) = | Reloc_annot a -> slot_for_annot a | Reloc_const sc -> slot_for_str_cst sc | Reloc_getglobal kn -> slot_for_getglobal env kn + | Reloc_proj_name p -> slot_for_proj_name p in let tc = patch buff pl slots in let vm_env = Array.map (slot_for_fv env) fv in - eval_tcode tc vm_env + eval_tcode tc (get_atom_rel ()) (vm_global global_data.glob_val) vm_env and val_of_constr env c = match compile ~fail_on_error:true env c with diff --git a/kernel/csymtable.mli b/kernel/csymtable.mli index 19b2b8b50..72c96b0b9 100644 --- a/kernel/csymtable.mli +++ b/kernel/csymtable.mli @@ -12,9 +12,11 @@ open Names open Constr -open Pre_env +open Environ val val_of_constr : env -> constr -> Vmvalues.values val set_opaque_const : Constant.t -> unit val set_transparent_const : Constant.t -> unit + +val get_global_data : unit -> Vmvalues.vm_global diff --git a/kernel/declarations.ml b/kernel/declarations.ml index b7427d20a..7bd70c050 100644 --- a/kernel/declarations.ml +++ b/kernel/declarations.ml @@ -52,7 +52,7 @@ type inline = int option type projection_body = { proj_ind : MutInd.t; proj_npars : int; - proj_arg : int; + proj_arg : int; (** Projection index, starting from 0 *) proj_type : types; (* Type under params *) proj_eta : constr * types; (* Eta-expanded term and type *) proj_body : constr; (* For compatibility with VMs only, the match version *) @@ -87,7 +87,7 @@ type constant_body = { const_type : types; const_body_code : Cemitcodes.to_patch_substituted option; const_universes : constant_universes; - const_proj : projection_body option; + const_proj : bool; const_inline_code : bool; const_typing_flags : typing_flags; (** The typing options which were used for diff --git a/kernel/declareops.ml b/kernel/declareops.ml index 3652a1ce4..75c0e5b4c 100644 --- a/kernel/declareops.ml +++ b/kernel/declareops.ml @@ -42,7 +42,7 @@ let map_decl_arity f g = function let hcons_template_arity ar = { template_param_levels = ar.template_param_levels; - (* List.smartmap (Option.smartmap Univ.hcons_univ_level) ar.template_param_levels; *) + (* List.Smart.map (Option.Smart.map Univ.hcons_univ_level) ar.template_param_levels; *) template_level = Univ.hcons_univ ar.template_level } (** {6 Constants } *) @@ -70,7 +70,7 @@ let is_opaque cb = match cb.const_body with let subst_rel_declaration sub = RelDecl.map_constr (subst_mps sub) -let subst_rel_context sub = List.smartmap (subst_rel_declaration sub) +let subst_rel_context sub = List.Smart.map (subst_rel_declaration sub) let subst_const_type sub arity = if is_empty_subst sub then arity @@ -94,14 +94,13 @@ let subst_const_body sub cb = else let body' = subst_const_def sub cb.const_body in let type' = subst_const_type sub cb.const_type in - let proj' = Option.smartmap (subst_const_proj sub) cb.const_proj in if body' == cb.const_body && type' == cb.const_type - && proj' == cb.const_proj then cb + then cb else { const_hyps = []; const_body = body'; const_type = type'; - const_proj = proj'; + const_proj = cb.const_proj; const_body_code = Option.map (Cemitcodes.subst_to_patch_subst sub) cb.const_body_code; const_universes = cb.const_universes; @@ -117,7 +116,7 @@ let subst_const_body sub cb = let hcons_rel_decl = RelDecl.map_name Names.Name.hcons %> RelDecl.map_value Constr.hcons %> RelDecl.map_type Constr.hcons -let hcons_rel_context l = List.smartmap hcons_rel_decl l +let hcons_rel_context l = List.Smart.map hcons_rel_decl l let hcons_const_def = function | Undef inl -> Undef inl @@ -178,7 +177,7 @@ let recarg_length p j = let (_,cstrs) = Rtree.dest_node p in Array.length (snd (Rtree.dest_node cstrs.(j-1))) -let subst_wf_paths sub p = Rtree.smartmap (subst_recarg sub) p +let subst_wf_paths sub p = Rtree.Smart.map (subst_recarg sub) p (** {7 Substitution of inductive declarations } *) @@ -198,10 +197,10 @@ let subst_mind_packet sub mbp = mind_consnrealdecls = mbp.mind_consnrealdecls; mind_consnrealargs = mbp.mind_consnrealargs; mind_typename = mbp.mind_typename; - mind_nf_lc = Array.smartmap (subst_mps sub) mbp.mind_nf_lc; + mind_nf_lc = Array.Smart.map (subst_mps sub) mbp.mind_nf_lc; mind_arity_ctxt = subst_rel_context sub mbp.mind_arity_ctxt; mind_arity = subst_ind_arity sub mbp.mind_arity; - mind_user_lc = Array.smartmap (subst_mps sub) mbp.mind_user_lc; + mind_user_lc = Array.Smart.map (subst_mps sub) mbp.mind_user_lc; mind_nrealargs = mbp.mind_nrealargs; mind_nrealdecls = mbp.mind_nrealdecls; mind_kelim = mbp.mind_kelim; @@ -211,13 +210,13 @@ let subst_mind_packet sub mbp = mind_reloc_tbl = mbp.mind_reloc_tbl } let subst_mind_record sub (id, ps, pb as r) = - let ps' = Array.smartmap (subst_constant sub) ps in - let pb' = Array.smartmap (subst_const_proj sub) pb in + let ps' = Array.Smart.map (subst_constant sub) ps in + let pb' = Array.Smart.map (subst_const_proj sub) pb in if ps' == ps && pb' == pb then r else (id, ps', pb') let subst_mind_body sub mib = - { mind_record = Option.smartmap (Option.smartmap (subst_mind_record sub)) mib.mind_record ; + { mind_record = Option.Smart.map (Option.Smart.map (subst_mind_record sub)) mib.mind_record ; mind_finite = mib.mind_finite ; mind_ntypes = mib.mind_ntypes ; mind_hyps = (match mib.mind_hyps with [] -> [] | _ -> assert false); @@ -225,7 +224,7 @@ let subst_mind_body sub mib = mind_nparams_rec = mib.mind_nparams_rec; mind_params_ctxt = Context.Rel.map (subst_mps sub) mib.mind_params_ctxt; - mind_packets = Array.smartmap (subst_mind_packet sub) mib.mind_packets ; + mind_packets = Array.Smart.map (subst_mind_packet sub) mib.mind_packets ; mind_universes = mib.mind_universes; mind_private = mib.mind_private; mind_typing_flags = mib.mind_typing_flags; @@ -263,15 +262,15 @@ let hcons_ind_arity = (** Substitution of inductive declarations *) let hcons_mind_packet oib = - let user = Array.smartmap Constr.hcons oib.mind_user_lc in - let nf = Array.smartmap Constr.hcons oib.mind_nf_lc in + let user = Array.Smart.map Constr.hcons oib.mind_user_lc in + let nf = Array.Smart.map Constr.hcons oib.mind_nf_lc in (* Special optim : merge [mind_user_lc] and [mind_nf_lc] if possible *) let nf = if Array.equal (==) user nf then user else nf in { oib with mind_typename = Names.Id.hcons oib.mind_typename; mind_arity_ctxt = hcons_rel_context oib.mind_arity_ctxt; mind_arity = hcons_ind_arity oib.mind_arity; - mind_consnames = Array.smartmap Names.Id.hcons oib.mind_consnames; + mind_consnames = Array.Smart.map Names.Id.hcons oib.mind_consnames; mind_user_lc = user; mind_nf_lc = nf } @@ -283,7 +282,7 @@ let hcons_mind_universes miu = let hcons_mind mib = { mib with - mind_packets = Array.smartmap hcons_mind_packet mib.mind_packets; + mind_packets = Array.Smart.map hcons_mind_packet mib.mind_packets; mind_params_ctxt = hcons_rel_context mib.mind_params_ctxt; mind_universes = hcons_mind_universes mib.mind_universes } @@ -331,7 +330,7 @@ and hcons_structure_body sb = let sfb' = hcons_structure_field_body sfb in if l == l' && sfb == sfb' then fb else (l', sfb') in - List.smartmap map sb + List.Smart.map map sb and hcons_module_signature ms = hcons_functorize hcons_module_type hcons_structure_body hcons_module_signature ms diff --git a/kernel/environ.ml b/kernel/environ.ml index 9d4063e43..fb89576dd 100644 --- a/kernel/environ.ml +++ b/kernel/environ.ml @@ -28,26 +28,206 @@ open Names open Constr open Vars open Declarations -open Pre_env open Context.Rel.Declaration +module NamedDecl = Context.Named.Declaration + (* The type of environments. *) -type named_context_val = Pre_env.named_context_val +(* The key attached to each constant is used by the VM to retrieve previous *) +(* evaluations of the constant. It is essentially an index in the symbols table *) +(* used by the VM. *) +type key = int CEphemeron.key option ref + +(** Linking information for the native compiler. *) + +type link_info = + | Linked of string + | LinkedInteractive of string + | NotLinked + +type constant_key = constant_body * (link_info ref * key) + +type mind_key = mutual_inductive_body * link_info ref + +type globals = { + env_constants : constant_key Cmap_env.t; + env_projections : projection_body Cmap_env.t; + env_inductives : mind_key Mindmap_env.t; + env_modules : module_body MPmap.t; + env_modtypes : module_type_body MPmap.t} + +type stratification = { + env_universes : UGraph.t; + env_engagement : engagement +} + +type val_kind = + | VKvalue of (Vmvalues.values * Id.Set.t) CEphemeron.key + | VKnone + +type lazy_val = val_kind ref + +let force_lazy_val vk = match !vk with +| VKnone -> None +| VKvalue v -> try Some (CEphemeron.get v) with CEphemeron.InvalidKey -> None + +let dummy_lazy_val () = ref VKnone +let build_lazy_val vk key = vk := VKvalue (CEphemeron.create key) + +type named_context_val = { + env_named_ctx : Context.Named.t; + env_named_map : (Context.Named.Declaration.t * lazy_val) Id.Map.t; +} + +type rel_context_val = { + env_rel_ctx : Context.Rel.t; + env_rel_map : (Context.Rel.Declaration.t * lazy_val) Range.t; +} + +type env = { + env_globals : globals; (* globals = constants + inductive types + modules + module-types *) + env_named_context : named_context_val; (* section variables *) + env_rel_context : rel_context_val; + env_nb_rel : int; + env_stratification : stratification; + env_typing_flags : typing_flags; + retroknowledge : Retroknowledge.retroknowledge; + indirect_pterms : Opaqueproof.opaquetab; +} + +let empty_named_context_val = { + env_named_ctx = []; + env_named_map = Id.Map.empty; +} + +let empty_rel_context_val = { + env_rel_ctx = []; + env_rel_map = Range.empty; +} + +let empty_env = { + env_globals = { + env_constants = Cmap_env.empty; + env_projections = Cmap_env.empty; + env_inductives = Mindmap_env.empty; + env_modules = MPmap.empty; + env_modtypes = MPmap.empty}; + env_named_context = empty_named_context_val; + env_rel_context = empty_rel_context_val; + env_nb_rel = 0; + env_stratification = { + env_universes = UGraph.initial_universes; + env_engagement = PredicativeSet }; + env_typing_flags = Declareops.safe_flags Conv_oracle.empty; + retroknowledge = Retroknowledge.initial_retroknowledge; + indirect_pterms = Opaqueproof.empty_opaquetab } + + +(* Rel context *) + +let push_rel_context_val d ctx = { + env_rel_ctx = Context.Rel.add d ctx.env_rel_ctx; + env_rel_map = Range.cons (d, ref VKnone) ctx.env_rel_map; +} + +let match_rel_context_val ctx = match ctx.env_rel_ctx with +| [] -> None +| decl :: rem -> + let (_, lval) = Range.hd ctx.env_rel_map in + let ctx = { env_rel_ctx = rem; env_rel_map = Range.tl ctx.env_rel_map } in + Some (decl, lval, ctx) + +let push_rel d env = + { env with + env_rel_context = push_rel_context_val d env.env_rel_context; + env_nb_rel = env.env_nb_rel + 1 } + +let lookup_rel n env = + try fst (Range.get env.env_rel_context.env_rel_map (n - 1)) + with Invalid_argument _ -> raise Not_found + +let lookup_rel_val n env = + try snd (Range.get env.env_rel_context.env_rel_map (n - 1)) + with Invalid_argument _ -> raise Not_found + +let rel_skipn n ctx = { + env_rel_ctx = Util.List.skipn n ctx.env_rel_ctx; + env_rel_map = Range.skipn n ctx.env_rel_map; +} + +let env_of_rel n env = + { env with + env_rel_context = rel_skipn n env.env_rel_context; + env_nb_rel = env.env_nb_rel - n + } + +(* Named context *) + +let push_named_context_val_val d rval ctxt = +(* assert (not (Id.Map.mem (NamedDecl.get_id d) ctxt.env_named_map)); *) + { + env_named_ctx = Context.Named.add d ctxt.env_named_ctx; + env_named_map = Id.Map.add (NamedDecl.get_id d) (d, rval) ctxt.env_named_map; + } + +let push_named_context_val d ctxt = + push_named_context_val_val d (ref VKnone) ctxt + +let match_named_context_val c = match c.env_named_ctx with +| [] -> None +| decl :: ctx -> + let (_, v) = Id.Map.find (NamedDecl.get_id decl) c.env_named_map in + let map = Id.Map.remove (NamedDecl.get_id decl) c.env_named_map in + let cval = { env_named_ctx = ctx; env_named_map = map } in + Some (decl, v, cval) + +let map_named_val f ctxt = + let open Context.Named.Declaration in + let fold accu d = + let d' = map_constr f d in + let accu = + if d == d' then accu + else Id.Map.modify (get_id d) (fun _ (_, v) -> (d', v)) accu + in + (accu, d') + in + let map, ctx = List.fold_left_map fold ctxt.env_named_map ctxt.env_named_ctx in + if map == ctxt.env_named_map then ctxt + else { env_named_ctx = ctx; env_named_map = map } + +let push_named d env = + {env with env_named_context = push_named_context_val d env.env_named_context} + +let lookup_named id env = + fst (Id.Map.find id env.env_named_context.env_named_map) + +let lookup_named_val id env = + snd(Id.Map.find id env.env_named_context.env_named_map) + +let lookup_named_ctxt id ctxt = + fst (Id.Map.find id ctxt.env_named_map) + +(* Global constants *) -type env = Pre_env.env +let lookup_constant_key kn env = + Cmap_env.find kn env.env_globals.env_constants + +let lookup_constant kn env = + fst (Cmap_env.find kn env.env_globals.env_constants) + +(* Mutual Inductives *) +let lookup_mind kn env = + fst (Mindmap_env.find kn env.env_globals.env_inductives) + +let lookup_mind_key kn env = + Mindmap_env.find kn env.env_globals.env_inductives -let pre_env env = env -let env_of_pre_env env = env let oracle env = env.env_typing_flags.conv_oracle let set_oracle env o = let env_typing_flags = { env.env_typing_flags with conv_oracle = o } in { env with env_typing_flags } -let empty_named_context_val = empty_named_context_val - -let empty_env = empty_env - let engagement env = env.env_stratification.env_engagement let typing_flags env = env.env_typing_flags @@ -72,15 +252,11 @@ let empty_context env = | _ -> false (* Rel context *) -let lookup_rel = lookup_rel - let evaluable_rel n env = is_local_def (lookup_rel n env) let nb_rel env = env.env_nb_rel -let push_rel = push_rel - let push_rel_context ctxt x = Context.Rel.fold_outside push_rel ctxt ~init:x let push_rec_types (lna,typarray,_) env = @@ -105,24 +281,14 @@ let named_context_of_val c = c.env_named_ctx let ids_of_named_context_val c = Id.Map.domain c.env_named_map -(* [map_named_val f ctxt] apply [f] to the body and the type of - each declarations. - *** /!\ *** [f t] should be convertible with t *) -let map_named_val = map_named_val - let empty_named_context = Context.Named.empty -let push_named = push_named let push_named_context = List.fold_right push_named -let push_named_context_val = push_named_context_val let val_of_named_context ctxt = List.fold_right push_named_context_val ctxt empty_named_context_val -let lookup_named = lookup_named -let lookup_named_val id ctxt = fst (Id.Map.find id ctxt.env_named_map) - let eq_named_context_val c1 c2 = c1 == c2 || Context.Named.equal Constr.equal (named_context_of_val c1) (named_context_of_val c2) @@ -181,7 +347,10 @@ let map_universes f env = let s = env.env_stratification in { env with env_stratification = { s with env_universes = f s.env_universes } } - + +let set_universes env u = + { env with env_stratification = { env.env_stratification with env_universes = u } } + let add_constraints c env = if Univ.Constraint.is_empty c then env else map_universes (UGraph.merge_constraints c) env @@ -221,8 +390,6 @@ let set_typing_flags c env = (* Unsafe *) (* Global constants *) -let lookup_constant = lookup_constant - let no_link_info = NotLinked let add_constant_key kn cb linkinfo env = @@ -320,18 +487,12 @@ let type_in_type_constant cst env = not (lookup_constant cst env).const_typing_flags.check_universes let lookup_projection cst env = - match (lookup_constant (Projection.constant cst) env).const_proj with - | Some pb -> pb - | None -> anomaly (Pp.str "lookup_projection: constant is not a projection.") + Cmap_env.find (Projection.constant cst) env.env_globals.env_projections let is_projection cst env = - match (lookup_constant cst env).const_proj with - | Some _ -> true - | None -> false + (lookup_constant cst env).const_proj (* Mutual Inductives *) -let lookup_mind = lookup_mind - let polymorphic_ind (mind,i) env = Declareops.inductive_is_polymorphic (lookup_mind mind env) @@ -351,11 +512,18 @@ let template_polymorphic_pind (ind,u) env = if not (Univ.Instance.is_empty u) then false else template_polymorphic_ind ind env -let add_mind_key kn mind_key env = +let add_mind_key kn (mind, _ as mind_key) env = let new_inds = Mindmap_env.add kn mind_key env.env_globals.env_inductives in + let new_projections = match mind.mind_record with + | None | Some None -> env.env_globals.env_projections + | Some (Some (id, kns, pbs)) -> + Array.fold_left2 (fun projs kn pb -> + Cmap_env.add kn pb projs) + env.env_globals.env_projections kns pbs + in let new_globals = { env.env_globals with - env_inductives = new_inds } in + env_inductives = new_inds; env_projections = new_projections; } in { env with env_globals = new_globals } let add_mind kn mib env = @@ -468,10 +636,6 @@ type 'types punsafe_type_judgment = { type unsafe_type_judgment = types punsafe_type_judgment -(*s Compilation of global declaration *) - -let compile_constant_body = Cbytegen.compile_constant_body ~fail_on_error:false - exception Hyp_not_found let apply_to_hyp ctxt id f = @@ -530,121 +694,3 @@ let register env field entry = in register_one (register_one env (KInt31 (grp,Int31Constructor)) i31c) field entry | field -> register_one env field entry - -(* the Environ.register function syncrhonizes the proactive and reactive - retroknowledge. *) -let dispatch = - - (* subfunction used for static decompilation of int31 (after a vm_compute, - see pretyping/vnorm.ml for more information) *) - let constr_of_int31 = - let nth_digit_plus_one i n = (* calculates the nth (starting with 0) - digit of i and adds 1 to it - (nth_digit_plus_one 1 3 = 2) *) - if Int.equal (i land (1 lsl n)) 0 then - 1 - else - 2 - in - fun ind -> fun digit_ind -> fun tag -> - let array_of_int i = - Array.init 31 (fun n -> mkConstruct - (digit_ind, nth_digit_plus_one i (30-n))) - in - (* We check that no bit above 31 is set to one. This assertion used to - fail in the VM, and led to conversion tests failing at Qed. *) - assert (Int.equal (tag lsr 31) 0); - mkApp(mkConstruct(ind, 1), array_of_int tag) - in - - (* subfunction which dispatches the compiling information of an - int31 operation which has a specific vm instruction (associates - it to the name of the coq definition in the reactive retroknowledge) *) - let int31_op n op prim kn = - { empty_reactive_info with - vm_compiling = Some (Clambda.compile_prim n op kn); - native_compiling = Some (Nativelambda.compile_prim prim (Univ.out_punivs kn)); - } - in - -fun rk value field -> - (* subfunction which shortens the (very common) dispatch of operations *) - let int31_op_from_const n op prim = - match kind value with - | Const kn -> int31_op n op prim kn - | _ -> anomaly ~label:"Environ.register" (Pp.str "should be a constant.") - in - let int31_binop_from_const op prim = int31_op_from_const 2 op prim in - let int31_unop_from_const op prim = int31_op_from_const 1 op prim in - match field with - | KInt31 (grp, Int31Type) -> - let int31bit = - (* invariant : the type of bits is registered, otherwise the function - would raise Not_found. The invariant is enforced in safe_typing.ml *) - match field with - | KInt31 (grp, Int31Type) -> Retroknowledge.find rk (KInt31 (grp,Int31Bits)) - | _ -> anomaly ~label:"Environ.register" - (Pp.str "add_int31_decompilation_from_type called with an abnormal field.") - in - let i31bit_type = - match kind int31bit with - | Ind (i31bit_type,_) -> i31bit_type - | _ -> anomaly ~label:"Environ.register" - (Pp.str "Int31Bits should be an inductive type.") - in - let int31_decompilation = - match kind value with - | Ind (i31t,_) -> - constr_of_int31 i31t i31bit_type - | _ -> anomaly ~label:"Environ.register" - (Pp.str "should be an inductive type.") - in - { empty_reactive_info with - vm_decompile_const = Some int31_decompilation; - vm_before_match = Some Clambda.int31_escape_before_match; - native_before_match = Some (Nativelambda.before_match_int31 i31bit_type); - } - | KInt31 (_, Int31Constructor) -> - { empty_reactive_info with - vm_constant_static = Some Clambda.compile_structured_int31; - vm_constant_dynamic = Some Clambda.dynamic_int31_compilation; - native_constant_static = Some Nativelambda.compile_static_int31; - native_constant_dynamic = Some Nativelambda.compile_dynamic_int31; - } - | KInt31 (_, Int31Plus) -> int31_binop_from_const Cbytecodes.Kaddint31 - CPrimitives.Int31add - | KInt31 (_, Int31PlusC) -> int31_binop_from_const Cbytecodes.Kaddcint31 - CPrimitives.Int31addc - | KInt31 (_, Int31PlusCarryC) -> int31_binop_from_const Cbytecodes.Kaddcarrycint31 - CPrimitives.Int31addcarryc - | KInt31 (_, Int31Minus) -> int31_binop_from_const Cbytecodes.Ksubint31 - CPrimitives.Int31sub - | KInt31 (_, Int31MinusC) -> int31_binop_from_const Cbytecodes.Ksubcint31 - CPrimitives.Int31subc - | KInt31 (_, Int31MinusCarryC) -> int31_binop_from_const - Cbytecodes.Ksubcarrycint31 CPrimitives.Int31subcarryc - | KInt31 (_, Int31Times) -> int31_binop_from_const Cbytecodes.Kmulint31 - CPrimitives.Int31mul - | KInt31 (_, Int31TimesC) -> int31_binop_from_const Cbytecodes.Kmulcint31 - CPrimitives.Int31mulc - | KInt31 (_, Int31Div21) -> int31_op_from_const 3 Cbytecodes.Kdiv21int31 - CPrimitives.Int31div21 - | KInt31 (_, Int31Diveucl) -> int31_binop_from_const Cbytecodes.Kdivint31 - CPrimitives.Int31diveucl - | KInt31 (_, Int31AddMulDiv) -> int31_op_from_const 3 Cbytecodes.Kaddmuldivint31 - CPrimitives.Int31addmuldiv - | KInt31 (_, Int31Compare) -> int31_binop_from_const Cbytecodes.Kcompareint31 - CPrimitives.Int31compare - | KInt31 (_, Int31Head0) -> int31_unop_from_const Cbytecodes.Khead0int31 - CPrimitives.Int31head0 - | KInt31 (_, Int31Tail0) -> int31_unop_from_const Cbytecodes.Ktail0int31 - CPrimitives.Int31tail0 - | KInt31 (_, Int31Lor) -> int31_binop_from_const Cbytecodes.Klorint31 - CPrimitives.Int31lor - | KInt31 (_, Int31Land) -> int31_binop_from_const Cbytecodes.Klandint31 - CPrimitives.Int31land - | KInt31 (_, Int31Lxor) -> int31_binop_from_const Cbytecodes.Klxorint31 - CPrimitives.Int31lxor - | _ -> empty_reactive_info - -let _ = Hook.set Retroknowledge.dispatch_hook dispatch diff --git a/kernel/environ.mli b/kernel/environ.mli index 4e6ac1e72..8928b32f1 100644 --- a/kernel/environ.mli +++ b/kernel/environ.mli @@ -28,16 +28,61 @@ open Declarations - a set of universe constraints - a flag telling if Set is, can be, or cannot be set impredicative *) +type lazy_val + +val build_lazy_val : lazy_val -> (Vmvalues.values * Id.Set.t) -> unit +val force_lazy_val : lazy_val -> (Vmvalues.values * Id.Set.t) option +val dummy_lazy_val : unit -> lazy_val + +(** Linking information for the native compiler *) +type link_info = + | Linked of string + | LinkedInteractive of string + | NotLinked + +type key = int CEphemeron.key option ref + +type constant_key = constant_body * (link_info ref * key) + +type mind_key = mutual_inductive_body * link_info ref + +type globals = { + env_constants : constant_key Cmap_env.t; + env_projections : projection_body Cmap_env.t; + env_inductives : mind_key Mindmap_env.t; + env_modules : module_body MPmap.t; + env_modtypes : module_type_body MPmap.t +} + +type stratification = { + env_universes : UGraph.t; + env_engagement : engagement +} + +type named_context_val = private { + env_named_ctx : Context.Named.t; + env_named_map : (Context.Named.Declaration.t * lazy_val) Id.Map.t; +} + +type rel_context_val = private { + env_rel_ctx : Context.Rel.t; + env_rel_map : (Context.Rel.Declaration.t * lazy_val) Range.t; +} + +type env = private { + env_globals : globals; (* globals = constants + inductive types + modules + module-types *) + env_named_context : named_context_val; (* section variables *) + env_rel_context : rel_context_val; + env_nb_rel : int; + env_stratification : stratification; + env_typing_flags : typing_flags; + retroknowledge : Retroknowledge.retroknowledge; + indirect_pterms : Opaqueproof.opaquetab; +} - - -type env -val pre_env : env -> Pre_env.env -val env_of_pre_env : Pre_env.env -> env val oracle : env -> Conv_oracle.oracle val set_oracle : env -> Conv_oracle.oracle -> env -type named_context_val val eq_named_context_val : named_context_val -> named_context_val -> bool val empty_env : env @@ -70,7 +115,9 @@ val push_rec_types : rec_declaration -> env -> env (** Looks up in the context of local vars referred by indice ([rel_context]) raises [Not_found] if the index points out of the context *) val lookup_rel : int -> env -> Context.Rel.Declaration.t +val lookup_rel_val : int -> env -> lazy_val val evaluable_rel : int -> env -> bool +val env_of_rel : int -> env -> env (** {6 Recurrence on [rel_context] } *) @@ -102,7 +149,8 @@ val push_named_context_val : raises [Not_found] if the Id.t is not found *) val lookup_named : variable -> env -> Context.Named.Declaration.t -val lookup_named_val : variable -> named_context_val -> Context.Named.Declaration.t +val lookup_named_val : variable -> env -> lazy_val +val lookup_named_ctxt : variable -> named_context_val -> Context.Named.Declaration.t val evaluable_named : variable -> env -> bool val named_type : variable -> env -> types val named_body : variable -> env -> constr option @@ -112,6 +160,8 @@ val named_body : variable -> env -> constr option val fold_named_context : (env -> Context.Named.Declaration.t -> 'a -> 'a) -> env -> init:'a -> 'a +val set_universes : env -> UGraph.t -> env + (** Recurrence on [named_context] starting from younger decl *) val fold_named_context_reverse : ('a -> Context.Named.Declaration.t -> 'a) -> init:'a -> env -> 'a @@ -129,8 +179,9 @@ val pop_rel_context : int -> env -> env {6 Add entries to global environment } *) val add_constant : Constant.t -> constant_body -> env -> env -val add_constant_key : Constant.t -> constant_body -> Pre_env.link_info -> +val add_constant_key : Constant.t -> constant_body -> link_info -> env -> env +val lookup_constant_key : Constant.t -> env -> constant_key (** Looks up in the context of global constant names raises [Not_found] if the required path is not found *) @@ -168,11 +219,12 @@ val constant_opt_value_in : env -> Constant.t puniverses -> constr option (** {6 Primitive projections} *) -val lookup_projection : Names.projection -> env -> projection_body +val lookup_projection : Names.Projection.t -> env -> projection_body val is_projection : Constant.t -> env -> bool (** {5 Inductive types } *) -val add_mind_key : MutInd.t -> Pre_env.mind_key -> env -> env +val lookup_mind_key : MutInd.t -> env -> mind_key +val add_mind_key : MutInd.t -> mind_key -> env -> env val add_mind : MutInd.t -> mutual_inductive_body -> env -> env (** Looks up in the context of global inductive names @@ -251,10 +303,6 @@ type 'types punsafe_type_judgment = { type unsafe_type_judgment = types punsafe_type_judgment -(** {6 Compilation of global declaration } *) - -val compile_constant_body : env -> constant_universes -> constant_def -> Cemitcodes.body_code option - exception Hyp_not_found (** [apply_to_hyp sign id f] split [sign] into [tail::(id,_,_)::head] and @@ -264,7 +312,7 @@ val apply_to_hyp : named_context_val -> variable -> (Context.Named.t -> Context.Named.Declaration.t -> Context.Named.t -> Context.Named.Declaration.t) -> named_context_val -val remove_hyps : Id.Set.t -> (Context.Named.Declaration.t -> Context.Named.Declaration.t) -> (Pre_env.lazy_val -> Pre_env.lazy_val) -> named_context_val -> named_context_val +val remove_hyps : Id.Set.t -> (Context.Named.Declaration.t -> Context.Named.Declaration.t) -> (lazy_val -> lazy_val) -> named_context_val -> named_context_val @@ -278,4 +326,4 @@ val registered : env -> field -> bool val register : env -> field -> Retroknowledge.entry -> env (** Native compiler *) -val no_link_info : Pre_env.link_info +val no_link_info : link_info diff --git a/kernel/esubst.ml b/kernel/esubst.ml index a11a0dc00..4b8edf63f 100644 --- a/kernel/esubst.ml +++ b/kernel/esubst.ml @@ -19,6 +19,8 @@ open Util (*********************) (* Explicit lifts and basic operations *) +(* Invariant to preserve in this module: no lift contains two consecutive + [ELSHFT] nor two consecutive [ELLFT]. *) type lift = | ELID | ELSHFT of lift * int (* ELSHFT(l,n) == lift of n, then apply lift l *) @@ -28,15 +30,15 @@ type lift = let el_id = ELID (* compose a relocation of magnitude n *) -let rec el_shft_rec n = function - | ELSHFT(el,k) -> el_shft_rec (k+n) el +let el_shft_rec n = function + | ELSHFT(el,k) -> ELSHFT(el,k+n) | el -> ELSHFT(el,n) let el_shft n el = if Int.equal n 0 then el else el_shft_rec n el (* cross n binders *) -let rec el_liftn_rec n = function +let el_liftn_rec n = function | ELID -> ELID - | ELLFT(k,el) -> el_liftn_rec (n+k) el + | ELLFT(k,el) -> ELLFT(n+k, el) | el -> ELLFT(n, el) let el_liftn n el = if Int.equal n 0 then el else el_liftn_rec n el @@ -138,7 +140,7 @@ let rec comp mk_cl s1 s2 = | ESID _, _ -> s2 | SHIFT(k,s), _ -> subs_shft(k, comp mk_cl s s2) | _, CONS(x,s') -> - CONS(CArray.Fun1.map (fun s t -> mk_cl(s,t)) s1 x, comp mk_cl s1 s') + CONS(Array.Fun1.map (fun s t -> mk_cl(s,t)) s1 x, comp mk_cl s1 s') | CONS(x,s), SHIFT(k,s') -> let lg = Array.length x in if k == lg then comp mk_cl s s' diff --git a/kernel/esubst.mli b/kernel/esubst.mli index b82d6fdf0..a674c425a 100644 --- a/kernel/esubst.mli +++ b/kernel/esubst.mli @@ -56,7 +56,11 @@ val comp : ('a subs * 'a -> 'a) -> 'a subs -> 'a subs -> 'a subs (** {6 Compact representation } *) (** Compact representation of explicit relocations - [ELSHFT(l,n)] == lift of [n], then apply [lift l]. - - [ELLFT(n,l)] == apply [l] to de Bruijn > [n] i.e under n binders. *) + - [ELLFT(n,l)] == apply [l] to de Bruijn > [n] i.e under n binders. + + Invariant ensured by the private flag: no lift contains two consecutive + [ELSHFT] nor two consecutive [ELLFT]. +*) type lift = private | ELID | ELSHFT of lift * int diff --git a/kernel/inductive.ml b/kernel/inductive.ml index 9bed598bb..090acdf16 100644 --- a/kernel/inductive.ml +++ b/kernel/inductive.ml @@ -803,9 +803,7 @@ let rec subterm_specif renv stack t = (* We take the subterm specs of the constructor of the record *) let wf_args = (dest_subterms wf).(0) in (* We extract the tree of the projected argument *) - let kn = Projection.constant p in - let cb = lookup_constant kn renv.env in - let pb = Option.get cb.const_proj in + let pb = lookup_projection p renv.env in let n = pb.proj_arg in spec_of_tree (List.nth wf_args n) | Dead_code -> Dead_code diff --git a/kernel/kernel.mllib b/kernel/kernel.mllib index 370185a72..50713b957 100644 --- a/kernel/kernel.mllib +++ b/kernel/kernel.mllib @@ -22,15 +22,17 @@ CPrimitives Declareops Retroknowledge Conv_oracle -Pre_env +Environ +CClosure +Reduction Clambda Nativelambda Cbytegen Nativecode Nativelib -Environ -CClosure -Reduction +Csymtable +Vm +Vconv Nativeconv Type_errors Modops @@ -43,6 +45,3 @@ Subtyping Mod_typing Nativelibrary Safe_typing -Vm -Csymtable -Vconv diff --git a/kernel/mod_subst.ml b/kernel/mod_subst.ml index 9c2fa0546..0027ebecf 100644 --- a/kernel/mod_subst.ml +++ b/kernel/mod_subst.ml @@ -367,7 +367,7 @@ let rec map_kn f f' c = in let p' = func p in let ct' = func ct in - let l' = Array.smartmap func l in + let l' = Array.Smart.map func l in if (ci.ci_ind==ci_ind && p'==p && l'==l && ct'==ct)then c else @@ -396,21 +396,21 @@ let rec map_kn f f' c = else mkLetIn (na, b', t', ct') | App (ct,l) -> let ct' = func ct in - let l' = Array.smartmap func l in + let l' = Array.Smart.map func l in if (ct'== ct && l'==l) then c else mkApp (ct',l') | Evar (e,l) -> - let l' = Array.smartmap func l in + let l' = Array.Smart.map func l in if (l'==l) then c else mkEvar (e,l') | Fix (ln,(lna,tl,bl)) -> - let tl' = Array.smartmap func tl in - let bl' = Array.smartmap func bl in + let tl' = Array.Smart.map func tl in + let bl' = Array.Smart.map func bl in if (bl == bl'&& tl == tl') then c else mkFix (ln,(lna,tl',bl')) | CoFix(ln,(lna,tl,bl)) -> - let tl' = Array.smartmap func tl in - let bl' = Array.smartmap func bl in + let tl' = Array.Smart.map func tl in + let bl' = Array.Smart.map func bl in if (bl == bl'&& tl == tl') then c else mkCoFix (ln,(lna,tl',bl')) | _ -> c diff --git a/kernel/mod_typing.ml b/kernel/mod_typing.ml index 1baab7c98..d63dc057b 100644 --- a/kernel/mod_typing.ml +++ b/kernel/mod_typing.ml @@ -120,7 +120,7 @@ let rec check_with_def env struc (idl,(c,ctx)) mp equiv = const_body = def; const_universes = univs ; const_body_code = Option.map Cemitcodes.from_val - (compile_constant_body env' cb.const_universes def) } + (Cbytegen.compile_constant_body ~fail_on_error:false env' cb.const_universes def) } in before@(lab,SFBconst(cb'))::after, c', ctx' else diff --git a/kernel/modops.ml b/kernel/modops.ml index bbf160db2..203817118 100644 --- a/kernel/modops.ml +++ b/kernel/modops.ml @@ -130,10 +130,10 @@ let destr_nofunctor = function |NoFunctor a -> a |MoreFunctor _ -> error_is_a_functor () -let rec functor_smartmap fty f0 funct = match funct with +let rec functor_smart_map fty f0 funct = match funct with |MoreFunctor (mbid,ty,e) -> let ty' = fty ty in - let e' = functor_smartmap fty f0 e in + let e' = functor_smart_map fty f0 e in if ty==ty' && e==e' then funct else MoreFunctor (mbid,ty',e') |NoFunctor a -> let a' = f0 a in if a==a' then funct else NoFunctor a' @@ -197,7 +197,7 @@ let rec subst_structure sub do_delta sign = let mtb' = subst_modtype sub do_delta mtb in if mtb==mtb' then orig else (l,SFBmodtype mtb') in - List.smartmap subst_body sign + List.Smart.map subst_body sign and subst_body : 'a. _ -> _ -> (_ -> 'a -> 'a) -> _ -> 'a generic_module_body -> 'a generic_module_body = fun is_mod sub subst_impl do_delta mb -> @@ -210,7 +210,7 @@ and subst_body : 'a. _ -> _ -> (_ -> 'a -> 'a) -> _ -> 'a generic_module_body -> in let ty' = subst_signature sub do_delta ty in let me' = subst_impl sub me in - let aty' = Option.smartmap (subst_expression sub id_delta) aty in + let aty' = Option.Smart.map (subst_expression sub id_delta) aty in let delta' = do_delta mb.mod_delta sub in if mp==mp' && me==me' && ty==ty' && aty==aty' && delta'==mb.mod_delta then mb @@ -245,12 +245,12 @@ and subst_expr sub do_delta seb = match seb with if meb==meb' && wdb==wdb' then seb else MEwith(meb',wdb') and subst_expression sub do_delta = - functor_smartmap + functor_smart_map (subst_modtype sub do_delta) (subst_expr sub do_delta) and subst_signature sub do_delta = - functor_smartmap + functor_smart_map (subst_modtype sub do_delta) (subst_structure sub do_delta) @@ -595,13 +595,13 @@ and clean_field l field = match field with if mb==mb' then field else (lab,SFBmodule mb') |_ -> field -and clean_structure l = List.smartmap (clean_field l) +and clean_structure l = List.Smart.map (clean_field l) and clean_signature l = - functor_smartmap (clean_module_type l) (clean_structure l) + functor_smart_map (clean_module_type l) (clean_structure l) and clean_expression l = - functor_smartmap (clean_module_type l) (fun me -> me) + functor_smart_map (clean_module_type l) (fun me -> me) let rec collect_mbid l sign = match sign with |MoreFunctor (mbid,ty,m) -> diff --git a/kernel/modops.mli b/kernel/modops.mli index cb41a5123..ac76d28cf 100644 --- a/kernel/modops.mli +++ b/kernel/modops.mli @@ -52,7 +52,7 @@ val add_module : module_body -> env -> env (** same as add_module, but for a module whose native code has been linked by the native compiler. The linking information is updated. *) -val add_linked_module : module_body -> Pre_env.link_info -> env -> env +val add_linked_module : module_body -> link_info -> env -> env (** same, for a module type *) val add_module_type : ModPath.t -> module_type_body -> env -> env diff --git a/kernel/names.ml b/kernel/names.ml index a3aa71f24..597061278 100644 --- a/kernel/names.ml +++ b/kernel/names.ml @@ -701,22 +701,6 @@ end module Constrmap = Map.Make(ConstructorOrdered) module Constrmap_env = Map.Make(ConstructorOrdered_env) -type global_reference = - | VarRef of variable (** A reference to the section-context. *) - | ConstRef of Constant.t (** A reference to the environment. *) - | IndRef of inductive (** A reference to an inductive type. *) - | ConstructRef of constructor (** A reference to a constructor of an inductive type. *) - -(* Better to have it here that in closure, since used in grammar.cma *) -type evaluable_global_reference = - | EvalVarRef of Id.t - | EvalConstRef of Constant.t - -let eq_egr e1 e2 = match e1, e2 with - EvalConstRef con1, EvalConstRef con2 -> Constant.equal con1 con2 - | EvalVarRef id1, EvalVarRef id2 -> Id.equal id1 id2 - | _, _ -> false - (** {6 Hash-consing of name objects } *) module Hind = Hashcons.Make( @@ -776,55 +760,8 @@ let eq_ind_chk (kn1,i1) (kn2,i2) = Int.equal i1 i2 && eq_mind_chk kn1 kn2 (*******************************************************************) (** Compatibility layers *) -(** Backward compatibility for [Id] *) - -type identifier = Id.t - -let id_eq = Id.equal -let id_ord = Id.compare -let string_of_id = Id.to_string -let id_of_string = Id.of_string - -module Idset = Id.Set -module Idmap = Id.Map -module Idpred = Id.Pred - -(** Compatibility layer for [Name] *) - -let name_eq = Name.equal - -(** Compatibility layer for [DirPath] *) - -type dir_path = DirPath.t -let dir_path_ord = DirPath.compare -let dir_path_eq = DirPath.equal -let make_dirpath = DirPath.make -let repr_dirpath = DirPath.repr -let empty_dirpath = DirPath.empty -let is_empty_dirpath = DirPath.is_empty -let string_of_dirpath = DirPath.to_string -let initial_dir = DirPath.initial - -(** Compatibility layer for [MBId] *) - type mod_bound_id = MBId.t -let mod_bound_id_ord = MBId.compare -let mod_bound_id_eq = MBId.equal -let make_mbid = MBId.make -let repr_mbid = MBId.repr -let debug_string_of_mbid = MBId.debug_to_string -let string_of_mbid = MBId.to_string -let id_of_mbid = MBId.to_id - -(** Compatibility layer for [Label] *) - -type label = Id.t -let mk_label = Label.make -let string_of_label = Label.to_string -let pr_label = Label.print -let id_of_label = Label.to_id -let label_of_id = Label.of_id -let eq_label = Label.equal +let eq_constant_key = Constant.UserOrd.equal (** Compatibility layer for [ModPath] *) @@ -832,32 +769,13 @@ type module_path = ModPath.t = | MPfile of DirPath.t | MPbound of MBId.t | MPdot of module_path * Label.t -let check_bound_mp = ModPath.is_bound -let string_of_mp = ModPath.to_string -let mp_ord = ModPath.compare -let mp_eq = ModPath.equal -let initial_path = ModPath.initial - -(** Compatibility layer for [KerName] *) - -type kernel_name = KerName.t -let make_kn = KerName.make -let repr_kn = KerName.repr -let modpath = KerName.modpath -let label = KerName.label -let string_of_kn = KerName.to_string -let pr_kn = KerName.print -let kn_ord = KerName.compare (** Compatibility layer for [Constant] *) -type constant = Constant.t - +module Projection = +struct + type t = Constant.t * bool -module Projection = -struct - type t = constant * bool - let make c b = (c, b) let constant = fst @@ -904,39 +822,39 @@ end type projection = Projection.t -let constant_of_kn = Constant.make1 -let constant_of_kn_equiv = Constant.make -let make_con = Constant.make3 -let repr_con = Constant.repr3 -let canonical_con = Constant.canonical -let user_con = Constant.user -let con_label = Constant.label -let con_modpath = Constant.modpath -let eq_constant = Constant.equal -let eq_constant_key = Constant.UserOrd.equal -let con_ord = Constant.CanOrd.compare -let con_user_ord = Constant.UserOrd.compare -let string_of_con = Constant.to_string -let pr_con = Constant.print -let debug_string_of_con = Constant.debug_to_string -let debug_pr_con = Constant.debug_print -let con_with_label = Constant.change_label - -(** Compatibility layer for [MutInd] *) - -type mutual_inductive = MutInd.t -let mind_of_kn = MutInd.make1 -let mind_of_kn_equiv = MutInd.make -let make_mind = MutInd.make3 -let canonical_mind = MutInd.canonical -let user_mind = MutInd.user -let repr_mind = MutInd.repr3 -let mind_label = MutInd.label -let mind_modpath = MutInd.modpath -let eq_mind = MutInd.equal -let mind_ord = MutInd.CanOrd.compare -let mind_user_ord = MutInd.UserOrd.compare -let string_of_mind = MutInd.to_string -let pr_mind = MutInd.print -let debug_string_of_mind = MutInd.debug_to_string -let debug_pr_mind = MutInd.debug_print +module GlobRef = struct + + type t = + | VarRef of variable (** A reference to the section-context. *) + | ConstRef of Constant.t (** A reference to the environment. *) + | IndRef of inductive (** A reference to an inductive type. *) + | ConstructRef of constructor (** A reference to a constructor of an inductive type. *) + + let equal gr1 gr2 = + gr1 == gr2 || match gr1,gr2 with + | ConstRef con1, ConstRef con2 -> Constant.equal con1 con2 + | IndRef kn1, IndRef kn2 -> eq_ind kn1 kn2 + | ConstructRef kn1, ConstructRef kn2 -> eq_constructor kn1 kn2 + | VarRef v1, VarRef v2 -> Id.equal v1 v2 + | (ConstRef _ | IndRef _ | ConstructRef _ | VarRef _), _ -> false + +end + +type global_reference = GlobRef.t +[@@ocaml.deprecated "Alias for [GlobRef.t]"] + +type evaluable_global_reference = + | EvalVarRef of Id.t + | EvalConstRef of Constant.t + +(* Better to have it here that in closure, since used in grammar.cma *) +let eq_egr e1 e2 = match e1, e2 with + EvalConstRef con1, EvalConstRef con2 -> Constant.equal con1 con2 + | EvalVarRef id1, EvalVarRef id2 -> Id.equal id1 id2 + | _, _ -> false + +(** Located identifiers and objects with syntax. *) + +type lident = Id.t CAst.t +type lname = Name.t CAst.t +type lstring = string CAst.t diff --git a/kernel/names.mli b/kernel/names.mli index ffd96781b..4eb5adb62 100644 --- a/kernel/names.mli +++ b/kernel/names.mli @@ -500,21 +500,6 @@ val constructor_user_hash : constructor -> int val constructor_syntactic_ord : constructor -> constructor -> int val constructor_syntactic_hash : constructor -> int -(** {6 Global reference is a kernel side type for all references together } *) -type global_reference = - | VarRef of variable (** A reference to the section-context. *) - | ConstRef of Constant.t (** A reference to the environment. *) - | IndRef of inductive (** A reference to an inductive type. *) - | ConstructRef of constructor (** A reference to a constructor of an inductive type. *) - -(** Better to have it here that in Closure, since required in grammar.cma *) -type evaluable_global_reference = - | EvalVarRef of Id.t - | EvalConstRef of Constant.t - -val eq_egr : evaluable_global_reference -> evaluable_global_reference - -> bool - (** {6 Hash-consing } *) val hcons_con : Constant.t -> Constant.t @@ -547,120 +532,14 @@ val eq_constant_key : Constant.t -> Constant.t -> bool (** equalities on constant and inductive names (for the checker) *) val eq_con_chk : Constant.t -> Constant.t -> bool +[@@ocaml.deprecated "Same as [Constant.UserOrd.equal]."] + val eq_ind_chk : inductive -> inductive -> bool (** {6 Deprecated functions. For backward compatibility.} *) -(** {5 Identifiers} *) - -type identifier = Id.t -[@@ocaml.deprecated "Alias for [Id.t]"] - -val string_of_id : Id.t -> string -[@@ocaml.deprecated "Same as [Id.to_string]."] - -val id_of_string : string -> Id.t -[@@ocaml.deprecated "Same as [Id.of_string]."] - -val id_ord : Id.t -> Id.t -> int -[@@ocaml.deprecated "Same as [Id.compare]."] - -val id_eq : Id.t -> Id.t -> bool -[@@ocaml.deprecated "Same as [Id.equal]."] - -module Idset : Set.S with type elt = Id.t and type t = Id.Set.t -[@@ocaml.deprecated "Same as [Id.Set]."] - -module Idpred : Predicate.S with type elt = Id.t and type t = Id.Pred.t -[@@ocaml.deprecated "Same as [Id.Pred]."] - -module Idmap : module type of Id.Map -[@@ocaml.deprecated "Same as [Id.Map]."] - -(** {5 Directory paths} *) - -type dir_path = DirPath.t -[@@ocaml.deprecated "Alias for [DirPath.t]."] - -val dir_path_ord : DirPath.t -> DirPath.t -> int -[@@ocaml.deprecated "Same as [DirPath.compare]."] - -val dir_path_eq : DirPath.t -> DirPath.t -> bool -[@@ocaml.deprecated "Same as [DirPath.equal]."] - -val make_dirpath : module_ident list -> DirPath.t -[@@ocaml.deprecated "Same as [DirPath.make]."] - -val repr_dirpath : DirPath.t -> module_ident list -[@@ocaml.deprecated "Same as [DirPath.repr]."] - -val empty_dirpath : DirPath.t -[@@ocaml.deprecated "Same as [DirPath.empty]."] - -val is_empty_dirpath : DirPath.t -> bool -[@@ocaml.deprecated "Same as [DirPath.is_empty]."] - -val string_of_dirpath : DirPath.t -> string -[@@ocaml.deprecated "Same as [DirPath.to_string]."] - -val initial_dir : DirPath.t -[@@ocaml.deprecated "Same as [DirPath.initial]."] - -(** {5 Labels} *) - -type label = Label.t -[@@ocaml.deprecated "Same as [Label.t]."] -(** Alias type *) - -val mk_label : string -> Label.t -[@@ocaml.deprecated "Same as [Label.make]."] - -val string_of_label : Label.t -> string -[@@ocaml.deprecated "Same as [Label.to_string]."] - -val pr_label : Label.t -> Pp.t -[@@ocaml.deprecated "Same as [Label.print]."] - -val label_of_id : Id.t -> Label.t -[@@ocaml.deprecated "Same as [Label.of_id]."] - -val id_of_label : Label.t -> Id.t -[@@ocaml.deprecated "Same as [Label.to_id]."] - -val eq_label : Label.t -> Label.t -> bool -[@@ocaml.deprecated "Same as [Label.equal]."] - -(** {5 Unique bound module names} *) - type mod_bound_id = MBId.t -(** Alias type. *) - -val mod_bound_id_ord : mod_bound_id -> mod_bound_id -> int -[@@ocaml.deprecated "Same as [MBId.compare]."] - -val mod_bound_id_eq : mod_bound_id -> mod_bound_id -> bool -[@@ocaml.deprecated "Same as [MBId.equal]."] - -val make_mbid : DirPath.t -> Id.t -> mod_bound_id -[@@ocaml.deprecated "Same as [MBId.make]."] - -val repr_mbid : mod_bound_id -> int * Id.t * DirPath.t -[@@ocaml.deprecated "Same as [MBId.repr]."] - -val id_of_mbid : mod_bound_id -> Id.t -[@@ocaml.deprecated "Same as [MBId.to_id]."] - -val string_of_mbid : mod_bound_id -> string -[@@ocaml.deprecated "Same as [MBId.to_string]."] - -val debug_string_of_mbid : mod_bound_id -> string -[@@ocaml.deprecated "Same as [MBId.debug_to_string]."] - -(** {5 Names} *) - -val name_eq : Name.t -> Name.t -> bool -[@@ocaml.deprecated "Same as [Name.equal]."] - +[@@ocaml.deprecated "Same as [MBId.t]."] (** {5 Module paths} *) type module_path = ModPath.t = @@ -669,52 +548,6 @@ type module_path = ModPath.t = | MPdot of ModPath.t * Label.t [@@ocaml.deprecated "Alias type"] -val mp_ord : ModPath.t -> ModPath.t -> int -[@@ocaml.deprecated "Same as [ModPath.compare]."] - -val mp_eq : ModPath.t -> ModPath.t -> bool -[@@ocaml.deprecated "Same as [ModPath.equal]."] - -val check_bound_mp : ModPath.t -> bool -[@@ocaml.deprecated "Same as [ModPath.is_bound]."] - -val string_of_mp : ModPath.t -> string -[@@ocaml.deprecated "Same as [ModPath.to_string]."] - -val initial_path : ModPath.t -[@@ocaml.deprecated "Same as [ModPath.initial]."] - -(** {5 Kernel names} *) - -type kernel_name = KerName.t -[@@ocaml.deprecated "Alias type"] - -val make_kn : ModPath.t -> DirPath.t -> Label.t -> KerName.t -[@@ocaml.deprecated "Same as [KerName.make]."] - -val repr_kn : KerName.t -> ModPath.t * DirPath.t * Label.t -[@@ocaml.deprecated "Same as [KerName.repr]."] - -val modpath : KerName.t -> ModPath.t -[@@ocaml.deprecated "Same as [KerName.modpath]."] - -val label : KerName.t -> Label.t -[@@ocaml.deprecated "Same as [KerName.label]."] - -val string_of_kn : KerName.t -> string -[@@ocaml.deprecated "Same as [KerName.to_string]."] - -val pr_kn : KerName.t -> Pp.t -[@@ocaml.deprecated "Same as [KerName.print]."] - -val kn_ord : KerName.t -> KerName.t -> int -[@@ocaml.deprecated "Same as [KerName.compare]."] - -(** {5 Constant names} *) - -type constant = Constant.t -[@@ocaml.deprecated "Alias type"] - module Projection : sig type t @@ -745,101 +578,36 @@ module Projection : sig end type projection = Projection.t +[@@ocaml.deprecated "Alias for [Projection.t]"] -val constant_of_kn_equiv : KerName.t -> KerName.t -> Constant.t -[@@ocaml.deprecated "Same as [Constant.make]"] - -val constant_of_kn : KerName.t -> Constant.t -[@@ocaml.deprecated "Same as [Constant.make1]"] - -val make_con : ModPath.t -> DirPath.t -> Label.t -> Constant.t -[@@ocaml.deprecated "Same as [Constant.make3]"] - -val repr_con : Constant.t -> ModPath.t * DirPath.t * Label.t -[@@ocaml.deprecated "Same as [Constant.repr3]"] - -val user_con : Constant.t -> KerName.t -[@@ocaml.deprecated "Same as [Constant.user]"] - -val canonical_con : Constant.t -> KerName.t -[@@ocaml.deprecated "Same as [Constant.canonical]"] - -val con_modpath : Constant.t -> ModPath.t -[@@ocaml.deprecated "Same as [Constant.modpath]"] - -val con_label : Constant.t -> Label.t -[@@ocaml.deprecated "Same as [Constant.label]"] - -val eq_constant : Constant.t -> Constant.t -> bool -[@@ocaml.deprecated "Same as [Constant.equal]"] - -val con_ord : Constant.t -> Constant.t -> int -[@@ocaml.deprecated "Same as [Constant.CanOrd.compare]"] - -val con_user_ord : Constant.t -> Constant.t -> int -[@@ocaml.deprecated "Same as [Constant.UserOrd.compare]"] - -val con_with_label : Constant.t -> Label.t -> Constant.t -[@@ocaml.deprecated "Same as [Constant.change_label]"] - -val string_of_con : Constant.t -> string -[@@ocaml.deprecated "Same as [Constant.to_string]"] - -val pr_con : Constant.t -> Pp.t -[@@ocaml.deprecated "Same as [Constant.print]"] - -val debug_pr_con : Constant.t -> Pp.t -[@@ocaml.deprecated "Same as [Constant.debug_print]"] - -val debug_string_of_con : Constant.t -> string -[@@ocaml.deprecated "Same as [Constant.debug_to_string]"] - -(** {5 Mutual Inductive names} *) - -type mutual_inductive = MutInd.t -[@@ocaml.deprecated "Alias type"] - -val mind_of_kn : KerName.t -> MutInd.t -[@@ocaml.deprecated "Same as [MutInd.make1]"] - -val mind_of_kn_equiv : KerName.t -> KerName.t -> MutInd.t -[@@ocaml.deprecated "Same as [MutInd.make]"] - -val make_mind : ModPath.t -> DirPath.t -> Label.t -> MutInd.t -[@@ocaml.deprecated "Same as [MutInd.make3]"] - -val user_mind : MutInd.t -> KerName.t -[@@ocaml.deprecated "Same as [MutInd.user]"] - -val canonical_mind : MutInd.t -> KerName.t -[@@ocaml.deprecated "Same as [MutInd.canonical]"] - -val repr_mind : MutInd.t -> ModPath.t * DirPath.t * Label.t -[@@ocaml.deprecated "Same as [MutInd.repr3]"] +(** {6 Global reference is a kernel side type for all references together } *) -val eq_mind : MutInd.t -> MutInd.t -> bool -[@@ocaml.deprecated "Same as [MutInd.equal]"] +(* XXX: Should we define GlobRefCan GlobRefUser? *) +module GlobRef : sig -val mind_ord : MutInd.t -> MutInd.t -> int -[@@ocaml.deprecated "Same as [MutInd.CanOrd.compare]"] + type t = + | VarRef of variable (** A reference to the section-context. *) + | ConstRef of Constant.t (** A reference to the environment. *) + | IndRef of inductive (** A reference to an inductive type. *) + | ConstructRef of constructor (** A reference to a constructor of an inductive type. *) -val mind_user_ord : MutInd.t -> MutInd.t -> int -[@@ocaml.deprecated "Same as [MutInd.UserOrd.compare]"] + val equal : t -> t -> bool -val mind_label : MutInd.t -> Label.t -[@@ocaml.deprecated "Same as [MutInd.label]"] +end -val mind_modpath : MutInd.t -> ModPath.t -[@@ocaml.deprecated "Same as [MutInd.modpath]"] +type global_reference = GlobRef.t +[@@ocaml.deprecated "Alias for [GlobRef.t]"] -val string_of_mind : MutInd.t -> string -[@@ocaml.deprecated "Same as [MutInd.to_string]"] +(** Better to have it here that in Closure, since required in grammar.cma *) +(* XXX: Move to a module *) +type evaluable_global_reference = + | EvalVarRef of Id.t + | EvalConstRef of Constant.t -val pr_mind : MutInd.t -> Pp.t -[@@ocaml.deprecated "Same as [MutInd.print]"] +val eq_egr : evaluable_global_reference -> evaluable_global_reference -> bool -val debug_pr_mind : MutInd.t -> Pp.t -[@@ocaml.deprecated "Same as [MutInd.debug_print]"] +(** Located identifiers and objects with syntax. *) -val debug_string_of_mind : MutInd.t -> string -[@@ocaml.deprecated "Same as [MutInd.debug_to_string]"] +type lident = Id.t CAst.t +type lname = Name.t CAst.t +type lstring = string CAst.t diff --git a/kernel/nativecode.ml b/kernel/nativecode.ml index c82d982b4..8257dc8b8 100644 --- a/kernel/nativecode.ml +++ b/kernel/nativecode.ml @@ -16,7 +16,7 @@ open Util open Nativevalues open Nativeinstr open Nativelambda -open Pre_env +open Environ [@@@ocaml.warning "-32-37"] @@ -53,7 +53,7 @@ type gname = | Gind of string * inductive (* prefix, inductive name *) | Gconstruct of string * constructor (* prefix, constructor name *) | Gconstant of string * Constant.t (* prefix, constant name *) - | Gproj of string * Constant.t (* prefix, constant name *) + | Gproj of string * inductive * int (* prefix, inductive, index (start from 0) *) | Gcase of Label.t option * int | Gpred of Label.t option * int | Gfixtype of Label.t option * int @@ -108,7 +108,7 @@ let gname_hash gn = match gn with | Ginternal s -> combinesmall 9 (String.hash s) | Grel i -> combinesmall 10 (Int.hash i) | Gnamed id -> combinesmall 11 (Id.hash id) -| Gproj (s, p) -> combinesmall 12 (combine (String.hash s) (Constant.hash p)) +| Gproj (s, p, i) -> combinesmall 12 (combine (String.hash s) (combine (ind_hash p) i)) let case_ctr = ref (-1) @@ -152,6 +152,7 @@ type symbol = | SymbMeta of metavariable | SymbEvar of Evar.t | SymbLevel of Univ.Level.t + | SymbProj of (inductive * int) let dummy_symb = SymbValue (dummy_value ()) @@ -166,6 +167,7 @@ let eq_symbol sy1 sy2 = | SymbMeta m1, SymbMeta m2 -> Int.equal m1 m2 | SymbEvar evk1, SymbEvar evk2 -> Evar.equal evk1 evk2 | SymbLevel l1, SymbLevel l2 -> Univ.Level.equal l1 l2 + | SymbProj (i1, k1), SymbProj (i2, k2) -> eq_ind i1 i2 && Int.equal k1 k2 | _, _ -> false let hash_symbol symb = @@ -179,6 +181,7 @@ let hash_symbol symb = | SymbMeta m -> combinesmall 7 m | SymbEvar evk -> combinesmall 8 (Evar.hash evk) | SymbLevel l -> combinesmall 9 (Univ.Level.hash l) + | SymbProj (i, k) -> combinesmall 10 (combine (ind_hash i) k) module HashedTypeSymbol = struct type t = symbol @@ -241,6 +244,11 @@ let get_level tbl i = | SymbLevel u -> u | _ -> anomaly (Pp.str "get_level failed.") +let get_proj tbl i = + match tbl.(i) with + | SymbProj p -> p + | _ -> anomaly (Pp.str "get_proj failed.") + let push_symbol x = try HashtblSymbol.find symb_tbl x with Not_found -> @@ -885,6 +893,10 @@ let get_level_code i = MLapp (MLglobal (Ginternal "get_level"), [|MLglobal symbols_tbl_name; MLint i|]) +let get_proj_code i = + MLapp (MLglobal (Ginternal "get_proj"), + [|MLglobal symbols_tbl_name; MLint i|]) + type rlist = | Rnil | Rcons of (constructor * lname option array) list ref * LNset.t * mllambda * rlist' @@ -1070,7 +1082,7 @@ let ml_of_instance instance u = | Lconst (prefix, (c, u)) -> let args = ml_of_instance env.env_univ u in mkMLapp (MLglobal(Gconstant (prefix, c))) args - | Lproj (prefix,c) -> MLglobal(Gproj (prefix,c)) + | Lproj (prefix, ind, i) -> MLglobal(Gproj (prefix, ind, i)) | Lprim _ -> let decl,cond,paux = extract_prim (ml_of_lam env l) t in compile_prim decl cond paux @@ -1544,8 +1556,8 @@ let string_of_gname g = Format.sprintf "%sconstruct_%s_%i_%i" prefix (string_of_mind mind) i (j-1) | Gconstant (prefix, c) -> Format.sprintf "%sconst_%s" prefix (string_of_con c) - | Gproj (prefix, c) -> - Format.sprintf "%sproj_%s" prefix (string_of_con c) + | Gproj (prefix, (mind, n), i) -> + Format.sprintf "%sproj_%s_%i_%i" prefix (string_of_mind mind) n i | Gcase (l,i) -> Format.sprintf "case_%s_%i" (string_of_label_def l) i | Gpred (l,i) -> @@ -1837,7 +1849,7 @@ and apply_fv env sigma univ (fv_named,fv_rel) auxdefs ml = and compile_rel env sigma univ auxdefs n = let open Context.Rel.Declaration in - let decl = Pre_env.lookup_rel n env in + let decl = lookup_rel n env in let n = List.length env.env_rel_context.env_rel_ctx - n in match decl with | LocalDef (_,t,_) -> @@ -1858,8 +1870,6 @@ and compile_named env sigma univ auxdefs id = Glet(Gnamed id, MLprimitive (Mk_var id))::auxdefs let compile_constant env sigma prefix ~interactive con cb = - match cb.const_proj with - | None -> let no_univs = match cb.const_universes with | Monomorphic_const _ -> true @@ -1903,38 +1913,6 @@ let compile_constant env sigma prefix ~interactive con cb = if interactive then LinkedInteractive prefix else Linked prefix end - | Some pb -> - let mind = pb.proj_ind in - let ind = (mind,0) in - let mib = lookup_mind mind env in - let oib = mib.mind_packets.(0) in - let tbl = oib.mind_reloc_tbl in - (* Building info *) - let prefix = get_mind_prefix env mind in - let ci = { ci_ind = ind; ci_npar = mib.mind_nparams; - ci_cstr_nargs = [|0|]; - ci_cstr_ndecls = [||] (*FIXME*); - ci_pp_info = { ind_tags = []; cstr_tags = [||] (*FIXME*); style = RegularStyle } } in - let asw = { asw_ind = ind; asw_prefix = prefix; asw_ci = ci; - asw_reloc = tbl; asw_finite = true } in - let c_uid = fresh_lname Anonymous in - let cf_uid = fresh_lname Anonymous in - let _, arity = tbl.(0) in - let ci_uid = fresh_lname Anonymous in - let cargs = Array.init arity - (fun i -> if Int.equal i pb.proj_arg then Some ci_uid else None) - in - let i = push_symbol (SymbConst con) in - let accu = MLapp (MLprimitive Cast_accu, [|MLlocal cf_uid|]) in - let accu_br = MLapp (MLprimitive Mk_proj, [|get_const_code i;accu|]) in - let code = MLmatch(asw,MLlocal cf_uid,accu_br,[|[((ind,1),cargs)],MLlocal ci_uid|]) in - let code = MLlet(cf_uid, MLapp (MLprimitive Force_cofix, [|MLlocal c_uid|]), code) in - let gn = Gproj ("",con) in - let fargs = Array.init (pb.proj_npars + 1) (fun _ -> fresh_lname Anonymous) in - let arg = fargs.(pb.proj_npars) in - Glet(Gconstant ("", con), mkMLlam fargs (MLapp (MLglobal gn, [|MLlocal - arg|]))):: - [Glet(gn, mkMLlam [|c_uid|] code)], Linked prefix module StringOrd = struct type t = string let compare = String.compare end module StringSet = Set.Make(StringOrd) @@ -1961,10 +1939,12 @@ let arg_name = Name (Id.of_string "arg") let compile_mind prefix ~interactive mb mind stack = let u = Declareops.inductive_polymorphic_context mb in + (** Generate data for every block *) let f i stack ob = - let gtype = Gtype((mind, i), Array.map snd ob.mind_reloc_tbl) in - let j = push_symbol (SymbInd (mind,i)) in - let name = Gind ("", (mind, i)) in + let ind = (mind, i) in + let gtype = Gtype(ind, Array.map snd ob.mind_reloc_tbl) in + let j = push_symbol (SymbInd ind) in + let name = Gind ("", ind) in let accu = let args = if Int.equal (Univ.AUContext.size u) 0 then @@ -1978,12 +1958,41 @@ let compile_mind prefix ~interactive mb mind stack = Array.init nparams (fun i -> {lname = param_name; luid = i}) in let add_construct j acc (_,arity) = let args = Array.init arity (fun k -> {lname = arg_name; luid = k}) in - let c = (mind,i), (j+1) in + let c = ind, (j+1) in Glet(Gconstruct ("", c), mkMLlam (Array.append params args) (MLconstruct("", c, Array.map (fun id -> MLlocal id) args)))::acc in - Array.fold_left_i add_construct (gtype::accu::stack) ob.mind_reloc_tbl + let constructors = Array.fold_left_i add_construct [] ob.mind_reloc_tbl in + let add_proj j acc pb = + let tbl = ob.mind_reloc_tbl in + (* Building info *) + let ci = { ci_ind = ind; ci_npar = nparams; + ci_cstr_nargs = [|0|]; + 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; + asw_reloc = tbl; asw_finite = true } in + let c_uid = fresh_lname Anonymous in + let cf_uid = fresh_lname Anonymous in + let _, arity = tbl.(0) in + let ci_uid = fresh_lname Anonymous in + let cargs = Array.init arity + (fun i -> if Int.equal i pb.proj_arg then Some ci_uid else None) + in + let i = push_symbol (SymbProj (ind, j)) in + let accu = MLapp (MLprimitive Cast_accu, [|MLlocal cf_uid|]) in + let accu_br = MLapp (MLprimitive Mk_proj, [|get_proj_code i;accu|]) in + let code = MLmatch(asw,MLlocal cf_uid,accu_br,[|[((ind,1),cargs)],MLlocal ci_uid|]) in + let code = MLlet(cf_uid, MLapp (MLprimitive Force_cofix, [|MLlocal c_uid|]), code) in + let gn = Gproj ("", (pb.proj_ind, j), pb.proj_arg) in + Glet (gn, mkMLlam [|c_uid|] code) :: acc + in + let projs = match mb.mind_record with + | None | Some None -> [] + | Some (Some (id, kns, pbs)) -> Array.fold_left_i add_proj [] pbs + in + projs @ constructors @ gtype :: accu :: stack in Array.fold_left_i f stack mb.mind_packets @@ -2016,24 +2025,22 @@ let compile_mind_deps env prefix ~interactive (* This function compiles all necessary dependencies of t, and generates code in reverse order, as well as linking information updates *) -let rec compile_deps env sigma prefix ~interactive init t = +let compile_deps env sigma prefix ~interactive init t = + let rec aux env lvl init t = match kind t with | Ind ((mind,_),u) -> compile_mind_deps env prefix ~interactive init mind | Const c -> - let c,u = get_alias env c in - let cb,(nameref,_) = lookup_constant_key c env in - let (_, (_, const_updates)) = init in - if is_code_loaded ~interactive nameref - || (Cmap_env.mem c const_updates) - then init - else + let c,u = get_alias env c in + let cb,(nameref,_) = lookup_constant_key c env in + let (_, (_, const_updates)) = init in + if is_code_loaded ~interactive nameref + || (Cmap_env.mem c const_updates) + then init + else let comp_stack, (mind_updates, const_updates) = - match cb.const_proj, cb.const_body with - | None, Def t -> - compile_deps env sigma prefix ~interactive init (Mod_subst.force_constr t) - | Some pb, _ -> - let mind = pb.proj_ind in - compile_mind_deps env prefix ~interactive init mind + match cb.const_body with + | Def t -> + aux env lvl init (Mod_subst.force_constr t) | _ -> init in let code, name = @@ -2044,13 +2051,32 @@ let rec compile_deps env sigma prefix ~interactive init t = comp_stack, (mind_updates, const_updates) | Construct (((mind,_),_),u) -> compile_mind_deps env prefix ~interactive init mind | Proj (p,c) -> - let term = mkApp (mkConst (Projection.constant p), [|c|]) in - compile_deps env sigma prefix ~interactive init term + let pb = lookup_projection p env in + let init = compile_mind_deps env prefix ~interactive init pb.proj_ind in + aux env lvl init c | Case (ci, p, c, ac) -> let mind = fst ci.ci_ind in let init = compile_mind_deps env prefix ~interactive init mind in - Constr.fold (compile_deps env sigma prefix ~interactive) init t - | _ -> Constr.fold (compile_deps env sigma prefix ~interactive) init t + fold_constr_with_binders succ (aux env) lvl init t + | Var id -> + let open Context.Named.Declaration in + begin match lookup_named id env with + | LocalDef (_,t,_) -> + aux env lvl init t + | _ -> init + end + | Rel n when n > lvl -> + let open Context.Rel.Declaration in + let decl = lookup_rel n env in + let env = env_of_rel n env in + begin match decl with + | LocalDef (_,t,_) -> + aux env lvl init t + | LocalAssum _ -> init + end + | _ -> fold_constr_with_binders succ (aux env) lvl init t + in + aux env 0 init t let compile_constant_field env prefix con acc cb = let (gl, _) = diff --git a/kernel/nativecode.mli b/kernel/nativecode.mli index 4b23cc5f8..684983a87 100644 --- a/kernel/nativecode.mli +++ b/kernel/nativecode.mli @@ -10,7 +10,7 @@ open Names open Constr open Declarations -open Pre_env +open Environ open Nativelambda (** This file defines the mllambda code generation phase of the native @@ -50,6 +50,8 @@ val get_evar : symbols -> int -> Evar.t val get_level : symbols -> int -> Univ.Level.t +val get_proj : symbols -> int -> inductive * int + val get_symbols : unit -> symbols type code_location_update diff --git a/kernel/nativeconv.ml b/kernel/nativeconv.ml index c71f746be..e97dbd0d6 100644 --- a/kernel/nativeconv.ml +++ b/kernel/nativeconv.ml @@ -114,8 +114,8 @@ and conv_atom env pb lvl a1 a2 cu = let cu = conv_val env CONV lvl d1 d2 cu in let v = mk_rel_accu lvl in conv_val env pb (lvl + 1) (d1 v) (d2 v) cu - | Aproj(p1,ac1), Aproj(p2,ac2) -> - if not (Constant.equal p1 p2) then raise NotConvertible + | Aproj((ind1, i1), ac1), Aproj((ind2, i2), ac2) -> + if not (eq_ind ind1 ind2 && Int.equal i1 i2) then raise NotConvertible else conv_accu env CONV lvl ac1 ac2 cu | Arel _, _ | Aind _, _ | Aconstant _, _ | Asort _, _ | Avar _, _ | Acase _, _ | Afix _, _ | Acofix _, _ | Acofixe _, _ | Aprod _, _ @@ -136,9 +136,8 @@ and conv_fix env lvl t1 f1 t2 f2 cu = aux 0 cu let native_conv_gen pb sigma env univs t1 t2 = - let penv = Environ.pre_env env in let ml_filename, prefix = get_ml_filename () in - let code, upds = mk_conv_code penv sigma prefix t1 t2 in + let code, upds = mk_conv_code env sigma prefix t1 t2 in match compile ml_filename code ~profile:false with | (true, fn) -> begin @@ -163,7 +162,7 @@ let warn_no_native_compiler = let native_conv cv_pb sigma env t1 t2 = if not Coq_config.native_compiler then begin warn_no_native_compiler (); - vm_conv cv_pb env t1 t2 + Vconv.vm_conv cv_pb env t1 t2 end else let univs = Environ.universes env in diff --git a/kernel/nativeinstr.mli b/kernel/nativeinstr.mli index 9c17cc2b5..eaad8ee0c 100644 --- a/kernel/nativeinstr.mli +++ b/kernel/nativeinstr.mli @@ -31,13 +31,13 @@ and lambda = | Llet of Name.t * lambda * lambda | Lapp of lambda * lambda array | Lconst of prefix * pconstant - | Lproj of prefix * Constant.t (* prefix, projection name *) + | Lproj of prefix * inductive * int (* prefix, inductive, index starting from 0 *) | Lprim of prefix * Constant.t * CPrimitives.t * lambda array | Lcase of annot_sw * lambda * lambda * lam_branches (* annotations, term being matched, accu, branches *) | Lif of lambda * lambda * lambda | Lfix of (int array * int) * fix_decl - | Lcofix of int * fix_decl + | Lcofix of int * fix_decl (* must be in eta-expanded form *) | Lmakeblock of prefix * pconstructor * int * lambda array (* prefix, constructor name, constructor tag, arguments *) (* A fully applied constructor *) @@ -50,6 +50,10 @@ and lambda = | Llazy | Lforce +(* Cofixpoints have to be in eta-expanded form for their call-by-need evaluation +to be correct. Otherwise, memoization of previous evaluations will be applied +again to extra arguments (see #7333). *) + and lam_branches = (constructor * Name.t array * lambda) array and fix_decl = Name.t array * lambda array * lambda array diff --git a/kernel/nativelambda.ml b/kernel/nativelambda.ml index 01ddffe3e..0325a00b4 100644 --- a/kernel/nativelambda.ml +++ b/kernel/nativelambda.ml @@ -12,7 +12,7 @@ open Names open Esubst open Constr open Declarations -open Pre_env +open Environ open Nativevalues open Nativeinstr @@ -102,10 +102,10 @@ let rec map_lam_with_binders g f n lam = if body == body' && def == def' then lam else Llet(id,def',body') | Lapp(fct,args) -> let fct' = f n fct in - let args' = Array.smartmap (f n) args in + let args' = Array.Smart.map (f n) args in if fct == fct' && args == args' then lam else mkLapp fct' args' | Lprim(prefix,kn,op,args) -> - let args' = Array.smartmap (f n) args in + let args' = Array.Smart.map (f n) args in if args == args' then lam else Lprim(prefix,kn,op,args') | Lcase(annot,t,a,br) -> let t' = f n t in @@ -116,7 +116,7 @@ let rec map_lam_with_binders g f n lam = if Array.is_empty ids then f n body else f (g (Array.length ids) n) body in if body == body' then b else (cn,ids,body') in - let br' = Array.smartmap on_b br in + let br' = Array.Smart.map on_b br in if t == t' && a == a' && br == br' then lam else Lcase(annot,t',a',br') | Lif(t,bt,bf) -> let t' = f n t in @@ -124,17 +124,17 @@ let rec map_lam_with_binders g f n lam = let bf' = f n bf in if t == t' && bt == bt' && bf == bf' then lam else Lif(t',bt',bf') | Lfix(init,(ids,ltypes,lbodies)) -> - let ltypes' = Array.smartmap (f n) ltypes in - let lbodies' = Array.smartmap (f (g (Array.length ids) n)) lbodies in + let ltypes' = Array.Smart.map (f n) ltypes in + let lbodies' = Array.Smart.map (f (g (Array.length ids) n)) lbodies in if ltypes == ltypes' && lbodies == lbodies' then lam else Lfix(init,(ids,ltypes',lbodies')) | Lcofix(init,(ids,ltypes,lbodies)) -> - let ltypes' = Array.smartmap (f n) ltypes in - let lbodies' = Array.smartmap (f (g (Array.length ids) n)) lbodies in + let ltypes' = Array.Smart.map (f n) ltypes in + let lbodies' = Array.Smart.map (f (g (Array.length ids) n)) lbodies in if ltypes == ltypes' && lbodies == lbodies' then lam else Lcofix(init,(ids,ltypes',lbodies')) | Lmakeblock(prefix,cn,tag,args) -> - let args' = Array.smartmap (f n) args in + let args' = Array.Smart.map (f n) args in if args == args' then lam else Lmakeblock(prefix,cn,tag,args') | Luint u -> let u' = map_uint g f n u in @@ -144,7 +144,7 @@ and map_uint g f n u = match u with | UintVal _ -> u | UintDigits(prefix,c,args) -> - let args' = Array.smartmap (f n) args in + let args' = Array.Smart.map (f n) args in if args == args' then u else UintDigits(prefix,c,args') | UintDecomp(prefix,c,a) -> let a' = f n a in @@ -177,7 +177,7 @@ let rec lam_exsubst subst lam = let lam_subst_args subst args = if is_subs_id subst then args - else Array.smartmap (lam_exsubst subst) args + else Array.Smart.map (lam_exsubst subst) args (** Simplification of lambda expression *) @@ -272,7 +272,7 @@ and simplify_app substf f substa args = (* TODO | Lproj -> simplify if the argument is known or a known global *) | _ -> mkLapp (simplify substf f) (simplify_args substa args) -and simplify_args subst args = Array.smartmap (simplify subst) args +and simplify_args subst args = Array.Smart.map (simplify subst) args and reduce_lapp substf lids body substa largs = match lids, largs with @@ -296,15 +296,17 @@ let is_value lc = match lc with | Lval _ -> true | Lmakeblock(_,_,_,args) when Array.is_empty args -> true + | Luint (UintVal _) -> true | _ -> false - + let get_value lc = match lc with | Lval v -> v - | Lmakeblock(_,_,tag,args) when Array.is_empty args -> + | Lmakeblock(_,_,tag,args) when Array.is_empty args -> Nativevalues.mk_int tag + | Luint (UintVal i) -> Nativevalues.mk_uint i | _ -> raise Not_found - + let make_args start _end = Array.init (start - _end + 1) (fun i -> Lrel (Anonymous, start - i)) @@ -517,8 +519,11 @@ let rec lambda_of_constr env sigma c = | Construct _ -> lambda_of_app env sigma c empty_args | Proj (p, c) -> - let kn = Projection.constant p in - mkLapp (Lproj (get_const_prefix !global_env kn, kn)) [|lambda_of_constr env sigma c|] + let pb = lookup_projection p !global_env in + (** FIXME: handle mutual records *) + let ind = (pb.proj_ind, 0) in + let prefix = get_mind_prefix !global_env (fst ind) in + mkLapp (Lproj (prefix, ind, pb.proj_arg)) [|lambda_of_constr env sigma c|] | Case(ci,t,a,branches) -> let (mind,i as ind) = ci.ci_ind in @@ -570,6 +575,7 @@ let rec lambda_of_constr env sigma c = Lfix(rec_init, (names, ltypes, lbodies)) | CoFix(init,(names,type_bodies,rec_bodies)) -> + let rec_bodies = Array.map2 (Reduction.eta_expand !global_env) rec_bodies type_bodies in let ltypes = lambda_of_args env sigma 0 type_bodies in Renv.push_rels env names; let lbodies = lambda_of_args env sigma 0 rec_bodies in diff --git a/kernel/nativelambda.mli b/kernel/nativelambda.mli index 9a1e19b3c..26bfeb7e0 100644 --- a/kernel/nativelambda.mli +++ b/kernel/nativelambda.mli @@ -9,7 +9,7 @@ (************************************************************************) open Names open Constr -open Pre_env +open Environ open Nativeinstr (** This file defines the lambda code generation phase of the native compiler *) diff --git a/kernel/nativelibrary.ml b/kernel/nativelibrary.ml index c69cf722b..8bff43632 100644 --- a/kernel/nativelibrary.ml +++ b/kernel/nativelibrary.ml @@ -10,7 +10,6 @@ open Names open Declarations -open Environ open Mod_subst open Modops open Nativecode @@ -32,7 +31,7 @@ and translate_field prefix mp env acc (l,x) = (if !Flags.debug then let msg = Printf.sprintf "Compiling constant %s..." (Constant.to_string con) in Feedback.msg_debug (Pp.str msg)); - compile_constant_field (pre_env env) prefix con acc cb + compile_constant_field env prefix con acc cb | SFBmind mb -> (if !Flags.debug then let id = mb.mind_packets.(0).mind_typename in diff --git a/kernel/nativevalues.ml b/kernel/nativevalues.ml index cfcb0a485..da4413a0a 100644 --- a/kernel/nativevalues.ml +++ b/kernel/nativevalues.ml @@ -64,7 +64,7 @@ type atom = | Aprod of Name.t * t * (t -> t) | Ameta of metavariable * t | Aevar of Evar.t * t * t array - | Aproj of Constant.t * accumulator + | Aproj of (inductive * int) * accumulator let accumulate_tag = 0 diff --git a/kernel/nativevalues.mli b/kernel/nativevalues.mli index 4a58a3c7d..649853f06 100644 --- a/kernel/nativevalues.mli +++ b/kernel/nativevalues.mli @@ -54,7 +54,7 @@ type atom = | Aprod of Name.t * t * (t -> t) | Ameta of metavariable * t | Aevar of Evar.t * t (* type *) * t array (* arguments *) - | Aproj of Constant.t * accumulator + | Aproj of (inductive * int) * accumulator (* Constructors *) @@ -71,7 +71,7 @@ val mk_fix_accu : rec_pos -> int -> t array -> t array -> t val mk_cofix_accu : int -> t array -> t array -> t val mk_meta_accu : metavariable -> t val mk_evar_accu : Evar.t -> t -> t array -> t -val mk_proj_accu : Constant.t -> accumulator -> t +val mk_proj_accu : (inductive * int) -> accumulator -> t val upd_cofix : t -> t -> unit val force_cofix : t -> t val mk_const : tag -> t diff --git a/kernel/pre_env.ml b/kernel/pre_env.ml deleted file mode 100644 index 8ebe48e20..000000000 --- a/kernel/pre_env.ml +++ /dev/null @@ -1,213 +0,0 @@ -(************************************************************************) -(* * 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) *) -(************************************************************************) - -(* Created by Benjamin Grégoire out of environ.ml for better - modularity in the design of the bytecode virtual evaluation - machine, Dec 2005 *) -(* Bug fix by Jean-Marc Notin *) - -(* This file defines the type of kernel environments *) - -open Util -open Names -open Declarations - -module NamedDecl = Context.Named.Declaration - -(* The type of environments. *) - -(* The key attached to each constant is used by the VM to retrieve previous *) -(* evaluations of the constant. It is essentially an index in the symbols table *) -(* used by the VM. *) -type key = int CEphemeron.key option ref - -(** Linking information for the native compiler. *) - -type link_info = - | Linked of string - | LinkedInteractive of string - | NotLinked - -type constant_key = constant_body * (link_info ref * key) - -type mind_key = mutual_inductive_body * link_info ref - -type globals = { - env_constants : constant_key Cmap_env.t; - env_inductives : mind_key Mindmap_env.t; - env_modules : module_body MPmap.t; - env_modtypes : module_type_body MPmap.t} - -type stratification = { - env_universes : UGraph.t; - env_engagement : engagement -} - -type val_kind = - | VKvalue of (Vmvalues.values * Id.Set.t) CEphemeron.key - | VKnone - -type lazy_val = val_kind ref - -let force_lazy_val vk = match !vk with -| VKnone -> None -| VKvalue v -> try Some (CEphemeron.get v) with CEphemeron.InvalidKey -> None - -let dummy_lazy_val () = ref VKnone -let build_lazy_val vk key = vk := VKvalue (CEphemeron.create key) - -type named_context_val = { - env_named_ctx : Context.Named.t; - env_named_map : (Context.Named.Declaration.t * lazy_val) Id.Map.t; -} - -type rel_context_val = { - env_rel_ctx : Context.Rel.t; - env_rel_map : (Context.Rel.Declaration.t * lazy_val) Range.t; -} - -type env = { - env_globals : globals; (* globals = constants + inductive types + modules + module-types *) - env_named_context : named_context_val; (* section variables *) - env_rel_context : rel_context_val; - env_nb_rel : int; - env_stratification : stratification; - env_typing_flags : typing_flags; - retroknowledge : Retroknowledge.retroknowledge; - indirect_pterms : Opaqueproof.opaquetab; -} - -let empty_named_context_val = { - env_named_ctx = []; - env_named_map = Id.Map.empty; -} - -let empty_rel_context_val = { - env_rel_ctx = []; - env_rel_map = Range.empty; -} - -let empty_env = { - env_globals = { - env_constants = Cmap_env.empty; - env_inductives = Mindmap_env.empty; - env_modules = MPmap.empty; - env_modtypes = MPmap.empty}; - env_named_context = empty_named_context_val; - env_rel_context = empty_rel_context_val; - env_nb_rel = 0; - env_stratification = { - env_universes = UGraph.initial_universes; - env_engagement = PredicativeSet }; - env_typing_flags = Declareops.safe_flags Conv_oracle.empty; - retroknowledge = Retroknowledge.initial_retroknowledge; - indirect_pterms = Opaqueproof.empty_opaquetab } - - -(* Rel context *) - -let nb_rel env = env.env_nb_rel - -let push_rel_context_val d ctx = { - env_rel_ctx = Context.Rel.add d ctx.env_rel_ctx; - env_rel_map = Range.cons (d, ref VKnone) ctx.env_rel_map; -} - -let match_rel_context_val ctx = match ctx.env_rel_ctx with -| [] -> None -| decl :: rem -> - let (_, lval) = Range.hd ctx.env_rel_map in - let ctx = { env_rel_ctx = rem; env_rel_map = Range.tl ctx.env_rel_map } in - Some (decl, lval, ctx) - -let push_rel d env = - { env with - env_rel_context = push_rel_context_val d env.env_rel_context; - env_nb_rel = env.env_nb_rel + 1 } - -let lookup_rel n env = - try fst (Range.get env.env_rel_context.env_rel_map (n - 1)) - with Invalid_argument _ -> raise Not_found - -let lookup_rel_val n env = - try snd (Range.get env.env_rel_context.env_rel_map (n - 1)) - with Invalid_argument _ -> raise Not_found - -let rel_skipn n ctx = { - env_rel_ctx = Util.List.skipn n ctx.env_rel_ctx; - env_rel_map = Range.skipn n ctx.env_rel_map; -} - -let env_of_rel n env = - { env with - env_rel_context = rel_skipn n env.env_rel_context; - env_nb_rel = env.env_nb_rel - n - } - -(* Named context *) - -let push_named_context_val_val d rval ctxt = -(* assert (not (Id.Map.mem (NamedDecl.get_id d) ctxt.env_named_map)); *) - { - env_named_ctx = Context.Named.add d ctxt.env_named_ctx; - env_named_map = Id.Map.add (NamedDecl.get_id d) (d, rval) ctxt.env_named_map; - } - -let push_named_context_val d ctxt = - push_named_context_val_val d (ref VKnone) ctxt - -let match_named_context_val c = match c.env_named_ctx with -| [] -> None -| decl :: ctx -> - let (_, v) = Id.Map.find (NamedDecl.get_id decl) c.env_named_map in - let map = Id.Map.remove (NamedDecl.get_id decl) c.env_named_map in - let cval = { env_named_ctx = ctx; env_named_map = map } in - Some (decl, v, cval) - -let map_named_val f ctxt = - let open Context.Named.Declaration in - let fold accu d = - let d' = map_constr f d in - let accu = - if d == d' then accu - else Id.Map.modify (get_id d) (fun _ (_, v) -> (d', v)) accu - in - (accu, d') - in - let map, ctx = List.fold_left_map fold ctxt.env_named_map ctxt.env_named_ctx in - if map == ctxt.env_named_map then ctxt - else { env_named_ctx = ctx; env_named_map = map } - -let push_named d env = - {env with env_named_context = push_named_context_val d env.env_named_context} - -let lookup_named id env = - fst (Id.Map.find id env.env_named_context.env_named_map) - -let lookup_named_val id env = - snd(Id.Map.find id env.env_named_context.env_named_map) - -(* Warning all the names should be different *) -let env_of_named id env = env - -(* Global constants *) - -let lookup_constant_key kn env = - Cmap_env.find kn env.env_globals.env_constants - -let lookup_constant kn env = - fst (Cmap_env.find kn env.env_globals.env_constants) - -(* Mutual Inductives *) -let lookup_mind kn env = - fst (Mindmap_env.find kn env.env_globals.env_inductives) - -let lookup_mind_key kn env = - Mindmap_env.find kn env.env_globals.env_inductives diff --git a/kernel/pre_env.mli b/kernel/pre_env.mli deleted file mode 100644 index b05074814..000000000 --- a/kernel/pre_env.mli +++ /dev/null @@ -1,108 +0,0 @@ -(************************************************************************) -(* * The Coq Proof Assistant / The Coq Development Team *) -(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) -(* <O___,, * (see CREDITS file for the list of authors) *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(* * (see LICENSE file for the text of the license) *) -(************************************************************************) - -open Names -open Constr -open Declarations - -(** The type of environments. *) - -type link_info = - | Linked of string - | LinkedInteractive of string - | NotLinked - -type key = int CEphemeron.key option ref - -type constant_key = constant_body * (link_info ref * key) - -type mind_key = mutual_inductive_body * link_info ref - -type globals = { - env_constants : constant_key Cmap_env.t; - env_inductives : mind_key Mindmap_env.t; - env_modules : module_body MPmap.t; - env_modtypes : module_type_body MPmap.t} - -type stratification = { - env_universes : UGraph.t; - env_engagement : engagement -} - -type lazy_val - -val force_lazy_val : lazy_val -> (Vmvalues.values * Id.Set.t) option -val dummy_lazy_val : unit -> lazy_val -val build_lazy_val : lazy_val -> (Vmvalues.values * Id.Set.t) -> unit - -type named_context_val = private { - env_named_ctx : Context.Named.t; - env_named_map : (Context.Named.Declaration.t * lazy_val) Id.Map.t; -} - -type rel_context_val = private { - env_rel_ctx : Context.Rel.t; - env_rel_map : (Context.Rel.Declaration.t * lazy_val) Range.t; -} - -type env = { - env_globals : globals; - env_named_context : named_context_val; - env_rel_context : rel_context_val; - env_nb_rel : int; - env_stratification : stratification; - env_typing_flags : typing_flags; - retroknowledge : Retroknowledge.retroknowledge; - indirect_pterms : Opaqueproof.opaquetab; -} - -val empty_named_context_val : named_context_val - -val empty_env : env - -(** Rel context *) - -val empty_rel_context_val : rel_context_val -val push_rel_context_val : - Context.Rel.Declaration.t -> rel_context_val -> rel_context_val -val match_rel_context_val : - rel_context_val -> (Context.Rel.Declaration.t * lazy_val * rel_context_val) option - -val nb_rel : env -> int -val push_rel : Context.Rel.Declaration.t -> env -> env -val lookup_rel : int -> env -> Context.Rel.Declaration.t -val lookup_rel_val : int -> env -> lazy_val -val env_of_rel : int -> env -> env - -(** Named context *) - -val push_named_context_val : - Context.Named.Declaration.t -> named_context_val -> named_context_val -val push_named_context_val_val : - Context.Named.Declaration.t -> lazy_val -> named_context_val -> named_context_val -val match_named_context_val : - named_context_val -> (Context.Named.Declaration.t * lazy_val * named_context_val) option -val map_named_val : - (constr -> constr) -> named_context_val -> named_context_val - -val push_named : Context.Named.Declaration.t -> env -> env -val lookup_named : Id.t -> env -> Context.Named.Declaration.t -val lookup_named_val : Id.t -> env -> lazy_val -val env_of_named : Id.t -> env -> env - -(** Global constants *) - - -val lookup_constant_key : Constant.t -> env -> constant_key -val lookup_constant : Constant.t -> env -> constant_body - -(** Mutual Inductives *) -val lookup_mind_key : MutInd.t -> env -> mind_key -val lookup_mind : MutInd.t -> env -> mutual_inductive_body diff --git a/kernel/reduction.ml b/kernel/reduction.ml index 81fbd4f5e..f4af31386 100644 --- a/kernel/reduction.ml +++ b/kernel/reduction.ml @@ -84,7 +84,7 @@ let map_lift (l : lift) (v : fconstr array) = match v with | [|c0; c1|] -> [|(l, c0); (l, c1)|] | [|c0; c1; c2|] -> [|(l, c0); (l, c1); (l, c2)|] | [|c0; c1; c2; c3|] -> [|(l, c0); (l, c1); (l, c2); (l, c3)|] -| v -> CArray.Fun1.map (fun l t -> (l, t)) l v +| v -> Array.Fun1.map (fun l t -> (l, t)) l v let pure_stack lfts stk = let rec pure_rec lfts stk = @@ -648,25 +648,24 @@ let check_leq univs u u' = let check_sort_cmp_universes env pb s0 s1 univs = let open Sorts in - match (s0,s1) with + if not (type_in_type env) then + match (s0,s1) with | (Prop c1, Prop c2) when is_cumul pb -> begin match c1, c2 with - | Null, _ | _, Pos -> () (* Prop <= Set *) - | _ -> raise NotConvertible + | Null, _ | _, Pos -> () (* Prop <= Set *) + | _ -> raise NotConvertible end | (Prop c1, Prop c2) -> if c1 != c2 then raise NotConvertible | (Prop c1, Type u) -> - if not (type_in_type env) then - let u0 = univ_of_sort s0 in - (match pb with - | CUMUL -> check_leq univs u0 u - | CONV -> check_eq univs u0 u) + let u0 = univ_of_sort s0 in + (match pb with + | CUMUL -> check_leq univs u0 u + | CONV -> check_eq univs u0 u) | (Type u, Prop c) -> raise NotConvertible | (Type u1, Type u2) -> - if not (type_in_type env) then - (match pb with - | CUMUL -> check_leq univs u1 u2 - | CONV -> check_eq univs u1 u2) + (match pb with + | CUMUL -> check_leq univs u1 u2 + | CONV -> check_eq univs u1 u2) let checked_sort_cmp_universes env pb s0 s1 univs = check_sort_cmp_universes env pb s0 s1 univs; univs @@ -699,25 +698,25 @@ let infer_leq (univs, cstrs as cuniv) u u' = let infer_cmp_universes env pb s0 s1 univs = let open Sorts in - match (s0,s1) with + if type_in_type env then univs + else + match (s0,s1) with | (Prop c1, Prop c2) when is_cumul pb -> begin match c1, c2 with - | Null, _ | _, Pos -> univs (* Prop <= Set *) - | _ -> raise NotConvertible + | Null, _ | _, Pos -> univs (* Prop <= Set *) + | _ -> raise NotConvertible end | (Prop c1, Prop c2) -> if c1 == c2 then univs else raise NotConvertible | (Prop c1, Type u) -> let u0 = univ_of_sort s0 in - (match pb with - | CUMUL -> infer_leq univs u0 u - | CONV -> infer_eq univs u0 u) + (match pb with + | CUMUL -> infer_leq univs u0 u + | CONV -> infer_eq univs u0 u) | (Type u, Prop c) -> raise NotConvertible | (Type u1, Type u2) -> - if not (type_in_type env) then - (match pb with - | CUMUL -> infer_leq univs u1 u2 - | CONV -> infer_eq univs u1 u2) - else univs + (match pb with + | CUMUL -> infer_leq univs u1 u2 + | CONV -> infer_eq univs u1 u2) let infer_convert_instances ~flex u u' (univs,cstrs) = let cstrs' = @@ -789,24 +788,6 @@ let infer_conv_leq ?(l2r=false) ?(evars=fun _ -> None) ?(ts=full_transparent_sta env univs t1 t2 = infer_conv_universes CUMUL l2r evars ts env univs t1 t2 -(* This reference avoids always having to link C code with the kernel *) -let vm_conv = ref (fun cv_pb env -> - gen_conv cv_pb env ~evars:((fun _->None), universes env)) - -let warn_bytecode_compiler_failed = - let open Pp in - CWarnings.create ~name:"bytecode-compiler-failed" ~category:"bytecode-compiler" - (fun () -> strbrk "Bytecode compiler failed, " ++ - strbrk "falling back to standard conversion") - -let set_vm_conv (f:conv_pb -> types kernel_conversion_function) = vm_conv := f -let vm_conv cv_pb env t1 t2 = - try - !vm_conv cv_pb env t1 t2 - with Not_found | Invalid_argument _ -> - warn_bytecode_compiler_failed (); - gen_conv cv_pb env t1 t2 - let default_conv cv_pb ?(l2r=false) env t1 t2 = gen_conv cv_pb env t1 t2 @@ -880,6 +861,17 @@ let dest_prod env = in decrec env Context.Rel.empty +let dest_lam env = + let rec decrec env m c = + let t = whd_all env c in + match kind t with + | Lambda (n,a,c0) -> + let d = LocalAssum (n,a) in + decrec (push_rel d env) (Context.Rel.add d m) c0 + | _ -> m,t + in + decrec env Context.Rel.empty + (* The same but preserving lets in the context, not internal ones. *) let dest_prod_assum env = let rec prodec_rec env l ty = @@ -925,3 +917,12 @@ let is_arity env c = let _ = dest_arity env c in true with NotArity -> false + +let eta_expand env t ty = + let ctxt, codom = dest_prod env ty in + let ctxt',t = dest_lam env t in + let d = Context.Rel.nhyps ctxt - Context.Rel.nhyps ctxt' in + let eta_args = List.rev_map mkRel (List.interval 1 d) in + let t = Term.applistc (Vars.lift d t) eta_args in + let t = Term.it_mkLambda_or_LetIn t (List.firstn d ctxt) in + Term.it_mkLambda_or_LetIn t ctxt' diff --git a/kernel/reduction.mli b/kernel/reduction.mli index 14e4270b7..e53ab6aef 100644 --- a/kernel/reduction.mli +++ b/kernel/reduction.mli @@ -87,10 +87,6 @@ val infer_conv_leq : ?l2r:bool -> ?evars:(existential->constr option) -> val generic_conv : conv_pb -> l2r:bool -> (existential->constr option) -> Names.transparent_state -> (constr,'a) generic_conversion_function -(** option for conversion *) -val set_vm_conv : (conv_pb -> types kernel_conversion_function) -> unit -val vm_conv : conv_pb -> types kernel_conversion_function - val default_conv : conv_pb -> ?l2r:bool -> types kernel_conversion_function val default_conv_leq : ?l2r:bool -> types kernel_conversion_function @@ -122,6 +118,7 @@ val betazeta_appvect : int -> constr -> constr array -> constr val dest_prod : env -> types -> Context.Rel.t * types val dest_prod_assum : env -> types -> Context.Rel.t * types +val dest_lam : env -> types -> Context.Rel.t * constr val dest_lam_assum : env -> types -> Context.Rel.t * types exception NotArity @@ -129,4 +126,4 @@ exception NotArity val dest_arity : env -> types -> Term.arity (* raises NotArity if not an arity *) val is_arity : env -> types -> bool -val warn_bytecode_compiler_failed : ?loc:Loc.t -> unit -> unit +val eta_expand : env -> constr -> types -> constr diff --git a/kernel/retroknowledge.mli b/kernel/retroknowledge.mli index 0334e7a9e..281c37b85 100644 --- a/kernel/retroknowledge.mli +++ b/kernel/retroknowledge.mli @@ -134,7 +134,7 @@ val get_native_before_match_info : retroknowledge -> entry -> Nativeinstr.lambda -> Nativeinstr.lambda -(** the following functions are solely used in Pre_env and Environ to implement +(** the following functions are solely used in Environ and Safe_typing to implement the functions register and unregister (and mem) of Environ *) val add_field : retroknowledge -> field -> entry -> retroknowledge val mem : retroknowledge -> field -> bool diff --git a/kernel/safe_typing.ml b/kernel/safe_typing.ml index de2a890fb..12c82e20d 100644 --- a/kernel/safe_typing.ml +++ b/kernel/safe_typing.ml @@ -59,6 +59,7 @@ etc. *) +open CErrors open Util open Names open Declarations @@ -914,16 +915,12 @@ let register field value by_clause senv = but it is meant to become a replacement for environ.register *) let register_inline kn senv = let open Environ in - let open Pre_env in if not (evaluable_constant kn senv.env) then CErrors.user_err Pp.(str "Register inline: an evaluable constant is expected"); - let env = pre_env senv.env in + let env = senv.env in let (cb,r) = Cmap_env.find kn env.env_globals.env_constants in let cb = {cb with const_inline_code = true} in - let new_constants = Cmap_env.add kn (cb,r) env.env_globals.env_constants in - let new_globals = { env.env_globals with env_constants = new_constants } in - let env = { env with env_globals = new_globals } in - { senv with env = env_of_pre_env env } + let env = add_constant kn cb env in { senv with env} let add_constraints c = add_constraints @@ -953,3 +950,125 @@ Would this be correct with respect to undo's and stuff ? let set_strategy e k l = { e with env = (Environ.set_oracle e.env (Conv_oracle.set_strategy (Environ.oracle e.env) k l)) } + +(** Register retroknowledge hooks *) + +open Retroknowledge + +(* the Environ.register function synchronizes the proactive and reactive + retroknowledge. *) +let dispatch = + + (* subfunction used for static decompilation of int31 (after a vm_compute, + see pretyping/vnorm.ml for more information) *) + let constr_of_int31 = + let nth_digit_plus_one i n = (* calculates the nth (starting with 0) + digit of i and adds 1 to it + (nth_digit_plus_one 1 3 = 2) *) + if Int.equal (i land (1 lsl n)) 0 then + 1 + else + 2 + in + fun ind -> fun digit_ind -> fun tag -> + let array_of_int i = + Array.init 31 (fun n -> Constr.mkConstruct + (digit_ind, nth_digit_plus_one i (30-n))) + in + (* We check that no bit above 31 is set to one. This assertion used to + fail in the VM, and led to conversion tests failing at Qed. *) + assert (Int.equal (tag lsr 31) 0); + Constr.mkApp(Constr.mkConstruct(ind, 1), array_of_int tag) + in + + (* subfunction which dispatches the compiling information of an + int31 operation which has a specific vm instruction (associates + it to the name of the coq definition in the reactive retroknowledge) *) + let int31_op n op prim kn = + { empty_reactive_info with + vm_compiling = Some (Clambda.compile_prim n op kn); + native_compiling = Some (Nativelambda.compile_prim prim (Univ.out_punivs kn)); + } + in + +fun rk value field -> + (* subfunction which shortens the (very common) dispatch of operations *) + let int31_op_from_const n op prim = + match Constr.kind value with + | Constr.Const kn -> int31_op n op prim kn + | _ -> anomaly ~label:"Environ.register" (Pp.str "should be a constant.") + in + let int31_binop_from_const op prim = int31_op_from_const 2 op prim in + let int31_unop_from_const op prim = int31_op_from_const 1 op prim in + match field with + | KInt31 (grp, Int31Type) -> + let int31bit = + (* invariant : the type of bits is registered, otherwise the function + would raise Not_found. The invariant is enforced in safe_typing.ml *) + match field with + | KInt31 (grp, Int31Type) -> Retroknowledge.find rk (KInt31 (grp,Int31Bits)) + | _ -> anomaly ~label:"Environ.register" + (Pp.str "add_int31_decompilation_from_type called with an abnormal field.") + in + let i31bit_type = + match Constr.kind int31bit with + | Constr.Ind (i31bit_type,_) -> i31bit_type + | _ -> anomaly ~label:"Environ.register" + (Pp.str "Int31Bits should be an inductive type.") + in + let int31_decompilation = + match Constr.kind value with + | Constr.Ind (i31t,_) -> + constr_of_int31 i31t i31bit_type + | _ -> anomaly ~label:"Environ.register" + (Pp.str "should be an inductive type.") + in + { empty_reactive_info with + vm_decompile_const = Some int31_decompilation; + vm_before_match = Some Clambda.int31_escape_before_match; + native_before_match = Some (Nativelambda.before_match_int31 i31bit_type); + } + | KInt31 (_, Int31Constructor) -> + { empty_reactive_info with + vm_constant_static = Some Clambda.compile_structured_int31; + vm_constant_dynamic = Some Clambda.dynamic_int31_compilation; + native_constant_static = Some Nativelambda.compile_static_int31; + native_constant_dynamic = Some Nativelambda.compile_dynamic_int31; + } + | KInt31 (_, Int31Plus) -> int31_binop_from_const Cbytecodes.Kaddint31 + CPrimitives.Int31add + | KInt31 (_, Int31PlusC) -> int31_binop_from_const Cbytecodes.Kaddcint31 + CPrimitives.Int31addc + | KInt31 (_, Int31PlusCarryC) -> int31_binop_from_const Cbytecodes.Kaddcarrycint31 + CPrimitives.Int31addcarryc + | KInt31 (_, Int31Minus) -> int31_binop_from_const Cbytecodes.Ksubint31 + CPrimitives.Int31sub + | KInt31 (_, Int31MinusC) -> int31_binop_from_const Cbytecodes.Ksubcint31 + CPrimitives.Int31subc + | KInt31 (_, Int31MinusCarryC) -> int31_binop_from_const + Cbytecodes.Ksubcarrycint31 CPrimitives.Int31subcarryc + | KInt31 (_, Int31Times) -> int31_binop_from_const Cbytecodes.Kmulint31 + CPrimitives.Int31mul + | KInt31 (_, Int31TimesC) -> int31_binop_from_const Cbytecodes.Kmulcint31 + CPrimitives.Int31mulc + | KInt31 (_, Int31Div21) -> int31_op_from_const 3 Cbytecodes.Kdiv21int31 + CPrimitives.Int31div21 + | KInt31 (_, Int31Diveucl) -> int31_binop_from_const Cbytecodes.Kdivint31 + CPrimitives.Int31diveucl + | KInt31 (_, Int31AddMulDiv) -> int31_op_from_const 3 Cbytecodes.Kaddmuldivint31 + CPrimitives.Int31addmuldiv + | KInt31 (_, Int31Compare) -> int31_binop_from_const Cbytecodes.Kcompareint31 + CPrimitives.Int31compare + | KInt31 (_, Int31Head0) -> int31_unop_from_const Cbytecodes.Khead0int31 + CPrimitives.Int31head0 + | KInt31 (_, Int31Tail0) -> int31_unop_from_const Cbytecodes.Ktail0int31 + CPrimitives.Int31tail0 + | KInt31 (_, Int31Lor) -> int31_binop_from_const Cbytecodes.Klorint31 + CPrimitives.Int31lor + | KInt31 (_, Int31Land) -> int31_binop_from_const Cbytecodes.Klandint31 + CPrimitives.Int31land + | KInt31 (_, Int31Lxor) -> int31_binop_from_const Cbytecodes.Klxorint31 + CPrimitives.Int31lxor + | _ -> empty_reactive_info + +let _ = Hook.set Retroknowledge.dispatch_hook dispatch diff --git a/kernel/term.ml b/kernel/term.ml index 403ed881c..b44e038e9 100644 --- a/kernel/term.ml +++ b/kernel/term.ml @@ -15,219 +15,17 @@ open Names open Vars open Constr -(**********************************************************************) -(** Redeclaration of types from module Constr *) -(**********************************************************************) - +(* Deprecated *) type contents = Sorts.contents = Pos | Null - -type sorts = Sorts.t = - | Prop of contents (** Prop and Set *) - | Type of Univ.Universe.t (** Type *) +[@@ocaml.deprecated "Alias for Sorts.contents"] type sorts_family = Sorts.family = InProp | InSet | InType +[@@ocaml.deprecated "Alias for Sorts.family"] -type constr = Constr.t -(** Alias types, for compatibility. *) - -type types = Constr.t -(** Same as [constr], for documentation purposes. *) - -type existential_key = Evar.t -type existential = Constr.existential - -type metavariable = Constr.metavariable - -type case_style = Constr.case_style = - LetStyle | IfStyle | LetPatternStyle | MatchStyle | RegularStyle - -type case_printing = Constr.case_printing = - { ind_tags : bool list; cstr_tags : bool list array; style : case_style } - -type case_info = Constr.case_info = - { ci_ind : inductive; - ci_npar : int; - ci_cstr_ndecls : int array; - ci_cstr_nargs : int array; - ci_pp_info : case_printing - } - -type cast_kind = Constr.cast_kind = - VMcast | NATIVEcast | DEFAULTcast | REVERTcast - -(********************************************************************) -(* Constructions as implemented *) -(********************************************************************) - -type rec_declaration = Constr.rec_declaration -type fixpoint = Constr.fixpoint -type cofixpoint = Constr.cofixpoint -type 'constr pexistential = 'constr Constr.pexistential -type ('constr, 'types) prec_declaration = - ('constr, 'types) Constr.prec_declaration -type ('constr, 'types) pfixpoint = ('constr, 'types) Constr.pfixpoint -type ('constr, 'types) pcofixpoint = ('constr, 'types) Constr.pcofixpoint -type 'a puniverses = 'a Univ.puniverses - -(** Simply type aliases *) -type pconstant = Constant.t puniverses -type pinductive = inductive puniverses -type pconstructor = constructor puniverses - -type ('constr, 'types, 'sort, 'univs) kind_of_term = - ('constr, 'types, 'sort, 'univs) Constr.kind_of_term = - | Rel of int - | Var of Id.t - | Meta of metavariable - | 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 - | App of 'constr * 'constr array - | Const of (Constant.t * 'univs) - | Ind of (inductive * 'univs) - | Construct of (constructor * 'univs) - | Case of case_info * 'constr * 'constr * 'constr array - | Fix of ('constr, 'types) pfixpoint - | CoFix of ('constr, 'types) pcofixpoint - | Proj of projection * 'constr - -type values = Vmvalues.values - -(**********************************************************************) -(** Redeclaration of functions from module Constr *) -(**********************************************************************) - -let set_sort = Sorts.set -let prop_sort = Sorts.prop -let type1_sort = Sorts.type1 -let sorts_ord = Sorts.compare -let is_prop_sort = Sorts.is_prop -let family_of_sort = Sorts.family -let univ_of_sort = Sorts.univ_of_sort -let sort_of_univ = Sorts.sort_of_univ - -(** {6 Term constructors. } *) - -let mkRel = Constr.mkRel -let mkVar = Constr.mkVar -let mkMeta = Constr.mkMeta -let mkEvar = Constr.mkEvar -let mkSort = Constr.mkSort -let mkProp = Constr.mkProp -let mkSet = Constr.mkSet -let mkType = Constr.mkType -let mkCast = Constr.mkCast -let mkProd = Constr.mkProd -let mkLambda = Constr.mkLambda -let mkLetIn = Constr.mkLetIn -let mkApp = Constr.mkApp -let mkConst = Constr.mkConst -let mkProj = Constr.mkProj -let mkInd = Constr.mkInd -let mkConstruct = Constr.mkConstruct -let mkConstU = Constr.mkConstU -let mkIndU = Constr.mkIndU -let mkConstructU = Constr.mkConstructU -let mkConstructUi = Constr.mkConstructUi -let mkCase = Constr.mkCase -let mkFix = Constr.mkFix -let mkCoFix = Constr.mkCoFix - -(**********************************************************************) -(** Aliases of functions from module Constr *) -(**********************************************************************) - -let eq_constr = Constr.equal -let eq_constr_univs = Constr.eq_constr_univs -let leq_constr_univs = Constr.leq_constr_univs -let eq_constr_nounivs = Constr.eq_constr_nounivs - -let kind_of_term = Constr.kind -let compare = Constr.compare -let constr_ord = compare -let fold_constr = Constr.fold -let map_puniverses = Constr.map_puniverses -let map_constr = Constr.map -let map_constr_with_binders = Constr.map_with_binders -let iter_constr = Constr.iter -let iter_constr_with_binders = Constr.iter_with_binders -let compare_constr = Constr.compare_head -let hash_constr = Constr.hash -let hcons_sorts = Sorts.hcons -let hcons_constr = Constr.hcons -let hcons_types = Constr.hcons - -(**********************************************************************) -(** HERE BEGINS THE INTERESTING STUFF *) -(**********************************************************************) - -(**********************************************************************) -(* Non primitive term destructors *) -(**********************************************************************) - -exception DestKO = DestKO -(* Destructs a de Bruijn index *) -let destRel = destRel -let destMeta = destRel -let isMeta = isMeta -let destVar = destVar -let isSort = isSort -let destSort = destSort -let isprop = isprop -let is_Prop = is_Prop -let is_Set = is_Set -let is_Type = is_Type -let is_small = is_small -let iskind = iskind -let isEvar = isEvar -let isEvar_or_Meta = isEvar_or_Meta -let destCast = destCast -let isCast = isCast -let isRel = isRel -let isRelN = isRelN -let isVar = isVar -let isVarId = isVarId -let isInd = isInd -let destProd = destProd -let isProd = isProd -let destLambda = destLambda -let isLambda = isLambda -let destLetIn = destLetIn -let isLetIn = isLetIn -let destApp = destApp -let destApplication = destApp -let isApp = isApp -let destConst = destConst -let isConst = isConst -let destEvar = destEvar -let destInd = destInd -let destConstruct = destConstruct -let isConstruct = isConstruct -let destCase = destCase -let isCase = isCase -let isProj = isProj -let destProj = destProj -let destFix = destFix -let isFix = isFix -let destCoFix = destCoFix -let isCoFix = isCoFix - -(******************************************************************) -(* Flattening and unflattening of embedded applications and casts *) -(******************************************************************) - -let decompose_app c = - match kind_of_term c with - | App (f,cl) -> (f, Array.to_list cl) - | _ -> (c,[]) - -let decompose_appvect c = - match kind_of_term c with - | App (f,cl) -> (f, cl) - | _ -> (c,[||]) +type sorts = Sorts.t = + | Prop of Sorts.contents (** Prop and Set *) + | Type of Univ.Universe.t (** Type *) +[@@ocaml.deprecated "Alias for Sorts.t"] (****************************************************************************) (* Functions for dealing with constr terms *) @@ -321,7 +119,7 @@ let rec to_lambda n prod = if Int.equal n 0 then prod else - match kind_of_term prod with + match kind prod with | Prod (na,ty,bd) -> mkLambda (na,ty,to_lambda (n-1) bd) | Cast (c,_,_) -> to_lambda n c | _ -> user_err ~hdr:"to_lambda" (mt ()) @@ -330,7 +128,7 @@ let rec to_prod n lam = if Int.equal n 0 then lam else - match kind_of_term lam with + match kind lam with | Lambda (na,ty,bd) -> mkProd (na,ty,to_prod (n-1) bd) | Cast (c,_,_) -> to_prod n c | _ -> user_err ~hdr:"to_prod" (mt ()) @@ -342,7 +140,7 @@ let it_mkLambda_or_LetIn = List.fold_left (fun c d -> mkLambda_or_LetIn d c) let lambda_applist c l = let rec app subst c l = - match kind_of_term c, l with + match kind c, l with | Lambda(_,_,c), arg::l -> app (arg::subst) c l | _, [] -> substl subst c | _ -> anomaly (Pp.str "Not enough lambda's.") in @@ -355,7 +153,7 @@ let lambda_applist_assum n c l = if Int.equal n 0 then if l == [] then substl subst t else anomaly (Pp.str "Too many arguments.") - else match kind_of_term t, l with + else match kind t, l with | Lambda(_,_,c), arg::l -> app (n-1) (arg::subst) c l | LetIn(_,b,_,c), _ -> app (n-1) (substl subst b::subst) c l | _, [] -> anomaly (Pp.str "Not enough arguments.") @@ -367,7 +165,7 @@ let lambda_appvect_assum n c v = lambda_applist_assum n c (Array.to_list v) (* prod_applist T [ a1 ; ... ; an ] -> (T a1 ... an) *) let prod_applist c l = let rec app subst c l = - match kind_of_term c, l with + match kind c, l with | Prod(_,_,c), arg::l -> app (arg::subst) c l | _, [] -> substl subst c | _ -> anomaly (Pp.str "Not enough prod's.") in @@ -381,7 +179,7 @@ let prod_applist_assum n c l = if Int.equal n 0 then if l == [] then substl subst t else anomaly (Pp.str "Too many arguments.") - else match kind_of_term t, l with + else match kind t, l with | Prod(_,_,c), arg::l -> app (n-1) (arg::subst) c l | LetIn(_,b,_,c), _ -> app (n-1) (substl subst b::subst) c l | _, [] -> anomaly (Pp.str "Not enough arguments.") @@ -397,7 +195,7 @@ let prod_appvect_assum n c v = prod_applist_assum n c (Array.to_list v) (* Transforms a product term (x1:T1)..(xn:Tn)T into the pair ([(xn,Tn);...;(x1,T1)],T), where T is not a product *) let decompose_prod = - let rec prodec_rec l c = match kind_of_term c with + let rec prodec_rec l c = match kind c with | Prod (x,t,c) -> prodec_rec ((x,t)::l) c | Cast (c,_,_) -> prodec_rec l c | _ -> l,c @@ -407,7 +205,7 @@ let decompose_prod = (* Transforms a lambda term [x1:T1]..[xn:Tn]T into the pair ([(xn,Tn);...;(x1,T1)],T), where T is not a lambda *) let decompose_lam = - let rec lamdec_rec l c = match kind_of_term c with + let rec lamdec_rec l c = match kind c with | Lambda (x,t,c) -> lamdec_rec ((x,t)::l) c | Cast (c,_,_) -> lamdec_rec l c | _ -> l,c @@ -420,7 +218,7 @@ let decompose_prod_n n = if n < 0 then user_err (str "decompose_prod_n: integer parameter must be positive"); let rec prodec_rec l n c = if Int.equal n 0 then l,c - else match kind_of_term c with + else match kind c with | Prod (x,t,c) -> prodec_rec ((x,t)::l) (n-1) c | Cast (c,_,_) -> prodec_rec l n c | _ -> user_err (str "decompose_prod_n: not enough products") @@ -433,7 +231,7 @@ let decompose_lam_n n = if n < 0 then user_err (str "decompose_lam_n: integer parameter must be positive"); let rec lamdec_rec l n c = if Int.equal n 0 then l,c - else match kind_of_term c with + else match kind c with | Lambda (x,t,c) -> lamdec_rec ((x,t)::l) (n-1) c | Cast (c,_,_) -> lamdec_rec l n c | _ -> user_err (str "decompose_lam_n: not enough abstractions") @@ -445,7 +243,7 @@ let decompose_lam_n n = let decompose_prod_assum = let open Context.Rel.Declaration in let rec prodec_rec l c = - match kind_of_term c with + match kind c with | Prod (x,t,c) -> prodec_rec (Context.Rel.add (LocalAssum (x,t)) l) c | LetIn (x,b,t,c) -> prodec_rec (Context.Rel.add (LocalDef (x,b,t)) l) c | Cast (c,_,_) -> prodec_rec l c @@ -458,7 +256,7 @@ let decompose_prod_assum = let decompose_lam_assum = let rec lamdec_rec l c = let open Context.Rel.Declaration in - match kind_of_term c with + match kind c with | Lambda (x,t,c) -> lamdec_rec (Context.Rel.add (LocalAssum (x,t)) l) c | LetIn (x,b,t,c) -> lamdec_rec (Context.Rel.add (LocalDef (x,b,t)) l) c | Cast (c,_,_) -> lamdec_rec l c @@ -477,7 +275,7 @@ let decompose_prod_n_assum n = if Int.equal n 0 then l,c else let open Context.Rel.Declaration in - match kind_of_term c with + match kind c with | Prod (x,t,c) -> prodec_rec (Context.Rel.add (LocalAssum (x,t)) l) (n-1) c | LetIn (x,b,t,c) -> prodec_rec (Context.Rel.add (LocalDef (x,b,t)) l) (n-1) c | Cast (c,_,_) -> prodec_rec l n c @@ -498,7 +296,7 @@ let decompose_lam_n_assum n = if Int.equal n 0 then l,c else let open Context.Rel.Declaration in - match kind_of_term c with + match kind c with | Lambda (x,t,c) -> lamdec_rec (Context.Rel.add (LocalAssum (x,t)) l) (n-1) c | LetIn (x,b,t,c) -> lamdec_rec (Context.Rel.add (LocalDef (x,b,t)) l) n c | Cast (c,_,_) -> lamdec_rec l n c @@ -514,7 +312,7 @@ let decompose_lam_n_decls n = if Int.equal n 0 then l,c else let open Context.Rel.Declaration in - match kind_of_term c with + match kind c with | Lambda (x,t,c) -> lamdec_rec (Context.Rel.add (LocalAssum (x,t)) l) (n-1) c | LetIn (x,b,t,c) -> lamdec_rec (Context.Rel.add (LocalDef (x,b,t)) l) (n-1) c | Cast (c,_,_) -> lamdec_rec l n c @@ -541,12 +339,12 @@ let strip_lam_n n t = snd (decompose_lam_n n t) Such a term can canonically be seen as the pair of a context of types and of a sort *) -type arity = Context.Rel.t * sorts +type arity = Context.Rel.t * Sorts.t let destArity = let open Context.Rel.Declaration in let rec prodec_rec l c = - match kind_of_term c with + match kind c with | Prod (x,t,c) -> prodec_rec (LocalAssum (x,t) :: l) c | LetIn (x,b,t,c) -> prodec_rec (LocalDef (x,b,t) :: l) c | Cast (c,_,_) -> prodec_rec l c @@ -558,7 +356,7 @@ let destArity = let mkArity (sign,s) = it_mkProd_or_LetIn (mkSort s) sign let rec isArity c = - match kind_of_term c with + match kind c with | Prod (_,_,c) -> isArity c | LetIn (_,b,_,c) -> isArity (subst1 b c) | Cast (c,_,_) -> isArity c @@ -569,13 +367,13 @@ let rec isArity c = (* Experimental, used in Presburger contrib *) type ('constr, 'types) kind_of_type = - | SortType of sorts + | SortType of Sorts.t | CastType of 'types * 'types | ProdType of Name.t * 'types * 'types | LetInType of Name.t * 'constr * 'types * 'types | AtomicType of 'constr * 'constr array -let kind_of_type t = match kind_of_term t with +let kind_of_type t = match kind t with | Sort s -> SortType s | Cast (c,_,t) -> CastType (c, t) | Prod (na,t,c) -> ProdType (na, t, c) diff --git a/kernel/term.mli b/kernel/term.mli index 7cb3b662d..f651d1a58 100644 --- a/kernel/term.mli +++ b/kernel/term.mli @@ -11,166 +11,6 @@ open Names open Constr -(** {5 Redeclaration of types from module Constr and Sorts} - - This reexports constructors of inductive types defined in module [Constr], - for compatibility purposes. Refer to this module for further info. - -*) - -exception DestKO -[@@ocaml.deprecated "Alias for [Constr.DestKO]"] - -(** {5 Simple term case analysis. } *) -val isRel : constr -> bool -[@@ocaml.deprecated "Alias for [Constr.isRel]"] -val isRelN : int -> constr -> bool -[@@ocaml.deprecated "Alias for [Constr.isRelN]"] -val isVar : constr -> bool -[@@ocaml.deprecated "Alias for [Constr.isVar]"] -val isVarId : Id.t -> constr -> bool -[@@ocaml.deprecated "Alias for [Constr.isVarId]"] -val isInd : constr -> bool -[@@ocaml.deprecated "Alias for [Constr.isInd]"] -val isEvar : constr -> bool -[@@ocaml.deprecated "Alias for [Constr.isEvar]"] -val isMeta : constr -> bool -[@@ocaml.deprecated "Alias for [Constr.isMeta]"] -val isEvar_or_Meta : constr -> bool -[@@ocaml.deprecated "Alias for [Constr.isEvar_or_Meta]"] -val isSort : constr -> bool -[@@ocaml.deprecated "Alias for [Constr.isSort]"] -val isCast : constr -> bool -[@@ocaml.deprecated "Alias for [Constr.isCast]"] -val isApp : constr -> bool -[@@ocaml.deprecated "Alias for [Constr.isApp]"] -val isLambda : constr -> bool -[@@ocaml.deprecated "Alias for [Constr.isLambda]"] -val isLetIn : constr -> bool -[@@ocaml.deprecated "Alias for [Constr.isletIn]"] -val isProd : constr -> bool -[@@ocaml.deprecated "Alias for [Constr.isProp]"] -val isConst : constr -> bool -[@@ocaml.deprecated "Alias for [Constr.isConst]"] -val isConstruct : constr -> bool -[@@ocaml.deprecated "Alias for [Constr.isConstruct]"] -val isFix : constr -> bool -[@@ocaml.deprecated "Alias for [Constr.isFix]"] -val isCoFix : constr -> bool -[@@ocaml.deprecated "Alias for [Constr.isCoFix]"] -val isCase : constr -> bool -[@@ocaml.deprecated "Alias for [Constr.isCase]"] -val isProj : constr -> bool -[@@ocaml.deprecated "Alias for [Constr.isProj]"] - -val is_Prop : constr -> bool -[@@ocaml.deprecated "Alias for [Constr.is_Prop]"] -val is_Set : constr -> bool -[@@ocaml.deprecated "Alias for [Constr.is_Set]"] -val isprop : constr -> bool -[@@ocaml.deprecated "Alias for [Constr.isprop]"] -val is_Type : constr -> bool -[@@ocaml.deprecated "Alias for [Constr.is_Type]"] -val iskind : constr -> bool -[@@ocaml.deprecated "Alias for [Constr.is_kind]"] -val is_small : Sorts.t -> bool -[@@ocaml.deprecated "Alias for [Constr.is_small]"] - - -(** {5 Term destructors } *) -(** Destructor operations are partial functions and - @raise DestKO if the term has not the expected form. *) - -(** Destructs a de Bruijn index *) -val destRel : constr -> int -[@@ocaml.deprecated "Alias for [Constr.destRel]"] - -(** Destructs an existential variable *) -val destMeta : constr -> metavariable -[@@ocaml.deprecated "Alias for [Constr.destMeta]"] - -(** Destructs a variable *) -val destVar : constr -> Id.t -[@@ocaml.deprecated "Alias for [Constr.destVar]"] - -(** Destructs a sort. [is_Prop] recognizes the sort {% \textsf{%}Prop{% }%}, whether - [isprop] recognizes both {% \textsf{%}Prop{% }%} and {% \textsf{%}Set{% }%}. *) -val destSort : constr -> Sorts.t -[@@ocaml.deprecated "Alias for [Constr.destSort]"] - -(** Destructs a casted term *) -val destCast : constr -> constr * cast_kind * constr -[@@ocaml.deprecated "Alias for [Constr.destCast]"] - -(** Destructs the product {% $ %}(x:t_1)t_2{% $ %} *) -val destProd : types -> Name.t * types * types -[@@ocaml.deprecated "Alias for [Constr.destProd]"] - -(** Destructs the abstraction {% $ %}[x:t_1]t_2{% $ %} *) -val destLambda : constr -> Name.t * types * constr -[@@ocaml.deprecated "Alias for [Constr.destLambda]"] - -(** Destructs the let {% $ %}[x:=b:t_1]t_2{% $ %} *) -val destLetIn : constr -> Name.t * constr * types * constr -[@@ocaml.deprecated "Alias for [Constr.destLetIn]"] - -(** Destructs an application *) -val destApp : constr -> constr * constr array -[@@ocaml.deprecated "Alias for [Constr.destApp]"] - -(** Obsolete synonym of destApp *) -val destApplication : constr -> constr * constr array -[@@ocaml.deprecated "Alias for [Constr.destApplication]"] - -(** Decompose any term as an applicative term; the list of args can be empty *) -val decompose_app : constr -> constr * constr list -[@@ocaml.deprecated "Alias for [Constr.decompose_app]"] - -(** Same as [decompose_app], but returns an array. *) -val decompose_appvect : constr -> constr * constr array -[@@ocaml.deprecated "Alias for [Constr.decompose_appvect]"] - -(** Destructs a constant *) -val destConst : constr -> Constant.t Univ.puniverses -[@@ocaml.deprecated "Alias for [Constr.destConst]"] - -(** Destructs an existential variable *) -val destEvar : constr -> existential -[@@ocaml.deprecated "Alias for [Constr.destEvar]"] - -(** Destructs a (co)inductive type *) -val destInd : constr -> inductive Univ.puniverses -[@@ocaml.deprecated "Alias for [Constr.destInd]"] - -(** Destructs a constructor *) -val destConstruct : constr -> constructor Univ.puniverses -[@@ocaml.deprecated "Alias for [Constr.destConstruct]"] - -(** Destructs a [match c as x in I args return P with ... | -Ci(...yij...) => ti | ... end] (or [let (..y1i..) := c as x in I args -return P in t1], or [if c then t1 else t2]) -@return [(info,c,fun args x => P,[|...|fun yij => ti| ...|])] -where [info] is pretty-printing information *) -val destCase : constr -> case_info * constr * constr * constr array -[@@ocaml.deprecated "Alias for [Constr.destCase]"] - -(** Destructs a projection *) -val destProj : constr -> projection * constr -[@@ocaml.deprecated "Alias for [Constr.destProj]"] - -(** Destructs the {% $ %}i{% $ %}th function of the block - [Fixpoint f{_ 1} ctx{_ 1} = b{_ 1} - with f{_ 2} ctx{_ 2} = b{_ 2} - ... - with f{_ n} ctx{_ n} = b{_ n}], - where the length of the {% $ %}j{% $ %}th context is {% $ %}ij{% $ %}. -*) -val destFix : constr -> fixpoint -[@@ocaml.deprecated "Alias for [Constr.destFix]"] - -val destCoFix : constr -> cofixpoint -[@@ocaml.deprecated "Alias for [Constr.destCoFix]"] - (** {5 Derived constructors} *) (** non-dependent product [t1 -> t2], an alias for @@ -349,242 +189,14 @@ type ('constr, 'types) kind_of_type = val kind_of_type : types -> (constr, types) kind_of_type -(** {5 Redeclaration of stuff from module [Sorts]} *) - -val set_sort : Sorts.t -[@@ocaml.deprecated "Alias for Sorts.set"] - -val prop_sort : Sorts.t -[@@ocaml.deprecated "Alias for Sorts.prop"] - -val type1_sort : Sorts.t -[@@ocaml.deprecated "Alias for Sorts.type1"] - -val sorts_ord : Sorts.t -> Sorts.t -> int -[@@ocaml.deprecated "Alias for Sorts.compare"] - -val is_prop_sort : Sorts.t -> bool -[@@ocaml.deprecated "Alias for Sorts.is_prop"] - -val family_of_sort : Sorts.t -> Sorts.family -[@@ocaml.deprecated "Alias for Sorts.family"] - -(** {5 Redeclaration of stuff from module [Constr]} - - See module [Constr] for further info. *) - -(** {6 Term constructors. } *) - -val mkRel : int -> constr -[@@ocaml.deprecated "Alias for Constr.mkRel"] -val mkVar : Id.t -> constr -[@@ocaml.deprecated "Alias for Constr.mkVar"] -val mkMeta : metavariable -> constr -[@@ocaml.deprecated "Alias for Constr.mkMeta"] -val mkEvar : existential -> constr -[@@ocaml.deprecated "Alias for Constr.mkEvar"] -val mkSort : Sorts.t -> types -[@@ocaml.deprecated "Alias for Constr.mkSort"] -val mkProp : types -[@@ocaml.deprecated "Alias for Constr.mkProp"] -val mkSet : types -[@@ocaml.deprecated "Alias for Constr.mkSet"] -val mkType : Univ.Universe.t -> types -[@@ocaml.deprecated "Alias for Constr.mkType"] -val mkCast : constr * cast_kind * constr -> constr -[@@ocaml.deprecated "Alias for Constr"] -val mkProd : Name.t * types * types -> types -[@@ocaml.deprecated "Alias for Constr"] -val mkLambda : Name.t * types * constr -> constr -[@@ocaml.deprecated "Alias for Constr"] -val mkLetIn : Name.t * constr * types * constr -> constr -[@@ocaml.deprecated "Alias for Constr"] -val mkApp : constr * constr array -> constr -[@@ocaml.deprecated "Alias for Constr"] -val mkConst : Constant.t -> constr -[@@ocaml.deprecated "Alias for Constr"] -val mkProj : projection * constr -> constr -[@@ocaml.deprecated "Alias for Constr"] -val mkInd : inductive -> constr -[@@ocaml.deprecated "Alias for Constr"] -val mkConstruct : constructor -> constr -[@@ocaml.deprecated "Alias for Constr"] -val mkConstU : Constant.t Univ.puniverses -> constr -[@@ocaml.deprecated "Alias for Constr"] -val mkIndU : inductive Univ.puniverses -> constr -[@@ocaml.deprecated "Alias for Constr"] -val mkConstructU : constructor Univ.puniverses -> constr -[@@ocaml.deprecated "Alias for Constr"] -val mkConstructUi : (pinductive * int) -> constr -[@@ocaml.deprecated "Alias for Constr"] -val mkCase : case_info * constr * constr * constr array -> constr -[@@ocaml.deprecated "Alias for Constr.mkCase"] -val mkFix : fixpoint -> constr -[@@ocaml.deprecated "Alias for Constr.mkFix"] -val mkCoFix : cofixpoint -> constr -[@@ocaml.deprecated "Alias for Constr.mkCoFix"] - -(** {6 Aliases} *) - -val eq_constr : constr -> constr -> bool -[@@ocaml.deprecated "Alias for Constr.equal"] - -(** [eq_constr_univs u a b] is [true] if [a] equals [b] modulo alpha, casts, - application grouping and the universe constraints in [u]. *) -val eq_constr_univs : constr UGraph.check_function -[@@ocaml.deprecated "Alias for Constr.eq_constr_univs"] - -(** [leq_constr_univs u a b] is [true] if [a] is convertible to [b] modulo - alpha, casts, application grouping and the universe constraints in [u]. *) -val leq_constr_univs : constr UGraph.check_function -[@@ocaml.deprecated "Alias for Constr.leq_constr_univs"] - -(** [eq_constr_univs a b] [true, c] if [a] equals [b] modulo alpha, casts, - application grouping and ignoring universe instances. *) -val eq_constr_nounivs : constr -> constr -> bool -[@@ocaml.deprecated "Alias for Constr.qe_constr_nounivs"] - -val kind_of_term : constr -> (constr, types, Sorts.t, Univ.Instance.t) kind_of_term -[@@ocaml.deprecated "Alias for Constr.kind"] - -val compare : constr -> constr -> int -[@@ocaml.deprecated "Alias for [Constr.compare]"] - -val constr_ord : constr -> constr -> int -[@@ocaml.deprecated "Alias for [Term.compare]"] - -val fold_constr : ('a -> constr -> 'a) -> 'a -> constr -> 'a -[@@ocaml.deprecated "Alias for [Constr.fold]"] - -val map_constr : (constr -> constr) -> constr -> constr -[@@ocaml.deprecated "Alias for [Constr.map]"] - -val map_constr_with_binders : - ('a -> 'a) -> ('a -> constr -> constr) -> 'a -> constr -> constr -[@@ocaml.deprecated "Alias for [Constr.map_with_binders]"] - -val map_puniverses : ('a -> 'b) -> 'a Univ.puniverses -> 'b Univ.puniverses -[@@ocaml.deprecated "Alias for [Constr.map_puniverses]"] -val univ_of_sort : Sorts.t -> Univ.Universe.t -[@@ocaml.deprecated "Alias for [Sorts.univ_of_sort]"] -val sort_of_univ : Univ.Universe.t -> Sorts.t -[@@ocaml.deprecated "Alias for [Sorts.sort_of_univ]"] - -val iter_constr : (constr -> unit) -> constr -> unit -[@@ocaml.deprecated "Alias for [Constr.iter]"] - -val iter_constr_with_binders : - ('a -> 'a) -> ('a -> constr -> unit) -> 'a -> constr -> unit -[@@ocaml.deprecated "Alias for [Constr.iter_with_binders]"] - -val compare_constr : (int -> constr -> constr -> bool) -> int -> constr -> constr -> bool -[@@ocaml.deprecated "Alias for [Constr.compare_head]"] - -type constr = Constr.constr -[@@ocaml.deprecated "Alias for Constr.t"] - -(** Alias types, for compatibility. *) - -type types = Constr.types -[@@ocaml.deprecated "Alias for Constr.types"] - +(* Deprecated *) type contents = Sorts.contents = Pos | Null [@@ocaml.deprecated "Alias for Sorts.contents"] +type sorts_family = Sorts.family = InProp | InSet | InType +[@@ocaml.deprecated "Alias for Sorts.family"] + type sorts = Sorts.t = | Prop of Sorts.contents (** Prop and Set *) | Type of Univ.Universe.t (** Type *) [@@ocaml.deprecated "Alias for Sorts.t"] - -type sorts_family = Sorts.family = InProp | InSet | InType -[@@ocaml.deprecated "Alias for Sorts.family"] - -type 'a puniverses = 'a Univ.puniverses -[@@ocaml.deprecated "Alias for Constr.puniverses"] - -(** Simply type aliases *) -type pconstant = Constr.pconstant -[@@ocaml.deprecated "Alias for Constr.pconstant"] -type pinductive = Constr.pinductive -[@@ocaml.deprecated "Alias for Constr.pinductive"] -type pconstructor = Constr.pconstructor -[@@ocaml.deprecated "Alias for Constr.pconstructor"] -type existential_key = Evar.t -[@@ocaml.deprecated "Alias for Evar.t"] -type existential = Constr.existential -[@@ocaml.deprecated "Alias for Constr.existential"] -type metavariable = Constr.metavariable -[@@ocaml.deprecated "Alias for Constr.metavariable"] - -type case_style = Constr.case_style = - LetStyle | IfStyle | LetPatternStyle | MatchStyle | RegularStyle -[@@ocaml.deprecated "Alias for Constr.case_style"] - -type case_printing = Constr.case_printing = - { ind_tags : bool list; cstr_tags : bool list array; style : Constr.case_style } -[@@ocaml.deprecated "Alias for Constr.case_printing"] - -type case_info = Constr.case_info = - { ci_ind : inductive; - ci_npar : int; - ci_cstr_ndecls : int array; - ci_cstr_nargs : int array; - ci_pp_info : Constr.case_printing - } -[@@ocaml.deprecated "Alias for Constr.case_info"] - -type cast_kind = Constr.cast_kind = - VMcast | NATIVEcast | DEFAULTcast | REVERTcast -[@@ocaml.deprecated "Alias for Constr.cast_kind"] - -type rec_declaration = Constr.rec_declaration -[@@ocaml.deprecated "Alias for Constr.rec_declaration"] -type fixpoint = Constr.fixpoint -[@@ocaml.deprecated "Alias for Constr.fixpoint"] -type cofixpoint = Constr.cofixpoint -[@@ocaml.deprecated "Alias for Constr.cofixpoint"] -type 'constr pexistential = 'constr Constr.pexistential -[@@ocaml.deprecated "Alias for Constr.pexistential"] -type ('constr, 'types) prec_declaration = - ('constr, 'types) Constr.prec_declaration -[@@ocaml.deprecated "Alias for Constr.prec_declaration"] -type ('constr, 'types) pfixpoint = ('constr, 'types) Constr.pfixpoint -[@@ocaml.deprecated "Alias for Constr.pfixpoint"] -type ('constr, 'types) pcofixpoint = ('constr, 'types) Constr.pcofixpoint -[@@ocaml.deprecated "Alias for Constr.pcofixpoint"] - -type ('constr, 'types, 'sort, 'univs) kind_of_term = - ('constr, 'types, 'sort, 'univs) Constr.kind_of_term = - | Rel of int - | Var of Id.t - | Meta of Constr.metavariable - | Evar of 'constr Constr.pexistential - | Sort of 'sort - | Cast of 'constr * Constr.cast_kind * 'types - | Prod of Name.t * 'types * 'types - | Lambda of Name.t * 'types * 'constr - | LetIn of Name.t * 'constr * 'types * 'constr - | App of 'constr * 'constr array - | Const of (Constant.t * 'univs) - | Ind of (inductive * 'univs) - | Construct of (constructor * 'univs) - | Case of Constr.case_info * 'constr * 'constr * 'constr array - | Fix of ('constr, 'types) Constr.pfixpoint - | CoFix of ('constr, 'types) Constr.pcofixpoint - | Proj of projection * 'constr -[@@ocaml.deprecated "Alias for Constr.kind_of_term"] - -type values = Vmvalues.values -[@@ocaml.deprecated "Alias for Vmvalues.values"] - -val hash_constr : Constr.constr -> int -[@@ocaml.deprecated "Alias for Constr.hash"] - -val hcons_sorts : Sorts.t -> Sorts.t -[@@ocaml.deprecated "Alias for [Sorts.hcons]"] - -val hcons_constr : Constr.constr -> Constr.constr -[@@ocaml.deprecated "Alias for [Constr.hcons]"] - -val hcons_types : Constr.types -> Constr.types -[@@ocaml.deprecated "Alias for [Constr.hcons]"] diff --git a/kernel/term_typing.ml b/kernel/term_typing.ml index e621a61c7..db1109e75 100644 --- a/kernel/term_typing.ml +++ b/kernel/term_typing.ml @@ -250,7 +250,7 @@ let infer_declaration (type a) ~(trust : a trust) env (dcl : a constant_entry) = { Cooking.cook_body = Undef nl; cook_type = t; - cook_proj = None; + cook_proj = false; cook_universes = univs; cook_inline = false; cook_context = ctx; @@ -291,7 +291,7 @@ let infer_declaration (type a) ~(trust : a trust) env (dcl : a constant_entry) = { Cooking.cook_body = def; cook_type = typ; - cook_proj = None; + cook_proj = false; cook_universes = Monomorphic_const univs; cook_inline = c.const_entry_inline_code; cook_context = c.const_entry_secctx; @@ -343,7 +343,7 @@ let infer_declaration (type a) ~(trust : a trust) env (dcl : a constant_entry) = { Cooking.cook_body = def; cook_type = typ; - cook_proj = None; + cook_proj = false; cook_universes = univs; cook_inline = c.const_entry_inline_code; cook_context = c.const_entry_secctx; @@ -370,7 +370,7 @@ let infer_declaration (type a) ~(trust : a trust) env (dcl : a constant_entry) = { Cooking.cook_body = Def (Mod_subst.from_val (Constr.hcons term)); cook_type = typ; - cook_proj = Some pb; + cook_proj = true; cook_universes = univs; cook_inline = false; cook_context = None; @@ -458,30 +458,8 @@ let build_constant_declaration kn env result = check declared inferred) lc) in let univs = result.cook_universes in let tps = - let res = - match result.cook_proj with - | None -> compile_constant_body env univs def - | Some pb -> - (* The compilation of primitive projections is a bit tricky, because - they refer to themselves (the body of p looks like fun c => - Proj(p,c)). We break the cycle by building an ad-hoc compilation - environment. A cleaner solution would be that kernel projections are - simply Proj(i,c) with i an int and c a constr, but we would have to - get rid of the compatibility layer. *) - let cb = - { const_hyps = hyps; - const_body = def; - const_type = typ; - const_proj = result.cook_proj; - const_body_code = None; - const_universes = univs; - const_inline_code = result.cook_inline; - const_typing_flags = Environ.typing_flags env; - } - in - let env = add_constant kn cb env in - compile_constant_body env univs def - in Option.map Cemitcodes.from_val res + let res = Cbytegen.compile_constant_body ~fail_on_error:false env univs def in + Option.map Cemitcodes.from_val res in { const_hyps = hyps; const_body = def; diff --git a/kernel/typeops.ml b/kernel/typeops.ml index be4c0e1ec..325d5cecd 100644 --- a/kernel/typeops.ml +++ b/kernel/typeops.ml @@ -221,7 +221,7 @@ let check_cast env c ct k expected_type = try match k with | VMcast -> - vm_conv CUMUL env ct expected_type + Vconv.vm_conv CUMUL env ct expected_type | DEFAULTcast -> default_conv ~l2r:false CUMUL env ct expected_type | REVERTcast -> @@ -528,13 +528,3 @@ 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 type_of_projection_constant env (p,u) = - let cst = Projection.constant p in - let cb = lookup_constant cst env in - match cb.const_proj with - | Some pb -> - if Declareops.constant_is_polymorphic cb then - Vars.subst_instance_constr u pb.proj_type - else pb.proj_type - | None -> raise (Invalid_argument "type_of_projection: not a projection") diff --git a/kernel/typeops.mli b/kernel/typeops.mli index bff40b017..546f2d2b4 100644 --- a/kernel/typeops.mli +++ b/kernel/typeops.mli @@ -60,7 +60,7 @@ val judge_of_constant : env -> pconstant -> unsafe_judgment (** {6 type of an applied projection } *) -val judge_of_projection : env -> Names.projection -> unsafe_judgment -> unsafe_judgment +val judge_of_projection : env -> Projection.t -> unsafe_judgment -> unsafe_judgment (** {6 Type of application. } *) val judge_of_apply : @@ -100,8 +100,6 @@ val judge_of_case : env -> case_info -> unsafe_judgment -> unsafe_judgment -> unsafe_judgment array -> unsafe_judgment -val type_of_projection_constant : env -> Names.projection puniverses -> types - val type_of_constant_in : env -> pconstant -> types (** Check that hyps are included in env and fails with error otherwise *) diff --git a/kernel/uGraph.ml b/kernel/uGraph.ml index 5d1644614..4a9467de5 100644 --- a/kernel/uGraph.ml +++ b/kernel/uGraph.ml @@ -21,7 +21,7 @@ open Univ (* Revisions by Bruno Barras, Hugo Herbelin, Pierre Letouzey, Matthieu Sozeau, Pierre-Marie Pédrot, Jacques-Henri Jourdan *) -let error_inconsistency o u v (p:explanation option) = +let error_inconsistency o u v p = raise (UniverseInconsistency (o,Universe.make u,Universe.make v,p)) (* Universes are stratified by a partial ordering $\le$. @@ -503,7 +503,7 @@ let insert_edge strict ucan vcan g = let () = cleanup_universes g in raise e -let add_universe vlev strict g = +let add_universe_gen vlev g = try let _arcv = UMap.find vlev g.entries in raise AlreadyDeclared @@ -520,8 +520,14 @@ let add_universe vlev strict g = } in let entries = UMap.add vlev (Canonical v) g.entries in - let g = { entries; index = g.index - 1; n_nodes = g.n_nodes + 1; n_edges = g.n_edges } in - insert_edge strict (get_set_arc g) v g + { entries; index = g.index - 1; n_nodes = g.n_nodes + 1; n_edges = g.n_edges }, v + +let add_universe vlev strict g = + let g, v = add_universe_gen vlev g in + insert_edge strict (get_set_arc g) v g + +let add_universe_unconstrained vlev g = + fst (add_universe_gen vlev g) exception Found_explanation of explanation @@ -557,8 +563,7 @@ let get_explanation strict u v g = else match traverse strict u with Some exp -> exp | None -> assert false let get_explanation strict u v g = - if !Flags.univ_print then Some (get_explanation strict u v g) - else None + Some (lazy (get_explanation strict u v g)) (* To compare two nodes, we simply do a forward search. We implement two improvements: @@ -697,6 +702,9 @@ let enforce_univ_lt u v g = error_inconsistency Lt u v (get_explanation false v u g) let empty_universes = + { entries = UMap.empty; index = 0; n_nodes = 0; n_edges = 0 } + +let initial_universes = let set_arc = Canonical { univ = Level.set; ltle = LMap.empty; @@ -719,9 +727,6 @@ let empty_universes = let empty = { entries; index = (-2); n_nodes = 2; n_edges = 0 } in enforce_univ_lt Level.prop Level.set empty -(* Prop = Set is forbidden here. *) -let initial_universes = empty_universes - let is_initial_universes g = UMap.equal (==) g.entries initial_universes.entries let enforce_constraint cst g = @@ -768,18 +773,54 @@ let normalize_universes g = g.entries g let constraints_of_universes g = + let module UF = Unionfind.Make (LSet) (LMap) in + let uf = UF.create () in let constraints_of u v acc = match v with | Canonical {univ=u; ltle} -> UMap.fold (fun v strict acc-> let typ = if strict then Lt else Le in Constraint.add (u,typ,v) acc) ltle acc - | Equiv v -> Constraint.add (u,Eq,v) acc + | Equiv v -> UF.union u v uf; acc in - UMap.fold constraints_of g.entries Constraint.empty - -let constraints_of_universes g = - constraints_of_universes (normalize_universes g) + let csts = UMap.fold constraints_of g.entries Constraint.empty in + csts, UF.partition uf + +(* domain g.entries = kept + removed *) +let constraints_for ~kept g = + (* rmap: partial map from canonical universes to kept universes *) + let rmap, csts = LSet.fold (fun u (rmap,csts) -> + let arcu = repr g u in + if LSet.mem arcu.univ kept then + LMap.add arcu.univ arcu.univ rmap, enforce_eq_level u arcu.univ csts + else + match LMap.find arcu.univ rmap with + | v -> rmap, enforce_eq_level u v csts + | exception Not_found -> LMap.add arcu.univ u rmap, csts) + kept (LMap.empty,Constraint.empty) + in + let rec add_from u csts todo = match todo with + | [] -> csts + | (v,strict)::todo -> + let v = repr g v in + (match LMap.find v.univ rmap with + | v -> + let d = if strict then Lt else Le in + let csts = Constraint.add (u,d,v) csts in + add_from u csts todo + | exception Not_found -> + (* v is not equal to any kept universe *) + let todo = LMap.fold (fun v' strict' todo -> + (v',strict || strict') :: todo) + v.ltle todo + in + add_from u csts todo) + in + LSet.fold (fun u csts -> + let arc = repr g u in + LMap.fold (fun v strict csts -> add_from u csts [v,strict]) + arc.ltle csts) + kept csts (** [sort_universes g] builds a totally ordered universe graph. The output graph should imply the input graph (and the implication diff --git a/kernel/uGraph.mli b/kernel/uGraph.mli index d4fba63fb..e6dd629e4 100644 --- a/kernel/uGraph.mli +++ b/kernel/uGraph.mli @@ -49,17 +49,28 @@ exception AlreadyDeclared val add_universe : Level.t -> bool -> t -> t +(** Add a universe without (Prop,Set) <= u *) +val add_universe_unconstrained : Level.t -> t -> t + (** {6 Pretty-printing of universes. } *) val pr_universes : (Level.t -> Pp.t) -> t -> Pp.t (** The empty graph of universes *) val empty_universes : t -[@@ocaml.deprecated "Use UGraph.initial_universes"] val sort_universes : t -> t -val constraints_of_universes : t -> Constraint.t +(** [constraints_of_universes g] returns [csts] and [partition] where + [csts] are the non-Eq constraints and [partition] is the partition + of the universes into equivalence classes. *) +val constraints_of_universes : t -> Constraint.t * LSet.t list + +(** [constraints_for ~kept g] returns the constraints about the + universes [kept] in [g] up to transitivity. + + eg if [g] is [a <= b <= c] then [constraints_for ~kept:{a, c} g] is [a <= c]. *) +val constraints_for : kept:LSet.t -> t -> Constraint.t val check_subtype : AUContext.t check_function (** [check_subtype univ ctx1 ctx2] checks whether [ctx2] is an instance of diff --git a/kernel/univ.ml b/kernel/univ.ml index be21381b7..9782312ca 100644 --- a/kernel/univ.ml +++ b/kernel/univ.ml @@ -456,10 +456,10 @@ struct let super l = if is_small l then type1 else - List.smartmap (fun x -> Expr.successor x) l + List.Smart.map (fun x -> Expr.successor x) l let addn n l = - List.smartmap (fun x -> Expr.addn n x) l + List.Smart.map (fun x -> Expr.addn n x) l let rec merge_univs l1 l2 = match l1, l2 with @@ -490,39 +490,6 @@ struct in List.fold_right (fun a acc -> aux a acc) u [] - (** [max_var_pred p u] returns the maximum variable level in [u] satisfying - [p], -1 if not found *) - let rec max_var_pred p u = - let open Level in - match u with - | [] -> -1 - | (v, _) :: u -> - match var_index v with - | Some i when p i -> max i (max_var_pred p u) - | _ -> max_var_pred p u - - let rec remap_var u i j = - let open Level in - match u with - | [] -> [] - | (v, incr) :: u when var_index v = Some i -> - (Level.var j, incr) :: remap_var u i j - | _ :: u -> remap_var u i j - - let rec compact u max_var i = - if i >= max_var then (u,[]) else - let j = max_var_pred (fun j -> j < i) u in - if Int.equal i (j+1) then - let (u,s) = compact u max_var (i+1) in - (u, i :: s) - else - let (u,s) = compact (remap_var u i j) max_var (i+1) in - (u, j+1 :: s) - - let compact u = - let max_var = max_var_pred (fun _ -> true) u in - compact u max_var 0 - (* Returns the formal universe that is greater than the universes u and v. Used to type the products. *) let sup x y = merge_univs x y @@ -533,7 +500,7 @@ struct let for_all = List.for_all - let smartmap = List.smartmap + let smart_map = List.Smart.map let map = List.map end @@ -574,11 +541,11 @@ let constraint_type_ord c1 c2 = match c1, c2 with (* Universe inconsistency: error raised when trying to enforce a relation that would create a cycle in the graph of universes. *) -type univ_inconsistency = constraint_type * universe * universe * explanation option +type univ_inconsistency = constraint_type * universe * universe * explanation Lazy.t option exception UniverseInconsistency of univ_inconsistency -let error_inconsistency o u v (p:explanation option) = +let error_inconsistency o u v p = raise (UniverseInconsistency (o,make u,make v,p)) (* Constraints and sets of constraints. *) @@ -886,7 +853,7 @@ struct let length a = Array.length a let subst_fn fn t = - let t' = CArray.smartmap fn t in + let t' = CArray.Smart.map fn t in if t' == t then t else of_array t' let levels x = LSet.of_array x @@ -923,11 +890,11 @@ let subst_instance_level s l = | _ -> l let subst_instance_instance s i = - Array.smartmap (fun l -> subst_instance_level s l) i + Array.Smart.map (fun l -> subst_instance_level s l) i let subst_instance_universe s u = let f x = Universe.Expr.map (fun u -> subst_instance_level s u) x in - let u' = Universe.smartmap f u in + let u' = Universe.smart_map f u in if u == u' then u else Universe.sort u' @@ -1133,7 +1100,7 @@ let subst_univs_level_level subst l = let subst_univs_level_universe subst u = let f x = Universe.Expr.map (fun u -> subst_univs_level_level subst u) x in - let u' = Universe.smartmap f u in + let u' = Universe.smart_map f u in if u == u' then u else Universe.sort u' @@ -1208,6 +1175,20 @@ let abstract_cumulativity_info (univs, variance) = let subst, univs = abstract_universes univs in subst, (univs, variance) +let rec compact_univ s vars i u = + match u with + | [] -> (s, List.rev vars) + | (lvl, _) :: u -> + match Level.var_index lvl with + | Some k when not (LMap.mem lvl s) -> + let lvl' = Level.var i in + compact_univ (LMap.add lvl lvl' s) (k :: vars) (i+1) u + | _ -> compact_univ s vars i u + +let compact_univ u = + let (s, s') = compact_univ LMap.empty [] 0 u in + (subst_univs_level_universe s u, s') + (** Pretty-printing *) let pr_constraints prl = Constraint.pr prl @@ -1254,13 +1235,16 @@ let explain_universe_inconsistency prl (o,u,v,p) = | Eq -> str"=" | Lt -> str"<" | Le -> str"<=" in let reason = match p with - | None | Some [] -> mt() + | None -> mt() | Some p -> - str " because" ++ spc() ++ pr_uni v ++ + let p = Lazy.force p in + if p = [] then mt () + else + str " because" ++ spc() ++ pr_uni v ++ prlist (fun (r,v) -> spc() ++ pr_rel r ++ str" " ++ pr_uni v) - p ++ + p ++ (if Universe.equal (snd (List.last p)) u then mt() else - (spc() ++ str "= " ++ pr_uni u)) + (spc() ++ str "= " ++ pr_uni u)) in str "Cannot enforce" ++ spc() ++ pr_uni u ++ spc() ++ pr_rel o ++ spc() ++ pr_uni v ++ reason diff --git a/kernel/univ.mli b/kernel/univ.mli index 629d83fb8..b68bbdf35 100644 --- a/kernel/univ.mli +++ b/kernel/univ.mli @@ -128,12 +128,6 @@ sig val map : (Level.t * int -> 'a) -> t -> 'a list - (** [compact u] remaps local variables in [u] such that their indices become - consecutive. It returns the new universe and the mapping. - Example: compact [(Var 0, i); (Prop, 0); (Var 2; j))] = - [(Var 0,i); (Prop, 0); (Var 1; j)], [0; 2] - *) - val compact : t -> t * int list end type universe = Universe.t @@ -211,7 +205,7 @@ val enforce_leq_level : Level.t constraint_function Constraint.t... *) type explanation = (constraint_type * Universe.t) list -type univ_inconsistency = constraint_type * Universe.t * Universe.t * explanation option +type univ_inconsistency = constraint_type * Universe.t * Universe.t * explanation Lazy.t option exception UniverseInconsistency of univ_inconsistency @@ -504,6 +498,13 @@ val abstract_cumulativity_info : CumulativityInfo.t -> Instance.t * ACumulativit val make_abstract_instance : AUContext.t -> Instance.t +(** [compact_univ u] remaps local variables in [u] such that their indices become + consecutive. It returns the new universe and the mapping. + Example: compact_univ [(Var 0, i); (Prop, 0); (Var 2; j))] = + [(Var 0,i); (Prop, 0); (Var 1; j)], [0; 2] +*) +val compact_univ : Universe.t -> Universe.t * int list + (** {6 Pretty-printing of universes. } *) val pr_constraint_type : constraint_type -> Pp.t diff --git a/kernel/vconv.ml b/kernel/vconv.ml index f11803b67..4e4168922 100644 --- a/kernel/vconv.ml +++ b/kernel/vconv.ml @@ -6,9 +6,6 @@ open Vm open Vmvalues open Csymtable -let val_of_constr env c = - val_of_constr (pre_env env) c - (* Test la structure des piles *) let compare_zipper z1 z2 = @@ -185,8 +182,18 @@ and conv_arguments env ?from:(from=0) k args1 args2 cu = !rcu else raise NotConvertible +let warn_bytecode_compiler_failed = + let open Pp in + CWarnings.create ~name:"bytecode-compiler-failed" ~category:"bytecode-compiler" + (fun () -> strbrk "Bytecode compiler failed, " ++ + strbrk "falling back to standard conversion") + let vm_conv_gen cv_pb env univs t1 t2 = - try + if not Coq_config.bytecode_compiler then + Reduction.generic_conv cv_pb ~l2r:false (fun _ -> None) + full_transparent_state env univs t1 t2 + else + try let v1 = val_of_constr env t1 in let v2 = val_of_constr env t2 in fst (conv_val env cv_pb (nb_rel env) v1 v2 univs) @@ -204,5 +211,3 @@ let vm_conv cv_pb env t1 t2 = if not b then let univs = (univs, checked_universes) in let _ = vm_conv_gen cv_pb env univs t1 t2 in () - -let _ = if Coq_config.bytecode_compiler then Reduction.set_vm_conv vm_conv diff --git a/kernel/vconv.mli b/kernel/vconv.mli index 620f6b5e8..1a3184898 100644 --- a/kernel/vconv.mli +++ b/kernel/vconv.mli @@ -9,7 +9,6 @@ (************************************************************************) open Constr -open Environ open Reduction (********************************************************************** @@ -19,6 +18,3 @@ val vm_conv : conv_pb -> types kernel_conversion_function (** A conversion function parametrized by a universe comparator. Used outside of the kernel. *) val vm_conv_gen : conv_pb -> (types, 'a) generic_conversion_function - -(** Precompute a VM value from a constr *) -val val_of_constr : env -> constr -> Vmvalues.values diff --git a/kernel/vm.ml b/kernel/vm.ml index 14aeb732f..d7eedc226 100644 --- a/kernel/vm.ml +++ b/kernel/vm.ml @@ -42,8 +42,11 @@ external push_vstack : vstack -> int -> unit = "coq_push_vstack" (* interpreteur *) -external interprete : tcode -> values -> vm_env -> int -> values = - "coq_interprete_ml" +external coq_interprete : tcode -> values -> atom array -> vm_global -> vm_env -> int -> values = + "coq_interprete_byte" "coq_interprete_ml" + +let interprete code v env k = + coq_interprete code v (get_atom_rel ()) (Csymtable.get_global_data ()) env k (* Functions over arguments *) @@ -184,6 +187,6 @@ let apply_whd k whd = push_val v; interprete (cofix_upd_code to_up) (cofix_upd_val to_up) (cofix_upd_env to_up) 0 | Vatom_stk(a,stk) -> - apply_stack (val_of_atom a) stk v + apply_stack (val_of_atom a) stk v | Vuniv_level lvl -> assert false diff --git a/kernel/vmvalues.ml b/kernel/vmvalues.ml index 0e0cb4e58..8524c44d2 100644 --- a/kernel/vmvalues.ml +++ b/kernel/vmvalues.ml @@ -43,6 +43,7 @@ let fix_val v = (Obj.magic v : values) let cofix_upd_val v = (Obj.magic v : values) type vm_env +type vm_global let fun_env v = (Obj.magic v : vm_env) let fix_env v = (Obj.magic v : vm_env) let cofix_env v = (Obj.magic v : vm_env) @@ -51,19 +52,24 @@ type vstack = values array let fun_of_val v = (Obj.magic v : vfun) +let vm_global (v : values array) = (Obj.magic v : vm_global) + (*******************************************) (* Machine code *** ************************) (*******************************************) type tcode +(** A block whose first field is a C-allocated VM bytecode, encoded as char*. + This is compatible with the representation of the Coq VM closures. *) + +type tcode_array external mkAccuCode : int -> tcode = "coq_makeaccu" external offset_tcode : tcode -> int -> tcode = "coq_offset_tcode" -let tcode_of_obj v = ((Obj.obj v):tcode) -let fun_code v = tcode_of_obj (Obj.field (Obj.repr v) 0) -let fix_code v = fun_code v -let cofix_upd_code v = fun_code v +let fun_code v = (Obj.magic v : tcode) +let fix_code = fun_code +let cofix_upd_code = fun_code type vswitch = { @@ -252,6 +258,7 @@ external kind_of_closure : Obj.t -> int = "coq_kind_of_closure" external is_accumulate : tcode -> bool = "coq_is_accumulate_code" external int_tcode : tcode -> int -> int = "coq_int_tcode" external accumulate : unit -> tcode = "accumulate_code" +external set_bytecode_field : Obj.t -> int -> tcode -> unit = "coq_set_bytecode_field" let accumulate = accumulate () let whd_val : values -> whd = @@ -281,7 +288,7 @@ let whd_val : values -> whd = let obj_of_atom : atom -> Obj.t = fun a -> let res = Obj.new_block accu_tag 2 in - Obj.set_field res 0 (Obj.repr accumulate); + set_bytecode_field res 0 accumulate; Obj.set_field res 1 (Obj.repr a); res @@ -290,7 +297,6 @@ let rec obj_of_str_const str = match str with | Const_sort s -> obj_of_atom (Asort s) | Const_ind ind -> obj_of_atom (Aind ind) - | Const_proj p -> Obj.repr p | Const_b0 tag -> Obj.repr tag | Const_bn(tag, args) -> let len = Array.length args in @@ -348,6 +354,7 @@ let val_of_constant c = val_of_idkey (ConstKey c) let val_of_evar evk = val_of_idkey (EvarKey evk) external val_of_annot_switch : annot_switch -> values = "%identity" +external val_of_proj_name : Constant.t -> values = "%identity" (*************************************************) (** Operations manipulating data types ***********) @@ -367,17 +374,20 @@ external closure_arity : vfun -> int = "coq_closure_arity" external offset : Obj.t -> int = "coq_offset" external offset_closure : Obj.t -> int -> Obj.t = "coq_offset_closure" external offset_closure_fix : vfix -> int -> vm_env = "coq_offset_closure" +external tcode_array : tcode_array -> tcode array = "coq_tcode_array" let first o = (offset_closure o (offset o)) let first_fix (v:vfix) = (Obj.magic (first (Obj.repr v)) : vfix) let last o = (Obj.field o (Obj.size o - 1)) -let fix_types (v:vfix) = (Obj.magic (last (Obj.repr v)) : tcode array) -let cofix_types (v:vcofix) = (Obj.magic (last (Obj.repr v)) : tcode array) +let fix_types (v:vfix) = tcode_array (Obj.magic (last (Obj.repr v)) : tcode_array) +let cofix_types (v:vcofix) = tcode_array (Obj.magic (last (Obj.repr v)) : tcode_array) let current_fix vf = - (offset (Obj.repr vf) / 2) -let unsafe_fb_code fb i = tcode_of_obj (Obj.field (Obj.repr fb) (2 * i)) +let unsafe_fb_code fb i = + let off = (2 * i) * (Sys.word_size / 8) in + Obj.obj (Obj.add_offset (Obj.repr fb) (Int32.of_int off)) let unsafe_rec_arg fb i = int_tcode (unsafe_fb_code fb i) 1 @@ -407,13 +417,20 @@ let check_fix f1 f2 = else false else false -external atom_rel : unit -> atom array = "get_coq_atom_tbl" -external realloc_atom_rel : int -> unit = "realloc_coq_atom_tbl" +let atom_rel : atom array ref = + let init i = Aid (RelKey i) in + ref (Array.init 40 init) + +let get_atom_rel () = !atom_rel + +let realloc_atom_rel n = + let n = min (2 * n + 0x100) Sys.max_array_length in + let init i = Aid (RelKey i) in + let ans = Array.init n init in + atom_rel := ans let relaccu_tbl = - let atom_rel = atom_rel() in - let len = Array.length atom_rel in - for i = 0 to len - 1 do atom_rel.(i) <- Aid (RelKey i) done; + let len = Array.length !atom_rel in ref (Array.init len mkAccuCode) let relaccu_code i = @@ -422,9 +439,7 @@ let relaccu_code i = else begin realloc_atom_rel i; - let atom_rel = atom_rel () in - let nl = Array.length atom_rel in - for j = len to nl - 1 do atom_rel.(j) <- Aid(RelKey j) done; + let nl = Array.length !atom_rel in relaccu_tbl := Array.init nl (fun j -> if j < len then !relaccu_tbl.(j) else mkAccuCode j); @@ -434,13 +449,12 @@ let relaccu_code i = let mk_fix_body k ndef fb = let e = Obj.dup (Obj.repr fb) in for i = 0 to ndef - 1 do - Obj.set_field e (2 * i) (Obj.repr (relaccu_code (k + i))) + set_bytecode_field e (2 * i) (relaccu_code (k + i)) done; let fix_body i = - let jump_grabrec c = offset_tcode c 2 in - let c = jump_grabrec (unsafe_fb_code fb i) in + let c = offset_tcode (unsafe_fb_code fb i) 2 in let res = Obj.new_block Obj.closure_tag 2 in - Obj.set_field res 0 (Obj.repr c); + set_bytecode_field res 0 c; Obj.set_field res 1 (offset_closure e (2*i)); ((Obj.obj res) : vfun) in Array.init ndef fix_body @@ -478,7 +492,7 @@ let mk_cofix_body apply_varray k ndef vcf = Obj.set_field e 0 c; let atom = Obj.new_block cofix_tag 1 in let self = Obj.new_block accu_tag 2 in - Obj.set_field self 0 (Obj.repr accumulate); + set_bytecode_field self 0 accumulate; Obj.set_field self 1 (Obj.repr atom); apply_varray (Obj.obj e) [|Obj.obj self|] in Array.init ndef cofix_body diff --git a/kernel/vmvalues.mli b/kernel/vmvalues.mli index c6e342a96..08d05a038 100644 --- a/kernel/vmvalues.mli +++ b/kernel/vmvalues.mli @@ -15,6 +15,7 @@ open Cbytecodes type values type vm_env +type vm_global type vprod type vfun type vfix @@ -33,6 +34,8 @@ val fix_env : vfix -> vm_env val cofix_env : vcofix -> vm_env val cofix_upd_env : to_update -> vm_env +val vm_global : values array -> vm_global + (** Cast a value known to be a function, unsafe in general *) val fun_of_val : values -> vfun @@ -69,6 +72,9 @@ type atom = | Aind of inductive | Asort of Sorts.t +val get_atom_rel : unit -> atom array +(** Global table of rels *) + (** Zippers *) type zipper = @@ -106,6 +112,7 @@ val val_of_proj : Constant.t -> values -> values val val_of_atom : atom -> values external val_of_annot_switch : annot_switch -> values = "%identity" +external val_of_proj_name : Constant.t -> values = "%identity" (** Destructors *) diff --git a/lib/aux_file.ml b/lib/aux_file.ml index 7d9c528e7..0f9476605 100644 --- a/lib/aux_file.ml +++ b/lib/aux_file.ml @@ -55,7 +55,7 @@ let record_in_aux_at ?loc key v = match loc with | Some loc -> let i, j = Loc.unloc loc in Printf.fprintf oc "%d %d %s %S\n" i j key v - | None -> Printf.fprintf oc "--- %s %S\n" key v + | None -> Printf.fprintf oc "0 0 %s %S\n" key v ) !oc let current_loc : Loc.t option ref = ref None diff --git a/lib/cWarnings.ml b/lib/cWarnings.ml index 92c86eaea..fda25a0a6 100644 --- a/lib/cWarnings.ml +++ b/lib/cWarnings.ml @@ -22,11 +22,8 @@ type t = { let warnings : (string, t) Hashtbl.t = Hashtbl.create 97 let categories : (string, string list) Hashtbl.t = Hashtbl.create 97 -let current_loc = ref None let flags = ref "" -let set_current_loc loc = current_loc := loc - let get_flags () = !flags let add_warning_in_category ~name ~category = @@ -170,7 +167,6 @@ let create ~name ~category ?(default=Enabled) pp = set_flags !flags; fun ?loc x -> let w = Hashtbl.find warnings name in - let loc = Option.append loc !current_loc in match w.status with | Disabled -> () | AsError -> CErrors.user_err ?loc (pp x) diff --git a/lib/cWarnings.mli b/lib/cWarnings.mli index fa96b18c8..f97a53c4d 100644 --- a/lib/cWarnings.mli +++ b/lib/cWarnings.mli @@ -10,8 +10,6 @@ type status = Disabled | Enabled | AsError -val set_current_loc : Loc.t option -> unit - val create : name:string -> category:string -> ?default:status -> ('a -> Pp.t) -> ?loc:Loc.t -> 'a -> unit diff --git a/lib/control.ml b/lib/control.ml index e67cd8b38..3fbeb168c 100644 --- a/lib/control.ml +++ b/lib/control.ml @@ -85,4 +85,7 @@ let timeout_fun = match Sys.os_type with | "Unix" | "Cygwin" -> { timeout = unix_timeout } | _ -> { timeout = windows_timeout } -let timeout n f e = timeout_fun.timeout n f e +let timeout_fun_ref = ref timeout_fun +let set_timeout f = timeout_fun_ref := f + +let timeout n f e = !timeout_fun_ref.timeout n f e diff --git a/lib/control.mli b/lib/control.mli index 415e05462..59e2a1515 100644 --- a/lib/control.mli +++ b/lib/control.mli @@ -24,3 +24,8 @@ val check_for_interrupt : unit -> unit val timeout : int -> ('a -> 'b) -> 'a -> exn -> 'b (** [timeout n f x e] tries to compute [f x], and if it fails to do so before [n] seconds, it raises [e] instead. *) + +(** Set a particular timeout function; warning, this is an internal + API and it is scheduled to go away. *) +type timeout = { timeout : 'a 'b. int -> ('a -> 'b) -> 'a -> exn -> 'b } +val set_timeout : timeout -> unit diff --git a/lib/coqProject_file.ml4 b/lib/coqProject_file.ml4 index d6c340f69..61eb1dafd 100644 --- a/lib/coqProject_file.ml4 +++ b/lib/coqProject_file.ml4 @@ -8,6 +8,14 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) +(* This needs to go trou feedback as it is invoked from IDEs, but + ideally we would like to make this independent so it can be + bootstrapped. *) + +(* Note the problem with the error invokation below calling exit... *) +(* let error msg = Feedback.msg_error msg *) +let warning msg = Feedback.msg_warning Pp.(str msg) + type arg_source = CmdLine | ProjectFile type 'a sourced = { thing : 'a; source : arg_source } @@ -122,7 +130,7 @@ let process_cmd_line orig_dir proj args = let sourced x = { thing = x; source = if !parsing_project_file then ProjectFile else CmdLine } in let orig_dir = (* avoids turning foo.v in ./foo.v *) if orig_dir = "." then "" else orig_dir in - let error s = Format.eprintf "@[%a]@@\n%!" Pp.pp_with Pp.(str (s^".")); exit 1 in + let error s = (Format.eprintf "Error: @[%s@].@\n%!" s; exit 1) in let mk_path d = let p = CUnix.correct_path d orig_dir in { path = CUnix.remove_path_dot (post_canonize p); @@ -140,7 +148,7 @@ let process_cmd_line orig_dir proj args = | ("-full"|"-opt") :: r -> aux { proj with use_ocamlopt = true } r | "-install" :: d :: r -> if proj.install_kind <> None then - Feedback.msg_warning (Pp.str "-install set more than once."); + (warning "-install set more than once.@\n%!"); let install = match d with | "user" -> UserInstall | "none" -> NoInstall @@ -167,8 +175,7 @@ let process_cmd_line orig_dir proj args = let file = CUnix.remove_path_dot (CUnix.correct_path file orig_dir) in let () = match proj.project_file with | None -> () - | Some _ -> Feedback.msg_warning (Pp.str - "Multiple project files are deprecated.") + | Some _ -> warning "Multiple project files are deprecated.@\n%!" in parsing_project_file := true; let proj = aux { proj with project_file = Some file } (parse file) in diff --git a/lib/flags.ml b/lib/flags.ml index 8491873e0..7e0065beb 100644 --- a/lib/flags.ml +++ b/lib/flags.ml @@ -57,10 +57,7 @@ let in_toplevel = ref false let profile = false -let ide_slave = ref false - let raw_print = ref false -let univ_print = ref false let we_are_parsing = ref false @@ -160,11 +157,3 @@ let print_mod_uid = ref false let profile_ltac = ref false let profile_ltac_cutoff = ref 2.0 - -let dump_bytecode = ref false -let set_dump_bytecode = (:=) dump_bytecode -let get_dump_bytecode () = !dump_bytecode - -let dump_lambda = ref false -let set_dump_lambda = (:=) dump_lambda -let get_dump_lambda () = !dump_lambda diff --git a/lib/flags.mli b/lib/flags.mli index 85aaf879f..02d8a3adc 100644 --- a/lib/flags.mli +++ b/lib/flags.mli @@ -10,6 +10,25 @@ (** Global options of the system. *) +(** WARNING: don't add new entries to this file! + + This file is own its way to deprecation in favor of a purely + functional state, but meanwhile it will contain options that are + truly global to the system such as [compat] or [debug] + + If you are thinking about adding a global flag, well, just + don't. First of all, options make testins exponentially more + expensive, due to the growth of flag combinations. So please make + some effort in order for your idea to work in a configuration-free + manner. + + If you absolutely must pass an option to your new system, then do + so as a functional argument so flags are exposed to unit + testing. Then, register such parameters with the proper + state-handling mechanism of the top-level subsystem of Coq. + + *) + (** Command-line flags *) val boot : bool ref @@ -33,18 +52,12 @@ val in_toplevel : bool ref val profile : bool -(* -ide_slave: printing will be more verbose, will affect stm caching *) -val ide_slave : bool ref - (* development flag to detect race conditions, it should go away. *) val we_are_parsing : bool ref (* Set Printing All flag. For some reason it is a global flag *) val raw_print : bool ref -(* Univ print flag, never set anywere. Maybe should belong to Univ? *) -val univ_print : bool ref - type compat_version = V8_6 | V8_7 | Current val compat_version : compat_version ref val version_compare : compat_version -> compat_version -> int @@ -129,13 +142,3 @@ val print_mod_uid : bool ref val profile_ltac : bool ref val profile_ltac_cutoff : float ref - -(** Dump the bytecode after compilation (for debugging purposes) *) -val dump_bytecode : bool ref -val set_dump_bytecode : bool -> unit -val get_dump_bytecode : unit -> bool - -(** Dump the VM lambda code after compilation (for debugging purposes) *) -val dump_lambda : bool ref -val set_dump_lambda : bool -> unit -val get_dump_lambda : unit -> bool diff --git a/lib/loc.ml b/lib/loc.ml index 6f5283aab..1a09091bf 100644 --- a/lib/loc.ml +++ b/lib/loc.ml @@ -62,6 +62,11 @@ let merge_opt l1 l2 = match l1, l2 with | None, Some l -> Some l | Some l1, Some l2 -> Some (merge l1 l2) +let finer l1 l2 = match l1, l2 with + | None, _ -> false + | Some l , None -> true + | Some l1, Some l2 -> l1.fname = l2.fname && merge l1 l2 = l2 + let unloc loc = (loc.bp, loc.ep) let shift_loc kb kp loc = { loc with bp = loc.bp + kb ; ep = loc.ep + kp } diff --git a/lib/loc.mli b/lib/loc.mli index 813c45fbb..23df1ebd9 100644 --- a/lib/loc.mli +++ b/lib/loc.mli @@ -42,6 +42,10 @@ val merge : t -> t -> t val merge_opt : t option -> t option -> t option (** Merge locations, usually generating the largest possible span *) +val finer : t option -> t option -> bool +(** Answers [true] when the first location is more defined, or, when + both defined, included in the second one *) + val shift_loc : int -> int -> t -> t (** [shift_loc loc n p] shifts the beginning of location by [n] and the end by [p]; it is assumed that the shifts do not change the diff --git a/lib/rtree.ml b/lib/rtree.ml index 0e371025e..e1c6a4c4d 100644 --- a/lib/rtree.ml +++ b/lib/rtree.ml @@ -94,22 +94,28 @@ let is_node t = Node _ -> true | _ -> false - let rec map f t = match t with Param(i,j) -> Param(i,j) | Node (a,sons) -> Node (f a, Array.map (map f) sons) | Rec(j,defs) -> Rec (j, Array.map (map f) defs) -let smartmap f t = match t with - Param _ -> t - | Node (a,sons) -> - let a'=f a and sons' = Array.smartmap (map f) sons in - if a'==a && sons'==sons then t - else Node (a',sons') - | Rec(j,defs) -> - let defs' = Array.smartmap (map f) defs in - if defs'==defs then t - else Rec(j,defs') +module Smart = +struct + + let map f t = match t with + Param _ -> t + | Node (a,sons) -> + let a'=f a and sons' = Array.Smart.map (map f) sons in + if a'==a && sons'==sons then t + else Node (a',sons') + | Rec(j,defs) -> + let defs' = Array.Smart.map (map f) defs in + if defs'==defs then t + else Rec(j,defs') + +end + +let smartmap = Smart.map (** Structural equality test, parametrized by an equality on elements *) diff --git a/lib/rtree.mli b/lib/rtree.mli index 8edfc3d37..5ab14f603 100644 --- a/lib/rtree.mli +++ b/lib/rtree.mli @@ -74,13 +74,22 @@ val incl : ('a -> 'a -> bool) -> ('a -> 'a -> 'a option) -> 'a -> 'a t -> 'a t - (** Iterators *) +(** See also [Smart.map] *) val map : ('a -> 'b) -> 'a t -> 'b t -(** [(smartmap f t) == t] if [(f a) ==a ] for all nodes *) val smartmap : ('a -> 'a) -> 'a t -> 'a t +(** @deprecated Same as [Smart.map] *) (** A rather simple minded pretty-printer *) val pp_tree : ('a -> Pp.t) -> 'a t -> Pp.t val eq_rtree : ('a -> 'a -> bool) -> 'a t -> 'a t -> bool (** @deprecated Same as [Rtree.equal] *) + +module Smart : +sig + + (** [(Smart.map f t) == t] if [(f a) ==a ] for all nodes *) + val map : ('a -> 'a) -> 'a t -> 'a t + +end diff --git a/lib/spawn.ml b/lib/spawn.ml index 6d2ad3787..63e9e452c 100644 --- a/lib/spawn.ml +++ b/lib/spawn.ml @@ -10,7 +10,7 @@ let proto_version = 0 let prefer_sock = Sys.os_type = "Win32" -let accept_timeout = 2.0 +let accept_timeout = 10.0 let pr_err s = Printf.eprintf "(Spawn ,%d) %s\n%!" (Unix.getpid ()) s let prerr_endline s = if !Flags.debug then begin pr_err s end else () diff --git a/lib/stateid.ml b/lib/stateid.ml index a258d5052..5485c4bf1 100644 --- a/lib/stateid.ml +++ b/lib/stateid.ml @@ -11,15 +11,11 @@ type t = int let initial = 1 let dummy = 0 -let fresh, in_range = +let fresh = let cur = ref initial in - (fun () -> incr cur; !cur), (fun id -> id >= 0 && id <= !cur) + fun () -> incr cur; !cur let to_string = string_of_int -let of_int id = - (* Coqide too to parse ids too, but cannot check if they are valid. - * Hence we check for validity only if we are an ide slave. *) - if !Flags.ide_slave then assert (in_range id); - id +let of_int id = id let to_int id = id let newer_than id1 id2 = id1 > id2 diff --git a/lib/system.ml b/lib/system.ml index dfede29e8..f109c7192 100644 --- a/lib/system.ml +++ b/lib/system.ml @@ -116,18 +116,6 @@ let where_in_path ?(warn=true) path filename = let f = Filename.concat lpe filename in if file_exists_respecting_case lpe filename then [lpe,f] else [])) -let where_in_path_rex path rex = - search path (fun lpe -> - try - let files = Sys.readdir lpe in - CList.map_filter (fun name -> - try - ignore(Str.search_forward rex name 0); - Some (lpe,Filename.concat lpe name) - with Not_found -> None) - (Array.to_list files) - with Sys_error _ -> []) - let find_file_in_path ?(warn=true) paths filename = if not (Filename.is_implicit filename) then (* the name is considered to be a physical name and we use the file @@ -312,3 +300,9 @@ let with_time ~batch f x = let msg2 = if batch then "" else " (failure)" in Feedback.msg_info (str msg ++ fmt_time_difference tstart tend ++ str msg2); raise e + +let get_toplevel_path top = + let dir = Filename.dirname Sys.argv.(0) in + let exe = if Sys.(os_type = "Win32" || os_type = "Cygwin") then ".exe" else "" in + let eff = if Dynlink.is_native then ".opt" else ".byte" in + dir ^ Filename.dir_sep ^ top ^ eff ^ exe diff --git a/lib/system.mli b/lib/system.mli index 3349dfea3..a34280037 100644 --- a/lib/system.mli +++ b/lib/system.mli @@ -50,8 +50,6 @@ val is_in_path : CUnix.load_path -> string -> bool val is_in_system_path : string -> bool val where_in_path : ?warn:bool -> CUnix.load_path -> string -> CUnix.physical_path * string -val where_in_path_rex : - CUnix.load_path -> Str.regexp -> (CUnix.physical_path * string) list val find_file_in_path : ?warn:bool -> CUnix.load_path -> string -> CUnix.physical_path * string @@ -107,3 +105,21 @@ val time_difference : time -> time -> float (** in seconds *) val fmt_time_difference : time -> time -> Pp.t val with_time : batch:bool -> ('a -> 'b) -> 'a -> 'b + +(** [get_toplevel_path program] builds a complete path to the + executable denoted by [program]. This involves: + + - locating the directory: we don't rely on PATH as to make calls to + /foo/bin/coqtop chose the right /foo/bin/coqproofworker + + - adding the proper suffixes: .opt/.byte depending on the current + mode, + .exe if in windows. + + Note that this function doesn't check that the executable actually + exists. This is left back to caller, as well as the choice of + fallback strategy. We could add a fallback strategy here but it is + better not to as in most cases if this function fails to construct + the right name you want you execution to fail rather than fall into + choosing some random binary from the system-wide installation of + Coq. *) +val get_toplevel_path : string -> string diff --git a/library/coqlib.ml b/library/coqlib.ml index 3f01c617c..408e25919 100644 --- a/library/coqlib.ml +++ b/library/coqlib.ml @@ -171,16 +171,16 @@ let jmeq_kn = make_ind jmeq_module "JMeq" let glob_jmeq = IndRef (jmeq_kn,0) type coq_sigma_data = { - proj1 : global_reference; - proj2 : global_reference; - elim : global_reference; - intro : global_reference; - typ : global_reference } + proj1 : GlobRef.t; + proj2 : GlobRef.t; + elim : GlobRef.t; + intro : GlobRef.t; + typ : GlobRef.t } type coq_bool_data = { - andb : global_reference; - andb_prop : global_reference; - andb_true_intro : global_reference} + andb : GlobRef.t; + andb_prop : GlobRef.t; + andb_true_intro : GlobRef.t} let build_bool_type () = { andb = init_reference ["Datatypes"] "andb"; @@ -213,18 +213,18 @@ let build_prod () = (* Equalities *) type coq_eq_data = { - eq : global_reference; - ind : global_reference; - refl : global_reference; - sym : global_reference; - trans: global_reference; - congr: global_reference } + eq : GlobRef.t; + ind : GlobRef.t; + refl : GlobRef.t; + sym : GlobRef.t; + trans: GlobRef.t; + congr: GlobRef.t } (* Data needed for discriminate and injection *) type coq_inversion_data = { - inv_eq : global_reference; (* : forall params, t -> Prop *) - inv_ind : global_reference; (* : forall params P y, eq params y -> P y *) - inv_congr: global_reference (* : forall params B (f:t->B) y, eq params y -> f c=f y *) + inv_eq : GlobRef.t; (* : forall params, t -> Prop *) + inv_ind : GlobRef.t; (* : forall params P y, eq params y -> P y *) + inv_congr: GlobRef.t (* : forall params B (f:t->B) y, eq params y -> f c=f y *) } let lazy_init_reference dir id = lazy (init_reference dir id) diff --git a/library/coqlib.mli b/library/coqlib.mli index 8077c47c7..b4bd1b0e0 100644 --- a/library/coqlib.mli +++ b/library/coqlib.mli @@ -8,10 +8,9 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) +open Util open Names open Libnames -open Globnames -open Util (** This module collects the global references, constructions and patterns of the standard library used in ocaml files *) @@ -44,14 +43,14 @@ open Util type message = string -val find_reference : message -> string list -> string -> global_reference -val coq_reference : message -> string list -> string -> global_reference +val find_reference : message -> string list -> string -> GlobRef.t +val coq_reference : message -> string list -> string -> GlobRef.t (** For tactics/commands requiring vernacular libraries *) val check_required_library : string list -> unit (** Search in several modules (not prefixed by "Coq") *) -val gen_reference_in_modules : string->string list list-> string -> global_reference +val gen_reference_in_modules : string->string list list-> string -> GlobRef.t val arith_modules : string list list val zarith_base_modules : string list list @@ -78,24 +77,24 @@ val type_of_id : Constant.t (** Natural numbers *) val nat_path : full_path -val glob_nat : global_reference +val glob_nat : GlobRef.t val path_of_O : constructor val path_of_S : constructor -val glob_O : global_reference -val glob_S : global_reference +val glob_O : GlobRef.t +val glob_S : GlobRef.t (** Booleans *) -val glob_bool : global_reference +val glob_bool : GlobRef.t val path_of_true : constructor val path_of_false : constructor -val glob_true : global_reference -val glob_false : global_reference +val glob_true : GlobRef.t +val glob_false : GlobRef.t (** Equality *) -val glob_eq : global_reference -val glob_identity : global_reference -val glob_jmeq : global_reference +val glob_eq : GlobRef.t +val glob_identity : GlobRef.t +val glob_jmeq : GlobRef.t (** {6 ... } *) (** Constructions and patterns related to Coq initial state are unknown @@ -106,18 +105,18 @@ val glob_jmeq : global_reference at runtime. *) type coq_bool_data = { - andb : global_reference; - andb_prop : global_reference; - andb_true_intro : global_reference} + andb : GlobRef.t; + andb_prop : GlobRef.t; + andb_true_intro : GlobRef.t} val build_bool_type : coq_bool_data delayed (** {6 For Equality tactics } *) type coq_sigma_data = { - proj1 : global_reference; - proj2 : global_reference; - elim : global_reference; - intro : global_reference; - typ : global_reference } + proj1 : GlobRef.t; + proj2 : GlobRef.t; + elim : GlobRef.t; + intro : GlobRef.t; + typ : GlobRef.t } val build_sigma_set : coq_sigma_data delayed val build_sigma_type : coq_sigma_data delayed @@ -132,30 +131,30 @@ val build_sigma : coq_sigma_data delayed val build_prod : coq_sigma_data delayed type coq_eq_data = { - eq : global_reference; - ind : global_reference; - refl : global_reference; - sym : global_reference; - trans: global_reference; - congr: global_reference } + eq : GlobRef.t; + ind : GlobRef.t; + refl : GlobRef.t; + sym : GlobRef.t; + trans: GlobRef.t; + congr: GlobRef.t } val build_coq_eq_data : coq_eq_data delayed val build_coq_identity_data : coq_eq_data delayed val build_coq_jmeq_data : coq_eq_data delayed -val build_coq_eq : global_reference delayed (** = [(build_coq_eq_data()).eq] *) -val build_coq_eq_refl : global_reference delayed (** = [(build_coq_eq_data()).refl] *) -val build_coq_eq_sym : global_reference delayed (** = [(build_coq_eq_data()).sym] *) -val build_coq_f_equal2 : global_reference delayed +val build_coq_eq : GlobRef.t delayed (** = [(build_coq_eq_data()).eq] *) +val build_coq_eq_refl : GlobRef.t delayed (** = [(build_coq_eq_data()).refl] *) +val build_coq_eq_sym : GlobRef.t delayed (** = [(build_coq_eq_data()).sym] *) +val build_coq_f_equal2 : GlobRef.t delayed (** Data needed for discriminate and injection *) type coq_inversion_data = { - inv_eq : global_reference; (** : forall params, args -> Prop *) - inv_ind : global_reference; (** : forall params P (H : P params) args, eq params args + inv_eq : GlobRef.t; (** : forall params, args -> Prop *) + inv_ind : GlobRef.t; (** : forall params P (H : P params) args, eq params args -> P args *) - inv_congr: global_reference (** : forall params B (f:t->B) args, eq params args -> + inv_congr: GlobRef.t (** : forall params B (f:t->B) args, eq params args -> f params = f args *) } @@ -165,45 +164,45 @@ val build_coq_inversion_jmeq_data : coq_inversion_data delayed val build_coq_inversion_eq_true_data : coq_inversion_data delayed (** Specif *) -val build_coq_sumbool : global_reference delayed +val build_coq_sumbool : GlobRef.t delayed (** {6 ... } *) (** Connectives The False proposition *) -val build_coq_False : global_reference delayed +val build_coq_False : GlobRef.t delayed (** The True proposition and its unique proof *) -val build_coq_True : global_reference delayed -val build_coq_I : global_reference delayed +val build_coq_True : GlobRef.t delayed +val build_coq_I : GlobRef.t delayed (** Negation *) -val build_coq_not : global_reference delayed +val build_coq_not : GlobRef.t delayed (** Conjunction *) -val build_coq_and : global_reference delayed -val build_coq_conj : global_reference delayed -val build_coq_iff : global_reference delayed +val build_coq_and : GlobRef.t delayed +val build_coq_conj : GlobRef.t delayed +val build_coq_iff : GlobRef.t delayed -val build_coq_iff_left_proj : global_reference delayed -val build_coq_iff_right_proj : global_reference delayed +val build_coq_iff_left_proj : GlobRef.t delayed +val build_coq_iff_right_proj : GlobRef.t delayed (** Disjunction *) -val build_coq_or : global_reference delayed +val build_coq_or : GlobRef.t delayed (** Existential quantifier *) -val build_coq_ex : global_reference delayed - -val coq_eq_ref : global_reference lazy_t -val coq_identity_ref : global_reference lazy_t -val coq_jmeq_ref : global_reference lazy_t -val coq_eq_true_ref : global_reference lazy_t -val coq_existS_ref : global_reference lazy_t -val coq_existT_ref : global_reference lazy_t -val coq_exist_ref : global_reference lazy_t -val coq_not_ref : global_reference lazy_t -val coq_False_ref : global_reference lazy_t -val coq_sumbool_ref : global_reference lazy_t -val coq_sig_ref : global_reference lazy_t - -val coq_or_ref : global_reference lazy_t -val coq_iff_ref : global_reference lazy_t +val build_coq_ex : GlobRef.t delayed + +val coq_eq_ref : GlobRef.t lazy_t +val coq_identity_ref : GlobRef.t lazy_t +val coq_jmeq_ref : GlobRef.t lazy_t +val coq_eq_true_ref : GlobRef.t lazy_t +val coq_existS_ref : GlobRef.t lazy_t +val coq_existT_ref : GlobRef.t lazy_t +val coq_exist_ref : GlobRef.t lazy_t +val coq_not_ref : GlobRef.t lazy_t +val coq_False_ref : GlobRef.t lazy_t +val coq_sumbool_ref : GlobRef.t lazy_t +val coq_sig_ref : GlobRef.t lazy_t + +val coq_or_ref : GlobRef.t lazy_t +val coq_iff_ref : GlobRef.t lazy_t diff --git a/intf/decl_kinds.ml b/library/decl_kinds.ml index 0d3285311..c1a673edf 100644 --- a/intf/decl_kinds.ml +++ b/library/decl_kinds.ml @@ -74,14 +74,3 @@ type logical_kind = | IsAssumption of assumption_object_kind | IsDefinition of definition_object_kind | IsProof of theorem_kind - -(** Recursive power of type declarations *) - -type recursivity_kind = Declarations.recursivity_kind = - | Finite (** = inductive *) - [@ocaml.deprecated "Please use [Declarations.Finite"] - | CoFinite (** = coinductive *) - [@ocaml.deprecated "Please use [Declarations.CoFinite"] - | BiFinite (** = non-recursive, like in "Record" definitions *) - [@ocaml.deprecated "Please use [Declarations.BiFinite"] -[@@ocaml.deprecated "Please use [Declarations.recursivity_kind"] diff --git a/library/declaremods.ml b/library/declaremods.ml index 762efc5e3..0b3b461e6 100644 --- a/library/declaremods.ml +++ b/library/declaremods.ml @@ -17,11 +17,26 @@ open Entries open Libnames open Libobject open Mod_subst -open Vernacexpr -open Misctypes (** {6 Inlining levels} *) +(** Rigid / flexible module signature *) + +type 'a module_signature = + | Enforce of 'a (** ... : T *) + | Check of 'a list (** ... <: T1 <: T2, possibly empty *) + +(** Which module inline annotations should we honor, + either None or the ones whose level is less or equal + to the given integer *) + +type inline = + | NoInline + | DefaultInline + | InlineAt of int + +type module_kind = Module | ModType | ModAny + let default_inline () = Some (Flags.get_inline_level ()) let inl2intopt = function @@ -980,8 +995,8 @@ let iter_all_segments f = (** {6 Some types used to shorten declaremods.mli} *) type 'modast module_interpretor = - Environ.env -> Misctypes.module_kind -> 'modast -> - Entries.module_struct_entry * Misctypes.module_kind * Univ.ContextSet.t + Environ.env -> module_kind -> 'modast -> + Entries.module_struct_entry * module_kind * Univ.ContextSet.t type 'modast module_params = (lident list * ('modast * inline)) list diff --git a/library/declaremods.mli b/library/declaremods.mli index fd8d29614..b42a59bfb 100644 --- a/library/declaremods.mli +++ b/library/declaremods.mli @@ -9,16 +9,34 @@ (************************************************************************) open Names -open Vernacexpr (** {6 Modules } *) +(** Rigid / flexible module signature *) + +type 'a module_signature = + | Enforce of 'a (** ... : T *) + | Check of 'a list (** ... <: T1 <: T2, possibly empty *) + +(** Which module inline annotations should we honor, + either None or the ones whose level is less or equal + to the given integer *) + +type inline = + | NoInline + | DefaultInline + | InlineAt of int + +(** Kinds of modules *) + +type module_kind = Module | ModType | ModAny + type 'modast module_interpretor = - Environ.env -> Misctypes.module_kind -> 'modast -> - Entries.module_struct_entry * Misctypes.module_kind * Univ.ContextSet.t + Environ.env -> module_kind -> 'modast -> + Entries.module_struct_entry * module_kind * Univ.ContextSet.t type 'modast module_params = - (Misctypes.lident list * ('modast * inline)) list + (lident list * ('modast * inline)) list (** [declare_module interp_modast id fargs typ exprs] declares module [id], with structure constructed by [interp_modast] diff --git a/library/global.mli b/library/global.mli index b82039a0c..57e173cb9 100644 --- a/library/global.mli +++ b/library/global.mli @@ -123,26 +123,26 @@ val env_of_context : Environ.named_context_val -> Environ.env val join_safe_environment : ?except:Future.UUIDSet.t -> unit -> unit val is_joined_environment : unit -> bool -val is_polymorphic : Globnames.global_reference -> bool -val is_template_polymorphic : Globnames.global_reference -> bool -val is_type_in_type : Globnames.global_reference -> bool +val is_polymorphic : GlobRef.t -> bool +val is_template_polymorphic : GlobRef.t -> bool +val is_type_in_type : GlobRef.t -> bool val constr_of_global_in_context : Environ.env -> - Globnames.global_reference -> Constr.types * Univ.AUContext.t + GlobRef.t -> Constr.types * Univ.AUContext.t (** Returns the type of the constant in its local universe context. The type should not be used without pushing it's universe context in the environmnent of usage. For non-universe-polymorphic constants, it does not matter. *) val type_of_global_in_context : Environ.env -> - Globnames.global_reference -> Constr.types * Univ.AUContext.t + GlobRef.t -> Constr.types * Univ.AUContext.t (** Returns the type of the constant in its local universe context. The type should not be used without pushing it's universe context in the environmnent of usage. For non-universe-polymorphic constants, it does not matter. *) (** Returns the universe context of the global reference (whatever its polymorphic status is). *) -val universes_of_global : Globnames.global_reference -> Univ.AUContext.t +val universes_of_global : GlobRef.t -> Univ.AUContext.t (** {6 Retroknowledge } *) diff --git a/library/globnames.ml b/library/globnames.ml index 2fa3adba2..6383a1f8f 100644 --- a/library/globnames.ml +++ b/library/globnames.ml @@ -15,7 +15,7 @@ open Mod_subst open Libnames (*s Global reference is a kernel side type for all references together *) -type global_reference = Names.global_reference = +type global_reference = GlobRef.t = | VarRef of variable (** A reference to the section-context. *) | ConstRef of Constant.t (** A reference to the environment. *) | IndRef of inductive (** A reference to an inductive type. *) @@ -26,14 +26,6 @@ let isConstRef = function ConstRef _ -> true | _ -> false let isIndRef = function IndRef _ -> true | _ -> false let isConstructRef = function ConstructRef _ -> true | _ -> false -let eq_gr gr1 gr2 = - gr1 == gr2 || match gr1,gr2 with - | ConstRef con1, ConstRef con2 -> Constant.equal con1 con2 - | IndRef kn1, IndRef kn2 -> eq_ind kn1 kn2 - | ConstructRef kn1, ConstructRef kn2 -> eq_constructor kn1 kn2 - | VarRef v1, VarRef v2 -> Id.equal v1 v2 - | (ConstRef _ | IndRef _ | ConstructRef _ | VarRef _), _ -> false - let destVarRef = function VarRef ind -> ind | _ -> failwith "destVarRef" let destConstRef = function ConstRef ind -> ind | _ -> failwith "destConstRef" let destIndRef = function IndRef ind -> ind | _ -> failwith "destIndRef" @@ -95,8 +87,6 @@ let printable_constr_of_global = function | ConstructRef sp -> mkConstruct sp | IndRef sp -> mkInd sp -let reference_of_constr = global_of_constr - let global_eq_gen eq_cst eq_ind eq_cons x y = x == y || match x, y with @@ -245,3 +235,6 @@ let pop_global_reference = function | IndRef (kn,i) -> IndRef (pop_kn kn,i) | ConstructRef ((kn,i),j) -> ConstructRef ((pop_kn kn,i),j) | VarRef id -> anomaly (Pp.str "VarRef not poppable.") + +(* Deprecated *) +let eq_gr = GlobRef.equal diff --git a/library/globnames.mli b/library/globnames.mli index f2b88b870..15fcd5bdd 100644 --- a/library/globnames.mli +++ b/library/globnames.mli @@ -14,71 +14,69 @@ open Constr open Mod_subst (** {6 Global reference is a kernel side type for all references together } *) -type global_reference = Names.global_reference = +type global_reference = GlobRef.t = | VarRef of variable (** A reference to the section-context. *) | ConstRef of Constant.t (** A reference to the environment. *) | IndRef of inductive (** A reference to an inductive type. *) | ConstructRef of constructor (** A reference to a constructor of an inductive type. *) +[@@ocaml.deprecated "Use Names.GlobRef.t"] -val isVarRef : global_reference -> bool -val isConstRef : global_reference -> bool -val isIndRef : global_reference -> bool -val isConstructRef : global_reference -> bool +val isVarRef : GlobRef.t -> bool +val isConstRef : GlobRef.t -> bool +val isIndRef : GlobRef.t -> bool +val isConstructRef : GlobRef.t -> bool -val eq_gr : global_reference -> global_reference -> bool -val canonical_gr : global_reference -> global_reference +val eq_gr : GlobRef.t -> GlobRef.t -> bool +[@@ocaml.deprecated "Use Names.GlobRef.equal"] +val canonical_gr : GlobRef.t -> GlobRef.t -val destVarRef : global_reference -> variable -val destConstRef : global_reference -> Constant.t -val destIndRef : global_reference -> inductive -val destConstructRef : global_reference -> constructor +val destVarRef : GlobRef.t -> variable +val destConstRef : GlobRef.t -> Constant.t +val destIndRef : GlobRef.t -> inductive +val destConstructRef : GlobRef.t -> constructor -val is_global : global_reference -> constr -> bool +val is_global : GlobRef.t -> constr -> bool val subst_constructor : substitution -> constructor -> constructor * constr -val subst_global : substitution -> global_reference -> global_reference * constr -val subst_global_reference : substitution -> global_reference -> global_reference +val subst_global : substitution -> GlobRef.t -> GlobRef.t * constr +val subst_global_reference : substitution -> GlobRef.t -> GlobRef.t (** This constr is not safe to be typechecked, universe polymorphism is not handled here: just use for printing *) -val printable_constr_of_global : global_reference -> constr +val printable_constr_of_global : GlobRef.t -> constr (** Turn a construction denoting a global reference into a global reference; raise [Not_found] if not a global reference *) -val global_of_constr : constr -> global_reference - -(** Obsolete synonyms for constr_of_global and global_of_constr *) -val reference_of_constr : constr -> global_reference -[@@ocaml.deprecated "Alias of Globnames.global_of_constr"] +val global_of_constr : constr -> GlobRef.t module RefOrdered : sig - type t = global_reference + type t = GlobRef.t val compare : t -> t -> int val equal : t -> t -> bool val hash : t -> int end module RefOrdered_env : sig - type t = global_reference + type t = GlobRef.t val compare : t -> t -> int val equal : t -> t -> bool val hash : t -> int end -module Refset : CSig.SetS with type elt = global_reference +module Refset : CSig.SetS with type elt = GlobRef.t module Refmap : Map.ExtS - with type key = global_reference and module Set := Refset + with type key = GlobRef.t and module Set := Refset -module Refset_env : CSig.SetS with type elt = global_reference +module Refset_env : CSig.SetS with type elt = GlobRef.t module Refmap_env : Map.ExtS - with type key = global_reference and module Set := Refset_env + with type key = GlobRef.t and module Set := Refset_env (** {6 Extended global references } *) type syndef_name = KerName.t type extended_global_reference = - | TrueGlobal of global_reference + | TrueGlobal of GlobRef.t | SynDef of syndef_name module ExtRefOrdered : sig @@ -89,7 +87,7 @@ module ExtRefOrdered : sig end type global_reference_or_constr = - | IsGlobal of global_reference + | IsGlobal of GlobRef.t | IsConstr of constr (** {6 Temporary function to brutally form kernel names from section paths } *) @@ -100,7 +98,6 @@ val encode_con : DirPath.t -> Id.t -> Constant.t val decode_con : Constant.t -> DirPath.t * Id.t (** {6 Popping one level of section in global names } *) - val pop_con : Constant.t -> Constant.t val pop_kn : MutInd.t-> MutInd.t -val pop_global_reference : global_reference -> global_reference +val pop_global_reference : GlobRef.t -> GlobRef.t diff --git a/library/heads.ml b/library/heads.ml index 198672a0a..3d5f6a6ff 100644 --- a/library/heads.ml +++ b/library/heads.ml @@ -129,7 +129,7 @@ let compute_head = function let cb = Environ.lookup_constant cst env in let is_Def = function Declarations.Def _ -> true | _ -> false in let body = - if cb.Declarations.const_proj = None && is_Def cb.Declarations.const_body + if not cb.Declarations.const_proj && is_Def cb.Declarations.const_body then Global.body_of_constant cst else None in (match body with diff --git a/library/keys.ml b/library/keys.ml index 34a6adabe..3cadcb647 100644 --- a/library/keys.ml +++ b/library/keys.ml @@ -10,12 +10,13 @@ (** Keys for unification and indexing *) -open Globnames -open Term +open Names +open Constr open Libobject +open Globnames type key = - | KGlob of global_reference + | KGlob of GlobRef.t | KLam | KLet | KProd @@ -126,7 +127,7 @@ let constr_key kind c = | Construct (c,u) -> KGlob (ConstructRef c) | Var id -> KGlob (VarRef id) | App (f, _) -> aux f - | Proj (p, _) -> KGlob (ConstRef (Names.Projection.constant p)) + | Proj (p, _) -> KGlob (ConstRef (Projection.constant p)) | Cast (p, _, _) -> aux p | Lambda _ -> KLam | Prod _ -> KProd diff --git a/library/keys.mli b/library/keys.mli index 1fb9a3de0..198383650 100644 --- a/library/keys.mli +++ b/library/keys.mli @@ -8,8 +8,6 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) -open Globnames - type key val declare_equiv_keys : key -> key -> unit @@ -21,5 +19,5 @@ val equiv_keys : key -> key -> bool val constr_key : ('a -> ('a, 't, 'u, 'i) Constr.kind_of_term) -> 'a -> key option (** Compute the head key of a term. *) -val pr_keys : (global_reference -> Pp.t) -> Pp.t +val pr_keys : (Names.GlobRef.t -> Pp.t) -> Pp.t (** Pretty-print the mapping *) diff --git a/library/lib.ml b/library/lib.ml index 543cb45bc..128b27e75 100644 --- a/library/lib.ml +++ b/library/lib.ml @@ -51,7 +51,7 @@ let subst_objects subst seg = if obj' == obj then node else (id, obj') in - List.smartmap subst_one seg + List.Smart.map subst_one seg (*let load_and_subst_objects i prefix subst seg = List.rev (List.fold_left (fun seg (id,obj as node) -> @@ -183,22 +183,11 @@ let split_lib_gen test = | before -> after,equal,before in let rec findeq after = function - | hd :: before -> - if test hd - then Some (collect after [hd] before) - else (match hd with - | (sp,ClosedModule seg) - | (sp,ClosedSection seg) -> - (match findeq after seg with - | None -> findeq (hd::after) before - | Some (sub_after,sub_equal,sub_before) -> - Some (sub_after, sub_equal, (List.append sub_before before))) - | _ -> findeq (hd::after) before) - | [] -> None + | hd :: before when test hd -> collect after [hd] before + | hd :: before -> findeq (hd::after) before + | [] -> user_err Pp.(str "no such entry") in - match findeq [] !lib_state.lib_stk with - | None -> user_err Pp.(str "no such entry") - | Some r -> r + findeq [] !lib_state.lib_stk let eq_object_name (fp1, kn1) (fp2, kn2) = eq_full_path fp1 fp2 && Names.KerName.equal kn1 kn2 @@ -580,13 +569,11 @@ let close_section () = in let (secdecls,mark,before) = split_lib_at_opening oname in lib_state := { !lib_state with lib_stk = before }; - let full_olddir = !lib_state.path_prefix.obj_dir in pop_path_prefix (); add_entry oname (ClosedSection (List.rev (mark::secdecls))); let newdecls = List.map discharge_item secdecls in Summary.unfreeze_summaries fs; - List.iter (Option.iter (fun (id,o) -> add_discharged_leaf id o)) newdecls; - Nametab.push_dir (Nametab.Until 1) full_olddir (DirClosedSection full_olddir) + List.iter (Option.iter (fun (id,o) -> add_discharged_leaf id o)) newdecls (* State and initialization. *) diff --git a/library/lib.mli b/library/lib.mli index 26f1718cc..1d77212e9 100644 --- a/library/lib.mli +++ b/library/lib.mli @@ -8,7 +8,7 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) - +open Names (** Lib: record of operations, backtrack, low-level sections *) (** This module provides a general mechanism to keep a trace of all operations @@ -28,7 +28,7 @@ type node = and library_segment = (Libnames.object_name * node) list -type lib_objects = (Names.Id.t * Libobject.obj) list +type lib_objects = (Id.t * Libobject.obj) list (** {6 Object iteration functions. } *) @@ -54,13 +54,13 @@ val segment_of_objects : (** Adding operations (which call the [cache] method, and getting the current list of operations (most recent ones coming first). *) -val add_leaf : Names.Id.t -> Libobject.obj -> Libnames.object_name +val add_leaf : Id.t -> Libobject.obj -> Libnames.object_name val add_anonymous_leaf : ?cache_first:bool -> Libobject.obj -> unit val pull_to_head : Libnames.object_name -> unit (** this operation adds all objects with the same name and calls [load_object] for each of them *) -val add_leaves : Names.Id.t -> Libobject.obj list -> Libnames.object_name +val add_leaves : Id.t -> Libobject.obj list -> Libnames.object_name (** {6 ... } *) @@ -76,15 +76,15 @@ val contents_after : Libnames.object_name -> library_segment (** {6 Functions relative to current path } *) (** User-side names *) -val cwd : unit -> Names.DirPath.t -val cwd_except_section : unit -> Names.DirPath.t -val current_dirpath : bool -> Names.DirPath.t (* false = except sections *) -val make_path : Names.Id.t -> Libnames.full_path -val make_path_except_section : Names.Id.t -> Libnames.full_path +val cwd : unit -> DirPath.t +val cwd_except_section : unit -> DirPath.t +val current_dirpath : bool -> DirPath.t (* false = except sections *) +val make_path : Id.t -> Libnames.full_path +val make_path_except_section : Id.t -> Libnames.full_path (** Kernel-side names *) -val current_mp : unit -> Names.ModPath.t -val make_kn : Names.Id.t -> Names.KerName.t +val current_mp : unit -> ModPath.t +val make_kn : Id.t -> KerName.t (** Are we inside an opened section *) val sections_are_opened : unit -> bool @@ -97,19 +97,19 @@ val is_modtype : unit -> bool if the latest module started is a module type. *) val is_modtype_strict : unit -> bool val is_module : unit -> bool -val current_mod_id : unit -> Names.module_ident +val current_mod_id : unit -> module_ident (** Returns the opening node of a given name *) -val find_opening_node : Names.Id.t -> node +val find_opening_node : Id.t -> node (** {6 Modules and module types } *) val start_module : - export -> Names.module_ident -> Names.ModPath.t -> + export -> module_ident -> ModPath.t -> Summary.frozen -> Libnames.object_prefix val start_modtype : - Names.module_ident -> Names.ModPath.t -> + module_ident -> ModPath.t -> Summary.frozen -> Libnames.object_prefix val end_module : @@ -124,23 +124,23 @@ val end_modtype : (** {6 Compilation units } *) -val start_compilation : Names.DirPath.t -> Names.ModPath.t -> unit -val end_compilation_checks : Names.DirPath.t -> Libnames.object_name +val start_compilation : DirPath.t -> ModPath.t -> unit +val end_compilation_checks : DirPath.t -> Libnames.object_name val end_compilation : Libnames.object_name-> Libnames.object_prefix * library_segment (** The function [library_dp] returns the [DirPath.t] of the current compiling library (or [default_library]) *) -val library_dp : unit -> Names.DirPath.t +val library_dp : unit -> DirPath.t (** Extract the library part of a name even if in a section *) -val dp_of_mp : Names.ModPath.t -> Names.DirPath.t -val split_modpath : Names.ModPath.t -> Names.DirPath.t * Names.Id.t list -val library_part : Globnames.global_reference -> Names.DirPath.t +val dp_of_mp : ModPath.t -> DirPath.t +val split_modpath : ModPath.t -> DirPath.t * Id.t list +val library_part : GlobRef.t -> DirPath.t (** {6 Sections } *) -val open_section : Names.Id.t -> unit +val open_section : Id.t -> unit val close_section : unit -> unit (** {6 We can get and set the state of the operations (used in [States]). } *) @@ -164,31 +164,31 @@ type abstr_info = private { (** Universe quantification, same length as the substitution *) } -val instance_from_variable_context : variable_context -> Names.Id.t array +val instance_from_variable_context : variable_context -> Id.t array val named_of_variable_context : variable_context -> Context.Named.t -val section_segment_of_constant : Names.Constant.t -> abstr_info -val section_segment_of_mutual_inductive: Names.MutInd.t -> abstr_info -val section_segment_of_reference : Globnames.global_reference -> abstr_info +val section_segment_of_constant : Constant.t -> abstr_info +val section_segment_of_mutual_inductive: MutInd.t -> abstr_info +val section_segment_of_reference : GlobRef.t -> abstr_info -val variable_section_segment_of_reference : Globnames.global_reference -> variable_context +val variable_section_segment_of_reference : GlobRef.t -> variable_context -val section_instance : Globnames.global_reference -> Univ.Instance.t * Names.Id.t array -val is_in_section : Globnames.global_reference -> bool +val section_instance : GlobRef.t -> Univ.Instance.t * Id.t array +val is_in_section : GlobRef.t -> bool -val add_section_variable : Names.Id.t -> Decl_kinds.binding_kind -> Decl_kinds.polymorphic -> Univ.ContextSet.t -> unit +val add_section_variable : Id.t -> Decl_kinds.binding_kind -> Decl_kinds.polymorphic -> Univ.ContextSet.t -> unit val add_section_context : Univ.ContextSet.t -> unit val add_section_constant : Decl_kinds.polymorphic -> - Names.Constant.t -> Context.Named.t -> unit + Constant.t -> Context.Named.t -> unit val add_section_kn : Decl_kinds.polymorphic -> - Names.MutInd.t -> Context.Named.t -> unit + MutInd.t -> Context.Named.t -> unit val replacement_context : unit -> Opaqueproof.work_list (** {6 Discharge: decrease the section level if in the current section } *) -val discharge_kn : Names.MutInd.t -> Names.MutInd.t -val discharge_con : Names.Constant.t -> Names.Constant.t -val discharge_global : Globnames.global_reference -> Globnames.global_reference -val discharge_inductive : Names.inductive -> Names.inductive +val discharge_kn : MutInd.t -> MutInd.t +val discharge_con : Constant.t -> Constant.t +val discharge_global : GlobRef.t -> GlobRef.t +val discharge_inductive : inductive -> inductive val discharge_abstract_universe_context : abstr_info -> Univ.AUContext.t -> Univ.universe_level_subst * Univ.AUContext.t diff --git a/library/libnames.ml b/library/libnames.ml index d84731322..8d5a02a29 100644 --- a/library/libnames.ml +++ b/library/libnames.ml @@ -15,8 +15,6 @@ open Names (**********************************************) -let pr_dirpath sl = DirPath.print sl - (*s Operations on dirpaths *) let split_dirpath d = match DirPath.repr d with @@ -80,8 +78,6 @@ let dirpath_of_string s = in DirPath.make path -let string_of_dirpath = Names.DirPath.to_string - module Dirset = Set.Make(DirPath) module Dirmap = Map.Make(DirPath) @@ -174,8 +170,6 @@ type global_dir_reference = | DirOpenModtype of object_prefix | DirOpenSection of object_prefix | DirModule of object_prefix - | DirClosedSection of DirPath.t - (* this won't last long I hope! *) let eq_op op1 op2 = DirPath.equal op1.obj_dir op2.obj_dir && @@ -187,7 +181,6 @@ let eq_global_dir_reference r1 r2 = match r1, r2 with | DirOpenModtype op1, DirOpenModtype op2 -> eq_op op1 op2 | DirOpenSection op1, DirOpenSection op2 -> eq_op op1 op2 | DirModule op1, DirModule op2 -> eq_op op1 op2 -| DirClosedSection dp1, DirClosedSection dp2 -> DirPath.equal dp1 dp2 | _ -> false type reference_r = @@ -243,8 +236,3 @@ let default_library = Names.DirPath.initial (* = ["Top"] *) let coq_string = "Coq" let coq_root = Id.of_string coq_string let default_root_prefix = DirPath.empty - -(* Deprecated synonyms *) - -let make_short_qualid = qualid_of_ident -let qualid_of_sp = qualid_of_path diff --git a/library/libnames.mli b/library/libnames.mli index 9dad26129..5f69b1f0f 100644 --- a/library/libnames.mli +++ b/library/libnames.mli @@ -14,12 +14,6 @@ open Names (** {6 Dirpaths } *) val dirpath_of_string : string -> DirPath.t -val pr_dirpath : DirPath.t -> Pp.t -[@@ocaml.deprecated "Alias for DirPath.print"] - -val string_of_dirpath : DirPath.t -> string -[@@ocaml.deprecated "Alias for DirPath.to_string"] - (** Pop the suffix of a [DirPath.t]. Raises a [Failure] for an empty path *) val pop_dirpath : DirPath.t -> DirPath.t @@ -125,8 +119,6 @@ type global_dir_reference = | DirOpenModtype of object_prefix | DirOpenSection of object_prefix | DirModule of object_prefix - | DirClosedSection of DirPath.t - (** this won't last long I hope! *) val eq_global_dir_reference : global_dir_reference -> global_dir_reference -> bool @@ -157,10 +149,3 @@ val coq_string : string (** "Coq" *) (** This is the default root prefix for developments which doesn't mention a root *) val default_root_prefix : DirPath.t - -(** Deprecated synonyms *) -val make_short_qualid : Id.t -> qualid (** = qualid_of_ident *) -[@@ocaml.deprecated "Alias for qualid_of_ident"] - -val qualid_of_sp : full_path -> qualid (** = qualid_of_path *) -[@@ocaml.deprecated "Alias for qualid_of_sp"] diff --git a/library/library.mllib b/library/library.mllib index e43bfb5a1..2ac4266fc 100644 --- a/library/library.mllib +++ b/library/library.mllib @@ -4,6 +4,7 @@ Libobject Summary Nametab Global +Decl_kinds Lib Declaremods Loadpath diff --git a/library/nametab.ml b/library/nametab.ml index 2046bf758..995f44706 100644 --- a/library/nametab.ml +++ b/library/nametab.ml @@ -432,7 +432,6 @@ let full_name_module qid = let locate_section qid = match locate_dir qid with | DirOpenSection { obj_dir; _ } -> obj_dir - | DirClosedSection dir -> dir | _ -> raise Not_found let locate_all qid = diff --git a/library/nametab.mli b/library/nametab.mli index cd28518ab..2ec73a986 100644 --- a/library/nametab.mli +++ b/library/nametab.mli @@ -75,7 +75,7 @@ val error_global_not_found : qualid CAst.t -> 'a type visibility = Until of int | Exactly of int -val push : visibility -> full_path -> global_reference -> unit +val push : visibility -> full_path -> GlobRef.t -> unit val push_modtype : visibility -> full_path -> ModPath.t -> unit val push_dir : visibility -> DirPath.t -> global_dir_reference -> unit val push_syndef : visibility -> full_path -> syndef_name -> unit @@ -91,7 +91,7 @@ val push_universe : visibility -> full_path -> universe_id -> unit (** These functions globalize a (partially) qualified name or fail with [Not_found] *) -val locate : qualid -> global_reference +val locate : qualid -> GlobRef.t val locate_extended : qualid -> extended_global_reference val locate_constant : qualid -> Constant.t val locate_syndef : qualid -> syndef_name @@ -105,20 +105,20 @@ val locate_universe : qualid -> universe_id references, like [locate] and co, but raise a nice error message in case of failure *) -val global : reference -> global_reference +val global : reference -> GlobRef.t val global_inductive : reference -> inductive (** These functions locate all global references with a given suffix; if [qualid] is valid as such, it comes first in the list *) -val locate_all : qualid -> global_reference list +val locate_all : qualid -> GlobRef.t list val locate_extended_all : qualid -> extended_global_reference list val locate_extended_all_dir : qualid -> global_dir_reference list val locate_extended_all_modtype : qualid -> ModPath.t list (** Mapping a full path to a global reference *) -val global_of_path : full_path -> global_reference +val global_of_path : full_path -> GlobRef.t val extended_global_of_path : full_path -> extended_global_reference (** {6 These functions tell if the given absolute name is already taken } *) @@ -144,7 +144,7 @@ val full_name_module : qualid -> DirPath.t definition, and the (full) dirpath associated to a module path *) val path_of_syndef : syndef_name -> full_path -val path_of_global : global_reference -> full_path +val path_of_global : GlobRef.t -> full_path val dirpath_of_module : ModPath.t -> DirPath.t val path_of_modtype : ModPath.t -> full_path @@ -155,12 +155,12 @@ val path_of_universe : universe_id -> full_path (** Returns in particular the dirpath or the basename of the full path associated to global reference *) -val dirpath_of_global : global_reference -> DirPath.t -val basename_of_global : global_reference -> Id.t +val dirpath_of_global : GlobRef.t -> DirPath.t +val basename_of_global : GlobRef.t -> Id.t (** Printing of global references using names as short as possible. @raise Not_found when the reference is not in the global tables. *) -val pr_global_env : Id.Set.t -> global_reference -> Pp.t +val pr_global_env : Id.Set.t -> GlobRef.t -> Pp.t (** The [shortest_qualid] functions given an object with [user_name] @@ -168,7 +168,7 @@ val pr_global_env : Id.Set.t -> global_reference -> Pp.t Coq.A.B.x that denotes the same object. @raise Not_found for unknown objects. *) -val shortest_qualid_of_global : Id.Set.t -> global_reference -> qualid +val shortest_qualid_of_global : Id.Set.t -> GlobRef.t -> qualid val shortest_qualid_of_syndef : Id.Set.t -> syndef_name -> qualid val shortest_qualid_of_modtype : ModPath.t -> qualid val shortest_qualid_of_module : ModPath.t -> qualid @@ -177,7 +177,7 @@ val shortest_qualid_of_universe : universe_id -> qualid (** Deprecated synonyms *) val extended_locate : qualid -> extended_global_reference (*= locate_extended *) -val absolute_reference : full_path -> global_reference (** = global_of_path *) +val absolute_reference : full_path -> GlobRef.t (** = global_of_path *) (** {5 Generic name handling} *) diff --git a/library/summary.ml b/library/summary.ml index 7ef19fbfb..9b2294591 100644 --- a/library/summary.ml +++ b/library/summary.ml @@ -75,20 +75,6 @@ let freeze_summaries ~marshallable : frozen = ml_module = Option.map (fun decl -> decl.freeze_function marshallable) !sum_mod; } -let unfreeze_single name state = - let decl = - try String.Map.find name !sum_map - with - | Not_found -> - CErrors.anomaly Pp.(str "trying to unfreeze unregistered summary " ++ str name) - in - try decl.unfreeze_function state - with e when CErrors.noncritical e -> - let e = CErrors.push e in - Feedback.msg_warning - Pp.(seq [str "Error unfreezing summary "; str name; fnl (); CErrors.iprint e]); - iraise e - let warn_summary_out_of_scope = let name = "summary-out-of-scope" in let category = "dev" in @@ -142,36 +128,6 @@ let remove_from_summary st tag = let summaries = String.Map.remove id st.summaries in {st with summaries} -(** Selective freeze *) - -type frozen_bits = Dyn.t String.Map.t - -let freeze_summary ~marshallable ?(complement=false) ids = - let sub_map = String.Map.filter (fun id _ -> complement <> List.(mem id ids)) !sum_map in - String.Map.map (fun decl -> decl.freeze_function marshallable) sub_map - -let unfreeze_summary = String.Map.iter unfreeze_single - -let surgery_summary { summaries; ml_module } bits = - let summaries = - String.Map.fold (fun hash state sum -> String.Map.set hash state sum ) summaries bits in - { summaries; ml_module } - -let project_summary { summaries; ml_module } ?(complement=false) ids = - String.Map.filter (fun name _ -> complement <> List.(mem name ids)) summaries - -let pointer_equal l1 l2 = - let ptr_equal d1 d2 = - let Dyn.Dyn (t1, x1) = d1 in - let Dyn.Dyn (t2, x2) = d2 in - match Dyn.eq t1 t2 with - | None -> false - | Some Refl -> x1 == x2 - in - let l1, l2 = String.Map.bindings l1, String.Map.bindings l2 in - CList.for_all2eq - (fun (id1,v1) (id2,v2) -> id1 = id2 && ptr_equal v1 v2) l1 l2 - (** All-in-one reference declaration + registration *) let ref_tag ?(freeze=fun _ r -> r) ~name x = diff --git a/library/summary.mli b/library/summary.mli index ed6c26b19..7d91a7918 100644 --- a/library/summary.mli +++ b/library/summary.mli @@ -91,25 +91,5 @@ val modify_summary : frozen -> 'a Dyn.tag -> 'a -> frozen val project_from_summary : frozen -> 'a Dyn.tag -> 'a val remove_from_summary : frozen -> 'a Dyn.tag -> frozen -(** The type [frozen_bits] is a snapshot of some of the registered - tables. It is DEPRECATED in favor of the typed projection - version. *) - -type frozen_bits -[@@ocaml.deprecated "Please use the typed version of summary projection"] - -[@@@ocaml.warning "-3"] -val freeze_summary : marshallable:marshallable -> ?complement:bool -> string list -> frozen_bits -[@@ocaml.deprecated "Please use the typed version of summary projection"] -val unfreeze_summary : frozen_bits -> unit -[@@ocaml.deprecated "Please use the typed version of summary projection"] -val surgery_summary : frozen -> frozen_bits -> frozen -[@@ocaml.deprecated "Please use the typed version of summary projection"] -val project_summary : frozen -> ?complement:bool -> string list -> frozen_bits -[@@ocaml.deprecated "Please use the typed version of summary projection"] -val pointer_equal : frozen_bits -> frozen_bits -> bool -[@@ocaml.deprecated "Please use the typed version of summary projection"] -[@@@ocaml.warning "+3"] - (** {6 Debug} *) val dump : unit -> (int * string) list diff --git a/man/coqtop.1 b/man/coqtop.1 index b1fbb3262..084adfe45 100644 --- a/man/coqtop.1 +++ b/man/coqtop.1 @@ -110,7 +110,7 @@ print Coq version and exit .TP .B \-q -skip loading of rcfile +skip loading of rcfile (resource file) if any .TP .BI \-init\-file \ filename diff --git a/intf/extend.ml b/parsing/extend.ml index 734b859f6..6805a96ed 100644 --- a/intf/extend.ml +++ b/parsing/extend.ml @@ -31,11 +31,6 @@ type production_level = | NextLevel | NumLevel of int -type constr_as_binder_kind = - | AsIdent - | AsIdentOrPattern - | AsStrictPattern - (** User-level types used to tell how to parse or interpret of the non-terminal *) type 'a constr_entry_key_gen = @@ -44,7 +39,7 @@ type 'a constr_entry_key_gen = | ETBigint | ETBinder of bool (* open list of binders if true, closed list of binders otherwise *) | ETConstr of 'a - | ETConstrAsBinder of constr_as_binder_kind * 'a + | ETConstrAsBinder of Notation_term.constr_as_binder_kind * 'a | ETPattern of bool * int option (* true = strict pattern, i.e. not a single variable *) | ETOther of string * string @@ -121,7 +116,7 @@ and 'a rules = type 'a production_rule = | Rule : ('a, 'act, Loc.t -> 'a) rule * 'act -> 'a production_rule -type 'a single_extend_statment = +type 'a single_extend_statement = string option * (** Level *) gram_assoc option * @@ -129,6 +124,6 @@ type 'a single_extend_statment = 'a production_rule list (** Symbol list with the interpretation function *) -type 'a extend_statment = +type 'a extend_statement = gram_position option * - 'a single_extend_statment list + 'a single_extend_statement list diff --git a/parsing/g_constr.ml4 b/parsing/g_constr.ml4 index 9c2806bea..94149a085 100644 --- a/parsing/g_constr.ml4 +++ b/parsing/g_constr.ml4 @@ -9,12 +9,14 @@ (************************************************************************) open Names +open Constr open Libnames +open Glob_term open Constrexpr open Constrexpr_ops open Util open Tok -open Misctypes +open Namegen open Decl_kinds open Pcoq diff --git a/parsing/g_prim.ml4 b/parsing/g_prim.ml4 index b25ea766a..08bcd0f8c 100644 --- a/parsing/g_prim.ml4 +++ b/parsing/g_prim.ml4 @@ -85,8 +85,8 @@ GEXTEND Gram [ [ s = ne_string; sc = OPT ["%"; key = IDENT -> key ] -> (s, sc) ] ] ; smart_global: - [ [ c = reference -> CAst.make ~loc:!@loc @@ Misctypes.AN c - | ntn = by_notation -> CAst.make ~loc:!@loc @@ Misctypes.ByNotation ntn ] ] + [ [ c = reference -> CAst.make ~loc:!@loc @@ Constrexpr.AN c + | ntn = by_notation -> CAst.make ~loc:!@loc @@ Constrexpr.ByNotation ntn ] ] ; qualid: [ [ qid = basequalid -> CAst.make ~loc:!@loc qid ] ] diff --git a/parsing/notation_gram.ml b/parsing/notation_gram.ml new file mode 100644 index 000000000..346350641 --- /dev/null +++ b/parsing/notation_gram.ml @@ -0,0 +1,42 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +open Names +open Extend + +(** Dealing with precedences *) + +type precedence = int +type parenRelation = L | E | Any | Prec of precedence +type tolerability = precedence * parenRelation + +type level = precedence * tolerability list * constr_entry_key list + +type grammar_constr_prod_item = + | GramConstrTerminal of Tok.t + | GramConstrNonTerminal of Extend.constr_prod_entry_key * Id.t option + | GramConstrListMark of int * bool * int + (* tells action rule to make a list of the n previous parsed items; + concat with last parsed list when true; additionally release + the p last items as if they were parsed autonomously *) + +(** Grammar rules for a notation *) + +type one_notation_grammar = { + notgram_level : level; + notgram_assoc : Extend.gram_assoc option; + notgram_notation : Constrexpr.notation; + notgram_prods : grammar_constr_prod_item list list; +} + +type notation_grammar = { + notgram_onlyprinting : bool; + notgram_rules : one_notation_grammar list +} diff --git a/parsing/notgram_ops.ml b/parsing/notgram_ops.ml new file mode 100644 index 000000000..071e6db20 --- /dev/null +++ b/parsing/notgram_ops.ml @@ -0,0 +1,65 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +open Pp +open CErrors +open Util +open Extend +open Notation_gram + +(* Uninterpreted notation levels *) + +let notation_level_map = Summary.ref ~name:"notation_level_map" String.Map.empty + +let declare_notation_level ?(onlyprint=false) ntn level = + if String.Map.mem ntn !notation_level_map then + anomaly (str "Notation " ++ str ntn ++ str " is already assigned a level."); + notation_level_map := String.Map.add ntn (level,onlyprint) !notation_level_map + +let level_of_notation ?(onlyprint=false) ntn = + let (level,onlyprint') = String.Map.find ntn !notation_level_map in + if onlyprint' && not onlyprint then raise Not_found; + level + +(**********************************************************************) +(* Operations on scopes *) + +let parenRelation_eq t1 t2 = match t1, t2 with +| L, L | E, E | Any, Any -> true +| Prec l1, Prec l2 -> Int.equal l1 l2 +| _ -> false + +let production_level_eq l1 l2 = true (* (l1 = l2) *) + +let production_position_eq pp1 pp2 = true (* pp1 = pp2 *) (* match pp1, pp2 with +| NextLevel, NextLevel -> true +| NumLevel n1, NumLevel n2 -> Int.equal n1 n2 +| (NextLevel | NumLevel _), _ -> false *) + +let constr_entry_key_eq eq v1 v2 = match v1, v2 with +| ETName, ETName -> true +| ETReference, ETReference -> true +| ETBigint, ETBigint -> true +| ETBinder b1, ETBinder b2 -> b1 == b2 +| ETConstr lev1, ETConstr lev2 -> eq lev1 lev2 +| ETConstrAsBinder (bk1,lev1), ETConstrAsBinder (bk2,lev2) -> eq lev1 lev2 && bk1 = bk2 +| ETPattern (b1,n1), ETPattern (b2,n2) -> b1 = b2 && Option.equal Int.equal n1 n2 +| ETOther (s1,s1'), ETOther (s2,s2') -> String.equal s1 s2 && String.equal s1' s2' +| (ETName | ETReference | ETBigint | ETBinder _ | ETConstr _ | ETPattern _ | ETOther _ | ETConstrAsBinder _), _ -> false + +let level_eq_gen strict (l1, t1, u1) (l2, t2, u2) = + let tolerability_eq (i1, r1) (i2, r2) = Int.equal i1 i2 && parenRelation_eq r1 r2 in + let prod_eq (l1,pp1) (l2,pp2) = + if strict then production_level_eq l1 l2 && production_position_eq pp1 pp2 + else production_level_eq l1 l2 in + Int.equal l1 l2 && List.equal tolerability_eq t1 t2 + && List.equal (constr_entry_key_eq prod_eq) u1 u2 + +let level_eq = level_eq_gen false diff --git a/parsing/notgram_ops.mli b/parsing/notgram_ops.mli new file mode 100644 index 000000000..f427a607b --- /dev/null +++ b/parsing/notgram_ops.mli @@ -0,0 +1,20 @@ +(************************************************************************) +(* * 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) *) +(************************************************************************) + +(* Merge with metasyntax? *) +open Constrexpr +open Notation_gram + +val level_eq : level -> level -> bool + +(** {6 Declare and test the level of a (possibly uninterpreted) notation } *) + +val declare_notation_level : ?onlyprint:bool -> notation -> level -> unit +val level_of_notation : ?onlyprint:bool -> notation -> level (** raise [Not_found] if no level or not respecting onlyprint *) diff --git a/parsing/parsing.mllib b/parsing/parsing.mllib index 1f29636b2..2154f2f88 100644 --- a/parsing/parsing.mllib +++ b/parsing/parsing.mllib @@ -1,9 +1,9 @@ Tok CLexer +Extend +Notation_gram +Ppextend +Notgram_ops Pcoq -Egramml -Egramcoq G_constr -G_vernac G_prim -G_proofs diff --git a/parsing/pcoq.ml b/parsing/pcoq.ml index 258c4bb11..6fdd9ea9b 100644 --- a/parsing/pcoq.ml +++ b/parsing/pcoq.ml @@ -79,10 +79,10 @@ module type S = type symbol = Tok.t Gramext.g_symbol type action = Gramext.g_action type production_rule = symbol list * action - type single_extend_statment = + type single_extend_statement = string option * Gramext.g_assoc option * production_rule list - type extend_statment = - Gramext.position option * single_extend_statment list + type extend_statement = + Gramext.position option * single_extend_statement list type coq_parsable val parsable : ?file:Loc.source -> char Stream.t -> coq_parsable @@ -105,10 +105,10 @@ end with type 'a Entry.e = 'a Grammar.GMake(CLexer).Entry.e = struct type symbol = Tok.t Gramext.g_symbol type action = Gramext.g_action type production_rule = symbol list * action - type single_extend_statment = + type single_extend_statement = string option * Gramext.g_assoc option * production_rule list - type extend_statment = - Gramext.position option * single_extend_statment list + type extend_statement = + Gramext.position option * single_extend_statement list type coq_parsable = parsable * CLexer.lexer_state ref @@ -145,7 +145,6 @@ end with type 'a Entry.e = 'a Grammar.GMake(CLexer).Entry.e = struct end - let warning_verbose = Gramext.warning_verbose let of_coq_assoc = function @@ -208,9 +207,9 @@ let camlp5_verbosity silent f x = (** Grammar extensions *) -(** NB: [extend_statment = - gram_position option * single_extend_statment list] - and [single_extend_statment = +(** NB: [extend_statement = + gram_position option * single_extend_statement list] + and [single_extend_statement = string option * gram_assoc option * production_rule list] and [production_rule = symbol list * action] @@ -264,7 +263,7 @@ let of_coq_extend_statement (pos, st) = type gram_reinit = gram_assoc * gram_position type extend_rule = -| ExtendRule : 'a G.entry * gram_reinit option * 'a extend_statment -> extend_rule +| ExtendRule : 'a G.entry * gram_reinit option * 'a extend_statement -> extend_rule type ext_kind = | ByGrammar of extend_rule @@ -387,7 +386,6 @@ let create_universe u = let uprim = create_universe "prim" let uconstr = create_universe "constr" let utactic = create_universe "tactic" -let uvernac = create_universe "vernac" let get_univ u = if Hashtbl.mem utables u then u @@ -493,44 +491,6 @@ module Module = let module_type = Gram.entry_create "module_type" end -module Vernac_ = - struct - let gec_vernac s = Gram.entry_create ("vernac:" ^ s) - - (* The different kinds of vernacular commands *) - let gallina = gec_vernac "gallina" - let gallina_ext = gec_vernac "gallina_ext" - let command = gec_vernac "command" - let syntax = gec_vernac "syntax_command" - let vernac_control = gec_vernac "Vernac.vernac_control" - let rec_definition = gec_vernac "Vernac.rec_definition" - let red_expr = make_gen_entry utactic "red_expr" - let hint_info = gec_vernac "hint_info" - (* Main vernac entry *) - let main_entry = Gram.entry_create "vernac" - let noedit_mode = gec_vernac "noedit_command" - - let () = - let act_vernac = Gram.action (fun v loc -> Some (to_coqloc loc, v)) in - let act_eoi = Gram.action (fun _ loc -> None) in - let rule = [ - ([ Symbols.stoken Tok.EOI ], act_eoi); - ([ Symbols.snterm (Gram.Entry.obj vernac_control) ], act_vernac ); - ] in - uncurry (Gram.extend main_entry) (None, make_rule rule) - - let command_entry_ref = ref noedit_mode - let command_entry = - Gram.Entry.of_parser "command_entry" - (fun strm -> Gram.parse_tokens_after_filter !command_entry_ref strm) - - end - -let main_entry = Vernac_.main_entry - -let set_command_entry e = Vernac_.command_entry_ref := e -let get_command_entry () = !Vernac_.command_entry_ref - let epsilon_value f e = let r = Rule (Next (Stop, e), fun x _ -> f x) in let ext = of_coq_extend_statement (None, [None, None, [r]]) in @@ -635,7 +595,6 @@ let () = Grammar.register0 wit_ref (Prim.reference); Grammar.register0 wit_sort_family (Constr.sort_family); Grammar.register0 wit_constr (Constr.constr); - Grammar.register0 wit_red_expr (Vernac_.red_expr); () (** Registering extra grammar *) diff --git a/parsing/pcoq.mli b/parsing/pcoq.mli index 9f186224b..9a45bc973 100644 --- a/parsing/pcoq.mli +++ b/parsing/pcoq.mli @@ -10,12 +10,9 @@ open Names open Extend -open Vernacexpr open Genarg open Constrexpr open Libnames -open Misctypes -open Genredexpr (** The parser of Coq *) @@ -67,10 +64,10 @@ module type S = type symbol = Tok.t Gramext.g_symbol type action = Gramext.g_action type production_rule = symbol list * action - type single_extend_statment = + type single_extend_statement = string option * Gramext.g_assoc option * production_rule list - type extend_statment = - Gramext.position option * single_extend_statment list + type extend_statement = + Gramext.position option * single_extend_statement list type coq_parsable @@ -89,6 +86,12 @@ module type S = end with type 'a Entry.e = 'a Grammar.GMake(CLexer).Entry.e +module Symbols : sig + + val stoken : Tok.t -> Gram.symbol + val snterm : Gram.internal_entry -> Gram.symbol +end + (** The parser of Coq is built from three kinds of rule declarations: - dynamic rules declared at the evaluation of Coq files (using @@ -177,11 +180,14 @@ val map_entry : ('a -> 'b) -> 'a Gram.entry -> 'b Gram.entry type gram_universe val get_univ : string -> gram_universe +val create_universe : string -> gram_universe + +val new_entry : gram_universe -> string -> 'a Gram.entry val uprim : gram_universe val uconstr : gram_universe val utactic : gram_universe -val uvernac : gram_universe + val register_grammar : ('raw, 'glb, 'top) genarg_type -> 'raw Gram.entry -> unit val genarg_grammar : ('raw, 'glb, 'top) genarg_type -> 'raw Gram.entry @@ -227,8 +233,8 @@ module Constr : val operconstr : constr_expr Gram.entry val ident : Id.t Gram.entry val global : reference Gram.entry - val universe_level : glob_level Gram.entry - val sort : glob_sort Gram.entry + val universe_level : Glob_term.glob_level Gram.entry + val sort : Glob_term.glob_sort Gram.entry val sort_family : Sorts.family Gram.entry val pattern : cases_pattern_expr Gram.entry val constr_pattern : constr_expr Gram.entry @@ -249,27 +255,6 @@ module Module : val module_type : module_ast Gram.entry end -module Vernac_ : - sig - val gallina : vernac_expr Gram.entry - val gallina_ext : vernac_expr Gram.entry - val command : vernac_expr Gram.entry - val syntax : vernac_expr Gram.entry - val vernac_control : vernac_control Gram.entry - val rec_definition : (fixpoint_expr * decl_notation list) Gram.entry - val noedit_mode : vernac_expr Gram.entry - val command_entry : vernac_expr Gram.entry - val red_expr : raw_red_expr Gram.entry - val hint_info : Vernacexpr.hint_info_expr Gram.entry - end - -(** The main entry: reads an optional vernac command *) -val main_entry : (Loc.t * vernac_control) option Gram.entry - -(** Handling of the proof mode entry *) -val get_command_entry : unit -> vernac_expr Gram.entry -val set_command_entry : vernac_expr Gram.entry -> unit - val epsilon_value : ('a -> 'self) -> ('self, 'a) Extend.symbol -> 'self option (** {5 Extending the parser without synchronization} *) @@ -278,7 +263,7 @@ type gram_reinit = gram_assoc * gram_position (** Type of reinitialization data *) val grammar_extend : 'a Gram.entry -> gram_reinit option -> - 'a Extend.extend_statment -> unit + 'a Extend.extend_statement -> unit (** Extend the grammar of Coq, without synchronizing it with the backtracking mechanism. This means that grammar extensions defined this way will survive an undo. *) @@ -293,7 +278,7 @@ type 'a grammar_command marshallable. *) type extend_rule = -| ExtendRule : 'a Gram.entry * gram_reinit option * 'a extend_statment -> extend_rule +| ExtendRule : 'a Gram.entry * gram_reinit option * 'a extend_statement -> extend_rule type 'a grammar_extension = 'a -> GramState.t -> extend_rule list * GramState.t (** Grammar extension entry point. Given some ['a] and a current grammar state, diff --git a/interp/ppextend.ml b/parsing/ppextend.ml index c75d9e12f..d2b50fa83 100644 --- a/interp/ppextend.ml +++ b/parsing/ppextend.ml @@ -8,8 +8,10 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) +open Util open Pp -open Notation_term +open CErrors +open Notation_gram (*s Pretty-print. *) @@ -41,3 +43,34 @@ type unparsing = | UnpTerminal of string | UnpBox of ppbox * unparsing Loc.located list | UnpCut of ppcut + +type unparsing_rule = unparsing list * precedence +type extra_unparsing_rules = (string * string) list +(* Concrete syntax for symbolic-extension table *) +let notation_rules = + Summary.ref ~name:"notation-rules" (String.Map.empty : (unparsing_rule * extra_unparsing_rules * notation_grammar) String.Map.t) + +let declare_notation_rule ntn ~extra unpl gram = + notation_rules := String.Map.add ntn (unpl,extra,gram) !notation_rules + +let find_notation_printing_rule ntn = + try pi1 (String.Map.find ntn !notation_rules) + with Not_found -> anomaly (str "No printing rule found for " ++ str ntn ++ str ".") +let find_notation_extra_printing_rules ntn = + try pi2 (String.Map.find ntn !notation_rules) + with Not_found -> [] +let find_notation_parsing_rules ntn = + try pi3 (String.Map.find ntn !notation_rules) + with Not_found -> anomaly (str "No parsing rule found for " ++ str ntn ++ str ".") + +let get_defined_notations () = + String.Set.elements @@ String.Map.domain !notation_rules + +let add_notation_extra_printing_rule ntn k v = + try + notation_rules := + let p, pp, gr = String.Map.find ntn !notation_rules in + String.Map.add ntn (p, (k,v) :: pp, gr) !notation_rules + with Not_found -> + user_err ~hdr:"add_notation_extra_printing_rule" + (str "No such Notation.") diff --git a/interp/ppextend.mli b/parsing/ppextend.mli index c81058e72..9f61e121a 100644 --- a/interp/ppextend.mli +++ b/parsing/ppextend.mli @@ -8,7 +8,8 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) -open Notation_term +open Constrexpr +open Notation_gram (** {6 Pretty-print. } *) @@ -26,6 +27,9 @@ val ppcmd_of_box : ppbox -> Pp.t -> Pp.t val ppcmd_of_cut : ppcut -> Pp.t +(** {6 Printing rules for notations} *) + +(** Declare and look for the printing rule for symbolic notations *) type unparsing = | UnpMetaVar of int * parenRelation | UnpBinderMetaVar of int * parenRelation @@ -34,3 +38,15 @@ type unparsing = | UnpTerminal of string | UnpBox of ppbox * unparsing Loc.located list | UnpCut of ppcut + +type unparsing_rule = unparsing list * precedence +type extra_unparsing_rules = (string * string) list + +val declare_notation_rule : notation -> extra:extra_unparsing_rules -> unparsing_rule -> notation_grammar -> unit +val find_notation_printing_rule : notation -> unparsing_rule +val find_notation_extra_printing_rules : notation -> extra_unparsing_rules +val find_notation_parsing_rules : notation -> notation_grammar +val add_notation_extra_printing_rule : notation -> string -> string -> unit + +(** Returns notations with defined parsing/printing rules *) +val get_defined_notations : unit -> notation list diff --git a/plugins/btauto/refl_btauto.ml b/plugins/btauto/refl_btauto.ml index a09abfa19..c2bc8c079 100644 --- a/plugins/btauto/refl_btauto.ml +++ b/plugins/btauto/refl_btauto.ml @@ -1,12 +1,24 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +open Constr + let contrib_name = "btauto" let init_constant dir s = let find_constant contrib dir s = - Universes.constr_of_global (Coqlib.find_reference contrib dir s) + UnivGen.constr_of_global (Coqlib.find_reference contrib dir s) in find_constant contrib_name dir s -let get_constant dir s = lazy (Universes.constr_of_global @@ Coqlib.coq_reference contrib_name dir s) +let get_constant dir s = lazy (UnivGen.constr_of_global @@ Coqlib.coq_reference contrib_name dir s) let get_inductive dir s = let glob_ref () = Coqlib.find_reference contrib_name ("Coq" :: dir) s in @@ -106,7 +118,7 @@ module Bool = struct let negb = Lazy.force negb in let rec aux c = match decomp_term sigma c with - | Term.App (head, args) -> + | App (head, args) -> if head === andb && Array.length args = 2 then Andb (aux args.(0), aux args.(1)) else if head === orb && Array.length args = 2 then @@ -116,9 +128,9 @@ module Bool = struct else if head === negb && Array.length args = 1 then Negb (aux args.(0)) else Var (Env.add env c) - | Term.Case (info, r, arg, pats) -> + | Case (info, r, arg, pats) -> let is_bool = - let i = info.Term.ci_ind in + let i = info.ci_ind in Names.eq_ind i (Lazy.force ind) in if is_bool then @@ -176,9 +188,9 @@ module Btauto = struct let _, var = Tacmach.pf_reduction_of_red_expr gl (Genredexpr.CbvVm None) var in let var = EConstr.Unsafe.to_constr var in let rec to_list l = match decomp_term (Tacmach.project gl) l with - | Term.App (c, _) + | App (c, _) when c === (Lazy.force CoqList._nil) -> [] - | Term.App (c, [|_; h; t|]) + | App (c, [|_; h; t|]) when c === (Lazy.force CoqList._cons) -> if h === (Lazy.force Bool.trueb) then (true :: to_list t) else if h === (Lazy.force Bool.falseb) then (false :: to_list t) @@ -218,7 +230,7 @@ module Btauto = struct let concl = EConstr.Unsafe.to_constr concl in let t = decomp_term (Tacmach.New.project gl) concl in match t with - | Term.App (c, [|typ; p; _|]) when c === eq -> + | App (c, [|typ; p; _|]) when c === eq -> (* should be an equality [@eq poly ?p (Cst false)] *) let tac = Tacticals.New.tclORELSE0 Tactics.reflexivity (Proofview.V82.tactic (print_counterexample p env)) in tac @@ -236,7 +248,7 @@ module Btauto = struct let bool = Lazy.force Bool.typ in let t = decomp_term sigma concl in match t with - | Term.App (c, [|typ; tl; tr|]) + | App (c, [|typ; tl; tr|]) when typ === bool && c === eq -> let env = Env.empty () in let fl = Bool.quote env sigma tl in diff --git a/plugins/cc/ccalgo.ml b/plugins/cc/ccalgo.ml index 5a4818926..4c6156a38 100644 --- a/plugins/cc/ccalgo.ml +++ b/plugins/cc/ccalgo.ml @@ -9,7 +9,7 @@ (************************************************************************) (* This file implements the basic congruence-closure algorithm by *) -(* Downey,Sethi and Tarjan. *) +(* Downey, Sethi and Tarjan. *) (* Plus some e-matching and constructor handling by P. Corbineau *) open CErrors @@ -18,7 +18,6 @@ open Names open Sorts open Constr open Vars -open Evd open Goptions open Tacmach open Util @@ -272,7 +271,8 @@ type state = mutable rew_depth:int; mutable changed:bool; by_type: Int.Set.t Typehash.t; - mutable gls:Goal.goal Evd.sigma} + mutable env:Environ.env; + sigma:Evd.evar_map} let dummy_node = { @@ -307,7 +307,8 @@ let empty depth gls:state = rew_depth=depth; by_type=Constrhash.create init_size; changed=false; - gls=gls + env=pf_env gls; + sigma=project gls } let forest state = state.uf @@ -426,7 +427,7 @@ let cc_product s1 s2 = mkLambda(_B_,mkSort(s2),_body_)) let rec constr_of_term = function - Symb s-> applist_projection s [] + Symb s-> s | Product(s1,s2) -> cc_product s1 s2 | Eps id -> mkVar id | Constructor cinfo -> mkConstructU cinfo.ci_constr @@ -434,25 +435,7 @@ let rec constr_of_term = function make_app [(constr_of_term s2)] s1 and make_app l=function Appli (s1,s2)->make_app ((constr_of_term s2)::l) s1 - | other -> - applist_proj other l -and applist_proj c l = - match c with - | Symb s -> applist_projection s l - | _ -> Term.applistc (constr_of_term c) l -and applist_projection c l = - match Constr.kind c with - | Const c when Environ.is_projection (fst c) (Global.env()) -> - let p = Projection.make (fst c) false in - (match l with - | [] -> (* Expand the projection *) - let ty = Typeops.type_of_constant_in (Global.env ()) c in (* FIXME constraints *) - let pb = Environ.lookup_projection p (Global.env()) in - let ctx,_ = Term.decompose_prod_n_assum (pb.Declarations.proj_npars + 1) ty in - Term.it_mkLambda_or_LetIn (mkProj(p,mkRel 1)) ctx - | hd :: tl -> - Term.applistc (mkProj (p, hd)) tl) - | _ -> Term.applistc c l + | other -> Term.applist (constr_of_term other,l) let rec canonize_name sigma c = let c = EConstr.Unsafe.to_constr c in @@ -474,7 +457,7 @@ let rec canonize_name sigma c = | LetIn (na,b,t,ct) -> mkLetIn (na, func b,func t,func ct) | App (ct,l) -> - mkApp (func ct,Array.smartmap func l) + mkApp (func ct,Array.Smart.map func l) | Proj(p,c) -> let p' = Projection.map (fun kn -> Constant.make1 (Constant.canonical kn)) p in @@ -511,8 +494,8 @@ let rec add_term state t= Not_found -> let b=next uf in let trm = constr_of_term t in - let typ = pf_unsafe_type_of state.gls (EConstr.of_constr trm) in - let typ = canonize_name (project state.gls) typ in + let typ = Typing.unsafe_type_of state.env state.sigma (EConstr.of_constr trm) in + let typ = canonize_name state.sigma typ in let new_node= match t with Symb _ | Product (_,_) -> @@ -820,11 +803,10 @@ let one_step state = let __eps__ = Id.of_string "_eps_" let new_state_var typ state = - let id = pf_get_new_id __eps__ state.gls in - let {it=gl ; sigma=sigma} = state.gls in - let gls = Goal.V82.new_goal_with sigma gl [Context.Named.Declaration.LocalAssum (id,typ)] in - state.gls<- gls; - id + 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; + id let complete_one_class state i= match (get_representative state.uf i).inductive_status with @@ -832,9 +814,9 @@ let complete_one_class state i= let rec app t typ n = if n<=0 then t else let _,etyp,rest= destProd typ in - let id = new_state_var etyp state in + let id = new_state_var (EConstr.of_constr etyp) state in app (Appli(t,Eps id)) (substl [mkVar id] rest) (n-1) in - let _c = pf_unsafe_type_of state.gls + 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 let _args = diff --git a/plugins/cc/cctac.ml b/plugins/cc/cctac.ml index d19817e74..04ff11fc4 100644 --- a/plugins/cc/cctac.ml +++ b/plugins/cc/cctac.ml @@ -49,7 +49,7 @@ let whd_delta env sigma t = (* decompose member of equality in an applicative format *) (** FIXME: evar leak *) -let sf_of env sigma c = e_sort_of env (ref sigma) c +let sf_of env sigma c = snd (sort_of env sigma c) let rec decompose_term env sigma t= match EConstr.kind sigma (whd env sigma t) with @@ -90,7 +90,7 @@ let rec decompose_term env sigma t= decompose_term env sigma c | _ -> let t = Termops.strip_outer_cast sigma t in - if closed0 sigma t then Symb (EConstr.to_constr sigma t) else raise Not_found + if closed0 sigma t then Symb (EConstr.to_constr ~abort_on_undefined_evars:false sigma t) else raise Not_found (* decompose equality in members and type *) open Termops @@ -264,9 +264,8 @@ let app_global_with_holes f args n = let ans = mkApp (fc, args) in let (sigma, holes) = gen_holes env sigma t n [] in let ans = applist (ans, holes) in - let evdref = ref sigma in - let () = Typing.e_check env evdref ans concl in - (!evdref, ans) + let sigma = Typing.check env sigma ans concl in + (sigma, ans) end end @@ -444,7 +443,7 @@ let cc_tactic depth additionnal_terms = let open Glob_term in let env = Proofview.Goal.env gl in let terms_to_complete = List.map (build_term_to_complete uf) (epsilons uf) in - let hole = DAst.make @@ GHole (Evar_kinds.InternalHole, Misctypes.IntroAnonymous, None) in + let hole = DAst.make @@ GHole (Evar_kinds.InternalHole, Namegen.IntroAnonymous, None) in let pr_missing (c, missing) = let c = Detyping.detype Detyping.Now ~lax:true false Id.Set.empty env sigma c in let holes = List.init missing (fun _ -> hole) in diff --git a/plugins/derive/derive.ml b/plugins/derive/derive.ml index 8a55538bd..480819ebe 100644 --- a/plugins/derive/derive.ml +++ b/plugins/derive/derive.ml @@ -61,7 +61,7 @@ let start_deriving f suchthat lemma = | Proved (opaque, None, obj) -> match Proof_global.(obj.entries) with | [_;f_def;lemma_def] -> - opaque <> Vernacexpr.Transparent , f_def , lemma_def + opaque <> Proof_global.Transparent , f_def , lemma_def | _ -> assert false in (** The opacity of [f_def] is adjusted to be [false], as it diff --git a/plugins/extraction/common.mli b/plugins/extraction/common.mli index 78545c8bd..07237d750 100644 --- a/plugins/extraction/common.mli +++ b/plugins/extraction/common.mli @@ -9,7 +9,6 @@ (************************************************************************) open Names -open Globnames open Miniml (** By default, in module Format, you can do horizontal placing of blocks @@ -54,7 +53,7 @@ val opened_libraries : unit -> ModPath.t list type kind = Term | Type | Cons | Mod -val pp_global : kind -> global_reference -> string +val pp_global : kind -> GlobRef.t -> string val pp_module : ModPath.t -> string val top_visible_mp : unit -> ModPath.t diff --git a/plugins/extraction/extract_env.ml b/plugins/extraction/extract_env.ml index 397cb2920..1e0589fac 100644 --- a/plugins/extraction/extract_env.ml +++ b/plugins/extraction/extract_env.ml @@ -79,7 +79,7 @@ module type VISIT = sig (* Add reference / ... in the visit lists. These functions silently add the mp of their arg in the mp list *) - val add_ref : global_reference -> unit + val add_ref : GlobRef.t -> unit val add_kn : KerName.t -> unit val add_decl_deps : ml_decl -> unit val add_spec_deps : ml_spec -> unit @@ -646,7 +646,7 @@ let separate_extraction lr = is \verb!Extraction! [qualid]. *) let simple_extraction r = - Vernacentries.dump_global CAst.(make (Misctypes.AN r)); + Vernacentries.dump_global CAst.(make (Constrexpr.AN r)); match locate_ref [r] with | ([], [mp]) as p -> full_extr None p | [r],[] -> diff --git a/plugins/extraction/extract_env.mli b/plugins/extraction/extract_env.mli index 591d3bb86..77f1fb5ef 100644 --- a/plugins/extraction/extract_env.mli +++ b/plugins/extraction/extract_env.mli @@ -12,7 +12,6 @@ open Names open Libnames -open Globnames val simple_extraction : reference -> unit val full_extraction : string option -> reference list -> unit @@ -26,7 +25,7 @@ val extract_and_compile : reference list -> unit (* For debug / external output via coqtop.byte + Drop : *) val mono_environment : - global_reference list -> ModPath.t list -> Miniml.ml_structure + GlobRef.t list -> ModPath.t list -> Miniml.ml_structure (* Used by the Relation Extraction plugin *) diff --git a/plugins/extraction/extraction.ml b/plugins/extraction/extraction.ml index f25f63624..5aee70194 100644 --- a/plugins/extraction/extraction.ml +++ b/plugins/extraction/extraction.ml @@ -431,7 +431,7 @@ and extract_really_ind env kn mib = let packets = Array.mapi (fun i mip -> - let (_,u),_ = Universes.fresh_inductive_instance env (kn,i) in + let (_,u),_ = UnivGen.fresh_inductive_instance env (kn,i) in let ar = Inductive.type_of_inductive env ((mib,mip),u) in let ar = EConstr.of_constr ar in let info = (fst (flag_of_type env sg ar) = Info) in @@ -1066,8 +1066,10 @@ let extract_constant env kn cb = | Undef _ -> warn_info (); mk_typ_ax () | Def c -> (match cb.const_proj with - | None -> mk_typ (get_body c) - | Some pb -> mk_typ (EConstr.of_constr pb.proj_body)) + | false -> mk_typ (get_body c) + | true -> + let pb = lookup_projection (Projection.make kn false) env in + mk_typ (EConstr.of_constr pb.proj_body)) | OpaqueDef c -> add_opaque r; if access_opaque () then mk_typ (get_opaque env c) @@ -1077,8 +1079,10 @@ let extract_constant env kn cb = | Undef _ -> warn_info (); mk_ax () | Def c -> (match cb.const_proj with - | None -> mk_def (get_body c) - | Some pb -> mk_def (EConstr.of_constr pb.proj_body)) + | false -> mk_def (get_body c) + | true -> + let pb = lookup_projection (Projection.make kn false) env in + mk_def (EConstr.of_constr pb.proj_body)) | OpaqueDef c -> add_opaque r; if access_opaque () then mk_def (get_opaque env c) diff --git a/plugins/extraction/miniml.ml b/plugins/extraction/miniml.ml index e1e49d926..ce920ad6a 100644 --- a/plugins/extraction/miniml.ml +++ b/plugins/extraction/miniml.ml @@ -11,7 +11,6 @@ (*s Target language for extraction: a core ML called MiniML. *) open Names -open Globnames (* The [signature] type is used to know how many arguments a CIC object expects, and what these arguments will become in the ML @@ -26,7 +25,7 @@ open Globnames type kill_reason = | Ktype | Kprop - | Kimplicit of global_reference * int (* n-th arg of a cst or construct *) + | Kimplicit of GlobRef.t * int (* n-th arg of a cst or construct *) type sign = Keep | Kill of kill_reason @@ -39,7 +38,7 @@ type signature = sign list type ml_type = | Tarr of ml_type * ml_type - | Tglob of global_reference * ml_type list + | Tglob of GlobRef.t * ml_type list | Tvar of int | Tvar' of int (* same as Tvar, used to avoid clash *) | Tmeta of ml_meta (* used during ML type reconstruction *) @@ -60,7 +59,7 @@ type inductive_kind = | Singleton | Coinductive | Standard - | Record of global_reference option list (* None for anonymous field *) + | Record of GlobRef.t option list (* None for anonymous field *) (* A [ml_ind_packet] is the miniml counterpart of a [one_inductive_body]. If the inductive is logical ([ip_logical = false]), then all other fields @@ -118,8 +117,8 @@ and ml_ast = | MLapp of ml_ast * ml_ast list | MLlam of ml_ident * ml_ast | MLletin of ml_ident * ml_ast * ml_ast - | MLglob of global_reference - | MLcons of ml_type * global_reference * ml_ast list + | MLglob of GlobRef.t + | MLcons of ml_type * GlobRef.t * ml_ast list | MLtuple of ml_ast list | MLcase of ml_type * ml_ast * ml_branch array | MLfix of int * Id.t array * ml_ast array @@ -129,24 +128,24 @@ and ml_ast = | MLmagic of ml_ast and ml_pattern = - | Pcons of global_reference * ml_pattern list + | Pcons of GlobRef.t * ml_pattern list | Ptuple of ml_pattern list | Prel of int (** Cf. the idents in the branch. [Prel 1] is the last one. *) | Pwild - | Pusual of global_reference (** Shortcut for Pcons (r,[Prel n;...;Prel 1]) **) + | Pusual of GlobRef.t (** Shortcut for Pcons (r,[Prel n;...;Prel 1]) **) (*s ML declarations. *) type ml_decl = | Dind of MutInd.t * ml_ind - | Dtype of global_reference * Id.t list * ml_type - | Dterm of global_reference * ml_ast * ml_type - | Dfix of global_reference array * ml_ast array * ml_type array + | Dtype of GlobRef.t * Id.t list * ml_type + | Dterm of GlobRef.t * ml_ast * ml_type + | Dfix of GlobRef.t array * ml_ast array * ml_type array type ml_spec = | Sind of MutInd.t * ml_ind - | Stype of global_reference * Id.t list * ml_type option - | Sval of global_reference * ml_type + | Stype of GlobRef.t * Id.t list * ml_type option + | Sval of GlobRef.t * ml_type type ml_specif = | Spec of ml_spec diff --git a/plugins/extraction/miniml.mli b/plugins/extraction/miniml.mli index e1e49d926..ce920ad6a 100644 --- a/plugins/extraction/miniml.mli +++ b/plugins/extraction/miniml.mli @@ -11,7 +11,6 @@ (*s Target language for extraction: a core ML called MiniML. *) open Names -open Globnames (* The [signature] type is used to know how many arguments a CIC object expects, and what these arguments will become in the ML @@ -26,7 +25,7 @@ open Globnames type kill_reason = | Ktype | Kprop - | Kimplicit of global_reference * int (* n-th arg of a cst or construct *) + | Kimplicit of GlobRef.t * int (* n-th arg of a cst or construct *) type sign = Keep | Kill of kill_reason @@ -39,7 +38,7 @@ type signature = sign list type ml_type = | Tarr of ml_type * ml_type - | Tglob of global_reference * ml_type list + | Tglob of GlobRef.t * ml_type list | Tvar of int | Tvar' of int (* same as Tvar, used to avoid clash *) | Tmeta of ml_meta (* used during ML type reconstruction *) @@ -60,7 +59,7 @@ type inductive_kind = | Singleton | Coinductive | Standard - | Record of global_reference option list (* None for anonymous field *) + | Record of GlobRef.t option list (* None for anonymous field *) (* A [ml_ind_packet] is the miniml counterpart of a [one_inductive_body]. If the inductive is logical ([ip_logical = false]), then all other fields @@ -118,8 +117,8 @@ and ml_ast = | MLapp of ml_ast * ml_ast list | MLlam of ml_ident * ml_ast | MLletin of ml_ident * ml_ast * ml_ast - | MLglob of global_reference - | MLcons of ml_type * global_reference * ml_ast list + | MLglob of GlobRef.t + | MLcons of ml_type * GlobRef.t * ml_ast list | MLtuple of ml_ast list | MLcase of ml_type * ml_ast * ml_branch array | MLfix of int * Id.t array * ml_ast array @@ -129,24 +128,24 @@ and ml_ast = | MLmagic of ml_ast and ml_pattern = - | Pcons of global_reference * ml_pattern list + | Pcons of GlobRef.t * ml_pattern list | Ptuple of ml_pattern list | Prel of int (** Cf. the idents in the branch. [Prel 1] is the last one. *) | Pwild - | Pusual of global_reference (** Shortcut for Pcons (r,[Prel n;...;Prel 1]) **) + | Pusual of GlobRef.t (** Shortcut for Pcons (r,[Prel n;...;Prel 1]) **) (*s ML declarations. *) type ml_decl = | Dind of MutInd.t * ml_ind - | Dtype of global_reference * Id.t list * ml_type - | Dterm of global_reference * ml_ast * ml_type - | Dfix of global_reference array * ml_ast array * ml_type array + | Dtype of GlobRef.t * Id.t list * ml_type + | Dterm of GlobRef.t * ml_ast * ml_type + | Dfix of GlobRef.t array * ml_ast array * ml_type array type ml_spec = | Sind of MutInd.t * ml_ind - | Stype of global_reference * Id.t list * ml_type option - | Sval of global_reference * ml_type + | Stype of GlobRef.t * Id.t list * ml_type option + | Sval of GlobRef.t * ml_type type ml_specif = | Spec of ml_spec diff --git a/plugins/extraction/mlutil.ml b/plugins/extraction/mlutil.ml index 0656d487a..9f5c1f1a1 100644 --- a/plugins/extraction/mlutil.ml +++ b/plugins/extraction/mlutil.ml @@ -59,7 +59,7 @@ let rec eq_ml_type t1 t2 = match t1, t2 with | Tarr (tl1, tr1), Tarr (tl2, tr2) -> eq_ml_type tl1 tl2 && eq_ml_type tr1 tr2 | Tglob (gr1, t1), Tglob (gr2, t2) -> - eq_gr gr1 gr2 && List.equal eq_ml_type t1 t2 + GlobRef.equal gr1 gr2 && List.equal eq_ml_type t1 t2 | Tvar i1, Tvar i2 -> Int.equal i1 i2 | Tvar' i1, Tvar' i2 -> Int.equal i1 i2 | Tmeta m1, Tmeta m2 -> eq_ml_meta m1 m2 @@ -120,7 +120,7 @@ let rec mgu = function | None -> m.contents <- Some t) | Tarr(a, b), Tarr(a', b') -> mgu (a, a'); mgu (b, b') - | Tglob (r,l), Tglob (r',l') when Globnames.eq_gr r r' -> + | Tglob (r,l), Tglob (r',l') when GlobRef.equal r r' -> List.iter mgu (List.combine l l') | Tdummy _, Tdummy _ -> () | Tvar i, Tvar j when Int.equal i j -> () @@ -270,7 +270,7 @@ let rec var2var' = function | Tglob (r,l) -> Tglob (r, List.map var2var' l) | a -> a -type abbrev_map = global_reference -> ml_type option +type abbrev_map = GlobRef.t -> ml_type option (*s Delta-reduction of type constants everywhere in a ML type [t]. [env] is a function of type [ml_type_env]. *) @@ -381,9 +381,9 @@ let rec eq_ml_ast t1 t2 = match t1, t2 with eq_ml_ident na1 na2 && eq_ml_ast t1 t2 | MLletin (na1, c1, t1), MLletin (na2, c2, t2) -> eq_ml_ident na1 na2 && eq_ml_ast c1 c2 && eq_ml_ast t1 t2 -| MLglob gr1, MLglob gr2 -> eq_gr gr1 gr2 +| MLglob gr1, MLglob gr2 -> GlobRef.equal gr1 gr2 | MLcons (t1, gr1, c1), MLcons (t2, gr2, c2) -> - eq_ml_type t1 t2 && eq_gr gr1 gr2 && List.equal eq_ml_ast c1 c2 + eq_ml_type t1 t2 && GlobRef.equal gr1 gr2 && List.equal eq_ml_ast c1 c2 | MLtuple t1, MLtuple t2 -> List.equal eq_ml_ast t1 t2 | MLcase (t1, c1, p1), MLcase (t2, c2, p2) -> @@ -398,13 +398,13 @@ let rec eq_ml_ast t1 t2 = match t1, t2 with and eq_ml_pattern p1 p2 = match p1, p2 with | Pcons (gr1, p1), Pcons (gr2, p2) -> - eq_gr gr1 gr2 && List.equal eq_ml_pattern p1 p2 + GlobRef.equal gr1 gr2 && List.equal eq_ml_pattern p1 p2 | Ptuple p1, Ptuple p2 -> List.equal eq_ml_pattern p1 p2 | Prel i1, Prel i2 -> Int.equal i1 i2 | Pwild, Pwild -> true -| Pusual gr1, Pusual gr2 -> eq_gr gr1 gr2 +| Pusual gr1, Pusual gr2 -> GlobRef.equal gr1 gr2 | _ -> false and eq_ml_branch (id1, p1, t1) (id2, p2, t2) = @@ -541,24 +541,24 @@ let dump_unused_vars a = | MLcase (t,e,br) -> let e' = ren env e in - let br' = Array.smartmap (ren_branch env) br in + let br' = Array.Smart.map (ren_branch env) br in if e' == e && br' == br then a else MLcase (t,e',br') | MLfix (i,ids,v) -> let env' = List.init (Array.length ids) (fun _ -> ref false) @ env in - let v' = Array.smartmap (ren env') v in + let v' = Array.Smart.map (ren env') v in if v' == v then a else MLfix (i,ids,v') | MLapp (b,l) -> - let b' = ren env b and l' = List.smartmap (ren env) l in + let b' = ren env b and l' = List.Smart.map (ren env) l in if b' == b && l' == l then a else MLapp (b',l') | MLcons(t,r,l) -> - let l' = List.smartmap (ren env) l in + let l' = List.Smart.map (ren env) l in if l' == l then a else MLcons (t,r,l') | MLtuple l -> - let l' = List.smartmap (ren env) l in + let l' = List.Smart.map (ren env) l in if l' == l then a else MLtuple l' | MLmagic b -> @@ -984,7 +984,7 @@ let rec iota_red i lift br ((typ,r,a) as cons) = if i >= Array.length br then raise Impossible; let (ids,p,c) = br.(i) in match p with - | Pusual r' | Pcons (r',_) when not (Globnames.eq_gr r' r) -> iota_red (i+1) lift br cons + | Pusual r' | Pcons (r',_) when not (GlobRef.equal r' r) -> iota_red (i+1) lift br cons | Pusual r' -> let c = named_lams (List.rev ids) c in let c = ast_lift lift c diff --git a/plugins/extraction/mlutil.mli b/plugins/extraction/mlutil.mli index 55a1ee893..d23fdb3d5 100644 --- a/plugins/extraction/mlutil.mli +++ b/plugins/extraction/mlutil.mli @@ -9,7 +9,6 @@ (************************************************************************) open Names -open Globnames open Miniml open Table @@ -59,7 +58,7 @@ val type_recomp : ml_type list * ml_type -> ml_type val var2var' : ml_type -> ml_type -type abbrev_map = global_reference -> ml_type option +type abbrev_map = GlobRef.t -> ml_type option val type_expand : abbrev_map -> ml_type -> ml_type val type_simpl : ml_type -> ml_type @@ -117,7 +116,7 @@ val dump_unused_vars : ml_ast -> ml_ast val normalize : ml_ast -> ml_ast val optimize_fix : ml_ast -> ml_ast -val inline : global_reference -> ml_ast -> bool +val inline : GlobRef.t -> ml_ast -> bool val is_basic_pattern : ml_pattern -> bool val has_deep_pattern : ml_branch array -> bool diff --git a/plugins/extraction/modutil.ml b/plugins/extraction/modutil.ml index f33a59edf..b398bc07a 100644 --- a/plugins/extraction/modutil.ml +++ b/plugins/extraction/modutil.ml @@ -76,7 +76,7 @@ let struct_iter do_decl do_spec do_mp s = (*s Apply some fonctions upon all references in [ml_type], [ml_ast], [ml_decl], [ml_spec] and [ml_structure]. *) -type do_ref = global_reference -> unit +type do_ref = GlobRef.t -> unit let record_iter_references do_term = function | Record l -> List.iter (Option.iter do_term) l diff --git a/plugins/extraction/modutil.mli b/plugins/extraction/modutil.mli index 6a81f2705..f45773f09 100644 --- a/plugins/extraction/modutil.mli +++ b/plugins/extraction/modutil.mli @@ -9,7 +9,6 @@ (************************************************************************) open Names -open Globnames open Miniml (*s Functions upon ML modules. *) @@ -17,7 +16,7 @@ open Miniml val struct_ast_search : (ml_ast -> bool) -> ml_structure -> bool val struct_type_search : (ml_type -> bool) -> ml_structure -> bool -type do_ref = global_reference -> unit +type do_ref = GlobRef.t -> unit val type_iter_references : do_ref -> ml_type -> unit val ast_iter_references : do_ref -> do_ref -> do_ref -> ml_ast -> unit @@ -30,7 +29,7 @@ val mtyp_of_mexpr : ml_module_expr -> ml_module_type val msid_of_mt : ml_module_type -> ModPath.t -val get_decl_in_structure : global_reference -> ml_structure -> ml_decl +val get_decl_in_structure : GlobRef.t -> ml_structure -> ml_decl (* Some transformations of ML terms. [optimize_struct] simplify all beta redexes (when the argument does not occur, it is just @@ -39,5 +38,5 @@ val get_decl_in_structure : global_reference -> ml_structure -> ml_decl optimizations. The first argument is the list of objects we want to appear. *) -val optimize_struct : global_reference list * ModPath.t list -> +val optimize_struct : GlobRef.t list * ModPath.t list -> ml_structure -> ml_structure diff --git a/plugins/extraction/table.ml b/plugins/extraction/table.ml index 54c6d9d72..c3f4cfe65 100644 --- a/plugins/extraction/table.ml +++ b/plugins/extraction/table.ml @@ -652,7 +652,7 @@ let add_inline_entries b l = (* Registration of operations for rollback. *) -let inline_extraction : bool * global_reference list -> obj = +let inline_extraction : bool * GlobRef.t list -> obj = declare_object {(default_object "Extraction Inline") with cache_function = (fun (_,(b,l)) -> add_inline_entries b l); @@ -736,7 +736,7 @@ let add_implicits r l = (* Registration of operations for rollback. *) -let implicit_extraction : global_reference * int_or_id list -> obj = +let implicit_extraction : GlobRef.t * int_or_id list -> obj = declare_object {(default_object "Extraction Implicit") with cache_function = (fun (_,(r,l)) -> add_implicits r l); @@ -857,7 +857,7 @@ let find_custom_match pv = (* Registration of operations for rollback. *) -let in_customs : global_reference * string list * string -> obj = +let in_customs : GlobRef.t * string list * string -> obj = declare_object {(default_object "ML extractions") with cache_function = (fun (_,(r,ids,s)) -> add_custom r ids s); @@ -867,7 +867,7 @@ let in_customs : global_reference * string list * string -> obj = (fun (s,(r,ids,str)) -> (fst (subst_global s r), ids, str)) } -let in_custom_matchs : global_reference * string -> obj = +let in_custom_matchs : GlobRef.t * string -> obj = declare_object {(default_object "ML extractions custom matchs") with cache_function = (fun (_,(r,s)) -> add_custom_match r s); diff --git a/plugins/extraction/table.mli b/plugins/extraction/table.mli index 906dfd96e..5bf944434 100644 --- a/plugins/extraction/table.mli +++ b/plugins/extraction/table.mli @@ -10,31 +10,30 @@ open Names open Libnames -open Globnames open Miniml open Declarations -module Refset' : CSig.SetS with type elt = global_reference -module Refmap' : CSig.MapS with type key = global_reference +module Refset' : CSig.SetS with type elt = GlobRef.t +module Refmap' : CSig.MapS with type key = GlobRef.t -val safe_basename_of_global : global_reference -> Id.t +val safe_basename_of_global : GlobRef.t -> Id.t (*s Warning and Error messages. *) val warning_axioms : unit -> unit val warning_opaques : bool -> unit -val warning_ambiguous_name : ?loc:Loc.t -> qualid * ModPath.t * global_reference -> unit +val warning_ambiguous_name : ?loc:Loc.t -> qualid * ModPath.t * GlobRef.t -> unit val warning_id : string -> unit -val error_axiom_scheme : global_reference -> int -> 'a -val error_constant : global_reference -> 'a -val error_inductive : global_reference -> 'a +val error_axiom_scheme : GlobRef.t -> int -> 'a +val error_constant : GlobRef.t -> 'a +val error_inductive : GlobRef.t -> 'a val error_nb_cons : unit -> 'a val error_module_clash : ModPath.t -> ModPath.t -> 'a val error_no_module_expr : ModPath.t -> 'a -val error_singleton_become_prop : Id.t -> global_reference option -> 'a +val error_singleton_become_prop : Id.t -> GlobRef.t option -> 'a val error_unknown_module : qualid -> 'a val error_scheme : unit -> 'a -val error_not_visible : global_reference -> 'a +val error_not_visible : GlobRef.t -> 'a val error_MPfile_as_mod : ModPath.t -> bool -> 'a val check_inside_module : unit -> unit val check_inside_section : unit -> unit @@ -44,12 +43,12 @@ val err_or_warn_remaining_implicit : kill_reason -> unit val info_file : string -> unit -(*s utilities about [module_path] and [kernel_names] and [global_reference] *) +(*s utilities about [module_path] and [kernel_names] and [GlobRef.t] *) -val occur_kn_in_ref : MutInd.t -> global_reference -> bool -val repr_of_r : global_reference -> ModPath.t * DirPath.t * Label.t -val modpath_of_r : global_reference -> ModPath.t -val label_of_r : global_reference -> Label.t +val occur_kn_in_ref : MutInd.t -> GlobRef.t -> bool +val repr_of_r : GlobRef.t -> ModPath.t * DirPath.t * Label.t +val modpath_of_r : GlobRef.t -> ModPath.t +val label_of_r : GlobRef.t -> Label.t val base_mp : ModPath.t -> ModPath.t val is_modfile : ModPath.t -> bool val string_of_modfile : ModPath.t -> string @@ -61,7 +60,7 @@ val prefixes_mp : ModPath.t -> MPset.t val common_prefix_from_list : ModPath.t -> ModPath.t list -> ModPath.t option val get_nth_label_mp : int -> ModPath.t -> Label.t -val labels_of_ref : global_reference -> ModPath.t * Label.t list +val labels_of_ref : GlobRef.t -> ModPath.t * Label.t list (*s Some table-related operations *) @@ -83,27 +82,27 @@ val add_ind : MutInd.t -> mutual_inductive_body -> ml_ind -> unit val lookup_ind : MutInd.t -> mutual_inductive_body -> ml_ind option val add_inductive_kind : MutInd.t -> inductive_kind -> unit -val is_coinductive : global_reference -> bool +val is_coinductive : GlobRef.t -> bool val is_coinductive_type : ml_type -> bool (* What are the fields of a record (empty for a non-record) *) val get_record_fields : - global_reference -> global_reference option list -val record_fields_of_type : ml_type -> global_reference option list + GlobRef.t -> GlobRef.t option list +val record_fields_of_type : ml_type -> GlobRef.t option list val add_recursors : Environ.env -> MutInd.t -> unit -val is_recursor : global_reference -> bool +val is_recursor : GlobRef.t -> bool val add_projection : int -> Constant.t -> inductive -> unit -val is_projection : global_reference -> bool -val projection_arity : global_reference -> int -val projection_info : global_reference -> inductive * int (* arity *) +val is_projection : GlobRef.t -> bool +val projection_arity : GlobRef.t -> int +val projection_info : GlobRef.t -> inductive * int (* arity *) -val add_info_axiom : global_reference -> unit -val remove_info_axiom : global_reference -> unit -val add_log_axiom : global_reference -> unit +val add_info_axiom : GlobRef.t -> unit +val remove_info_axiom : GlobRef.t -> unit +val add_log_axiom : GlobRef.t -> unit -val add_opaque : global_reference -> unit -val remove_opaque : global_reference -> unit +val add_opaque : GlobRef.t -> unit +val remove_opaque : GlobRef.t -> unit val reset_tables : unit -> unit @@ -172,22 +171,22 @@ val is_extrcompute : unit -> bool (*s Table for custom inlining *) -val to_inline : global_reference -> bool -val to_keep : global_reference -> bool +val to_inline : GlobRef.t -> bool +val to_keep : GlobRef.t -> bool (*s Table for implicits arguments *) -val implicits_of_global : global_reference -> Int.Set.t +val implicits_of_global : GlobRef.t -> Int.Set.t (*s Table for user-given custom ML extractions. *) (* UGLY HACK: registration of a function defined in [extraction.ml] *) val type_scheme_nb_args_hook : (Environ.env -> Constr.t -> int) Hook.t -val is_custom : global_reference -> bool -val is_inline_custom : global_reference -> bool -val find_custom : global_reference -> string -val find_type_custom : global_reference -> string list * string +val is_custom : GlobRef.t -> bool +val is_inline_custom : GlobRef.t -> bool +val find_custom : GlobRef.t -> string +val find_type_custom : GlobRef.t -> string list * string val is_custom_match : ml_branch array -> bool val find_custom_match : ml_branch array -> string diff --git a/plugins/firstorder/formula.ml b/plugins/firstorder/formula.ml index 047fc9fbf..a60a966ce 100644 --- a/plugins/firstorder/formula.ml +++ b/plugins/firstorder/formula.ml @@ -211,7 +211,7 @@ type left_pattern= | Lexists of pinductive | LA of constr*left_arrow_pattern -type t={id:global_reference; +type t={id:GlobRef.t; constr:constr; pat:(left_pattern,right_pattern) sum; atoms:atoms} diff --git a/plugins/firstorder/formula.mli b/plugins/firstorder/formula.mli index 2962d9230..e2c6f1c4b 100644 --- a/plugins/firstorder/formula.mli +++ b/plugins/firstorder/formula.mli @@ -8,9 +8,9 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) +open Names open Constr open EConstr -open Globnames val qflag : bool ref @@ -35,7 +35,7 @@ type atoms = {positive:constr list;negative:constr list} type side = Hyp | Concl | Hint -val dummy_id: global_reference +val dummy_id: GlobRef.t val build_atoms : Environ.env -> Evd.evar_map -> counter -> side -> constr -> bool * atoms @@ -65,13 +65,13 @@ type left_pattern= | Lexists of pinductive | LA of constr*left_arrow_pattern -type t={id: global_reference; +type t={id: GlobRef.t; constr: constr; pat: (left_pattern,right_pattern) sum; atoms: atoms} (*exception Is_atom of constr*) -val build_formula : Environ.env -> Evd.evar_map -> side -> global_reference -> types -> +val build_formula : Environ.env -> Evd.evar_map -> side -> GlobRef.t -> types -> counter -> (t,types) sum diff --git a/plugins/firstorder/instances.ml b/plugins/firstorder/instances.ml index e8c0b927d..85f493956 100644 --- a/plugins/firstorder/instances.ml +++ b/plugins/firstorder/instances.ml @@ -22,7 +22,6 @@ open Reductionops open Formula open Sequent open Names -open Misctypes open Context.Rel.Declaration let compare_instance inst1 inst2= @@ -43,7 +42,7 @@ let compare_gr id1 id2 = module OrderedInstance= struct - type t=instance * Globnames.global_reference + type t=instance * GlobRef.t let compare (inst1,id1) (inst2,id2)= (compare_instance =? compare_gr) inst2 inst1 id2 id1 (* we want a __decreasing__ total order *) @@ -184,12 +183,12 @@ let right_instance_tac inst continue seq= [introf; Proofview.Goal.enter begin fun gl -> let id0 = List.nth (pf_ids_of_hyps gl) 0 in - split (ImplicitBindings [mkVar id0]) + split (Tactypes.ImplicitBindings [mkVar id0]) end; tclSOLVE [wrap 0 true continue (deepen seq)]]; tclTRY assumption] | Real ((0,t),_) -> - (tclTHEN (split (ImplicitBindings [t])) + (tclTHEN (split (Tactypes.ImplicitBindings [t])) (tclSOLVE [wrap 0 true continue (deepen seq)])) | Real ((m,t),_) -> tclFAIL 0 (Pp.str "not implemented ... yet") diff --git a/plugins/firstorder/instances.mli b/plugins/firstorder/instances.mli index 61786ffdc..9f9ade3aa 100644 --- a/plugins/firstorder/instances.mli +++ b/plugins/firstorder/instances.mli @@ -8,13 +8,13 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) -open Globnames +open Names open Rules val collect_quantified : Evd.evar_map -> Sequent.t -> Formula.t list * Sequent.t val give_instances : Evd.evar_map -> Formula.t list -> Sequent.t -> - (Unify.instance * global_reference) list + (Unify.instance * GlobRef.t) list val quantified_tac : Formula.t list -> seqtac with_backtracking diff --git a/plugins/firstorder/rules.ml b/plugins/firstorder/rules.ml index cfcd65619..b13580bc0 100644 --- a/plugins/firstorder/rules.ml +++ b/plugins/firstorder/rules.ml @@ -29,7 +29,7 @@ type tactic = unit Proofview.tactic type seqtac= (Sequent.t -> tactic) -> Sequent.t -> tactic -type lseqtac= global_reference -> seqtac +type lseqtac= GlobRef.t -> seqtac type 'a with_backtracking = tactic -> 'a @@ -233,7 +233,7 @@ let ll_forall_tac prod backtrack id continue seq= (* special for compatibility with old Intuition *) -let constant str = Universes.constr_of_global +let constant str = UnivGen.constr_of_global @@ Coqlib.coq_reference "User" ["Init";"Logic"] str let defined_connectives=lazy diff --git a/plugins/firstorder/rules.mli b/plugins/firstorder/rules.mli index 859388b30..924c26790 100644 --- a/plugins/firstorder/rules.mli +++ b/plugins/firstorder/rules.mli @@ -11,21 +11,20 @@ open Names open Constr open EConstr -open Globnames type tactic = unit Proofview.tactic type seqtac= (Sequent.t -> tactic) -> Sequent.t -> tactic -type lseqtac= global_reference -> seqtac +type lseqtac= GlobRef.t -> seqtac type 'a with_backtracking = tactic -> 'a val wrap : int -> bool -> seqtac -val basename_of_global: global_reference -> Id.t +val basename_of_global: GlobRef.t -> Id.t -val clear_global: global_reference -> tactic +val clear_global: GlobRef.t -> tactic val axiom_tac : constr -> Sequent.t -> tactic @@ -41,7 +40,7 @@ val left_and_tac : pinductive -> lseqtac with_backtracking val left_or_tac : pinductive -> lseqtac with_backtracking -val left_false_tac : global_reference -> tactic +val left_false_tac : GlobRef.t -> tactic val ll_ind_tac : pinductive -> constr list -> lseqtac with_backtracking diff --git a/plugins/firstorder/sequent.ml b/plugins/firstorder/sequent.ml index 285991797..2a527da9b 100644 --- a/plugins/firstorder/sequent.ml +++ b/plugins/firstorder/sequent.ml @@ -8,13 +8,13 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) -open EConstr -open CErrors open Util +open Pp +open CErrors +open Names +open EConstr open Formula open Unify -open Globnames -open Pp let newcnt ()= let cnt=ref (-1) in @@ -56,7 +56,7 @@ struct (priority e1.pat) - (priority e2.pat) end -type h_item = global_reference * (int*Constr.t) option +type h_item = GlobRef.t * (int*Constr.t) option module Hitem= struct @@ -77,17 +77,17 @@ module CM=Map.Make(Constr) module History=Set.Make(Hitem) let cm_add sigma typ nam cm= - let typ = EConstr.to_constr sigma typ in + let typ = EConstr.to_constr ~abort_on_undefined_evars:false sigma typ in try let l=CM.find typ cm in CM.add typ (nam::l) cm with Not_found->CM.add typ [nam] cm let cm_remove sigma typ nam cm= - let typ = EConstr.to_constr sigma typ in + let typ = EConstr.to_constr ~abort_on_undefined_evars:false sigma typ in try let l=CM.find typ cm in - let l0=List.filter (fun id-> not (Globnames.eq_gr id nam)) l in + let l0=List.filter (fun id-> not (GlobRef.equal id nam)) l in match l0 with []->CM.remove typ cm | _ ->CM.add typ l0 cm @@ -97,7 +97,7 @@ module HP=Heap.Functional(OrderedFormula) type t= {redexes:HP.t; - context:(global_reference list) CM.t; + context:(GlobRef.t list) CM.t; latoms:constr list; gl:types; glatom:constr option; @@ -117,7 +117,7 @@ let lookup sigma item seq= let p (id2,o)= match o with None -> false - | Some (m2, t2)-> Globnames.eq_gr id id2 && m2>m && more_general sigma (m2, EConstr.of_constr t2) (m, EConstr.of_constr t) in + | Some (m2, t2)-> GlobRef.equal id id2 && m2>m && more_general sigma (m2, EConstr.of_constr t2) (m, EConstr.of_constr t) in History.exists p seq.history let add_formula env sigma side nam t seq = @@ -152,7 +152,7 @@ let re_add_formula_list sigma lf seq= redexes=List.fold_right HP.add lf seq.redexes; context=List.fold_right do_one lf seq.context} -let find_left sigma t seq=List.hd (CM.find (EConstr.to_constr sigma t) seq.context) +let find_left sigma t seq=List.hd (CM.find (EConstr.to_constr ~abort_on_undefined_evars:false sigma t) seq.context) (*let rev_left seq= try @@ -187,9 +187,9 @@ let empty_seq depth= let expand_constructor_hints = List.map_append (function - | IndRef ind -> + | GlobRef.IndRef ind -> List.init (Inductiveops.nconstructors ind) - (fun i -> ConstructRef (ind,i+1)) + (fun i -> GlobRef.ConstructRef (ind,i+1)) | gr -> [gr]) @@ -197,7 +197,7 @@ let extend_with_ref_list env sigma l seq = let l = expand_constructor_hints l in let f gr (seq, sigma) = let sigma, c = Evd.fresh_global env sigma gr in - let sigma, typ= Typing.type_of env sigma (EConstr.of_constr c) in + let sigma, typ= Typing.type_of env sigma c in (add_formula env sigma Hyp gr typ seq, sigma) in List.fold_right f l (seq, sigma) @@ -229,7 +229,9 @@ let extend_with_auto_hints env sigma l seq = let print_cmap map= let print_entry c l s= - let xc=Constrextern.extern_constr false (Global.env ()) Evd.empty (EConstr.of_constr c) in + let env = Global.env () in + let sigma = Evd.from_env env in + let xc=Constrextern.extern_constr false env sigma (EConstr.of_constr c) in str "| " ++ prlist Printer.pr_global l ++ str " : " ++ diff --git a/plugins/firstorder/sequent.mli b/plugins/firstorder/sequent.mli index c4ed3e21f..709b278ec 100644 --- a/plugins/firstorder/sequent.mli +++ b/plugins/firstorder/sequent.mli @@ -8,26 +8,26 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) +open Names open EConstr open Formula -open Globnames module CM: CSig.MapS with type key=Constr.t -type h_item = global_reference * (int*Constr.t) option +type h_item = GlobRef.t * (int*Constr.t) option module History: Set.S with type elt = h_item -val cm_add : Evd.evar_map -> constr -> global_reference -> global_reference list CM.t -> - global_reference list CM.t +val cm_add : Evd.evar_map -> constr -> GlobRef.t -> GlobRef.t list CM.t -> + GlobRef.t list CM.t -val cm_remove : Evd.evar_map -> constr -> global_reference -> global_reference list CM.t -> - global_reference list CM.t +val cm_remove : Evd.evar_map -> constr -> GlobRef.t -> GlobRef.t list CM.t -> + GlobRef.t list CM.t module HP: Heap.S with type elt=Formula.t type t = {redexes:HP.t; - context: global_reference list CM.t; + context: GlobRef.t list CM.t; latoms:constr list; gl:types; glatom:constr option; @@ -41,20 +41,20 @@ val record: h_item -> t -> t val lookup: Evd.evar_map -> h_item -> t -> bool -val add_formula : Environ.env -> Evd.evar_map -> side -> global_reference -> constr -> t -> t +val add_formula : Environ.env -> Evd.evar_map -> side -> GlobRef.t -> constr -> t -> t val re_add_formula_list : Evd.evar_map -> Formula.t list -> t -> t -val find_left : Evd.evar_map -> constr -> t -> global_reference +val find_left : Evd.evar_map -> constr -> t -> GlobRef.t val take_formula : Evd.evar_map -> t -> Formula.t * t val empty_seq : int -> t -val extend_with_ref_list : Environ.env -> Evd.evar_map -> global_reference list -> +val extend_with_ref_list : Environ.env -> Evd.evar_map -> GlobRef.t list -> t -> t * Evd.evar_map val extend_with_auto_hints : Environ.env -> Evd.evar_map -> Hints.hint_db_name list -> t -> t * Evd.evar_map -val print_cmap: global_reference list CM.t -> Pp.t +val print_cmap: GlobRef.t list CM.t -> Pp.t diff --git a/plugins/firstorder/unify.ml b/plugins/firstorder/unify.ml index b869c04a2..d63fe9d79 100644 --- a/plugins/firstorder/unify.ml +++ b/plugins/firstorder/unify.ml @@ -9,7 +9,7 @@ (************************************************************************) open Util -open Term +open Constr open EConstr open Vars open Termops @@ -56,12 +56,12 @@ let unif evd t1 t2= | Meta i,_ -> let t=subst_meta !sigma nt2 in if Int.Set.is_empty (free_rels evd t) && - not (dependent evd (EConstr.mkMeta i) t) then + not (occur_metavariable evd i t) then bind i t else raise (UFAIL(nt1,nt2)) | _,Meta i -> let t=subst_meta !sigma nt1 in if Int.Set.is_empty (free_rels evd t) && - not (dependent evd (EConstr.mkMeta i) t) then + not (occur_metavariable evd i t) then 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 diff --git a/plugins/fourier/fourierR.ml b/plugins/fourier/fourierR.ml index b1c003de2..96be1d893 100644 --- a/plugins/fourier/fourierR.ml +++ b/plugins/fourier/fourierR.ml @@ -227,7 +227,7 @@ let ineq1_of_constr (h,t) = hstrict=false}] |_-> raise NoIneq) | Ind ((kn,i),_) -> - if not (eq_gr (IndRef(kn,i)) Coqlib.glob_eq) then raise NoIneq; + if not (GlobRef.equal (IndRef(kn,i)) Coqlib.glob_eq) then raise NoIneq; let t0= args.(0) in let t1= args.(1) in let t2= args.(2) in @@ -283,15 +283,15 @@ let fourier_lineq lineq1 = let get = Lazy.force let cget = get let eget c = EConstr.of_constr (Lazy.force c) -let constant path s = Universes.constr_of_global @@ +let constant path s = UnivGen.constr_of_global @@ Coqlib.coq_reference "Fourier" path s (* Standard library *) open Coqlib let coq_sym_eqT = lazy (build_coq_eq_sym ()) -let coq_False = lazy (Universes.constr_of_global @@ build_coq_False ()) -let coq_not = lazy (Universes.constr_of_global @@ build_coq_not ()) -let coq_eq = lazy (Universes.constr_of_global @@ build_coq_eq ()) +let coq_False = lazy (UnivGen.constr_of_global @@ build_coq_False ()) +let coq_not = lazy (UnivGen.constr_of_global @@ build_coq_not ()) +let coq_eq = lazy (UnivGen.constr_of_global @@ build_coq_eq ()) (* Rdefinitions *) let constant_real = constant ["Reals";"Rdefinitions"] diff --git a/plugins/funind/functional_principles_proofs.ml b/plugins/funind/functional_principles_proofs.ml index d04887a48..533694864 100644 --- a/plugins/funind/functional_principles_proofs.ml +++ b/plugins/funind/functional_principles_proofs.ml @@ -230,7 +230,7 @@ let isAppConstruct ?(env=Global.env ()) sigma t = with Not_found -> false let nf_betaiotazeta = (* Reductionops.local_strong Reductionops.whd_betaiotazeta *) - Reductionops.clos_norm_flags CClosure.betaiotazeta Environ.empty_env Evd.empty + Reductionops.clos_norm_flags CClosure.betaiotazeta Environ.empty_env @@ Evd.from_env Environ.empty_env exception NoChange @@ -243,7 +243,7 @@ let change_eq env sigma hyp_id (context:rel_context) x t end_of_type = raise NoChange; end in - let eq_constr c1 c2 = Evarconv.e_conv env (ref sigma) c1 c2 in + let eq_constr c1 c2 = Option.has_some (Evarconv.conv env sigma c1 c2) in if not (noccurn sigma 1 end_of_type) then nochange "dependent"; (* if end_of_type depends on this term we don't touch it *) if not (isApp sigma t) then nochange "not an equality"; @@ -414,9 +414,9 @@ let rewrite_until_var arg_num eq_ids : tactic = let rec_pte_id = Id.of_string "Hrec" let clean_hyp_with_heq ptes_infos eq_hyps hyp_id env sigma = - let coq_False = EConstr.of_constr (Universes.constr_of_global @@ Coqlib.build_coq_False ()) in - let coq_True = EConstr.of_constr (Universes.constr_of_global @@ Coqlib.build_coq_True ()) in - let coq_I = EConstr.of_constr (Universes.constr_of_global @@ Coqlib.build_coq_I ()) in + let coq_False = EConstr.of_constr (UnivGen.constr_of_global @@ Coqlib.build_coq_False ()) in + let coq_True = EConstr.of_constr (UnivGen.constr_of_global @@ Coqlib.build_coq_True ()) in + let coq_I = EConstr.of_constr (UnivGen.constr_of_global @@ Coqlib.build_coq_I ()) in let rec scan_type context type_of_hyp : tactic = if isLetIn sigma type_of_hyp then let real_type_of_hyp = it_mkProd_or_LetIn type_of_hyp context in @@ -598,7 +598,7 @@ let treat_new_case ptes_infos nb_prod continue_tac term dyn_infos = Proofview.V82.of_tactic (intro_using heq_id); onLastHypId (fun heq_id -> tclTHENLIST [ (* Then the new hypothesis *) - tclMAP (fun id -> Proofview.V82.of_tactic (introduction ~check:false id)) dyn_infos.rec_hyps; + tclMAP (fun id -> Proofview.V82.of_tactic (introduction id)) dyn_infos.rec_hyps; observe_tac "after_introduction" (fun g' -> (* We get infos on the equations introduced*) let new_term_value_eq = pf_unsafe_type_of g' (mkVar heq_id) in @@ -1013,7 +1013,7 @@ let generate_equation_lemma evd fnames f fun_num nb_params nb_args rec_args_num lemma_type (Lemmas.mk_hook (fun _ _ -> ())); ignore (Pfedit.by (Proofview.V82.tactic prove_replacement)); - Lemmas.save_proof (Vernacexpr.(Proved(Transparent,None))); + Lemmas.save_proof (Vernacexpr.(Proved(Proof_global.Transparent,None))); evd @@ -1050,9 +1050,9 @@ let do_replace (evd:Evd.evar_map ref) params rec_arg_num rev_args_id f fun_num a (Global.env ()) !evd (Constrintern.locate_reference (qualid_of_ident equation_lemma_id)) in - let res = EConstr.of_constr res in - evd:=evd'; - let _ = Typing.e_type_of ~refresh:true (Global.env ()) evd res in + evd:=evd'; + let sigma, _ = Typing.type_of ~refresh:true (Global.env ()) !evd res in + evd := sigma; res in let nb_intro_to_do = nb_prod (project g) (pf_concl g) in @@ -1099,10 +1099,12 @@ let prove_princ_for_struct (evd:Evd.evar_map ref) interactive_proof fun_num fnam let get_body const = match Global.body_of_constant const with | Some (body, _) -> + let env = Global.env () in + let sigma = Evd.from_env env in Tacred.cbv_norm_flags (CClosure.RedFlags.mkflags [CClosure.RedFlags.fZETA]) - (Global.env ()) - (Evd.empty) + env + sigma (EConstr.of_constr body) | None -> user_err Pp.(str "Cannot define a principle over an axiom ") in @@ -1242,7 +1244,7 @@ let prove_princ_for_struct (evd:Evd.evar_map ref) interactive_proof fun_num fnam if this_fix_info.idx + 1 = 0 then tclIDTAC (* Someone tries to defined a principle on a fully parametric definition declared as a fixpoint (strange but ....) *) else - observe_tac_stream (str "h_fix " ++ int (this_fix_info.idx +1) ) (Proofview.V82.of_tactic (fix (Some this_fix_info.name) (this_fix_info.idx +1))) + observe_tac_stream (str "h_fix " ++ int (this_fix_info.idx +1) ) (Proofview.V82.of_tactic (fix this_fix_info.name (this_fix_info.idx +1))) else Proofview.V82.of_tactic (Tactics.mutual_fix this_fix_info.name (this_fix_info.idx + 1) other_fix_infos 0) @@ -1340,7 +1342,7 @@ let prove_princ_for_struct (evd:Evd.evar_map ref) interactive_proof fun_num fnam nb_rec_hyps = -100; rec_hyps = []; info = - Reductionops.nf_betaiota (pf_env g) Evd.empty + Reductionops.nf_betaiota (pf_env g) (project g) (applist(fbody_with_full_params, (List.rev_map var_of_decl princ_params)@ (List.rev_map mkVar args_id) @@ -1603,7 +1605,7 @@ let prove_principle_for_gen match !tcc_lemma_ref with | Undefined -> user_err Pp.(str "No tcc proof !!") | Value lemma -> EConstr.of_constr lemma - | Not_needed -> EConstr.of_constr (Universes.constr_of_global @@ Coqlib.build_coq_I ()) + | Not_needed -> EConstr.of_constr (UnivGen.constr_of_global @@ Coqlib.build_coq_I ()) in (* let rec list_diff del_list check_list = *) (* match del_list with *) @@ -1657,7 +1659,7 @@ let prove_principle_for_gen (* observe_tac "reverting" *) (revert (List.rev (acc_rec_arg_id::args_ids))); (* (fun g -> observe (Printer.pr_goal (sig_it g) ++ fnl () ++ *) (* str "fix arg num" ++ int (List.length args_ids + 1) ); tclIDTAC g); *) - (* observe_tac "h_fix " *) (Proofview.V82.of_tactic (fix (Some fix_id) (List.length args_ids + 1))); + (* observe_tac "h_fix " *) (Proofview.V82.of_tactic (fix fix_id (List.length args_ids + 1))); (* (fun g -> observe (Printer.pr_goal (sig_it g) ++ fnl() ++ pr_lconstr_env (pf_env g ) (pf_unsafe_type_of g (mkVar fix_id) )); tclIDTAC g); *) h_intros (List.rev (acc_rec_arg_id::args_ids)); Proofview.V82.of_tactic (Equality.rewriteLR (mkConst eq_ref)); diff --git a/plugins/funind/functional_principles_types.ml b/plugins/funind/functional_principles_types.ml index 7a9bbd92c..a158fc8ff 100644 --- a/plugins/funind/functional_principles_types.ml +++ b/plugins/funind/functional_principles_types.ml @@ -266,7 +266,7 @@ let change_property_sort evd toSort princ princName = (Global.env ()) evd (Constrintern.locate_reference (Libnames.qualid_of_ident princName)) in let init = let nargs = (princ_info.nparams + (List.length princ_info.predicates)) in - mkApp(princName_as_constr, + mkApp(EConstr.Unsafe.to_constr princName_as_constr, Array.init nargs (fun i -> mkRel (nargs - i ))) in @@ -291,7 +291,8 @@ let build_functional_principle (evd:Evd.evar_map ref) interactive_proof old_prin let new_princ_name = next_ident_away_in_goal (Id.of_string "___________princ_________") Id.Set.empty in - let _ = Typing.e_type_of ~refresh:true (Global.env ()) evd (EConstr.of_constr new_principle_type) in + let sigma, _ = Typing.type_of ~refresh:true (Global.env ()) !evd (EConstr.of_constr new_principle_type) in + evd := sigma; let hook = Lemmas.mk_hook (hook new_principle_type) in begin Lemmas.start_proof @@ -628,16 +629,23 @@ let build_scheme fas = user_err ~hdr:"FunInd.build_scheme" (str "Cannot find " ++ Libnames.pr_reference f) in - let evd',f = Evd.fresh_global (Global.env ()) !evd f_as_constant in + let evd',f = Evd.fresh_global (Global.env ()) !evd f_as_constant in let _ = evd := evd' in - let _ = Typing.e_type_of ~refresh:true (Global.env ()) evd (EConstr.of_constr f) in - (destConst f,sort) - ) + let sigma, _ = Typing.type_of ~refresh:true (Global.env ()) !evd f in + evd := sigma; + let c, u = + try EConstr.destConst !evd f + with DestKO -> + user_err Pp.(pr_econstr_env (Global.env ()) !evd f ++spc () ++ str "should be the named of a globally defined function") + in + (c, EConstr.EInstance.kind !evd u), sort + ) fas ) in let bodies_types = make_scheme evd pconstants in + List.iter2 (fun (princ_id,_,_) def_entry -> ignore @@ -681,7 +689,7 @@ let build_case_scheme fa = let scheme_type = EConstr.Unsafe.to_constr ((Typing.unsafe_type_of env sigma) (EConstr.of_constr scheme)) in let sorts = (fun (_,_,x) -> - Universes.new_sort_in_family x + UnivGen.new_sort_in_family x ) fa in diff --git a/plugins/funind/g_indfun.ml4 b/plugins/funind/g_indfun.ml4 index 90af20b4c..9899b7b21 100644 --- a/plugins/funind/g_indfun.ml4 +++ b/plugins/funind/g_indfun.ml4 @@ -15,7 +15,8 @@ open Indfun_common open Indfun open Genarg open Stdarg -open Misctypes +open Tacarg +open Tactypes open Pcoq open Pcoq.Prim open Pcoq.Constr @@ -38,7 +39,9 @@ let pr_fun_ind_using_typed prc prlc _ opt_c = match opt_c with | None -> mt () | Some b -> - let (_, b) = b (Global.env ()) Evd.empty in + 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) @@ -123,7 +126,7 @@ ARGUMENT EXTEND auto_using' END module Gram = Pcoq.Gram -module Vernac = Pcoq.Vernac_ +module Vernac = Pvernac.Vernac_ module Tactic = Pltac type function_rec_definition_loc_argtype = (Vernacexpr.fixpoint_expr * Vernacexpr.decl_notation list) Loc.located diff --git a/plugins/funind/glob_term_to_relation.ml b/plugins/funind/glob_term_to_relation.ml index 319b410df..6b9b10312 100644 --- a/plugins/funind/glob_term_to_relation.ml +++ b/plugins/funind/glob_term_to_relation.ml @@ -10,7 +10,6 @@ open Indfun_common open CErrors open Util open Glob_termops -open Misctypes module RelDecl = Context.Rel.Declaration module NamedDecl = Context.Named.Declaration @@ -885,7 +884,7 @@ let is_res r = match DAst.get r with | _ -> false let is_gr c gr = match DAst.get c with -| GRef (r, _) -> Globnames.eq_gr r gr +| GRef (r, _) -> GlobRef.equal r gr | _ -> false let is_gvar c = match DAst.get c with @@ -894,7 +893,7 @@ let is_gvar c = match DAst.get c with let same_raw_term rt1 rt2 = match DAst.get rt1, DAst.get rt2 with - | GRef(r1,_), GRef (r2,_) -> Globnames.eq_gr r1 r2 + | GRef(r1,_), GRef (r2,_) -> GlobRef.equal r1 r2 | GHole _, GHole _ -> true | _ -> false let decompose_raw_eq lhs rhs = diff --git a/plugins/funind/glob_termops.ml b/plugins/funind/glob_termops.ml index 40ea40b6b..954fc3bab 100644 --- a/plugins/funind/glob_termops.ml +++ b/plugins/funind/glob_termops.ml @@ -1,10 +1,10 @@ open Pp +open Constr open Glob_term open CErrors open Util open Names open Decl_kinds -open Misctypes (* Some basic functions to rebuild glob_constr @@ -16,8 +16,8 @@ let mkGApp(rt,rtl) = DAst.make @@ GApp(rt,rtl) let mkGLambda(n,t,b) = DAst.make @@ GLambda(n,Explicit,t,b) let mkGProd(n,t,b) = DAst.make @@ GProd(n,Explicit,t,b) let mkGLetIn(n,b,t,c) = DAst.make @@ GLetIn(n,b,t,c) -let mkGCases(rto,l,brl) = DAst.make @@ GCases(Term.RegularStyle,rto,l,brl) -let mkGHole () = DAst.make @@ GHole(Evar_kinds.BinderType Anonymous,Misctypes.IntroAnonymous,None) +let mkGCases(rto,l,brl) = DAst.make @@ GCases(RegularStyle,rto,l,brl) +let mkGHole () = DAst.make @@ GHole(Evar_kinds.BinderType Anonymous,Namegen.IntroAnonymous,None) (* Some basic functions to decompose glob_constrs @@ -108,7 +108,7 @@ let change_vars = | GHole _ as x -> x | GCast(b,c) -> GCast(change_vars mapping b, - Miscops.map_cast_type (change_vars mapping) c) + Glob_ops.map_cast_type (change_vars mapping) c) | GProj(p,c) -> GProj(p, change_vars mapping c) ) rt and change_vars_br mapping ({CAst.loc;v=(idl,patl,res)} as br) = @@ -289,7 +289,7 @@ let rec alpha_rt excluded rt = | GHole _ as rt -> rt | GCast (b,c) -> GCast(alpha_rt excluded b, - Miscops.map_cast_type (alpha_rt excluded) c) + Glob_ops.map_cast_type (alpha_rt excluded) c) | GApp(f,args) -> GApp(alpha_rt excluded f, List.map (alpha_rt excluded) args @@ -439,7 +439,7 @@ let replace_var_by_term x_id term = | GHole _ as rt -> rt | GCast(b,c) -> GCast(replace_var_by_pattern b, - Miscops.map_cast_type replace_var_by_pattern c) + Glob_ops.map_cast_type replace_var_by_pattern c) | GProj(p,c) -> GProj(p,replace_var_by_pattern c) ) x @@ -541,7 +541,7 @@ let expand_as = | GRec _ -> user_err Pp.(str "Not handled GRec") | GCast(b,c) -> GCast(expand_as map b, - Miscops.map_cast_type (expand_as map) c) + Glob_ops.map_cast_type (expand_as map) c) | GCases(sty,po,el,brl) -> GCases(sty, Option.map (expand_as map) po, List.map (fun (rt,t) -> expand_as map rt,t) el, List.map (expand_as_br map) brl) @@ -563,7 +563,8 @@ let resolve_and_replace_implicits ?(flags=Pretyping.all_and_fail_flags) ?(expect (* FIXME : JF (30/03/2017) I'm not completely sure to have split understand as needed. If someone knows how to prevent solved existantial removal in understand, please do not hesitate to change the computation of [ctx] here *) let ctx,_,_ = Pretyping.ise_pretype_gen flags env sigma Glob_ops.empty_lvar expected_type rt in - let ctx, f = Evarutil.nf_evars_and_universes ctx in + let ctx = Evd.minimize_universes ctx in + let f c = EConstr.of_constr (Evarutil.nf_evars_universes ctx (EConstr.Unsafe.to_constr c)) in (* then we map [rt] to replace the implicit holes by their values *) let rec change rt = @@ -575,7 +576,7 @@ If someone knows how to prevent solved existantial removal in understand, pleas (fun _ evi _ -> match evi.evar_source with | (loc_evi,ImplicitArg(gr_evi,p_evi,b_evi)) -> - if Globnames.eq_gr grk gr_evi && pk=p_evi && bk=b_evi && rt.CAst.loc = loc_evi + if GlobRef.equal grk gr_evi && pk=p_evi && bk=b_evi && rt.CAst.loc = loc_evi then raise (Found evi) | _ -> () ) @@ -586,8 +587,8 @@ If someone knows how to prevent solved existantial removal in understand, pleas with Found evi -> (* we found the evar corresponding to this hole *) match evi.evar_body with | Evar_defined c -> - (* we just have to lift the solution in glob_term *) - Detyping.detype Detyping.Now false Id.Set.empty env ctx (EConstr.of_constr (f c)) + (* we just have to lift the solution in glob_term *) + Detyping.detype Detyping.Now false Id.Set.empty env ctx (f c) | Evar_empty -> rt (* the hole was not solved : we do nothing *) ) | (GHole(BinderType na,_,_)) -> (* we only want to deal with implicit arguments *) @@ -609,7 +610,7 @@ If someone knows how to prevent solved existantial removal in understand, pleas match evi.evar_body with | Evar_defined c -> (* we just have to lift the solution in glob_term *) - Detyping.detype Detyping.Now false Id.Set.empty env ctx (EConstr.of_constr (f c)) + Detyping.detype Detyping.Now false Id.Set.empty env ctx (f c) | Evar_empty -> rt (* the hole was not solved : we d when falseo nothing *) in res diff --git a/plugins/funind/glob_termops.mli b/plugins/funind/glob_termops.mli index 7088ae596..481a8be3b 100644 --- a/plugins/funind/glob_termops.mli +++ b/plugins/funind/glob_termops.mli @@ -13,7 +13,7 @@ val pattern_to_term : cases_pattern -> glob_constr Some basic functions to rebuild glob_constr In each of them the location is Util.Loc.ghost *) -val mkGRef : Globnames.global_reference -> glob_constr +val mkGRef : GlobRef.t -> glob_constr val mkGVar : Id.t -> glob_constr val mkGApp : glob_constr*(glob_constr list) -> glob_constr val mkGLambda : Name.t * glob_constr * glob_constr -> glob_constr diff --git a/plugins/funind/indfun.ml b/plugins/funind/indfun.ml index 9c350483b..cd640eebd 100644 --- a/plugins/funind/indfun.ml +++ b/plugins/funind/indfun.ml @@ -10,7 +10,7 @@ open Libnames open Globnames open Glob_term open Declarations -open Misctypes +open Tactypes open Decl_kinds module RelDecl = Context.Rel.Declaration @@ -77,8 +77,7 @@ let functional_induction with_clean c princl pat = user_err (str "Cannot find induction principle for " ++ Printer.pr_leconstr_env (Tacmach.pf_env g) sigma (mkConst c') ) in - let princ = EConstr.of_constr princ in - (princ,NoBindings,Tacmach.pf_unsafe_type_of g' princ,g') + (princ,NoBindings,Tacmach.pf_unsafe_type_of g' princ,g') | _ -> raise (UserError(None,str "functional induction must be used with a function" )) end | Some ((princ,binding)) -> @@ -91,10 +90,19 @@ let functional_induction with_clean c princl pat = if princ_infos.Tactics.farg_in_concl then [c] else [] in + if List.length args + List.length c_list = 0 + then user_err Pp.(str "Cannot recognize a valid functional scheme" ); let encoded_pat_as_patlist = - List.make (List.length args + List.length c_list - 1) None @ [pat] in - List.map2 (fun c pat -> ((None,Ltac_plugin.Tacexpr.ElimOnConstr (fun env sigma -> (sigma,(c,NoBindings)) )),(None,pat),None)) - (args@c_list) encoded_pat_as_patlist + List.make (List.length args + List.length c_list - 1) None @ [pat] + in + List.map2 + (fun c pat -> + ((None, + Ltac_plugin.Tacexpr.ElimOnConstr (fun env sigma -> (sigma,(c,NoBindings)))), + (None,pat), + None)) + (args@c_list) + encoded_pat_as_patlist in let princ' = Some (princ,bindings) in let princ_vars = @@ -252,7 +260,6 @@ let derive_inversion fix_names = let evd,c = Evd.fresh_global (Global.env ()) evd (Constrintern.locate_reference (Libnames.qualid_of_ident id)) in - let c = EConstr.of_constr c in let (cst, u) = destConst evd c in evd, (cst, EInstance.kind evd u) :: l ) @@ -274,8 +281,7 @@ let derive_inversion fix_names = (Global.env ()) evd (Constrintern.locate_reference (Libnames.qualid_of_ident (mk_rel_id id))) in - let id = EConstr.of_constr id in - evd,(fst (destInd evd id))::l + evd,(fst (destInd evd id))::l ) fix_names (evd',[]) @@ -379,7 +385,8 @@ let generate_principle (evd:Evd.evar_map ref) pconstants on_error let evd = ref (Evd.from_env env) in let evd',uprinc = Evd.fresh_global env !evd princ in let _ = evd := evd' in - let princ_type = Typing.e_type_of ~refresh:true env evd (EConstr.of_constr uprinc) in + let sigma, princ_type = Typing.type_of ~refresh:true env !evd uprinc in + evd := sigma; let princ_type = EConstr.Unsafe.to_constr princ_type in Functional_principles_types.generate_functional_principle evd @@ -416,7 +423,6 @@ let register_struct is_rec (fixpoint_exprl:(Vernacexpr.fixpoint_expr * Vernacexp let evd,c = Evd.fresh_global (Global.env ()) evd (Constrintern.locate_reference (Libnames.qualid_of_ident fname)) in - let c = EConstr.of_constr c in let (cst, u) = destConst evd c in let u = EInstance.kind evd u in evd,((cst, u) :: l) @@ -433,7 +439,6 @@ let register_struct is_rec (fixpoint_exprl:(Vernacexpr.fixpoint_expr * Vernacexp let evd,c = Evd.fresh_global (Global.env ()) evd (Constrintern.locate_reference (Libnames.qualid_of_ident fname)) in - let c = EConstr.of_constr c in let (cst, u) = destConst evd c in let u = EInstance.kind evd u in evd,((cst, u) :: l) @@ -777,7 +782,7 @@ let rec add_args id new_args = CAst.map (function | CSort _ as b -> b | CCast(b1,b2) -> CCast(add_args id new_args b1, - Miscops.map_cast_type (add_args id new_args) b2) + Glob_ops.map_cast_type (add_args id new_args) b2) | CRecord pars -> CRecord (List.map (fun (e,o) -> e, add_args id new_args o) pars) | CNotation _ -> anomaly ~label:"add_args " (Pp.str "CNotation.") @@ -842,7 +847,7 @@ let rec get_args b t : Constrexpr.local_binder_expr list * | _ -> [],b,t -let make_graph (f_ref:global_reference) = +let make_graph (f_ref : GlobRef.t) = let c,c_body = match f_ref with | ConstRef c -> diff --git a/plugins/funind/indfun.mli b/plugins/funind/indfun.mli index dcc1c2ea6..f209fb19f 100644 --- a/plugins/funind/indfun.mli +++ b/plugins/funind/indfun.mli @@ -1,4 +1,5 @@ -open Misctypes +open Names +open Tactypes val warn_cannot_define_graph : ?loc:Loc.t -> Pp.t * Pp.t -> unit @@ -18,4 +19,4 @@ val functional_induction : Goal.goal Evd.sigma -> Goal.goal list Evd.sigma -val make_graph : Globnames.global_reference -> unit +val make_graph : GlobRef.t -> unit diff --git a/plugins/funind/indfun_common.ml b/plugins/funind/indfun_common.ml index a0b9217c7..c6faa142a 100644 --- a/plugins/funind/indfun_common.ml +++ b/plugins/funind/indfun_common.ml @@ -109,7 +109,7 @@ let const_of_id id = let def_of_const t = match Constr.kind t with - Term.Const sp -> + Const sp -> (try (match Environ.constant_opt_value_in (Global.env()) sp with | Some c -> c | _ -> assert false) @@ -117,7 +117,7 @@ let def_of_const t = |_ -> assert false let coq_constant s = - Universes.constr_of_global @@ + UnivGen.constr_of_global @@ Coqlib.gen_reference_in_modules "RecursiveDefinition" Coqlib.init_modules s;; @@ -269,12 +269,12 @@ let subst_Function (subst,finfos) = in let function_constant' = do_subst_con finfos.function_constant in let graph_ind' = do_subst_ind finfos.graph_ind in - let equation_lemma' = Option.smartmap do_subst_con finfos.equation_lemma in - let correctness_lemma' = Option.smartmap do_subst_con finfos.correctness_lemma in - let completeness_lemma' = Option.smartmap do_subst_con finfos.completeness_lemma in - let rect_lemma' = Option.smartmap do_subst_con finfos.rect_lemma in - let rec_lemma' = Option.smartmap do_subst_con finfos.rec_lemma in - let prop_lemma' = Option.smartmap do_subst_con finfos.prop_lemma in + let equation_lemma' = Option.Smart.map do_subst_con finfos.equation_lemma in + let correctness_lemma' = Option.Smart.map do_subst_con finfos.correctness_lemma in + let completeness_lemma' = Option.Smart.map do_subst_con finfos.completeness_lemma in + 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 if function_constant' == finfos.function_constant && graph_ind' == finfos.graph_ind && equation_lemma' == finfos.equation_lemma && @@ -302,12 +302,12 @@ let classify_Function infos = Libobject.Substitute infos let discharge_Function (_,finfos) = let function_constant' = Lib.discharge_con finfos.function_constant and graph_ind' = Lib.discharge_inductive finfos.graph_ind - and equation_lemma' = Option.smartmap Lib.discharge_con finfos.equation_lemma - and correctness_lemma' = Option.smartmap Lib.discharge_con finfos.correctness_lemma - and completeness_lemma' = Option.smartmap Lib.discharge_con finfos.completeness_lemma - and rect_lemma' = Option.smartmap Lib.discharge_con finfos.rect_lemma - and rec_lemma' = Option.smartmap Lib.discharge_con finfos.rec_lemma - and prop_lemma' = Option.smartmap Lib.discharge_con finfos.prop_lemma + and equation_lemma' = Option.Smart.map Lib.discharge_con finfos.equation_lemma + and correctness_lemma' = Option.Smart.map Lib.discharge_con finfos.correctness_lemma + and completeness_lemma' = Option.Smart.map Lib.discharge_con finfos.completeness_lemma + and rect_lemma' = Option.Smart.map Lib.discharge_con finfos.rect_lemma + and rec_lemma' = Option.Smart.map Lib.discharge_con finfos.rec_lemma + and prop_lemma' = Option.Smart.map Lib.discharge_con finfos.prop_lemma in if function_constant' == finfos.function_constant && graph_ind' == finfos.graph_ind && @@ -471,7 +471,7 @@ let jmeq () = try Coqlib.check_required_library Coqlib.jmeq_module_name; EConstr.of_constr @@ - Universes.constr_of_global @@ + UnivGen.constr_of_global @@ Coqlib.coq_reference "Function" ["Logic";"JMeq"] "JMeq" with e when CErrors.noncritical e -> raise (ToShow e) @@ -479,7 +479,7 @@ let jmeq_refl () = try Coqlib.check_required_library Coqlib.jmeq_module_name; EConstr.of_constr @@ - Universes.constr_of_global @@ + UnivGen.constr_of_global @@ Coqlib.coq_reference "Function" ["Logic";"JMeq"] "JMeq_refl" with e when CErrors.noncritical e -> raise (ToShow e) @@ -492,7 +492,7 @@ let well_founded = function () -> EConstr.of_constr (coq_constant "well_founded" let acc_rel = function () -> EConstr.of_constr (coq_constant "Acc") let acc_inv_id = function () -> EConstr.of_constr (coq_constant "Acc_inv") -let well_founded_ltof () = EConstr.of_constr @@ Universes.constr_of_global @@ +let well_founded_ltof () = EConstr.of_constr @@ UnivGen.constr_of_global @@ Coqlib.coq_reference "" ["Arith";"Wf_nat"] "well_founded_ltof" let ltof_ref = function () -> (find_reference ["Coq";"Arith";"Wf_nat"] "ltof") diff --git a/plugins/funind/indfun_common.mli b/plugins/funind/indfun_common.mli index 5cc7163aa..346b21ef2 100644 --- a/plugins/funind/indfun_common.mli +++ b/plugins/funind/indfun_common.mli @@ -41,7 +41,7 @@ val chop_rprod_n : int -> Glob_term.glob_constr -> val def_of_const : Constr.t -> Constr.t val eq : EConstr.constr Lazy.t val refl_equal : EConstr.constr Lazy.t -val const_of_id: Id.t -> Globnames.global_reference(* constantyes *) +val const_of_id: Id.t -> GlobRef.t(* constantyes *) val jmeq : unit -> EConstr.constr val jmeq_refl : unit -> EConstr.constr @@ -107,11 +107,11 @@ val h_intros: Names.Id.t list -> Tacmach.tactic val h_id : Names.Id.t val hrec_id : Names.Id.t val acc_inv_id : EConstr.constr Util.delayed -val ltof_ref : Globnames.global_reference Util.delayed +val ltof_ref : GlobRef.t Util.delayed val well_founded_ltof : EConstr.constr Util.delayed val acc_rel : EConstr.constr Util.delayed val well_founded : EConstr.constr Util.delayed -val evaluable_of_global_reference : Globnames.global_reference -> Names.evaluable_global_reference +val evaluable_of_global_reference : GlobRef.t -> Names.evaluable_global_reference val list_rewrite : bool -> (EConstr.constr*bool) list -> Tacmach.tactic val decompose_lam_n : Evd.evar_map -> int -> EConstr.t -> diff --git a/plugins/funind/invfun.ml b/plugins/funind/invfun.ml index ae84eaa93..439274240 100644 --- a/plugins/funind/invfun.ml +++ b/plugins/funind/invfun.ml @@ -23,7 +23,7 @@ open Tacticals open Tactics open Indfun_common open Tacmach -open Misctypes +open Tactypes open Termops open Context.Rel.Declaration @@ -67,7 +67,7 @@ let observe_tac s tac g = let nf_zeta = Reductionops.clos_norm_flags (CClosure.RedFlags.mkflags [CClosure.RedFlags.fZETA]) Environ.empty_env - Evd.empty + (Evd.from_env Environ.empty_env) let thin ids gl = Proofview.V82.of_tactic (Tactics.clear ids) gl @@ -81,7 +81,7 @@ let thin ids gl = Proofview.V82.of_tactic (Tactics.clear ids) gl let make_eq () = try - EConstr.of_constr (Universes.constr_of_global (Coqlib.build_coq_eq ())) + EConstr.of_constr (UnivGen.constr_of_global (Coqlib.build_coq_eq ())) with _ -> assert false @@ -102,9 +102,9 @@ let generate_type evd g_to_f f graph i = let evd',graph = Evd.fresh_global (Global.env ()) !evd (Globnames.IndRef (fst (destInd !evd graph))) in - let graph = EConstr.of_constr graph in evd:=evd'; - let graph_arity = Typing.e_type_of (Global.env ()) evd graph in + let sigma, graph_arity = Typing.type_of (Global.env ()) !evd graph in + evd := sigma; let ctxt,_ = decompose_prod_assum !evd graph_arity in let fun_ctxt,res_type = match ctxt with @@ -172,7 +172,6 @@ let find_induction_principle evd f = | None -> raise Not_found | Some rect_lemma -> let evd',rect_lemma = Evd.fresh_global (Global.env ()) !evd (Globnames.ConstRef rect_lemma) in - let rect_lemma = EConstr.of_constr rect_lemma in let evd',typ = Typing.type_of ~refresh:true (Global.env ()) evd' rect_lemma in evd:=evd'; rect_lemma,typ @@ -240,7 +239,7 @@ let prove_fun_correct evd funs_constr graphs_constr schemes lemmas_types_infos i List.map (fun decl -> List.map - (fun id -> CAst.make @@ IntroNaming (IntroIdentifier id)) + (fun id -> CAst.make @@ IntroNaming (Namegen.IntroIdentifier id)) (generate_fresh_id (Id.of_string "y") ids (List.length (fst (decompose_prod_assum evd (RelDecl.get_type decl))))) ) branches @@ -258,7 +257,7 @@ let prove_fun_correct evd funs_constr graphs_constr schemes lemmas_types_infos i List.fold_right (fun {CAst.v=pat} acc -> match pat with - | IntroNaming (IntroIdentifier id) -> id::acc + | IntroNaming (Namegen.IntroIdentifier id) -> id::acc | _ -> anomaly (Pp.str "Not an identifier.") ) (List.nth intro_pats (pred i)) @@ -513,7 +512,7 @@ and intros_with_rewrite_aux : Tacmach.tactic = intros_with_rewrite ] g end - | Ind _ when EConstr.eq_constr sigma t (EConstr.of_constr (Universes.constr_of_global @@ Coqlib.build_coq_False ())) -> + | Ind _ when EConstr.eq_constr sigma t (EConstr.of_constr (UnivGen.constr_of_global @@ Coqlib.build_coq_False ())) -> Proofview.V82.of_tactic tauto g | Case(_,_,v,_) -> tclTHENLIST[ @@ -771,7 +770,8 @@ let derive_correctness make_scheme (funs: pconstant list) (graphs:inductive list let type_info = (type_of_lemma_ctxt,type_of_lemma_concl) in graphs_constr.(i) <- graph; let type_of_lemma = EConstr.it_mkProd_or_LetIn type_of_lemma_concl type_of_lemma_ctxt in - let _ = Typing.e_type_of (Global.env ()) evd type_of_lemma in + let sigma, _ = Typing.type_of (Global.env ()) !evd type_of_lemma in + evd := sigma; let type_of_lemma = nf_zeta type_of_lemma in observe (str "type_of_lemma := " ++ Printer.pr_leconstr_env (Global.env ()) !evd type_of_lemma); type_of_lemma,type_info @@ -818,13 +818,12 @@ let derive_correctness make_scheme (funs: pconstant list) (graphs:inductive list ignore (Pfedit.by (Proofview.V82.tactic (observe_tac ("prove correctness ("^(Id.to_string f_id)^")") (proving_tac i)))); - (Lemmas.save_proof (Vernacexpr.(Proved(Transparent,None)))); + (Lemmas.save_proof (Vernacexpr.(Proved(Proof_global.Transparent,None)))); let finfo = find_Function_infos (fst f_as_constant) in (* let lem_cst = fst (destConst (Constrintern.global_reference lem_id)) in *) let _,lem_cst_constr = Evd.fresh_global (Global.env ()) !evd (Constrintern.locate_reference (Libnames.qualid_of_ident lem_id)) in - let lem_cst_constr = EConstr.of_constr lem_cst_constr in - let (lem_cst,_) = destConst !evd lem_cst_constr in + let (lem_cst,_) = destConst !evd lem_cst_constr in update_Function {finfo with correctness_lemma = Some lem_cst}; ) @@ -880,12 +879,11 @@ let derive_correctness make_scheme (funs: pconstant list) (graphs:inductive list ignore (Pfedit.by (Proofview.V82.tactic (observe_tac ("prove completeness ("^(Id.to_string f_id)^")") (proving_tac i)))) ; - (Lemmas.save_proof (Vernacexpr.(Proved(Transparent,None)))); + (Lemmas.save_proof (Vernacexpr.(Proved(Proof_global.Transparent,None)))); let finfo = find_Function_infos (fst f_as_constant) in let _,lem_cst_constr = Evd.fresh_global (Global.env ()) !evd (Constrintern.locate_reference (Libnames.qualid_of_ident lem_id)) in - let lem_cst_constr = EConstr.of_constr lem_cst_constr in - let (lem_cst,_) = destConst !evd lem_cst_constr in + let (lem_cst,_) = destConst !evd lem_cst_constr in update_Function {finfo with completeness_lemma = Some lem_cst} ) funs) diff --git a/plugins/funind/invfun.mli b/plugins/funind/invfun.mli index ad306ab25..3ddc60920 100644 --- a/plugins/funind/invfun.mli +++ b/plugins/funind/invfun.mli @@ -9,8 +9,8 @@ (************************************************************************) val invfun : - Misctypes.quantified_hypothesis -> - Globnames.global_reference option -> + Tactypes.quantified_hypothesis -> + Names.GlobRef.t option -> Evar.t Evd.sigma -> Evar.t list Evd.sigma val derive_correctness : (Evd.evar_map ref -> diff --git a/plugins/funind/recdef.ml b/plugins/funind/recdef.ml index fb9ae64bf..aa49148fc 100644 --- a/plugins/funind/recdef.ml +++ b/plugins/funind/recdef.ml @@ -37,7 +37,7 @@ open Glob_term open Pretyping open Termops open Constrintern -open Misctypes +open Tactypes open Genredexpr open Equality @@ -49,7 +49,7 @@ open Context.Rel.Declaration (* Ugly things which should not be here *) -let coq_constant m s = EConstr.of_constr @@ Universes.constr_of_global @@ +let coq_constant m s = EConstr.of_constr @@ UnivGen.constr_of_global @@ Coqlib.coq_reference "RecursiveDefinition" m s let arith_Nat = ["Arith";"PeanoNat";"Nat"] @@ -61,7 +61,7 @@ let pr_leconstr_rd = let coq_init_constant s = EConstr.of_constr ( - Universes.constr_of_global @@ + UnivGen.constr_of_global @@ Coqlib.gen_reference_in_modules "RecursiveDefinition" Coqlib.init_modules s) let find_reference sl s = @@ -72,7 +72,7 @@ let declare_fun f_id kind ?univs value = let ce = definition_entry ?univs value (*FIXME *) in ConstRef(declare_constant f_id (DefinitionEntry ce, kind));; -let defined () = Lemmas.save_proof (Vernacexpr.(Proved (Transparent,None))) +let defined () = Lemmas.save_proof (Vernacexpr.(Proved (Proof_global.Transparent,None))) let def_of_const t = match (Constr.kind t) with @@ -106,12 +106,12 @@ let const_of_ref = function let nf_zeta env = Reductionops.clos_norm_flags (CClosure.RedFlags.mkflags [CClosure.RedFlags.fZETA]) - env - Evd.empty + env (Evd.from_env env) let nf_betaiotazeta = (* Reductionops.local_strong Reductionops.whd_betaiotazeta *) - Reductionops.clos_norm_flags CClosure.betaiotazeta Environ.empty_env Evd.empty + Reductionops.clos_norm_flags CClosure.betaiotazeta Environ.empty_env + (Evd.from_env Environ.empty_env) @@ -181,7 +181,7 @@ let simpl_iter clause = clause (* Others ugly things ... *) -let (value_f: Constr.t list -> global_reference -> Constr.t) = +let (value_f: Constr.t list -> GlobRef.t -> Constr.t) = let open Term in let open Constr in fun al fterm -> @@ -215,7 +215,7 @@ let (value_f: Constr.t list -> global_reference -> Constr.t) = let body = EConstr.Unsafe.to_constr body in it_mkLambda_or_LetIn body context -let (declare_f : Id.t -> logical_kind -> Constr.t list -> global_reference -> global_reference) = +let (declare_f : Id.t -> logical_kind -> Constr.t list -> GlobRef.t -> GlobRef.t) = fun f_id kind input_type fterm_ref -> declare_fun f_id kind (value_f input_type fterm_ref);; @@ -356,7 +356,7 @@ type 'a infos = f_id : Id.t; (* function name *) f_constr : constr; (* function term *) f_terminate : constr; (* termination proof term *) - func : global_reference; (* functional reference *) + func : GlobRef.t; (* functional reference *) info : 'a; is_main_branch : bool; (* on the main branch or on a matched expression *) is_final : bool; (* final first order term or not *) @@ -1152,7 +1152,7 @@ let termination_proof_header is_mes input_type ids args_id relation tclTHEN (Proofview.V82.of_tactic (Tactics.generalize [mkVar id])) (Proofview.V82.of_tactic (clear [id]))) )) ; - observe_tac (str "fix") (Proofview.V82.of_tactic (fix (Some hrec) (nargs+1))); + observe_tac (str "fix") (Proofview.V82.of_tactic (fix hrec (nargs+1))); h_intros args_id; Proofview.V82.of_tactic (Simple.intro wf_rec_arg); observe_tac (str "tac") (tac wf_rec_arg hrec wf_rec_arg acc_inv) @@ -1241,7 +1241,7 @@ let get_current_subgoals_types () = exception EmptySubgoals let build_and_l sigma l = - let and_constr = Universes.constr_of_global @@ Coqlib.build_coq_and () in + let and_constr = UnivGen.constr_of_global @@ Coqlib.build_coq_and () in let conj_constr = coq_conj () in let mk_and p1 p2 = mkApp(EConstr.of_constr and_constr,[|p1;p2|]) in @@ -1306,9 +1306,9 @@ let build_new_goal_type () = let is_opaque_constant c = let cb = Global.lookup_constant c in match cb.Declarations.const_body with - | Declarations.OpaqueDef _ -> Vernacexpr.Opaque - | Declarations.Undef _ -> Vernacexpr.Opaque - | Declarations.Def _ -> Vernacexpr.Transparent + | Declarations.OpaqueDef _ -> Proof_global.Opaque + | Declarations.Undef _ -> Proof_global.Opaque + | Declarations.Def _ -> Proof_global.Transparent let open_new_goal build_proof sigma using_lemmas ref_ goal_name (gls_type,decompose_and_tac,nb_goal) = (* Pp.msgnl (str "gls_type := " ++ Printer.pr_lconstr gls_type); *) @@ -1456,7 +1456,7 @@ let com_terminate -let start_equation (f:global_reference) (term_f:global_reference) +let start_equation (f:GlobRef.t) (term_f:GlobRef.t) (cont_tactic:Id.t list -> tactic) g = let sigma = project g in let ids = pf_ids_of_hyps g in @@ -1473,7 +1473,7 @@ let start_equation (f:global_reference) (term_f:global_reference) observe_tac (str "prove_eq") (cont_tactic x)]) g;; let (com_eqn : int -> Id.t -> - global_reference -> global_reference -> global_reference + GlobRef.t -> GlobRef.t -> GlobRef.t -> Constr.t -> unit) = fun nb_arg eq_name functional_ref f_ref terminate_ref equation_lemma_type -> let open CVars in @@ -1533,14 +1533,12 @@ 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 env evd type_of_f in - let function_type = EConstr.Unsafe.to_constr function_type in - let env = push_named (Context.Named.Declaration.LocalAssum (function_name,function_type)) env in + let env = EConstr.push_named (Context.Named.Declaration.LocalAssum (function_name,function_type)) env in (* Pp.msgnl (str "function type := " ++ Printer.pr_lconstr function_type); *) let evd, ty = interp_type_evars env evd ~impls:rec_impls eq in - let ty = EConstr.Unsafe.to_constr ty in - let evd, nf = Evarutil.nf_evars_and_universes evd in - let equation_lemma_type = nf_betaiotazeta (EConstr.of_constr (nf ty)) in - let function_type = nf function_type in + let evd = Evd.minimize_universes evd in + let equation_lemma_type = nf_betaiotazeta (Evarutil.nf_evar evd ty) in + let function_type = EConstr.to_constr ~abort_on_undefined_evars:false evd function_type in let equation_lemma_type = EConstr.Unsafe.to_constr equation_lemma_type in (* Pp.msgnl (str "lemma type := " ++ Printer.pr_lconstr equation_lemma_type ++ fnl ()); *) let res_vars,eq' = decompose_prod equation_lemma_type in diff --git a/plugins/ltac/coretactics.ml4 b/plugins/ltac/coretactics.ml4 index 931633e1a..61525cb49 100644 --- a/plugins/ltac/coretactics.ml4 +++ b/plugins/ltac/coretactics.ml4 @@ -10,11 +10,13 @@ open Util open Locus -open Misctypes +open Tactypes open Genredexpr open Stdarg open Extraargs +open Tacarg open Names +open Logic DECLARE PLUGIN "ltac_plugin" @@ -273,15 +275,13 @@ END (* Fix *) TACTIC EXTEND fix - [ "fix" natural(n) ] -> [ Tactics.fix None n ] -| [ "fix" ident(id) natural(n) ] -> [ Tactics.fix (Some id) n ] + [ "fix" ident(id) natural(n) ] -> [ Tactics.fix id n ] END (* Cofix *) TACTIC EXTEND cofix - [ "cofix" ] -> [ Tactics.cofix None ] -| [ "cofix" ident(id) ] -> [ Tactics.cofix (Some id) ] + [ "cofix" ident(id) ] -> [ Tactics.cofix id ] END (* Clear *) diff --git a/plugins/ltac/evar_tactics.ml b/plugins/ltac/evar_tactics.ml index 9382f567b..84f13d213 100644 --- a/plugins/ltac/evar_tactics.ml +++ b/plugins/ltac/evar_tactics.ml @@ -10,7 +10,7 @@ open Util open Names -open Term +open Constr open CErrors open Evar_refiner open Tacmach @@ -52,7 +52,7 @@ let instantiate_tac n c ido = match ido with ConclLocation () -> evar_list sigma (pf_concl gl) | HypLocation (id,hloc) -> - let decl = Environ.lookup_named_val id (Goal.V82.hyps sigma (sig_it gl)) in + let decl = Environ.lookup_named id (pf_env gl) in match hloc with InHyp -> (match decl with @@ -85,16 +85,14 @@ let let_evar name typ = Proofview.Goal.enter begin fun gl -> let sigma = Tacmach.New.project gl in let env = Proofview.Goal.env gl in - let sigma = ref sigma in - let _ = Typing.e_sort_of env sigma typ in - let sigma = !sigma in + let sigma, _ = Typing.sort_of env sigma typ in let id = match name with | Name.Anonymous -> let id = Namegen.id_of_name_using_hdchar env sigma typ name in Namegen.next_ident_away_in_goal id (Termops.vars_of_env env) | Name.Name id -> id in - let (sigma, evar) = Evarutil.new_evar env sigma ~src ~naming:(Misctypes.IntroFresh id) typ in + let (sigma, evar) = Evarutil.new_evar env sigma ~src ~naming:(Namegen.IntroFresh id) typ in Tacticals.New.tclTHEN (Proofview.Unsafe.tclEVARS sigma) (Tactics.letin_tac None (Name.Name id) evar None Locusops.nowhere) end diff --git a/plugins/ltac/extraargs.ml4 b/plugins/ltac/extraargs.ml4 index 702b83034..dae2582bd 100644 --- a/plugins/ltac/extraargs.ml4 +++ b/plugins/ltac/extraargs.ml4 @@ -19,7 +19,6 @@ open Tacmach open Tacexpr open Taccoerce open Tacinterp -open Misctypes open Locus (** Adding scopes for generic arguments not defined through ARGUMENT EXTEND *) @@ -35,7 +34,7 @@ let () = create_generic_quotation "ident" Pcoq.Prim.ident Stdarg.wit_ident let () = create_generic_quotation "reference" Pcoq.Prim.reference Stdarg.wit_ref let () = create_generic_quotation "uconstr" Pcoq.Constr.lconstr Stdarg.wit_uconstr let () = create_generic_quotation "constr" Pcoq.Constr.lconstr Stdarg.wit_constr -let () = create_generic_quotation "ipattern" Pltac.simple_intropattern Stdarg.wit_intro_pattern +let () = create_generic_quotation "ipattern" Pltac.simple_intropattern wit_intro_pattern let () = create_generic_quotation "open_constr" Pcoq.Constr.lconstr Stdarg.wit_open_constr let () = let inject (loc, v) = Tacexpr.Tacexp v in @@ -251,7 +250,7 @@ END let pr_by_arg_tac _prc _prlc prtac opt_c = match opt_c with | None -> mt () - | Some t -> hov 2 (str "by" ++ spc () ++ prtac (3,Notation_term.E) t) + | Some t -> hov 2 (str "by" ++ spc () ++ prtac (3,Notation_gram.E) t) ARGUMENT EXTEND by_arg_tac TYPED AS tactic_opt diff --git a/plugins/ltac/extraargs.mli b/plugins/ltac/extraargs.mli index e5a4f090e..737147884 100644 --- a/plugins/ltac/extraargs.mli +++ b/plugins/ltac/extraargs.mli @@ -12,7 +12,6 @@ open Tacexpr open Names open Constrexpr open Glob_term -open Misctypes val wit_orient : bool Genarg.uniform_genarg_type val orient : bool Pcoq.Gram.entry @@ -20,9 +19,9 @@ val pr_orient : bool -> Pp.t val wit_rename : (Id.t * Id.t) Genarg.uniform_genarg_type -val occurrences : (int list or_var) Pcoq.Gram.entry -val wit_occurrences : (int list or_var, int list or_var, int list) Genarg.genarg_type -val pr_occurrences : int list or_var -> Pp.t +val occurrences : (int list Locus.or_var) Pcoq.Gram.entry +val wit_occurrences : (int list Locus.or_var, int list Locus.or_var, int list) Genarg.genarg_type +val pr_occurrences : int list Locus.or_var -> Pp.t val occurrences_of : int list -> Locus.occurrences val wit_natural : int Genarg.uniform_genarg_type @@ -66,7 +65,7 @@ val wit_by_arg_tac : Geninterp.Val.t option) Genarg.genarg_type val pr_by_arg_tac : - (int * Notation_term.parenRelation -> raw_tactic_expr -> Pp.t) -> + (int * Notation_gram.parenRelation -> raw_tactic_expr -> Pp.t) -> raw_tactic_expr option -> Pp.t val test_lpar_id_colon : unit Pcoq.Gram.entry diff --git a/plugins/ltac/extratactics.ml4 b/plugins/ltac/extratactics.ml4 index 2e90ce90c..f2899ab63 100644 --- a/plugins/ltac/extratactics.ml4 +++ b/plugins/ltac/extratactics.ml4 @@ -9,6 +9,7 @@ (************************************************************************) open Pp +open Constr open Genarg open Stdarg open Tacarg @@ -23,7 +24,8 @@ open CErrors open Util open Termops open Equality -open Misctypes +open Namegen +open Tactypes open Proofview.Notations open Vernacinterp @@ -284,80 +286,6 @@ VERNAC COMMAND FUNCTIONAL EXTEND HintRewrite CLASSIFIED BY classify_hint END (**********************************************************************) -(* Hint Resolve *) - -open Term -open EConstr -open Vars -open Coqlib - -let project_hint ~poly pri l2r r = - let gr = Smartlocate.global_with_alias r in - let env = Global.env() in - let sigma = Evd.from_env env in - let sigma, c = Evd.fresh_global env sigma gr in - let c = EConstr.of_constr c in - let t = Retyping.get_type_of env sigma c in - let t = - Tacred.reduce_to_quantified_ref env sigma (Lazy.force coq_iff_ref) t in - let sign,ccl = decompose_prod_assum sigma t in - let (a,b) = match snd (decompose_app sigma ccl) with - | [a;b] -> (a,b) - | _ -> assert false in - let p = - if l2r then build_coq_iff_left_proj () else build_coq_iff_right_proj () in - let sigma, p = Evd.fresh_global env sigma p in - let p = EConstr.of_constr 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 - let id = - Nameops.add_suffix (Nametab.basename_of_global gr) ("_proj_" ^ (if l2r then "l2r" else "r2l")) - in - let ctx = Evd.const_univ_entry ~poly sigma in - let c = EConstr.to_constr sigma c in - let c = Declare.declare_definition ~internal:Declare.InternalTacticRequest id (c,ctx) in - let info = {Vernacexpr.hint_priority = pri; hint_pattern = None} in - (info,false,true,Hints.PathAny, Hints.IsGlobRef (Globnames.ConstRef c)) - -let add_hints_iff ~atts l2r lc n bl = - let open Vernacinterp in - Hints.add_hints (Locality.make_module_locality atts.locality) bl - (Hints.HintsResolveEntry (List.map (project_hint ~poly:atts.polymorphic n l2r) lc)) - -VERNAC COMMAND FUNCTIONAL EXTEND HintResolveIffLR CLASSIFIED AS SIDEFF - [ "Hint" "Resolve" "->" ne_global_list(lc) natural_opt(n) - ":" preident_list(bl) ] -> - [ fun ~atts ~st -> begin - add_hints_iff ~atts true lc n bl; - st - end - ] -| [ "Hint" "Resolve" "->" ne_global_list(lc) natural_opt(n) ] -> - [ fun ~atts ~st -> begin - add_hints_iff ~atts true lc n ["core"]; - st - end - ] -END - -VERNAC COMMAND FUNCTIONAL EXTEND HintResolveIffRL CLASSIFIED AS SIDEFF - [ "Hint" "Resolve" "<-" ne_global_list(lc) natural_opt(n) - ":" preident_list(bl) ] -> - [ fun ~atts ~st -> begin - add_hints_iff ~atts false lc n bl; - st - end - ] -| [ "Hint" "Resolve" "<-" ne_global_list(lc) natural_opt(n) ] -> - [ fun ~atts ~st -> begin - add_hints_iff ~atts false lc n ["core"]; - st - end - ] -END - -(**********************************************************************) (* Refine *) open EConstr @@ -596,10 +524,16 @@ let inImplicitTactic : glob_tactic_expr option -> obj = subst_function = subst_implicit_tactic; classify_function = (fun o -> Dispose)} +let warn_deprecated_implicit_tactic = + CWarnings.create ~name:"deprecated-implicit-tactic" ~category:"deprecated" + (fun () -> strbrk "Implicit tactics are deprecated") + let declare_implicit_tactic tac = + let () = warn_deprecated_implicit_tactic () in Lib.add_anonymous_leaf (inImplicitTactic (Some (Tacintern.glob_tactic tac))) let clear_implicit_tactic () = + let () = warn_deprecated_implicit_tactic () in Lib.add_anonymous_leaf (inImplicitTactic None) VERNAC COMMAND EXTEND ImplicitTactic CLASSIFIED AS SIDEFF @@ -615,10 +549,12 @@ END VERNAC COMMAND EXTEND RetroknowledgeRegister CLASSIFIED AS SIDEFF | [ "Register" constr(c) "as" retroknowledge_field(f) "by" constr(b)] -> - [ let tc,_ctx = Constrintern.interp_constr (Global.env ()) Evd.empty c in - let tb,_ctx(*FIXME*) = Constrintern.interp_constr (Global.env ()) Evd.empty b in - let tc = EConstr.to_constr Evd.empty tc in - let tb = EConstr.to_constr Evd.empty tb in + [ let env = Global.env () in + let evd = Evd.from_env env in + let tc,_ctx = Constrintern.interp_constr env evd c in + let tb,_ctx(*FIXME*) = Constrintern.interp_constr env evd b in + let tc = EConstr.to_constr evd tc in + let tb = EConstr.to_constr evd tb in Global.register f tc tb ] END @@ -669,7 +605,7 @@ let subst_var_with_hole occ tid t = (incr locref; DAst.make ~loc:(Loc.make_loc (!locref,0)) @@ GHole (Evar_kinds.QuestionMark(Evar_kinds.Define true,Anonymous), - Misctypes.IntroAnonymous, None))) + IntroAnonymous, None))) else x | _ -> map_glob_constr_left_to_right substrec x in let t' = substrec t @@ -680,13 +616,13 @@ let subst_hole_with_term occ tc t = let locref = ref 0 in let occref = ref occ in let rec substrec c = match DAst.get c with - | GHole (Evar_kinds.QuestionMark(Evar_kinds.Define true,Anonymous),Misctypes.IntroAnonymous,s) -> + | GHole (Evar_kinds.QuestionMark(Evar_kinds.Define true,Anonymous),IntroAnonymous,s) -> decr occref; if Int.equal !occref 0 then tc else (incr locref; DAst.make ~loc:(Loc.make_loc (!locref,0)) @@ - GHole (Evar_kinds.QuestionMark(Evar_kinds.Define true,Anonymous),Misctypes.IntroAnonymous,s)) + GHole (Evar_kinds.QuestionMark(Evar_kinds.Define true,Anonymous),IntroAnonymous,s)) | _ -> map_glob_constr_left_to_right substrec c in substrec t @@ -781,7 +717,7 @@ let mkCaseEq a : unit Proofview.tactic = let concl = Proofview.Goal.concl gl in let env = Proofview.Goal.env gl in (** FIXME: this looks really wrong. Does anybody really use this tactic? *) - let (_, c) = Tacred.pattern_occs [Locus.OnlyOccurrences [1], a] env Evd.empty concl in + let (_, c) = Tacred.pattern_occs [Locus.OnlyOccurrences [1], a] env (Evd.from_env env) concl in change_concl c end; simplest_case a] @@ -1108,7 +1044,9 @@ END VERNAC COMMAND EXTEND Declare_keys CLASSIFIED AS SIDEFF | [ "Declare" "Equivalent" "Keys" constr(c) constr(c') ] -> [ let get_key c = - let (evd, c) = Constrintern.interp_open_constr (Global.env ()) Evd.empty c in + let env = Global.env () in + let evd = Evd.from_env env in + let (evd, c) = Constrintern.interp_open_constr env evd c in let kind c = EConstr.kind evd c in Keys.constr_key kind c in diff --git a/plugins/ltac/g_auto.ml4 b/plugins/ltac/g_auto.ml4 index 643f7e99f..642e52155 100644 --- a/plugins/ltac/g_auto.ml4 +++ b/plugins/ltac/g_auto.ml4 @@ -9,6 +9,7 @@ (************************************************************************) open Pp +open Constr open Genarg open Stdarg open Pcoq.Prim @@ -169,7 +170,7 @@ END TACTIC EXTEND convert_concl_no_check -| ["convert_concl_no_check" constr(x) ] -> [ Tactics.convert_concl_no_check x Term.DEFAULTcast ] +| ["convert_concl_no_check" constr(x) ] -> [ Tactics.convert_concl_no_check x DEFAULTcast ] END let pr_pre_hints_path_atom _ _ _ = Hints.pp_hints_path_atom Libnames.pr_reference @@ -219,7 +220,7 @@ VERNAC COMMAND FUNCTIONAL EXTEND HintCut CLASSIFIED AS SIDEFF fun ~atts ~st -> begin let open Vernacinterp in let entry = Hints.HintsCutEntry (Hints.glob_hints_path p) in - Hints.add_hints (Locality.make_section_locality atts.locality) + Hints.add_hints ~local:(Locality.make_section_locality atts.locality) (match dbnames with None -> ["core"] | Some l -> l) entry; st end diff --git a/plugins/ltac/g_ltac.ml4 b/plugins/ltac/g_ltac.ml4 index 0c42a8bb2..d7d642e50 100644 --- a/plugins/ltac/g_ltac.ml4 +++ b/plugins/ltac/g_ltac.ml4 @@ -12,21 +12,22 @@ DECLARE PLUGIN "ltac_plugin" open Util open Pp +open Glob_term open Constrexpr open Tacexpr -open Misctypes +open Namegen open Genarg open Genredexpr open Tok (* necessary for camlp5 *) open Names open Pcoq -open Pcoq.Constr -open Pcoq.Vernac_ open Pcoq.Prim +open Pcoq.Constr +open Pvernac.Vernac_ open Pltac -let fail_default_value = ArgArg 0 +let fail_default_value = Locus.ArgArg 0 let arg_of_expr = function TacArg (loc,a) -> a @@ -34,7 +35,7 @@ let arg_of_expr = function let genarg_of_unit () = in_gen (rawwit Stdarg.wit_unit) () let genarg_of_int n = in_gen (rawwit Stdarg.wit_int) n -let genarg_of_ipattern pat = in_gen (rawwit Stdarg.wit_intro_pattern) pat +let genarg_of_ipattern pat = in_gen (rawwit Tacarg.wit_intro_pattern) pat let genarg_of_uconstr c = in_gen (rawwit Stdarg.wit_uconstr) c let in_tac tac = in_gen (rawwit Tacarg.wit_ltac) tac @@ -58,8 +59,8 @@ let tacdef_body = new_entry "tactic:tacdef_body" let _ = let mode = { Proof_global.name = "Classic"; - set = (fun () -> set_command_entry tactic_mode); - reset = (fun () -> set_command_entry Pcoq.Vernac_.noedit_mode); + set = (fun () -> Pvernac.set_command_entry tactic_mode); + reset = (fun () -> Pvernac.(set_command_entry noedit_mode)); } in Proof_global.register_proof_mode mode @@ -197,9 +198,9 @@ GEXTEND Gram non ambiguous name where dots are replaced by "_"? Probably too verbose most of the time. *) fresh_id: - [ [ s = STRING -> ArgArg s (*| id = ident -> ArgVar (!@loc,id)*) + [ [ s = STRING -> Locus.ArgArg s (*| id = ident -> Locus.ArgVar (!@loc,id)*) | qid = qualid -> let (_pth,id) = Libnames.repr_qualid qid.CAst.v in - ArgVar (CAst.make ~loc:!@loc id) ] ] + Locus.ArgVar (CAst.make ~loc:!@loc id) ] ] ; constr_eval: [ [ IDENT "eval"; rtc = red_expr; "in"; c = Constr.constr -> @@ -325,6 +326,7 @@ GEXTEND Gram ; toplevel_selector: [ [ sel = selector_body; ":" -> sel + | "!"; ":" -> SelectAlreadyFocused | IDENT "all"; ":" -> SelectAll ] ] ; tactic_mode: @@ -415,7 +417,7 @@ let is_explicit_terminator = function TacSolve _ -> true | _ -> false VERNAC tactic_mode EXTEND VernacSolve | [ - ltac_selector_opt(g) ltac_info_opt(n) tactic(t) ltac_use_default(def) ] => [ classify_as_proofstep ] -> [ - let g = Option.default (Proof_bullet.get_default_goal_selector ()) g in + let g = Option.default (Goal_select.get_default_goal_selector ()) g in vernac_solve g n t def ] | [ - "par" ":" ltac_info_opt(n) tactic(t) ltac_use_default(def) ] => diff --git a/plugins/ltac/g_rewrite.ml4 b/plugins/ltac/g_rewrite.ml4 index fbaa2e58f..2189e224f 100644 --- a/plugins/ltac/g_rewrite.ml4 +++ b/plugins/ltac/g_rewrite.ml4 @@ -11,7 +11,6 @@ (* Syntax for rewriting with strategies *) open Names -open Misctypes open Locus open Constrexpr open Glob_term @@ -20,9 +19,10 @@ open Extraargs open Tacmach open Rewrite open Stdarg -open Pcoq.Vernac_ +open Tactypes open Pcoq.Prim open Pcoq.Constr +open Pvernac.Vernac_ open Pltac DECLARE PLUGIN "ltac_plugin" diff --git a/plugins/ltac/g_tactic.ml4 b/plugins/ltac/g_tactic.ml4 index 7534e2799..05005c733 100644 --- a/plugins/ltac/g_tactic.ml4 +++ b/plugins/ltac/g_tactic.ml4 @@ -11,12 +11,14 @@ open Pp open CErrors open Util +open Names +open Namegen open Tacexpr open Genredexpr open Constrexpr open Libnames open Tok -open Misctypes +open Tactypes open Locus open Decl_kinds @@ -211,7 +213,7 @@ let warn_deprecated_eqn_syntax = (* Auxiliary grammar rules *) -open Vernac_ +open Pvernac.Vernac_ GEXTEND Gram GLOBAL: simple_tactic constr_with_bindings quantified_hypothesis @@ -383,19 +385,19 @@ GEXTEND Gram ; hypident: [ [ id = id_or_meta -> - let id : Misctypes.lident = id in + let id : lident = id in id,InHyp | "("; IDENT "type"; IDENT "of"; id = id_or_meta; ")" -> - let id : Misctypes.lident = id in + let id : lident = id in id,InHypTypeOnly | "("; IDENT "value"; IDENT "of"; id = id_or_meta; ")" -> - let id : Misctypes.lident = id in + let id : lident = id in id,InHypValueOnly ] ] ; hypident_occ: [ [ (id,l)=hypident; occs=occs -> - let id : Misctypes.lident = id in + let id : lident = id in ((occs,id),l) ] ] ; in_clause: @@ -494,12 +496,12 @@ GEXTEND Gram | -> None ] ] ; rewriter : - [ [ "!"; c = constr_with_bindings_arg -> (RepeatPlus,c) - | ["?"| LEFTQMARK]; c = constr_with_bindings_arg -> (RepeatStar,c) - | n = natural; "!"; c = constr_with_bindings_arg -> (Precisely n,c) - | n = natural; ["?" | LEFTQMARK]; c = constr_with_bindings_arg -> (UpTo n,c) - | n = natural; c = constr_with_bindings_arg -> (Precisely n,c) - | c = constr_with_bindings_arg -> (Precisely 1, c) + [ [ "!"; c = constr_with_bindings_arg -> (Equality.RepeatPlus,c) + | ["?"| LEFTQMARK]; c = constr_with_bindings_arg -> (Equality.RepeatStar,c) + | n = natural; "!"; c = constr_with_bindings_arg -> (Equality.Precisely n,c) + | n = natural; ["?" | LEFTQMARK]; c = constr_with_bindings_arg -> (Equality.UpTo n,c) + | n = natural; c = constr_with_bindings_arg -> (Equality.Precisely n,c) + | c = constr_with_bindings_arg -> (Equality.Precisely 1, c) ] ] ; oriented_rewriter : diff --git a/plugins/ltac/pltac.mli b/plugins/ltac/pltac.mli index 434feba95..4c075d413 100644 --- a/plugins/ltac/pltac.mli +++ b/plugins/ltac/pltac.mli @@ -15,22 +15,22 @@ open Libnames open Constrexpr open Tacexpr open Genredexpr -open Misctypes +open Tactypes val open_constr : constr_expr Gram.entry val constr_with_bindings : constr_expr with_bindings Gram.entry val bindings : constr_expr bindings Gram.entry -val hypident : (lident * Locus.hyp_location_flag) Gram.entry +val hypident : (Names.lident * Locus.hyp_location_flag) Gram.entry val constr_may_eval : (constr_expr,reference or_by_notation,constr_expr) may_eval Gram.entry val constr_eval : (constr_expr,reference or_by_notation,constr_expr) may_eval Gram.entry val uconstr : constr_expr Gram.entry val quantified_hypothesis : quantified_hypothesis Gram.entry val destruction_arg : constr_expr with_bindings Tactics.destruction_arg Gram.entry -val int_or_var : int or_var Gram.entry +val int_or_var : int Locus.or_var Gram.entry val simple_tactic : raw_tactic_expr Gram.entry val simple_intropattern : constr_expr intro_pattern_expr CAst.t Gram.entry -val in_clause : lident Locus.clause_expr Gram.entry -val clause_dft_concl : lident Locus.clause_expr Gram.entry +val in_clause : Names.lident Locus.clause_expr Gram.entry +val clause_dft_concl : Names.lident Locus.clause_expr Gram.entry val tactic_arg : raw_tactic_arg Gram.entry val tactic_expr : raw_tactic_expr Gram.entry val binder_tactic : raw_tactic_expr Gram.entry diff --git a/plugins/ltac/pptactic.ml b/plugins/ltac/pptactic.ml index 11bb7a234..e19a95e84 100644 --- a/plugins/ltac/pptactic.ml +++ b/plugins/ltac/pptactic.ml @@ -18,8 +18,8 @@ open Genarg open Geninterp open Stdarg open Libnames -open Notation_term -open Misctypes +open Notation_gram +open Tactypes open Locus open Decl_kinds open Genredexpr @@ -149,9 +149,12 @@ let string_of_genarg_arg (ArgumentType arg) = let open Genprint in match generic_top_print (in_gen (Topwit wit) x) with | TopPrinterBasic pr -> pr () - | TopPrinterNeedsContext pr -> pr (Global.env()) Evd.empty + | TopPrinterNeedsContext pr -> + let env = Global.env() in + pr env (Evd.from_env env) | TopPrinterNeedsContextAndLevel { default_ensure_surrounded; printer } -> - printer (Global.env()) Evd.empty default_ensure_surrounded + let env = Global.env() in + printer env (Evd.from_env env) default_ensure_surrounded end | _ -> default @@ -490,7 +493,7 @@ let string_of_genarg_arg (ArgumentType arg) = let pr_orient b = if b then mt () else str "<- " - let pr_multi = function + let pr_multi = let open Equality in function | Precisely 1 -> mt () | Precisely n -> int n ++ str "!" | UpTo n -> int n ++ str "?" @@ -515,6 +518,7 @@ let string_of_genarg_arg (ArgumentType arg) = else int i ++ str "-" ++ int j let pr_goal_selector toplevel = function + | SelectAlreadyFocused -> str "!:" | SelectNth i -> int i ++ str ":" | SelectList l -> prlist_with_sep (fun () -> str ", ") pr_range_selector l ++ str ":" | SelectId id -> str "[" ++ Id.print id ++ str "]:" @@ -745,7 +749,7 @@ let pr_goal_selector ~toplevel s = | TacIntroPattern (ev,(_::_ as p)) -> hov 1 (primitive (if ev then "eintros" else "intros") ++ (match p with - | [{CAst.v=Misctypes.IntroForthcoming false}] -> mt () + | [{CAst.v=IntroForthcoming false}] -> mt () | _ -> spc () ++ prlist_with_sep spc (Miscprint.pr_intro_pattern pr.pr_dconstr) p)) | TacApply (a,ev,cb,inhyp) -> hov 1 ( diff --git a/plugins/ltac/pptactic.mli b/plugins/ltac/pptactic.mli index aea00c240..6c09e447a 100644 --- a/plugins/ltac/pptactic.mli +++ b/plugins/ltac/pptactic.mli @@ -14,11 +14,11 @@ open Genarg open Geninterp open Names -open Misctypes open Environ open Constrexpr -open Notation_term +open Notation_gram open Tacexpr +open Tactypes type 'a grammar_tactic_prod_item_expr = | TacTerm of string @@ -84,7 +84,7 @@ type pp_tactic = { pptac_prods : grammar_terminals; } -val pr_goal_selector : toplevel:bool -> Vernacexpr.goal_selector -> Pp.t +val pr_goal_selector : toplevel:bool -> Goal_select.t -> Pp.t val declare_notation_tactic_pprule : KerName.t -> pp_tactic -> unit @@ -97,7 +97,7 @@ val pr_may_eval : ('a -> Pp.t) -> ('a -> Pp.t) -> ('b -> Pp.t) -> ('c -> Pp.t) -> ('a,'b,'c) Genredexpr.may_eval -> Pp.t -val pr_and_short_name : ('a -> Pp.t) -> 'a and_short_name -> Pp.t +val pr_and_short_name : ('a -> Pp.t) -> 'a Stdarg.and_short_name -> Pp.t val pr_or_by_notation : ('a -> Pp.t) -> 'a or_by_notation -> Pp.t val pr_evaluable_reference_env : env -> evaluable_global_reference -> Pp.t @@ -153,5 +153,5 @@ val pr_value : tolerability -> Val.t -> Pp.t val ltop : tolerability -val make_constr_printer : (env -> Evd.evar_map -> Notation_term.tolerability -> 'a -> Pp.t) -> +val make_constr_printer : (env -> Evd.evar_map -> tolerability -> 'a -> Pp.t) -> 'a Genprint.top_printer diff --git a/plugins/ltac/rewrite.ml b/plugins/ltac/rewrite.ml index d32a2faef..cd04f4ae9 100644 --- a/plugins/ltac/rewrite.ml +++ b/plugins/ltac/rewrite.ml @@ -26,7 +26,7 @@ open Classes open Constrexpr open Globnames open Evd -open Misctypes +open Tactypes open Locus open Locusops open Decl_kinds @@ -104,9 +104,8 @@ let extends_undefined evars evars' = let app_poly_check env evars f args = let (evars, cstrs), fc = f evars in - let evdref = ref evars in - let t = Typing.e_solve_evars env evdref (mkApp (fc, args)) in - (!evdref, cstrs), t + let evars, t = Typing.solve_evars env evars (mkApp (fc, args)) in + (evars, cstrs), t let app_poly_nocheck env evars f args = let evars, fc = f evars in @@ -428,7 +427,8 @@ let split_head = function | [] -> assert(false) let eq_pb (ty, env, x, y as pb) (ty', env', x', y' as pb') = - pb == pb' || (ty == ty' && Constr.equal x x' && Constr.equal y y') + let equal x y = Constr.equal (EConstr.Unsafe.to_constr x) (EConstr.Unsafe.to_constr y) in + pb == pb' || (ty == ty' && equal x x' && equal y y') let problem_inclusion x y = List.for_all (fun pb -> List.exists (fun pb' -> eq_pb pb pb') y) x @@ -626,9 +626,9 @@ let solve_remaining_by env sigma holes by = (** Evar should not be defined, but just in case *) | Some evi -> let env = Environ.reset_with_named_context evi.evar_hyps env in - let ty = EConstr.of_constr evi.evar_concl in + let ty = evi.evar_concl in let c, sigma = Pfedit.refine_by_tactic env sigma ty solve_tac in - Evd.define evk c sigma + Evd.define evk (EConstr.of_constr c) sigma in List.fold_left solve sigma indep @@ -1468,8 +1468,8 @@ exception RewriteFailure of Pp.t type result = (evar_map * constr option * types) option option let cl_rewrite_clause_aux ?(abs=None) strat env avoid sigma concl is_hyp : result = + let sigma, sort = Typing.sort_of env sigma concl in let evdref = ref sigma in - let sort = Typing.e_sort_of env evdref concl in let evars = (!evdref, Evar.Set.empty) in let evars, cstr = let prop, (evars, arrow) = @@ -1846,7 +1846,7 @@ let declare_relation ?locality ?(binders=[]) a aeq n refl symm trans = (CAst.make @@ Ident (Id.of_string "Equivalence_Symmetric"), lemma2); (CAst.make @@ Ident (Id.of_string "Equivalence_Transitive"), lemma3)]) -let cHole = CAst.make @@ CHole (None, Misctypes.IntroAnonymous, None) +let cHole = CAst.make @@ CHole (None, Namegen.IntroAnonymous, None) let proper_projection sigma r ty = let rel_vect n m = Array.init m (fun i -> mkRel(n+m-i)) in @@ -1862,7 +1862,6 @@ let declare_projection n instance_id r = let env = Global.env () in let sigma = Evd.from_env env in let sigma,c = Evd.fresh_global env sigma r in - let c = EConstr.of_constr c in let ty = Retyping.get_type_of env sigma c in let term = proper_projection sigma c ty in let sigma, typ = Typing.type_of env sigma term in @@ -1923,7 +1922,7 @@ let build_morphism_signature env sigma m = let evd = solve_constraints env !evd in let evd = Evd.minimize_universes evd in let m = Evarutil.nf_evars_universes evd (EConstr.Unsafe.to_constr morph) in - Pretyping.check_evars env Evd.empty evd (EConstr.of_constr m); + Pretyping.check_evars env (Evd.from_env env) evd (EConstr.of_constr m); Evd.evar_universe_context evd, m let default_morphism sign m = diff --git a/plugins/ltac/rewrite.mli b/plugins/ltac/rewrite.mli index 1e3d4733b..0d014a0bf 100644 --- a/plugins/ltac/rewrite.mli +++ b/plugins/ltac/rewrite.mli @@ -12,9 +12,9 @@ open Names open Environ open EConstr open Constrexpr -open Tacexpr -open Misctypes open Evd +open Tactypes +open Tacexpr open Tacinterp (** TODO: document and clean me! *) diff --git a/plugins/ltac/tacarg.ml b/plugins/ltac/tacarg.ml index 6eb482b1c..8a25d4851 100644 --- a/plugins/ltac/tacarg.ml +++ b/plugins/ltac/tacarg.ml @@ -19,6 +19,14 @@ let make0 ?dyn name = let () = Geninterp.register_val0 wit dyn in wit +let wit_intro_pattern = make0 "intropattern" +let wit_quant_hyp = make0 "quant_hyp" +let wit_constr_with_bindings = make0 "constr_with_bindings" +let wit_open_constr_with_bindings = make0 "open_constr_with_bindings" +let wit_bindings = make0 "bindings" +let wit_quantified_hypothesis = wit_quant_hyp +let wit_intropattern = wit_intro_pattern + let wit_tactic : (raw_tactic_expr, glob_tactic_expr, Val.t) genarg_type = make0 "tactic" diff --git a/plugins/ltac/tacarg.mli b/plugins/ltac/tacarg.mli index 59473a5e5..bdb0be03c 100644 --- a/plugins/ltac/tacarg.mli +++ b/plugins/ltac/tacarg.mli @@ -9,9 +9,33 @@ (************************************************************************) open Genarg -open Tacexpr +open EConstr open Constrexpr -open Misctypes +open Tactypes +open Tacexpr + +(** Tactic related witnesses, could also live in tactics/ if other users *) +val wit_intro_pattern : (constr_expr intro_pattern_expr CAst.t, glob_constr_and_expr intro_pattern_expr CAst.t, intro_pattern) genarg_type + +val wit_quant_hyp : quantified_hypothesis uniform_genarg_type + +val wit_constr_with_bindings : + (constr_expr with_bindings, + glob_constr_and_expr with_bindings, + constr with_bindings delayed_open) genarg_type + +val wit_open_constr_with_bindings : + (constr_expr with_bindings, + glob_constr_and_expr with_bindings, + constr with_bindings delayed_open) genarg_type + +val wit_bindings : + (constr_expr bindings, + glob_constr_and_expr bindings, + constr bindings delayed_open) genarg_type + +val wit_quantified_hypothesis : quantified_hypothesis uniform_genarg_type +val wit_intropattern : (constr_expr intro_pattern_expr CAst.t, glob_constr_and_expr intro_pattern_expr CAst.t, intro_pattern) genarg_type (** Generic arguments based on Ltac. *) diff --git a/plugins/ltac/taccoerce.ml b/plugins/ltac/taccoerce.ml index 3812a2ba2..cc9c2046d 100644 --- a/plugins/ltac/taccoerce.ml +++ b/plugins/ltac/taccoerce.ml @@ -12,9 +12,11 @@ open Util open Names open Constr open EConstr -open Misctypes +open Namegen +open Tactypes open Genarg open Stdarg +open Tacarg open Geninterp open Pp @@ -365,7 +367,7 @@ let coerce_to_int_or_var_list v = match Value.to_list v with | None -> raise (CannotCoerceTo "an int list") | Some l -> - let map n = ArgArg (coerce_to_int n) in + let map n = Locus.ArgArg (coerce_to_int n) in List.map map l (** Abstract application, to print ltac functions *) diff --git a/plugins/ltac/taccoerce.mli b/plugins/ltac/taccoerce.mli index 1fa5e3c07..56f881684 100644 --- a/plugins/ltac/taccoerce.mli +++ b/plugins/ltac/taccoerce.mli @@ -11,9 +11,9 @@ open Util open Names open EConstr -open Misctypes open Genarg open Geninterp +open Tactypes (** Coercions from highest level generic arguments to actual data used by Ltac interpretation. Those functions examinate dynamic types and try to return @@ -56,7 +56,7 @@ val coerce_to_ident_not_fresh : Environ.env -> Evd.evar_map -> Value.t -> Id.t val coerce_to_intro_pattern : Environ.env -> Evd.evar_map -> Value.t -> Tacexpr.delayed_open_constr intro_pattern_expr val coerce_to_intro_pattern_naming : - Environ.env -> Evd.evar_map -> Value.t -> intro_pattern_naming_expr + Environ.env -> Evd.evar_map -> Value.t -> Namegen.intro_pattern_naming_expr val coerce_to_hint_base : Value.t -> string @@ -80,13 +80,13 @@ val coerce_to_hyp : Environ.env -> Evd.evar_map -> Value.t -> Id.t val coerce_to_hyp_list : Environ.env -> Evd.evar_map -> Value.t -> Id.t list -val coerce_to_reference : Environ.env -> Evd.evar_map -> Value.t -> Globnames.global_reference +val coerce_to_reference : Environ.env -> Evd.evar_map -> Value.t -> GlobRef.t val coerce_to_quantified_hypothesis : Evd.evar_map -> Value.t -> quantified_hypothesis val coerce_to_decl_or_quant_hyp : Environ.env -> Evd.evar_map -> Value.t -> quantified_hypothesis -val coerce_to_int_or_var_list : Value.t -> int or_var list +val coerce_to_int_or_var_list : Value.t -> int Locus.or_var list (** {5 Missing generic arguments} *) diff --git a/plugins/ltac/tacentries.ml b/plugins/ltac/tacentries.ml index e510b9f59..fada7424c 100644 --- a/plugins/ltac/tacentries.ml +++ b/plugins/ltac/tacentries.ml @@ -376,7 +376,7 @@ let add_ml_tactic_notation name ~level prods = in let ids = List.map_filter get_id prods in let entry = { mltac_name = name; mltac_index = len - i - 1 } in - let map id = Reference (Misctypes.ArgVar (CAst.make id)) in + let map id = Reference (Locus.ArgVar (CAst.make id)) in let tac = TacML (Loc.tag (entry, List.map map ids)) in add_glob_tactic_notation false ~level prods true ids tac in diff --git a/plugins/ltac/tacexpr.ml b/plugins/ltac/tacexpr.ml index 3baa475ab..d51de8c65 100644 --- a/plugins/ltac/tacexpr.ml +++ b/plugins/ltac/tacexpr.ml @@ -15,7 +15,7 @@ open Libnames open Genredexpr open Genarg open Pattern -open Misctypes +open Tactypes open Locus type ltac_constant = KerName.t @@ -35,7 +35,8 @@ type advanced_flag = bool (* true = advanced false = basic *) type letin_flag = bool (* true = use local def false = use Leibniz *) type clear_flag = bool option (* true = clear hyp, false = keep hyp, None = use default *) -type goal_selector = Vernacexpr.goal_selector = +type goal_selector = Goal_select.t = + | SelectAlreadyFocused | SelectNth of int | SelectList of (int * int) list | SelectId of Id.t @@ -74,7 +75,7 @@ type 'id message_token = type ('dconstr,'id) induction_clause = 'dconstr with_bindings Tactics.destruction_arg * - (intro_pattern_naming_expr CAst.t option (* eqn:... *) + (Namegen.intro_pattern_naming_expr CAst.t option (* eqn:... *) * 'dconstr or_and_intro_pattern_expr CAst.t or_var option) (* as ... *) * 'id clause_expr option (* in ... *) @@ -116,7 +117,7 @@ type ml_tactic_entry = { (** Composite types *) -type glob_constr_and_expr = Tactypes.glob_constr_and_expr +type glob_constr_and_expr = Genintern.glob_constr_and_expr type open_constr_expr = unit * constr_expr type open_glob_constr = unit * glob_constr_and_expr @@ -133,7 +134,7 @@ type delayed_open_constr = EConstr.constr delayed_open type intro_pattern = delayed_open_constr intro_pattern_expr CAst.t type intro_patterns = delayed_open_constr intro_pattern_expr CAst.t list type or_and_intro_pattern = delayed_open_constr or_and_intro_pattern_expr CAst.t -type intro_pattern_naming = intro_pattern_naming_expr CAst.t +type intro_pattern_naming = Namegen.intro_pattern_naming_expr CAst.t (** Generic expressions for atomic tactics *) @@ -151,7 +152,7 @@ type 'a gen_atomic_tactic_expr = 'dtrm intro_pattern_expr CAst.t option * 'trm | TacGeneralize of ('trm with_occurrences * Name.t) list | TacLetTac of evars_flag * Name.t * 'trm * 'nam clause_expr * letin_flag * - intro_pattern_naming_expr CAst.t option + Namegen.intro_pattern_naming_expr CAst.t option (* Derived basic tactics *) | TacInductionDestruct of @@ -163,7 +164,7 @@ type 'a gen_atomic_tactic_expr = (* Equality and inversion *) | TacRewrite of evars_flag * - (bool * multi * 'dtrm with_bindings_arg) list * 'nam clause_expr * + (bool * Equality.multi * 'dtrm with_bindings_arg) list * 'nam clause_expr * (* spiwack: using ['dtrm] here is a small hack, may not be stable by a change in the representation of delayed terms. Because, in fact, it is the whole "with_bindings" @@ -269,7 +270,7 @@ and 'a gen_tactic_expr = ('p,'a gen_tactic_expr) match_rule list | TacFun of 'a gen_tactic_fun_ast | TacArg of 'a gen_tactic_arg located - | TacSelect of Vernacexpr.goal_selector * 'a gen_tactic_expr + | TacSelect of Goal_select.t * 'a gen_tactic_expr (* For ML extensions *) | TacML of (ml_tactic_entry * 'a gen_tactic_arg list) Loc.located (* For syntax extensions *) @@ -304,7 +305,7 @@ constraint 'a = < type g_trm = glob_constr_and_expr type g_pat = glob_constr_pattern_and_expr -type g_cst = evaluable_global_reference and_short_name or_var +type g_cst = evaluable_global_reference Stdarg.and_short_name or_var type g_ref = ltac_constant located or_var type g_nam = lident diff --git a/plugins/ltac/tacexpr.mli b/plugins/ltac/tacexpr.mli index 3baa475ab..01eead164 100644 --- a/plugins/ltac/tacexpr.mli +++ b/plugins/ltac/tacexpr.mli @@ -15,8 +15,8 @@ open Libnames open Genredexpr open Genarg open Pattern -open Misctypes open Locus +open Tactypes type ltac_constant = KerName.t @@ -35,7 +35,8 @@ type advanced_flag = bool (* true = advanced false = basic *) type letin_flag = bool (* true = use local def false = use Leibniz *) type clear_flag = bool option (* true = clear hyp, false = keep hyp, None = use default *) -type goal_selector = Vernacexpr.goal_selector = +type goal_selector = Goal_select.t = + | SelectAlreadyFocused | SelectNth of int | SelectList of (int * int) list | SelectId of Id.t @@ -74,7 +75,7 @@ type 'id message_token = type ('dconstr,'id) induction_clause = 'dconstr with_bindings Tactics.destruction_arg * - (intro_pattern_naming_expr CAst.t option (* eqn:... *) + (Namegen.intro_pattern_naming_expr CAst.t option (* eqn:... *) * 'dconstr or_and_intro_pattern_expr CAst.t or_var option) (* as ... *) * 'id clause_expr option (* in ... *) @@ -116,7 +117,7 @@ type ml_tactic_entry = { (** Composite types *) -type glob_constr_and_expr = Tactypes.glob_constr_and_expr +type glob_constr_and_expr = Genintern.glob_constr_and_expr type open_constr_expr = unit * constr_expr type open_glob_constr = unit * glob_constr_and_expr @@ -133,7 +134,7 @@ type delayed_open_constr = EConstr.constr delayed_open type intro_pattern = delayed_open_constr intro_pattern_expr CAst.t type intro_patterns = delayed_open_constr intro_pattern_expr CAst.t list type or_and_intro_pattern = delayed_open_constr or_and_intro_pattern_expr CAst.t -type intro_pattern_naming = intro_pattern_naming_expr CAst.t +type intro_pattern_naming = Namegen.intro_pattern_naming_expr CAst.t (** Generic expressions for atomic tactics *) @@ -151,7 +152,7 @@ type 'a gen_atomic_tactic_expr = 'dtrm intro_pattern_expr CAst.t option * 'trm | TacGeneralize of ('trm with_occurrences * Name.t) list | TacLetTac of evars_flag * Name.t * 'trm * 'nam clause_expr * letin_flag * - intro_pattern_naming_expr CAst.t option + Namegen.intro_pattern_naming_expr CAst.t option (* Derived basic tactics *) | TacInductionDestruct of @@ -163,7 +164,7 @@ type 'a gen_atomic_tactic_expr = (* Equality and inversion *) | TacRewrite of evars_flag * - (bool * multi * 'dtrm with_bindings_arg) list * 'nam clause_expr * + (bool * Equality.multi * 'dtrm with_bindings_arg) list * 'nam clause_expr * (* spiwack: using ['dtrm] here is a small hack, may not be stable by a change in the representation of delayed terms. Because, in fact, it is the whole "with_bindings" @@ -269,7 +270,7 @@ and 'a gen_tactic_expr = ('p,'a gen_tactic_expr) match_rule list | TacFun of 'a gen_tactic_fun_ast | TacArg of 'a gen_tactic_arg located - | TacSelect of Vernacexpr.goal_selector * 'a gen_tactic_expr + | TacSelect of Goal_select.t * 'a gen_tactic_expr (* For ML extensions *) | TacML of (ml_tactic_entry * 'a gen_tactic_arg list) Loc.located (* For syntax extensions *) @@ -304,7 +305,7 @@ constraint 'a = < type g_trm = glob_constr_and_expr type g_pat = glob_constr_pattern_and_expr -type g_cst = evaluable_global_reference and_short_name or_var +type g_cst = evaluable_global_reference Stdarg.and_short_name or_var type g_ref = ltac_constant located or_var type g_nam = lident diff --git a/plugins/ltac/tacintern.ml b/plugins/ltac/tacintern.ml index 9ad9e1520..cef5bb1b8 100644 --- a/plugins/ltac/tacintern.ml +++ b/plugins/ltac/tacintern.ml @@ -27,7 +27,8 @@ open Tacexpr open Genarg open Stdarg open Tacarg -open Misctypes +open Namegen +open Tactypes open Locus (** Globalization of tactic expressions : diff --git a/plugins/ltac/tacintern.mli b/plugins/ltac/tacintern.mli index fb32508cc..9146fced2 100644 --- a/plugins/ltac/tacintern.mli +++ b/plugins/ltac/tacintern.mli @@ -12,7 +12,7 @@ open Names open Tacexpr open Genarg open Constrexpr -open Misctypes +open Tactypes (** Globalization of tactic expressions : Conversion from [raw_tactic_expr] to [glob_tactic_expr] *) diff --git a/plugins/ltac/tacinterp.ml b/plugins/ltac/tacinterp.ml index 6a4bf577b..8a8f9e71a 100644 --- a/plugins/ltac/tacinterp.ml +++ b/plugins/ltac/tacinterp.ml @@ -12,6 +12,7 @@ open Constrintern open Patternops open Pp open CAst +open Namegen open Genredexpr open Glob_term open Glob_ops @@ -35,7 +36,7 @@ open Stdarg open Tacarg open Printer open Pretyping -open Misctypes +open Tactypes open Locus open Tacintern open Taccoerce @@ -691,11 +692,9 @@ let interp_may_eval f ist env sigma = function let (sigma,ic) = f ist env sigma c in let ctxt = coerce_to_constr_context (Id.Map.find s ist.lfun) in let ctxt = EConstr.Unsafe.to_constr ctxt in - let evdref = ref sigma in - let ic = EConstr.Unsafe.to_constr ic in + let ic = EConstr.Unsafe.to_constr ic in let c = subst_meta [Constr_matching.special_meta,ic] ctxt in - let c = Typing.e_solve_evars env evdref (EConstr.of_constr c) in - !evdref , c + Typing.solve_evars env sigma (EConstr.of_constr c) with | Not_found -> user_err ?loc ~hdr:"interp_may_eval" @@ -2010,7 +2009,8 @@ let interp_redexp env sigma r = let _ = let eval lfun env sigma ty tac = - let ist = { lfun = lfun; extra = TacStore.empty; } in + let extra = TacStore.set TacStore.empty f_debug (get_debug ()) in + let ist = { lfun = lfun; extra; } in let tac = interp_tactic ist tac in let (c, sigma) = Pfedit.refine_by_tactic env sigma ty tac in (EConstr.of_constr c, sigma) diff --git a/plugins/ltac/tacinterp.mli b/plugins/ltac/tacinterp.mli index bd44bdbea..fd2d96bd6 100644 --- a/plugins/ltac/tacinterp.mli +++ b/plugins/ltac/tacinterp.mli @@ -14,7 +14,7 @@ open EConstr open Tacexpr open Genarg open Redexpr -open Misctypes +open Tactypes val ltac_trace_info : ltac_trace Exninfo.t @@ -131,7 +131,7 @@ val interp_ltac_var : (value -> 'a) -> interp_sign -> val interp_int : interp_sign -> lident -> int -val interp_int_or_var : interp_sign -> int or_var -> int +val interp_int_or_var : interp_sign -> int Locus.or_var -> int val default_ist : unit -> Geninterp.interp_sign (** Empty ist with debug set on the current value. *) diff --git a/plugins/ltac/tacsubst.ml b/plugins/ltac/tacsubst.ml index a1d8b087e..dd799dc13 100644 --- a/plugins/ltac/tacsubst.ml +++ b/plugins/ltac/tacsubst.ml @@ -14,7 +14,7 @@ open Mod_subst open Genarg open Stdarg open Tacarg -open Misctypes +open Tactypes open Globnames open Genredexpr open Patternops @@ -75,7 +75,7 @@ let subst_and_short_name f (c,n) = (* assert (n=None); *)(* since tacdef are strictly globalized *) (f c,None) -let subst_or_var f = function +let subst_or_var f = let open Locus in function | ArgVar _ as x -> x | ArgArg x -> ArgArg (f x) @@ -112,7 +112,7 @@ let subst_glob_constr_or_pattern subst (bvars,c,p) = (bvars,subst_glob_constr subst c,subst_pattern subst p) let subst_redexp subst = - Miscops.map_red_expr_gen + Redops.map_red_expr_gen (subst_glob_constr subst) (subst_evaluable subst) (subst_glob_constr_or_pattern subst) diff --git a/plugins/ltac/tacsubst.mli b/plugins/ltac/tacsubst.mli index 0a894791b..d406686c5 100644 --- a/plugins/ltac/tacsubst.mli +++ b/plugins/ltac/tacsubst.mli @@ -11,7 +11,7 @@ open Tacexpr open Mod_subst open Genarg -open Misctypes +open Tactypes (** Substitution of tactics at module closing time *) diff --git a/plugins/ltac/tactic_debug.ml b/plugins/ltac/tactic_debug.ml index 57a11d947..105b5c59a 100644 --- a/plugins/ltac/tactic_debug.ml +++ b/plugins/ltac/tactic_debug.ml @@ -399,8 +399,6 @@ let skip_extensions trace = | [] -> [] in List.rev (aux (List.rev trace)) -let finer_loc loc1 loc2 = Loc.merge_opt loc1 loc2 = loc2 - let extract_ltac_trace ?loc trace = let trace = skip_extensions trace in let (tloc,c),tail = List.sep_last trace in @@ -408,7 +406,7 @@ let extract_ltac_trace ?loc trace = (* We entered a user-defined tactic, we display the trace with location of the call *) let msg = hov 0 (explain_ltac_call_trace c tail loc ++ fnl()) in - (if finer_loc loc tloc then loc else tloc), Some msg + (if Loc.finer loc tloc then loc else tloc), Some msg else (* We entered a primitive tactic, we don't display trace but report on the finest location *) @@ -417,7 +415,7 @@ let extract_ltac_trace ?loc trace = let rec aux best_loc = function | (loc,_)::tail -> if Option.is_empty best_loc || - not (Option.is_empty loc) && finer_loc loc best_loc + not (Option.is_empty loc) && Loc.finer loc best_loc then aux loc tail else diff --git a/plugins/ltac/tactic_debug.mli b/plugins/ltac/tactic_debug.mli index 734e76b56..175341df0 100644 --- a/plugins/ltac/tactic_debug.mli +++ b/plugins/ltac/tactic_debug.mli @@ -76,7 +76,7 @@ val db_logic_failure : debug_info -> exn -> unit Proofview.NonLogical.t (** Prints a logic failure message for a rule *) val db_breakpoint : debug_info -> - Misctypes.lident message_token list -> unit Proofview.NonLogical.t + lident message_token list -> unit Proofview.NonLogical.t val extract_ltac_trace : ?loc:Loc.t -> Tacexpr.ltac_trace -> Pp.t option Loc.located diff --git a/plugins/ltac/tactic_matching.ml b/plugins/ltac/tactic_matching.ml index b6462c810..c949589e2 100644 --- a/plugins/ltac/tactic_matching.ml +++ b/plugins/ltac/tactic_matching.ml @@ -46,7 +46,7 @@ let adjust : Constr_matching.bound_ident_map * Ltac_pretype.patvar_map -> (** Adds a binding to a {!Id.Map.t} if the identifier is [Some id] *) let id_map_try_add id x m = match id with - | Some id -> Id.Map.add id x m + | Some id -> Id.Map.add id (Lazy.force x) m | None -> m (** Adds a binding to a {!Id.Map.t} if the name is [Name id] *) diff --git a/plugins/ltac/tauto.ml b/plugins/ltac/tauto.ml index a51c09ca4..299bc7ea4 100644 --- a/plugins/ltac/tauto.ml +++ b/plugins/ltac/tauto.ml @@ -8,12 +8,11 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) -open Term +open Constr open EConstr open Hipattern open Names open Geninterp -open Misctypes open Ltac_plugin open Tacexpr open Tacinterp @@ -94,7 +93,7 @@ let clear id = Tactics.clear [id] let assumption = Tactics.assumption -let split = Tactics.split_with_bindings false [Misctypes.NoBindings] +let split = Tactics.split_with_bindings false [Tactypes.NoBindings] (** Test *) @@ -175,7 +174,7 @@ let flatten_contravariant_disj _ ist = | Some (_,args) -> let map i arg = let typ = mkArrow arg c in - let ci = Tactics.constructor_tac false None (succ i) Misctypes.NoBindings 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 in @@ -187,7 +186,7 @@ let flatten_contravariant_disj _ ist = let make_unfold name = let dir = DirPath.make (List.map Id.of_string ["Logic"; "Init"; "Coq"]) in let const = Constant.make2 (ModPath.MPfile dir) (Label.make name) in - (Locus.AllOccurrences, ArgArg (EvalConstRef const, None)) + Locus.(AllOccurrences, ArgArg (EvalConstRef const, None)) let u_not = make_unfold "not" @@ -245,7 +244,7 @@ let with_flags flags _ ist = let x = CAst.make @@ Id.of_string "x" in let arg = Val.Dyn (tag_tauto_flags, flags) in let ist = { ist with lfun = Id.Map.add x.CAst.v arg ist.lfun } in - eval_tactic_ist ist (TacArg (Loc.tag @@ TacCall (Loc.tag (ArgVar f, [Reference (ArgVar x)])))) + eval_tactic_ist ist (TacArg (Loc.tag @@ TacCall (Loc.tag (Locus.ArgVar f, [Reference (Locus.ArgVar x)])))) let register_tauto_tactic tac name0 args = let ids = List.map (fun id -> Id.of_string id) args in diff --git a/plugins/micromega/certificate.ml b/plugins/micromega/certificate.ml index 9f39191f8..3a9709b6c 100644 --- a/plugins/micromega/certificate.ml +++ b/plugins/micromega/certificate.ml @@ -17,10 +17,9 @@ (* We take as input a list of polynomials [p1...pn] and return an unfeasibility certificate polynomial. *) -type var = int - - +let debug = false +open Util open Big_int open Num open Polynomial @@ -59,9 +58,6 @@ let q_spec = { eqb = Mc.qeq_bool } -let r_spec = z_spec - - let dev_form n_spec p = let rec dev_form p = match p with @@ -84,38 +80,6 @@ let dev_form n_spec p = pow n in dev_form p - -let monomial_to_polynomial mn = - Monomial.fold - (fun v i acc -> - let v = Ml2C.positive v in - let mn = if Int.equal i 1 then Mc.PEX v else Mc.PEpow (Mc.PEX v ,Ml2C.n i) in - if Pervasives.(=) acc (Mc.PEc (Mc.Zpos Mc.XH)) (** FIXME *) - then mn - else Mc.PEmul(mn,acc)) - mn - (Mc.PEc (Mc.Zpos Mc.XH)) - - - -let list_to_polynomial vars l = - assert (List.for_all (fun x -> ceiling_num x =/ x) l); - let var x = monomial_to_polynomial (List.nth vars x) in - - let rec xtopoly p i = function - | [] -> p - | c::l -> if c =/ (Int 0) then xtopoly p (i+1) l - else let c = Mc.PEc (Ml2C.bigint (numerator c)) in - let mn = - if Pervasives.(=) c (Mc.PEc (Mc.Zpos Mc.XH)) - then var i - else Mc.PEmul (c,var i) in - let p' = if Pervasives.(=) p (Mc.PEc Mc.Z0) then mn else - Mc.PEadd (mn, p) in - xtopoly p' (i+1) l in - - xtopoly (Mc.PEc Mc.Z0) 0 l - let rec fixpoint f x = let y' = f x in if Pervasives.(=) y' x then y' @@ -135,15 +99,6 @@ let rec_simpl_cone n_spec e = let simplify_cone n_spec c = fixpoint (rec_simpl_cone n_spec) c - -type cone_prod = - Const of cone -| Ideal of cone *cone -| Mult of cone * cone -| Other of cone -and cone = Mc.zWitness - - let factorise_linear_cone c = @@ -224,14 +179,6 @@ let positivity l = in xpositivity 0 l - -let string_of_op = function - | Mc.Strict -> "> 0" - | Mc.NonStrict -> ">= 0" - | Mc.Equal -> "= 0" - | Mc.NonEqual -> "<> 0" - - module MonSet = Set.Make(Monomial) (* If the certificate includes at least one strict inequality, @@ -261,9 +208,6 @@ let build_linear_system l = op = Ge ; cst = Big_int zero_big_int}::(strict::(positivity l)@s0) - -let big_int_to_z = Ml2C.bigint - (* For Q, this is a pity that the certificate has been scaled -- at a lower layer, certificates are using nums... *) let make_certificate n_spec (cert,li) = @@ -296,8 +240,6 @@ let make_certificate n_spec (cert,li) = (simplify_cone n_spec (scalar_product cert' li))) -exception Found of Monomial.t - exception Strict module MonMap = Map.Make(Monomial) @@ -367,7 +309,7 @@ let simple_linear_prover l = let linear_prover n_spec l = let build_system n_spec l = - let li = List.combine l (interval 0 (List.length l -1)) in + let li = List.combine l (CList.interval 0 (List.length l -1)) in let (l1,l') = List.partition (fun (x,_) -> if Pervasives.(=) (snd x) Mc.NonEqual then true else false) li in List.map @@ -397,7 +339,7 @@ let nlinear_prover prfdepth (sys: (Mc.q Mc.pExpr * Mc.op1) list) = LinPoly.MonT.clear (); max_nb_cstr := compute_max_nb_cstr sys prfdepth ; (* Assign a proof to the initial hypotheses *) - let sys = mapi (fun c i -> (c,Mc.PsatzIn (Ml2C.nat i))) sys in + let sys = List.mapi (fun i c -> (c,Mc.PsatzIn (Ml2C.nat i))) sys in (* Add all the product of hypotheses *) @@ -452,39 +394,6 @@ let nlinear_prover prfdepth (sys: (Mc.q Mc.pExpr * Mc.op1) list) = | Mc.PsatzZ -> Mc.PsatzZ in Some (map_psatz cert) - - -let make_linear_system l = - let l' = List.map fst l in - let monomials = List.fold_left (fun acc p -> Poly.addition p acc) - (Poly.constant (Int 0)) l' in - let monomials = Poly.fold - (fun mn _ l -> if Pervasives.(=) mn Monomial.const then l else mn::l) monomials [] in - (List.map (fun (c,op) -> - {coeffs = Vect.from_list (List.map (fun mn -> (Poly.get mn c)) monomials) ; - op = op ; - cst = minus_num ( (Poly.get Monomial.const c))}) l - ,monomials) - - -let pplus x y = Mc.PEadd(x,y) -let pmult x y = Mc.PEmul(x,y) -let pconst x = Mc.PEc x -let popp x = Mc.PEopp x - -(* keep track of enumerated vectors *) -let rec mem p x l = - match l with [] -> false | e::l -> if p x e then true else mem p x l - -let rec remove_assoc p x l = - match l with [] -> [] | e::l -> if p x (fst e) then - remove_assoc p x l else e::(remove_assoc p x l) - -let eq x y = Int.equal (Vect.compare x y) 0 - -let remove e l = List.fold_left (fun l x -> if eq x e then l else x::l) [] l - - (* The prover is (probably) incomplete -- only searching for naive cutting planes *) @@ -494,38 +403,6 @@ let develop_constraint z_spec (e,k) = | Mc.Equal -> (dev_form z_spec e , Eq) | _ -> assert false - -let op_of_op_compat = function - | Ge -> Mc.NonStrict - | Eq -> Mc.Equal - - -let integer_vector coeffs = - let vars , coeffs = List.split coeffs in - List.combine vars (List.map (fun x -> Big_int x) (rats_to_ints coeffs)) - -let integer_cstr {coeffs = coeffs ; op = op ; cst = cst } = - let vars , coeffs = List.split coeffs in - match rats_to_ints (cst::coeffs) with - | cst :: coeffs -> - { - coeffs = List.combine vars (List.map (fun x -> Big_int x) coeffs) ; - op = op ; cst = Big_int cst} - | _ -> assert false - - -let pexpr_of_cstr_compat var cstr = - let {coeffs = coeffs ; op = op ; cst = cst } = integer_cstr cstr in - try - let expr = list_to_polynomial var (Vect.to_list coeffs) in - let d = Ml2C.bigint (denominator cst) in - let n = Ml2C.bigint (numerator cst) in - (pplus (pmult (pconst d) expr) (popp (pconst n)), op_of_op_compat op) - with Failure _ -> failwith "pexpr_of_cstr_compat" - - - - open Sos_types let rec scale_term t = @@ -555,18 +432,6 @@ let scale_term t = let (s,t') = scale_term t in s,t' - -let get_index_of_ith_match f i l = - let rec get j res l = - match l with - | [] -> failwith "bad index" - | e::l -> if f e - then - (if Int.equal j i then res else get (j+1) (res+1) l ) - else get j (res+1) l in - get 0 0 l - - let rec scale_certificate pos = match pos with | Axiom_eq i -> unit_big_int , Axiom_eq i | Axiom_le i -> unit_big_int , Axiom_le i @@ -681,8 +546,6 @@ open Polynomial module Env = struct - type t = int list - let id_of_hyp hyp l = let rec xid_of_hyp i l = match l with @@ -749,9 +612,6 @@ let xlinear_prover sys = | Inl _ -> None -let output_num o n = output_string o (string_of_num n) -let output_bigint o n = output_string o (string_of_big_int n) - let proof_of_farkas prf cert = (* Printf.printf "\nproof_of_farkas %a , %a \n" (pp_list output_prf_rule) prf (pp_list output_bigint) cert ; *) let rec mk_farkas acc prf cert = @@ -894,23 +754,6 @@ let rec ext_gcd a b = let (s,t) = ext_gcd b r in (t, sub_big_int s (mult_big_int q t)) - -let pp_ext_gcd a b = - let a' = big_int_of_int a in - let b' = big_int_of_int b in - - let (x,y) = ext_gcd a' b' in - Printf.fprintf stdout "%s * %s + %s * %s = %s\n" - (string_of_big_int x) (string_of_big_int a') - (string_of_big_int y) (string_of_big_int b') - (string_of_big_int (add_big_int (mult_big_int x a') (mult_big_int y b'))) - -exception Result of (int * (proof * cstr_compat)) - -let split_equations psys = - List.partition (fun (c,p) -> c.op == Eq) - - let extract_coprime (c1,p1) (c2,p2) = let rec exist2 vect1 vect2 = match vect1 , vect2 with @@ -1058,29 +901,6 @@ let reduce_var_change psys = Some (apply_and_normalise pivot_eq sys) - - - -let reduce_pivot psys = - let is_equation (cstr,prf) = - if cstr.op == Eq - then - try - Some (fst (List.hd cstr.coeffs)) - with Not_found -> None - else None in - let (oeq,sys) = extract is_equation psys in - match oeq with - | None -> None (* Nothing to do *) - | Some(v,pc) -> - if debug then - Printf.printf "Bad news : loss of completeness %a=%s" Vect.pp_vect (fst pc).coeffs (string_of_num (fst pc).cst); - Some(pivot_sys v pc sys) - - - - - let iterate_until_stable f x = let rec iter x = match f x with @@ -1225,7 +1045,7 @@ let xlia (can_enum:bool) reduction_equations sys = | None -> None | Some prf -> (*Printf.printf "direct proof %a\n" output_proof prf ; *) - let env = mapi (fun _ i -> i) sys in + let env = List.mapi (fun i _ -> i) sys in let prf = compile_proof env prf in (*try if Mc.zChecker sys' prf then Some prf else @@ -1244,7 +1064,7 @@ let lia (can_enum:bool) (prfdepth:int) sys = max_nb_cstr := compute_max_nb_cstr sys prfdepth ; let sys = List.map (develop_constraint z_spec) sys in let (sys:cstr_compat list) = List.map cstr_compat_of_poly sys in - let sys = mapi (fun c i -> (c,Hyp i)) sys in + let sys = List.mapi (fun i c -> (c,Hyp i)) sys in xlia can_enum reduction_equations sys @@ -1252,7 +1072,7 @@ let nlia enum prfdepth sys = LinPoly.MonT.clear (); max_nb_cstr := compute_max_nb_cstr sys prfdepth; let sys = List.map (develop_constraint z_spec) sys in - let sys = mapi (fun c i -> (c,Hyp i)) sys in + let sys = List.mapi (fun i c -> (c,Hyp i)) sys in let is_linear = List.for_all (fun ((p,_),_) -> Poly.is_linear p) sys in diff --git a/plugins/micromega/certificate.mli b/plugins/micromega/certificate.mli new file mode 100644 index 000000000..13d50d1ee --- /dev/null +++ b/plugins/micromega/certificate.mli @@ -0,0 +1,22 @@ +(************************************************************************) +(* * 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) *) +(************************************************************************) + +module Mc = Micromega + +type 'a number_spec + +val q_cert_of_pos : Sos_types.positivstellensatz -> Mc.q Mc.psatz +val z_cert_of_pos : Sos_types.positivstellensatz -> Mc.z Mc.psatz +val lia : bool -> int -> (Mc.z Mc.pExpr * Mc.op1) list -> Mc.zArithProof option +val nlia : bool -> int -> (Mc.z Mc.pExpr * Mc.op1) list -> Mc.zArithProof option +val nlinear_prover : int -> (Mc.q Mc.pExpr * Mc.op1) list -> Mc.q Mc.psatz option +val linear_prover_with_cert : int -> 'a number_spec -> + ('a Mc.pExpr * Mc.op1) list -> 'a Mc.psatz option +val q_spec : Mc.q number_spec diff --git a/plugins/micromega/coq_micromega.ml b/plugins/micromega/coq_micromega.ml index 168105e8f..f22147f8b 100644 --- a/plugins/micromega/coq_micromega.ml +++ b/plugins/micromega/coq_micromega.ml @@ -19,10 +19,11 @@ (************************************************************************) open Pp -open Mutils -open Goptions open Names +open Goptions +open Mutils open Constr +open Tactypes (** * Debug flag @@ -30,19 +31,6 @@ open Constr let debug = false -(** - * Time function - *) - -let time str f x = - let t0 = (Unix.times()).Unix.tms_utime in - let res = f x in - let t1 = (Unix.times()).Unix.tms_utime in - (*if debug then*) (Printf.printf "time %s %f\n" str (t1 -. t0) ; - flush stdout); - res - - (* Limit the proof search *) let max_depth = max_int @@ -305,8 +293,7 @@ let rec add_term t0 = function *) module ISet = Set.Make(Int) -module IMap = Map.Make(Int) - + (** * Given a set of integers s=\{i0,...,iN\} and a list m, return the list of * elements of m that are at position i0,...,iN. @@ -373,7 +360,7 @@ struct * ZMicromega.v *) - let gen_constant_in_modules s m n = EConstr.of_constr (Universes.constr_of_global @@ Coqlib.gen_reference_in_modules s m n) + let gen_constant_in_modules s m n = EConstr.of_constr (UnivGen.constr_of_global @@ Coqlib.gen_reference_in_modules s m n) let init_constant = gen_constant_in_modules "ZMicromega" Coqlib.init_modules let constant = gen_constant_in_modules "ZMicromega" coq_modules let bin_constant = gen_constant_in_modules "ZMicromega" bin_module @@ -395,16 +382,10 @@ struct let coq_O = lazy (init_constant "O") let coq_S = lazy (init_constant "S") - let coq_nat = lazy (init_constant "nat") let coq_N0 = lazy (bin_constant "N0") let coq_Npos = lazy (bin_constant "Npos") - let coq_pair = lazy (init_constant "pair") - let coq_None = lazy (init_constant "None") - let coq_option = lazy (init_constant "option") - - let coq_positive = lazy (bin_constant "positive") let coq_xH = lazy (bin_constant "xH") let coq_xO = lazy (bin_constant "xO") let coq_xI = lazy (bin_constant "xI") @@ -417,8 +398,6 @@ struct let coq_Q = lazy (constant "Q") let coq_R = lazy (constant "R") - let coq_Build_Witness = lazy (constant "Build_Witness") - let coq_Qmake = lazy (constant "Qmake") let coq_Rcst = lazy (constant "Rcst") @@ -455,8 +434,6 @@ struct let coq_Zmult = lazy (z_constant "Z.mul") let coq_Zpower = lazy (z_constant "Z.pow") - let coq_Qgt = lazy (constant "Qgt") - let coq_Qge = lazy (constant "Qge") let coq_Qle = lazy (constant "Qle") let coq_Qlt = lazy (constant "Qlt") let coq_Qeq = lazy (constant "Qeq") @@ -476,7 +453,6 @@ struct let coq_Rminus = lazy (r_constant "Rminus") let coq_Ropp = lazy (r_constant "Ropp") let coq_Rmult = lazy (r_constant "Rmult") - let coq_Rdiv = lazy (r_constant "Rdiv") let coq_Rinv = lazy (r_constant "Rinv") let coq_Rpower = lazy (r_constant "pow") let coq_IZR = lazy (r_constant "IZR") @@ -509,12 +485,6 @@ struct let coq_PsatzAdd = lazy (constant "PsatzAdd") let coq_PsatzC = lazy (constant "PsatzC") let coq_PsatzZ = lazy (constant "PsatzZ") - let coq_coneMember = lazy (constant "coneMember") - - let coq_make_impl = lazy - (gen_constant_in_modules "Zmicromega" [["Refl"]] "make_impl") - let coq_make_conj = lazy - (gen_constant_in_modules "Zmicromega" [["Refl"]] "make_conj") let coq_TT = lazy (gen_constant_in_modules "ZMicromega" @@ -552,13 +522,6 @@ struct let coq_QWitness = lazy (gen_constant_in_modules "QMicromega" [["Coq"; "micromega"; "QMicromega"]] "QWitness") - let coq_ZWitness = lazy - (gen_constant_in_modules "QMicromega" - [["Coq"; "micromega"; "ZMicromega"]] "ZWitness") - - let coq_N_of_Z = lazy - (gen_constant_in_modules "ZArithRing" - [["Coq";"setoid_ring";"ZArithRing"]] "N_of_Z") let coq_Build = lazy (gen_constant_in_modules "RingMicromega" @@ -577,34 +540,16 @@ struct * pp_* functions pretty-print Coq terms. *) - (* Error datastructures *) - - type parse_error = - | Ukn - | BadStr of string - | BadNum of int - | BadTerm of constr - | Msg of string - | Goal of (constr list ) * constr * parse_error - - let string_of_error = function - | Ukn -> "ukn" - | BadStr s -> s - | BadNum i -> string_of_int i - | BadTerm _ -> "BadTerm" - | Msg s -> s - | Goal _ -> "Goal" - exception ParseError (* A simple but useful getter function *) let get_left_construct sigma term = match EConstr.kind sigma term with - | Term.Construct((_,i),_) -> (i,[| |]) - | Term.App(l,rst) -> + | Construct((_,i),_) -> (i,[| |]) + | App(l,rst) -> (match EConstr.kind sigma l with - | Term.Construct((_,i),_) -> (i,rst) + | Construct((_,i),_) -> (i,rst) | _ -> raise ParseError ) | _ -> raise ParseError @@ -648,19 +593,6 @@ struct | Mc.N0 -> Lazy.force coq_N0 | Mc.Npos p -> EConstr.mkApp(Lazy.force coq_Npos,[| dump_positive p|]) - let rec dump_index x = - match x with - | Mc.XH -> Lazy.force coq_xH - | Mc.XO p -> EConstr.mkApp(Lazy.force coq_xO,[| dump_index p |]) - | Mc.XI p -> EConstr.mkApp(Lazy.force coq_xI,[| dump_index p |]) - - let pp_index o x = Printf.fprintf o "%i" (CoqToCaml.index x) - - let pp_n o x = output_string o (string_of_int (CoqToCaml.n x)) - - let dump_pair t1 t2 dump_t1 dump_t2 (x,y) = - EConstr.mkApp(Lazy.force coq_pair,[| t1 ; t2 ; dump_t1 x ; dump_t2 y|]) - let parse_z sigma term = let (i,c) = get_left_construct sigma term in match i with @@ -677,18 +609,13 @@ struct let pp_z o x = Printf.fprintf o "%s" (Big_int.string_of_big_int (CoqToCaml.z_big_int x)) - let dump_num bd1 = - EConstr.mkApp(Lazy.force coq_Qmake, - [|dump_z (CamlToCoq.bigint (numerator bd1)) ; - dump_positive (CamlToCoq.positive_big_int (denominator bd1)) |]) - let dump_q q = EConstr.mkApp(Lazy.force coq_Qmake, [| dump_z q.Micromega.qnum ; dump_positive q.Micromega.qden|]) let parse_q sigma term = match EConstr.kind sigma term with - | Term.App(c, args) -> if EConstr.eq_constr sigma c (Lazy.force coq_Qmake) then + | App(c, args) -> if EConstr.eq_constr sigma c (Lazy.force coq_Qmake) then {Mc.qnum = parse_z sigma args.(0) ; Mc.qden = parse_positive sigma args.(1) } else raise ParseError | _ -> raise ParseError @@ -719,29 +646,6 @@ struct | Mc.CInv t -> EConstr.mkApp(Lazy.force coq_CInv, [| dump_Rcst t |]) | Mc.COpp t -> EConstr.mkApp(Lazy.force coq_COpp, [| dump_Rcst t |]) - let rec parse_Rcst sigma term = - let (i,c) = get_left_construct sigma term in - match i with - | 1 -> Mc.C0 - | 2 -> Mc.C1 - | 3 -> Mc.CQ (parse_q sigma c.(0)) - | 4 -> Mc.CPlus(parse_Rcst sigma c.(0), parse_Rcst sigma c.(1)) - | 5 -> Mc.CMinus(parse_Rcst sigma c.(0), parse_Rcst sigma c.(1)) - | 6 -> Mc.CMult(parse_Rcst sigma c.(0), parse_Rcst sigma c.(1)) - | 7 -> Mc.CInv(parse_Rcst sigma c.(0)) - | 8 -> Mc.COpp(parse_Rcst sigma c.(0)) - | _ -> raise ParseError - - - - - let rec parse_list sigma parse_elt term = - let (i,c) = get_left_construct sigma term in - match i with - | 1 -> [] - | 2 -> parse_elt sigma c.(1) :: parse_list sigma parse_elt c.(2) - | i -> raise ParseError - let rec dump_list typ dump_elt l = match l with | [] -> EConstr.mkApp(Lazy.force coq_nil,[| typ |]) @@ -756,22 +660,8 @@ struct | e::l -> Printf.fprintf o "%a ,%a" elt e _pp l in Printf.fprintf o "%s%a%s" op _pp l cl - let pp_var = pp_positive - let dump_var = dump_positive - let pp_expr pp_z o e = - let rec pp_expr o e = - match e with - | Mc.PEX n -> Printf.fprintf o "V %a" pp_var n - | Mc.PEc z -> pp_z o z - | Mc.PEadd(e1,e2) -> Printf.fprintf o "(%a)+(%a)" pp_expr e1 pp_expr e2 - | Mc.PEmul(e1,e2) -> Printf.fprintf o "%a*(%a)" pp_expr e1 pp_expr e2 - | Mc.PEopp e -> Printf.fprintf o "-(%a)" pp_expr e - | Mc.PEsub(e1,e2) -> Printf.fprintf o "(%a)-(%a)" pp_expr e1 pp_expr e2 - | Mc.PEpow(e,n) -> Printf.fprintf o "(%a)^(%a)" pp_expr e pp_n n in - pp_expr o e - let dump_expr typ dump_z e = let rec dump_expr e = match e with @@ -854,18 +744,6 @@ struct | Mc.OpGt-> Lazy.force coq_OpGt | Mc.OpLt-> Lazy.force coq_OpLt - let pp_op o e= - match e with - | Mc.OpEq-> Printf.fprintf o "=" - | Mc.OpNEq-> Printf.fprintf o "<>" - | Mc.OpLe -> Printf.fprintf o "=<" - | Mc.OpGe -> Printf.fprintf o ">=" - | Mc.OpGt-> Printf.fprintf o ">" - | Mc.OpLt-> Printf.fprintf o "<" - - let pp_cstr pp_z o {Mc.flhs = l ; Mc.fop = op ; Mc.frhs = r } = - Printf.fprintf o"(%a %a %a)" (pp_expr pp_z) l pp_op op (pp_expr pp_z) r - let dump_cstr typ dump_constant {Mc.flhs = e1 ; Mc.fop = o ; Mc.frhs = e2} = EConstr.mkApp(Lazy.force coq_Build, [| typ; dump_expr typ dump_constant e1 ; @@ -904,8 +782,8 @@ struct let parse_zop gl (op,args) = let sigma = gl.sigma in match EConstr.kind sigma op with - | Term.Const (x,_) -> (assoc_const sigma op zop_table, args.(0) , args.(1)) - | Term.Ind((n,0),_) -> + | Const (x,_) -> (assoc_const sigma op zop_table, args.(0) , args.(1)) + | Ind((n,0),_) -> if EConstr.eq_constr sigma op (Lazy.force coq_Eq) && is_convertible gl args.(0) (Lazy.force coq_Z) then (Mc.OpEq, args.(1), args.(2)) else raise ParseError @@ -914,8 +792,8 @@ struct let parse_rop gl (op,args) = let sigma = gl.sigma in match EConstr.kind sigma op with - | Term.Const (x,_) -> (assoc_const sigma op rop_table, args.(0) , args.(1)) - | Term.Ind((n,0),_) -> + | Const (x,_) -> (assoc_const sigma op rop_table, args.(0) , args.(1)) + | Ind((n,0),_) -> if EConstr.eq_constr sigma op (Lazy.force coq_Eq) && is_convertible gl args.(0) (Lazy.force coq_R) then (Mc.OpEq, args.(1), args.(2)) else raise ParseError @@ -924,11 +802,6 @@ struct let parse_qop gl (op,args) = (assoc_const gl.sigma op qop_table, args.(0) , args.(1)) - let is_constant sigma t = (* This is an approx *) - match EConstr.kind sigma t with - | Term.Construct(i,_) -> true - | _ -> false - type 'a op = | Binop of ('a Mc.pExpr -> 'a Mc.pExpr -> 'a Mc.pExpr) | Opp @@ -947,8 +820,6 @@ struct module Env = struct - type t = EConstr.constr list - let compute_rank_add env sigma v = let rec _add env n v = match env with @@ -1011,10 +882,10 @@ struct try (Mc.PEc (parse_constant term) , env) with ParseError -> match EConstr.kind sigma term with - | Term.App(t,args) -> + | App(t,args) -> ( match EConstr.kind sigma t with - | Term.Const c -> + | Const c -> ( match assoc_ops sigma t ops_spec with | Binop f -> combine env f (args.(0),args.(1)) | Opp -> let (expr,env) = parse_expr env args.(0) in @@ -1077,13 +948,13 @@ struct let rec rconstant sigma term = match EConstr.kind sigma term with - | Term.Const x -> + | Const x -> if EConstr.eq_constr sigma term (Lazy.force coq_R0) then Mc.C0 else if EConstr.eq_constr sigma term (Lazy.force coq_R1) then Mc.C1 else raise ParseError - | Term.App(op,args) -> + | App(op,args) -> begin try (* the evaluation order is important in the following *) @@ -1153,7 +1024,7 @@ struct if debug then Feedback.msg_debug (Pp.str "parse_arith: " ++ Printer.pr_leconstr_env gl.env sigma cstr ++ fnl ()); match EConstr.kind sigma cstr with - | Term.App(op,args) -> + | 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 @@ -1168,17 +1039,6 @@ struct (* generic parsing of arithmetic expressions *) - let rec f2f = function - | TT -> Mc.TT - | FF -> Mc.FF - | X _ -> Mc.X - | A (x,_,_) -> Mc.A x - | C (a,b) -> Mc.Cj(f2f a,f2f b) - | D (a,b) -> Mc.D(f2f a,f2f b) - | N (a) -> Mc.N(f2f a) - | I(a,_,b) -> Mc.I(f2f a,f2f b) - - let mkC f1 f2 = C(f1,f2) let mkD f1 f2 = D(f1,f2) let mkIff f1 f2 = C(I(f1,None,f2),I(f2,None,f1)) @@ -1208,7 +1068,7 @@ struct let rec xparse_formula env tg term = match EConstr.kind sigma term with - | Term.App(l,rst) -> + | App(l,rst) -> (match rst with | [|a;b|] when EConstr.eq_constr sigma l (Lazy.force coq_and) -> let f,env,tg = xparse_formula env tg a in @@ -1225,7 +1085,7 @@ struct let g,env,tg = xparse_formula env tg b in mkformula_binary mkIff term f g,env,tg | _ -> parse_atom env tg term) - | Term.Prod(typ,a,b) when EConstr.Vars.noccurn sigma 1 b -> + | Prod(typ,a,b) when EConstr.Vars.noccurn sigma 1 b -> let f,env,tg = xparse_formula env tg a in let g,env,tg = xparse_formula env tg b in mkformula_binary mkI term f g,env,tg @@ -1323,31 +1183,6 @@ let dump_qexpr = lazy dump_op = List.map (fun (x,y) -> (y,Lazy.force x)) qop_table } - let dump_positive_as_R p = - let mult = Lazy.force coq_Rmult in - let add = Lazy.force coq_Rplus in - - let one = Lazy.force coq_R1 in - let mk_add x y = EConstr.mkApp(add,[|x;y|]) in - let mk_mult x y = EConstr.mkApp(mult,[|x;y|]) in - - let two = mk_add one one in - - let rec dump_positive p = - match p with - | Mc.XH -> one - | Mc.XO p -> mk_mult two (dump_positive p) - | Mc.XI p -> mk_add one (mk_mult two (dump_positive p)) in - - dump_positive p - -let dump_n_as_R n = - let z = CoqToCaml.n n in - if z = 0 - then Lazy.force coq_R0 - else dump_positive_as_R (CamlToCoq.positive z) - - let rec dump_Rcst_as_R cst = match cst with | Mc.C0 -> Lazy.force coq_R0 @@ -1481,54 +1316,6 @@ end (** open M -let rec sig_of_cone = function - | Mc.PsatzIn n -> [CoqToCaml.nat n] - | Mc.PsatzMulE(w1,w2) -> (sig_of_cone w1)@(sig_of_cone w2) - | Mc.PsatzMulC(w1,w2) -> (sig_of_cone w2) - | Mc.PsatzAdd(w1,w2) -> (sig_of_cone w1)@(sig_of_cone w2) - | _ -> [] - -let same_proof sg cl1 cl2 = - let rec xsame_proof sg = - match sg with - | [] -> true - | n::sg -> - (try Int.equal (List.nth cl1 n) (List.nth cl2 n) with Invalid_argument _ -> false) - && (xsame_proof sg ) in - xsame_proof sg - -let tags_of_clause tgs wit clause = - let rec xtags tgs = function - | Mc.PsatzIn n -> Names.Id.Set.union tgs - (snd (List.nth clause (CoqToCaml.nat n) )) - | Mc.PsatzMulC(e,w) -> xtags tgs w - | Mc.PsatzMulE (w1,w2) | Mc.PsatzAdd(w1,w2) -> xtags (xtags tgs w1) w2 - | _ -> tgs in - xtags tgs wit - -(*let tags_of_cnf wits cnf = - List.fold_left2 (fun acc w cl -> tags_of_clause acc w cl) - Names.Id.Set.empty wits cnf *) - -let find_witness prover polys1 = try_any prover polys1 - -let rec witness prover l1 l2 = - match l2 with - | [] -> Some [] - | e :: l2 -> - match find_witness prover (e::l1) with - | None -> None - | Some w -> - (match witness prover l1 l2 with - | None -> None - | Some l -> Some (w::l) - ) - -let rec apply_ids t ids = - match ids with - | [] -> t - | i::ids -> apply_ids (mkApp(t,[| mkVar i |])) ids - let coq_Node = lazy (gen_constant_in_modules "VarMap" [["Coq" ; "micromega" ; "VarMap"];["VarMap"]] "Node") @@ -1559,15 +1346,6 @@ let vm_of_list env = List.fold_left (fun vm (c,i) -> Mc.vm_add d (CamlToCoq.positive i) c vm) Mc.Empty env - -let rec pp_varmap o vm = - match vm with - | Mc.Empty -> output_string o "[]" - | Mc.Leaf z -> Printf.fprintf o "[%a]" pp_z z - | Mc.Node(l,z,r) -> Printf.fprintf o "[%a, %a, %a]" pp_varmap l pp_z z pp_varmap r - - - let rec dump_proof_term = function | Micromega.DoneProof -> Lazy.force coq_doneProof | Micromega.RatProof(cone,rst) -> @@ -1662,45 +1440,11 @@ let qq_domain_spec = lazy { dump_proof = dump_psatz coq_Q dump_q } -let rcst_domain_spec = lazy { - typ = Lazy.force coq_R; - coeff = Lazy.force coq_Rcst; - dump_coeff = dump_Rcst; - proof_typ = Lazy.force coq_QWitness ; - dump_proof = dump_psatz coq_Q dump_q -} - (** Naive topological sort of constr according to the subterm-ordering *) (* An element is minimal x is minimal w.r.t y if x <= y or (x and y are incomparable) *) -let is_min le x y = - if le x y then true - else if le y x then false else true - -let is_minimal le l c = List.for_all (is_min le c) l - -let find_rem p l = - let rec xfind_rem acc l = - match l with - | [] -> (None, acc) - | x :: l -> if p x then (Some x, acc @ l) - else xfind_rem (x::acc) l in - xfind_rem [] l - -let find_minimal le l = find_rem (is_minimal le l) l - -let rec mk_topo_order le l = - match find_minimal le l with - | (None , _) -> [] - | (Some v,l') -> v :: (mk_topo_order le l') - - -let topo_sort_constr l = - mk_topo_order (fun c t -> Termops.dependent Evd.empty (** FIXME *) (EConstr.of_constr c) (EConstr.of_constr t)) l - - (** * Instanciate the current Coq goal with a Micromega formula, a varmap, and a * witness. @@ -1778,13 +1522,6 @@ let witness_list prover l = let witness_list_tags = witness_list -(* *Deprecated* let is_singleton = function [] -> true | [e] -> true | _ -> false *) - -let pp_ml_list pp_elt o l = - output_string o "[" ; - List.iter (fun x -> Printf.fprintf o "%a ;" pp_elt x) l ; - output_string o "]" - (** * Prune the proof object, according to the 'diff' between two cnf formulas. *) @@ -1792,7 +1529,7 @@ let pp_ml_list pp_elt o l = let compact_proofs (cnf_ff: 'cst cnf) res (cnf_ff': 'cst cnf) = let compact_proof (old_cl:'cst clause) (prf,prover) (new_cl:'cst clause) = - let new_cl = Mutils.mapi (fun (f,_) i -> (f,i)) new_cl in + let new_cl = List.mapi (fun i (f,_) -> (f,i)) new_cl in let remap i = let formula = try fst (List.nth old_cl i) with Failure _ -> failwith "bad old index" in List.assoc formula new_cl in @@ -1991,7 +1728,7 @@ let micromega_gen let intro_vars = Tacticals.New.tclTHENLIST (List.map intro vars) in let intro_props = Tacticals.New.tclTHENLIST (List.map intro props) in - let ipat_of_name id = Some (CAst.make @@ Misctypes.IntroNaming (Misctypes.IntroIdentifier id)) in + let ipat_of_name id = Some (CAst.make @@ IntroNaming (Namegen.IntroIdentifier id)) in let goal_name = fresh_id Id.Set.empty (Names.Id.of_string "__arith") gl in let env' = List.map (fun (id,i) -> EConstr.mkVar id,i) vars in @@ -2106,7 +1843,7 @@ let micromega_genr prover tac = let intro_vars = Tacticals.New.tclTHENLIST (List.map intro vars) in let intro_props = Tacticals.New.tclTHENLIST (List.map intro props) in - let ipat_of_name id = Some (CAst.make @@ Misctypes.IntroNaming (Misctypes.IntroIdentifier id)) in + let ipat_of_name id = Some (CAst.make @@ IntroNaming (Namegen.IntroIdentifier id)) in let goal_name = fresh_id Id.Set.empty (Names.Id.of_string "__arith") gl in let env' = List.map (fun (id,i) -> EConstr.mkVar id,i) vars in @@ -2158,7 +1895,11 @@ let lift_ratproof prover l = | Some c -> Some (Mc.RatProof( c,Mc.DoneProof)) type micromega_polys = (Micromega.q Mc.pol * Mc.op1) list + +[@@@ocaml.warning "-37"] type csdp_certificate = S of Sos_types.positivstellensatz option | F of string +(* Used to read the result of the execution of csdpcert *) + type provername = string * int option (** @@ -2406,16 +2147,6 @@ let nlinear_Z = { pp_f = fun o x -> pp_pol pp_z o (fst x) } - - -let tauto_lia ff = - let prover = linear_Z in - let cnf_ff,_ = cnf Mc.negate Mc.normalise Mc.zunsat Mc.zdeduce ff in - match witness_list_tags [prover] cnf_ff with - | None -> None - | Some l -> Some (List.map fst l) - - (** * Functions instantiating micromega_gen with the appropriate theories and * solvers diff --git a/plugins/micromega/coq_micromega.mli b/plugins/micromega/coq_micromega.mli new file mode 100644 index 000000000..b91feb398 --- /dev/null +++ b/plugins/micromega/coq_micromega.mli @@ -0,0 +1,22 @@ +(************************************************************************) +(* * 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) *) +(************************************************************************) + +val psatz_Z : int -> unit Proofview.tactic -> unit Proofview.tactic +val psatz_Q : int -> unit Proofview.tactic -> unit Proofview.tactic +val psatz_R : int -> unit Proofview.tactic -> unit Proofview.tactic +val xlia : unit Proofview.tactic -> unit Proofview.tactic +val xnlia : unit Proofview.tactic -> unit Proofview.tactic +val nra : unit Proofview.tactic -> unit Proofview.tactic +val nqa : unit Proofview.tactic -> unit Proofview.tactic +val sos_Z : unit Proofview.tactic -> unit Proofview.tactic +val sos_Q : unit Proofview.tactic -> unit Proofview.tactic +val sos_R : unit Proofview.tactic -> unit Proofview.tactic +val lra_Q : unit Proofview.tactic -> unit Proofview.tactic +val lra_R : unit Proofview.tactic -> unit Proofview.tactic diff --git a/plugins/micromega/csdpcert.ml b/plugins/micromega/csdpcert.ml index a1245b7cc..9c1b4810d 100644 --- a/plugins/micromega/csdpcert.ml +++ b/plugins/micromega/csdpcert.ml @@ -20,7 +20,6 @@ open Sos_types open Sos_lib module Mc = Micromega -module Ml2C = Mutils.CamlToCoq module C2Ml = Mutils.CoqToCaml type micromega_polys = (Micromega.q Mc.pol * Mc.op1) list @@ -28,7 +27,6 @@ type csdp_certificate = S of Sos_types.positivstellensatz option | F of string type provername = string * int option -let debug = false let flags = [Open_append;Open_binary;Open_creat] let chan = open_out_gen flags 0o666 "trace" @@ -55,27 +53,6 @@ struct end open M -open Mutils - - - - -let canonical_sum_to_string = function s -> failwith "not implemented" - -let print_canonical_sum m = Format.print_string (canonical_sum_to_string m) - -let print_list_term o l = - output_string o "print_list_term\n"; - List.iter (fun (e,k) -> Printf.fprintf o "q: %s %s ;" - (string_of_poly (poly_of_term (expr_to_term e))) - (match k with - Mc.Equal -> "= " - | Mc.Strict -> "> " - | Mc.NonStrict -> ">= " - | _ -> failwith "not_implemented")) (List.map (fun (e, o) -> Mc.denorm e , o) l) ; - output_string o "\n" - - let partition_expr l = let rec f i = function | [] -> ([],[],[]) @@ -125,7 +102,7 @@ let real_nonlinear_prover d l = (sets_of_list neq) in let (cert_ideal, cert_cone,monoid) = deepen_until d (fun d -> - list_try_find (fun m -> let (ci,cc) = + tryfind (fun m -> let (ci,cc) = real_positivnullstellensatz_general false d peq pge (poly_neg (fst m) ) in (ci,cc,snd m)) monoids) 0 in @@ -144,7 +121,7 @@ let real_nonlinear_prover d l = | l -> Monoid l in List.fold_right (fun x y -> Product(x,y)) lt sq in - let proof = list_fold_right_elements + let proof = end_itlist (fun s t -> Sum(s,t)) (proof_ne :: proofs_ideal @ proofs_cone) in S (Some proof) with @@ -158,7 +135,7 @@ let pure_sos l = (* If there is no strict inequality, I should nonetheless be able to try something - over Z > is equivalent to -1 >= *) try - let l = List.combine l (interval 0 (List.length l -1)) in + let l = List.combine l (CList.interval 0 (List.length l -1)) in let (lt,i) = try (List.find (fun (x,_) -> Pervasives.(=) (snd x) Mc.Strict) l) with Not_found -> List.hd l in let plt = poly_neg (poly_of_term (expr_to_term (fst lt))) in @@ -183,13 +160,6 @@ let run_prover prover pb = | "pure_sos", None -> pure_sos pb | prover, _ -> (Printf.printf "unknown prover: %s\n" prover; exit 1) - -let output_csdp_certificate o = function - | S None -> output_string o "S None" - | S (Some p) -> Printf.fprintf o "S (Some %a)" output_psatz p - | F s -> Printf.fprintf o "F %s" s - - let main () = try let (prover,poly) = (input_value stdin : provername * micromega_polys) in diff --git a/plugins/micromega/csdpcert.mli b/plugins/micromega/csdpcert.mli new file mode 100644 index 000000000..7c3ee6004 --- /dev/null +++ b/plugins/micromega/csdpcert.mli @@ -0,0 +1,9 @@ +(************************************************************************) +(* * 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) *) +(************************************************************************) diff --git a/plugins/micromega/g_micromega.mli b/plugins/micromega/g_micromega.mli new file mode 100644 index 000000000..7c3ee6004 --- /dev/null +++ b/plugins/micromega/g_micromega.mli @@ -0,0 +1,9 @@ +(************************************************************************) +(* * 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) *) +(************************************************************************) diff --git a/plugins/micromega/mfourier.ml b/plugins/micromega/mfourier.ml index 377994415..3328abdab 100644 --- a/plugins/micromega/mfourier.ml +++ b/plugins/micromega/mfourier.ml @@ -1,13 +1,9 @@ +open Util open Num -module Utils = Mutils open Polynomial open Vect -let map_option = Utils.map_option -let from_option = Utils.from_option - let debug = false -type ('a,'b) lr = Inl of 'a | Inr of 'b let compare_float (p : float) q = Pervasives.compare p q @@ -26,9 +22,6 @@ struct Intervals needs to be explicitly normalised. *) - type who = Left | Right - - (** if then interval [itv] is empty, [norm_itv itv] returns [None] otherwise, it returns [Some itv] *) @@ -37,14 +30,6 @@ struct | Some a , Some b -> if a <=/ b then Some itv else None | _ -> Some itv - (** [opp_itv itv] computes the opposite interval *) - let opp_itv itv = - let (l,r) = itv in - (map_option minus_num r, map_option minus_num l) - - - - (** [inter i1 i2 = None] if the intersection of intervals is empty [inter i1 i2 = Some i] if [i] is the intersection of the intervals [i1] and [i2] *) let inter i1 i2 = @@ -92,10 +77,6 @@ type vector = Vect.t module ISet = Set.Make(Int) - -module PSet = ISet - - module System = Hashtbl.Make(Vect) type proof = @@ -131,14 +112,6 @@ and cstr_info = { (** To be thrown when a system has no solution *) exception SystemContradiction of proof -let hyps prf = - let rec hyps prf acc = - match prf with - | Assum i -> ISet.add i acc - | Elim(_,prf1,prf2) - | And(prf1,prf2) -> hyps prf1 (hyps prf2 acc) in - hyps prf ISet.empty - (** Pretty printing *) let rec pp_proof o prf = @@ -147,26 +120,6 @@ let hyps prf = | Elim(v, prf1,prf2) -> Printf.fprintf o "E(%i,%a,%a)" v pp_proof prf1 pp_proof prf2 | And(prf1,prf2) -> Printf.fprintf o "A(%a,%a)" pp_proof prf1 pp_proof prf2 -let pp_bound o = function - | None -> output_string o "oo" - | Some a -> output_string o (string_of_num a) - -let pp_itv o (l,r) = Printf.fprintf o "(%a,%a)" pp_bound l pp_bound r - - -let pp_iset o s = - output_string o "{" ; - ISet.fold (fun i _ -> Printf.fprintf o "%i " i) s (); - output_string o "}" - -let pp_pset o s = - output_string o "{" ; - PSet.fold (fun i _ -> Printf.fprintf o "%i " i) s (); - output_string o "}" - - -let pp_info o i = pp_itv o i.bound - let pp_cstr o (vect,bnd) = let (l,r) = bnd in (match l with @@ -183,11 +136,6 @@ let pp_system o sys= System.iter (fun vect ibnd -> pp_cstr o (vect,(!ibnd).bound)) sys - - -let pp_split_cstr o (vl,v,c,_) = - Printf.fprintf o "(val x = %s ,%a,%s)" (string_of_num vl) pp_vect v (string_of_num c) - (** [merge_cstr_info] takes: - the intersection of bounds and - the union of proofs @@ -243,8 +191,8 @@ let normalise_cstr vect cinfo = (if n <>/ Int 1 then List.map (fun (x,nx) -> (x,nx // n)) vect else vect), let divn x = x // n in if Int.equal (sign_num n) 1 - then{cinfo with bound = (map_option divn l , map_option divn r) } - else {cinfo with pos = cinfo.neg ; neg = cinfo.pos ; bound = (map_option divn r , map_option divn l)}) + then{cinfo with bound = (Option.map divn l , Option.map divn r) } + else {cinfo with pos = cinfo.neg ; neg = cinfo.pos ; bound = (Option.map divn r , Option.map divn l)}) (** For compatibility, there is an external representation of constraints *) @@ -281,7 +229,7 @@ let load_system l = let sys = System.create 1000 in - let li = Mutils.mapi (fun e i -> (e,i)) l in + let li = List.mapi (fun i e -> (e,i)) l in let vars = List.fold_left (fun vrs (cstr,i) -> match norm_cstr cstr i with @@ -335,9 +283,6 @@ let add (v1,c1) (v2,c2) = (* Printf.printf "add(%a,%s,%a,%s) -> %a\n" pp_vect v1 (string_of_num c1) pp_vect v2 (string_of_num c2) pp_vect (fst res) ;*) res -type tlr = (num * vector * cstr_info) list -type tm = (vector * cstr_info ) list - (** To perform Fourier elimination, constraints are categorised depending on the sign of the variable to eliminate. *) (** [split x vect info (l,m,r)] @@ -381,8 +326,8 @@ let project vr sys = let {neg = n1 ; pos = p1 ; bound = bound1 ; prf = prf1} = info1 and {neg = n2 ; pos = p2 ; bound = bound2 ; prf = prf2} = info2 in - let bnd1 = from_option (fst bound1) - and bnd2 = from_option (fst bound2) in + let bnd1 = Option.get (fst bound1) + and bnd2 = Option.get (fst bound2) in let bound = (bnd1 // v1) +/ (bnd2 // minus_num v2) in let vres,(n,p) = add (vect1,v1) (vect2,minus_num v2) in (vres,{neg = n ; pos = p ; bound = (Some bound, None); prf = Elim(vr,info1.prf,info2.prf)}) in @@ -419,13 +364,13 @@ let project_using_eq vr c vect bound prf (vect',info') = let bndres = let f x = cst +/ x // c2 in let (l,r) = info'.bound in - (map_option f l , map_option f r) in + (Option.map f l , Option.map f r) in (vres,{neg = n ; pos = p ; bound = bndres ; prf = Elim(vr,prf,info'.prf)}) | None -> (vect',info') let elim_var_using_eq vr vect cst prf sys = - let c = from_option (get vr vect) in + let c = Option.get (get vr vect) in let elim_var = project_using_eq vr c vect cst prf in @@ -444,9 +389,7 @@ let elim_var_using_eq vr vect cst prf sys = (** [size sys] computes the number of entries in the system of constraints *) let size sys = System.fold (fun v iref s -> s + (!iref).neg + (!iref).pos) sys 0 -module IMap = Map.Make(Int) - -let pp_map o map = IMap.fold (fun k elt () -> Printf.fprintf o "%i -> %s\n" k (string_of_num elt)) map () +module IMap = CMap.Make(Int) (** [eval_vect map vect] evaluates vector [vect] using the values of [map]. If [map] binds all the variables of [vect], we get @@ -475,8 +418,8 @@ let restrict_bound n sum (itv:interval) = | 0 -> if in_bound itv sum then (None,None) (* redundant *) else failwith "SystemContradiction" - | 1 -> map_option f l , map_option f r - | _ -> map_option f r , map_option f l + | 1 -> Option.map f l , Option.map f r + | _ -> Option.map f r , Option.map f l (** [bound_of_variable map v sys] computes the interval of [v] in @@ -613,12 +556,6 @@ struct |(Some a, Some b) -> a =/ b | _ -> false - let eq_bound bnd c = - match bnd with - |(Some a, Some b) -> a =/ b && c =/ b - | _ -> false - - let rec unroll_until v l = match l with | [] -> (false,[]) diff --git a/plugins/micromega/mfourier.mli b/plugins/micromega/mfourier.mli new file mode 100644 index 000000000..f1d8edeab --- /dev/null +++ b/plugins/micromega/mfourier.mli @@ -0,0 +1,49 @@ +(************************************************************************) +(* * 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) *) +(************************************************************************) + +module Itv : sig + + type interval = Num.num option * Num.num option + val range : interval -> Num.num option + val smaller_itv : interval -> interval -> bool + +end + +module IMap : CSig.MapS with type key = int + +type proof + +module Fourier : sig + + val find_point : Polynomial.cstr_compat list -> + ((IMap.key * Num.num) list, proof) Util.union + + val optimise : Polynomial.Vect.t -> + Polynomial.cstr_compat list -> + Itv.interval option + +end + +val pp_proof : out_channel -> proof -> unit + +module Proof : sig + + val mk_proof : Polynomial.cstr_compat list -> + proof -> (Polynomial.Vect.t * Polynomial.cstr_compat) list + + val add_op : Polynomial.op -> Polynomial.op -> Polynomial.op + +end + +val max_nb_cstr : int ref + +val eval_op : Polynomial.op -> Num.num -> Num.num -> bool + +exception TimeOut diff --git a/plugins/micromega/mutils.ml b/plugins/micromega/mutils.ml index 82367c0b2..9d03560b7 100644 --- a/plugins/micromega/mutils.ml +++ b/plugins/micromega/mutils.ml @@ -19,8 +19,6 @@ (* *) (************************************************************************) -let debug = false - let rec pp_list f o l = match l with | [] -> () @@ -36,15 +34,6 @@ let finally f rst = with any -> raise reraise ); raise reraise -let map_option f x = - match x with - | None -> None - | Some v -> Some (f v) - -let from_option = function - | None -> failwith "from_option" - | Some v -> v - let rec try_any l x = match l with | [] -> None @@ -52,13 +41,6 @@ let rec try_any l x = | None -> try_any l x | x -> x -let iteri f l = - let rec xiter i l = - match l with - | [] -> () - | e::l -> f i e ; xiter (i+1) l in - xiter 0 l - let all_sym_pairs f l = let pair_with acc e l = List.fold_left (fun acc x -> (f e x) ::acc) acc l in @@ -77,14 +59,6 @@ let all_pairs f l = | e::lx -> xpairs (pair_with acc e l) lx in xpairs [] l - - -let rec map3 f l1 l2 l3 = - match l1 , l2 ,l3 with - | [] , [] , [] -> [] - | e1::l1 , e2::l2 , e3::l3 -> (f e1 e2 e3)::(map3 f l1 l2 l3) - | _ -> invalid_arg "map3" - let rec is_sublist f l1 l2 = match l1 ,l2 with | [] ,_ -> true @@ -93,26 +67,6 @@ let rec is_sublist f l1 l2 = if f e e' then is_sublist f l1' l2' else is_sublist f l1 l2' -let list_try_find f = - let rec try_find_f = function - | [] -> failwith "try_find" - | h::t -> try f h with Failure _ -> try_find_f t - in - try_find_f - -let list_fold_right_elements f l = - let rec aux = function - | [] -> invalid_arg "list_fold_right_elements" - | [x] -> x - | x::l -> f x (aux l) in - aux l - -let interval n m = - let rec interval_n (l,m) = - if n > m then l else interval_n (m::l,pred m) - in - interval_n ([],m) - let extract pred l = List.fold_left (fun (fd,sys) e -> match fd with @@ -163,51 +117,7 @@ let rats_to_ints l = List.map (fun x -> (div_big_int (mult_big_int (numerator x) c) (denominator x))) l -(* Nasty reordering of lists - useful to trim certificate down *) -let mapi f l = - let rec xmapi i l = - match l with - | [] -> [] - | e::l -> (f e i)::(xmapi (i+1) l) in - xmapi 0 l - -let concatMapi f l = List.rev (mapi (fun e i -> (i,f e)) l) - (* assoc_pos j [a0...an] = [j,a0....an,j+n],j+n+1 *) -let assoc_pos j l = (mapi (fun e i -> e,i+j) l, j + (List.length l)) - -let assoc_pos_assoc l = - let rec xpos i l = - match l with - | [] -> [] - | (x,l) ::rst -> let (l',j) = assoc_pos i l in - (x,l')::(xpos j rst) in - xpos 0 l - -let filter_pos f l = - (* Could sort ... take care of duplicates... *) - let rec xfilter l = - match l with - | [] -> [] - | (x,e)::l -> - if List.exists (fun ee -> List.mem ee f) (List.map snd e) - then (x,e)::(xfilter l) - else xfilter l in - xfilter l - -let select_pos lpos l = - let rec xselect i lpos l = - match lpos with - | [] -> [] - | j::rpos -> - match l with - | [] -> failwith "select_pos" - | e::l -> - if Int.equal i j - then e:: (xselect (i+1) rpos l) - else xselect (i+1) lpos l in - xselect 0 lpos l - (** * MODULE: Coq to Caml data-structure mappings *) @@ -238,12 +148,6 @@ struct | XI i -> 1+(2*(index i)) | XO i -> 2*(index i) - let z x = - match x with - | Z0 -> 0 - | Zpos p -> (positive p) - | Zneg p -> - (positive p) - open Big_int let rec positive_big_int p = @@ -258,8 +162,6 @@ struct | Zpos p -> (positive_big_int p) | Zneg p -> minus_big_int (positive_big_int p) - let num x = Num.Big_int (z_big_int x) - let q_to_num {qnum = x ; qden = y} = Big_int (z_big_int x) // (Big_int (z_big_int (Zpos y))) @@ -352,17 +254,6 @@ struct let c = cmp e1 e2 in if Int.equal c 0 then compare_list cmp l1 l2 else c -(** - * hash_list takes a hash function and a list, and computes an integer which - * is the hash value of the list. - *) - let hash_list hash l = - let rec _hash_list l h = - match l with - | [] -> h lxor (Hashtbl.hash []) - | e::l -> _hash_list l ((hash e) lxor h) - in _hash_list l 0 - end (** diff --git a/plugins/micromega/mutils.mli b/plugins/micromega/mutils.mli new file mode 100644 index 000000000..7b7a090de --- /dev/null +++ b/plugins/micromega/mutils.mli @@ -0,0 +1,70 @@ +(************************************************************************) +(* * 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) *) +(************************************************************************) + +val numerator : Num.num -> Big_int.big_int +val denominator : Num.num -> Big_int.big_int + +module Cmp : sig + + val compare_list : ('a -> 'b -> int) -> 'a list -> 'b list -> int + val compare_lexical : (unit -> int) list -> int + +end + +module Tag : sig + + type t + + val pp : out_channel -> t -> unit + val next : t -> t + val from : int -> t + +end + +module TagSet : CSig.SetS with type elt = Tag.t + +val pp_list : (out_channel -> 'a -> 'b) -> out_channel -> 'a list -> unit + +module CamlToCoq : sig + + val positive : int -> Micromega.positive + val bigint : Big_int.big_int -> Micromega.z + val n : int -> Micromega.n + val nat : int -> Micromega.nat + val q : Num.num -> Micromega.q + val index : int -> Micromega.positive + val z : int -> Micromega.z + val positive_big_int : Big_int.big_int -> Micromega.positive + +end + +module CoqToCaml : sig + + val z_big_int : Micromega.z -> Big_int.big_int + val q_to_num : Micromega.q -> Num.num + val positive : Micromega.positive -> int + val n : Micromega.n -> int + val nat : Micromega.nat -> int + val index : Micromega.positive -> int + +end + +val rats_to_ints : Num.num list -> Big_int.big_int list + +val all_pairs : ('a -> 'a -> 'b) -> 'a list -> 'b list +val all_sym_pairs : ('a -> 'a -> 'b) -> 'a list -> 'b list +val try_any : (('a -> 'b option) * 'c) list -> 'a -> 'b option +val is_sublist : ('a -> 'b -> bool) -> 'a list -> 'b list -> bool + +val gcd_list : Num.num list -> Big_int.big_int + +val extract : ('a -> 'b option) -> 'a list -> ('b * 'a) option * 'a list + +val command : string -> string array -> 'a -> 'b diff --git a/plugins/micromega/persistent_cache.mli b/plugins/micromega/persistent_cache.mli new file mode 100644 index 000000000..240fa490f --- /dev/null +++ b/plugins/micromega/persistent_cache.mli @@ -0,0 +1,47 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +open Hashtbl + +module type PHashtable = + sig + type 'a t + type key + + val create : int -> string -> 'a t + (** [create i f] creates an empty persistent table + with initial size i associated with file [f] *) + + + val open_in : string -> 'a t + (** [open_in f] rebuilds a table from the records stored in file [f]. + As marshaling is not type-safe, it migth segault. + *) + + val find : 'a t -> key -> 'a + (** find has the specification of Hashtable.find *) + + val add : 'a t -> key -> 'a -> unit + (** [add tbl key elem] adds the binding [key] [elem] to the table [tbl]. + (and writes the binding to the file associated with [tbl].) + If [key] is already bound, raises KeyAlreadyBound *) + + val close : 'a t -> unit + (** [close tbl] is closing the table. + Once closed, a table cannot be used. + i.e, find,add will raise UnboundTable *) + + val memo : string -> (key -> 'a) -> (key -> 'a) + (** [memo cache f] returns a memo function for [f] using file [cache] as persistent table. + Note that the cache will only be loaded when the function is used for the first time *) + + end + +module PHashtable(Key:HashedType) : PHashtable with type key = Key.t diff --git a/plugins/micromega/polynomial.ml b/plugins/micromega/polynomial.ml index db8b73a20..1d18a26f3 100644 --- a/plugins/micromega/polynomial.ml +++ b/plugins/micromega/polynomial.ml @@ -20,9 +20,9 @@ open Utils type var = int +let debug = false let (<+>) = add_num -let (<->) = minus_num let (<*>) = mult_num @@ -33,8 +33,6 @@ sig val is_const : t -> bool val var : var -> t val is_var : t -> bool - val find : var -> t -> int - val mult : var -> t -> t val prod : t -> t -> t val exp : t -> int -> t val div : t -> t -> t * int @@ -99,9 +97,6 @@ struct (* Get the degre of a variable in a monomial *) let find x m = try find x m with Not_found -> 0 - (* Multiply a monomial by a variable *) - let mult x m = add x ( (find x m) + 1) m - (* Product of monomials *) let prod m1 m2 = Map.fold (fun k d m -> add k ((find k m) + d) m) m1 m2 @@ -145,14 +140,10 @@ sig val variable : var -> t val add : Monomial.t -> num -> t -> t val constant : num -> t - val mult : Monomial.t -> num -> t -> t val product : t -> t -> t val addition : t -> t -> t val uminus : t -> t val fold : (Monomial.t -> num -> 'a -> 'a) -> t -> 'a -> 'a - val pp : out_channel -> t -> unit - val compare : t -> t -> int - val is_null : t -> bool val is_linear : t -> bool end = struct @@ -162,12 +153,6 @@ struct type t = num P.t - let pp o p = P.iter - (fun k v -> - if Monomial.compare Monomial.const k = 0 - then Printf.fprintf o "%s " (string_of_num v) - else Printf.fprintf o "%s*%a " (string_of_num v) Monomial.pp k) p - (* Get the coefficient of monomial mn *) let get : Monomial.t -> t -> num = fun mn p -> try find mn p with Not_found -> (Int 0) @@ -220,10 +205,6 @@ struct let fold = P.fold - let is_null p = fold (fun mn vl b -> b && sign_num vl = 0) p true - - let compare = compare compare_num - let is_linear p = P.fold (fun m _ acc -> acc && (Monomial.is_const m || Monomial.is_var m)) p true (* let is_linear p = @@ -277,7 +258,6 @@ module Vect = xfrom_list 0 l let zero_num = Int 0 - let unit_num = Int 1 let to_list m = @@ -311,11 +291,6 @@ module Vect = | 1 -> (k,v) :: (set i n l) | _ -> failwith "compare_num" - let gcd m = - let res = List.fold_left (fun x (i,e) -> Big_int.gcd_big_int x (Utils.numerator e)) Big_int.zero_big_int m in - if Big_int.compare_big_int res Big_int.zero_big_int = 0 - then Big_int.unit_big_int else res - let mul z t = match z with | Int 0 -> [] @@ -345,7 +320,7 @@ module Vect = - let compare : t -> t -> int = Utils.Cmp.compare_list (fun x y -> Utils.Cmp.compare_lexical + let compare : t -> t -> int = Mutils.Cmp.compare_list (fun x y -> Mutils.Cmp.compare_lexical [ (fun () -> Int.compare (fst x) (fst y)); (fun () -> compare_num (snd x) (snd y))]) @@ -395,18 +370,8 @@ let opMult o1 o2 = | Eq , Ge | Ge , Eq -> Ge | Ge , Ge -> Ge -let opAdd o1 o2 = - match o1 , o2 with - | Eq , _ | _ , Eq -> Eq - | Ge , Ge -> Ge - - - - open Big_int -type index = int - type prf_rule = | Hyp of int | Def of int @@ -550,35 +515,6 @@ let mul_proof_ext (p,c) prf = | _ -> MulC((p,c),prf) - -(* - let rec scale_prf_rule = function - | Hyp i -> (unit_big_int, Hyp i) - | Def i -> (unit_big_int, Def i) - | Cst c -> (unit_big_int, Cst i) - | Zero -> (unit_big_int, Zero) - | Square p -> (unit_big_int,Square p) - | Div(c,pr) -> - let (bi,pr') = scale_prf_rule pr in - (mult_big_int c bi , pr') - | MulC(p,pr) -> - let bi,pr' = scale_prf_rule pr in - (bi,MulC p,pr') - | MulPrf(p1,p2) -> - let b1,p1 = scale_prf_rule p1 in - let b2,p2 = scale_prf_rule p2 in - - - | AddPrf(p1,p2) -> - let b1,p1 = scale_prf_rule p1 in - let b2,p2 = scale_prf_rule p2 in - let g = gcd_big_int -*) - - - - - module LinPoly = struct type t = Vect.t * num diff --git a/plugins/micromega/polynomial.mli b/plugins/micromega/polynomial.mli new file mode 100644 index 000000000..4c095202a --- /dev/null +++ b/plugins/micromega/polynomial.mli @@ -0,0 +1,118 @@ +(************************************************************************) +(* * 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) *) +(************************************************************************) + +type var = int + +module Monomial : sig + + type t + val fold : (var -> int -> 'a -> 'a) -> t -> 'a -> 'a + val const : t + val sqrt : t -> t option + val is_var : t -> bool + val div : t -> t -> t * int + + val compare : t -> t -> int + +end + +module Poly : sig + + type t + + val constant : Num.num -> t + val variable : var -> t + val addition : t -> t -> t + val product : t -> t -> t + val uminus : t -> t + val get : Monomial.t -> t -> Num.num + val fold : (Monomial.t -> Num.num -> 'a -> 'a) -> t -> 'a -> 'a + + val is_linear : t -> bool + + val add : Monomial.t -> Num.num -> t -> t + +end + +module Vect : sig + + type var = int + type t = (var * Num.num) list + val hash : t -> int + val equal : t -> t -> bool + val compare : t -> t -> int + val pp_vect : 'a -> t -> unit + + val get : var -> t -> Num.num option + val set : var -> Num.num -> t -> t + val fresh : (int * 'a) list -> int + val update : Int.t -> (Num.num -> Num.num) -> + (Int.t * Num.num) list -> (Int.t * Num.num) list + val null : t + + val from_list : Num.num list -> t + val to_list : t -> Num.num list + + val add : t -> t -> t + val mul : Num.num -> t -> t + +end + +type cstr_compat = {coeffs : Vect.t ; op : op ; cst : Num.num} +and op = Eq | Ge + +type prf_rule = + | Hyp of int + | Def of int + | Cst of Big_int.big_int + | Zero + | Square of (Vect.t * Num.num) + | MulC of (Vect.t * Num.num) * prf_rule + | Gcd of Big_int.big_int * prf_rule + | MulPrf of prf_rule * prf_rule + | AddPrf of prf_rule * prf_rule + | CutPrf of prf_rule + +type proof = + | Done + | Step of int * prf_rule * proof + | Enum of int * prf_rule * Vect.t * prf_rule * proof list + +val proof_max_id : proof -> int + +val normalise_proof : int -> proof -> int * proof + +val output_proof : out_channel -> proof -> unit + +val add_proof : prf_rule -> prf_rule -> prf_rule +val mul_proof : Big_int.big_int -> prf_rule -> prf_rule + +module LinPoly : sig + + type t = Vect.t * Num.num + + module MonT : sig + + val clear : unit -> unit + val retrieve : int -> Monomial.t + + end + + val pivot_eq : Vect.var -> + cstr_compat * prf_rule -> + cstr_compat * prf_rule -> (cstr_compat * prf_rule) option + + val linpol_of_pol : Poly.t -> t + +end + +val output_cstr : out_channel -> cstr_compat -> unit + +val opMult : op -> op -> op diff --git a/plugins/micromega/sos.ml b/plugins/micromega/sos.ml index e1ceabe9e..42a41e176 100644 --- a/plugins/micromega/sos.ml +++ b/plugins/micromega/sos.ml @@ -95,7 +95,7 @@ let dim (v:vector) = fst v;; let vector_const c n = if c =/ Int 0 then vector_0 n - else (n,itlist (fun k -> k |-> c) (1--n) undefined :vector);; + else (n,List.fold_right (fun k -> k |-> c) (1--n) undefined :vector);; let vector_cmul c (v:vector) = let n = dim v in @@ -104,7 +104,7 @@ let vector_cmul c (v:vector) = let vector_of_list l = let n = List.length l in - (n,itlist2 (|->) (1--n) l undefined :vector);; + (n,List.fold_right2 (|->) (1--n) l undefined :vector);; (* ------------------------------------------------------------------------- *) (* Matrices; again rows and columns indexed from 1. *) @@ -242,7 +242,7 @@ let string_of_monomial m = if m = monomial_1 then "1" else let vps = List.fold_right (fun (x,k) a -> string_of_varpow x k :: a) (sort humanorder_varpow (graph m)) [] in - end_itlist (fun s t -> s^"*"^t) vps;; + String.concat "*" vps;; let string_of_cmonomial (c,m) = if m = monomial_1 then string_of_num c @@ -310,7 +310,7 @@ let rec poly_of_term t = match t with let sdpa_of_vector (v:vector) = let n = dim v in let strs = List.map (o (decimalize 20) (element v)) (1--n) in - end_itlist (fun x y -> x ^ " " ^ y) strs ^ "\n";; + String.concat " " strs ^ "\n";; (* ------------------------------------------------------------------------- *) (* String for a matrix numbered k, in SDPA sparse format. *) @@ -321,7 +321,7 @@ let sdpa_of_matrix k (m:matrix) = let ms = foldr (fun (i,j) c a -> if i > j then a else ((i,j),c)::a) (snd m) [] in let mss = sort (increasing fst) ms in - itlist (fun ((i,j),c) a -> + List.fold_right (fun ((i,j),c) a -> pfx ^ string_of_int i ^ " " ^ string_of_int j ^ " " ^ decimalize 20 c ^ "\n" ^ a) mss "";; @@ -340,7 +340,7 @@ let sdpa_of_problem comment obj mats = "1\n" ^ string_of_int n ^ "\n" ^ sdpa_of_vector obj ^ - itlist2 (fun k m a -> sdpa_of_matrix (k - 1) m ^ a) + List.fold_right2 (fun k m a -> sdpa_of_matrix (k - 1) m ^ a) (1--List.length mats) mats "";; (* ------------------------------------------------------------------------- *) @@ -489,11 +489,11 @@ let scale_then = and maximal_element amat acc = foldl (fun maxa m c -> max_num maxa (abs_num c)) acc amat in fun solver obj mats -> - let cd1 = itlist common_denominator mats (Int 1) + let cd1 = List.fold_right common_denominator mats (Int 1) and cd2 = common_denominator (snd obj) (Int 1) in let mats' = List.map (mapf (fun x -> cd1 */ x)) mats and obj' = vector_cmul cd2 obj in - let max1 = itlist maximal_element mats' (Int 0) + let max1 = List.fold_right maximal_element mats' (Int 0) and max2 = maximal_element (snd obj') (Int 0) in let scal1 = pow2 (20-int_of_float(log(float_of_num max1) /. log 2.0)) and scal2 = pow2 (20-int_of_float(log(float_of_num max2) /. log 2.0)) in @@ -551,7 +551,7 @@ let minimal_convex_hull = | (m::ms) -> if in_convex_hull ms m then ms else ms@[m] in let augment m ms = funpow 3 augment1 (m::ms) in fun mons -> - let mons' = itlist augment (List.tl mons) [List.hd mons] in + let mons' = List.fold_right augment (List.tl mons) [List.hd mons] in funpow (List.length mons') augment1 mons';; (* ------------------------------------------------------------------------- *) @@ -612,11 +612,11 @@ let newton_polytope pol = let vars = poly_variables pol in let mons = List.map (fun m -> List.map (fun x -> monomial_degree x m) vars) (dom pol) and ds = List.map (fun x -> (degree x pol + 1) / 2) vars in - let all = itlist (fun n -> allpairs (fun h t -> h::t) (0--n)) ds [[]] + let all = List.fold_right (fun n -> allpairs (fun h t -> h::t) (0--n)) ds [[]] and mons' = minimal_convex_hull mons in let all' = List.filter (fun m -> in_convex_hull mons' (List.map (fun x -> 2 * x) m)) all in - List.map (fun m -> itlist2 (fun v i a -> if i = 0 then a else (v |-> i) a) + List.map (fun m -> List.fold_right2 (fun v i a -> if i = 0 then a else (v |-> i) a) vars m monomial_1) (List.rev all');; (* ------------------------------------------------------------------------- *) @@ -657,8 +657,8 @@ let deration d = foldl (fun a i c -> gcd_num a (numerator c)) (Int 0) (snd l) in (c // (a */ a)),mapa (fun x -> a */ x) l in let d' = List.map adj d in - let a = itlist ((o) lcm_num ( (o) denominator fst)) d' (Int 1) // - itlist ((o) gcd_num ( (o) numerator fst)) d' (Int 0) in + let a = List.fold_right ((o) lcm_num ( (o) denominator fst)) d' (Int 1) // + List.fold_right ((o) gcd_num ( (o) numerator fst)) d' (Int 0) in (Int 1 // a),List.map (fun (c,l) -> (a */ c,l)) d';; (* ------------------------------------------------------------------------- *) @@ -719,7 +719,7 @@ let sdpa_of_blockdiagonal k m = let ents = foldl (fun a (b,i,j) c -> if i > j then a else ((b,i,j),c)::a) [] m in let entss = sort (increasing fst) ents in - itlist (fun ((b,i,j),c) a -> + List.fold_right (fun ((b,i,j),c) a -> pfx ^ string_of_int b ^ " " ^ string_of_int i ^ " " ^ string_of_int j ^ " " ^ decimalize 20 c ^ "\n" ^ a) entss "";; @@ -732,10 +732,10 @@ let sdpa_of_blockproblem comment nblocks blocksizes obj mats = "\"" ^ comment ^ "\"\n" ^ string_of_int m ^ "\n" ^ string_of_int nblocks ^ "\n" ^ - (end_itlist (fun s t -> s^" "^t) (List.map string_of_int blocksizes)) ^ + (String.concat " " (List.map string_of_int blocksizes)) ^ "\n" ^ sdpa_of_vector obj ^ - itlist2 (fun k m a -> sdpa_of_blockdiagonal (k - 1) m ^ a) + List.fold_right2 (fun k m a -> sdpa_of_blockdiagonal (k - 1) m ^ a) (1--List.length mats) mats "";; (* ------------------------------------------------------------------------- *) @@ -791,14 +791,14 @@ let blocks blocksizes bm = (fun a (b,i,j) c -> if b = b0 then ((i,j) |-> c) a else a) undefined bm in (((bs,bs),m):matrix)) - (zip blocksizes (1--List.length blocksizes));; + (List.combine blocksizes (1--List.length blocksizes));; (* ------------------------------------------------------------------------- *) (* Positiv- and Nullstellensatz. Flag "linf" forces a linear representation. *) (* ------------------------------------------------------------------------- *) let real_positivnullstellensatz_general linf d eqs leqs pol = - let vars = itlist ((o) union poly_variables) (pol::eqs @ List.map fst leqs) [] in + let vars = List.fold_right ((o) union poly_variables) (pol::eqs @ List.map fst leqs) [] in let monoid = if linf then (poly_const num_1,Rational_lt num_1):: @@ -808,16 +808,16 @@ let real_positivnullstellensatz_general linf d eqs leqs pol = let mk_idmultiplier k p = let e = d - multidegree p in let mons = enumerate_monomials e vars in - let nons = zip mons (1--List.length mons) in + let nons = List.combine mons (1--List.length mons) in mons, - itlist (fun (m,n) -> (m |-> ((-k,-n,n) |=> Int 1))) nons undefined in + List.fold_right (fun (m,n) -> (m |-> ((-k,-n,n) |=> Int 1))) nons undefined in let mk_sqmultiplier k (p,c) = let e = (d - multidegree p) / 2 in let mons = enumerate_monomials e vars in - let nons = zip mons (1--List.length mons) in + let nons = List.combine mons (1--List.length mons) in mons, - itlist (fun (m1,n1) -> - itlist (fun (m2,n2) a -> + List.fold_right (fun (m1,n1) -> + List.fold_right (fun (m2,n2) a -> let m = monomial_mul m1 m2 in if n1 > n2 then a else let c = if n1 = n2 then Int 1 else Int 2 in @@ -825,17 +825,17 @@ let real_positivnullstellensatz_general linf d eqs leqs pol = (m |-> equation_add ((k,n1,n2) |=> c) e) a) nons) nons undefined in - let sqmonlist,sqs = unzip(List.map2 mk_sqmultiplier (1--List.length monoid) monoid) - and idmonlist,ids = unzip(List.map2 mk_idmultiplier (1--List.length eqs) eqs) in + let sqmonlist,sqs = List.split(List.map2 mk_sqmultiplier (1--List.length monoid) monoid) + and idmonlist,ids = List.split(List.map2 mk_idmultiplier (1--List.length eqs) eqs) in let blocksizes = List.map List.length sqmonlist in let bigsum = - itlist2 (fun p q a -> epoly_pmul p q a) eqs ids - (itlist2 (fun (p,c) s a -> epoly_pmul p s a) monoid sqs + List.fold_right2 (fun p q a -> epoly_pmul p q a) eqs ids + (List.fold_right2 (fun (p,c) s a -> epoly_pmul p s a) monoid sqs (epoly_of_poly(poly_neg pol))) in let eqns = foldl (fun a m e -> e::a) [] bigsum in let pvs,assig = eliminate_all_equations (0,0,0) eqns in let qvars = (0,0,0)::pvs in - let allassig = itlist (fun v -> (v |-> (v |=> Int 1))) pvs assig in + let allassig = List.fold_right (fun v -> (v |-> (v |=> Int 1))) pvs assig in let mk_matrix v = foldl (fun m (b,i,j) ass -> if b < 0 then m else let c = tryapplyd ass v (Int 0) in @@ -858,8 +858,8 @@ let real_positivnullstellensatz_general linf d eqs leqs pol = else ()); let vec = nice_vector d raw_vec in let blockmat = iter (1,dim vec) - (fun i a -> bmatrix_add (bmatrix_cmul (element vec i) (el i mats)) a) - (bmatrix_neg (el 0 mats)) in + (fun i a -> bmatrix_add (bmatrix_cmul (element vec i) (List.nth mats i)) a) + (bmatrix_neg (List.nth mats 0)) in let allmats = blocks blocksizes blockmat in vec,List.map diag allmats in let vec,ratdias = @@ -867,7 +867,7 @@ let real_positivnullstellensatz_general linf d eqs leqs pol = else tryfind find_rounding (List.map Num.num_of_int (1--31) @ List.map pow2 (5--66)) in let newassigs = - itlist (fun k -> el (k - 1) pvs |-> element vec k) + List.fold_right (fun k -> List.nth pvs (k - 1) |-> element vec k) (1--dim vec) ((0,0,0) |=> Int(-1)) in let finalassigs = foldl (fun a v e -> (v |-> equation_eval newassigs e) a) newassigs @@ -877,17 +877,17 @@ let real_positivnullstellensatz_general linf d eqs leqs pol = undefined p in let mk_sos mons = let mk_sq (c,m) = - c,itlist (fun k a -> (el (k - 1) mons |--> element m k) a) + c,List.fold_right (fun k a -> (List.nth mons (k - 1) |--> element m k) a) (1--List.length mons) undefined in List.map mk_sq in let sqs = List.map2 mk_sos sqmonlist ratdias and cfs = List.map poly_of_epoly ids in let msq = List.filter (fun (a,b) -> b <> []) (List.map2 (fun a b -> a,b) monoid sqs) in - let eval_sq sqs = itlist + let eval_sq sqs = List.fold_right (fun (c,q) -> poly_add (poly_cmul c (poly_mul q q))) sqs poly_0 in let sanity = - itlist (fun ((p,c),s) -> poly_add (poly_mul p (eval_sq s))) msq - (itlist2 (fun p q -> poly_add (poly_mul p q)) cfs eqs + List.fold_right (fun ((p,c),s) -> poly_add (poly_mul p (eval_sq s))) msq + (List.fold_right2 (fun p q -> poly_add (poly_mul p q)) cfs eqs (poly_neg pol)) in if not(is_undefined sanity) then raise Sanity else cfs,List.map (fun (a,b) -> snd a,b) msq;; @@ -913,8 +913,8 @@ let monomial_order = fun m1 m2 -> if m2 = monomial_1 then true else if m1 = monomial_1 then false else let mon1 = dest_monomial m1 and mon2 = dest_monomial m2 in - let deg1 = itlist ((o) (+) snd) mon1 0 - and deg2 = itlist ((o) (+) snd) mon2 0 in + let deg1 = List.fold_right ((o) (+) snd) mon1 0 + and deg2 = List.fold_right ((o) (+) snd) mon2 0 in if deg1 < deg2 then false else if deg1 > deg2 then true else lexorder mon1 mon2;; @@ -929,7 +929,7 @@ let term_of_varpow = let term_of_monomial = fun m -> if m = monomial_1 then Const num_1 else let m' = dest_monomial m in - let vps = itlist (fun (x,k) a -> term_of_varpow x k :: a) m' [] in + let vps = List.fold_right (fun (x,k) a -> term_of_varpow x k :: a) m' [] in end_itlist (fun s t -> Mul (s,t)) vps;; let term_of_cmonomial = @@ -953,202 +953,12 @@ let term_of_sos (pr,sqs) = else Product(pr,end_itlist (fun a b -> Sum(a,b)) (List.map term_of_sqterm sqs));; (* ------------------------------------------------------------------------- *) -(* Interface to HOL. *) -(* ------------------------------------------------------------------------- *) -(* -let REAL_NONLINEAR_PROVER translator (eqs,les,lts) = - let eq0 = map (poly_of_term o lhand o concl) eqs - and le0 = map (poly_of_term o lhand o concl) les - and lt0 = map (poly_of_term o lhand o concl) lts in - let eqp0 = map (fun (t,i) -> t,Axiom_eq i) (zip eq0 (0--(length eq0 - 1))) - and lep0 = map (fun (t,i) -> t,Axiom_le i) (zip le0 (0--(length le0 - 1))) - and ltp0 = map (fun (t,i) -> t,Axiom_lt i) (zip lt0 (0--(length lt0 - 1))) in - let keq,eq = partition (fun (p,_) -> multidegree p = 0) eqp0 - and klep,lep = partition (fun (p,_) -> multidegree p = 0) lep0 - and kltp,ltp = partition (fun (p,_) -> multidegree p = 0) ltp0 in - let trivial_axiom (p,ax) = - match ax with - Axiom_eq n when eval undefined p <>/ num_0 -> el n eqs - | Axiom_le n when eval undefined p </ num_0 -> el n les - | Axiom_lt n when eval undefined p <=/ num_0 -> el n lts - | _ -> failwith "not a trivial axiom" in - try let th = tryfind trivial_axiom (keq @ klep @ kltp) in - CONV_RULE (LAND_CONV REAL_POLY_CONV THENC REAL_RAT_RED_CONV) th - with Failure _ -> - let pol = itlist poly_mul (map fst ltp) (poly_const num_1) in - let leq = lep @ ltp in - let tryall d = - let e = multidegree pol in - let k = if e = 0 then 0 else d / e in - let eq' = map fst eq in - tryfind (fun i -> d,i,real_positivnullstellensatz_general false d eq' leq - (poly_neg(poly_pow pol i))) - (0--k) in - let d,i,(cert_ideal,cert_cone) = deepen tryall 0 in - let proofs_ideal = - map2 (fun q (p,ax) -> Eqmul(term_of_poly q,ax)) cert_ideal eq - and proofs_cone = map term_of_sos cert_cone - and proof_ne = - if ltp = [] then Rational_lt num_1 else - let p = end_itlist (fun s t -> Product(s,t)) (map snd ltp) in - funpow i (fun q -> Product(p,q)) (Rational_lt num_1) in - let proof = end_itlist (fun s t -> Sum(s,t)) - (proof_ne :: proofs_ideal @ proofs_cone) in - print_string("Translating proof certificate to HOL"); - print_newline(); - translator (eqs,les,lts) proof;; -*) -(* ------------------------------------------------------------------------- *) -(* A wrapper that tries to substitute away variables first. *) -(* ------------------------------------------------------------------------- *) -(* -let REAL_NONLINEAR_SUBST_PROVER = - let zero = `&0:real` - and mul_tm = `( * ):real->real->real` - and shuffle1 = - CONV_RULE(REWR_CONV(REAL_ARITH `a + x = (y:real) <=> x = y - a`)) - and shuffle2 = - CONV_RULE(REWR_CONV(REAL_ARITH `x + a = (y:real) <=> x = y - a`)) in - let rec substitutable_monomial fvs tm = - match tm with - Var(_,Tyapp("real",[])) when not (mem tm fvs) -> Int 1,tm - | Comb(Comb(Const("real_mul",_),c),(Var(_,_) as t)) - when is_ratconst c && not (mem t fvs) - -> rat_of_term c,t - | Comb(Comb(Const("real_add",_),s),t) -> - (try substitutable_monomial (union (frees t) fvs) s - with Failure _ -> substitutable_monomial (union (frees s) fvs) t) - | _ -> failwith "substitutable_monomial" - and isolate_variable v th = - match lhs(concl th) with - x when x = v -> th - | Comb(Comb(Const("real_add",_),(Var(_,Tyapp("real",[])) as x)),t) - when x = v -> shuffle2 th - | Comb(Comb(Const("real_add",_),s),t) -> - isolate_variable v(shuffle1 th) in - let make_substitution th = - let (c,v) = substitutable_monomial [] (lhs(concl th)) in - let th1 = AP_TERM (mk_comb(mul_tm,term_of_rat(Int 1 // c))) th in - let th2 = CONV_RULE(BINOP_CONV REAL_POLY_MUL_CONV) th1 in - CONV_RULE (RAND_CONV REAL_POLY_CONV) (isolate_variable v th2) in - fun translator -> - let rec substfirst(eqs,les,lts) = - try let eth = tryfind make_substitution eqs in - let modify = - CONV_RULE(LAND_CONV(SUBS_CONV[eth] THENC REAL_POLY_CONV)) in - substfirst(filter (fun t -> lhand(concl t) <> zero) (map modify eqs), - map modify les,map modify lts) - with Failure _ -> REAL_NONLINEAR_PROVER translator (eqs,les,lts) in - substfirst;; -*) -(* ------------------------------------------------------------------------- *) -(* Overall function. *) -(* ------------------------------------------------------------------------- *) -(* -let REAL_SOS = - let init = GEN_REWRITE_CONV ONCE_DEPTH_CONV [DECIMAL] - and pure = GEN_REAL_ARITH REAL_NONLINEAR_SUBST_PROVER in - fun tm -> let th = init tm in EQ_MP (SYM th) (pure(rand(concl th)));; -*) -(* ------------------------------------------------------------------------- *) -(* Add hacks for division. *) -(* ------------------------------------------------------------------------- *) -(* -let REAL_SOSFIELD = - let inv_tm = `inv:real->real` in - let prenex_conv = - TOP_DEPTH_CONV BETA_CONV THENC - PURE_REWRITE_CONV[FORALL_SIMP; EXISTS_SIMP; real_div; - REAL_INV_INV; REAL_INV_MUL; GSYM REAL_POW_INV] THENC - NNFC_CONV THENC DEPTH_BINOP_CONV `(/\)` CONDS_CELIM_CONV THENC - PRENEX_CONV - and setup_conv = NNF_CONV THENC WEAK_CNF_CONV THENC CONJ_CANON_CONV - and core_rule t = - try REAL_ARITH t - with Failure _ -> try REAL_RING t - with Failure _ -> REAL_SOS t - and is_inv = - let is_div = is_binop `(/):real->real->real` in - fun tm -> (is_div tm or (is_comb tm && rator tm = inv_tm)) && - not(is_ratconst(rand tm)) in - let BASIC_REAL_FIELD tm = - let is_freeinv t = is_inv t && free_in t tm in - let itms = setify(map rand (find_terms is_freeinv tm)) in - let hyps = map (fun t -> SPEC t REAL_MUL_RINV) itms in - let tm' = itlist (fun th t -> mk_imp(concl th,t)) hyps tm in - let itms' = map (curry mk_comb inv_tm) itms in - let gvs = map (genvar o type_of) itms' in - let tm'' = subst (zip gvs itms') tm' in - let th1 = setup_conv tm'' in - let cjs = conjuncts(rand(concl th1)) in - let ths = map core_rule cjs in - let th2 = EQ_MP (SYM th1) (end_itlist CONJ ths) in - rev_itlist (C MP) hyps (INST (zip itms' gvs) th2) in - fun tm -> - let th0 = prenex_conv tm in - let tm0 = rand(concl th0) in - let avs,bod = strip_forall tm0 in - let th1 = setup_conv bod in - let ths = map BASIC_REAL_FIELD (conjuncts(rand(concl th1))) in - EQ_MP (SYM th0) (GENL avs (EQ_MP (SYM th1) (end_itlist CONJ ths)));; -*) -(* ------------------------------------------------------------------------- *) -(* Integer version. *) -(* ------------------------------------------------------------------------- *) -(* -let INT_SOS = - let atom_CONV = - let pth = prove - (`(~(x <= y) <=> y + &1 <= x:int) /\ - (~(x < y) <=> y <= x) /\ - (~(x = y) <=> x + &1 <= y \/ y + &1 <= x) /\ - (x < y <=> x + &1 <= y)`, - REWRITE_TAC[INT_NOT_LE; INT_NOT_LT; INT_NOT_EQ; INT_LT_DISCRETE]) in - GEN_REWRITE_CONV I [pth] - and bub_CONV = GEN_REWRITE_CONV TOP_SWEEP_CONV - [int_eq; int_le; int_lt; int_ge; int_gt; - int_of_num_th; int_neg_th; int_add_th; int_mul_th; - int_sub_th; int_pow_th; int_abs_th; int_max_th; int_min_th] in - let base_CONV = TRY_CONV atom_CONV THENC bub_CONV in - let NNF_NORM_CONV = GEN_NNF_CONV false - (base_CONV,fun t -> base_CONV t,base_CONV(mk_neg t)) in - let init_CONV = - GEN_REWRITE_CONV DEPTH_CONV [FORALL_SIMP; EXISTS_SIMP] THENC - GEN_REWRITE_CONV DEPTH_CONV [INT_GT; INT_GE] THENC - CONDS_ELIM_CONV THENC NNF_NORM_CONV in - let p_tm = `p:bool` - and not_tm = `(~)` in - let pth = TAUT(mk_eq(mk_neg(mk_neg p_tm),p_tm)) in - fun tm -> - let th0 = INST [tm,p_tm] pth - and th1 = NNF_NORM_CONV(mk_neg tm) in - let th2 = REAL_SOS(mk_neg(rand(concl th1))) in - EQ_MP th0 (EQ_MP (AP_TERM not_tm (SYM th1)) th2);; -*) -(* ------------------------------------------------------------------------- *) -(* Natural number version. *) -(* ------------------------------------------------------------------------- *) -(* -let SOS_RULE tm = - let avs = frees tm in - let tm' = list_mk_forall(avs,tm) in - let th1 = NUM_TO_INT_CONV tm' in - let th2 = INT_SOS (rand(concl th1)) in - SPECL avs (EQ_MP (SYM th1) th2);; -*) -(* ------------------------------------------------------------------------- *) -(* Now pure SOS stuff. *) -(* ------------------------------------------------------------------------- *) - -(*prioritize_real();;*) - -(* ------------------------------------------------------------------------- *) (* Some combinatorial helper functions. *) (* ------------------------------------------------------------------------- *) let rec allpermutations l = if l = [] then [[]] else - itlist (fun h acc -> List.map (fun t -> h::t) + List.fold_right (fun h acc -> List.map (fun t -> h::t) (allpermutations (subtract l [h])) @ acc) l [];; let changevariables_monomial zoln (m:monomial) = @@ -1165,14 +975,14 @@ let changevariables zoln pol = let sdpa_of_vector (v:vector) = let n = dim v in let strs = List.map (o (decimalize 20) (element v)) (1--n) in - end_itlist (fun x y -> x ^ " " ^ y) strs ^ "\n";; + String.concat " " strs ^ "\n";; let sdpa_of_matrix k (m:matrix) = let pfx = string_of_int k ^ " 1 " in let ms = foldr (fun (i,j) c a -> if i > j then a else ((i,j),c)::a) (snd m) [] in let mss = sort (increasing fst) ms in - itlist (fun ((i,j),c) a -> + List.fold_right (fun ((i,j),c) a -> pfx ^ string_of_int i ^ " " ^ string_of_int j ^ " " ^ decimalize 20 c ^ "\n" ^ a) mss "";; @@ -1184,7 +994,7 @@ let sdpa_of_problem comment obj mats = "1\n" ^ string_of_int n ^ "\n" ^ sdpa_of_vector obj ^ - itlist2 (fun k m a -> sdpa_of_matrix (k - 1) m ^ a) + List.fold_right2 (fun k m a -> sdpa_of_matrix (k - 1) m ^ a) (1--List.length mats) mats "";; let run_csdp dbg obj mats = @@ -1224,9 +1034,9 @@ let sumofsquares_general_symmetry tool pol = let sym_eqs = let invariants = List.filter (fun vars' -> - is_undefined(poly_sub pol (changevariables (zip vars vars') pol))) + is_undefined(poly_sub pol (changevariables (List.combine vars vars') pol))) (allpermutations vars) in - let lpns = zip lpps (1--List.length lpps) in + let lpns = List.combine lpps (1--List.length lpps) in let lppcs = List.filter (fun (m,(n1,n2)) -> n1 <= n2) (allpairs @@ -1234,8 +1044,8 @@ let sumofsquares_general_symmetry tool pol = let clppcs = end_itlist (@) (List.map (fun ((m1,m2),(n1,n2)) -> List.map (fun vars' -> - (changevariables_monomial (zip vars vars') m1, - changevariables_monomial (zip vars vars') m2),(n1,n2)) + (changevariables_monomial (List.combine vars vars') m1, + changevariables_monomial (List.combine vars vars') m2),(n1,n2)) invariants) lppcs) in let clppcs_dom = setify(List.map fst clppcs) in @@ -1247,7 +1057,7 @@ let sumofsquares_general_symmetry tool pol = [] -> raise Sanity | [h] -> acc | h::t -> List.map (fun k -> (k |-> Int(-1)) (h |=> Int 1)) t @ acc in - itlist mk_eq eqvcls [] in + List.fold_right mk_eq eqvcls [] in let eqs = foldl (fun a x y -> y::a) [] (itern 1 lpps (fun m1 n1 -> itern 1 lpps (fun m2 n2 f -> @@ -1259,7 +1069,7 @@ let sumofsquares_general_symmetry tool pol = undefined pol)) @ sym_eqs in let pvs,assig = eliminate_all_equations (0,0) eqs in - let allassig = itlist (fun v -> (v |-> (v |=> Int 1))) pvs assig in + let allassig = List.fold_right (fun v -> (v |-> (v |=> Int 1))) pvs assig in let qvars = (0,0)::pvs in let diagents = end_itlist equation_add (List.map (fun i -> apply allassig (i,i)) (1--n)) in @@ -1281,18 +1091,18 @@ let sumofsquares_general_symmetry tool pol = else ()); let vec = nice_vector d raw_vec in let mat = iter (1,dim vec) - (fun i a -> matrix_add (matrix_cmul (element vec i) (el i mats)) a) - (matrix_neg (el 0 mats)) in + (fun i a -> matrix_add (matrix_cmul (element vec i) (List.nth mats i)) a) + (matrix_neg (List.nth mats 0)) in deration(diag mat) in let rat,dia = if pvs = [] then - let mat = matrix_neg (el 0 mats) in + let mat = matrix_neg (List.nth mats 0) in deration(diag mat) else tryfind find_rounding (List.map Num.num_of_int (1--31) @ List.map pow2 (5--66)) in let poly_of_lin(d,v) = - d,foldl(fun a i c -> (el (i - 1) lpps |-> c) a) undefined (snd v) in + d,foldl(fun a i c -> (List.nth lpps (i - 1) |-> c) a) undefined (snd v) in let lins = List.map poly_of_lin dia in let sqs = List.map (fun (d,l) -> poly_mul (poly_const d) (poly_pow l 2)) lins in let sos = poly_cmul rat (end_itlist poly_add sqs) in @@ -1300,325 +1110,3 @@ let sumofsquares_general_symmetry tool pol = let sumofsquares = sumofsquares_general_symmetry csdp;; -(* ------------------------------------------------------------------------- *) -(* Pure HOL SOS conversion. *) -(* ------------------------------------------------------------------------- *) -(* -let SOS_CONV = - let mk_square = - let pow_tm = `(pow)` and two_tm = `2` in - fun tm -> mk_comb(mk_comb(pow_tm,tm),two_tm) - and mk_prod = mk_binop `( * )` - and mk_sum = mk_binop `(+)` in - fun tm -> - let k,sos = sumofsquares(poly_of_term tm) in - let mk_sqtm(c,p) = - mk_prod (term_of_rat(k */ c)) (mk_square(term_of_poly p)) in - let tm' = end_itlist mk_sum (map mk_sqtm sos) in - let th = REAL_POLY_CONV tm and th' = REAL_POLY_CONV tm' in - TRANS th (SYM th');; -*) -(* ------------------------------------------------------------------------- *) -(* Attempt to prove &0 <= x by direct SOS decomposition. *) -(* ------------------------------------------------------------------------- *) -(* -let PURE_SOS_TAC = - let tac = - MATCH_ACCEPT_TAC(REWRITE_RULE[GSYM REAL_POW_2] REAL_LE_SQUARE) ORELSE - MATCH_ACCEPT_TAC REAL_LE_SQUARE ORELSE - (MATCH_MP_TAC REAL_LE_ADD THEN CONJ_TAC) ORELSE - (MATCH_MP_TAC REAL_LE_MUL THEN CONJ_TAC) ORELSE - CONV_TAC(RAND_CONV REAL_RAT_REDUCE_CONV THENC REAL_RAT_LE_CONV) in - REPEAT GEN_TAC THEN REWRITE_TAC[real_ge] THEN - GEN_REWRITE_TAC I [GSYM REAL_SUB_LE] THEN - CONV_TAC(RAND_CONV SOS_CONV) THEN - REPEAT tac THEN NO_TAC;; - -let PURE_SOS tm = prove(tm,PURE_SOS_TAC);; -*) -(* ------------------------------------------------------------------------- *) -(* Examples. *) -(* ------------------------------------------------------------------------- *) - -(***** - -time REAL_SOS - `a1 >= &0 /\ a2 >= &0 /\ - (a1 * a1 + a2 * a2 = b1 * b1 + b2 * b2 + &2) /\ - (a1 * b1 + a2 * b2 = &0) - ==> a1 * a2 - b1 * b2 >= &0`;; - -time REAL_SOS `&3 * x + &7 * a < &4 /\ &3 < &2 * x ==> a < &0`;; - -time REAL_SOS - `b pow 2 < &4 * a * c ==> ~(a * x pow 2 + b * x + c = &0)`;; - -time REAL_SOS - `(a * x pow 2 + b * x + c = &0) ==> b pow 2 >= &4 * a * c`;; - -time REAL_SOS - `&0 <= x /\ x <= &1 /\ &0 <= y /\ y <= &1 - ==> x pow 2 + y pow 2 < &1 \/ - (x - &1) pow 2 + y pow 2 < &1 \/ - x pow 2 + (y - &1) pow 2 < &1 \/ - (x - &1) pow 2 + (y - &1) pow 2 < &1`;; - -time REAL_SOS - `&0 <= b /\ &0 <= c /\ &0 <= x /\ &0 <= y /\ - (x pow 2 = c) /\ (y pow 2 = a pow 2 * c + b) - ==> a * c <= y * x`;; - -time REAL_SOS - `&0 <= x /\ &0 <= y /\ &0 <= z /\ x + y + z <= &3 - ==> x * y + x * z + y * z >= &3 * x * y * z`;; - -time REAL_SOS - `(x pow 2 + y pow 2 + z pow 2 = &1) ==> (x + y + z) pow 2 <= &3`;; - -time REAL_SOS - `(w pow 2 + x pow 2 + y pow 2 + z pow 2 = &1) - ==> (w + x + y + z) pow 2 <= &4`;; - -time REAL_SOS - `x >= &1 /\ y >= &1 ==> x * y >= x + y - &1`;; - -time REAL_SOS - `x > &1 /\ y > &1 ==> x * y > x + y - &1`;; - -time REAL_SOS - `abs(x) <= &1 - ==> abs(&64 * x pow 7 - &112 * x pow 5 + &56 * x pow 3 - &7 * x) <= &1`;; - -time REAL_SOS - `abs(x - z) <= e /\ abs(y - z) <= e /\ &0 <= u /\ &0 <= v /\ (u + v = &1) - ==> abs((u * x + v * y) - z) <= e`;; - -(* ------------------------------------------------------------------------- *) -(* One component of denominator in dodecahedral example. *) -(* ------------------------------------------------------------------------- *) - -time REAL_SOS - `&2 <= x /\ x <= &125841 / &50000 /\ - &2 <= y /\ y <= &125841 / &50000 /\ - &2 <= z /\ z <= &125841 / &50000 - ==> &2 * (x * z + x * y + y * z) - (x * x + y * y + z * z) >= &0`;; - -(* ------------------------------------------------------------------------- *) -(* Over a larger but simpler interval. *) -(* ------------------------------------------------------------------------- *) - -time REAL_SOS - `&2 <= x /\ x <= &4 /\ &2 <= y /\ y <= &4 /\ &2 <= z /\ z <= &4 - ==> &0 <= &2 * (x * z + x * y + y * z) - (x * x + y * y + z * z)`;; - -(* ------------------------------------------------------------------------- *) -(* We can do 12. I think 12 is a sharp bound; see PP's certificate. *) -(* ------------------------------------------------------------------------- *) - -time REAL_SOS - `&2 <= x /\ x <= &4 /\ &2 <= y /\ y <= &4 /\ &2 <= z /\ z <= &4 - ==> &12 <= &2 * (x * z + x * y + y * z) - (x * x + y * y + z * z)`;; - -(* ------------------------------------------------------------------------- *) -(* Gloptipoly example. *) -(* ------------------------------------------------------------------------- *) - -(*** This works but normalization takes minutes - -time REAL_SOS - `(x - y - &2 * x pow 4 = &0) /\ &0 <= x /\ x <= &2 /\ &0 <= y /\ y <= &3 - ==> y pow 2 - &7 * y - &12 * x + &17 >= &0`;; - - ***) - -(* ------------------------------------------------------------------------- *) -(* Inequality from sci.math (see "Leon-Sotelo, por favor"). *) -(* ------------------------------------------------------------------------- *) - -time REAL_SOS - `&0 <= x /\ &0 <= y /\ (x * y = &1) - ==> x + y <= x pow 2 + y pow 2`;; - -time REAL_SOS - `&0 <= x /\ &0 <= y /\ (x * y = &1) - ==> x * y * (x + y) <= x pow 2 + y pow 2`;; - -time REAL_SOS - `&0 <= x /\ &0 <= y ==> x * y * (x + y) pow 2 <= (x pow 2 + y pow 2) pow 2`;; - -(* ------------------------------------------------------------------------- *) -(* Some examples over integers and natural numbers. *) -(* ------------------------------------------------------------------------- *) - -time SOS_RULE `!m n. 2 * m + n = (n + m) + m`;; -time SOS_RULE `!n. ~(n = 0) ==> (0 MOD n = 0)`;; -time SOS_RULE `!m n. m < n ==> (m DIV n = 0)`;; -time SOS_RULE `!n:num. n <= n * n`;; -time SOS_RULE `!m n. n * (m DIV n) <= m`;; -time SOS_RULE `!n. ~(n = 0) ==> (0 DIV n = 0)`;; -time SOS_RULE `!m n p. ~(p = 0) /\ m <= n ==> m DIV p <= n DIV p`;; -time SOS_RULE `!a b n. ~(a = 0) ==> (n <= b DIV a <=> a * n <= b)`;; - -(* ------------------------------------------------------------------------- *) -(* This is particularly gratifying --- cf hideous manual proof in arith.ml *) -(* ------------------------------------------------------------------------- *) - -(*** This doesn't now seem to work as well as it did; what changed? - -time SOS_RULE - `!a b c d. ~(b = 0) /\ b * c < (a + 1) * d ==> c DIV d <= a DIV b`;; - - ***) - -(* ------------------------------------------------------------------------- *) -(* Key lemma for injectivity of Cantor-type pairing functions. *) -(* ------------------------------------------------------------------------- *) - -time SOS_RULE - `!x1 y1 x2 y2. ((x1 + y1) EXP 2 + x1 + 1 = (x2 + y2) EXP 2 + x2 + 1) - ==> (x1 + y1 = x2 + y2)`;; - -time SOS_RULE - `!x1 y1 x2 y2. ((x1 + y1) EXP 2 + x1 + 1 = (x2 + y2) EXP 2 + x2 + 1) /\ - (x1 + y1 = x2 + y2) - ==> (x1 = x2) /\ (y1 = y2)`;; - -time SOS_RULE - `!x1 y1 x2 y2. - (((x1 + y1) EXP 2 + 3 * x1 + y1) DIV 2 = - ((x2 + y2) EXP 2 + 3 * x2 + y2) DIV 2) - ==> (x1 + y1 = x2 + y2)`;; - -time SOS_RULE - `!x1 y1 x2 y2. - (((x1 + y1) EXP 2 + 3 * x1 + y1) DIV 2 = - ((x2 + y2) EXP 2 + 3 * x2 + y2) DIV 2) /\ - (x1 + y1 = x2 + y2) - ==> (x1 = x2) /\ (y1 = y2)`;; - -(* ------------------------------------------------------------------------- *) -(* Reciprocal multiplication (actually just ARITH_RULE does these). *) -(* ------------------------------------------------------------------------- *) - -time SOS_RULE `x <= 127 ==> ((86 * x) DIV 256 = x DIV 3)`;; - -time SOS_RULE `x < 2 EXP 16 ==> ((104858 * x) DIV (2 EXP 20) = x DIV 10)`;; - -(* ------------------------------------------------------------------------- *) -(* This is more impressive since it's really nonlinear. See REMAINDER_DECODE *) -(* ------------------------------------------------------------------------- *) - -time SOS_RULE `0 < m /\ m < n ==> ((m * ((n * x) DIV m + 1)) DIV n = x)`;; - -(* ------------------------------------------------------------------------- *) -(* Some conversion examples. *) -(* ------------------------------------------------------------------------- *) - -time SOS_CONV - `&2 * x pow 4 + &2 * x pow 3 * y - x pow 2 * y pow 2 + &5 * y pow 4`;; - -time SOS_CONV - `x pow 4 - (&2 * y * z + &1) * x pow 2 + - (y pow 2 * z pow 2 + &2 * y * z + &2)`;; - -time SOS_CONV `&4 * x pow 4 + - &4 * x pow 3 * y - &7 * x pow 2 * y pow 2 - &2 * x * y pow 3 + - &10 * y pow 4`;; - -time SOS_CONV `&4 * x pow 4 * y pow 6 + x pow 2 - x * y pow 2 + y pow 2`;; - -time SOS_CONV - `&4096 * (x pow 4 + x pow 2 + z pow 6 - &3 * x pow 2 * z pow 2) + &729`;; - -time SOS_CONV - `&120 * x pow 2 - &63 * x pow 4 + &10 * x pow 6 + - &30 * x * y - &120 * y pow 2 + &120 * y pow 4 + &31`;; - -time SOS_CONV - `&9 * x pow 2 * y pow 4 + &9 * x pow 2 * z pow 4 + &36 * x pow 2 * y pow 3 + - &36 * x pow 2 * y pow 2 - &48 * x * y * z pow 2 + &4 * y pow 4 + - &4 * z pow 4 - &16 * y pow 3 + &16 * y pow 2`;; - -time SOS_CONV - `(x pow 2 + y pow 2 + z pow 2) * - (x pow 4 * y pow 2 + x pow 2 * y pow 4 + - z pow 6 - &3 * x pow 2 * y pow 2 * z pow 2)`;; - -time SOS_CONV - `x pow 4 + y pow 4 + z pow 4 - &4 * x * y * z + x + y + z + &3`;; - -(*** I think this will work, but normalization is slow - -time SOS_CONV - `&100 * (x pow 4 + y pow 4 + z pow 4 - &4 * x * y * z + x + y + z) + &212`;; - - ***) - -time SOS_CONV - `&100 * ((&2 * x - &2) pow 2 + (x pow 3 - &8 * x - &2) pow 2) - &588`;; - -time SOS_CONV - `x pow 2 * (&120 - &63 * x pow 2 + &10 * x pow 4) + &30 * x * y + - &30 * y pow 2 * (&4 * y pow 2 - &4) + &31`;; - -(* ------------------------------------------------------------------------- *) -(* Example of basic rule. *) -(* ------------------------------------------------------------------------- *) - -time PURE_SOS - `!x. x pow 4 + y pow 4 + z pow 4 - &4 * x * y * z + x + y + z + &3 - >= &1 / &7`;; - -time PURE_SOS - `&0 <= &98 * x pow 12 + - -- &980 * x pow 10 + - &3038 * x pow 8 + - -- &2968 * x pow 6 + - &1022 * x pow 4 + - -- &84 * x pow 2 + - &2`;; - -time PURE_SOS - `!x. &0 <= &2 * x pow 14 + - -- &84 * x pow 12 + - &1022 * x pow 10 + - -- &2968 * x pow 8 + - &3038 * x pow 6 + - -- &980 * x pow 4 + - &98 * x pow 2`;; - -(* ------------------------------------------------------------------------- *) -(* From Zeng et al, JSC vol 37 (2004), p83-99. *) -(* All of them work nicely with pure SOS_CONV, except (maybe) the one noted. *) -(* ------------------------------------------------------------------------- *) - -PURE_SOS - `x pow 6 + y pow 6 + z pow 6 - &3 * x pow 2 * y pow 2 * z pow 2 >= &0`;; - -PURE_SOS `x pow 4 + y pow 4 + z pow 4 + &1 - &4*x*y*z >= &0`;; - -PURE_SOS `x pow 4 + &2*x pow 2*z + x pow 2 - &2*x*y*z + &2*y pow 2*z pow 2 + -&2*y*z pow 2 + &2*z pow 2 - &2*x + &2* y*z + &1 >= &0`;; - -(**** This is harder. Interestingly, this fails the pure SOS test, it seems. - Yet only on rounding(!?) Poor Newton polytope optimization or something? - But REAL_SOS does finally converge on the second run at level 12! - -REAL_SOS -`x pow 4*y pow 4 - &2*x pow 5*y pow 3*z pow 2 + x pow 6*y pow 2*z pow 4 + &2*x -pow 2*y pow 3*z - &4* x pow 3*y pow 2*z pow 3 + &2*x pow 4*y*z pow 5 + z pow -2*y pow 2 - &2*z pow 4*y*x + z pow 6*x pow 2 >= &0`;; - - ****) - -PURE_SOS -`x pow 4 + &4*x pow 2*y pow 2 + &2*x*y*z pow 2 + &2*x*y*w pow 2 + y pow 4 + z -pow 4 + w pow 4 + &2*z pow 2*w pow 2 + &2*x pow 2*w + &2*y pow 2*w + &2*x*y + -&3*w pow 2 + &2*z pow 2 + &1 >= &0`;; - -PURE_SOS -`w pow 6 + &2*z pow 2*w pow 3 + x pow 4 + y pow 4 + z pow 4 + &2*x pow 2*w + -&2*x pow 2*z + &3*x pow 2 + w pow 2 + &2*z*w + z pow 2 + &2*z + &2*w + &1 >= -&0`;; - -*****) diff --git a/plugins/micromega/sos_lib.ml b/plugins/micromega/sos_lib.ml index 6b8b820ac..6aebc4ca9 100644 --- a/plugins/micromega/sos_lib.ml +++ b/plugins/micromega/sos_lib.ml @@ -9,8 +9,6 @@ open Num -let debugging = ref false;; - (* ------------------------------------------------------------------------- *) (* Comparisons that are reflexive on NaN and also short-circuiting. *) (* ------------------------------------------------------------------------- *) @@ -21,7 +19,6 @@ let (=?) = fun x y -> cmp x y = 0;; let (<?) = fun x y -> cmp x y < 0;; let (<=?) = fun x y -> cmp x y <= 0;; let (>?) = fun x y -> cmp x y > 0;; -let (>=?) = fun x y -> cmp x y >= 0;; (* ------------------------------------------------------------------------- *) (* Combinators. *) @@ -59,48 +56,29 @@ let lcm_num x y = (* ------------------------------------------------------------------------- *) -(* List basics. *) -(* ------------------------------------------------------------------------- *) - -let rec el n l = - if n = 0 then List.hd l else el (n - 1) (List.tl l);; - - -(* ------------------------------------------------------------------------- *) (* Various versions of list iteration. *) (* ------------------------------------------------------------------------- *) -let rec itlist f l b = - match l with - [] -> b - | (h::t) -> f h (itlist f t b);; - let rec end_itlist f l = match l with [] -> failwith "end_itlist" | [x] -> x | (h::t) -> f h (end_itlist f t);; -let rec itlist2 f l1 l2 b = - match (l1,l2) with - ([],[]) -> b - | (h1::t1,h2::t2) -> f h1 h2 (itlist2 f t1 t2 b) - | _ -> failwith "itlist2";; - (* ------------------------------------------------------------------------- *) (* All pairs arising from applying a function over two lists. *) (* ------------------------------------------------------------------------- *) let rec allpairs f l1 l2 = match l1 with - h1::t1 -> itlist (fun x a -> f h1 x :: a) l2 (allpairs f t1 l2) + h1::t1 -> List.fold_right (fun x a -> f h1 x :: a) l2 (allpairs f t1 l2) | [] -> [];; (* ------------------------------------------------------------------------- *) (* String operations (surely there is a better way...) *) (* ------------------------------------------------------------------------- *) -let implode l = itlist (^) l "";; +let implode l = List.fold_right (^) l "";; let explode s = let rec exap n l = @@ -110,13 +88,6 @@ let explode s = (* ------------------------------------------------------------------------- *) -(* Attempting function or predicate applications. *) -(* ------------------------------------------------------------------------- *) - -let can f x = try (f x; true) with Failure _ -> false;; - - -(* ------------------------------------------------------------------------- *) (* Repetition of a function. *) (* ------------------------------------------------------------------------- *) @@ -126,36 +97,20 @@ let rec funpow n f x = (* ------------------------------------------------------------------------- *) -(* Replication and sequences. *) +(* Sequences. *) (* ------------------------------------------------------------------------- *) -let rec replicate x n = - if n < 1 then [] - else x::(replicate x (n - 1));; - let rec (--) = fun m n -> if m > n then [] else m::((m + 1) -- n);; (* ------------------------------------------------------------------------- *) (* Various useful list operations. *) (* ------------------------------------------------------------------------- *) -let rec forall p l = - match l with - [] -> true - | h::t -> p(h) && forall p t;; - let rec tryfind f l = match l with [] -> failwith "tryfind" | (h::t) -> try f h with Failure _ -> tryfind f t;; -let index x = - let rec ind n l = - match l with - [] -> failwith "index" - | (h::t) -> if x =? h then n else ind (n + 1) t in - ind 0;; - (* ------------------------------------------------------------------------- *) (* "Set" operations on lists. *) (* ------------------------------------------------------------------------- *) @@ -168,46 +123,16 @@ let rec mem x lis = let insert x l = if mem x l then l else x::l;; -let union l1 l2 = itlist insert l1 l2;; +let union l1 l2 = List.fold_right insert l1 l2;; let subtract l1 l2 = List.filter (fun x -> not (mem x l2)) l1;; (* ------------------------------------------------------------------------- *) -(* Merging and bottom-up mergesort. *) -(* ------------------------------------------------------------------------- *) - -let rec merge ord l1 l2 = - match l1 with - [] -> l2 - | h1::t1 -> match l2 with - [] -> l1 - | h2::t2 -> if ord h1 h2 then h1::(merge ord t1 l2) - else h2::(merge ord l1 t2);; - - -(* ------------------------------------------------------------------------- *) (* Common measure predicates to use with "sort". *) (* ------------------------------------------------------------------------- *) let increasing f x y = f x <? f y;; -let decreasing f x y = f x >? f y;; - -(* ------------------------------------------------------------------------- *) -(* Zipping, unzipping etc. *) -(* ------------------------------------------------------------------------- *) - -let rec zip l1 l2 = - match (l1,l2) with - ([],[]) -> [] - | (h1::t1,h2::t2) -> (h1,h2)::(zip t1 t2) - | _ -> failwith "zip";; - -let rec unzip = - function [] -> [],[] - | ((a,b)::rest) -> let alist,blist = unzip rest in - (a::alist,b::blist);; - (* ------------------------------------------------------------------------- *) (* Iterating functions over lists. *) (* ------------------------------------------------------------------------- *) @@ -443,8 +368,6 @@ let apply f = applyd f (fun x -> failwith "apply");; let tryapplyd f a d = applyd f (fun x -> d) a;; -let defined f x = try apply f x; true with Failure _ -> false;; - (* ------------------------------------------------------------------------- *) (* Undefinition. *) (* ------------------------------------------------------------------------- *) @@ -490,8 +413,6 @@ let graph f = setify (foldl (fun a x y -> (x,y)::a) [] f);; let dom f = setify(foldl (fun a x y -> x::a) [] f);; -let ran f = setify(foldl (fun a x y -> y::a) [] f);; - (* ------------------------------------------------------------------------- *) (* More parser basics. *) (* ------------------------------------------------------------------------- *) @@ -499,7 +420,7 @@ let ran f = setify(foldl (fun a x y -> y::a) [] f);; exception Noparse;; -let isspace,issep,isbra,issymb,isalpha,isnum,isalnum = +let isspace,isnum = let charcode s = Char.code(String.get s 0) in let spaces = " \t\n\r" and separators = ",;" @@ -508,7 +429,7 @@ let isspace,issep,isbra,issymb,isalpha,isnum,isalnum = and alphas = "'abcdefghijklmnopqrstuvwxyz_ABCDEFGHIJKLMNOPQRSTUVWXYZ" and nums = "0123456789" in let allchars = spaces^separators^brackets^symbs^alphas^nums in - let csetsize = itlist ((o) max charcode) (explode allchars) 256 in + let csetsize = List.fold_right ((o) max charcode) (explode allchars) 256 in let ctable = Array.make csetsize 0 in do_list (fun c -> Array.set ctable (charcode c) 1) (explode spaces); do_list (fun c -> Array.set ctable (charcode c) 2) (explode separators); @@ -517,13 +438,8 @@ let isspace,issep,isbra,issymb,isalpha,isnum,isalnum = do_list (fun c -> Array.set ctable (charcode c) 16) (explode alphas); do_list (fun c -> Array.set ctable (charcode c) 32) (explode nums); let isspace c = Array.get ctable (charcode c) = 1 - and issep c = Array.get ctable (charcode c) = 2 - and isbra c = Array.get ctable (charcode c) = 4 - and issymb c = Array.get ctable (charcode c) = 8 - and isalpha c = Array.get ctable (charcode c) = 16 - and isnum c = Array.get ctable (charcode c) = 32 - and isalnum c = Array.get ctable (charcode c) >= 16 in - isspace,issep,isbra,issymb,isalpha,isnum,isalnum;; + and isnum c = Array.get ctable (charcode c) = 32 in + isspace,isnum;; let parser_or parser1 parser2 input = try parser1 input @@ -566,9 +482,6 @@ let rec atleast n prs i = (if n <= 0 then many prs else prs ++ atleast (n - 1) prs >> (fun (h,t) -> h::t)) i;; -let finished input = - if input = [] then 0,input else failwith "Unparsed input";; - (* ------------------------------------------------------------------------- *) let temp_path = Filename.get_temp_dir_name ();; @@ -589,7 +502,7 @@ let strings_of_file filename = (Pervasives.close_in fd; data);; let string_of_file filename = - end_itlist (fun s t -> s^"\n"^t) (strings_of_file filename);; + String.concat "\n" (strings_of_file filename);; let file_of_string filename s = let fd = Pervasives.open_out filename in diff --git a/plugins/micromega/sos_lib.mli b/plugins/micromega/sos_lib.mli new file mode 100644 index 000000000..8b53b8151 --- /dev/null +++ b/plugins/micromega/sos_lib.mli @@ -0,0 +1,79 @@ +(************************************************************************) +(* * 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) *) +(************************************************************************) + +val o : ('a -> 'b) -> ('c -> 'a) -> 'c -> 'b + +val num_1 : Num.num +val pow10 : int -> Num.num +val pow2 : int -> Num.num + +val implode : string list -> string +val explode : string -> string list + +val funpow : int -> ('a -> 'a) -> 'a -> 'a +val tryfind : ('a -> 'b) -> 'a list -> 'b + +type ('a,'b) func = + | Empty + | Leaf of int * ('a*'b) list + | Branch of int * int * ('a,'b) func * ('a,'b) func + +val undefined : ('a, 'b) func +val is_undefined : ('a, 'b) func -> bool +val (|->) : 'a -> 'b -> ('a, 'b) func -> ('a, 'b) func +val (|=>) : 'a -> 'b -> ('a, 'b) func +val choose : ('a, 'b) func -> 'a * 'b +val combine : ('a -> 'a -> 'a) -> ('a -> bool) -> ('b, 'a) func -> ('b, 'a) func -> ('b, 'a) func +val (--) : int -> int -> int list + +val tryapplyd : ('a, 'b) func -> 'a -> 'b -> 'b +val apply : ('a, 'b) func -> 'a -> 'b + +val foldl : ('a -> 'b -> 'c -> 'a) -> 'a -> ('b, 'c) func -> 'a +val foldr : ('a -> 'b -> 'c -> 'c) -> ('a, 'b) func -> 'c -> 'c +val mapf : ('a -> 'b) -> ('c, 'a) func -> ('c, 'b) func + +val undefine : 'a -> ('a, 'b) func -> ('a, 'b) func + +val dom : ('a, 'b) func -> 'a list +val graph : ('a, 'b) func -> ('a * 'b) list + +val union : 'a list -> 'a list -> 'a list +val subtract : 'a list -> 'a list -> 'a list +val sort : ('a -> 'a -> bool) -> 'a list -> 'a list +val setify : 'a list -> 'a list +val increasing : ('a -> 'b) -> 'a -> 'a -> bool +val allpairs : ('a -> 'b -> 'c) -> 'a list -> 'b list -> 'c list + +val gcd_num : Num.num -> Num.num -> Num.num +val lcm_num : Num.num -> Num.num -> Num.num +val numerator : Num.num -> Num.num +val denominator : Num.num -> Num.num +val end_itlist : ('a -> 'a -> 'a) -> 'a list -> 'a + +val (>>) : ('a -> 'b * 'c) -> ('b -> 'd) -> 'a -> 'd * 'c +val (++) : ('a -> 'b * 'c) -> ('c -> 'd * 'e) -> 'a -> ('b * 'd) * 'e + +val a : 'a -> 'a list -> 'a * 'a list +val many : ('a -> 'b * 'a) -> 'a -> 'b list * 'a +val some : ('a -> bool) -> 'a list -> 'a * 'a list +val possibly : ('a -> 'b * 'a) -> 'a -> 'b list * 'a +val isspace : string -> bool +val parser_or : ('a -> 'b) -> ('a -> 'b) -> 'a -> 'b +val isnum : string -> bool +val atleast : int -> ('a -> 'b * 'a) -> 'a -> 'b list * 'a +val listof : ('a -> 'b * 'c) -> ('c -> 'd * 'a) -> string -> 'a -> 'b list * 'c + +val temp_path : string +val string_of_file : string -> string +val file_of_string : string -> string -> unit + +val deepen_until : int -> (int -> 'a) -> int -> 'a +exception TooDeep diff --git a/plugins/nsatz/nsatz.ml b/plugins/nsatz/nsatz.ml index 81b44ffad..d2d4639d2 100644 --- a/plugins/nsatz/nsatz.ml +++ b/plugins/nsatz/nsatz.ml @@ -136,7 +136,7 @@ let mul = function | (Const n,q) when eq_num n num_1 -> q | (p,q) -> Mul(p,q) -let gen_constant msg path s = Universes.constr_of_global @@ +let gen_constant msg path s = UnivGen.constr_of_global @@ coq_reference msg path s let tpexpr = lazy (gen_constant "CC" ["setoid_ring";"Ring_polynom"] "PExpr") diff --git a/plugins/omega/coq_omega.ml b/plugins/omega/coq_omega.ml index 51cd665f6..6f4138828 100644 --- a/plugins/omega/coq_omega.ml +++ b/plugins/omega/coq_omega.ml @@ -18,8 +18,8 @@ open CErrors open Util open Names +open Constr open Nameops -open Term open EConstr open Tacticals.New open Tacmach.New @@ -29,7 +29,7 @@ open Libnames open Globnames open Nametab open Contradiction -open Misctypes +open Tactypes open Context.Named.Declaration module NamedDecl = Context.Named.Declaration @@ -206,7 +206,7 @@ let coq_modules = init_modules @arith_modules @ [logic_dir] @ zarith_base_modules @ [["Coq"; "omega"; "OmegaLemmas"]] -let gen_constant_in_modules n m s = EConstr.of_constr (Universes.constr_of_global @@ gen_reference_in_modules n m s) +let gen_constant_in_modules n m s = EConstr.of_constr (UnivGen.constr_of_global @@ gen_reference_in_modules n m s) let init_constant = gen_constant_in_modules "Omega" init_modules let constant = gen_constant_in_modules "Omega" coq_modules @@ -369,8 +369,11 @@ let coq_True = lazy (init_constant "True") (* uses build_coq_and, build_coq_not, build_coq_or, build_coq_ex *) (* For unfold *) -let evaluable_ref_of_constr s c = match EConstr.kind Evd.empty (Lazy.force c) with - | Const (kn,u) when Tacred.is_evaluable (Global.env()) (EvalConstRef kn) -> +let evaluable_ref_of_constr s c = + let env = Global.env () in + let evd = Evd.from_env env in + match EConstr.kind evd (Lazy.force c) with + | Const (kn,u) when Tacred.is_evaluable env (EvalConstRef kn) -> EvalConstRef kn | _ -> anomaly ~label:"Coq_omega" (Pp.str (s^" is not an evaluable constant.")) diff --git a/plugins/quote/g_quote.ml4 b/plugins/quote/g_quote.ml4 index c35e0fe12..09209dc22 100644 --- a/plugins/quote/g_quote.ml4 +++ b/plugins/quote/g_quote.ml4 @@ -10,7 +10,6 @@ open Ltac_plugin open Names -open Misctypes open Tacexpr open Geninterp open Quote @@ -24,7 +23,7 @@ let x = Id.of_string "x" let make_cont (k : Val.t) (c : EConstr.t) = let c = Tacinterp.Value.of_constr c in - let tac = TacCall (Loc.tag (ArgVar CAst.(make cont), [Reference (ArgVar CAst.(make x))])) in + let tac = TacCall (Loc.tag (Locus.ArgVar CAst.(make cont), [Reference (Locus.ArgVar CAst.(make x))])) in let ist = { lfun = Id.Map.add cont k (Id.Map.singleton x c); extra = TacStore.empty; } in Tacinterp.eval_tactic_ist ist (TacArg (Loc.tag tac)) diff --git a/plugins/quote/quote.ml b/plugins/quote/quote.ml index 912429c31..7464b42dc 100644 --- a/plugins/quote/quote.ml +++ b/plugins/quote/quote.ml @@ -120,7 +120,7 @@ open Proofview.Notations the constants are loaded in the environment *) let constant dir s = - EConstr.of_constr @@ Universes.constr_of_global @@ + EConstr.of_constr @@ UnivGen.constr_of_global @@ Coqlib.coq_reference "Quote" ("quote"::dir) s let coq_Empty_vm = lazy (constant ["Quote"] "Empty_vm") diff --git a/plugins/romega/const_omega.ml b/plugins/romega/const_omega.ml index ad3afafd8..949cba2db 100644 --- a/plugins/romega/const_omega.ml +++ b/plugins/romega/const_omega.ml @@ -69,19 +69,19 @@ let z_module = [["Coq";"ZArith";"BinInt"]] let init_constant x = EConstr.of_constr @@ - Universes.constr_of_global @@ + UnivGen.constr_of_global @@ Coqlib.gen_reference_in_modules "Omega" Coqlib.init_modules x let constant x = EConstr.of_constr @@ - Universes.constr_of_global @@ + UnivGen.constr_of_global @@ Coqlib.gen_reference_in_modules "Omega" coq_modules x let z_constant x = EConstr.of_constr @@ - Universes.constr_of_global @@ + UnivGen.constr_of_global @@ Coqlib.gen_reference_in_modules "Omega" z_module x let bin_constant x = EConstr.of_constr @@ - Universes.constr_of_global @@ + UnivGen.constr_of_global @@ Coqlib.gen_reference_in_modules "Omega" bin_module x (* Logic *) @@ -170,7 +170,7 @@ let mk_list univ typ l = loop l let mk_plist = - let type1lev = Universes.new_univ_level () in + let type1lev = UnivGen.new_univ_level () in fun l -> mk_list type1lev EConstr.mkProp l let mk_list = mk_list Univ.Level.set diff --git a/plugins/romega/refl_omega.ml b/plugins/romega/refl_omega.ml index d18249784..e60348065 100644 --- a/plugins/romega/refl_omega.ml +++ b/plugins/romega/refl_omega.ml @@ -8,6 +8,7 @@ open Pp open Util +open Constr open Const_omega module OmegaSolver = Omega_plugin.Omega.MakeOmegaSolver (Bigint) open OmegaSolver @@ -1036,13 +1037,13 @@ let resolution unsafe sigma env (reified_concl,reified_hyps) systems_list = let decompose_tactic = decompose_tree env context solution_tree in Tactics.generalize (l_generalize_arg @ l_reified_hypnames) >> - Tactics.convert_concl_no_check reified Term.DEFAULTcast >> + Tactics.convert_concl_no_check reified DEFAULTcast >> Tactics.apply (app coq_do_omega [|decompose_tactic|]) >> show_goal >> (if unsafe then (* Trust the produced term. Faster, but might fail later at Qed. Also handy when debugging, e.g. via a Show Proof after romega. *) - Tactics.convert_concl_no_check (Lazy.force coq_True) Term.VMcast + Tactics.convert_concl_no_check (Lazy.force coq_True) VMcast else Tactics.normalise_vm_in_concl) >> Tactics.apply (Lazy.force coq_I) diff --git a/plugins/rtauto/refl_tauto.ml b/plugins/rtauto/refl_tauto.ml index 946b6dff4..8a0f48dc4 100644 --- a/plugins/rtauto/refl_tauto.ml +++ b/plugins/rtauto/refl_tauto.ml @@ -26,27 +26,27 @@ let step_count = ref 0 let node_count = ref 0 -let logic_constant s = Universes.constr_of_global @@ +let logic_constant s = UnivGen.constr_of_global @@ Coqlib.coq_reference "refl_tauto" ["Init";"Logic"] s let li_False = lazy (destInd (logic_constant "False")) let li_and = lazy (destInd (logic_constant "and")) let li_or = lazy (destInd (logic_constant "or")) -let pos_constant s = Universes.constr_of_global @@ +let pos_constant s = UnivGen.constr_of_global @@ Coqlib.coq_reference "refl_tauto" ["Numbers";"BinNums"] s let l_xI = lazy (pos_constant "xI") let l_xO = lazy (pos_constant "xO") let l_xH = lazy (pos_constant "xH") -let store_constant s = Universes.constr_of_global @@ +let store_constant s = UnivGen.constr_of_global @@ Coqlib.coq_reference "refl_tauto" ["rtauto";"Bintree"] s let l_empty = lazy (store_constant "empty") let l_push = lazy (store_constant "push") -let constant s = Universes.constr_of_global @@ +let constant s = UnivGen.constr_of_global @@ Coqlib.coq_reference "refl_tauto" ["rtauto";"Rtauto"] s let l_Reflect = lazy (constant "Reflect") diff --git a/plugins/setoid_ring/Algebra_syntax.v b/plugins/setoid_ring/Algebra_syntax.v index e896554ea..1204bbd2e 100644 --- a/plugins/setoid_ring/Algebra_syntax.v +++ b/plugins/setoid_ring/Algebra_syntax.v @@ -1,3 +1,12 @@ +(************************************************************************) +(* * 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) *) +(************************************************************************) Class Zero (A : Type) := zero : A. Notation "0" := zero. diff --git a/plugins/setoid_ring/Integral_domain.v b/plugins/setoid_ring/Integral_domain.v index 0c16fe1a3..98407cb6d 100644 --- a/plugins/setoid_ring/Integral_domain.v +++ b/plugins/setoid_ring/Integral_domain.v @@ -1,3 +1,13 @@ +(************************************************************************) +(* * 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) *) +(************************************************************************) + Require Export Cring. diff --git a/plugins/setoid_ring/RealField.v b/plugins/setoid_ring/RealField.v index facd2e062..38bc58a65 100644 --- a/plugins/setoid_ring/RealField.v +++ b/plugins/setoid_ring/RealField.v @@ -1,3 +1,13 @@ +(************************************************************************) +(* * 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) *) +(************************************************************************) + Require Import Nnat. Require Import ArithRing. Require Export Ring Field. diff --git a/plugins/setoid_ring/Ring_tac.v b/plugins/setoid_ring/Ring_tac.v index 36d1e7c54..e8efb362e 100644 --- a/plugins/setoid_ring/Ring_tac.v +++ b/plugins/setoid_ring/Ring_tac.v @@ -1,3 +1,13 @@ +(************************************************************************) +(* * 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) *) +(************************************************************************) + Set Implicit Arguments. Require Import Setoid. Require Import BinPos. diff --git a/plugins/setoid_ring/Rings_Q.v b/plugins/setoid_ring/Rings_Q.v index fd7654713..ae91ee166 100644 --- a/plugins/setoid_ring/Rings_Q.v +++ b/plugins/setoid_ring/Rings_Q.v @@ -1,3 +1,13 @@ +(************************************************************************) +(* * 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) *) +(************************************************************************) + Require Export Cring. Require Export Integral_domain. diff --git a/plugins/setoid_ring/Rings_R.v b/plugins/setoid_ring/Rings_R.v index fd219c235..901b36ed3 100644 --- a/plugins/setoid_ring/Rings_R.v +++ b/plugins/setoid_ring/Rings_R.v @@ -1,3 +1,13 @@ +(************************************************************************) +(* * 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) *) +(************************************************************************) + Require Export Cring. Require Export Integral_domain. diff --git a/plugins/setoid_ring/Rings_Z.v b/plugins/setoid_ring/Rings_Z.v index 605a23a98..75e77ab6e 100644 --- a/plugins/setoid_ring/Rings_Z.v +++ b/plugins/setoid_ring/Rings_Z.v @@ -1,3 +1,13 @@ +(************************************************************************) +(* * 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) *) +(************************************************************************) + Require Export Cring. Require Export Integral_domain. Require Export Ncring_initial. diff --git a/plugins/setoid_ring/newring.ml b/plugins/setoid_ring/newring.ml index 99bb8440c..84b29a0bf 100644 --- a/plugins/setoid_ring/newring.ml +++ b/plugins/setoid_ring/newring.ml @@ -20,6 +20,7 @@ open Environ open Libnames open Globnames open Glob_term +open Locus open Tacexpr open Coqlib open Mod_subst @@ -29,7 +30,6 @@ open Printer open Declare open Decl_kinds open Entries -open Misctypes open Newring_ast open Proofview.Notations @@ -40,11 +40,7 @@ let error msg = CErrors.user_err Pp.(str msg) type protect_flag = Eval|Prot|Rec -let tag_arg tag_rec map subs i c = - match map i with - Eval -> mk_clos subs c - | Prot -> mk_atom c - | Rec -> if Int.equal i (-1) then mk_clos subs c else tag_rec c +type protection = Evd.evar_map -> EConstr.t -> GlobRef.t -> (Int.t -> protect_flag) option let global_head_of_constr sigma c = let f, args = decompose_app sigma c in @@ -55,32 +51,24 @@ let global_of_constr_nofail c = try global_of_constr c with Not_found -> VarRef (Id.of_string "dummy") -let rec mk_clos_but f_map subs t = - let open Term in - match f_map (global_of_constr_nofail t) with - | Some map -> tag_arg (mk_clos_but f_map subs) map subs (-1) t - | None -> - (match Constr.kind t with - App(f,args) -> mk_clos_app_but f_map subs f args 0 - | Prod _ -> mk_clos_deep (mk_clos_but f_map) subs t - | _ -> mk_atom t) +let rec mk_clos_but f_map n t = + let (f, args) = Constr.decompose_appvect t in + match f_map (global_of_constr_nofail f) with + | Some tag -> + let map i t = tag_arg f_map n (tag i) t in + if Array.is_empty args then map (-1) f + else mk_red (FApp (map (-1) f, Array.mapi map args)) + | None -> mk_atom t -and mk_clos_app_but f_map subs f args n = - let open Constr in - if n >= Array.length args then mk_atom(mkApp(f, args)) - else - let fargs, args' = Array.chop n args in - let f' = mkApp(f,fargs) in - match f_map (global_of_constr_nofail f') with - | Some map -> - let f i t = tag_arg (mk_clos_but f_map subs) map subs i t in - mk_red (FApp (f (-1) f', Array.mapi f args')) - | None -> mk_atom (mkApp (f, args)) +and tag_arg f_map n tag c = match tag with +| Eval -> mk_clos (Esubst.subs_id n) c +| Prot -> mk_atom c +| Rec -> mk_clos_but f_map n c let interp_map l t = - try Some(List.assoc_f eq_gr t l) with Not_found -> None + try Some(List.assoc_f GlobRef.equal t l) with Not_found -> None -let protect_maps = ref String.Map.empty +let protect_maps : protection String.Map.t ref = ref String.Map.empty let add_map s m = protect_maps := String.Map.add s m !protect_maps let lookup_map map = try String.Map.find map !protect_maps @@ -90,8 +78,14 @@ let lookup_map map = let protect_red map env sigma c0 = let evars ev = Evarutil.safe_evar_value sigma ev in let c = EConstr.Unsafe.to_constr c0 in - EConstr.of_constr (kl (create_clos_infos ~evars all env) (create_tab ()) - (mk_clos_but (lookup_map map sigma c0) (Esubst.subs_id 0) c));; + let tab = create_tab () in + let infos = create_clos_infos ~evars all env in + let map = lookup_map map sigma c0 in + let rec eval n c = match Constr.kind c with + | Prod (na, t, u) -> Constr.mkProd (na, eval n t, eval (n + 1) u) + | _ -> kl infos tab (mk_clos_but map n c) + in + EConstr.of_constr (eval 0 c) let protect_tac map = Tactics.reduct_option (protect_red map,DEFAULTcast) None @@ -105,7 +99,7 @@ let protect_tac_in map id = let closed_term t l = let open Quote_plugin in Proofview.tclEVARMAP >>= fun sigma -> - let l = List.map Universes.constr_of_global l in + let l = List.map UnivGen.constr_of_global l in let cs = List.fold_right Quote.ConstrSet.add l Quote.ConstrSet.empty in if Quote.closed_under sigma cs t then Proofview.tclUNIT () else Tacticals.New.tclFAIL 0 (mt()) @@ -186,8 +180,8 @@ let dummy_goal env sigma = Goal.V82.mk_goal sigma (named_context_val env) EConstr.mkProp Evd.Store.empty in {Evd.it = gl; Evd.sigma = sigma} -let constr_of v = match Value.to_constr v with - | Some c -> EConstr.Unsafe.to_constr c +let constr_of evd v = match Value.to_constr v with + | Some c -> EConstr.to_constr evd c | None -> failwith "Ring.exec_tactic: anomaly" let tactic_res = ref [||] @@ -221,8 +215,8 @@ let exec_tactic env evd n f args = (** Evaluate the whole result *) let gl = dummy_goal env evd in let gls = Proofview.V82.of_tactic (Tacinterp.eval_tactic_ist ist (ltac_call f (args@[getter]))) gl in - let evd, nf = Evarutil.nf_evars_and_universes (Refiner.project gls) in - let nf c = nf (constr_of c) in + let evd = Evd.minimize_universes (Refiner.project gls) in + let nf c = constr_of evd c in Array.map nf !tactic_res, Evd.universe_context_set evd let stdlib_modules = @@ -233,7 +227,7 @@ let stdlib_modules = ] let coq_constant c = - lazy (EConstr.of_constr (Universes.constr_of_global @@ Coqlib.gen_reference_in_modules "Ring" stdlib_modules c)) + lazy (EConstr.of_constr (UnivGen.constr_of_global @@ Coqlib.gen_reference_in_modules "Ring" stdlib_modules c)) let coq_reference c = lazy (Coqlib.gen_reference_in_modules "Ring" stdlib_modules c) @@ -247,9 +241,10 @@ let coq_nil = coq_reference "nil" let lapp f args = mkApp(Lazy.force f,args) -let plapp evd f args = - let fc = Evarutil.e_new_global evd (Lazy.force f) in - mkApp(fc,args) +let plapp evdref f args = + let evd, fc = Evarutil.new_global !evdref (Lazy.force f) in + evdref := evd; + mkApp(fc,args) let dest_rel0 sigma t = match EConstr.kind sigma t with @@ -278,7 +273,7 @@ let plugin_modules = ] let my_constant c = - lazy (EConstr.of_constr (Universes.constr_of_global @@ Coqlib.gen_reference_in_modules "Ring" plugin_modules c)) + lazy (EConstr.of_constr (UnivGen.constr_of_global @@ Coqlib.gen_reference_in_modules "Ring" plugin_modules c)) let my_reference c = lazy (Coqlib.gen_reference_in_modules "Ring" plugin_modules c) @@ -504,10 +499,12 @@ let ring_equality env evd (r,add,mul,opp,req) = let op_morph = match opp with Some opp -> plapp evd coq_eq_morph [|r;add;mul;opp|] - | None -> plapp evd coq_eq_smorph [|r;add;mul|] in - let setoid = Typing.e_solve_evars env evd setoid in - let op_morph = Typing.e_solve_evars env evd op_morph in - (setoid,op_morph) + | None -> plapp evd coq_eq_smorph [|r;add;mul|] in + let sigma = !evd in + let sigma, setoid = Typing.solve_evars env sigma setoid in + let sigma, op_morph = Typing.solve_evars env sigma op_morph in + evd := sigma; + (setoid,op_morph) | _ -> let setoid = setoid_of_relation (Global.env ()) evd r req in let signature = [Some (r,Some req);Some (r,Some req)],Some(r,Some req) in @@ -586,48 +583,53 @@ let make_hyp env evd c = let t = Retyping.get_type_of env !evd c in plapp evd coq_mkhypo [|t;c|] -let make_hyp_list env evd lH = - let carrier = Evarutil.e_new_global evd (Lazy.force coq_hypo) in +let make_hyp_list env evdref lH = + let evd, carrier = Evarutil.new_global !evdref (Lazy.force coq_hypo) in + evdref := evd; let l = List.fold_right - (fun c l -> plapp evd coq_cons [|carrier; (make_hyp env evd c); l|]) lH - (plapp evd coq_nil [|carrier|]) + (fun c l -> plapp evdref coq_cons [|carrier; (make_hyp env evdref c); l|]) lH + (plapp evdref coq_nil [|carrier|]) in - let l' = Typing.e_solve_evars env evd l in + let sigma, l' = Typing.solve_evars env !evdref l in + evdref := sigma; let l' = EConstr.Unsafe.to_constr l' in - Evarutil.nf_evars_universes !evd l' + Evarutil.nf_evars_universes !evdref l' -let interp_power env evd pow = - let carrier = Evarutil.e_new_global evd (Lazy.force coq_hypo) in +let interp_power env evdref pow = + let evd, carrier = Evarutil.new_global !evdref (Lazy.force coq_hypo) in + evdref := evd; match pow with | None -> let t = ArgArg(Loc.tag (Lazy.force ltac_inv_morph_nothing)) in - (TacArg(Loc.tag (TacCall(Loc.tag (t,[])))), plapp evd coq_None [|carrier|]) + (TacArg(Loc.tag (TacCall(Loc.tag (t,[])))), plapp evdref coq_None [|carrier|]) | Some (tac, spec) -> let tac = match tac with | CstTac t -> Tacintern.glob_tactic t | Closed lc -> closed_term_ast (List.map Smartlocate.global_with_alias lc) in - let spec = make_hyp env evd (ic_unsafe spec) in - (tac, plapp evd coq_Some [|carrier; spec|]) + let spec = make_hyp env evdref (ic_unsafe spec) in + (tac, plapp evdref coq_Some [|carrier; spec|]) -let interp_sign env evd sign = - let carrier = Evarutil.e_new_global evd (Lazy.force coq_hypo) in +let interp_sign env evdref sign = + let evd, carrier = Evarutil.new_global !evdref (Lazy.force coq_hypo) in + evdref := evd; match sign with - | None -> plapp evd coq_None [|carrier|] + | None -> plapp evdref coq_None [|carrier|] | Some spec -> - let spec = make_hyp env evd (ic_unsafe spec) in - plapp evd coq_Some [|carrier;spec|] + let spec = make_hyp env evdref (ic_unsafe spec) in + plapp evdref coq_Some [|carrier;spec|] (* Same remark on ill-typed terms ... *) -let interp_div env evd div = - let carrier = Evarutil.e_new_global evd (Lazy.force coq_hypo) in +let interp_div env evdref div = + let evd, carrier = Evarutil.new_global !evdref (Lazy.force coq_hypo) in + evdref := evd; match div with - | None -> plapp evd coq_None [|carrier|] + | None -> plapp evdref coq_None [|carrier|] | Some spec -> - let spec = make_hyp env evd (ic_unsafe spec) in - plapp evd coq_Some [|carrier;spec|] + let spec = make_hyp env evdref (ic_unsafe spec) in + plapp evdref coq_Some [|carrier;spec|] (* Same remark on ill-typed terms ... *) let add_theory0 name (sigma, rth) eqth morphth cst_tac (pre,post) power sign div = @@ -728,7 +730,9 @@ let make_term_list env evd carrier rl = let l = List.fold_right (fun x l -> plapp evd coq_cons [|carrier;x;l|]) rl (plapp evd coq_nil [|carrier|]) - in Typing.e_solve_evars env evd l + in + let sigma, l = Typing.solve_evars env !evd l in + evd := sigma; l let carg c = Tacinterp.Value.of_constr (EConstr.of_constr c) let tacarg expr = @@ -917,7 +921,7 @@ let ftheory_to_obj : field_info -> obj = let field_equality evd r inv req = match EConstr.kind !evd req with | App (f, [| _ |]) when eq_constr_nounivs !evd f (Lazy.force coq_eq) -> - let c = Universes.constr_of_global (Coqlib.build_coq_eq_data()).congr in + let c = UnivGen.constr_of_global (Coqlib.build_coq_eq_data()).congr in let c = EConstr.of_constr c in mkApp(c,[|r;r;inv|]) | _ -> diff --git a/plugins/setoid_ring/newring.mli b/plugins/setoid_ring/newring.mli index 1d1557b12..0e056a472 100644 --- a/plugins/setoid_ring/newring.mli +++ b/plugins/setoid_ring/newring.mli @@ -11,7 +11,6 @@ open Names open EConstr open Libnames -open Globnames open Constrexpr open Newring_ast @@ -19,7 +18,7 @@ val protect_tac_in : string -> Id.t -> unit Proofview.tactic val protect_tac : string -> unit Proofview.tactic -val closed_term : EConstr.constr -> global_reference list -> unit Proofview.tactic +val closed_term : EConstr.constr -> GlobRef.t list -> unit Proofview.tactic val add_theory : Id.t -> diff --git a/plugins/ssr/ssrast.mli b/plugins/ssr/ssrast.mli index 7f5f2f63d..5571c5420 100644 --- a/plugins/ssr/ssrast.mli +++ b/plugins/ssr/ssrast.mli @@ -37,7 +37,7 @@ type ssrmult = int * ssrmmod type ssrocc = (bool * int list) option (* index MAYBE REMOVE ONLY INTERNAL stuff between {} *) -type ssrindex = int Misctypes.or_var +type ssrindex = int Locus.or_var (* clear switch {H G} *) type ssrclear = ssrhyps diff --git a/plugins/ssr/ssrcommon.ml b/plugins/ssr/ssrcommon.ml index d5118da4c..2a31157be 100644 --- a/plugins/ssr/ssrcommon.ml +++ b/plugins/ssr/ssrcommon.ml @@ -181,10 +181,9 @@ let option_assert_get o msg = (** Constructors for rawconstr *) open Glob_term open Globnames -open Misctypes open Decl_kinds -let mkRHole = DAst.make @@ GHole (Evar_kinds.InternalHole, IntroAnonymous, None) +let mkRHole = DAst.make @@ GHole (Evar_kinds.InternalHole, Namegen.IntroAnonymous, None) let rec mkRHoles n = if n > 0 then mkRHole :: mkRHoles (n - 1) else [] let rec isRHoles cl = match cl with @@ -254,7 +253,7 @@ let interp_refine ist gl rc = let interp_open_constr ist gl gc = - let (sigma, (c, _)) = Tacinterp.interp_open_constr_with_bindings ist (pf_env gl) (project gl) (gc, Misctypes.NoBindings) in + let (sigma, (c, _)) = Tacinterp.interp_open_constr_with_bindings ist (pf_env gl) (project gl) (gc, Tactypes.NoBindings) in (project gl, (sigma, c)) let interp_term ist gl (_, c) = snd (interp_open_constr ist gl c) @@ -423,12 +422,12 @@ let mk_anon_id t gl_ids = (set s i (Char.chr (Char.code (get s i) + 1)); s) in Id.of_bytes (loop (n - 1)) -let convert_concl_no_check t = Tactics.convert_concl_no_check t Term.DEFAULTcast -let convert_concl t = Tactics.convert_concl t Term.DEFAULTcast +let convert_concl_no_check t = Tactics.convert_concl_no_check t DEFAULTcast +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 - | Term.Prod(_,src,tgt) -> + | Prod(_,src,tgt) -> Proofview.V82.of_tactic (convert_concl_no_check (EConstr.mkProd (!orig_name_ref,src,tgt))) gl | _ -> CErrors.anomaly (str "gentac creates no product") @@ -504,16 +503,17 @@ let nf_evar sigma t = EConstr.Unsafe.to_constr (Evarutil.nf_evar sigma (EConstr.of_constr t)) let pf_abs_evars2 gl rigid (sigma, c0) = - let c0 = EConstr.to_constr sigma c0 in + let c0 = EConstr.to_constr ~abort_on_undefined_evars:false sigma c0 in let sigma0, ucst = project gl, Evd.evar_universe_context sigma in let nenv = env_size (pf_env gl) in let abs_evar n k = let evi = Evd.find sigma k in - let dc = CList.firstn n (evar_filtered_context evi) in + 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.LocalAssum (x,t) -> mkNamedProd x t c in - let t = Context.Named.fold_inside abs_dc ~init:evi.evar_concl dc in + let t = Context.Named.fold_inside abs_dc ~init:concl dc in nf_evar sigma t in let rec put evlist c = match Constr.kind c with | Evar (k, a) -> @@ -569,11 +569,12 @@ let pf_abs_evars_pirrel gl (sigma, c0) = let nenv = env_size (pf_env gl) in let abs_evar n k = let evi = Evd.find sigma k in - let dc = CList.firstn n (evar_filtered_context evi) in + 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.LocalAssum (x,t) -> mkNamedProd x t c in - let t = Context.Named.fold_inside abs_dc ~init:evi.evar_concl dc in + let t = Context.Named.fold_inside abs_dc ~init:concl dc in nf_evar sigma0 (nf_evar sigma t) in let rec put evlist c = match Constr.kind c with | Evar (k, a) -> @@ -581,7 +582,7 @@ let pf_abs_evars_pirrel gl (sigma, c0) = let n = max 0 (Array.length a - nenv) in let k_ty = Retyping.get_sort_family_of - (pf_env gl) sigma (EConstr.of_constr (Evd.evar_concl (Evd.find sigma k))) in + (pf_env gl) sigma (Evd.evar_concl (Evd.find sigma k)) in let is_prop = k_ty = InProp in let t = abs_evar n k in (k, (n, t, is_prop)) :: put evlist t | _ -> Constr.fold put evlist c in @@ -746,7 +747,7 @@ let pf_mkSsrConst name gl = let pf_fresh_global name gl = let sigma, env, it = project gl, pf_env gl, sig_it gl in let sigma,t = Evd.fresh_global env sigma name in - t, re_sig it sigma + EConstr.Unsafe.to_constr t, re_sig it sigma let mkProt t c gl = let prot, gl = pf_mkSsrConst "protect_term" gl in @@ -800,8 +801,11 @@ let rec is_name_in_ipats name = function List.exists (function SsrHyp(_,id) -> id = name) clr || is_name_in_ipats name tl | IPatId id :: tl -> id = name || is_name_in_ipats name tl - | (IPatCase l | IPatDispatch l) :: tl -> List.exists (is_name_in_ipats name) l || is_name_in_ipats name tl - | _ :: tl -> is_name_in_ipats name tl + | IPatAbstractVars ids :: tl -> + CList.mem_f Id.equal name ids || is_name_in_ipats name tl + | (IPatCase l | IPatDispatch l | IPatInj l) :: tl -> + List.exists (is_name_in_ipats name) l || is_name_in_ipats name tl + | (IPatView _ | IPatAnon _ | IPatSimpl _ | IPatRewrite _ | IPatTac _ | IPatNoop) :: tl -> is_name_in_ipats name tl | [] -> false let view_error s gv = @@ -856,8 +860,8 @@ let mkCProp loc = CAst.make ?loc @@ CSort GProp let mkCType loc = CAst.make ?loc @@ CSort (GType []) let mkCVar ?loc id = CAst.make ?loc @@ CRef (CAst.make ?loc @@ Ident id, None) let rec mkCHoles ?loc n = - if n <= 0 then [] else (CAst.make ?loc @@ CHole (None, IntroAnonymous, None)) :: mkCHoles ?loc (n - 1) -let mkCHole loc = CAst.make ?loc @@ CHole (None, IntroAnonymous, None) + if n <= 0 then [] else (CAst.make ?loc @@ CHole (None, Namegen.IntroAnonymous, None)) :: mkCHoles ?loc (n - 1) +let mkCHole loc = CAst.make ?loc @@ CHole (None, Namegen.IntroAnonymous, None) let mkCLambda ?loc name ty t = CAst.make ?loc @@ CLambdaN ([CLocalAssum([CAst.make ?loc name], Default Explicit, ty)], t) let mkCArrow ?loc ty t = CAst.make ?loc @@ @@ -980,7 +984,7 @@ let applyn ~with_evars ?beta ?(with_shelve=false) n t gl = if not (EConstr.Vars.closed0 sigma ty) then raise dependent_apply_error; let m = Evarutil.new_meta () in - loop (meta_declare m (EConstr.Unsafe.to_constr ty) sigma) bo ((EConstr.mkMeta m)::args) (n-1) + loop (meta_declare m ty sigma) bo ((EConstr.mkMeta m)::args) (n-1) | _ -> assert false in loop sigma t [] n in pp(lazy(str"Refiner.refiner " ++ Printer.pr_econstr_env (pf_env gl) (project gl) t)); @@ -1216,7 +1220,7 @@ let genclrtac cl cs clr = (fun type_err gl -> tclTHEN (tclTHEN (Proofview.V82.of_tactic (Tactics.elim_type (EConstr.of_constr - (Universes.constr_of_global @@ Coqlib.build_coq_False ())))) (old_cleartac clr)) + (UnivGen.constr_of_global @@ Coqlib.build_coq_False ())))) (old_cleartac clr)) (fun gl -> raise type_err) gl)) (old_cleartac clr) @@ -1441,7 +1445,7 @@ let tclINTRO_ANON = tclINTRO ~id:None ~conclusion:return let tclRENAME_HD_PROD name = Goal.enter begin fun gl -> let convert_concl_no_check t = - Tactics.convert_concl_no_check t Term.DEFAULTcast in + Tactics.convert_concl_no_check t DEFAULTcast in let concl = Goal.concl gl in let sigma = Goal.sigma gl in match EConstr.kind sigma concl with @@ -1500,7 +1504,7 @@ let tclOPTION o d = let tacIS_INJECTION_CASE ?ty t = begin tclOPTION ty (tacTYPEOF t) >>= fun ty -> tacREDUCE_TO_QUANTIFIED_IND ty >>= fun ((mind,_),_) -> - tclUNIT (Globnames.eq_gr (Globnames.IndRef mind) (Coqlib.build_coq_eq ())) + tclUNIT (GlobRef.equal (GlobRef.IndRef mind) (Coqlib.build_coq_eq ())) end let tclWITHTOP tac = Goal.enter begin fun gl -> diff --git a/plugins/ssr/ssrcommon.mli b/plugins/ssr/ssrcommon.mli index 2b8f1d540..9ba23467e 100644 --- a/plugins/ssr/ssrcommon.mli +++ b/plugins/ssr/ssrcommon.mli @@ -212,7 +212,7 @@ val pf_abs_prod : EConstr.t -> Goal.goal Evd.sigma * EConstr.types val mkSsrRRef : string -> Glob_term.glob_constr * 'a option -val mkSsrRef : string -> Globnames.global_reference +val mkSsrRef : string -> GlobRef.t val mkSsrConst : string -> env -> evar_map -> evar_map * EConstr.t @@ -224,7 +224,7 @@ val new_wild_id : tac_ctx -> Names.Id.t * tac_ctx val pf_fresh_global : - Globnames.global_reference -> + GlobRef.t -> Goal.goal Evd.sigma -> Constr.constr * Goal.goal Evd.sigma diff --git a/plugins/ssr/ssrelim.ml b/plugins/ssr/ssrelim.ml index 717657a24..fbe3b000f 100644 --- a/plugins/ssr/ssrelim.ml +++ b/plugins/ssr/ssrelim.ml @@ -14,9 +14,10 @@ open Util open Names open Printer open Term +open Constr open Termops open Globnames -open Misctypes +open Tactypes open Tacmach open Ssrmatching_plugin @@ -356,7 +357,7 @@ let ssrelim ?(ind=ref None) ?(is_case=false) deps what ?elim eqid elim_intro_tac let ev = List.fold_left Evar.Set.union Evar.Set.empty patterns_ev in let ty_ev = Evar.Set.fold (fun i e -> let ex = i in - let i_ty = EConstr.of_constr (Evd.evar_concl (Evd.find (project gl) ex)) in + let i_ty = Evd.evar_concl (Evd.find (project gl) ex) in Evar.Set.union e (evars_of_term i_ty)) ev Evar.Set.empty in let inter = Evar.Set.inter ev ty_ev in @@ -418,7 +419,7 @@ let injectl2rtac sigma c = match EConstr.kind sigma c with let is_injection_case c gl = let gl, cty = pfe_type_of gl c in let (mind,_), _ = pf_reduce_to_quantified_ind gl cty in - eq_gr (IndRef mind) (Coqlib.build_coq_eq ()) + GlobRef.equal (IndRef mind) (Coqlib.build_coq_eq ()) let perform_injection c gl = let gl, cty = pfe_type_of gl c in diff --git a/plugins/ssr/ssrequality.ml b/plugins/ssr/ssrequality.ml index 57635edac..f929e9430 100644 --- a/plugins/ssr/ssrequality.ml +++ b/plugins/ssr/ssrequality.ml @@ -276,7 +276,7 @@ let unfoldintac occ rdx t (kt,_) gl = let foldtac occ rdx ft gl = let sigma0, concl0, env0 = project gl, pf_concl gl, pf_env gl in let sigma, t = ft in - let t = EConstr.to_constr sigma t in + let t = EConstr.to_constr ~abort_on_undefined_evars:false sigma t in let fold, conclude = match rdx with | Some (_, (In_T _ | In_X_In_T _)) | None -> let ise = Evd.create_evar_defs sigma in @@ -287,7 +287,10 @@ let foldtac occ rdx ft gl = (fun env c _ h -> try find_T env c h ~k:(fun env t _ _ -> t) with NoMatch ->c), (fun () -> try end_T () with NoMatch -> fake_pmatcher_end ()) | _ -> - (fun env c _ h -> try let sigma = unify_HO env sigma (EConstr.of_constr c) (EConstr.of_constr t) in EConstr.to_constr sigma (EConstr.of_constr t) + (fun env c _ h -> + 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)), fake_pmatcher_end in @@ -359,7 +362,7 @@ let pirrel_rewrite pred rdx rdx_ty new_rdx dir (sigma, c) c_ty gl = let evs = Evar.Set.elements (Evarutil.undefined_evars_of_term sigma t) in let open_evs = List.filter (fun k -> Sorts.InProp <> Retyping.get_sort_family_of - env sigma (EConstr.of_constr (Evd.evar_concl (Evd.find sigma k)))) + env sigma (Evd.evar_concl (Evd.find sigma k))) evs in if open_evs <> [] then Some name else None) (List.combine (Array.to_list args) names) @@ -369,8 +372,8 @@ let pirrel_rewrite pred rdx rdx_ty new_rdx dir (sigma, c) c_ty gl = ;; let is_construct_ref sigma c r = - EConstr.isConstruct sigma c && eq_gr (ConstructRef (fst(EConstr.destConstruct sigma c))) r -let is_ind_ref sigma c r = EConstr.isInd sigma c && eq_gr (IndRef (fst(EConstr.destInd sigma c))) r + EConstr.isConstruct sigma c && GlobRef.equal (ConstructRef (fst(EConstr.destConstruct sigma c))) r +let is_ind_ref sigma c r = EConstr.isInd sigma c && GlobRef.equal (IndRef (fst(EConstr.destInd sigma c))) r let rwcltac cl rdx dir sr gl = let n, r_n,_, ucst = pf_abs_evars gl sr in @@ -435,7 +438,7 @@ let lz_setoid_relation = | env', srel when env' == env -> srel | _ -> let srel = - try Some (Universes.constr_of_global @@ + try Some (UnivGen.constr_of_global @@ Coqlib.coq_reference "Class_setoid" sdir "RewriteRelation") with _ -> None in last_srel := (env, srel); srel @@ -478,11 +481,11 @@ let rwprocess_rule dir rule gl = | _ -> let ra = Array.append a [|r|] in function 1 -> let sigma, pi1 = Evd.fresh_global env sigma coq_prod.Coqlib.proj1 in - EConstr.mkApp (EConstr.of_constr pi1, ra), sigma + EConstr.mkApp (pi1, ra), sigma | _ -> let sigma, pi2 = Evd.fresh_global env sigma coq_prod.Coqlib.proj2 in - EConstr.mkApp (EConstr.of_constr pi2, ra), sigma in - if EConstr.eq_constr sigma a.(0) (EConstr.of_constr (Universes.constr_of_global @@ Coqlib.build_coq_True ())) then + EConstr.mkApp (pi2, ra), sigma in + if EConstr.eq_constr sigma a.(0) (EConstr.of_constr (UnivGen.constr_of_global @@ Coqlib.build_coq_True ())) then let s, sigma = sr sigma 2 in loop (converse_dir d) sigma s a.(1) rs 0 else @@ -557,7 +560,7 @@ let rwrxtac occ rdx_pat dir rule gl = let rpat env sigma0 (sigma, pats) (d, r, lhs, rhs) = let sigma, pat = let rw_progress rhs t evd = rw_progress rhs (EConstr.of_constr t) evd in - mk_tpattern env sigma0 (sigma,EConstr.to_constr sigma r) (rw_progress rhs) d (EConstr.to_constr sigma lhs) in + mk_tpattern env sigma0 (sigma, EConstr.to_constr ~abort_on_undefined_evars:false sigma r) (rw_progress rhs) d (EConstr.to_constr ~abort_on_undefined_evars:false sigma lhs) in sigma, pats @ [pat] in let rpats = List.fold_left (rpat env0 sigma0) (r_sigma,[]) rules in let find_R, end_R = mk_tpattern_matcher sigma0 occ ~upats_origin rpats in @@ -567,7 +570,7 @@ let rwrxtac occ rdx_pat dir rule gl = let r = ref None in (fun env c _ h -> do_once r (fun () -> find_rule (EConstr.of_constr c), c); mkRel h), (fun concl -> closed0_check concl e gl; - let (d,(ev,ctx,c)) , x = assert_done r in (d,(ev,ctx, EConstr.to_constr ev c)) , x) in + let (d,(ev,ctx,c)) , x = assert_done r in (d,(ev,ctx, EConstr.to_constr ~abort_on_undefined_evars:false ev c)) , x) in let concl0 = EConstr.Unsafe.to_constr concl0 in let concl = eval_pattern env0 sigma0 concl0 rdx_pat occ find_R in let (d, r), rdx = conclude concl in @@ -589,7 +592,10 @@ let ssrinstancesofrule ist dir arg gl = let rpat env sigma0 (sigma, pats) (d, r, lhs, rhs) = let sigma, pat = let rw_progress rhs t evd = rw_progress rhs (EConstr.of_constr t) evd in - mk_tpattern env sigma0 (sigma,EConstr.to_constr sigma r) (rw_progress rhs) d (EConstr.to_constr sigma lhs) in + mk_tpattern env sigma0 + (sigma,EConstr.to_constr ~abort_on_undefined_evars:false sigma r) + (rw_progress rhs) d + (EConstr.to_constr ~abort_on_undefined_evars:false sigma lhs) in sigma, pats @ [pat] in let rpats = List.fold_left (rpat env0 sigma0) (r_sigma,[]) rules in mk_tpattern_matcher ~all_instances:true ~raise_NoMatch:true sigma0 None ~upats_origin rpats in diff --git a/plugins/ssr/ssrfwd.ml b/plugins/ssr/ssrfwd.ml index 6e17e8e15..2c046190f 100644 --- a/plugins/ssr/ssrfwd.ml +++ b/plugins/ssr/ssrfwd.ml @@ -86,7 +86,6 @@ let _ = open Constrexpr open Glob_term -open Misctypes let combineCG t1 t2 f g = match t1, t2 with | (x, (t1, None)), (_, (t2, None)) -> x, (g t1 t2, None) @@ -184,9 +183,7 @@ let havetac ist let gs = List.map (fun (_,a) -> Ssripats.Internal.pf_find_abstract_proof false gl (EConstr.Unsafe.to_constr a.(1))) skols_args in - let tacopen_skols gl = - let stuff, g = Refiner.unpackage gl in - Refiner.repackage stuff (gs @ [g]) in + let tacopen_skols gl = re_sig (gs @ [gl.Evd.it]) gl.Evd.sigma in let gl, ty = pf_e_type_of gl t in gl, ty, Proofview.V82.of_tactic (Tactics.apply t), id, Tacticals.tclTHEN (Tacticals.tclTHEN itac_c simpltac) diff --git a/plugins/ssr/ssripats.ml b/plugins/ssr/ssripats.ml index 42566575c..8207bc11e 100644 --- a/plugins/ssr/ssripats.ml +++ b/plugins/ssr/ssripats.ml @@ -12,6 +12,7 @@ open Ssrmatching_plugin open Util open Names +open Constr open Proofview open Proofview.Notations @@ -90,11 +91,11 @@ open State (** Warning: unlike [nb_deps_assums], it does not perform reduction *) let rec nb_assums cur env sigma t = match EConstr.kind sigma t with - | Term.Prod(name,ty,body) -> + | Prod(name,ty,body) -> nb_assums (cur+1) env sigma body - | Term.LetIn(name,ty,t1,t2) -> + | LetIn(name,ty,t1,t2) -> nb_assums (cur+1) env sigma t2 - | Term.Cast(t,_,_) -> + | Cast(t,_,_) -> nb_assums cur env sigma t | _ -> cur let nb_assums = nb_assums 0 @@ -133,6 +134,12 @@ let intro_clear ids future_ipats = isCLR_PUSHL clear_ids end +let tacCHECK_HYPS_EXIST hyps = Goal.enter begin fun gl -> + let ctx = Goal.hyps gl in + List.iter (Ssrcommon.check_hyp_exists ctx) hyps; + tclUNIT () +end + (** [=> []] *****************************************************************) let tac_case t = Goal.enter begin fun _ -> @@ -212,15 +219,16 @@ let rec ipat_tac1 future_ipats ipat : unit tactic = Ssrview.tclIPAT_VIEWS ~views:l ~conclusion:(fun ~to_clear:clr -> intro_clear clr future_ipats) | IPatDispatch ipatss -> - tclEXTEND (List.map ipat_tac ipatss) (tclUNIT ()) [] + tclEXTEND (List.map (ipat_tac future_ipats) ipatss) (tclUNIT ()) [] | IPatId id -> Ssrcommon.tclINTRO_ID id | IPatCase ipatss -> - tclIORPAT (Ssrcommon.tclWITHTOP tac_case) ipatss + tclIORPAT (Ssrcommon.tclWITHTOP tac_case) future_ipats ipatss | IPatInj ipatss -> tclIORPAT (Ssrcommon.tclWITHTOP - (fun t -> V82.tactic ~nf_evars:false (Ssrelim.perform_injection t))) ipatss + (fun t -> V82.tactic ~nf_evars:false (Ssrelim.perform_injection t))) + future_ipats ipatss | IPatAnon Drop -> intro_drop | IPatAnon One -> Ssrcommon.tclINTRO_ANON @@ -229,7 +237,9 @@ let rec ipat_tac1 future_ipats ipat : unit tactic = | IPatNoop -> tclUNIT () | IPatSimpl Nop -> tclUNIT () - | IPatClear ids -> intro_clear (List.map Ssrcommon.hyp_id ids) future_ipats + | IPatClear ids -> + tacCHECK_HYPS_EXIST ids <*> + intro_clear (List.map Ssrcommon.hyp_id ids) future_ipats | IPatSimpl (Simpl n) -> V82.tactic ~nf_evars:false (Ssrequality.simpltac (Simpl n)) @@ -246,17 +256,17 @@ let rec ipat_tac1 future_ipats ipat : unit tactic = | IPatTac t -> t -and ipat_tac pl : unit tactic = +and ipat_tac future_ipats pl : unit tactic = match pl with | [] -> tclUNIT () | pat :: pl -> - Ssrcommon.tcl0G (tclLOG pat (ipat_tac1 pl)) <*> + Ssrcommon.tcl0G (tclLOG pat (ipat_tac1 (pl @ future_ipats))) <*> isTICK pat <*> - ipat_tac pl + ipat_tac future_ipats pl -and tclIORPAT tac = function +and tclIORPAT tac future_ipats = function | [[]] -> tac - | p -> Tacticals.New.tclTHENS tac (List.map ipat_tac p) + | p -> Tacticals.New.tclTHENS tac (List.map (ipat_tac future_ipats) p) let split_at_first_case ipats = let rec loop acc = function @@ -277,7 +287,7 @@ let main ?eqtac ~first_case_is_dispatch ipats = let case = ssr_exception first_case_is_dispatch case in let case = option_to_list case in let eqtac = option_to_list (Option.map (fun x -> IPatTac x) eqtac) in - Ssrcommon.tcl0G (ipat_tac (ip_before @ case @ eqtac @ ip_after) <*> intro_end) + Ssrcommon.tcl0G (ipat_tac [] (ip_before @ case @ eqtac @ ip_after) <*> intro_end) end (* }}} *) @@ -410,7 +420,7 @@ let tclLAST_GEN ~to_ind ((oclr, occ), t) conclusion = tclINDEPENDENTL begin Goal.enter_one begin fun g -> let pat = Ssrmatching.interp_cpattern sigma0 t None in let cl0, env, sigma, hyps = Goal.(concl g, env g, sigma g, hyps g) in - let cl = EConstr.to_constr sigma cl0 in + let cl = EConstr.to_constr ~abort_on_undefined_evars:false sigma cl0 in let (c, ucst), cl = try Ssrmatching.fill_occ_pattern ~raise_NoMatch:true env sigma cl pat occ 1 with Ssrmatching.NoMatch -> Ssrmatching.redex_of_pattern env pat, cl in @@ -547,7 +557,7 @@ let rec eqmoveipats eqpat = function let ssrsmovetac = Goal.enter begin fun g -> let sigma, concl = Goal.(sigma g, concl g) in match EConstr.kind sigma concl with - | Term.Prod _ | Term.LetIn _ -> tclUNIT () + | Prod _ | LetIn _ -> tclUNIT () | _ -> Tactics.hnf_in_concl end @@ -585,8 +595,8 @@ let rec is_Evar_or_CastedMeta sigma x = let occur_existential_or_casted_meta sigma c = let rec occrec c = match EConstr.kind sigma c with - | Term.Evar _ -> raise Not_found - | Term.Cast (m,_,_) when EConstr.isMeta sigma m -> raise Not_found + | Evar _ -> raise Not_found + | Cast (m,_,_) when EConstr.isMeta sigma m -> raise Not_found | _ -> EConstr.iter sigma occrec c in try occrec c; false @@ -615,8 +625,8 @@ let tacFIND_ABSTRACT_PROOF check_lock abstract_n = Goal.enter_one ~__LOC__ begin fun g -> let sigma, env = Goal.(sigma g, env g) in let l = Evd.fold_undefined (fun e ei l -> - match EConstr.kind sigma (EConstr.of_constr ei.Evd.evar_concl) with - | Term.App(hd, [|ty; n; lock|]) + match EConstr.kind sigma ei.Evd.evar_concl with + | App(hd, [|ty; n; lock|]) when (not check_lock || (occur_existential_or_casted_meta sigma ty && is_Evar_or_CastedMeta sigma lock)) && @@ -645,8 +655,8 @@ let ssrabstract dgens = let sigma, env, concl = Goal.(sigma g, env g, concl g) in let t = args_id.(0) in match EConstr.kind sigma t with - | (Term.Evar _ | Term.Meta _) -> Ssrcommon.tacUNIFY concl t <*> tclUNIT id - | Term.Cast(m,_,_) + | (Evar _ | Meta _) -> Ssrcommon.tacUNIFY concl t <*> tclUNIT id + | Cast(m,_,_) when EConstr.isEvar sigma m || EConstr.isMeta sigma m -> Ssrcommon.tacUNIFY concl t <*> tclUNIT id | _ -> diff --git a/plugins/ssr/ssrparser.ml4 b/plugins/ssr/ssrparser.ml4 index 0d82a9f09..352f88bb3 100644 --- a/plugins/ssr/ssrparser.ml4 +++ b/plugins/ssr/ssrparser.ml4 @@ -10,6 +10,7 @@ (* This file is (C) Copyright 2006-2015 Microsoft Corporation and Inria. *) +let _vmcast = Constr.VMcast open Names open Pp open Pcoq @@ -17,18 +18,19 @@ open Ltac_plugin open Genarg open Stdarg open Tacarg -open Term open Libnames open Tactics open Tacmach open Util +open Locus open Tacexpr open Tacinterp open Pltac open Extraargs open Ppconstr -open Misctypes +open Namegen +open Tactypes open Decl_kinds open Constrexpr open Constrexpr_ops @@ -64,7 +66,7 @@ DECLARE PLUGIN "ssreflect_plugin" * we thus save the lexer to restore it at the end of the file *) let frozen_lexer = CLexer.get_keyword_state () ;; -let tacltop = (5,Notation_term.E) +let tacltop = (5,Notation_gram.E) let pr_ssrtacarg _ _ prt = prt tacltop ARGUMENT EXTEND ssrtacarg TYPED AS tactic PRINTED BY pr_ssrtacarg @@ -301,24 +303,24 @@ END let pr_index = function - | Misctypes.ArgVar {CAst.v=id} -> pr_id id - | Misctypes.ArgArg n when n > 0 -> int n + | ArgVar {CAst.v=id} -> pr_id id + | ArgArg n when n > 0 -> int n | _ -> mt () let pr_ssrindex _ _ _ = pr_index -let noindex = Misctypes.ArgArg 0 +let noindex = ArgArg 0 let check_index ?loc i = if i > 0 then i else CErrors.user_err ?loc (str"Index not positive") let mk_index ?loc = function - | Misctypes.ArgArg i -> Misctypes.ArgArg (check_index ?loc i) + | ArgArg i -> ArgArg (check_index ?loc i) | iv -> iv let interp_index ist gl idx = Tacmach.project gl, match idx with - | Misctypes.ArgArg _ -> idx - | Misctypes.ArgVar id -> + | ArgArg _ -> idx + | ArgVar id -> let i = try let v = Id.Map.find id.CAst.v ist.Tacinterp.lfun in @@ -336,7 +338,7 @@ let interp_index ist gl idx = | None -> raise Not_found end end with _ -> CErrors.user_err ?loc:id.CAst.loc (str"Index not a number") in - Misctypes.ArgArg (check_index ?loc:id.CAst.loc i) + ArgArg (check_index ?loc:id.CAst.loc i) open Pltac @@ -543,7 +545,7 @@ END let remove_loc x = x.CAst.v -let ipat_of_intro_pattern p = Misctypes.( +let ipat_of_intro_pattern p = Tactypes.( let rec ipat_of_intro_pattern = function | IntroNaming (IntroIdentifier id) -> IPatId id | IntroAction IntroWildcard -> IPatAnon Drop @@ -585,37 +587,25 @@ let pr_ssripat _ _ _ = pr_ipat let pr_ssripats _ _ _ = pr_ipats let pr_ssriorpat _ _ _ = pr_iorpat -(* -let intern_ipat ist ipat = - let rec check_pat = function - | IPatClear clr -> ignore (List.map (intern_hyp ist) clr) - | IPatCase iorpat -> List.iter (List.iter check_pat) iorpat - | IPatDispatch iorpat -> List.iter (List.iter check_pat) iorpat - | IPatInj iorpat -> List.iter (List.iter check_pat) iorpat - | _ -> () in - check_pat ipat; ipat -*) - let intern_ipat ist = map_ipat (fun id -> id) - (intern_hyp ist) (* TODO: check with ltac, old code was ignoring the result *) + (intern_hyp ist) (glob_ast_closure_term ist) let intern_ipats ist = List.map (intern_ipat ist) let interp_intro_pattern = interp_wit wit_intro_pattern -let interp_introid ist gl id = Misctypes.( +let interp_introid ist gl id = try IntroNaming (IntroIdentifier (hyp_id (snd (interp_hyp ist gl (SsrHyp (Loc.tag id)))))) with _ -> (snd (interp_intro_pattern ist gl (CAst.make @@ IntroNaming (IntroIdentifier id)))).CAst.v -) let get_intro_id = function | IntroNaming (IntroIdentifier id) -> id | _ -> assert false -let rec add_intro_pattern_hyps ipat hyps = Misctypes.( +let rec add_intro_pattern_hyps ipat hyps = let {CAst.loc=loc;v=ipat} = ipat in match ipat with | IntroNaming (IntroIdentifier id) -> @@ -634,7 +624,6 @@ let rec add_intro_pattern_hyps ipat hyps = Misctypes.( | IntroForthcoming _ -> (* As in ipat_of_intro_pattern, was unable to determine which kind of ipat interp_introid could return [HH] *) assert false -) (* We interp the ipat using the standard ltac machinery for ids, since * we have no clue what a name could be bound to (maybe another ipat) *) @@ -1075,7 +1064,7 @@ let rec format_constr_expr h0 c0 = let open CAst in match h0, c0 with | BFdef :: h, { v = CLetIn({CAst.v=x}, v, oty, c) } -> let bs, c' = format_constr_expr h c in Bdef (x, oty, v) :: bs, c' - | [BFcast], { v = CCast (c, CastConv t) } -> + | [BFcast], { v = CCast (c, Glob_term.CastConv t) } -> [Bcast t], c | BFrec (has_str, has_cast) :: h, { v = CFix ( _, [_, (Some locn, CStructRec), bl, t, c]) } -> @@ -1104,7 +1093,7 @@ let wit_ssrfwdfmt = add_genarg "ssrfwdfmt" pr_fwdfmt let mkFwdVal fk c = ((fk, []), c) let mkssrFwdVal fk c = ((fk, []), (c,None)) -let dC t = CastConv t +let dC t = Glob_term.CastConv t let same_ist { interp_env = x } { interp_env = y } = match x,y with @@ -1221,8 +1210,8 @@ let push_binders c2 bs = | [] -> c | _ -> anomaly "binder not a lambda nor a let in" in match c2 with - | { loc; v = CCast (ct, CastConv cty) } -> - CAst.make ?loc @@ (CCast (loop false ct bs, CastConv (loop true cty bs))) + | { loc; v = CCast (ct, Glob_term.CastConv cty) } -> + CAst.make ?loc @@ (CCast (loop false ct bs, Glob_term.CastConv (loop true cty bs))) | ct -> loop false ct bs let rec fix_binders = let open CAst in function @@ -1949,7 +1938,7 @@ END let vmexacttac pf = Goal.nf_enter begin fun gl -> - exact_no_check (EConstr.mkCast (pf, VMcast, Tacmach.New.pf_concl gl)) + exact_no_check (EConstr.mkCast (pf, _vmcast, Tacmach.New.pf_concl gl)) end TACTIC EXTEND ssrexact diff --git a/plugins/ssr/ssrparser.mli b/plugins/ssr/ssrparser.mli index 2ac7c7e26..7cd3751ce 100644 --- a/plugins/ssr/ssrparser.mli +++ b/plugins/ssr/ssrparser.mli @@ -14,11 +14,11 @@ open Ltac_plugin val ssrtacarg : Tacexpr.raw_tactic_expr Pcoq.Gram.entry val wit_ssrtacarg : (Tacexpr.raw_tactic_expr, Tacexpr.glob_tactic_expr, Geninterp.Val.t) Genarg.genarg_type -val pr_ssrtacarg : 'a -> 'b -> (Notation_term.tolerability -> 'c) -> 'c +val pr_ssrtacarg : 'a -> 'b -> (Notation_gram.tolerability -> 'c) -> 'c val ssrtclarg : Tacexpr.raw_tactic_expr Pcoq.Gram.entry val wit_ssrtclarg : (Tacexpr.raw_tactic_expr, Tacexpr.glob_tactic_expr, Geninterp.Val.t) Genarg.genarg_type -val pr_ssrtclarg : 'a -> 'b -> (Notation_term.tolerability -> 'c -> 'd) -> 'c -> 'd +val pr_ssrtclarg : 'a -> 'b -> (Notation_gram.tolerability -> 'c -> 'd) -> 'c -> 'd val add_genarg : string -> ('a -> Pp.t) -> 'a Genarg.uniform_genarg_type diff --git a/plugins/ssr/ssrtacticals.ml b/plugins/ssr/ssrtacticals.ml index 9cc4f5cec..83581f341 100644 --- a/plugins/ssr/ssrtacticals.ml +++ b/plugins/ssr/ssrtacticals.ml @@ -11,9 +11,9 @@ (* This file is (C) Copyright 2006-2015 Microsoft Corporation and Inria. *) open Names +open Constr open Termops open Tacmach -open Misctypes open Locusops open Ssrast @@ -24,7 +24,7 @@ module NamedDecl = Context.Named.Declaration (** Tacticals (+, -, *, done, by, do, =>, first, and last). *) -let get_index = function ArgArg i -> i | _ -> +let get_index = function Locus.ArgArg i -> i | _ -> anomaly "Uninterpreted index" (* Toplevel constr must be globalized twice ! *) @@ -32,9 +32,8 @@ let get_index = function ArgArg i -> i | _ -> let tclPERM perm tac gls = let subgls = tac gls in - let sigma, subgll = Refiner.unpackage subgls in - let subgll' = perm subgll in - Refiner.repackage sigma subgll' + let subgll' = perm subgls.Evd.it in + re_sig subgll' subgls.Evd.sigma let rot_hyps dir i hyps = let n = List.length hyps in @@ -104,10 +103,10 @@ let endclausestac id_map clseq gl_id cl0 gl = | ids, dc' -> forced && ids = [] && (not hide_goal || dc' = [] && c_hidden) in let rec unmark c = match EConstr.kind (project gl) c with - | Term.Var id when hidden_clseq clseq && id = gl_id -> cl0 - | Term.Prod (Name id, t, c') when List.mem_assoc id id_map -> + | 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') - | Term.LetIn (Name id, v, t, c') when List.mem_assoc id id_map -> + | 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') | _ -> EConstr.map (project gl) unmark c in let utac hyp = diff --git a/plugins/ssr/ssrtacticals.mli b/plugins/ssr/ssrtacticals.mli index a5636ad0f..684e00235 100644 --- a/plugins/ssr/ssrtacticals.mli +++ b/plugins/ssr/ssrtacticals.mli @@ -17,7 +17,7 @@ val tclSEQAT : Tacinterp.interp_sign -> Tacinterp.Value.t -> Ssrast.ssrdir -> - int Misctypes.or_var * + int Locus.or_var * (('a * Tacinterp.Value.t option list) * Tacinterp.Value.t option) -> Tacmach.tactic @@ -37,7 +37,7 @@ val hinttac : val ssrdotac : Tacinterp.interp_sign -> - ((int Misctypes.or_var * Ssrast.ssrmmod) * + ((int Locus.or_var * Ssrast.ssrmmod) * (bool * Tacinterp.Value.t option list)) * ((Ssrast.ssrhyps * ((Ssrast.ssrhyp_or_id * string) * diff --git a/plugins/ssr/ssrvernac.ml4 b/plugins/ssr/ssrvernac.ml4 index 05dbf0a86..939e97866 100644 --- a/plugins/ssr/ssrvernac.ml4 +++ b/plugins/ssr/ssrvernac.ml4 @@ -19,7 +19,7 @@ open Constrexpr_ops open Pcoq open Pcoq.Prim open Pcoq.Constr -open Pcoq.Vernac_ +open Pvernac.Vernac_ open Ltac_plugin open Notation_ops open Notation_term @@ -27,7 +27,6 @@ open Glob_term open Globnames open Stdarg open Genarg -open Misctypes open Decl_kinds open Libnames open Pp @@ -377,7 +376,10 @@ let interp_head_pat hpat = | Cast (c', _, _) -> loop c' | Prod (_, _, c') -> loop c' | LetIn (_, _, _, c') -> loop c' - | _ -> Constr_matching.is_matching (Global.env()) Evd.empty p (EConstr.of_constr c) in + | _ -> + let env = Global.env () in + let sigma = Evd.from_env env in + Constr_matching.is_matching env sigma p (EConstr.of_constr c) in filter_head, loop let all_true _ = true diff --git a/plugins/ssr/ssrview.ml b/plugins/ssr/ssrview.ml index aa614fbc1..faebe3179 100644 --- a/plugins/ssr/ssrview.ml +++ b/plugins/ssr/ssrview.ml @@ -157,7 +157,7 @@ let tclINJ_CONSTR_IST ist p = let mkGHole = DAst.make - (Glob_term.GHole(Evar_kinds.InternalHole, Misctypes.IntroAnonymous, None)) + (Glob_term.GHole(Evar_kinds.InternalHole, Namegen.IntroAnonymous, None)) let rec mkGHoles n = if n > 0 then mkGHole :: mkGHoles (n - 1) else [] let mkGApp f args = if args = [] then f @@ -254,18 +254,18 @@ let finalize_view s0 ?(simple_types=true) p = Goal.enter_one ~__LOC__ begin fun g -> let env = Goal.env g in let sigma = Goal.sigma g in - let evars_of_p = Evd.evars_of_term (EConstr.to_constr sigma p) in + let evars_of_p = Evd.evars_of_term (EConstr.to_constr ~abort_on_undefined_evars:false sigma p) in let filter x _ = Evar.Set.mem x evars_of_p in let sigma = Typeclasses.resolve_typeclasses ~fail:false ~filter env sigma in let p = Reductionops.nf_evar sigma p in let get_body = function Evd.Evar_defined x -> x | _ -> assert false in let evars_of_econstr sigma t = - Evd.evars_of_term (EConstr.to_constr sigma (EConstr.of_constr t)) in + Evarutil.undefined_evars_of_term sigma (EConstr.of_constr t) in let rigid_of s = List.fold_left (fun l k -> if Evd.is_defined sigma k then let bo = get_body Evd.(evar_body (find sigma k)) in - k :: l @ Evar.Set.elements (evars_of_econstr sigma bo) + k :: l @ Evar.Set.elements (evars_of_econstr sigma (EConstr.Unsafe.to_constr bo)) else l ) [] s in let und0 = (* Unassigned evars in the initial goal *) diff --git a/plugins/ssrmatching/ssrmatching.ml4 b/plugins/ssrmatching/ssrmatching.ml4 index 2ba6acc03..69d944fa1 100644 --- a/plugins/ssrmatching/ssrmatching.ml4 +++ b/plugins/ssrmatching/ssrmatching.ml4 @@ -40,7 +40,7 @@ open Pretyping open Ppconstr open Printer open Globnames -open Misctypes +open Namegen open Decl_kinds open Evar_kinds open Constrexpr @@ -283,7 +283,7 @@ exception NoProgress (* comparison can be much faster than the HO one. *) let unif_EQ env sigma p c = - let evars = existential_opt_value sigma, Evd.universes sigma in + let evars = existential_opt_value0 sigma, Evd.universes sigma in try let _ = Reduction.conv env p ~evars c in true with _ -> false let unif_EQ_args env sigma pa a = @@ -312,20 +312,22 @@ let unif_HO_args env ise0 pa i ca = (* for HO evars, though hopefully Miller patterns can pick up some of *) (* those cases, and HO matching will mop up the rest. *) let flags_FO env = + let oracle = Environ.oracle env in + let ts = Conv_oracle.get_transp_state oracle in let flags = - { (Unification.default_no_delta_unify_flags ()).Unification.core_unify_flags + { (Unification.default_no_delta_unify_flags ts).Unification.core_unify_flags with Unification.modulo_conv_on_closed_terms = None; Unification.modulo_eta = true; Unification.modulo_betaiota = true; - Unification.modulo_delta_types = Conv_oracle.get_transp_state (Environ.oracle env)} + Unification.modulo_delta_types = ts } in { Unification.core_unify_flags = flags; Unification.merge_unify_flags = flags; Unification.subterm_unify_flags = flags; Unification.allow_K_in_toplevel_higher_order_unification = false; Unification.resolve_evars = - (Unification.default_no_delta_unify_flags ()).Unification.resolve_evars + (Unification.default_no_delta_unify_flags ts).Unification.resolve_evars } let unif_FO env ise p c = Unification.w_unify env ise Reduction.CONV ~flags:(flags_FO env) @@ -337,7 +339,7 @@ let nf_open_term sigma0 ise c = let s = ise and s' = ref sigma0 in let rec nf c' = match kind c' with | Evar ex -> - begin try nf (existential_value s ex) with _ -> + begin try nf (existential_value0 s ex) with _ -> let k, a = ex in let a' = Array.map nf a in if not (Evd.mem !s' k) then s' := Evd.add !s' k (Evarutil.nf_evar_info s (Evd.find s k)); @@ -347,7 +349,9 @@ let nf_open_term sigma0 ise c = let copy_def k evi () = if evar_body evi != Evd.Evar_empty then () else match Evd.evar_body (Evd.find s k) with - | Evar_defined c' -> s' := Evd.define k (nf c') !s' + | Evar_defined c' -> + let c' = EConstr.of_constr (nf (EConstr.Unsafe.to_constr c')) in + s' := Evd.define k c' !s' | _ -> () in let c' = nf c in let _ = Evd.fold copy_def sigma0 () in !s', Evd.evar_universe_context s, EConstr.of_constr c' @@ -446,7 +450,7 @@ let evars_for_FO ~hack env sigma0 (ise0:evar_map) c0 = let nenv = env_size env + if hack then 1 else 0 in let rec put c = match kind c with | Evar (k, a as ex) -> - begin try put (existential_value !sigma ex) + begin try put (existential_value0 !sigma ex) with NotInstantiatedEvar -> if Evd.mem sigma0 k then map put c else let evi = Evd.find !sigma k in @@ -457,11 +461,13 @@ let evars_for_FO ~hack env sigma0 (ise0:evar_map) c0 = | Context.Named.Declaration.LocalAssum (x, t) -> mkVar x :: d, mkNamedProd x (put t) c in let a, t = - Context.Named.fold_inside abs_dc ~init:([], (put evi.evar_concl)) dc in + Context.Named.fold_inside abs_dc + ~init:([], (put @@ EConstr.Unsafe.to_constr evi.evar_concl)) + (EConstr.Unsafe.to_named_context dc) in let m = Evarutil.new_meta () in - ise := meta_declare m t !ise; - sigma := Evd.define k (applistc (mkMeta m) a) !sigma; - put (existential_value !sigma ex) + ise := meta_declare m (EConstr.of_constr t) !ise; + sigma := Evd.define k (EConstr.of_constr (applistc (mkMeta m) a)) !sigma; + put (existential_value0 !sigma ex) end | _ -> map put c in let c1 = put c0 in !ise, c1 @@ -541,7 +547,7 @@ let splay_app ise = | App (f, a') -> loop f (Array.append a' a) | Cast (c', _, _) -> loop c' a | Evar ex -> - (try loop (existential_value ise ex) a with _ -> c, a) + (try loop (existential_value0 ise ex) a with _ -> c, a) | _ -> c, a in fun c -> match kind c with | App (f, a) -> loop f a @@ -704,9 +710,9 @@ let match_upats_HO ~on_instance upats env sigma0 ise c = ;; -let fixed_upat = function +let fixed_upat evd = function | {up_k = KpatFlex | KpatEvar _ | KpatProj _} -> false -| {up_t = t} -> not (occur_existential Evd.empty (EConstr.of_constr t)) (** FIXME *) +| {up_t = t} -> not (occur_existential evd (EConstr.of_constr t)) (** FIXME *) let do_once r f = match !r with Some _ -> () | None -> r := Some (f ()) @@ -765,7 +771,7 @@ let mk_tpattern_matcher ?(all_instances=false) let p2t p = mkApp(p.up_f,p.up_a) in let source () = match upats_origin, upats with | None, [p] -> - (if fixed_upat p then str"term " else str"partial term ") ++ + (if fixed_upat ise p then str"term " else str"partial term ") ++ pr_constr_pat (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() @@ -1095,15 +1101,14 @@ let thin id sigma goal = let ids = Id.Set.singleton id in let env = Goal.V82.env sigma goal in let cl = Goal.V82.concl sigma goal in - let evdref = ref (Evd.clear_metas sigma) in + let sigma = Evd.clear_metas sigma in let ans = - try Some (Evarutil.clear_hyps_in_evi env evdref (Environ.named_context_val env) cl ids) + try Some (Evarutil.clear_hyps_in_evi env sigma (Environ.named_context_val env) cl ids) with Evarutil.ClearDependencyError _ -> None in match ans with | None -> sigma - | Some (hyps, concl) -> - let sigma = !evdref in + | Some (sigma, hyps, concl) -> let (gl,ev,sigma) = Goal.V82.mk_goal sigma hyps concl (Goal.V82.extra sigma goal) in let sigma = Goal.V82.partial_solution_to sigma goal gl ev in sigma @@ -1255,7 +1260,7 @@ let eval_pattern ?raise_NoMatch env0 sigma0 concl0 pattern occ do_subst = let fs sigma x = nf_evar sigma x in let pop_evar sigma e p = let { Evd.evar_body = e_body } as e_def = Evd.find sigma e in - let e_body = match e_body with Evar_defined c -> c + let e_body = match e_body with Evar_defined c -> EConstr.Unsafe.to_constr c | _ -> errorstrm (str "Matching the pattern " ++ pr_constr_env env0 sigma0 p ++ str " did not instantiate ?" ++ int (Evar.repr e) ++ spc () ++ str "Does the variable bound by the \"in\" construct occur "++ diff --git a/plugins/syntax/ascii_syntax.ml b/plugins/syntax/ascii_syntax.ml index acb297ddf..47a59ba63 100644 --- a/plugins/syntax/ascii_syntax.ml +++ b/plugins/syntax/ascii_syntax.ml @@ -28,7 +28,7 @@ let make_kn dir id = Globnames.encode_mind (make_dir dir) (Id.of_string id) let make_path dir id = Libnames.make_path (make_dir dir) (Id.of_string id) let is_gr c gr = match DAst.get c with -| GRef (r, _) -> Globnames.eq_gr r gr +| GRef (r, _) -> GlobRef.equal r gr | _ -> false let ascii_module = ["Coq";"Strings";"Ascii"] diff --git a/plugins/syntax/int31_syntax.ml b/plugins/syntax/int31_syntax.ml index 5529ea700..f10f98e23 100644 --- a/plugins/syntax/int31_syntax.ml +++ b/plugins/syntax/int31_syntax.ml @@ -26,7 +26,7 @@ let make_dir l = DirPath.make (List.rev_map Id.of_string l) let make_path dir id = Libnames.make_path (make_dir dir) (Id.of_string id) let is_gr c gr = match DAst.get c with -| GRef (r, _) -> Globnames.eq_gr r gr +| GRef (r, _) -> GlobRef.equal r gr | _ -> false let make_mind mp id = Names.MutInd.make2 mp (Label.make id) diff --git a/plugins/syntax/nat_syntax.ml b/plugins/syntax/nat_syntax.ml index ad8b54d4d..e158e0b51 100644 --- a/plugins/syntax/nat_syntax.ml +++ b/plugins/syntax/nat_syntax.ml @@ -16,11 +16,12 @@ let () = Mltop.add_known_module __coq_plugin_name (* This file defines the printer for natural numbers in [nat] *) (*i*) +open Pp +open CErrors +open Names open Glob_term open Bigint open Coqlib -open Pp -open CErrors (*i*) (**********************************************************************) @@ -61,10 +62,10 @@ exception Non_closed_number let rec int_of_nat x = DAst.with_val (function | GApp (r, [a]) -> begin match DAst.get r with - | GRef (s,_) when Globnames.eq_gr s glob_S -> add_1 (int_of_nat a) + | GRef (s,_) when GlobRef.equal s glob_S -> add_1 (int_of_nat a) | _ -> raise Non_closed_number end - | GRef (z,_) when Globnames.eq_gr z glob_O -> zero + | GRef (z,_) when GlobRef.equal z glob_O -> zero | _ -> raise Non_closed_number ) x diff --git a/plugins/syntax/r_syntax.ml b/plugins/syntax/r_syntax.ml index 372e8ff30..94aa14335 100644 --- a/plugins/syntax/r_syntax.ml +++ b/plugins/syntax/r_syntax.ml @@ -30,7 +30,7 @@ let make_dir l = DirPath.make (List.rev_map Id.of_string l) let make_path dir id = Libnames.make_path (make_dir dir) (Id.of_string id) let is_gr c gr = match DAst.get c with -| GRef (r, _) -> Globnames.eq_gr r gr +| GRef (r, _) -> GlobRef.equal r gr | _ -> false let positive_path = make_path binnums "positive" @@ -66,7 +66,7 @@ let pos_of_bignat ?loc x = let rec bignat_of_pos c = match DAst.get c with | GApp (r, [a]) when is_gr r glob_xO -> mult_2(bignat_of_pos a) | GApp (r, [a]) when is_gr r glob_xI -> add_1(mult_2(bignat_of_pos a)) - | GRef (a, _) when Globnames.eq_gr a glob_xH -> Bigint.one + | GRef (a, _) when GlobRef.equal a glob_xH -> Bigint.one | _ -> raise Non_closed_number (**********************************************************************) @@ -98,7 +98,7 @@ let z_of_int ?loc n = let bigint_of_z c = match DAst.get c with | GApp (r,[a]) when is_gr r glob_POS -> bignat_of_pos a | GApp (r,[a]) when is_gr r glob_NEG -> Bigint.neg (bignat_of_pos a) - | GRef (a, _) when Globnames.eq_gr a glob_ZERO -> Bigint.zero + | GRef (a, _) when GlobRef.equal a glob_ZERO -> Bigint.zero | _ -> raise Non_closed_number (**********************************************************************) diff --git a/plugins/syntax/string_syntax.ml b/plugins/syntax/string_syntax.ml index 2421cc12f..c22869f4d 100644 --- a/plugins/syntax/string_syntax.ml +++ b/plugins/syntax/string_syntax.ml @@ -8,6 +8,7 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) +open Names open Globnames open Ascii_syntax_plugin.Ascii_syntax open Glob_term @@ -34,7 +35,7 @@ let glob_String = lazy (make_reference "String") let glob_EmptyString = lazy (make_reference "EmptyString") let is_gr c gr = match DAst.get c with -| GRef (r, _) -> Globnames.eq_gr r gr +| GRef (r, _) -> GlobRef.equal r gr | _ -> false open Lazy @@ -55,7 +56,7 @@ let uninterp_string (AnyGlobConstr r) = (match uninterp_ascii a with | Some c -> Buffer.add_char b (Char.chr c); aux s | _ -> raise Non_closed_string) - | GRef (z,_) when eq_gr z (force glob_EmptyString) -> + | GRef (z,_) when GlobRef.equal z (force glob_EmptyString) -> Some (Buffer.contents b) | _ -> raise Non_closed_string diff --git a/plugins/syntax/z_syntax.ml b/plugins/syntax/z_syntax.ml index d5300e474..09fe8bf70 100644 --- a/plugins/syntax/z_syntax.ml +++ b/plugins/syntax/z_syntax.ml @@ -71,13 +71,13 @@ let interp_positive ?loc n = (**********************************************************************) let is_gr c gr = match DAst.get c with -| GRef (r, _) -> Globnames.eq_gr r gr +| GRef (r, _) -> GlobRef.equal r gr | _ -> false let rec bignat_of_pos x = DAst.with_val (function | GApp (r ,[a]) when is_gr r glob_xO -> mult_2(bignat_of_pos a) | GApp (r ,[a]) when is_gr r glob_xI -> add_1(mult_2(bignat_of_pos a)) - | GRef (a, _) when Globnames.eq_gr a glob_xH -> Bigint.one + | GRef (a, _) when GlobRef.equal a glob_xH -> Bigint.one | _ -> raise Non_closed_number ) x @@ -132,7 +132,7 @@ let n_of_int ?loc n = let bignat_of_n n = DAst.with_val (function | GApp (r, [a]) when is_gr r glob_Npos -> bignat_of_pos a - | GRef (a,_) when Globnames.eq_gr a glob_N0 -> Bigint.zero + | GRef (a,_) when GlobRef.equal a glob_N0 -> Bigint.zero | _ -> raise Non_closed_number ) n @@ -180,7 +180,7 @@ let z_of_int ?loc n = let bigint_of_z z = DAst.with_val (function | GApp (r, [a]) when is_gr r glob_POS -> bignat_of_pos a | GApp (r, [a]) when is_gr r glob_NEG -> Bigint.neg (bignat_of_pos a) - | GRef (a, _) when Globnames.eq_gr a glob_ZERO -> Bigint.zero + | GRef (a, _) when GlobRef.equal a glob_ZERO -> Bigint.zero | _ -> raise Non_closed_number ) z diff --git a/pretyping/arguments_renaming.ml b/pretyping/arguments_renaming.ml index 84295959f..9d4badc60 100644 --- a/pretyping/arguments_renaming.ml +++ b/pretyping/arguments_renaming.ml @@ -26,7 +26,7 @@ let name_table = type req = | ReqLocal - | ReqGlobal of global_reference * Name.t list + | ReqGlobal of GlobRef.t * Name.t list let load_rename_args _ (_, (_, (r, names))) = name_table := Refmap.add r names !name_table diff --git a/pretyping/arguments_renaming.mli b/pretyping/arguments_renaming.mli index 65e3c3be5..6a776dc96 100644 --- a/pretyping/arguments_renaming.mli +++ b/pretyping/arguments_renaming.mli @@ -9,14 +9,13 @@ (************************************************************************) open Names -open Globnames open Environ open Constr -val rename_arguments : bool -> global_reference -> Name.t list -> unit +val rename_arguments : bool -> GlobRef.t -> Name.t list -> unit (** [Not_found] is raised if no names are defined for [r] *) -val arguments_names : global_reference -> Name.t list +val arguments_names : GlobRef.t -> Name.t list val rename_type_of_constant : env -> pconstant -> types val rename_type_of_inductive : env -> pinductive -> types diff --git a/pretyping/cases.ml b/pretyping/cases.ml index 73be9d6b7..6e1d3e551 100644 --- a/pretyping/cases.ml +++ b/pretyping/cases.ml @@ -295,8 +295,11 @@ let inductive_template evdref env tmloc ind = | LocalAssum (na,ty) -> let ty = EConstr.of_constr ty in let ty' = substl subst ty in - let e = e_new_evar env evdref ~src:(hole_source n) ty' in - (e::subst,e::evarl,n+1) + let e = evd_comb1 + (Evarutil.new_evar env ~src:(hole_source n)) + evdref ty' + in + (e::subst,e::evarl,n+1) | LocalDef (na,b,ty) -> let b = EConstr.of_constr b in (substl subst b::subst,evarl,n+1)) @@ -314,13 +317,15 @@ let try_find_ind env sigma typ realnames = IsInd (typ,ind,names) let inh_coerce_to_ind evdref env loc ty tyi = - let sigma = !evdref in + let orig = !evdref in let expected_typ = inductive_template evdref env loc tyi in (* Try to refine the type with inductive information coming from the constructor and renounce if not able to give more information *) (* devrait être indifférent d'exiger leq ou pas puisque pour un inductif cela doit être égal *) - if not (e_cumul env evdref expected_typ ty) then evdref := sigma + match cumul env !evdref expected_typ ty with + | Some sigma -> evdref := sigma + | None -> evdref := orig let binding_vars_of_inductive sigma = function | NotInd _ -> [] @@ -372,8 +377,7 @@ let coerce_row typing_fun evdref env lvar pats (tomatch,(na,indopt)) = let loc = loc_of_glob_constr tomatch in let tycon,realnames = find_tomatch_tycon evdref env loc indopt in let j = typing_fun tycon env evdref !lvar tomatch in - let evd, j = Coercion.inh_coerce_to_base ?loc:(loc_of_glob_constr tomatch) env !evdref j in - evdref := evd; + let j = evd_comb1 (Coercion.inh_coerce_to_base ?loc:(loc_of_glob_constr tomatch) env) evdref j in let typ = nf_evar !evdref j.uj_type in lvar := make_return_predicate_ltac_lvar !evdref na tomatch j.uj_val !lvar; let t = @@ -396,12 +400,8 @@ let coerce_to_indtype typing_fun evdref env lvar matx tomatchl = (* Utils *) let mkExistential env ?(src=(Loc.tag Evar_kinds.InternalHole)) evdref = - let e, u = e_new_type_evar env evdref univ_flexible_alg ~src:src in e - -let evd_comb2 f evdref x y = - let (evd',y) = f !evdref x y in - evdref := evd'; - y + let (e, u) = evd_comb1 (new_type_evar env ~src:src) evdref univ_flexible_alg in + e let adjust_tomatch_to_pattern pb ((current,typ),deps,dep) = (* Ideally, we could find a common inductive type to which both the @@ -424,7 +424,7 @@ let adjust_tomatch_to_pattern pb ((current,typ),deps,dep) = let current = if List.is_empty deps && isEvar !(pb.evdref) typ then (* Don't insert coercions if dependent; only solve evars *) - let _ = e_cumul pb.env pb.evdref indt typ in + let () = Option.iter ((:=) pb.evdref) (cumul pb.env !(pb.evdref) indt typ) in current else (evd_comb2 (Coercion.inh_conv_coerce_to true pb.env) @@ -574,7 +574,7 @@ let dependent_decl sigma a = let rec dep_in_tomatch sigma n = function | (Pushed _ | Alias _ | NonDepAlias) :: l -> dep_in_tomatch sigma n l - | Abstract (_,d) :: l -> dependent_decl sigma (mkRel n) d || dep_in_tomatch sigma (n+1) l + | Abstract (_,d) :: l -> RelDecl.exists (fun c -> not (noccurn sigma n c)) d || dep_in_tomatch sigma (n+1) l | [] -> false let dependencies_in_rhs sigma nargs current tms eqns = @@ -1014,8 +1014,8 @@ let adjust_impossible_cases pb pred tomatch submat = begin match Constr.kind pred with | Evar (evk,_) when snd (evar_source evk !(pb.evdref)) == Evar_kinds.ImpossibleCase -> if not (Evd.is_defined !(pb.evdref) evk) then begin - let evd, default = use_unit_judge !(pb.evdref) in - pb.evdref := Evd.define evk (EConstr.Unsafe.to_constr default.uj_type) evd + let default = evd_comb0 use_unit_judge pb.evdref in + pb.evdref := Evd.define evk default.uj_type !(pb.evdref) end; add_assert_false_case pb tomatch | _ -> @@ -1427,6 +1427,7 @@ and match_current pb (initial,tomatch) = let case = make_case_or_project pb.env !(pb.evdref) indf ci pred current brvals in + let _ = Typing.e_type_of pb.env pb.evdref pred in Typing.check_allowed_sort pb.env !(pb.evdref) mind current pred; { uj_val = applist (case, inst); uj_type = prod_applist !(pb.evdref) typ inst } @@ -1681,7 +1682,7 @@ let abstract_tycon ?loc env evdref subst tycon extenv t = (fun i _ -> try list_assoc_in_triple i subst0 with Not_found -> mkRel i) 1 (rel_context env) in - let ev' = e_new_evar env evdref ~src ty in + let ev' = evd_comb1 (Evarutil.new_evar env ~src) evdref ty in begin match solve_simple_eqn (evar_conv_x full_transparent_state) env !evdref (None,ev,substl inst ev') with | Success evd -> evdref := evd | UnifFailure _ -> assert false @@ -1704,15 +1705,17 @@ let abstract_tycon ?loc env evdref subst tycon extenv t = List.map_i (fun i _ -> if Int.List.mem i vl then u else mkRel i) 1 (rel_context extenv) in - let rel_filter = - List.map (fun a -> not (isRel !evdref a) || dependent !evdref a u - || Int.Set.mem (destRel !evdref a) depvl) inst in + let map a = match EConstr.kind !evdref a with + | Rel n -> not (noccurn !evdref n u) || Int.Set.mem n depvl + | _ -> true + in + let rel_filter = List.map map inst in let named_filter = List.map (fun d -> local_occur_var !evdref (NamedDecl.get_id d) u) (named_context extenv) in let filter = Filter.make (rel_filter @ named_filter) in let candidates = u :: List.map mkRel vl in - let ev = e_new_evar extenv evdref ~src ~filter ~candidates ty in + let ev = evd_comb1 (Evarutil.new_evar extenv ~src ~filter ~candidates) evdref ty in lift k ev in aux (0,extenv,subst0) t0 @@ -1724,17 +1727,20 @@ let build_tycon ?loc env tycon_env s subst tycon extenv evdref t = we are in an impossible branch *) let n = Context.Rel.length (rel_context env) in let n' = Context.Rel.length (rel_context tycon_env) in - let impossible_case_type, u = - e_new_type_evar (reset_context env) evdref univ_flexible_alg ~src:(Loc.tag ?loc Evar_kinds.ImpossibleCase) in - (lift (n'-n) impossible_case_type, mkSort u) + let impossible_case_type, u = + evd_comb1 + (new_type_evar (reset_context env) ~src:(Loc.tag ?loc Evar_kinds.ImpossibleCase)) + evdref univ_flexible_alg + in + (lift (n'-n) impossible_case_type, mkSort u) | Some t -> let t = abstract_tycon ?loc tycon_env evdref subst tycon extenv t in - let evd,tt = Typing.type_of extenv !evdref t in - evdref := evd; + let tt = evd_comb1 (Typing.type_of extenv) evdref t in (t,tt) in - let b = e_cumul env evdref tt (mkSort s) (* side effect *) in - if not b then anomaly (Pp.str "Build_tycon: should be a type."); - { uj_val = t; uj_type = tt } + match cumul env !evdref tt (mkSort s) with + | None -> anomaly (Pp.str "Build_tycon: should be a type."); + | Some sigma -> evdref := sigma; + { uj_val = t; uj_type = tt } (* For a multiple pattern-matching problem Xi on t1..tn with return * type T, [build_inversion_problem Gamma Sigma (t1..tn) T] builds a return @@ -1845,7 +1851,7 @@ let build_inversion_problem loc env sigma tms t = (* [pb] is the auxiliary pattern-matching serving as skeleton for the return type of the original problem Xi *) let s' = Retyping.get_sort_of env sigma t in - let sigma, s = Evd.new_sort_variable univ_flexible_alg sigma in + let sigma, s = Evd.new_sort_variable univ_flexible sigma in let sigma = Evd.set_leq_sort env sigma s' s in let evdref = ref sigma in let pb = @@ -1923,9 +1929,7 @@ let extract_arity_signature ?(dolift=true) env0 lvar tomatchl tmsign = let inh_conv_coerce_to_tycon ?loc env evdref j tycon = match tycon with | Some p -> - let (evd',j) = Coercion.inh_conv_coerce_to ?loc true env !evdref j p in - evdref := evd'; - j + evd_comb2 (Coercion.inh_conv_coerce_to ?loc true env) evdref j p | None -> j (* We put the tycon inside the arity signature, possibly discovering dependencies. *) @@ -1936,8 +1940,8 @@ let prepare_predicate_from_arsign_tycon env sigma loc tomatchs arsign c = List.fold_right2 (fun (tm, tmtype) sign (subst, len) -> let signlen = List.length sign in match EConstr.kind sigma tm with - | Rel n when dependent sigma tm c - && Int.equal signlen 1 (* The term to match is not of a dependent type itself *) -> + | Rel n when Int.equal signlen 1 && not (noccurn sigma n c) + (* The term to match is not of a dependent type itself *) -> ((n, len) :: subst, len - signlen) | Rel n when signlen > 1 (* The term is of a dependent type, maybe some variable in its type appears in the tycon. *) -> @@ -1948,13 +1952,13 @@ let prepare_predicate_from_arsign_tycon env sigma loc tomatchs arsign c = List.fold_left (fun (subst, len) arg -> match EConstr.kind sigma arg with - | Rel n when dependent sigma arg c -> + | Rel n when not (noccurn sigma n c) -> ((n, len) :: subst, pred len) | _ -> (subst, pred len)) (subst, len) realargs in let subst = - if dependent sigma tm c && List.for_all (isRel sigma) realargs + if not (noccurn sigma n c) && List.for_all (isRel sigma) realargs then (n, len) :: subst else subst in (subst, pred len)) | _ -> (subst, len - signlen)) @@ -2100,7 +2104,7 @@ let mk_JMeq_refl evdref typ x = let hole na = DAst.make @@ GHole (Evar_kinds.QuestionMark (Evar_kinds.Define false,na), - Misctypes.IntroAnonymous, None) + IntroAnonymous, None) let constr_of_pat env evdref arsign pat avoid = let rec typ env (ty, realargs) pat avoid = @@ -2581,7 +2585,8 @@ let compile_program_cases ?loc style (typing_function, evdref) tycon env lvar let body = it_mkLambda_or_LetIn (applist (j.uj_val, args)) lets in let j = { uj_val = it_mkLambda_or_LetIn body tomatchs_lets; - uj_type = EConstr.of_constr (EConstr.to_constr !evdref tycon); } + (* XXX: is this normalization needed? *) + uj_type = Evarutil.nf_evar !evdref tycon; } in j (**************************************************************************) diff --git a/pretyping/cbv.ml b/pretyping/cbv.ml index a2155697e..cb0fc3257 100644 --- a/pretyping/cbv.ml +++ b/pretyping/cbv.ml @@ -71,7 +71,7 @@ and cbv_stack = | TOP | APP of cbv_value array * cbv_stack | CASE of constr * constr array * case_info * cbv_value subs * cbv_stack - | PROJ of projection * Declarations.projection_body * cbv_stack + | PROJ of Projection.t * Declarations.projection_body * cbv_stack (* les vars pourraient etre des constr, cela permet de retarder les lift: utile ?? *) diff --git a/pretyping/cbv.mli b/pretyping/cbv.mli index 2ac59911c..cdaa39c53 100644 --- a/pretyping/cbv.mli +++ b/pretyping/cbv.mli @@ -41,7 +41,7 @@ and cbv_stack = | TOP | APP of cbv_value array * cbv_stack | CASE of constr * constr array * case_info * cbv_value subs * cbv_stack - | PROJ of projection * Declarations.projection_body * cbv_stack + | PROJ of Projection.t * Declarations.projection_body * cbv_stack val shift_value : int -> cbv_value -> cbv_value diff --git a/pretyping/classops.ml b/pretyping/classops.ml index a0804b72b..7dbef01c2 100644 --- a/pretyping/classops.ml +++ b/pretyping/classops.ml @@ -37,7 +37,7 @@ type cl_info_typ = { cl_param : int } -type coe_typ = global_reference +type coe_typ = GlobRef.t module CoeTypMap = Refmap_env @@ -316,7 +316,7 @@ let lookup_pattern_path_between env (s,t) = let coercion_value { coe_value = c; coe_type = t; coe_context = ctx; coe_is_identity = b; coe_is_projection = b' } = - let subst, ctx = Universes.fresh_universe_context_set_instance ctx in + let subst, ctx = UnivGen.fresh_universe_context_set_instance ctx in let c' = Vars.subst_univs_level_constr subst c and t' = Vars.subst_univs_level_constr subst t in (make_judge (EConstr.of_constr c') (EConstr.of_constr t'), b, b'), ctx @@ -440,7 +440,7 @@ let cache_coercion env sigma (_, c) = let () = add_class c.coercion_target in let is, _ = class_info c.coercion_source in let it, _ = class_info c.coercion_target in - let value, ctx = Universes.fresh_global_instance env c.coercion_type in + let value, ctx = UnivGen.fresh_global_instance env c.coercion_type in let typ = Retyping.get_type_of env sigma (EConstr.of_constr value) in let typ = EConstr.Unsafe.to_constr typ in let xf = diff --git a/pretyping/classops.mli b/pretyping/classops.mli index f8600bbe0..35691ea37 100644 --- a/pretyping/classops.mli +++ b/pretyping/classops.mli @@ -36,7 +36,7 @@ type cl_info_typ = { cl_param : int } (** This is the type of coercion kinds *) -type coe_typ = Globnames.global_reference +type coe_typ = GlobRef.t (** This is the type of infos for declared coercions *) type coe_info_typ diff --git a/pretyping/coercion.ml b/pretyping/coercion.ml index 04cb6a59f..bf9e37aa7 100644 --- a/pretyping/coercion.ml +++ b/pretyping/coercion.ml @@ -20,6 +20,7 @@ open CErrors open Util open Names open Term +open Constr open Environ open EConstr open Vars @@ -48,31 +49,35 @@ exception NoCoercion exception NoCoercionNoUnifier of evar_map * unification_error (* Here, funj is a coercion therefore already typed in global context *) -let apply_coercion_args env evd check isproj argl funj = - let evdref = ref evd in - let rec apply_rec acc typ = function +let apply_coercion_args env sigma check isproj argl funj = + let rec apply_rec sigma acc typ = function | [] -> if isproj then - let cst = fst (destConst !evdref (j_val funj)) in + let cst = fst (destConst sigma (j_val funj)) in let p = Projection.make cst false in let pb = lookup_projection p env in let args = List.skipn pb.Declarations.proj_npars argl in let hd, tl = match args with hd :: tl -> hd, tl | [] -> assert false in - { uj_val = applist (mkProj (p, hd), tl); - uj_type = typ } + sigma, { uj_val = applist (mkProj (p, hd), tl); + uj_type = typ } else - { uj_val = applist (j_val funj,argl); - uj_type = typ } + sigma, { uj_val = applist (j_val funj,argl); + uj_type = typ } | h::restl -> (* On devrait pouvoir s'arranger pour qu'on n'ait pas a faire hnf_constr *) - match EConstr.kind !evdref (whd_all env !evdref typ) with + match EConstr.kind sigma (whd_all env sigma typ) with | Prod (_,c1,c2) -> - if check && not (e_cumul env evdref (Retyping.get_type_of env !evdref h) c1) then - raise NoCoercion; - apply_rec (h::acc) (subst1 h c2) restl + let sigma = + if check then + begin match cumul env sigma (Retyping.get_type_of env sigma h) c1 with + | None -> raise NoCoercion + | Some sigma -> sigma + end + else sigma + in + apply_rec sigma (h::acc) (subst1 h c2) restl | _ -> anomaly (Pp.str "apply_coercion_args.") in - let res = apply_rec [] funj.uj_type argl in - !evdref, res + apply_rec sigma [] funj.uj_type argl (* appliquer le chemin de coercions de patterns p *) let apply_pattern_coercion ?loc pat p = @@ -94,7 +99,9 @@ open Program let make_existential ?loc ?(opaque = not (get_proofs_transparency ())) na env evdref c = let src = Loc.tag ?loc (Evar_kinds.QuestionMark (Evar_kinds.Define opaque,na)) in - Evarutil.e_new_evar env evdref ~src c + let evd, v = Evarutil.new_evar env !evdref ~src c in + evdref := evd; + v let app_opt env evdref f t = whd_betaiota !evdref (app_opt f t) @@ -191,7 +198,8 @@ and coerce ?loc env evdref (x : EConstr.constr) (y : EConstr.constr) (subst1 hdy restT') (succ i) (fun x -> eq_app (co x)) else Some (fun x -> let term = co x in - Typing.e_solve_evars env evdref term) + let sigma, term = Typing.solve_evars env !evdref term in + evdref := sigma; term) in if isEvar !evdref c || isEvar !evdref c' || not (Program.is_program_generalized_coercion ()) then (* Second-order unification needed. *) @@ -251,7 +259,7 @@ and coerce ?loc env evdref (x : EConstr.constr) (y : EConstr.constr) let (n, dom, rng) = destLambda !evdref t in if isEvar !evdref dom then let (domk, args) = destEvar !evdref dom in - evdref := define domk (EConstr.Unsafe.to_constr a) !evdref; + evdref := define domk a !evdref; else (); t, rng | _ -> raise NoSubtacCoercion @@ -337,8 +345,9 @@ let app_coercion env evdref coercion v = match coercion with | None -> v | Some f -> - let v' = Typing.e_solve_evars env evdref (f v) in - whd_betaiota !evdref v' + let sigma, v' = Typing.solve_evars env !evdref (f v) in + evdref := sigma; + whd_betaiota !evdref v' let coerce_itf ?loc env evd v t c1 = let evdref = ref evd in diff --git a/pretyping/constr_matching.ml b/pretyping/constr_matching.ml index 89d490a41..2bc603a90 100644 --- a/pretyping/constr_matching.ml +++ b/pretyping/constr_matching.ml @@ -13,6 +13,7 @@ open Pp open CErrors open Util open Names +open Constr open Globnames open Termops open Term @@ -20,7 +21,6 @@ open EConstr open Vars open Pattern open Patternops -open Misctypes open Context.Rel.Declaration open Ltac_pretype (*i*) @@ -59,7 +59,7 @@ let warn_meta_collision = strbrk " and a metavariable of same name.") -let constrain sigma n (ids, m) (names, terms as subst) = +let constrain sigma n (ids, m) ((names,seen as names_seen), terms as subst) = let open EConstr in try let (ids', m') = Id.Map.find n terms in @@ -67,19 +67,21 @@ let constrain sigma n (ids, m) (names, terms as subst) = else raise PatternMatchingFailure with Not_found -> let () = if Id.Map.mem n names then warn_meta_collision n in - (names, Id.Map.add n (ids, m) terms) + (names_seen, Id.Map.add n (ids, m) terms) -let add_binders na1 na2 binding_vars (names, terms as subst) = +let add_binders na1 na2 binding_vars ((names,seen), terms as subst) = match na1, na2 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 - (names, terms) + subst else + let id2 = Namegen.next_ident_away id2 seen in let names = Id.Map.add id1 id2 names in + let seen = Id.Set.add id2 seen in let () = if Id.Map.mem id1 terms then warn_meta_collision id1 in - (names, terms) + ((names,seen), terms) | _ -> subst let rec build_lambda sigma vars ctx m = match vars with @@ -277,6 +279,7 @@ let matches_core env sigma allow_bound_rels | PSort ps, Sort s -> + let open Glob_term in begin match ps, ESorts.kind sigma s with | GProp, Prop Null -> subst | GSet, Prop Pos -> subst @@ -412,13 +415,15 @@ let matches_core env sigma allow_bound_rels | PFix _ | PCoFix _| PEvar _), _ -> raise PatternMatchingFailure in - sorec [] env (Id.Map.empty, Id.Map.empty) pat c + sorec [] env ((Id.Map.empty,Id.Set.empty), Id.Map.empty) pat c let matches_core_closed env sigma pat c = let names, subst = matches_core env sigma false pat c in - (names, Id.Map.map snd subst) + (fst names, Id.Map.map snd subst) -let extended_matches env sigma = matches_core env sigma true +let extended_matches env sigma pat c = + let (names,_), subst = matches_core env sigma true pat c in + names, subst let matches env sigma pat c = snd (matches_core_closed env sigma (Id.Set.empty,pat) c) @@ -427,7 +432,7 @@ let special_meta = (-1) type matching_result = { m_sub : bound_ident_map * patvar_map; - m_ctx : constr; } + m_ctx : constr Lazy.t; } let mkresult s c n = IStream.Cons ( { m_sub=s; m_ctx=c; } , (IStream.thunk n) ) @@ -451,7 +456,7 @@ let authorized_occ env sigma closed pat c mk_ctx = let subst = matches_core_closed env sigma pat c in if closed && Id.Map.exists (fun _ c -> not (closed0 sigma c)) (snd subst) then (fun next -> next ()) - else (fun next -> mkresult subst (mk_ctx (mkMeta special_meta)) next) + else (fun next -> mkresult subst (lazy (mk_ctx (mkMeta special_meta))) next) with PatternMatchingFailure -> (fun next -> next ()) let subargs env v = Array.map_to_list (fun c -> (env, c)) v diff --git a/pretyping/constr_matching.mli b/pretyping/constr_matching.mli index 3c2c73915..d19789ef4 100644 --- a/pretyping/constr_matching.mli +++ b/pretyping/constr_matching.mli @@ -61,7 +61,7 @@ val is_matching_head : env -> Evd.evar_map -> constr_pattern -> constr -> bool (whose hole is denoted here with [special_meta]) *) type matching_result = { m_sub : bound_ident_map * patvar_map; - m_ctx : EConstr.t } + m_ctx : EConstr.t Lazy.t } (** [match_subterm pat c] returns the substitution and the context corresponding to each **closed** subterm of [c] matching [pat], diff --git a/pretyping/detyping.ml b/pretyping/detyping.ml index bb563220b..df89d9eac 100644 --- a/pretyping/detyping.ml +++ b/pretyping/detyping.ml @@ -14,6 +14,7 @@ open Pp open CErrors open Util open Names +open Constr open Term open EConstr open Vars @@ -26,7 +27,6 @@ open Libnames open Globnames open Nametab open Mod_subst -open Misctypes open Decl_kinds open Context.Named.Declaration open Ltac_pretype @@ -36,7 +36,7 @@ type _ delay = | Later : [ `thunk ] delay (** Should we keep details of universes during detyping ? *) -let print_universes = Flags.univ_print +let print_universes = ref false (** If true, prints local context of evars, whatever print_arguments *) let print_evar_arguments = ref false @@ -920,7 +920,7 @@ let rec subst_cases_pattern subst = DAst.map (function | PatVar _ as pat -> pat | PatCstr (((kn,i),j),cpl,n) as pat -> let kn' = subst_mind subst kn - and cpl' = List.smartmap (subst_cases_pattern subst) cpl in + and cpl' = List.Smart.map (subst_cases_pattern subst) cpl in if kn' == kn && cpl' == cpl then pat else PatCstr (((kn',i),j),cpl',n) ) @@ -929,9 +929,11 @@ let (f_subst_genarg, subst_genarg_hook) = Hook.make () let rec subst_glob_constr subst = DAst.map (function | GRef (ref,u) as raw -> - let ref',t = subst_global subst ref in - if ref' == ref then raw else - DAst.get (detype Now false Id.Set.empty (Global.env()) Evd.empty (EConstr.of_constr t)) + let ref',t = subst_global subst ref in + if ref' == ref then raw else + let env = Global.env () in + let evd = Evd.from_env env in + DAst.get (detype Now false Id.Set.empty env evd (EConstr.of_constr t)) | GSort _ | GVar _ @@ -940,7 +942,7 @@ let rec subst_glob_constr subst = DAst.map (function | GApp (r,rl) as raw -> let r' = subst_glob_constr subst r - and rl' = List.smartmap (subst_glob_constr subst) rl in + and rl' = List.Smart.map (subst_glob_constr subst) rl in if r' == r && rl' == rl then raw else GApp(r',rl') @@ -957,25 +959,25 @@ let rec subst_glob_constr subst = DAst.map (function | GLetIn (n,r1,t,r2) as raw -> let r1' = subst_glob_constr subst r1 in let r2' = subst_glob_constr subst r2 in - let t' = Option.smartmap (subst_glob_constr subst) t in + let t' = Option.Smart.map (subst_glob_constr subst) t in if r1' == r1 && t == t' && r2' == r2 then raw else GLetIn (n,r1',t',r2') | GCases (sty,rtno,rl,branches) as raw -> let open CAst in - let rtno' = Option.smartmap (subst_glob_constr subst) rtno - and rl' = List.smartmap (fun (a,x as y) -> + let rtno' = Option.Smart.map (subst_glob_constr subst) rtno + and rl' = List.Smart.map (fun (a,x as y) -> let a' = subst_glob_constr subst a in let (n,topt) = x in - let topt' = Option.smartmap + let topt' = Option.Smart.map (fun ({loc;v=((sp,i),y)} as t) -> let sp' = subst_mind subst sp in if sp == sp' then t else CAst.(make ?loc ((sp',i),y))) topt in if a == a' && topt == topt' then y else (a',(n,topt'))) rl - and branches' = List.smartmap + and branches' = List.Smart.map (fun ({loc;v=(idl,cpl,r)} as branch) -> let cpl' = - List.smartmap (subst_cases_pattern subst) cpl + List.Smart.map (subst_cases_pattern subst) cpl and r' = subst_glob_constr subst r in if cpl' == cpl && r' == r then branch else CAst.(make ?loc (idl,cpl',r'))) @@ -985,14 +987,14 @@ let rec subst_glob_constr subst = DAst.map (function GCases (sty,rtno',rl',branches') | GLetTuple (nal,(na,po),b,c) as raw -> - let po' = Option.smartmap (subst_glob_constr subst) po + let po' = Option.Smart.map (subst_glob_constr subst) po and b' = subst_glob_constr subst b and c' = subst_glob_constr subst c in if po' == po && b' == b && c' == c then raw else GLetTuple (nal,(na,po'),b',c') | GIf (c,(na,po),b1,b2) as raw -> - let po' = Option.smartmap (subst_glob_constr subst) po + let po' = Option.Smart.map (subst_glob_constr subst) po and b1' = subst_glob_constr subst b1 and b2' = subst_glob_constr subst b2 and c' = subst_glob_constr subst c in @@ -1000,12 +1002,12 @@ let rec subst_glob_constr subst = DAst.map (function GIf (c',(na,po'),b1',b2') | GRec (fix,ida,bl,ra1,ra2) as raw -> - let ra1' = Array.smartmap (subst_glob_constr subst) ra1 - and ra2' = Array.smartmap (subst_glob_constr subst) ra2 in - let bl' = Array.smartmap - (List.smartmap (fun (na,k,obd,ty as dcl) -> + let ra1' = Array.Smart.map (subst_glob_constr subst) ra1 + and ra2' = Array.Smart.map (subst_glob_constr subst) ra2 in + let bl' = Array.Smart.map + (List.Smart.map (fun (na,k,obd,ty as dcl) -> let ty' = subst_glob_constr subst ty in - let obd' = Option.smartmap (subst_glob_constr subst) obd in + let obd' = Option.Smart.map (subst_glob_constr subst) obd in if ty'==ty && obd'==obd then dcl else (na,k,obd',ty'))) bl in if ra1' == ra1 && ra2' == ra2 && bl'==bl then raw else @@ -1018,13 +1020,13 @@ let rec subst_glob_constr subst = DAst.map (function if nref == ref then knd else Evar_kinds.ImplicitArg (nref, i, b) | _ -> knd in - let nsolve = Option.smartmap (Hook.get f_subst_genarg subst) solve in + let nsolve = Option.Smart.map (Hook.get f_subst_genarg subst) solve in if nsolve == solve && nknd == knd then raw else GHole (nknd, naming, nsolve) | GCast (r1,k) as raw -> let r1' = subst_glob_constr subst r1 in - let k' = Miscops.smartmap_cast_type (subst_glob_constr subst) k in + let k' = smartmap_cast_type (subst_glob_constr subst) k in if r1' == r1 && k' == k then raw else GCast (r1',k') | GProj (p,c) as raw -> diff --git a/pretyping/detyping.mli b/pretyping/detyping.mli index 817b8ba6e..5310455fe 100644 --- a/pretyping/detyping.mli +++ b/pretyping/detyping.mli @@ -14,7 +14,6 @@ open EConstr open Glob_term open Termops open Mod_subst -open Misctypes open Evd open Ltac_pretype diff --git a/pretyping/evarconv.ml b/pretyping/evarconv.ml index d37090a65..6d08f66c1 100644 --- a/pretyping/evarconv.ml +++ b/pretyping/evarconv.ml @@ -49,7 +49,7 @@ let _ = Goptions.declare_bool_option { (* XXX: we would like to search for this with late binding "data.id.type" etc... *) let impossible_default_case () = - let c, ctx = Universes.fresh_global_instance (Global.env()) (Globnames.ConstRef Coqlib.id) in + let c, ctx = UnivGen.fresh_global_instance (Global.env()) (Globnames.ConstRef Coqlib.id) in let (_, u) = Constr.destConst c in Some (c, Constr.mkConstU (Coqlib.type_of_id, u), ctx) @@ -114,9 +114,6 @@ let flex_kind_of_term ts env evd c sk = | Fix _ -> Rigid (* happens when the fixpoint is partially applied *) | Cast _ | App _ | Case _ -> assert false -let add_conv_pb (pb, env, x, y) sigma = - Evd.add_conv_pb (pb, env, EConstr.Unsafe.to_constr x, EConstr.Unsafe.to_constr y) sigma - let apprec_nohdbeta ts env evd c = let (t,sk as appr) = Reductionops.whd_nored_state evd (c, []) in if Stack.not_purely_applicative sk @@ -213,7 +210,7 @@ let check_conv_record env sigma (t1,sk1) (t2,sk2) = else match (Stack.strip_n_app (l_us-1) sk2_effective) with | None -> raise Not_found | Some (l',el,s') -> (l'@Stack.append_app [|el|] Stack.empty,s') in - let u, ctx' = Universes.fresh_instance_from ctx None in + let u, ctx' = UnivGen.fresh_instance_from ctx None in let subst = Univ.make_inverse_instance_subst u in let c = EConstr.of_constr c in let c' = subst_univs_level_constr subst c in @@ -369,13 +366,10 @@ let rec evar_conv_x ts env evd pbty term1 term2 = let ground_test = if is_ground_term evd term1 && is_ground_term evd term2 then ( let e = - try - let evd, b = infer_conv ~catch_incon:false ~pb:pbty ~ts:(fst ts) - env evd term1 term2 - in - if b then Success evd - else UnifFailure (evd, ConversionFailed (env,term1,term2)) - with Univ.UniverseInconsistency e -> UnifFailure (evd, UnifUnivInconsistency e) + match infer_conv ~catch_incon:false ~pb:pbty ~ts:(fst ts) env evd term1 term2 with + | Some evd -> Success evd + | None -> UnifFailure (evd, ConversionFailed (env,term1,term2)) + | exception Univ.UniverseInconsistency e -> UnifFailure (evd, UnifUnivInconsistency e) in match e with | UnifFailure (evd, e) when not (is_ground_env evd env) -> None @@ -1045,7 +1039,7 @@ let choose_less_dependent_instance evk evd term args = let subst' = List.filter (fun (id,c) -> EConstr.eq_constr evd c term) subst in match subst' with | [] -> None - | (id, _) :: _ -> Some (Evd.define evk (Constr.mkVar id) evd) + | (id, _) :: _ -> Some (Evd.define evk (mkVar id) evd) let apply_on_subterm env evdref f c t = let rec applyrec (env,(k,c) as acc) t = @@ -1085,7 +1079,7 @@ let filter_possible_projections evd c ty ctxt args = let a = Array.unsafe_get args i in (match decl with | NamedDecl.LocalAssum _ -> false - | NamedDecl.LocalDef (_,c,_) -> not (isRel evd (EConstr.of_constr c) || isVar evd (EConstr.of_constr c))) || + | NamedDecl.LocalDef (_,c,_) -> not (isRel evd c || isVar evd c)) || a == c || (* Here we make an approximation, for instance, we could also be *) (* interested in finding a term u convertible to c such that a occurs *) @@ -1135,7 +1129,7 @@ let second_order_matching ts env_rhs evd (evk,args) argoccs rhs = end | decl'::ctxt', c::l, occs::occsl -> let id = NamedDecl.get_id decl' in - let t = EConstr.of_constr (NamedDecl.get_type decl') in + let t = NamedDecl.get_type decl' in let evs = ref [] in let ty = Retyping.get_type_of env_rhs evd c in let filter' = filter_possible_projections evd c ty ctxt args in @@ -1162,17 +1156,18 @@ let second_order_matching ts env_rhs evd (evk,args) argoccs rhs = let subst = make_subst (ctxt,Array.to_list args,argoccs) in - let evdref = ref evd in - let rhs = set_holes evdref rhs subst in - let evd = !evdref in + let evd, rhs = + let evdref = ref evd in + let rhs = set_holes evdref rhs subst in + !evdref, rhs + in (* We instantiate the evars of which the value is forced by typing *) let evd,rhs = - let evdref = ref evd in - try let c = !solve_evars env_evar evdref rhs in !evdref,c + try !solve_evars env_evar evd rhs with e when Pretype_errors.precatchable_exception e -> (* Could not revert all subterms *) - raise (TypingFailed !evdref) in + raise (TypingFailed evd) in let rec abstract_free_holes evd = function | (id,idty,c,_,evsref,_,_)::l -> @@ -1183,7 +1178,7 @@ let second_order_matching ts env_rhs evd (evk,args) argoccs rhs = (* We force abstraction over this unconstrained occurrence *) (* and we use typing to propagate this instantiation *) (* This is an arbitrary choice *) - let evd = Evd.define evk (Constr.mkVar id) evd in + let evd = Evd.define evk (mkVar id) evd in match evar_conv_x ts env_evar evd CUMUL idty evty with | UnifFailure _ -> user_err Pp.(str "Cannot find an instance") | Success evd -> @@ -1205,14 +1200,11 @@ let second_order_matching ts env_rhs evd (evk,args) argoccs rhs = (evar_conv_x full_transparent_state) with IllTypedInstance _ -> raise (TypingFailed evd) in - Evd.define evk (EConstr.Unsafe.to_constr rhs) evd + Evd.define evk rhs evd in abstract_free_holes evd subst, true with TypingFailed evd -> evd, false -let to_pb (pb, env, t1, t2) = - (pb, env, EConstr.Unsafe.to_constr t1, EConstr.Unsafe.to_constr t2) - let second_order_matching_with_args ts env evd pbty ev l t = (* let evd,ev = evar_absorb_arguments env evd ev l in @@ -1222,7 +1214,7 @@ let second_order_matching_with_args ts env evd pbty ev l t = else UnifFailure (evd, ConversionFailed (env,mkApp(mkEvar ev,l),t)) if b then Success evd else *) - let pb = to_pb (pbty,env,mkApp(mkEvar ev,l),t) in + let pb = (pbty,env,mkApp(mkEvar ev,l),t) in UnifFailure (evd, CannotSolveConstraint (pb,ProblemBeyondCapabilities)) let apply_conversion_problem_heuristic ts env evd pbty t1 t2 = @@ -1245,7 +1237,7 @@ let apply_conversion_problem_heuristic ts env evd pbty t1 t2 = | Some evd -> Success evd | None -> let reason = ProblemBeyondCapabilities in - UnifFailure (evd, CannotSolveConstraint (to_pb (pbty,env,t1,t2),reason))) + UnifFailure (evd, CannotSolveConstraint ((pbty,env,t1,t2),reason))) | (Rel _|Var _), Evar (evk2,args2) when app_empty && List.for_all (fun a -> EConstr.eq_constr evd a term1 || isEvar evd a) (remove_instance_local_defs evd evk2 args2) -> @@ -1255,7 +1247,7 @@ let apply_conversion_problem_heuristic ts env evd pbty t1 t2 = | Some evd -> Success evd | None -> let reason = ProblemBeyondCapabilities in - UnifFailure (evd, CannotSolveConstraint (to_pb (pbty,env,t1,t2),reason))) + UnifFailure (evd, CannotSolveConstraint ((pbty,env,t1,t2),reason))) | Evar (evk1,args1), Evar (evk2,args2) when Evar.equal evk1 evk2 -> let f env evd pbty x y = is_fconv ~reds:ts pbty env evd x y in Success (solve_refl ~can_drop:true f env evd @@ -1295,10 +1287,10 @@ let error_cannot_unify env evd pb ?reason t1 t2 = let check_problems_are_solved env evd = match snd (extract_all_conv_pbs evd) with - | (pbty,env,t1,t2) as pb::_ -> error_cannot_unify env evd pb (EConstr.of_constr t1) (EConstr.of_constr t2) + | (pbty,env,t1,t2) as pb::_ -> error_cannot_unify env evd pb t1 t2 | _ -> () -exception MaxUndefined of (Evar.t * evar_info * Constr.t list) +exception MaxUndefined of (Evar.t * evar_info * EConstr.t list) let max_undefined_with_candidates evd = let fold evk evi () = match evi.evar_candidates with @@ -1326,7 +1318,7 @@ let rec solve_unconstrained_evars_with_candidates ts evd = | a::l -> try let conv_algo = evar_conv_x ts in - let evd = check_evar_instance evd evk (EConstr.of_constr a) conv_algo in + let evd = check_evar_instance evd evk a conv_algo in let evd = Evd.define evk a evd in match reconsider_unif_constraints conv_algo evd with | Success evd -> solve_unconstrained_evars_with_candidates ts evd @@ -1348,7 +1340,7 @@ let solve_unconstrained_impossible_cases env evd = let ty = j_type j in let conv_algo = evar_conv_x full_transparent_state in let evd' = check_evar_instance evd' evk ty conv_algo in - Evd.define evk (EConstr.Unsafe.to_constr ty) evd' + Evd.define evk ty evd' | _ -> evd') evd evd let solve_unif_constraints_with_heuristics env @@ -1357,8 +1349,6 @@ let solve_unif_constraints_with_heuristics env let rec aux evd pbs progress stuck = match pbs with | (pbty,env,t1,t2 as pb) :: pbs -> - let t1 = EConstr.of_constr t1 in - let t2 = EConstr.of_constr t2 in (match apply_conversion_problem_heuristic ts env evd pbty t1 t2 with | Success evd' -> let (evd', rest) = extract_all_conv_pbs evd' in @@ -1375,9 +1365,7 @@ let solve_unif_constraints_with_heuristics env match stuck with | [] -> (* We're finished *) evd | (pbty,env,t1,t2 as pb) :: _ -> - let t1 = EConstr.of_constr t1 in - let t2 = EConstr.of_constr t2 in - (* There remains stuck problems *) + (* There remains stuck problems *) error_cannot_unify env evd pb t1 t2 in let (evd,pbs) = extract_all_conv_pbs evd in @@ -1404,6 +1392,16 @@ let the_conv_x_leq env ?(ts=default_transparent_state env) t1 t2 evd = | Success evd' -> evd' | UnifFailure (evd',e) -> raise (UnableToUnify (evd',e)) +let make_opt = function + | Success evd -> Some evd + | UnifFailure _ -> None + +let conv env ?(ts=default_transparent_state env) evd t1 t2 = + make_opt(evar_conv_x ts env evd CONV t1 t2) + +let cumul env ?(ts=default_transparent_state env) evd t1 t2 = + make_opt(evar_conv_x ts env evd CUMUL t1 t2) + let e_conv env ?(ts=default_transparent_state env) evdref t1 t2 = match evar_conv_x ts env !evdref CONV t1 t2 with | Success evd' -> evdref := evd'; true diff --git a/pretyping/evarconv.mli b/pretyping/evarconv.mli index 627430708..cdf5dd0e5 100644 --- a/pretyping/evarconv.mli +++ b/pretyping/evarconv.mli @@ -28,7 +28,13 @@ val the_conv_x_leq : env -> ?ts:transparent_state -> constr -> constr -> evar_ma (** The same function resolving evars by side-effect and catching the exception *) val e_conv : env -> ?ts:transparent_state -> evar_map ref -> constr -> constr -> bool +[@@ocaml.deprecated "Use [Evarconv.conv]"] + val e_cumul : env -> ?ts:transparent_state -> evar_map ref -> constr -> constr -> bool +[@@ocaml.deprecated "Use [Evarconv.cumul]"] + +val conv : env -> ?ts:transparent_state -> evar_map -> constr -> constr -> evar_map option +val cumul : env -> ?ts:transparent_state -> evar_map -> constr -> constr -> evar_map option (** {6 Unification heuristics. } *) @@ -38,7 +44,7 @@ val e_cumul : env -> ?ts:transparent_state -> evar_map ref -> constr -> constr - val solve_unif_constraints_with_heuristics : env -> ?ts:transparent_state -> evar_map -> evar_map val consider_remaining_unif_problems : env -> ?ts:transparent_state -> evar_map -> evar_map -(** @deprecated Alias for [solve_unif_constraints_with_heuristics] *) +[@@ocaml.deprecated "Alias for [solve_unif_constraints_with_heuristics]"] (** Check all pending unification problems are solved and raise an error otherwise *) @@ -63,7 +69,7 @@ val second_order_matching : transparent_state -> env -> evar_map -> (** Declare function to enforce evars resolution by using typing constraints *) -val set_solve_evars : (env -> evar_map ref -> constr -> constr) -> unit +val set_solve_evars : (env -> evar_map -> constr -> evar_map * constr) -> unit type unify_fun = transparent_state -> env -> evar_map -> conv_pb -> constr -> constr -> Evarsolve.unification_result diff --git a/pretyping/evardefine.ml b/pretyping/evardefine.ml index 4cffbbb83..b452755b1 100644 --- a/pretyping/evardefine.ml +++ b/pretyping/evardefine.ml @@ -77,7 +77,7 @@ let define_pure_evar_as_product evd evk = let evi = Evd.find_undefined evd evk in let evenv = evar_env evi in let id = next_ident_away idx (Environ.ids_of_named_context_val evi.evar_hyps) in - let concl = Reductionops.whd_all evenv evd (EConstr.of_constr evi.evar_concl) in + let concl = Reductionops.whd_all evenv evd evi.evar_concl in let s = destSort evd concl in let evksrc = evar_source evk evd in let src = subterm_source evk ~where:Domain evksrc in @@ -101,7 +101,7 @@ let define_pure_evar_as_product evd evk = evd3, rng in let prod = mkProd (Name id, dom, subst_var id rng) in - let evd3 = Evd.define evk (EConstr.Unsafe.to_constr prod) evd2 in + let evd3 = Evd.define evk prod evd2 in evd3,prod (* Refine an applied evar to a product and returns its instantiation *) @@ -128,7 +128,7 @@ let define_pure_evar_as_lambda env evd evk = let open Context.Named.Declaration in let evi = Evd.find_undefined evd evk in let evenv = evar_env evi in - let typ = Reductionops.whd_all evenv evd (EConstr.of_constr (evar_concl evi)) in + 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 @@ -141,7 +141,7 @@ let define_pure_evar_as_lambda env evd evk = let src = subterm_source evk ~where:Body (evar_source evk evd1) in let evd2,body = new_evar newenv evd1 ~src (subst1 (mkVar id) rng) ~filter in let lam = mkLambda (Name id, dom, subst_var id body) in - Evd.define evk (EConstr.Unsafe.to_constr lam) evd2, lam + Evd.define evk lam evd2, lam let define_evar_as_lambda env evd (evk,args) = let evd,lam = define_pure_evar_as_lambda env evd evk in @@ -166,9 +166,9 @@ let define_evar_as_sort env evd (ev,args) = let evd, u = new_univ_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 (EConstr.of_constr evi.evar_concl) 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 (Constr.mkSort s) evd 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 (* Propagation of constraints through application and abstraction: diff --git a/pretyping/evarsolve.ml b/pretyping/evarsolve.ml index 96d80741a..8afb9b942 100644 --- a/pretyping/evarsolve.ml +++ b/pretyping/evarsolve.ml @@ -89,9 +89,9 @@ let refresh_universes ?(status=univ_rigid) ?(onlyalg=false) ?(refreshset=false) Array.iter (refresh_term_evars onevars false) args | Evar (ev, a) when onevars -> let evi = Evd.find !evdref ev in - let ty' = refresh ~onlyalg univ_flexible ~direction:true (EConstr.of_constr evi.evar_concl) in + let ty' = refresh ~onlyalg univ_flexible ~direction:true evi.evar_concl in if !modified then - evdref := Evd.add !evdref ev {evi with evar_concl = EConstr.Unsafe.to_constr ty'} + evdref := Evd.add !evdref ev {evi with evar_concl = ty'} else () | _ -> EConstr.iter !evdref (refresh_term_evars onevars false) t and refresh_polymorphic_positions args pos = @@ -137,8 +137,6 @@ let test_success conv_algo env evd c c' rhs = is_success (conv_algo env evd c c' rhs) let add_conv_oriented_pb ?(tail=true) (pbty,env,t1,t2) evd = - let t1 = EConstr.Unsafe.to_constr t1 in - let t2 = EConstr.Unsafe.to_constr t2 in match pbty with | Some true -> add_conv_pb ~tail (Reduction.CUMUL,env,t1,t2) evd | Some false -> add_conv_pb ~tail (Reduction.CUMUL,env,t2,t1) evd @@ -197,7 +195,7 @@ let restrict_evar_key evd evk filter candidates = | None -> evar_filter evi | Some filter -> filter in let candidates = match candidates with - | NoUpdate -> Option.map (fun l -> List.map EConstr.of_constr l) evi.evar_candidates + | NoUpdate -> evi.evar_candidates | UpdateWith c -> Some c in restrict_evar evd evk filter candidates end @@ -527,7 +525,7 @@ let is_unification_pattern_meta env evd nb m l t = match Option.List.map map l with | Some l -> begin match find_unification_pattern_args env evd l t with - | Some _ as x when not (dependent evd (mkMeta m) t) -> x + | Some _ as x when not (occur_metavariable evd m t) -> x | _ -> None end | None -> @@ -600,7 +598,6 @@ let solve_pattern_eqn env sigma l c = let make_projectable_subst aliases sigma evi args = let sign = evar_filtered_context evi in - let sign = List.map (fun d -> map_named_decl EConstr.of_constr d) sign in let evar_aliases = compute_var_aliases sign sigma in let (_,full_subst,cstr_subst) = List.fold_right @@ -877,7 +874,7 @@ let choose_projection evi sols = let rec do_projection_effects define_fun env ty evd = function | ProjectVar -> evd | ProjectEvar ((evk,argsv),evi,id,p) -> - let evd = Evd.define evk (Constr.mkVar id) evd in + let evd = Evd.define evk (mkVar id) evd in (* TODO: simplify constraints involving evk *) let evd = do_projection_effects define_fun env ty evd p in let ty = whd_all env evd (Lazy.force ty) in @@ -887,7 +884,7 @@ let rec do_projection_effects define_fun env ty evd = function one (however, regarding coercions, because t is obtained by unif, we know that no coercion can be inserted) *) let subst = make_pure_subst evi argsv in - let ty' = replace_vars subst (EConstr.of_constr evi.evar_concl) in + let ty' = replace_vars subst evi.evar_concl in if isEvar evd ty' then define_fun env evd (Some false) (destEvar evd ty') ty else evd else evd @@ -932,7 +929,7 @@ let invert_arg_from_subst evd aliases k0 subst_in_env_extended_with_k_binders c_ with Not_found -> match expand_alias_once evd aliases t with | None -> raise Not_found - | Some c -> aux k c in + | Some c -> aux k (lift k c) in try let c = aux 0 c_in_env_extended_with_k_binders in Invertible (UniqueProjection (c,!effects)) @@ -1004,7 +1001,7 @@ let filter_effective_candidates evd evi filter candidates = let filter_candidates evd evk filter candidates_update = let evi = Evd.find_undefined evd evk in let candidates = match candidates_update with - | NoUpdate -> Option.map (fun l -> List.map EConstr.of_constr l) evi.evar_candidates + | NoUpdate -> evi.evar_candidates | UpdateWith c -> Some c in match candidates with @@ -1023,13 +1020,12 @@ let closure_of_filter evd evk = function | None -> None | Some filter -> let evi = Evd.find_undefined evd evk in - let vars = collect_vars evd (EConstr.of_constr (evar_concl evi)) in + let vars = collect_vars evd (evar_concl evi) in let test b decl = b || Id.Set.mem (get_id decl) vars || match decl with | LocalAssum _ -> false | LocalDef (_,c,_) -> - let c = EConstr.of_constr c in not (isRel evd c || isVar evd c) in let newfilter = Filter.map_along test filter (evar_context evi) in @@ -1062,7 +1058,7 @@ let do_restrict_hyps evd (evk,args as ev) filter candidates = match candidates,filter with | UpdateWith [], _ -> user_err Pp.(str "Not solvable.") | UpdateWith [nc],_ -> - let evd = Evd.define evk (EConstr.Unsafe.to_constr nc) evd in + let evd = Evd.define evk nc evd in raise (EvarSolvedWhileRestricting (evd,mkEvar ev)) | NoUpdate, None -> evd,ev | _ -> restrict_applied_evar evd ev filter candidates @@ -1072,8 +1068,14 @@ let do_restrict_hyps evd (evk,args as ev) filter candidates = let postpone_non_unique_projection env evd pbty (evk,argsv as ev) sols rhs = let rhs = expand_vars_in_term env evd rhs in - let filter = - restrict_upon_filter evd evk + let filter a = match EConstr.kind evd a with + | Rel n -> not (noccurn evd n rhs) + | Var id -> + local_occur_var evd id rhs + || List.exists (fun (id', _) -> Id.equal id id') sols + | _ -> true + in + let filter = restrict_upon_filter evd evk filter argsv in (* Keep only variables that occur in rhs *) (* This is not safe: is the variable is a local def, its body *) (* may contain references to variables that are removed, leading to *) @@ -1081,9 +1083,6 @@ let postpone_non_unique_projection env evd pbty (evk,argsv as ev) sols rhs = (* that says that the body is hidden. Note that expand_vars_in_term *) (* expands only rels and vars aliases, not rels or vars bound to an *) (* arbitrary complex term *) - (fun a -> not (isRel evd a || isVar evd a) - || dependent evd a rhs || List.exists (fun (id,_) -> isVarId evd id a) sols) - argsv in let filter = closure_of_filter evd evk filter in let candidates = extract_candidates sols in match candidates with @@ -1113,9 +1112,6 @@ let postpone_non_unique_projection env evd pbty (evk,argsv as ev) sols rhs = * Note: argument f is the function used to instantiate evars. *) -let instantiate_evar_array evi c args = - EConstr.of_constr (instantiate_evar_array evi (EConstr.Unsafe.to_constr c) (Array.map EConstr.Unsafe.to_constr args)) - let filter_compatible_candidates conv_algo env evd evi args rhs c = let c' = instantiate_evar_array evi c args in match conv_algo env evd Reduction.CONV rhs c' with @@ -1135,8 +1131,6 @@ let restrict_candidates conv_algo env evd filter1 (evk1,argsv1) (evk2,argsv2) = | _, None -> filter_candidates evd evk1 filter1 NoUpdate | None, Some _ -> raise DoesNotPreserveCandidateRestriction | Some l1, Some l2 -> - let l1 = List.map EConstr.of_constr l1 in - let l2 = List.map EConstr.of_constr l2 in let l1 = filter_effective_candidates evd evi1 filter1 l1 in let l1' = List.filter (fun c1 -> let c1' = instantiate_evar_array evi1 c1 argsv1 in @@ -1242,9 +1236,9 @@ let check_evar_instance evd evk1 body conv_algo = try Retyping.get_type_of ~lax:true evenv evd body with Retyping.RetypeError _ -> user_err Pp.(str "Ill-typed evar instance") in - match conv_algo evenv evd Reduction.CUMUL ty (EConstr.of_constr evi.evar_concl) with + match conv_algo evenv evd Reduction.CUMUL ty evi.evar_concl with | Success evd -> evd - | UnifFailure _ -> raise (IllTypedInstance (evenv,ty,EConstr.of_constr evi.evar_concl)) + | UnifFailure _ -> raise (IllTypedInstance (evenv,ty, evi.evar_concl)) let update_evar_source ev1 ev2 evd = let loc, evs2 = evar_source ev2 evd in @@ -1257,7 +1251,7 @@ let update_evar_source ev1 ev2 evd = let solve_evar_evar_l2r force f g env evd aliases pbty ev1 (evk2,_ as ev2) = try let evd,body = project_evar_on_evar force g env evd aliases 0 pbty ev1 ev2 in - let evd' = Evd.define evk2 (EConstr.Unsafe.to_constr body) evd in + let evd' = Evd.define evk2 body evd in let evd' = update_evar_source (fst (destEvar evd body)) evk2 evd' in check_evar_instance evd' evk2 body g with EvarSolvedOnTheFly (evd,c) -> @@ -1292,17 +1286,19 @@ let solve_evar_evar_aux force f g env evd pbty (evk1,args1 as ev1) (evk2,args2 a let solve_evar_evar ?(force=false) f g env evd pbty (evk1,args1 as ev1) (evk2,args2 as ev2) = let pbty = if force then None else pbty in let evi = Evd.find evd evk1 in - let downcast evk t evd = downcast evk (EConstr.Unsafe.to_constr t) evd in + let downcast evk t evd = downcast evk t evd in let evd = try (* ?X : Π Δ. Type i = ?Y : Π Δ'. Type j. The body of ?X and ?Y just has to be of type Π Δ. Type k for some k <= i, j. *) let evienv = Evd.evar_env evi in - let ctx1, i = Reduction.dest_arity evienv evi.evar_concl in + let concl1 = EConstr.Unsafe.to_constr evi.evar_concl in + let ctx1, i = Reduction.dest_arity evienv concl1 in let ctx1 = List.map (fun c -> map_rel_decl EConstr.of_constr c) ctx1 in let evi2 = Evd.find evd evk2 in let evi2env = Evd.evar_env evi2 in - let ctx2, j = Reduction.dest_arity evi2env evi2.evar_concl in + let concl2 = EConstr.Unsafe.to_constr evi2.evar_concl in + let ctx2, j = Reduction.dest_arity evi2env concl2 in let ctx2 = List.map (fun c -> map_rel_decl EConstr.of_constr c) ctx2 in let ui, uj = univ_of_sort i, univ_of_sort j in if i == j || Evd.check_eq evd ui uj @@ -1375,14 +1371,14 @@ let solve_candidates conv_algo env evd (evk,argsv) rhs = | Some l -> let l' = List.map_filter - (fun c -> filter_compatible_candidates conv_algo env evd evi argsv rhs (EConstr.of_constr c)) l in + (fun c -> filter_compatible_candidates conv_algo env evd evi argsv rhs c) l in match l' with | [] -> raise IncompatibleCandidates | [c,evd] -> (* solve_candidates might have been called recursively in the mean *) (* time and the evar been solved by the filtering process *) if Evd.is_undefined evd evk then - let evd' = Evd.define evk (EConstr.Unsafe.to_constr c) evd in + let evd' = Evd.define evk c evd in check_evar_instance evd' evk c conv_algo else evd | l when List.length l < List.length l' -> @@ -1401,8 +1397,8 @@ let occur_evar_upto_types sigma n c = Array.iter occur_rec args else ( seen := Evar.Set.add sp !seen; - Option.iter occur_rec (existential_opt_value sigma e); - occur_rec (Evd.existential_type sigma e)) + Option.iter occur_rec (existential_opt_value0 sigma e); + occur_rec (Evd.existential_type0 sigma e)) | _ -> Constr.iter occur_rec c in try occur_rec c; false with Occur -> true @@ -1529,7 +1525,7 @@ let rec invert_definition conv_algo choose env evd pbty (evk,argsv as ev) rhs = (* Try to project (a restriction of) the left evar ... *) try let evd,body = project_evar_on_evar false conv_algo env' evd aliases 0 None ev'' ev' in - let evd = Evd.define evk' (EConstr.Unsafe.to_constr body) evd in + let evd = Evd.define evk' body evd in check_evar_instance evd evk' body conv_algo with | EvarSolvedOnTheFly _ -> assert false (* ev has no candidates *) @@ -1592,14 +1588,14 @@ let rec invert_definition conv_algo choose env evd pbty (evk,argsv as ev) rhs = Id.Set.subset (collect_vars evd rhs) !names in let body = - if fast rhs then EConstr.of_constr (EConstr.to_constr evd rhs) (** FIXME? *) + if fast rhs then nf_evar evd rhs (** FIXME? *) else let t' = imitate (env,0) rhs in if !progress then (recheck_applications conv_algo (evar_env evi) evdref t'; t') else t' in (!evdref,body) - + (* [define] tries to solve the problem "?ev[args] = rhs" when "?ev" is * an (uninstantiated) evar such that "hyps |- ?ev : typ". Otherwise said, * [define] tries to find an instance lhs such that @@ -1644,7 +1640,7 @@ and evar_define conv_algo ?(choose=false) env evd pbty (evk,argsv as ev) rhs = print_constr body); raise e in*) let evd' = check_evar_instance evd' evk body conv_algo in - Evd.define evk (EConstr.Unsafe.to_constr body) evd' + Evd.define evk body evd' with | NotEnoughInformationToProgress sols -> postpone_non_unique_projection env evd pbty ev sols rhs @@ -1691,8 +1687,6 @@ and evar_define conv_algo ?(choose=false) env evd pbty (evk,argsv as ev) rhs = *) let status_changed evd lev (pbty,_,t1,t2) = - let t1 = EConstr.of_constr t1 in - let t2 = EConstr.of_constr t2 in (try Evar.Set.mem (head_evar evd t1) lev with NoHeadEvar -> false) || (try Evar.Set.mem (head_evar evd t2) lev with NoHeadEvar -> false) @@ -1702,7 +1696,7 @@ let reconsider_unif_constraints conv_algo evd = (fun p (pbty,env,t1,t2 as x) -> match p with | Success evd -> - (match conv_algo env evd pbty (EConstr.of_constr t1) (EConstr.of_constr t2) with + (match conv_algo env evd pbty t1 t2 with | Success _ as x -> x | UnifFailure (i,e) -> UnifFailure (i,CannotSolveConstraint (x,e))) | UnifFailure _ as x -> x) diff --git a/pretyping/evarsolve.mli b/pretyping/evarsolve.mli index 9b21599b6..3f05c58c4 100644 --- a/pretyping/evarsolve.mli +++ b/pretyping/evarsolve.mli @@ -63,7 +63,7 @@ val solve_simple_eqn : conv_fun -> ?choose:bool -> env -> evar_map -> val reconsider_unif_constraints : conv_fun -> evar_map -> unification_result val reconsider_conv_pbs : conv_fun -> evar_map -> unification_result -(** @deprecated Alias for [reconsider_unif_constraints] *) +[@@ocaml.deprecated "Alias for [reconsider_unif_constraints]"] val is_unification_pattern_evar : env -> evar_map -> existential -> constr list -> constr -> alias list option diff --git a/pretyping/glob_ops.ml b/pretyping/glob_ops.ml index e89bbf7c3..8ecec30cf 100644 --- a/pretyping/glob_ops.ml +++ b/pretyping/glob_ops.ml @@ -13,7 +13,6 @@ open CAst open Names open Nameops open Globnames -open Misctypes open Glob_term open Evar_kinds open Ltac_pretype @@ -47,12 +46,20 @@ let map_glob_decl_left_to_right f (na,k,obd,ty) = let comp2 = f ty in (na,k,comp1,comp2) + +let glob_sort_eq g1 g2 = let open Glob_term in match g1, g2 with +| GProp, GProp -> true +| GSet, GSet -> true +| GType l1, GType l2 -> + List.equal (Option.equal (fun (x,m) (y,n) -> Libnames.eq_reference x y && Int.equal m n)) l1 l2 +| _ -> false + let binding_kind_eq bk1 bk2 = match bk1, bk2 with | Decl_kinds.Explicit, Decl_kinds.Explicit -> true | Decl_kinds.Implicit, Decl_kinds.Implicit -> true | (Decl_kinds.Explicit | Decl_kinds.Implicit), _ -> false -let case_style_eq s1 s2 = match s1, s2 with +let case_style_eq s1 s2 = let open Constr in match s1, s2 with | LetStyle, LetStyle -> true | IfStyle, IfStyle -> true | LetPatternStyle, LetPatternStyle -> true @@ -113,7 +120,7 @@ let instance_eq f (x1,c1) (x2,c2) = Id.equal x1 x2 && f c1 c2 let mk_glob_constr_eq f c1 c2 = match DAst.get c1, DAst.get c2 with - | GRef (gr1, _), GRef (gr2, _) -> eq_gr gr1 gr2 + | GRef (gr1, _), GRef (gr2, _) -> GlobRef.equal gr1 gr2 | GVar id1, GVar id2 -> Id.equal id1 id2 | GEvar (id1, arg1), GEvar (id2, arg2) -> Id.equal id1 id2 && List.equal (instance_eq f) arg1 arg2 @@ -140,10 +147,10 @@ let mk_glob_constr_eq f c1 c2 = match DAst.get c1, DAst.get c2 with fix_kind_eq f kn1 kn2 && Array.equal Id.equal id1 id2 && Array.equal (fun l1 l2 -> List.equal (glob_decl_eq f) l1 l2) decl1 decl2 && Array.equal f c1 c2 && Array.equal f t1 t2 - | GSort s1, GSort s2 -> Miscops.glob_sort_eq s1 s2 + | GSort s1, GSort s2 -> glob_sort_eq s1 s2 | GHole (kn1, nam1, gn1), GHole (kn2, nam2, gn2) -> Option.equal (==) gn1 gn2 (** Only thing sensible *) && - Miscops.intro_pattern_naming_eq nam1 nam2 + Namegen.intro_pattern_naming_eq nam1 nam2 | GCast (c1, t1), GCast (c2, t2) -> f c1 c2 && cast_type_eq f t1 t2 | GProj (p1, t1), GProj (p2, t2) -> @@ -153,6 +160,21 @@ let mk_glob_constr_eq f c1 c2 = match DAst.get c1, DAst.get c2 with let rec glob_constr_eq c = mk_glob_constr_eq glob_constr_eq c +(** Mapping [cast_type] *) + +let map_cast_type f = function + | CastConv a -> CastConv (f a) + | CastVM a -> CastVM (f a) + | CastCoerce -> CastCoerce + | CastNative a -> CastNative (f a) + +let smartmap_cast_type f c = + match c with + | CastConv a -> let a' = f a in if a' == a then c else CastConv a' + | CastVM a -> let a' = f a in if a' == a then c else CastVM a' + | CastCoerce -> CastCoerce + | CastNative a -> let a' = f a in if a' == a then c else CastNative a' + let map_glob_constr_left_to_right f = DAst.map (function | GApp (g,args) -> let comp1 = f g in @@ -193,7 +215,7 @@ let map_glob_constr_left_to_right f = DAst.map (function GRec (fk,idl,comp1,comp2,comp3) | GCast (c,k) -> let comp1 = f c in - let comp2 = Miscops.map_cast_type f k in + let comp2 = map_cast_type f k in GCast (comp1,comp2) | GProj (p,c) -> GProj (p, f c) @@ -247,8 +269,9 @@ let fold_glob_constr_with_binders g f v acc = DAst.(with_val (function | GCases (_,rtntypopt,tml,pl) -> let fold_pattern acc {v=(idl,p,c)} = f (List.fold_right g idl v) acc c in let fold_tomatch (v',acc) (tm,(na,onal)) = - (Option.fold_left (fun v'' {v=(_,nal)} -> List.fold_right (Name.fold_right g) nal v'') - (Name.fold_right g na v') onal, + ((if rtntypopt = None then v' else + Option.fold_left (fun v'' {v=(_,nal)} -> List.fold_right (Name.fold_right g) nal v'') + (Name.fold_right g na v') onal), f v acc tm) in let (v',acc) = List.fold_left fold_tomatch (v,acc) tml in let acc = Option.fold_left (f v') acc rtntypopt in @@ -259,6 +282,7 @@ let fold_glob_constr_with_binders g f v acc = DAst.(with_val (function | GIf (c,rtntyp,b1,b2) -> f v (f v (f v (fold_return_type_with_binders f g v acc rtntyp) c) b1) b2 | GRec (_,idl,bll,tyl,bv) -> + let v' = Array.fold_right g idl v in let f' i acc fid = let v,acc = List.fold_left @@ -266,7 +290,7 @@ let fold_glob_constr_with_binders g f v acc = DAst.(with_val (function (Name.fold_right g na v, f v (Option.fold_left (f v) acc bbd) bty)) (v,acc) bll.(i) in - f (Array.fold_right g idl v) (f v acc tyl.(i)) (bv.(i)) in + f v' (f v acc tyl.(i)) (bv.(i)) in Array.fold_left_i f' acc idl | GCast (c,k) -> let acc = match k with @@ -331,19 +355,19 @@ let bound_glob_vars = (** Mapping of names in binders *) -(* spiwack: I used a smartmap-style kind of mapping here, because the +(* spiwack: I used a smart-style kind of mapping here, because the operation will be the identity almost all of the time (with any term outside of Ltac to begin with). But to be honest, there would probably be no significant penalty in doing reallocation as pattern-matching expressions are usually rather small. *) let map_inpattern_binders f ({loc;v=(id,nal)} as x) = - let r = CList.smartmap f nal in + let r = CList.Smart.map f nal in if r == nal then x else CAst.make ?loc (id,r) let map_tomatch_binders f ((c,(na,inp)) as x) : tomatch_tuple = - let r = Option.smartmap (fun p -> map_inpattern_binders f p) inp in + let r = Option.Smart.map (fun p -> map_inpattern_binders f p) inp in if r == inp then x else c,(f na, r) @@ -355,7 +379,7 @@ let rec map_case_pattern_binders f = DAst.map (function | PatCstr (c,ps,na) as x -> let rna = f na in let rps = - CList.smartmap (fun p -> map_case_pattern_binders f p) ps + CList.Smart.map (fun p -> map_case_pattern_binders f p) ps in if rna == na && rps == ps then x else PatCstr(c,rps,rna) @@ -366,13 +390,13 @@ let map_cases_branch_binders f ({CAst.loc;v=(il,cll,rhs)} as x) : cases_clause = It is intended to be a superset of the free variable of the right-hand side, if I understand correctly. But I'm not sure when or how they are used. *) - let r = List.smartmap (fun cl -> map_case_pattern_binders f cl) cll in + let r = List.Smart.map (fun cl -> map_case_pattern_binders f cl) cll in if r == cll then x else CAst.make ?loc (il,r,rhs) let map_pattern_binders f tomatch branches = - CList.smartmap (fun tm -> map_tomatch_binders f tm) tomatch, - CList.smartmap (fun br -> map_cases_branch_binders f br) branches + CList.Smart.map (fun tm -> map_tomatch_binders f tm) tomatch, + CList.Smart.map (fun br -> map_cases_branch_binders f br) branches (** /mapping of names in binders *) @@ -538,7 +562,7 @@ let rec glob_constr_of_cases_pattern_aux isclosed x = DAst.map_with_loc (fun ?lo | PatVar (Name id) when not isclosed -> GVar id | PatVar Anonymous when not isclosed -> - GHole (Evar_kinds.QuestionMark (Define false,Anonymous),Misctypes.IntroAnonymous,None) + GHole (Evar_kinds.QuestionMark (Define false,Anonymous),Namegen.IntroAnonymous,None) | _ -> raise Not_found ) x diff --git a/pretyping/glob_ops.mli b/pretyping/glob_ops.mli index 124440f5d..c967f4e88 100644 --- a/pretyping/glob_ops.mli +++ b/pretyping/glob_ops.mli @@ -13,6 +13,8 @@ open Glob_term (** Equalities *) +val glob_sort_eq : Glob_term.glob_sort -> Glob_term.glob_sort -> bool + val cases_pattern_eq : 'a cases_pattern_g -> 'a cases_pattern_g -> bool val alias_of_pat : 'a cases_pattern_g -> Name.t @@ -20,10 +22,15 @@ val alias_of_pat : 'a cases_pattern_g -> Name.t val set_pat_alias : Id.t -> 'a cases_pattern_g -> 'a cases_pattern_g val cast_type_eq : ('a -> 'a -> bool) -> - 'a Misctypes.cast_type -> 'a Misctypes.cast_type -> bool + 'a cast_type -> 'a cast_type -> bool val glob_constr_eq : 'a glob_constr_g -> 'a glob_constr_g -> bool +(** Mapping [cast_type] *) + +val map_cast_type : ('a -> 'b) -> 'a cast_type -> 'b cast_type +val smartmap_cast_type : ('a -> 'a) -> 'a cast_type -> 'a cast_type + (** Operations on [glob_constr] *) val cases_pattern_loc : 'a cases_pattern_g -> Loc.t option diff --git a/intf/glob_term.ml b/pretyping/glob_term.ml index 84be15552..54fa5328f 100644 --- a/intf/glob_term.ml +++ b/pretyping/glob_term.ml @@ -17,12 +17,37 @@ arguments and pattern-matching compilation are not. *) open Names -open Globnames open Decl_kinds -open Misctypes type existential_name = Id.t +(** Sorts *) + +type 'a glob_sort_gen = + | GProp (** representation of [Prop] literal *) + | GSet (** representation of [Set] literal *) + | GType of 'a (** representation of [Type] literal *) + +type 'a universe_kind = + | UAnonymous + | UUnknown + | UNamed of 'a + +type level_info = Libnames.reference universe_kind +type glob_level = level_info glob_sort_gen +type glob_constraint = glob_level * Univ.constraint_type * glob_level + +type sort_info = (Libnames.reference * int) option list +type glob_sort = sort_info glob_sort_gen + +(** Casts *) + +type 'a cast_type = + | CastConv of 'a + | CastVM of 'a + | CastCoerce (** Cast to a base type (eg, an underlying inductive type) *) + | CastNative of 'a + (** The kind of patterns that occurs in "match ... with ... end" locs here refers to the ident's location, not whole pat *) @@ -36,7 +61,7 @@ type cases_pattern = [ `any ] cases_pattern_g (** Representation of an internalized (or in other words globalized) term. *) type 'a glob_constr_r = - | GRef of global_reference * glob_level list option + | GRef of GlobRef.t * glob_level list option (** An identifier that represents a reference to an object defined either in the (global) environment or in the (local) context. *) | GVar of Id.t @@ -55,7 +80,7 @@ type 'a glob_constr_r = | GRec of 'a fix_kind_g * Id.t array * 'a glob_decl_g list array * 'a glob_constr_g array * 'a glob_constr_g array | GSort of glob_sort - | GHole of Evar_kinds.t * intro_pattern_naming_expr * Genarg.glob_generic_argument option + | GHole of Evar_kinds.t * Namegen.intro_pattern_naming_expr * Genarg.glob_generic_argument option | GCast of 'a glob_constr_g * 'a glob_constr_g cast_type | GProj of Projection.t * 'a glob_constr_g and 'a glob_constr_g = ('a glob_constr_r, 'a) DAst.t diff --git a/pretyping/indrec.ml b/pretyping/indrec.ml index 3327c250d..27b029aad 100644 --- a/pretyping/indrec.ml +++ b/pretyping/indrec.ml @@ -42,7 +42,7 @@ type recursion_scheme_error = exception RecursionSchemeError of recursion_scheme_error -let named_hd env t na = named_hd env Evd.empty (EConstr.of_constr t) na +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) @@ -86,7 +86,7 @@ let mis_make_case_com dep env sigma (ind, u as pind) (mib,mip as specif) kind = if not (Sorts.List.mem kind (elim_sorts specif)) then raise (RecursionSchemeError - (NotAllowedCaseAnalysis (false, fst (Universes.fresh_sort_in_family env kind), pind))) + (NotAllowedCaseAnalysis (false, fst (UnivGen.fresh_sort_in_family env kind), pind))) in let ndepar = mip.mind_nrealdecls + 1 in @@ -550,7 +550,7 @@ let check_arities env listdepkind = let kelim = elim_sorts (mibi,mipi) in if not (Sorts.List.mem kind kelim) then raise (RecursionSchemeError - (NotAllowedCaseAnalysis (true, fst (Universes.fresh_sort_in_family env + (NotAllowedCaseAnalysis (true, fst (UnivGen.fresh_sort_in_family env kind),(mind,u)))) else if Int.List.mem ni ln then raise (RecursionSchemeError (NotMutualInScheme (mind,mind))) diff --git a/pretyping/indrec.mli b/pretyping/indrec.mli index 119ff5222..d87a19d28 100644 --- a/pretyping/indrec.mli +++ b/pretyping/indrec.mli @@ -61,7 +61,7 @@ val weaken_sort_scheme : env -> evar_map -> bool -> Sorts.t -> int -> constr -> (** Recursor names utilities *) -val lookup_eliminator : inductive -> Sorts.family -> Globnames.global_reference +val lookup_eliminator : inductive -> Sorts.family -> GlobRef.t val elimination_suffix : Sorts.family -> string val make_elimination_ident : Id.t -> Sorts.family -> Id.t diff --git a/pretyping/inductiveops.ml b/pretyping/inductiveops.ml index 8e3c33ff7..b1ab2d2b7 100644 --- a/pretyping/inductiveops.ml +++ b/pretyping/inductiveops.ml @@ -629,6 +629,10 @@ let type_of_inductive_knowing_conclusion env sigma ((mib,mip),u) conclty = env evdref scl ar.template_level (ctx,ar.template_param_levels) in !evdref, EConstr.of_constr (mkArity (List.rev ctx,scl)) +let type_of_projection_constant env (p,u) = + let pb = lookup_projection p env in + Vars.subst_instance_constr u pb.proj_type + let type_of_projection_knowing_arg env sigma p c ty = let c = EConstr.Unsafe.to_constr c in let IndType(pars,realargs) = @@ -637,7 +641,7 @@ let type_of_projection_knowing_arg env sigma p c ty = raise (Invalid_argument "type_of_projection_knowing_arg_type: not an inductive type") in let (_,u), pars = dest_ind_family pars in - substl (c :: List.rev pars) (Typeops.type_of_projection_constant env (p,u)) + substl (c :: List.rev pars) (type_of_projection_constant env (p,u)) (***********************************************) (* Guard condition *) diff --git a/pretyping/inductiveops.mli b/pretyping/inductiveops.mli index 296f25d3f..b0d714b03 100644 --- a/pretyping/inductiveops.mli +++ b/pretyping/inductiveops.mli @@ -129,8 +129,8 @@ val allowed_sorts : env -> inductive -> Sorts.family list val has_dependent_elim : mutual_inductive_body -> bool (** Primitive projections *) -val projection_nparams : projection -> int -val projection_nparams_env : env -> projection -> int +val projection_nparams : Projection.t -> int +val projection_nparams_env : env -> Projection.t -> int val type_of_projection_knowing_arg : env -> evar_map -> Projection.t -> EConstr.t -> EConstr.types -> types diff --git a/intf/locus.ml b/pretyping/locus.ml index 95a2e495b..37dd120c1 100644 --- a/intf/locus.ml +++ b/pretyping/locus.ml @@ -9,10 +9,13 @@ (************************************************************************) open Names -open Misctypes (** Locus : positions in hypotheses and goals *) +type 'a or_var = + | ArgArg of 'a + | ArgVar of lident + (** {6 Occurrences} *) type 'a occurrences_gen = diff --git a/pretyping/locusops.ml b/pretyping/locusops.ml index 1664e68f2..6b6a3f8a9 100644 --- a/pretyping/locusops.ml +++ b/pretyping/locusops.ml @@ -86,8 +86,8 @@ let concrete_clause_of enum_hyps cl = (** Miscellaneous functions *) let out_arg = function - | Misctypes.ArgVar _ -> CErrors.anomaly (Pp.str "Unevaluated or_var variable.") - | Misctypes.ArgArg x -> x + | ArgVar _ -> CErrors.anomaly (Pp.str "Unevaluated or_var variable.") + | ArgArg x -> x let occurrences_of_hyp id cls = let rec hyp_occ = function diff --git a/pretyping/miscops.ml b/pretyping/miscops.ml deleted file mode 100644 index 0f0af5409..000000000 --- a/pretyping/miscops.ml +++ /dev/null @@ -1,76 +0,0 @@ -(************************************************************************) -(* * The Coq Proof Assistant / The Coq Development Team *) -(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) -(* <O___,, * (see CREDITS file for the list of authors) *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(* * (see LICENSE file for the text of the license) *) -(************************************************************************) - -open Util -open Misctypes -open Genredexpr - -(** Mapping [cast_type] *) - -let map_cast_type f = function - | CastConv a -> CastConv (f a) - | CastVM a -> CastVM (f a) - | CastCoerce -> CastCoerce - | CastNative a -> CastNative (f a) - -let smartmap_cast_type f c = - match c with - | CastConv a -> let a' = f a in if a' == a then c else CastConv a' - | CastVM a -> let a' = f a in if a' == a then c else CastVM a' - | CastCoerce -> CastCoerce - | CastNative a -> let a' = f a in if a' == a then c else CastNative a' - -(** Equalities on [glob_sort] *) - -let glob_sort_eq g1 g2 = match g1, g2 with -| GProp, GProp -> true -| GSet, GSet -> true -| GType l1, GType l2 -> - List.equal (Option.equal (fun (x,m) (y,n) -> Libnames.eq_reference x y && Int.equal m n)) l1 l2 -| _ -> false - -let intro_pattern_naming_eq nam1 nam2 = match nam1, nam2 with -| IntroAnonymous, IntroAnonymous -> true -| IntroIdentifier id1, IntroIdentifier id2 -> Names.Id.equal id1 id2 -| IntroFresh id1, IntroFresh id2 -> Names.Id.equal id1 id2 -| _ -> false - -(** Mapping [red_expr_gen] *) - -let map_flags f flags = - { flags with rConst = List.map f flags.rConst } - -let map_occs f (occ,e) = (occ,f e) - -let map_red_expr_gen f g h = function - | Fold l -> Fold (List.map f l) - | Pattern occs_l -> Pattern (List.map (map_occs f) occs_l) - | Simpl (flags,occs_o) -> - Simpl (map_flags g flags, Option.map (map_occs (map_union g h)) occs_o) - | Unfold occs_l -> Unfold (List.map (map_occs g) occs_l) - | Cbv flags -> Cbv (map_flags g flags) - | Lazy flags -> Lazy (map_flags g flags) - | CbvVm occs_o -> CbvVm (Option.map (map_occs (map_union g h)) occs_o) - | CbvNative occs_o -> CbvNative (Option.map (map_occs (map_union g h)) occs_o) - | Cbn flags -> Cbn (map_flags g flags) - | ExtraRedExpr _ | Red _ | Hnf as x -> x - -(** Mapping bindings *) - -let map_explicit_bindings f l = - let map = CAst.map (fun (hyp, x) -> (hyp, f x)) in - List.map map l - -let map_bindings f = function -| ImplicitBindings l -> ImplicitBindings (List.map f l) -| ExplicitBindings expl -> ExplicitBindings (map_explicit_bindings f expl) -| NoBindings -> NoBindings - -let map_with_bindings f (x, bl) = (f x, map_bindings f bl) diff --git a/pretyping/miscops.mli b/pretyping/miscops.mli deleted file mode 100644 index abe817fe5..000000000 --- a/pretyping/miscops.mli +++ /dev/null @@ -1,36 +0,0 @@ -(************************************************************************) -(* * The Coq Proof Assistant / The Coq Development Team *) -(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) -(* <O___,, * (see CREDITS file for the list of authors) *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(* * (see LICENSE file for the text of the license) *) -(************************************************************************) - -open Misctypes -open Genredexpr - -(** Mapping [cast_type] *) - -val map_cast_type : ('a -> 'b) -> 'a cast_type -> 'b cast_type -val smartmap_cast_type : ('a -> 'a) -> 'a cast_type -> 'a cast_type - -(** Equalities on [glob_sort] *) - -val glob_sort_eq : glob_sort -> glob_sort -> bool - -(** Equalities on [intro_pattern_naming] *) - -val intro_pattern_naming_eq : - intro_pattern_naming_expr -> intro_pattern_naming_expr -> bool - -(** Mapping [red_expr_gen] *) - -val map_red_expr_gen : ('a -> 'd) -> ('b -> 'e) -> ('c -> 'f) -> - ('a,'b,'c) red_expr_gen -> ('d,'e,'f) red_expr_gen - -(** Mapping bindings *) - -val map_bindings : ('a -> 'b) -> 'a bindings -> 'b bindings -val map_with_bindings : ('a -> 'b) -> 'a with_bindings -> 'b with_bindings diff --git a/pretyping/nativenorm.ml b/pretyping/nativenorm.ml index fcbf50fea..4b8e0e096 100644 --- a/pretyping/nativenorm.ml +++ b/pretyping/nativenorm.ml @@ -188,6 +188,14 @@ let branch_of_switch lvl ans bs = bs ci in Array.init (Array.length tbl) branch +let get_proj env ((mind, _n), i) = + let mib = Environ.lookup_mind mind env in + match mib.mind_record with + | None | Some None -> + CErrors.anomaly (Pp.strbrk "Return type is not a primitive record") + | Some (Some (_, projs, _)) -> + Projection.make projs.(i) true + let rec nf_val env sigma v typ = match kind_of_value v with | Vaccu accu -> nf_accu env sigma accu @@ -279,9 +287,10 @@ and nf_atom env sigma atom = let codom = nf_type env sigma (codom vn) in mkProd(n,dom,codom) | Ameta (mv,_) -> mkMeta mv - | Aproj(p,c) -> + | Aproj (p, c) -> let c = nf_accu env sigma c in - mkProj(Projection.make p true,c) + let p = get_proj env p in + mkProj(p, c) | _ -> fst (nf_atom_type env sigma atom) and nf_atom_type env sigma atom = @@ -303,10 +312,10 @@ and nf_atom_type env sigma atom = let (mib,mip) = Inductive.lookup_mind_specif env (fst ind) in let nparams = mib.mind_nparams in let params,realargs = Array.chop nparams allargs in + let nparamdecls = Context.Rel.length (Inductive.inductive_paramdecls (mib,u)) in let pT = - hnf_prod_applist env + hnf_prod_applist_assum env nparamdecls (Inductiveops.type_of_inductive env ind) (Array.to_list params) in - let pT = whd_all env pT in let dep, p = nf_predicate env sigma ind mip params p pT in (* Calcul du type des branches *) let btypes = build_branches_type env sigma (fst ind) mib mip u params dep p in @@ -357,25 +366,30 @@ and nf_atom_type env sigma atom = | Aproj(p,c) -> let c,tc = nf_accu_type env sigma c in let cj = make_judge c tc in - let uj = Typeops.judge_of_projection env (Projection.make p true) cj in + let p = get_proj env p in + let uj = Typeops.judge_of_projection env p cj in uj.uj_val, uj.uj_type and nf_predicate env sigma ind mip params v pT = - match kind_of_value v, kind pT with - | Vfun f, Prod _ -> + match kind (whd_allnolet env pT) with + | LetIn (name,b,t,pT) -> + let dep,body = + nf_predicate (push_rel (LocalDef (name,b,t)) env) sigma ind mip params v pT in + dep, mkLetIn (name,b,t,body) + | Prod (name,dom,codom) -> begin + match kind_of_value v with + | Vfun f -> let k = nb_rel env in let vb = f (mk_rel_accu k) in - let name,dom,codom = - try decompose_prod env pT with - DestKO -> - CErrors.anomaly - (Pp.strbrk "Returned a functional value in a type not recognized as a product type.") - in let dep,body = nf_predicate (push_rel (LocalAssum (name,dom)) env) sigma ind mip params vb codom in dep, mkLambda(name,dom,body) - | Vfun f, _ -> + | _ -> false, nf_type env sigma v + end + | _ -> + match kind_of_value v with + | Vfun f -> let k = nb_rel env in let vb = f (mk_rel_accu k) in let name = Name (Id.of_string "c") in @@ -385,7 +399,7 @@ and nf_predicate env sigma ind mip params v pT = let dom = mkApp(mkIndU ind,Array.append params rargs) in let body = nf_type (push_rel (LocalAssum (name,dom)) env) sigma vb in true, mkLambda(name,dom,body) - | _, _ -> false, nf_type env sigma v + | _ -> false, nf_type env sigma v and nf_evar env sigma evk ty args = let evi = try Evd.find sigma evk with Not_found -> assert false in @@ -401,9 +415,9 @@ and nf_evar env sigma evk ty args = mkEvar (evk, Array.of_list args), ty let evars_of_evar_map sigma = - { Nativelambda.evars_val = Evd.existential_opt_value sigma; - Nativelambda.evars_typ = Evd.existential_type sigma; - Nativelambda.evars_metas = Evd.meta_type sigma } + { Nativelambda.evars_val = Evd.existential_opt_value0 sigma; + Nativelambda.evars_typ = Evd.existential_type0 sigma; + Nativelambda.evars_metas = Evd.meta_type0 sigma } (* fork perf process, return profiler's process id *) let start_profiler_linux profile_fn = @@ -457,13 +471,12 @@ let native_norm env sigma c ty = if not Coq_config.native_compiler then user_err Pp.(str "Native_compute reduction has been disabled at configure time.") else - let penv = Environ.pre_env env in (* Format.eprintf "Numbers of free variables (named): %i\n" (List.length vl1); Format.eprintf "Numbers of free variables (rel): %i\n" (List.length vl2); *) let ml_filename, prefix = Nativelib.get_ml_filename () in - let code, upd = mk_norm_code penv (evars_of_evar_map sigma) prefix c in + let code, upd = mk_norm_code env (evars_of_evar_map sigma) prefix c in let profile = get_profiling_enabled () in match Nativelib.compile ml_filename code ~profile:profile with | true, fn -> diff --git a/pretyping/nativenorm.mli b/pretyping/nativenorm.mli index 67b7a2a40..4997d0bf0 100644 --- a/pretyping/nativenorm.mli +++ b/pretyping/nativenorm.mli @@ -25,4 +25,4 @@ val native_norm : env -> evar_map -> constr -> types -> constr (** Conversion with inference of universe constraints *) val native_infer_conv : ?pb:conv_pb -> env -> evar_map -> constr -> constr -> - evar_map * bool + evar_map option diff --git a/intf/pattern.ml b/pretyping/pattern.ml index 76367b612..be7ebe49c 100644 --- a/intf/pattern.ml +++ b/pretyping/pattern.ml @@ -9,11 +9,12 @@ (************************************************************************) open Names -open Globnames -open Misctypes (** {5 Patterns} *) +(** Cases pattern variables *) +type patvar = Id.t + type case_info_pattern = { cip_style : Constr.case_style; cip_ind : inductive option; @@ -21,9 +22,9 @@ type case_info_pattern = cip_extensible : bool (** does this match end with _ => _ ? *) } type constr_pattern = - | PRef of global_reference + | PRef of GlobRef.t | PVar of Id.t - | PEvar of existential_key * constr_pattern array + | PEvar of Evar.t * constr_pattern array | PRel of int | PApp of constr_pattern * constr_pattern array | PSoApp of patvar * constr_pattern list @@ -31,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_sort + | PSort of Glob_term.glob_sort | 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 e52112fda..622a8e982 100644 --- a/pretyping/patternops.ml +++ b/pretyping/patternops.ml @@ -18,7 +18,6 @@ open Constr open Glob_term open Pp open Mod_subst -open Misctypes open Decl_kinds open Pattern open Environ @@ -30,7 +29,7 @@ let case_info_pattern_eq i1 i2 = i1.cip_extensible == i2.cip_extensible let rec constr_pattern_eq p1 p2 = match p1, p2 with -| PRef r1, PRef r2 -> eq_gr r1 r2 +| PRef r1, PRef r2 -> GlobRef.equal r1 r2 | PVar v1, PVar v2 -> Id.equal v1 v2 | PEvar (ev1, ctx1), PEvar (ev2, ctx2) -> Evar.equal ev1 ev2 && Array.equal constr_pattern_eq ctx1 ctx2 @@ -47,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 -> Miscops.glob_sort_eq s1 s2 +| PSort s1, PSort s2 -> Glob_ops.glob_sort_eq 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 @@ -184,7 +183,7 @@ let pattern_of_constr env sigma t = | Evar_kinds.GoalEvar | Evar_kinds.VarInstance _ -> (* These are the two evar kinds used for existing goals *) (* see Proofview.mark_in_evm *) - if Evd.is_defined sigma evk then pattern_of_constr env (Evd.existential_value sigma ev) + if Evd.is_defined sigma evk then pattern_of_constr env (Evd.existential_value0 sigma ev) else PEvar (evk,Array.map (pattern_of_constr env) ctxt) | Evar_kinds.MatchingVar (Evar_kinds.SecondOrderPatVar ido) -> assert false | _ -> @@ -279,9 +278,11 @@ let lift_pattern k = liftn_pattern k 1 let rec subst_pattern subst pat = match pat with | PRef ref -> - let ref',t = subst_global subst ref in - if ref' == ref then pat else - pattern_of_constr (Global.env()) Evd.empty t + let ref',t = subst_global subst ref in + if ref' == ref then pat else + let env = Global.env () in + let evd = Evd.from_env env in + pattern_of_constr env evd t | PVar _ | PEvar _ | PRel _ -> pat @@ -293,11 +294,11 @@ let rec subst_pattern subst pat = PProj(p',c') | PApp (f,args) -> let f' = subst_pattern subst f in - let args' = Array.smartmap (subst_pattern subst) args in + let args' = Array.Smart.map (subst_pattern subst) args in if f' == f && args' == args then pat else PApp (f',args') | PSoApp (i,args) -> - let args' = List.smartmap (subst_pattern subst) args in + let args' = List.Smart.map (subst_pattern subst) args in if args' == args then pat else PSoApp (i,args') | PLambda (name,c1,c2) -> @@ -312,7 +313,7 @@ let rec subst_pattern subst pat = PProd (name,c1',c2') | PLetIn (name,c1,t,c2) -> let c1' = subst_pattern subst c1 in - let t' = Option.smartmap (subst_pattern subst) t in + let t' = Option.Smart.map (subst_pattern subst) t in let c2' = subst_pattern subst c2 in if c1' == c1 && t' == t && c2' == c2 then pat else PLetIn (name,c1',t',c2') @@ -326,7 +327,7 @@ let rec subst_pattern subst pat = PIf (c',c1',c2') | PCase (cip,typ,c,branches) -> let ind = cip.cip_ind in - let ind' = Option.smartmap (subst_ind subst) ind in + let ind' = Option.Smart.map (subst_ind subst) ind in let cip' = if ind' == ind then cip else { cip with cip_ind = ind' } in let typ' = subst_pattern subst typ in let c' = subst_pattern subst c in @@ -334,18 +335,18 @@ let rec subst_pattern subst pat = let c' = subst_pattern subst c in if c' == c then br else (i,n,c') in - let branches' = List.smartmap subst_branch branches in + let branches' = List.Smart.map subst_branch branches in if cip' == cip && typ' == typ && c' == c && branches' == branches then pat else PCase(cip', typ', c', branches') | PFix (lni,(lna,tl,bl)) -> - let tl' = Array.smartmap (subst_pattern subst) tl in - let bl' = Array.smartmap (subst_pattern subst) bl in + let tl' = Array.Smart.map (subst_pattern subst) tl in + let bl' = Array.Smart.map (subst_pattern subst) bl in if bl' == bl && tl' == tl then pat else PFix (lni,(lna,tl',bl')) | PCoFix (ln,(lna,tl,bl)) -> - let tl' = Array.smartmap (subst_pattern subst) tl in - let bl' = Array.smartmap (subst_pattern subst) bl in + let tl' = Array.Smart.map (subst_pattern subst) tl in + let bl' = Array.Smart.map (subst_pattern subst) bl in if bl' == bl && tl' == tl then pat else PCoFix (ln,(lna,tl',bl')) @@ -416,7 +417,7 @@ let rec pat_of_raw metas vars = DAst.with_loc_val (fun ?loc -> function pat_of_raw metas vars b1,pat_of_raw metas vars b2) | GLetTuple (nal,(_,None),b,c) -> let mkGLambda na c = DAst.make ?loc @@ - GLambda (na,Explicit, DAst.make @@ GHole (Evar_kinds.InternalHole, IntroAnonymous, None),c) in + GLambda (na,Explicit, DAst.make @@ GHole (Evar_kinds.InternalHole, Namegen.IntroAnonymous, None),c) in let c = List.fold_right mkGLambda nal c in let cip = { cip_style = LetStyle; diff --git a/pretyping/patternops.mli b/pretyping/patternops.mli index 9f0878578..36317b3ac 100644 --- a/pretyping/patternops.mli +++ b/pretyping/patternops.mli @@ -8,12 +8,11 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) -open EConstr -open Globnames -open Glob_term +open Names open Mod_subst -open Misctypes +open Glob_term open Pattern +open EConstr open Ltac_pretype (** {5 Functions on patterns} *) @@ -32,12 +31,12 @@ exception BoundPattern type [t] or raises [BoundPattern] (even if a sort); it raises an anomaly if [t] is an abstraction *) -val head_pattern_bound : constr_pattern -> global_reference +val head_pattern_bound : constr_pattern -> GlobRef.t (** [head_of_constr_reference c] assumes [r] denotes a reference and returns its label; raises an anomaly otherwise *) -val head_of_constr_reference : Evd.evar_map -> constr -> global_reference +val head_of_constr_reference : Evd.evar_map -> constr -> GlobRef.t (** [pattern_of_constr c] translates a term [c] with metavariables into a pattern; currently, no destructor (Cases, Fix, Cofix) and no diff --git a/pretyping/pretype_errors.ml b/pretyping/pretype_errors.ml index 278a4761d..856894d9a 100644 --- a/pretyping/pretype_errors.ml +++ b/pretyping/pretype_errors.ml @@ -165,7 +165,7 @@ let error_not_product ?loc env sigma c = (*s Error in conversion from AST to glob_constr *) let error_var_not_found ?loc s = - raise_pretype_error ?loc (empty_env, Evd.empty, VarNotFound s) + raise_pretype_error ?loc (empty_env, Evd.from_env empty_env, VarNotFound s) (*s Typeclass errors *) diff --git a/pretyping/pretyping.ml b/pretyping/pretyping.ml index 4962b89a0..9e024b1c2 100644 --- a/pretyping/pretyping.ml +++ b/pretyping/pretyping.ml @@ -28,6 +28,7 @@ open CErrors open Util open Names open Evd +open Constr open Term open Termops open Environ @@ -44,7 +45,6 @@ open Pretype_errors open Glob_term open Glob_ops open Evarconv -open Misctypes open Ltac_pretype module NamedDecl = Context.Named.Declaration @@ -117,7 +117,7 @@ open ExtraEnv exception Found of int array let nf_fix sigma (nas, cs, ts) = - let inj c = EConstr.to_constr sigma c in + let inj c = EConstr.to_constr ~abort_on_undefined_evars:false sigma c in (nas, Array.map inj cs, Array.map inj ts) let search_guard ?loc env possible_indexes fixdefs = @@ -169,14 +169,6 @@ let _ = optread = is_strict_universe_declarations; optwrite = (:=) strict_universe_declarations }) -let _ = - Goptions.(declare_bool_option - { optdepr = false; - optname = "minimization to Set"; - optkey = ["Universe";"Minimization";"ToSet"]; - optread = Universes.is_set_minimization; - optwrite = (:=) Universes.set_minimization }) - (** Miscellaneous interpretation functions *) let interp_known_universe_level evd r = @@ -245,7 +237,7 @@ let interp_known_level_info ?loc evd = function with Not_found -> user_err ?loc ~hdr:"interp_known_level_info" (str "Undeclared universe " ++ Libnames.pr_reference ref) -let interp_level_info ?loc evd : Misctypes.level_info -> _ = function +let interp_level_info ?loc evd : level_info -> _ = function | UUnknown -> new_univ_level_variable ?loc univ_rigid evd | UAnonymous -> new_univ_level_variable ?loc univ_flexible evd | UNamed s -> interp_universe_level_name ~anon_rigidity:univ_flexible evd s @@ -315,7 +307,7 @@ let apply_inference_hook hook evdref frozen = match frozen with then try let sigma, c = hook sigma evk in - Evd.define evk (EConstr.Unsafe.to_constr c) sigma + Evd.define evk c sigma with Exit -> sigma else @@ -429,7 +421,7 @@ let ltac_interp_name_env k0 lvar env sigma = let n = Context.Rel.length (rel_context env) - k0 in let ctxt,_ = List.chop n (rel_context env) in let open Context.Rel.Declaration in - let ctxt' = List.smartmap (map_name (ltac_interp_name lvar)) ctxt in + let ctxt' = List.Smart.map (map_name (ltac_interp_name lvar)) ctxt in if List.equal (fun d1 d2 -> Name.equal (get_name d1) (get_name d2)) ctxt ctxt' then env else push_rel_context sigma ctxt' (pop_rel_context n env sigma) @@ -499,7 +491,7 @@ let interp_known_glob_level ?loc evd = function | GSet -> Univ.Level.set | GType s -> interp_known_level_info ?loc evd s -let interp_glob_level ?loc evd : Misctypes.glob_level -> _ = function +let interp_glob_level ?loc evd : glob_level -> _ = function | GProp -> evd, Univ.Level.prop | GSet -> evd, Univ.Level.set | GType s -> interp_level_info ?loc evd s @@ -532,7 +524,7 @@ let pretype_global ?loc rigid env evd gr us = interp_instance ?loc evd ~len l in let (sigma, c) = Evd.fresh_global ?loc ~rigid ?names:instance env.ExtraEnv.env evd gr in - (sigma, EConstr.of_constr c) + (sigma, c) let pretype_ref ?loc evdref env ref us = match ref with @@ -674,14 +666,18 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) (env : ExtraEnv.t) evdre let ftys = Array.map2 (fun e a -> it_mkProd_or_LetIn a e) ctxtv lara in let nbfix = Array.length lar in let names = Array.map (fun id -> Name id) names in - let _ = + let () = match tycon with | Some t -> let fixi = match fixkind with | GFix (vn,i) -> i | GCoFix i -> i - in e_conv env.ExtraEnv.env evdref ftys.(fixi) t - | None -> true + in + begin match conv env.ExtraEnv.env !evdref ftys.(fixi) t with + | None -> () + | Some sigma -> evdref := sigma + end + | None -> () in (* Note: bodies are not used by push_rec_types, so [||] is safe *) let newenv = push_rec_types !evdref (names,ftys,[||]) env in @@ -698,7 +694,7 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) (env : ExtraEnv.t) evdre { uj_val = it_mkLambda_or_LetIn j.uj_val ctxt; uj_type = it_mkProd_or_LetIn j.uj_type ctxt }) ctxtv vdef in - Typing.check_type_fixpoint ?loc env.ExtraEnv.env evdref names ftys vdefj; + evdref := Typing.check_type_fixpoint ?loc env.ExtraEnv.env !evdref names ftys vdefj; let nf c = nf_evar !evdref c in let ftys = Array.map nf ftys in (** FIXME *) let fdefs = Array.map (fun x -> nf (j_val x)) vdefj in @@ -793,9 +789,12 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) (env : ExtraEnv.t) evdre match candargs with | [] -> [], j_val hj | arg :: args -> - if e_conv env.ExtraEnv.env evdref (j_val hj) arg then - args, nf_evar !evdref (j_val hj) - else [], j_val hj + begin match conv env.ExtraEnv.env !evdref (j_val hj) arg with + | Some sigma -> evdref := sigma; + args, nf_evar !evdref (j_val hj) + | None -> + [], j_val hj + end in let ujval = adjust_evar_source evdref na ujval in let value, typ = app_f n (j_val resj) ujval, subst1 ujval c2 in @@ -1082,9 +1081,9 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) (env : ExtraEnv.t) evdre let cj = pretype empty_tycon env evdref lvar c in let cty = nf_evar !evdref cj.uj_type and tval = nf_evar !evdref tval in if not (occur_existential !evdref cty || occur_existential !evdref tval) then - let (evd,b) = Reductionops.vm_infer_conv env.ExtraEnv.env !evdref cty tval in - if b then (evdref := evd; cj, tval) - else + match Reductionops.vm_infer_conv env.ExtraEnv.env !evdref cty tval with + | Some evd -> (evdref := evd; cj, tval) + | None -> error_actual_type ?loc env.ExtraEnv.env !evdref cj tval (ConversionFailed (env.ExtraEnv.env,cty,tval)) else user_err ?loc (str "Cannot check cast with vm: " ++ @@ -1093,9 +1092,9 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) (env : ExtraEnv.t) evdre let cj = pretype empty_tycon env evdref lvar c in let cty = nf_evar !evdref cj.uj_type and tval = nf_evar !evdref tval in begin - let (evd,b) = Nativenorm.native_infer_conv env.ExtraEnv.env !evdref cty tval in - if b then (evdref := evd; cj, tval) - else + match Nativenorm.native_infer_conv env.ExtraEnv.env !evdref cty tval with + | Some evd -> (evdref := evd; cj, tval) + | None -> error_actual_type ?loc env.ExtraEnv.env !evdref cj tval (ConversionFailed (env.ExtraEnv.env,cty,tval)) end @@ -1109,7 +1108,7 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) (env : ExtraEnv.t) evdre and pretype_instance k0 resolve_tc env evdref lvar loc hyps evk update = let f decl (subst,update) = let id = NamedDecl.get_id decl in - let t = replace_vars subst (EConstr.of_constr (NamedDecl.get_type decl)) in + let t = replace_vars subst (NamedDecl.get_type decl) in let c, update = try let c = List.assoc id update in @@ -1118,7 +1117,7 @@ and pretype_instance k0 resolve_tc env evdref lvar loc hyps evk update = with Not_found -> try let (n,_,t') = lookup_rel_id id (rel_context env) in - if is_conv env.ExtraEnv.env !evdref t t' then mkRel n, update else raise Not_found + if is_conv env.ExtraEnv.env !evdref t (lift n t') then mkRel n, update else raise Not_found with Not_found -> try let t' = env |> lookup_named id |> NamedDecl.get_type in @@ -1150,7 +1149,7 @@ and pretype_type k0 resolve_tc valcon (env : ExtraEnv.t) evdref lvar c = match D (* Correction of bug #5315 : we need to define an evar for *all* holes *) let evkt = e_new_evar env evdref ~src:(loc, knd) ~naming (mkSort s) in let ev,_ = destEvar !evdref evkt in - evdref := Evd.define ev (to_constr !evdref v) !evdref; + evdref := Evd.define ev (nf_evar !evdref v) !evdref; (* End of correction of bug #5315 *) { utj_val = v; utj_type = s } @@ -1166,10 +1165,12 @@ and pretype_type k0 resolve_tc valcon (env : ExtraEnv.t) evdref lvar c = match D match valcon with | None -> tj | Some v -> - if e_cumul env.ExtraEnv.env evdref v tj.utj_val then tj - else + begin match cumul env.ExtraEnv.env !evdref v tj.utj_val with + | Some sigma -> evdref := sigma; tj + | None -> error_unexpected_type ?loc:(loc_of_glob_constr c) env.ExtraEnv.env !evdref tj.utj_val v + end let ise_pretype_gen flags env sigma lvar kind c = let env = make_env env sigma in diff --git a/pretyping/pretyping.mli b/pretyping/pretyping.mli index 415c4e172..73f5b77e0 100644 --- a/pretyping/pretyping.mli +++ b/pretyping/pretyping.mli @@ -22,7 +22,7 @@ open Ltac_pretype open Evardefine val interp_known_glob_level : ?loc:Loc.t -> Evd.evar_map -> - Misctypes.glob_level -> Univ.Level.t + glob_level -> Univ.Level.t (** An auxiliary function for searching for fixpoint guard indexes *) diff --git a/pretyping/pretyping.mllib b/pretyping/pretyping.mllib index ae4ad0be7..3d9b5d3cf 100644 --- a/pretyping/pretyping.mllib +++ b/pretyping/pretyping.mllib @@ -1,5 +1,5 @@ Geninterp -Ltac_pretype +Locus Locusops Pretype_errors Reductionops @@ -17,8 +17,10 @@ Recordops Evarconv Typing Miscops +Glob_term +Ltac_pretype Glob_ops -Redops +Pattern Patternops Constr_matching Tacred @@ -32,4 +34,3 @@ Indrec Cases Pretyping Unification -Univdecls diff --git a/pretyping/program.ml b/pretyping/program.ml index 52d940d8e..8cfb7966c 100644 --- a/pretyping/program.ml +++ b/pretyping/program.ml @@ -16,7 +16,9 @@ let init_reference dir s () = Coqlib.coq_reference "Program" dir s let papp evdref r args = let open EConstr in let gr = delayed_force r in - mkApp (Evarutil.e_new_global evdref gr, args) + let evd, hd = Evarutil.new_global !evdref gr in + evdref := evd; + mkApp (hd, args) let sig_typ = init_reference ["Init"; "Specif"] "sig" let sig_intro = init_reference ["Init"; "Specif"] "exist" diff --git a/pretyping/program.mli b/pretyping/program.mli index df0848ba1..a8f511578 100644 --- a/pretyping/program.mli +++ b/pretyping/program.mli @@ -8,37 +8,37 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) +open Names open EConstr -open Globnames (** A bunch of Coq constants used by Progam *) -val sig_typ : unit -> global_reference -val sig_intro : unit -> global_reference -val sig_proj1 : unit -> global_reference -val sigT_typ : unit -> global_reference -val sigT_intro : unit -> global_reference -val sigT_proj1 : unit -> global_reference -val sigT_proj2 : unit -> global_reference +val sig_typ : unit -> GlobRef.t +val sig_intro : unit -> GlobRef.t +val sig_proj1 : unit -> GlobRef.t +val sigT_typ : unit -> GlobRef.t +val sigT_intro : unit -> GlobRef.t +val sigT_proj1 : unit -> GlobRef.t +val sigT_proj2 : unit -> GlobRef.t -val prod_typ : unit -> global_reference -val prod_intro : unit -> global_reference -val prod_proj1 : unit -> global_reference -val prod_proj2 : unit -> global_reference +val prod_typ : unit -> GlobRef.t +val prod_intro : unit -> GlobRef.t +val prod_proj1 : unit -> GlobRef.t +val prod_proj2 : unit -> GlobRef.t -val coq_eq_ind : unit -> global_reference -val coq_eq_refl : unit -> global_reference -val coq_eq_refl_ref : unit -> global_reference -val coq_eq_rect : unit -> global_reference +val coq_eq_ind : unit -> GlobRef.t +val coq_eq_refl : unit -> GlobRef.t +val coq_eq_refl_ref : unit -> GlobRef.t +val coq_eq_rect : unit -> GlobRef.t -val coq_JMeq_ind : unit -> global_reference -val coq_JMeq_refl : unit -> global_reference +val coq_JMeq_ind : unit -> GlobRef.t +val coq_JMeq_refl : unit -> GlobRef.t val mk_coq_and : Evd.evar_map -> constr list -> Evd.evar_map * constr val mk_coq_not : Evd.evar_map -> constr -> Evd.evar_map * constr (** Polymorphic application of delayed references *) -val papp : Evd.evar_map ref -> (unit -> global_reference) -> constr array -> constr +val papp : Evd.evar_map ref -> (unit -> GlobRef.t) -> constr array -> constr val get_proofs_transparency : unit -> bool val is_program_cases : unit -> bool diff --git a/pretyping/recordops.ml b/pretyping/recordops.ml index d070edead..56a883099 100644 --- a/pretyping/recordops.ml +++ b/pretyping/recordops.ml @@ -69,8 +69,8 @@ let subst_structure (subst,((kn,i),id,kl,projs as obj)) = let projs' = (* invariant: struc.s_PROJ is an evaluable reference. Thus we can take *) (* the first component of subst_con. *) - List.smartmap - (Option.smartmap (fun kn -> fst (subst_con_kn subst kn))) + List.Smart.map + (Option.Smart.map (fun kn -> fst (subst_con_kn subst kn))) projs in let id' = fst (subst_constructor subst id) in @@ -144,13 +144,13 @@ type obj_typ = { o_TCOMPS : constr list } (* ordered *) type cs_pattern = - Const_cs of global_reference + Const_cs of GlobRef.t | Prod_cs | Sort_cs of Sorts.family | Default_cs let eq_cs_pattern p1 p2 = match p1, p2 with -| Const_cs gr1, Const_cs gr2 -> eq_gr gr1 gr2 +| Const_cs gr1, Const_cs gr2 -> GlobRef.equal gr1 gr2 | Prod_cs, Prod_cs -> true | Sort_cs s1, Sort_cs s2 -> Sorts.family_equal s1 s2 | Default_cs, Default_cs -> true @@ -199,7 +199,7 @@ let warn_projection_no_head_constant = let env = Termops.push_rels_assum sign env in let con_pp = Nametab.pr_global_env Id.Set.empty (ConstRef con) in let proji_sp_pp = Nametab.pr_global_env Id.Set.empty (ConstRef proji_sp) in - let term_pp = Termops.print_constr_env env Evd.empty (EConstr.of_constr t) in + let term_pp = Termops.print_constr_env env (Evd.from_env env) (EConstr.of_constr t) in strbrk "Projection value has no head constant: " ++ term_pp ++ strbrk " in canonical instance " ++ con_pp ++ str " of " ++ proji_sp_pp ++ strbrk ", ignoring it.") @@ -211,7 +211,7 @@ let compute_canonical_projections warn (con,ind) = let u = Univ.make_abstract_instance ctx in let v = (mkConstU (con,u)) in let c = Environ.constant_value_in env (con,u) in - let sign,t = Reductionops.splay_lam env Evd.empty (EConstr.of_constr c) in + let sign,t = Reductionops.splay_lam env (Evd.from_env env) (EConstr.of_constr c) in let sign = List.map (on_snd EConstr.Unsafe.to_constr) sign in let t = EConstr.Unsafe.to_constr t in let lt = List.rev_map snd sign in @@ -317,7 +317,9 @@ let check_and_decompose_canonical_structure ref = let vc = match Environ.constant_opt_value_in env (sp, u) with | Some vc -> vc | None -> error_not_structure ref "Could not find its value in the global environment." in - let body = snd (splay_lam (Global.env()) Evd.empty (EConstr.of_constr vc)) (** FIXME *) in + let env = Global.env () in + let evd = Evd.from_env env in + let body = snd (splay_lam (Global.env()) evd (EConstr.of_constr vc)) in let body = EConstr.Unsafe.to_constr body in let f,args = match kind body with | App (f,args) -> f,args diff --git a/pretyping/recordops.mli b/pretyping/recordops.mli index 1f7b23c0c..748f053b2 100644 --- a/pretyping/recordops.mli +++ b/pretyping/recordops.mli @@ -10,7 +10,6 @@ open Names open Constr -open Globnames (** Operations concerning records and canonical structures *) @@ -40,10 +39,10 @@ val lookup_structure : inductive -> struc_typ val lookup_projections : inductive -> Constant.t option list (** raise [Not_found] if not a projection *) -val find_projection_nparams : global_reference -> int +val find_projection_nparams : GlobRef.t -> int (** raise [Not_found] if not a projection *) -val find_projection : global_reference -> struc_typ +val find_projection : GlobRef.t -> struc_typ (** {6 Canonical structures } *) (** A canonical structure declares "canonical" conversion hints between @@ -52,7 +51,7 @@ val find_projection : global_reference -> struc_typ (** A cs_pattern characterizes the form of a component of canonical structure *) type cs_pattern = - Const_cs of global_reference + Const_cs of GlobRef.t | Prod_cs | Sort_cs of Sorts.family | Default_cs @@ -71,9 +70,9 @@ val cs_pattern_of_constr : Environ.env -> constr -> cs_pattern * int option * co val pr_cs_pattern : cs_pattern -> Pp.t -val lookup_canonical_conversion : (global_reference * cs_pattern) -> constr * obj_typ -val declare_canonical_structure : global_reference -> unit +val lookup_canonical_conversion : (GlobRef.t * cs_pattern) -> constr * obj_typ +val declare_canonical_structure : GlobRef.t -> unit val is_open_canonical_projection : Environ.env -> Evd.evar_map -> Reductionops.state -> bool val canonical_projections : unit -> - ((global_reference * cs_pattern) * obj_typ) list + ((GlobRef.t * cs_pattern) * obj_typ) list diff --git a/pretyping/reductionops.ml b/pretyping/reductionops.ml index 9e3e68f05..7fb1a0a57 100644 --- a/pretyping/reductionops.ml +++ b/pretyping/reductionops.ml @@ -83,7 +83,7 @@ let declare_reduction_effect funkey f = (** A function to set the value of the print function *) let set_reduction_effect x funkey = - let termkey = Universes.constr_of_global x in + let termkey = UnivGen.constr_of_global x in Lib.add_anonymous_leaf (inReductionEffect (termkey,funkey)) @@ -104,7 +104,7 @@ module ReductionBehaviour = struct type flag = [ `ReductionDontExposeCase | `ReductionNeverUnfold ] type req = | ReqLocal - | ReqGlobal of global_reference * (int list * int * flag list) + | ReqGlobal of GlobRef.t * (int list * int * flag list) let load _ (_,(_,(r, b))) = table := Refmap.add r b !table @@ -275,12 +275,12 @@ sig type cst_member = | Cst_const of pconstant - | Cst_proj of projection + | Cst_proj of Projection.t type 'a member = | App of 'a app_node | Case of case_info * 'a * 'a array * Cst_stack.t - | Proj of int * int * projection * Cst_stack.t + | Proj of int * int * Projection.t * Cst_stack.t | Fix of ('a, 'a) pfixpoint * 'a t * Cst_stack.t | Cst of cst_member * int * int list * 'a t * Cst_stack.t and 'a t = 'a member list @@ -332,12 +332,12 @@ struct type cst_member = | Cst_const of pconstant - | Cst_proj of projection + | Cst_proj of Projection.t type 'a member = | App of 'a app_node | Case of case_info * 'a * 'a array * Cst_stack.t - | Proj of int * int * projection * Cst_stack.t + | Proj of int * int * Projection.t * Cst_stack.t | Fix of ('a, 'a) pfixpoint * 'a t * Cst_stack.t | Cst of cst_member * int * int list * 'a t * Cst_stack.t and 'a t = 'a member list @@ -701,18 +701,18 @@ let reducible_mind_case sigma c = match EConstr.kind sigma c with let magicaly_constant_of_fixbody env sigma reference bd = function | Name.Anonymous -> bd | Name.Name id -> - let open Universes in + let open UnivProblem in try let (cst_mod,cst_sect,_) = Constant.repr3 reference in let cst = Constant.make3 cst_mod cst_sect (Label.of_id id) in - let (cst, u), ctx = fresh_constant_instance env cst in + let (cst, u), ctx = UnivGen.fresh_constant_instance env cst in match constant_opt_value_in env (cst,u) with | None -> bd | Some t -> let csts = EConstr.eq_constr_universes env sigma (EConstr.of_constr t) bd in begin match csts with | Some csts -> - let subst = Constraints.fold (fun cst acc -> + let subst = Set.fold (fun cst acc -> let l, r = match cst with | ULub (u, v) | UWeak (u, v) -> u, v | UEq (u, v) | ULe (u, v) -> @@ -871,7 +871,7 @@ let rec whd_state_gen ?csts ~refold ~tactic_mode flags env sigma = | Evar ev -> fold () | Meta ev -> (match safe_meta_value sigma ev with - | Some body -> whrec cst_l (EConstr.of_constr body, stack) + | Some body -> whrec cst_l (body, stack) | None -> fold ()) | Const (c,u as const) -> reduction_effect_hook env sigma (EConstr.to_constr sigma x) @@ -1106,7 +1106,7 @@ let local_whd_state_gen flags sigma = | Evar ev -> s | Meta ev -> (match safe_meta_value sigma ev with - Some c -> whrec (EConstr.of_constr c,stack) + Some c -> whrec (c,stack) | None -> s) | Construct ((ind,c),u) -> @@ -1348,11 +1348,10 @@ let infer_conv_gen conv_fun ?(catch_incon=true) ?(pb=Reduction.CUMUL) ?(ts=full_transparent_state) env sigma x y = (** FIXME *) try - let b, sigma = - let ans = - if pb == Reduction.CUMUL then + let ans = match pb with + | Reduction.CUMUL -> EConstr.leq_constr_universes env sigma x y - else + | Reduction.CONV -> EConstr.eq_constr_universes env sigma x y in let ans = match ans with @@ -1362,20 +1361,17 @@ let infer_conv_gen conv_fun ?(catch_incon=true) ?(pb=Reduction.CUMUL) with Univ.UniverseInconsistency _ | Evd.UniversesDiffer -> None in match ans with - | None -> false, sigma - | Some sigma -> true, sigma - in - if b then sigma, true - else + | Some sigma -> ans + | None -> let x = EConstr.Unsafe.to_constr x in let y = EConstr.Unsafe.to_constr y in let sigma' = conv_fun pb ~l2r:false sigma ts env (sigma, sigma_univ_state) x y in - sigma', true + Some sigma' with - | Reduction.NotConvertible -> sigma, false - | Univ.UniverseInconsistency _ when catch_incon -> sigma, false + | Reduction.NotConvertible -> None + | Univ.UniverseInconsistency _ when catch_incon -> None | e when is_anomaly e -> report_anomaly e let infer_conv = infer_conv_gen (fun pb ~l2r sigma -> @@ -1392,7 +1388,7 @@ let vm_infer_conv ?(pb=Reduction.CUMUL) env t1 t2 = (********************************************************************) let whd_meta sigma c = match EConstr.kind sigma c with - | Meta p -> (try EConstr.of_constr (meta_value sigma p) with Not_found -> c) + | Meta p -> (try meta_value sigma p with Not_found -> c) | _ -> c let default_plain_instance_ident = Id.of_string "H" @@ -1404,7 +1400,7 @@ let plain_instance sigma s c = | Meta p -> (try lift n (Metamap.find p s) with Not_found -> u) | App (f,l) when isCast sigma f -> let (f,_,t) = destCast sigma f in - let l' = CArray.Fun1.smartmap irec n l in + let l' = Array.Fun1.Smart.map irec n l in (match EConstr.kind sigma f with | Meta p -> (* Don't flatten application nodes: this is used to extract a @@ -1413,7 +1409,7 @@ let plain_instance sigma s c = (try let g = Metamap.find p s in match EConstr.kind sigma g with | App _ -> - let l' = CArray.Fun1.smartmap lift 1 l' in + let l' = Array.Fun1.Smart.map lift 1 l' in mkLetIn (Name default_plain_instance_ident,g,t,mkApp(mkRel 1, l')) | _ -> mkApp (g,l') with Not_found -> mkApp (f,l')) @@ -1612,7 +1608,7 @@ let meta_value evd mv = match meta_opt_fvalue evd mv with | Some (b,_) -> let metas = Metamap.bind valrec b.freemetas in - instance evd metas (EConstr.of_constr b.rebus) + instance evd metas b.rebus | None -> mkMeta mv in valrec mv @@ -1625,9 +1621,8 @@ let meta_instance sigma b = instance sigma c_sigma b.rebus let nf_meta sigma c = - let c = EConstr.Unsafe.to_constr c in let cl = mk_freelisted c in - meta_instance sigma { cl with rebus = EConstr.of_constr cl.rebus } + meta_instance sigma { cl with rebus = cl.rebus } (* Instantiate metas that create beta/iota redexes *) @@ -1648,7 +1643,6 @@ let meta_reducible_instance evd b = (match try let g, s = Metamap.find m metas in - let g = EConstr.of_constr g in let is_coerce = match s with CoerceToType -> true | _ -> false in if isConstruct evd g || not is_coerce then Some g else None with Not_found -> None @@ -1660,7 +1654,6 @@ let meta_reducible_instance evd b = (match try let g, s = Metamap.find m metas in - let g = EConstr.of_constr g in let is_coerce = match s with CoerceToType -> true | _ -> false in if isLambda evd g || not is_coerce then Some g else None with Not_found -> None @@ -1669,7 +1662,6 @@ let meta_reducible_instance evd b = | None -> mkApp (f,Array.map irec l)) | Meta m -> (try let g, s = Metamap.find m metas in - let g = EConstr.of_constr g in let is_coerce = match s with CoerceToType -> true | _ -> false in if not is_coerce then irec g else u with Not_found -> u) @@ -1678,7 +1670,6 @@ let meta_reducible_instance evd b = (match try let g, s = Metamap.find m metas in - let g = EConstr.of_constr g in let is_coerce = match s with CoerceToType -> true | _ -> false in if isConstruct evd g || not is_coerce then Some g else None with Not_found -> None diff --git a/pretyping/reductionops.mli b/pretyping/reductionops.mli index 29dc3ed0f..9256fa7ce 100644 --- a/pretyping/reductionops.mli +++ b/pretyping/reductionops.mli @@ -25,10 +25,10 @@ module ReductionBehaviour : sig (** [set is_local ref (recargs, nargs, flags)] *) val set : - bool -> Globnames.global_reference -> (int list * int * flag list) -> unit + bool -> GlobRef.t -> (int list * int * flag list) -> unit val get : - Globnames.global_reference -> (int list * int * flag list) option - val print : Globnames.global_reference -> Pp.t + GlobRef.t -> (int list * int * flag list) option + val print : GlobRef.t -> Pp.t end (** {6 Support for reduction effects } *) @@ -41,7 +41,7 @@ val declare_reduction_effect : effect_name -> (Environ.env -> Evd.evar_map -> Constr.constr -> unit) -> unit (* [set_reduction_effect cst name] declares effect [name] to be called when [cst] is found *) -val set_reduction_effect : Globnames.global_reference -> effect_name -> unit +val set_reduction_effect : GlobRef.t -> effect_name -> unit (* [effect_hook env sigma key term] apply effect associated to [key] on [term] *) val reduction_effect_hook : Environ.env -> Evd.evar_map -> Constr.constr -> @@ -70,12 +70,12 @@ module Stack : sig type cst_member = | Cst_const of pconstant - | Cst_proj of projection + | Cst_proj of Projection.t type 'a member = | App of 'a app_node | Case of case_info * 'a * 'a array * Cst_stack.t - | Proj of int * int * projection * Cst_stack.t + | Proj of int * int * Projection.t * Cst_stack.t | Fix of ('a, 'a) pfixpoint * 'a t * Cst_stack.t | Cst of cst_member * int (** current foccussed arg *) * int list (** remaining args *) * 'a t * Cst_stack.t @@ -277,13 +277,13 @@ val check_conv : ?pb:conv_pb -> ?ts:transparent_state -> env -> evar_map -> con otherwise returns false in that case. *) val infer_conv : ?catch_incon:bool -> ?pb:conv_pb -> ?ts:transparent_state -> - env -> evar_map -> constr -> constr -> evar_map * bool + env -> evar_map -> constr -> constr -> evar_map option (** Conversion with inference of universe constraints *) val set_vm_infer_conv : (?pb:conv_pb -> env -> evar_map -> constr -> constr -> - evar_map * bool) -> unit + evar_map option) -> unit val vm_infer_conv : ?pb:conv_pb -> env -> evar_map -> constr -> constr -> - evar_map * bool + evar_map option (** [infer_conv_gen] behaves like [infer_conv] but is parametrized by a @@ -291,7 +291,7 @@ conversion function. Used to pretype vm and native casts. *) val infer_conv_gen : (conv_pb -> l2r:bool -> evar_map -> transparent_state -> (Constr.constr, evar_map) Reduction.generic_conversion_function) -> ?catch_incon:bool -> ?pb:conv_pb -> ?ts:transparent_state -> env -> - evar_map -> constr -> constr -> evar_map * bool + evar_map -> constr -> constr -> evar_map option (** {6 Special-Purpose Reduction Functions } *) diff --git a/pretyping/retyping.ml b/pretyping/retyping.ml index 3582b6447..746a68b21 100644 --- a/pretyping/retyping.ml +++ b/pretyping/retyping.ml @@ -57,8 +57,8 @@ let get_type_from_constraints env sigma t = if isEvar sigma (fst (decompose_app_vect sigma t)) then match List.map_filter (fun (pbty,env,t1,t2) -> - if is_fconv Reduction.CONV env sigma t (EConstr.of_constr t1) then Some t2 - else if is_fconv Reduction.CONV env sigma t (EConstr.of_constr t2) then Some t1 + if is_fconv Reduction.CONV env sigma t t1 then Some t2 + else if is_fconv Reduction.CONV env sigma t t2 then Some t1 else None) (snd (Evd.extract_all_conv_pbs sigma)) with @@ -99,7 +99,7 @@ let retype ?(polyprop=true) sigma = let rec type_of env cstr = match EConstr.kind sigma cstr with | Meta n -> - (try strip_outer_cast sigma (EConstr.of_constr (Evd.meta_ftype sigma n).Evd.rebus) + (try strip_outer_cast sigma (Evd.meta_ftype sigma n).Evd.rebus with Not_found -> retype_error (BadMeta n)) | Rel n -> let ty = RelDecl.get_type (lookup_rel n env) in @@ -115,7 +115,7 @@ let retype ?(polyprop=true) sigma = try Inductiveops.find_rectype env sigma t with Not_found -> try - let t = EConstr.of_constr (get_type_from_constraints env sigma t) in + let t = get_type_from_constraints env sigma t in Inductiveops.find_rectype env sigma t with Not_found -> retype_error BadRecursiveType in @@ -170,7 +170,7 @@ let retype ?(polyprop=true) sigma = and type_of_global_reference_knowing_parameters env c args = let argtyps = - Array.map (fun c -> lazy (EConstr.to_constr sigma (type_of env c))) args in + Array.map (fun c -> lazy (EConstr.to_constr ~abort_on_undefined_evars:false sigma (type_of env c))) args in match EConstr.kind sigma c with | Ind (ind, u) -> let u = EInstance.kind sigma u in diff --git a/pretyping/retyping.mli b/pretyping/retyping.mli index 40424ead4..2aff0c777 100644 --- a/pretyping/retyping.mli +++ b/pretyping/retyping.mli @@ -50,6 +50,6 @@ val type_of_global_reference_knowing_conclusion : val sorts_of_context : env -> evar_map -> rel_context -> Sorts.t list -val expand_projection : env -> evar_map -> Names.projection -> constr -> constr list -> constr +val expand_projection : env -> evar_map -> Names.Projection.t -> constr -> constr list -> constr val print_retype_error : retype_error -> Pp.t diff --git a/pretyping/tacred.ml b/pretyping/tacred.ml index 518d2f604..40c4cfaa4 100644 --- a/pretyping/tacred.ml +++ b/pretyping/tacred.ml @@ -12,7 +12,7 @@ open Pp open CErrors open Util open Names -open Term +open Constr open Libnames open Globnames open Termops @@ -416,7 +416,7 @@ exception Partial reduction is solved by the expanded fix term. *) let solve_arity_problem env sigma fxminargs c = let evm = ref sigma in - let set_fix i = evm := Evd.define i (Constr.mkVar vfx) !evm in + let set_fix i = evm := Evd.define i (mkVar vfx) !evm in let rec check strict c = let c' = whd_betaiotazeta sigma c in let (h,rcargs) = decompose_app_vect sigma c' in @@ -558,7 +558,7 @@ let match_eval_ref_value env sigma constr stack = else None | Proj (p, c) when not (Projection.unfolded p) -> - reduction_effect_hook env sigma (EConstr.to_constr sigma constr) + reduction_effect_hook env sigma (EConstr.to_constr ~abort_on_undefined_evars:false sigma constr) (lazy (EConstr.to_constr sigma (applist (constr,stack)))); if is_evaluable env (EvalConstRef (Projection.constant p)) then Some (mkProj (Projection.unfold p, c)) @@ -641,7 +641,7 @@ let whd_nothing_for_iota env sigma s = | _ -> s) | Evar ev -> s | Meta ev -> - (try whrec (EConstr.of_constr (Evd.meta_value sigma ev), stack) + (try whrec (Evd.meta_value sigma ev, stack) with Not_found -> s) | Const (const, u) when is_transparent_constant full_transparent_state const -> let u = EInstance.kind sigma u in @@ -1279,7 +1279,7 @@ let reduce_to_ref_gen allow_product env sigma ref t = error_cannot_recognize ref | _ -> try - if eq_gr (fst (global_of_constr sigma c)) ref + if GlobRef.equal (fst (global_of_constr sigma c)) ref then it_mkProd_or_LetIn t l else raise Not_found with Not_found -> diff --git a/pretyping/tacred.mli b/pretyping/tacred.mli index aa7604f53..e6065dda8 100644 --- a/pretyping/tacred.mli +++ b/pretyping/tacred.mli @@ -14,7 +14,6 @@ open Evd open EConstr open Reductionops open Pattern -open Globnames open Locus open Univ open Ltac_pretype @@ -30,13 +29,13 @@ exception ReductionTacticError of reduction_tactic_error val is_evaluable : Environ.env -> evaluable_global_reference -> bool -val error_not_evaluable : Globnames.global_reference -> 'a +val error_not_evaluable : GlobRef.t -> 'a val evaluable_of_global_reference : - Environ.env -> Globnames.global_reference -> evaluable_global_reference + Environ.env -> GlobRef.t -> evaluable_global_reference val global_of_evaluable_reference : - evaluable_global_reference -> Globnames.global_reference + evaluable_global_reference -> GlobRef.t exception Redelimination @@ -88,10 +87,10 @@ val reduce_to_quantified_ind : env -> evar_map -> types -> (inductive * EInstan (** [reduce_to_quantified_ref env sigma ref t] try to put [t] in the form [t'=(x1:A1)..(xn:An)(ref args)] and fails with user error if not possible *) val reduce_to_quantified_ref : - env -> evar_map -> global_reference -> types -> types + env -> evar_map -> GlobRef.t -> types -> types val reduce_to_atomic_ref : - env -> evar_map -> global_reference -> types -> types + env -> evar_map -> GlobRef.t -> types -> types val find_hnf_rectype : env -> evar_map -> types -> (inductive * EInstance.t) * constr list diff --git a/pretyping/typeclasses.ml b/pretyping/typeclasses.ml index 08051fd3a..d3aa7ac64 100644 --- a/pretyping/typeclasses.ml +++ b/pretyping/typeclasses.ml @@ -25,6 +25,13 @@ module RelDecl = Context.Rel.Declaration module NamedDecl = Context.Named.Declaration (*i*) +(* Core typeclasses hints *) +type 'a hint_info_gen = + { hint_priority : int option; + hint_pattern : 'a option } + +type hint_info = (Pattern.patvar list * Pattern.constr_pattern) hint_info_gen + let typeclasses_unique_solutions = ref false let set_typeclasses_unique_solutions d = (:=) typeclasses_unique_solutions d let get_typeclasses_unique_solutions () = !typeclasses_unique_solutions @@ -64,16 +71,16 @@ type typeclass = { cl_univs : Univ.AUContext.t; (* The class implementation *) - cl_impl : global_reference; + cl_impl : GlobRef.t; (* Context in which the definitions are typed. Includes both typeclass parameters and superclasses. *) - cl_context : global_reference option list * Context.Rel.t; + cl_context : GlobRef.t option list * Context.Rel.t; (* Context of definitions and properties on defs, will not be shared *) cl_props : Context.Rel.t; (* The method implementaions as projections. *) - cl_projs : (Name.t * (direction * Vernacexpr.hint_info_expr) option + cl_projs : (Name.t * (direction * hint_info) option * Constant.t option) list; cl_strict : bool; @@ -84,19 +91,19 @@ type typeclass = { type typeclasses = typeclass Refmap.t type instance = { - is_class: global_reference; - is_info: Vernacexpr.hint_info_expr; + is_class: GlobRef.t; + is_info: hint_info; (* Sections where the instance should be redeclared, None for discard, Some 0 for none. *) is_global: int option; - is_impl: global_reference; + is_impl: GlobRef.t; } type instances = (instance Refmap.t) Refmap.t let instance_impl is = is.is_impl -let hint_priority is = is.is_info.Vernacexpr.hint_priority +let hint_priority is = is.is_info.hint_priority let new_instance cl info glob impl = let global = @@ -158,7 +165,7 @@ let rec is_class_type evd c = | _ -> is_class_constr evd c let is_class_evar evd evi = - is_class_type evd (EConstr.of_constr evi.Evd.evar_concl) + is_class_type evd evi.Evd.evar_concl (* * classes persistent object @@ -173,12 +180,12 @@ let subst_class (subst,cl) = let do_subst_con c = Mod_subst.subst_constant subst c and do_subst c = Mod_subst.subst_mps subst c and do_subst_gr gr = fst (subst_global subst gr) in - let do_subst_ctx = List.smartmap (RelDecl.map_constr do_subst) in + let do_subst_ctx = List.Smart.map (RelDecl.map_constr do_subst) in let do_subst_context (grs,ctx) = - List.smartmap (Option.smartmap do_subst_gr) grs, + List.Smart.map (Option.Smart.map do_subst_gr) grs, do_subst_ctx ctx in - let do_subst_projs projs = List.smartmap (fun (x, y, z) -> - (x, y, Option.smartmap do_subst_con z)) projs in + let do_subst_projs projs = List.Smart.map (fun (x, y, z) -> + (x, y, Option.Smart.map do_subst_con z)) projs in { cl_univs = cl.cl_univs; cl_impl = do_subst_gr cl.cl_impl; cl_context = do_subst_context cl.cl_context; @@ -216,7 +223,7 @@ let discharge_class (_,cl) = | Some (_, ((tc,_), _)) -> Some tc.cl_impl) ctx' in - List.smartmap (Option.smartmap Lib.discharge_global) grs + List.Smart.map (Option.Smart.map Lib.discharge_global) grs @ newgrs in grs', discharge_rel_context subst 1 ctx @ ctx' in let cl_impl' = Lib.discharge_global cl.cl_impl in @@ -227,12 +234,12 @@ let discharge_class (_,cl) = let usubst, cl_univs' = Lib.discharge_abstract_universe_context info cl.cl_univs in let context = discharge_context ctx (subst, usubst) cl.cl_context in let props = discharge_rel_context (subst, usubst) (succ (List.length (fst cl.cl_context))) cl.cl_props in - let discharge_proj (x, y, z) = x, y, Option.smartmap Lib.discharge_con z in + let discharge_proj (x, y, z) = x, y, Option.Smart.map Lib.discharge_con z in { cl_univs = cl_univs'; cl_impl = cl_impl'; cl_context = context; cl_props = props; - cl_projs = List.smartmap discharge_proj cl.cl_projs; + cl_projs = List.Smart.map discharge_proj cl.cl_projs; cl_strict = cl.cl_strict; cl_unique = cl.cl_unique } @@ -266,8 +273,6 @@ let check_instance env sigma c = not (Evd.has_undefined evd) with e when CErrors.noncritical e -> false -open Vernacexpr - let build_subclasses ~check env sigma glob { hint_priority = pri } = let _id = Nametab.basename_of_global glob in let _next_id = @@ -276,7 +281,7 @@ let build_subclasses ~check env sigma glob { hint_priority = pri } = Nameops.add_suffix _id ("_subinstance_" ^ string_of_int !i)) in let ty, ctx = Global.type_of_global_in_context env glob in - let inst, ctx = Universes.fresh_instance_from ctx None in + let inst, ctx = UnivGen.fresh_instance_from ctx None in let ty = Vars.subst_instance_constr inst ty in let ty = EConstr.of_constr ty in let sigma = Evd.merge_context_set Evd.univ_rigid sigma ctx in @@ -316,7 +321,7 @@ let build_subclasses ~check env sigma glob { hint_priority = pri } = hints @ (path', info, body) :: rest in List.fold_left declare_proj [] projs in - let term = Universes.constr_of_global_univ (glob, inst) in + let term = UnivGen.constr_of_global_univ (glob, inst) in (*FIXME subclasses should now get substituted for each particular instance of the polymorphic superclass *) aux pri term ty [glob] @@ -475,7 +480,7 @@ let instances r = let cl = class_info r in instances_of cl let is_class gr = - Refmap.exists (fun _ v -> eq_gr v.cl_impl gr) !classes + Refmap.exists (fun _ v -> GlobRef.equal v.cl_impl gr) !classes let is_instance = function | ConstRef c -> diff --git a/pretyping/typeclasses.mli b/pretyping/typeclasses.mli index b80c28711..e4a56960c 100644 --- a/pretyping/typeclasses.mli +++ b/pretyping/typeclasses.mli @@ -16,6 +16,13 @@ open Environ type direction = Forward | Backward +(* Core typeclasses hints *) +type 'a hint_info_gen = + { hint_priority : int option; + hint_pattern : 'a option } + +type hint_info = (Pattern.patvar list * Pattern.constr_pattern) hint_info_gen + (** This module defines type-classes *) type typeclass = { (** The toplevel universe quantification in which the typeclass lives. In @@ -24,11 +31,11 @@ type typeclass = { (** The class implementation: a record parameterized by the context with defs in it or a definition if the class is a singleton. This acts as the class' global identifier. *) - cl_impl : global_reference; + cl_impl : GlobRef.t; (** Context in which the definitions are typed. Includes both typeclass parameters and superclasses. The global reference gives a direct link to the class itself. *) - cl_context : global_reference option list * Context.Rel.t; + cl_context : GlobRef.t option list * Context.Rel.t; (** Context of definitions and properties on defs, will not be shared *) cl_props : Context.Rel.t; @@ -37,7 +44,7 @@ type typeclass = { Some may be undefinable due to sorting restrictions or simply undefined if no name is provided. The [int option option] indicates subclasses whose hint has the given priority. *) - cl_projs : (Name.t * (direction * Vernacexpr.hint_info_expr) option * Constant.t option) list; + cl_projs : (Name.t * (direction * hint_info) option * Constant.t option) list; (** Whether we use matching or full unification during resolution *) cl_strict : bool; @@ -49,18 +56,17 @@ type typeclass = { type instance -val instances : global_reference -> instance list +val instances : GlobRef.t -> instance list val typeclasses : unit -> typeclass list val all_instances : unit -> instance list val add_class : typeclass -> unit -val new_instance : typeclass -> Vernacexpr.hint_info_expr -> bool -> - global_reference -> instance +val new_instance : typeclass -> hint_info -> bool -> GlobRef.t -> instance val add_instance : instance -> unit val remove_instance : instance -> unit -val class_info : global_reference -> typeclass (** raises a UserError if not a class *) +val class_info : GlobRef.t -> typeclass (** raises a UserError if not a class *) (** These raise a UserError if not a class. @@ -74,12 +80,12 @@ val typeclass_univ_instance : typeclass Univ.puniverses -> typeclass (** Just return None if not a class *) val class_of_constr : evar_map -> EConstr.constr -> (EConstr.rel_context * ((typeclass * EConstr.EInstance.t) * constr list)) option -val instance_impl : instance -> global_reference +val instance_impl : instance -> GlobRef.t val hint_priority : instance -> int option -val is_class : global_reference -> bool -val is_instance : global_reference -> bool +val is_class : GlobRef.t -> bool +val is_instance : GlobRef.t -> bool (** Returns the term and type for the given instance of the parameters and fields of the type class. *) @@ -121,24 +127,24 @@ val set_typeclass_transparency : evaluable_global_reference -> bool -> bool -> u val classes_transparent_state_hook : (unit -> transparent_state) Hook.t val classes_transparent_state : unit -> transparent_state -val add_instance_hint_hook : - (global_reference_or_constr -> global_reference list -> - bool (* local? *) -> Vernacexpr.hint_info_expr -> Decl_kinds.polymorphic -> unit) Hook.t -val remove_instance_hint_hook : (global_reference -> unit) Hook.t -val add_instance_hint : global_reference_or_constr -> global_reference list -> - bool -> Vernacexpr.hint_info_expr -> Decl_kinds.polymorphic -> unit -val remove_instance_hint : global_reference -> unit +val add_instance_hint_hook : + (global_reference_or_constr -> GlobRef.t list -> + bool (* local? *) -> hint_info -> Decl_kinds.polymorphic -> unit) Hook.t +val remove_instance_hint_hook : (GlobRef.t -> unit) Hook.t +val add_instance_hint : global_reference_or_constr -> GlobRef.t list -> + bool -> hint_info -> Decl_kinds.polymorphic -> unit +val remove_instance_hint : GlobRef.t -> unit val solve_all_instances_hook : (env -> evar_map -> evar_filter -> bool -> bool -> bool -> evar_map) Hook.t val solve_one_instance_hook : (env -> evar_map -> EConstr.types -> bool -> evar_map * EConstr.constr) Hook.t -val declare_instance : Vernacexpr.hint_info_expr option -> bool -> global_reference -> unit +val declare_instance : hint_info option -> bool -> GlobRef.t -> unit (** Build the subinstances hints for a given typeclass object. check tells if we should check for existence of the subinstances and add only the missing ones. *) -val build_subclasses : check:bool -> env -> evar_map -> global_reference -> - Vernacexpr.hint_info_expr -> - (global_reference list * Vernacexpr.hint_info_expr * constr) list +val build_subclasses : check:bool -> env -> evar_map -> GlobRef.t -> + hint_info -> + (GlobRef.t list * hint_info * constr) list diff --git a/pretyping/typeclasses_errors.ml b/pretyping/typeclasses_errors.ml index e10c81c24..2720a3e4d 100644 --- a/pretyping/typeclasses_errors.ml +++ b/pretyping/typeclasses_errors.ml @@ -9,18 +9,16 @@ (************************************************************************) (*i*) +open Names open EConstr open Environ -open Constrexpr -open Globnames (*i*) type contexts = Parameters | Properties type typeclass_error = | NotAClass of constr - | UnboundMethod of global_reference * Misctypes.lident (* Class name, method *) - | MismatchedContextInstance of contexts * constr_expr list * Context.Rel.t (* found, expected *) + | UnboundMethod of GlobRef.t * lident (* Class name, method *) exception TypeClassError of env * typeclass_error @@ -29,5 +27,3 @@ let typeclass_error env err = raise (TypeClassError (env, err)) let not_a_class env c = typeclass_error env (NotAClass c) let unbound_method env cid id = typeclass_error env (UnboundMethod (cid, id)) - -let mismatched_ctx_inst env c n m = typeclass_error env (MismatchedContextInstance (c, n, m)) diff --git a/pretyping/typeclasses_errors.mli b/pretyping/typeclasses_errors.mli index d98295658..9831627a9 100644 --- a/pretyping/typeclasses_errors.mli +++ b/pretyping/typeclasses_errors.mli @@ -8,23 +8,19 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) +open Names open EConstr open Environ -open Constrexpr -open Globnames type contexts = Parameters | Properties type typeclass_error = | NotAClass of constr - | UnboundMethod of global_reference * Misctypes.lident (** Class name, method *) - | MismatchedContextInstance of contexts * constr_expr list * Context.Rel.t (** found, expected *) + | UnboundMethod of GlobRef.t * lident (** Class name, method *) exception TypeClassError of env * typeclass_error val not_a_class : env -> constr -> 'a -val unbound_method : env -> global_reference -> Misctypes.lident -> 'a - -val mismatched_ctx_inst : env -> contexts -> constr_expr list -> Context.Rel.t -> 'a +val unbound_method : env -> GlobRef.t -> lident -> 'a diff --git a/pretyping/typing.ml b/pretyping/typing.ml index 4c834f2f8..cf34ac016 100644 --- a/pretyping/typing.ml +++ b/pretyping/typing.ml @@ -14,6 +14,7 @@ open Pp open CErrors open Util open Term +open Constr open Environ open EConstr open Vars @@ -29,113 +30,123 @@ let meta_type evd mv = let ty = try Evd.meta_ftype evd mv with Not_found -> anomaly (str "unknown meta ?" ++ str (Nameops.string_of_meta mv) ++ str ".") in - let ty = Evd.map_fl EConstr.of_constr ty in meta_instance evd ty let inductive_type_knowing_parameters env sigma (ind,u) jl = let u = Unsafe.to_instance u in let mspec = lookup_mind_specif env ind in - let paramstyp = Array.map (fun j -> lazy (EConstr.to_constr sigma j.uj_type)) jl in + let paramstyp = Array.map (fun j -> lazy (EConstr.to_constr ~abort_on_undefined_evars:false sigma j.uj_type)) jl in Inductive.type_of_inductive_knowing_parameters env (mspec,u) paramstyp -let e_type_judgment env evdref j = - match EConstr.kind !evdref (whd_all env !evdref j.uj_type) with - | Sort s -> {utj_val = j.uj_val; utj_type = ESorts.kind !evdref s } +let type_judgment env sigma j = + match EConstr.kind sigma (whd_all env sigma j.uj_type) with + | Sort s -> sigma, {utj_val = j.uj_val; utj_type = ESorts.kind sigma s } | Evar ev -> - let (evd,s) = Evardefine.define_evar_as_sort env !evdref ev in - evdref := evd; { utj_val = j.uj_val; utj_type = s } - | _ -> error_not_a_type env !evdref j - -let e_assumption_of_judgment env evdref j = - try (e_type_judgment env evdref j).utj_val + let (sigma,s) = Evardefine.define_evar_as_sort env sigma ev in + sigma, { utj_val = j.uj_val; utj_type = s } + | _ -> error_not_a_type env sigma j + +let assumption_of_judgment env sigma j = + try + let sigma, j = type_judgment env sigma j in + sigma, j.utj_val with Type_errors.TypeError _ | PretypeError _ -> - error_assumption env !evdref j + error_assumption env sigma j -let e_judge_of_applied_inductive_knowing_parameters env evdref funj ind argjv = - let rec apply_rec n typ = function +let judge_of_applied_inductive_knowing_parameters env sigma funj ind argjv = + let rec apply_rec sigma n typ = function | [] -> - { uj_val = mkApp (j_val funj, Array.map j_val argjv); - uj_type = - let ar = inductive_type_knowing_parameters env !evdref ind argjv in - hnf_prod_appvect env !evdref (EConstr.of_constr ar) (Array.map j_val argjv) } + sigma, { uj_val = mkApp (j_val funj, Array.map j_val argjv); + uj_type = + let ar = inductive_type_knowing_parameters env sigma ind argjv in + hnf_prod_appvect env sigma (EConstr.of_constr ar) (Array.map j_val argjv) } | hj::restjl -> - let (c1,c2) = - match EConstr.kind !evdref (whd_all env !evdref typ) with - | Prod (_,c1,c2) -> (c1,c2) + let sigma, (c1,c2) = + match EConstr.kind sigma (whd_all env sigma typ) with + | Prod (_,c1,c2) -> sigma, (c1,c2) | Evar ev -> - let (evd',t) = Evardefine.define_evar_as_product !evdref ev in - evdref := evd'; - let (_,c1,c2) = destProd evd' t in - (c1,c2) + let (sigma,t) = Evardefine.define_evar_as_product sigma ev in + let (_,c1,c2) = destProd sigma t in + sigma, (c1,c2) | _ -> - error_cant_apply_not_functional env !evdref funj argjv + error_cant_apply_not_functional env sigma funj argjv in - if Evarconv.e_cumul env evdref hj.uj_type c1 then - apply_rec (n+1) (subst1 hj.uj_val c2) restjl - else - error_cant_apply_bad_type env !evdref (n, c1, hj.uj_type) funj argjv + begin match Evarconv.cumul env sigma hj.uj_type c1 with + | Some sigma -> + apply_rec sigma (n+1) (subst1 hj.uj_val c2) restjl + | None -> + error_cant_apply_bad_type env sigma (n, c1, hj.uj_type) funj argjv + end in - apply_rec 1 funj.uj_type (Array.to_list argjv) + apply_rec sigma 1 funj.uj_type (Array.to_list argjv) -let e_judge_of_apply env evdref funj argjv = - let rec apply_rec n typ = function +let judge_of_apply env sigma funj argjv = + let rec apply_rec sigma n typ = function | [] -> - { uj_val = mkApp (j_val funj, Array.map j_val argjv); - uj_type = typ } + sigma, { uj_val = mkApp (j_val funj, Array.map j_val argjv); + uj_type = typ } | hj::restjl -> - let (c1,c2) = - match EConstr.kind !evdref (whd_all env !evdref typ) with - | Prod (_,c1,c2) -> (c1,c2) + let sigma, (c1,c2) = + match EConstr.kind sigma (whd_all env sigma typ) with + | Prod (_,c1,c2) -> sigma, (c1,c2) | Evar ev -> - let (evd',t) = Evardefine.define_evar_as_product !evdref ev in - evdref := evd'; - let (_,c1,c2) = destProd evd' t in - (c1,c2) + let (sigma,t) = Evardefine.define_evar_as_product sigma ev in + let (_,c1,c2) = destProd sigma t in + sigma, (c1,c2) | _ -> - error_cant_apply_not_functional env !evdref funj argjv + error_cant_apply_not_functional env sigma funj argjv in - if Evarconv.e_cumul env evdref hj.uj_type c1 then - apply_rec (n+1) (subst1 hj.uj_val c2) restjl - else - error_cant_apply_bad_type env !evdref (n, c1, hj.uj_type) funj argjv + begin match Evarconv.cumul env sigma hj.uj_type c1 with + | Some sigma -> + apply_rec sigma (n+1) (subst1 hj.uj_val c2) restjl + | None -> + error_cant_apply_bad_type env sigma (n, c1, hj.uj_type) funj argjv + end in - apply_rec 1 funj.uj_type (Array.to_list argjv) + apply_rec sigma 1 funj.uj_type (Array.to_list argjv) -let e_check_branch_types env evdref (ind,u) cj (lfj,explft) = +let check_branch_types env sigma (ind,u) cj (lfj,explft) = if not (Int.equal (Array.length lfj) (Array.length explft)) then - error_number_branches env !evdref cj (Array.length explft); - for i = 0 to Array.length explft - 1 do - if not (Evarconv.e_cumul env evdref lfj.(i).uj_type explft.(i)) then - error_ill_formed_branch env !evdref cj.uj_val ((ind,i+1),u) lfj.(i).uj_type explft.(i) - done + error_number_branches env sigma cj (Array.length explft); + Array.fold_left2_i (fun i sigma lfj explft -> + match Evarconv.cumul env sigma lfj.uj_type explft with + | Some sigma -> sigma + | None -> + error_ill_formed_branch env sigma cj.uj_val ((ind,i+1),u) lfj.uj_type explft) + sigma lfj explft let max_sort l = if Sorts.List.mem InType l then InType else if Sorts.List.mem InSet l then InSet else InProp -let e_is_correct_arity env evdref c pj ind specif params = - let arsign = make_arity_signature env !evdref true (make_ind_family (ind,params)) in +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 !evdref ind allowed_sorts c pj None in - let rec srec env pt ar = - let pt' = whd_all env !evdref pt in - match EConstr.kind !evdref pt', ar with + let error () = Pretype_errors.error_elim_arity env sigma ind allowed_sorts 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 | Prod (na1,a1,t), (LocalAssum (_,a1'))::ar' -> - if not (Evarconv.e_cumul env evdref a1 a1') then error (); - srec (push_rel (LocalAssum (na1,a1)) env) t ar' + begin match Evarconv.cumul env sigma a1 a1' with + | None -> error () + | Some sigma -> + srec (push_rel (LocalAssum (na1,a1)) env) sigma t ar' + end | Sort s, [] -> - let s = ESorts.kind !evdref s in + let s = ESorts.kind sigma s in if not (Sorts.List.mem (Sorts.family s) allowed_sorts) then error () + else sigma | Evar (ev,_), [] -> - let evd, s = Evd.fresh_sort_in_family env !evdref (max_sort allowed_sorts) in - evdref := Evd.define ev (Constr.mkSort s) evd + let sigma, s = Evd.fresh_sort_in_family env sigma (max_sort allowed_sorts) in + let sigma = Evd.define ev (mkSort s) sigma in + sigma | _, (LocalDef _ as d)::ar' -> - srec (push_rel d env) (lift 1 pt') ar' + srec (push_rel d env) sigma (lift 1 pt') ar' | _ -> error () in - srec env pj.uj_type (List.rev arsign) + srec env sigma pj.uj_type (List.rev arsign) let lambda_applist_assum sigma n c l = let rec app n subst t l = @@ -148,66 +159,70 @@ let lambda_applist_assum sigma n c l = | _ -> anomaly (Pp.str "Not enough lambda/let's.") in app n [] c l -let e_type_case_branches env evdref (ind,largs) pj c = +let type_case_branches env sigma (ind,largs) pj c = let specif = lookup_mind_specif env (fst ind) in let nparams = inductive_params specif in 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 () = e_is_correct_arity env evdref c pj ind specif params in - let lc = build_branches_type ind specif params (EConstr.to_constr !evdref p) in + let sigma = 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 !evdref (lambda_applist_assum !evdref (n+1) p (realargs@[c])) in - (lc, ty) + let ty = whd_betaiota sigma (lambda_applist_assum sigma (n+1) p (realargs@[c])) in + sigma, (lc, ty) -let e_judge_of_case env evdref ci pj cj lfj = +let judge_of_case env sigma ci pj cj lfj = let ((ind, u), spec) = - try find_mrectype env !evdref cj.uj_type - with Not_found -> error_case_not_inductive env !evdref cj in - let indspec = ((ind, EInstance.kind !evdref u), spec) in + 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 (bty,rslty) = e_type_case_branches env evdref indspec pj cj.uj_val in - e_check_branch_types env evdref (fst indspec) cj (lfj,bty); - { uj_val = mkCase (ci, pj.uj_val, cj.uj_val, Array.map j_val lfj); - uj_type = rslty } + let sigma, (bty,rslty) = type_case_branches env sigma indspec pj cj.uj_val 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 } -let check_type_fixpoint ?loc env evdref lna lar vdefj = +let check_type_fixpoint ?loc env sigma lna lar vdefj = let lt = Array.length vdefj in - if Int.equal (Array.length lar) lt then - for i = 0 to lt-1 do - if not (Evarconv.e_cumul env evdref (vdefj.(i)).uj_type - (lift lt lar.(i))) then - error_ill_typed_rec_body ?loc env !evdref - i lna vdefj lar - done + assert (Int.equal (Array.length lar) lt); + Array.fold_left2_i (fun i sigma defj ar -> + match Evarconv.cumul env sigma defj.uj_type (lift lt ar) with + | Some sigma -> sigma + | None -> + error_ill_typed_rec_body ?loc env sigma + i lna vdefj lar) + sigma vdefj lar + (* FIXME: might depend on the level of actual parameters!*) let check_allowed_sort env sigma ind c p = - let pj = Retyping.get_judgment_of env sigma p in - let ksort = Sorts.family (ESorts.kind sigma (sort_of_arity env sigma pj.uj_type)) in let specif = Global.lookup_inductive (fst ind) in let sorts = elim_sorts specif in + let pj = Retyping.get_judgment_of env sigma p in + 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 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)) -let e_judge_of_cast env evdref cj k tj = +let judge_of_cast env sigma cj k tj = let expected_type = tj.utj_val in - if not (Evarconv.e_cumul env evdref cj.uj_type expected_type) then - error_actual_type_core env !evdref cj expected_type; - { uj_val = mkCast (cj.uj_val, k, expected_type); - uj_type = expected_type } + match Evarconv.cumul env sigma cj.uj_type expected_type with + | None -> + error_actual_type_core env sigma cj expected_type; + | Some sigma -> + sigma, { uj_val = mkCast (cj.uj_val, k, expected_type); + uj_type = expected_type } -let enrich_env env evdref = - let penv = Environ.pre_env env in - let penv' = Pre_env.({ penv with env_stratification = - { penv.env_stratification with env_universes = Evd.universes !evdref } }) in - Environ.env_of_pre_env penv' +let enrich_env env sigma = + set_universes env @@ Evd.universes sigma let check_fix env sigma pfix = - let inj c = EConstr.to_constr sigma c in + let inj c = EConstr.to_constr ~abort_on_undefined_evars:false sigma c in let (idx, (ids, cs, ts)) = pfix in check_fix env (idx, (ids, Array.map inj cs, Array.map inj ts)) @@ -268,165 +283,167 @@ let judge_of_letin env name defj typj j = (* cstr must be in n.f. w.r.t. evars and execute returns a judgement where both the term and type are in n.f. *) -let rec execute env evdref cstr = - let cstr = whd_evar !evdref cstr in - match EConstr.kind !evdref cstr with +let rec execute env sigma cstr = + let cstr = whd_evar sigma cstr in + match EConstr.kind sigma cstr with | Meta n -> - { uj_val = cstr; uj_type = meta_type !evdref n } + sigma, { uj_val = cstr; uj_type = meta_type sigma n } | Evar ev -> - let ty = EConstr.existential_type !evdref ev in - let jty = execute env evdref ty in - let jty = e_assumption_of_judgment env evdref jty in - { uj_val = cstr; uj_type = jty } + let ty = EConstr.existential_type sigma ev in + let sigma, jty = execute env sigma ty in + let sigma, jty = assumption_of_judgment env sigma jty in + sigma, { uj_val = cstr; uj_type = jty } | Rel n -> - judge_of_relative env n + sigma, judge_of_relative env n | Var id -> - judge_of_variable env id + sigma, judge_of_variable env id | Const (c, u) -> - let u = EInstance.kind !evdref u in - make_judge cstr (EConstr.of_constr (rename_type_of_constant env (c, u))) + let u = EInstance.kind sigma u in + sigma, make_judge cstr (EConstr.of_constr (rename_type_of_constant env (c, u))) | Ind (ind, u) -> - let u = EInstance.kind !evdref u in - make_judge cstr (EConstr.of_constr (rename_type_of_inductive env (ind, u))) + let u = EInstance.kind sigma u in + sigma, make_judge cstr (EConstr.of_constr (rename_type_of_inductive env (ind, u))) | Construct (cstruct, u) -> - let u = EInstance.kind !evdref u in - make_judge cstr (EConstr.of_constr (rename_type_of_constructor env (cstruct, u))) + let u = EInstance.kind sigma u in + sigma, make_judge cstr (EConstr.of_constr (rename_type_of_constructor env (cstruct, u))) | Case (ci,p,c,lf) -> - let cj = execute env evdref c in - let pj = execute env evdref p in - let lfj = execute_array env evdref lf in - e_judge_of_case env evdref ci pj cj lfj + let sigma, cj = execute env sigma c in + let sigma, pj = execute env sigma p in + let sigma, lfj = execute_array env sigma lf in + judge_of_case env sigma ci pj cj lfj | Fix ((vn,i as vni),recdef) -> - let (_,tys,_ as recdef') = execute_recdef env evdref recdef in + let sigma, (_,tys,_ as recdef') = execute_recdef env sigma recdef in let fix = (vni,recdef') in - check_fix env !evdref fix; - make_judge (mkFix fix) tys.(i) + check_fix env sigma fix; + sigma, make_judge (mkFix fix) tys.(i) | CoFix (i,recdef) -> - let (_,tys,_ as recdef') = execute_recdef env evdref recdef in + let sigma, (_,tys,_ as recdef') = execute_recdef env sigma recdef in let cofix = (i,recdef') in - check_cofix env !evdref cofix; - make_judge (mkCoFix cofix) tys.(i) + check_cofix env sigma cofix; + sigma, make_judge (mkCoFix cofix) tys.(i) | Sort s -> - begin match ESorts.kind !evdref s with + begin match ESorts.kind sigma s with | Prop c -> - judge_of_prop_contents c + sigma, judge_of_prop_contents c | Type u -> - judge_of_type u + sigma, judge_of_type u end | Proj (p, c) -> - let cj = execute env evdref c in - judge_of_projection env !evdref p cj + let sigma, cj = execute env sigma c in + sigma, judge_of_projection env sigma p cj | App (f,args) -> - let jl = execute_array env evdref args in - (match EConstr.kind !evdref f with + let sigma, jl = execute_array env sigma args in + (match EConstr.kind sigma f with | Ind (ind, u) when EInstance.is_empty u && Environ.template_polymorphic_ind ind env -> - let fj = execute env evdref f in - e_judge_of_applied_inductive_knowing_parameters env evdref fj (ind, u) jl + let sigma, fj = execute env sigma f in + judge_of_applied_inductive_knowing_parameters env sigma fj (ind, u) jl | _ -> (* No template polymorphism *) - let fj = execute env evdref f in - e_judge_of_apply env evdref fj jl) + let sigma, fj = execute env sigma f in + judge_of_apply env sigma fj jl) | Lambda (name,c1,c2) -> - let j = execute env evdref c1 in - let var = e_type_judgment env evdref j in + 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 j' = execute env1 evdref c2 in - judge_of_abstraction env1 name var j' + let sigma, j' = execute env1 sigma c2 in + sigma, judge_of_abstraction env1 name var j' | Prod (name,c1,c2) -> - let j = execute env evdref c1 in - let varj = e_type_judgment env evdref j in + 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 j' = execute env1 evdref c2 in - let varj' = e_type_judgment env1 evdref j' in - judge_of_product env name varj varj' + 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' | LetIn (name,c1,c2,c3) -> - let j1 = execute env evdref c1 in - let j2 = execute env evdref c2 in - let j2 = e_type_judgment env evdref j2 in - let _ = e_judge_of_cast env evdref j1 DEFAULTcast j2 in + 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 env1 = push_rel (LocalDef (name, j1.uj_val, j2.utj_val)) env in - let j3 = execute env1 evdref c3 in - judge_of_letin env name j1 j2 j3 + let sigma, j3 = execute env1 sigma c3 in + sigma, judge_of_letin env name j1 j2 j3 | Cast (c,k,t) -> - let cj = execute env evdref c in - let tj = execute env evdref t in - let tj = e_type_judgment env evdref tj in - e_judge_of_cast env evdref cj k tj - -and execute_recdef env evdref (names,lar,vdef) = - let larj = execute_array env evdref lar in - let lara = Array.map (e_assumption_of_judgment env evdref) larj in + let sigma, cj = execute env sigma c in + let sigma, tj = execute env sigma t in + let sigma, tj = type_judgment env sigma tj in + judge_of_cast env sigma cj k tj + +and execute_recdef env sigma (names,lar,vdef) = + let sigma, larj = execute_array env sigma lar in + let sigma, lara = Array.fold_left_map (assumption_of_judgment env) sigma larj in let env1 = push_rec_types (names,lara,vdef) env in - let vdefj = execute_array env1 evdref vdef in + let sigma, vdefj = execute_array env1 sigma vdef in let vdefv = Array.map j_val vdefj in - let _ = check_type_fixpoint env1 evdref names lara vdefj in - (names,lara,vdefv) + let sigma = check_type_fixpoint env1 sigma names lara vdefj in + sigma, (names,lara,vdefv) + +and execute_array env = Array.fold_left_map (execute env) -and execute_array env evdref = Array.map (execute env evdref) +let check env sigma c t = + let env = enrich_env env sigma in + let sigma, j = execute env sigma c in + match Evarconv.cumul env sigma j.uj_type t with + | None -> + error_actual_type_core env sigma j t + | Some sigma -> sigma let e_check env evdref c t = - let env = enrich_env env evdref in - let j = execute env evdref c in - if not (Evarconv.e_cumul env evdref j.uj_type t) then - error_actual_type_core env !evdref j t + evdref := check env !evdref c t (* Type of a constr *) -let unsafe_type_of env evd c = - let evdref = ref evd in - let env = enrich_env env evdref in - let j = execute env evdref c in - j.uj_type +let unsafe_type_of env sigma c = + let env = enrich_env env sigma in + let sigma, j = execute env sigma c in + j.uj_type (* Sort of a type *) +let sort_of env sigma c = + let env = enrich_env env sigma in + let sigma, j = execute env sigma c in + let sigma, a = type_judgment env sigma j in + sigma, a.utj_type + let e_sort_of env evdref c = - let env = enrich_env env evdref in - let j = execute env evdref c in - let a = e_type_judgment env evdref j in - a.utj_type + Evarutil.evd_comb1 (sort_of env) evdref c (* Try to solve the existential variables by typing *) -let type_of ?(refresh=false) env evd c = - let evdref = ref evd in - let env = enrich_env env evdref in - let j = execute env evdref c in +let type_of ?(refresh=false) env sigma c = + let env = enrich_env env sigma in + let sigma, j = execute env sigma c in (* side-effect on evdref *) if refresh then - Evarsolve.refresh_universes ~onlyalg:true (Some false) env !evdref j.uj_type - else !evdref, j.uj_type + Evarsolve.refresh_universes ~onlyalg:true (Some false) env sigma j.uj_type + else sigma, j.uj_type -let e_type_of ?(refresh=false) env evdref c = - let env = enrich_env env evdref in - let j = execute env evdref c in +let e_type_of ?refresh env evdref c = + Evarutil.evd_comb1 (type_of ?refresh env) evdref c + +let solve_evars env sigma c = + let env = enrich_env env sigma in + let sigma, j = execute env sigma c in (* side-effect on evdref *) - if refresh then - let evd, c = Evarsolve.refresh_universes ~onlyalg:true (Some false) env !evdref j.uj_type in - let () = evdref := evd in - c - else j.uj_type + sigma, nf_evar sigma j.uj_val let e_solve_evars env evdref c = - let env = enrich_env env evdref in - let c = (execute env evdref c).uj_val in - (* side-effect on evdref *) - nf_evar !evdref c + Evarutil.evd_comb1 (solve_evars env) evdref c -let _ = Evarconv.set_solve_evars (fun env evdref c -> e_solve_evars env evdref c) +let _ = Evarconv.set_solve_evars (fun env sigma c -> solve_evars env sigma c) diff --git a/pretyping/typing.mli b/pretyping/typing.mli index fe83a2cc8..3cf43ace0 100644 --- a/pretyping/typing.mli +++ b/pretyping/typing.mli @@ -26,18 +26,25 @@ val type_of : ?refresh:bool -> env -> evar_map -> constr -> evar_map * types (** Variant of [type_of] using references instead of state-passing. *) val e_type_of : ?refresh:bool -> env -> evar_map ref -> constr -> types +[@@ocaml.deprecated "Use [Typing.type_of]"] (** Typecheck a type and return its sort *) +val sort_of : env -> evar_map -> types -> evar_map * Sorts.t val e_sort_of : env -> evar_map ref -> types -> Sorts.t +[@@ocaml.deprecated "Use [Typing.sort_of]"] (** Typecheck a term has a given type (assuming the type is OK) *) +val check : env -> evar_map -> constr -> types -> evar_map val e_check : env -> evar_map ref -> constr -> types -> unit +[@@ocaml.deprecated "Use [Typing.check]"] (** Returns the instantiated type of a metavariable *) val meta_type : evar_map -> metavariable -> types (** Solve existential variables using typing *) +val solve_evars : env -> evar_map -> constr -> evar_map * constr val e_solve_evars : env -> evar_map ref -> constr -> constr +[@@ocaml.deprecated "Use [Typing.solve_evars]"] (** Raise an error message if incorrect elimination for this inductive *) (** (first constr is term to match, second is return predicate) *) @@ -46,8 +53,8 @@ val check_allowed_sort : env -> evar_map -> pinductive -> constr -> constr -> (** Raise an error message if bodies have types not unifiable with the expected ones *) -val check_type_fixpoint : ?loc:Loc.t -> env -> evar_map ref -> - Names.Name.t array -> types array -> unsafe_judgment array -> unit +val check_type_fixpoint : ?loc:Loc.t -> env -> evar_map -> + Names.Name.t array -> types array -> unsafe_judgment array -> evar_map val judge_of_prop : unsafe_judgment val judge_of_set : unsafe_judgment @@ -55,4 +62,4 @@ val judge_of_abstraction : Environ.env -> Name.t -> unsafe_type_judgment -> unsafe_judgment -> unsafe_judgment val judge_of_product : Environ.env -> Name.t -> unsafe_type_judgment -> unsafe_type_judgment -> unsafe_judgment -val judge_of_projection : env -> evar_map -> projection -> unsafe_judgment -> unsafe_judgment +val judge_of_projection : env -> evar_map -> Projection.t -> unsafe_judgment -> unsafe_judgment diff --git a/pretyping/unification.ml b/pretyping/unification.ml index f2f922fd5..5cf6e4b26 100644 --- a/pretyping/unification.ml +++ b/pretyping/unification.ml @@ -84,7 +84,7 @@ let occur_meta_or_undefined_evar evd c = | Evar (ev,args) -> (match evar_body (Evd.find evd ev) with | Evar_defined c -> - occrec c; Array.iter occrec args + occrec (EConstr.Unsafe.to_constr c); Array.iter occrec args | Evar_empty -> raise Occur) | _ -> Constr.iter occrec c in try occrec c; false with Occur | Not_found -> true @@ -189,18 +189,17 @@ let pose_all_metas_as_evars env evd t = let rec aux t = match EConstr.kind !evdref t with | Meta mv -> (match Evd.meta_opt_fvalue !evdref mv with - | Some ({rebus=c},_) -> EConstr.of_constr c + | Some ({rebus=c},_) -> c | None -> let {rebus=ty;freemetas=mvs} = Evd.meta_ftype evd mv in - let ty = EConstr.of_constr ty in let ty = if Evd.Metaset.is_empty mvs then ty else aux ty in let ty = if Flags.version_strictly_greater Flags.V8_6 then nf_betaiota env evd ty (* How it was in Coq <= 8.4 (but done in logic.ml at this time) *) else ty (* some beta-iota-normalization "regression" in 8.5 and 8.6 *) in let src = Evd.evar_source_of_meta mv !evdref in - let ev = Evarutil.e_new_evar env evdref ~src ty in - evdref := meta_assign mv (EConstr.Unsafe.to_constr ev,(Conv,TypeNotProcessed)) !evdref; + let evd, ev = Evarutil.new_evar env !evdref ~src ty in + evdref := meta_assign mv (ev,(Conv,TypeNotProcessed)) evd; ev) | _ -> EConstr.map !evdref aux t in @@ -399,8 +398,13 @@ let default_no_delta_core_unify_flags () = { (default_core_unify_flags ()) with modulo_betaiota = false; } -let default_no_delta_unify_flags () = - let flags = default_no_delta_core_unify_flags () in { +let default_no_delta_unify_flags ts = + let flags = default_no_delta_core_unify_flags () in + let flags = { flags with + modulo_conv_on_closed_terms = Some ts; + modulo_delta_types = ts + } in + { core_unify_flags = flags; merge_unify_flags = flags; subterm_unify_flags = flags; @@ -466,7 +470,7 @@ let use_metas_pattern_unification sigma flags nb l = type key = | IsKey of CClosure.table_key - | IsProj of projection * EConstr.constr + | IsProj of Projection.t * EConstr.constr let expand_table_key env = function | ConstKey cst -> constant_opt_value_in env cst @@ -562,16 +566,16 @@ let is_rigid_head sigma flags t = | Proj (_, _) -> false (* Why aren't Prod, Sort rigid heads ? *) let force_eqs c = - let open Universes in - Constraints.fold + let open UnivProblem in + Set.fold (fun c acc -> let c' = match c with (* Should we be forcing weak constraints? *) | ULub (l, r) | UWeak (l, r) -> UEq (Univ.Universe.make l,Univ.Universe.make r) | ULe _ | UEq _ -> c in - Constraints.add c' acc) - c Constraints.empty + Set.add c' acc) + c Set.empty let constr_cmp pb env sigma flags t u = let cstrs = @@ -580,16 +584,16 @@ let constr_cmp pb env sigma flags t u = in match cstrs with | Some cstrs -> - begin try Evd.add_universe_constraints sigma cstrs, true - with Univ.UniverseInconsistency _ -> sigma, false + begin try Some (Evd.add_universe_constraints sigma cstrs) + with Univ.UniverseInconsistency _ -> None | Evd.UniversesDiffer -> if is_rigid_head sigma flags t then - try Evd.add_universe_constraints sigma (force_eqs cstrs), true - with Univ.UniverseInconsistency _ -> sigma, false - else sigma, false + try Some (Evd.add_universe_constraints sigma (force_eqs cstrs)) + with Univ.UniverseInconsistency _ -> None + else None end | None -> - sigma, false + None let do_reduce ts (env, nb) sigma c = Stack.zip sigma (fst (whd_betaiota_deltazeta_for_iota_state @@ -624,9 +628,9 @@ let check_compatibility env pbty flags (sigma,metasubst,evarsubst : subst0) tyM | None -> sigma | Some n -> if is_ground_term sigma m && is_ground_term sigma n then - let sigma, b = infer_conv ~pb:pbty ~ts:flags.modulo_delta_types env sigma m n in - if b then sigma - else error_cannot_unify env sigma (m,n) + match infer_conv ~pb:pbty ~ts:flags.modulo_delta_types env sigma m n with + | Some sigma -> sigma + | None -> error_cannot_unify env sigma (m,n) else sigma @@ -699,7 +703,7 @@ let rec unify_0_with_initial_metas (sigma,ms,es as subst : subst0) conv_at_top e if k2 < k1 then sigma,(k1,cN,stN)::metasubst,evarsubst else sigma,(k2,cM,stM)::metasubst,evarsubst | Meta k, _ - when not (dependent sigma cM cN) (* helps early trying alternatives *) -> + when not (occur_metavariable sigma k cN) (* helps early trying alternatives *) -> let sigma = if opt.with_types && flags.check_applied_meta_types then (try @@ -719,7 +723,7 @@ let rec unify_0_with_initial_metas (sigma,ms,es as subst : subst0) conv_at_top e evarsubst) else error_cannot_unify_local curenv sigma (m,n,cN) | _, Meta k - when not (dependent sigma cN cM) (* helps early trying alternatives *) -> + when not (occur_metavariable sigma k cM) (* helps early trying alternatives *) -> let sigma = if opt.with_types && flags.check_applied_meta_types then (try @@ -741,11 +745,12 @@ let rec unify_0_with_initial_metas (sigma,ms,es as subst : subst0) conv_at_top e | Evar (evk,_ as ev), Evar (evk',_) when not (Evar.Set.mem evk flags.frozen_evars) && Evar.equal evk evk' -> - let sigma',b = constr_cmp cv_pb env sigma flags cM cN in - if b then - sigma',metasubst,evarsubst - else + begin match constr_cmp cv_pb env sigma flags cM cN with + | Some sigma -> + sigma, metasubst, evarsubst + | None -> sigma,metasubst,((curenv,ev,cN)::evarsubst) + end | Evar (evk,_ as ev), _ when not (Evar.Set.mem evk flags.frozen_evars) && not (occur_evar sigma evk cN) -> @@ -838,6 +843,26 @@ let rec unify_0_with_initial_metas (sigma,ms,es as subst : subst0) conv_at_top e with ex when precatchable_exception ex -> reduce curenvnb pb opt substn cM cN) + | Fix ((ln1,i1),(lna1,tl1,bl1)), Fix ((ln2,i2),(_,tl2,bl2)) when + Int.equal i1 i2 && Array.equal Int.equal ln1 ln2 -> + (try + let opt' = {opt with at_top = true; with_types = false} in + let curenvnb' = Array.fold_right2 (fun na t -> push (na,t)) lna1 tl1 curenvnb in + Array.fold_left2 (unirec_rec curenvnb' CONV opt') + (Array.fold_left2 (unirec_rec curenvnb CONV opt') substn tl1 tl2) bl1 bl2 + with ex when precatchable_exception ex -> + reduce curenvnb pb opt substn cM cN) + + | CoFix (i1,(lna1,tl1,bl1)), CoFix (i2,(_,tl2,bl2)) when + Int.equal i1 i2 -> + (try + let opt' = {opt with at_top = true; with_types = false} in + let curenvnb' = Array.fold_right2 (fun na t -> push (na,t)) lna1 tl1 curenvnb in + Array.fold_left2 (unirec_rec curenvnb' CONV opt') + (Array.fold_left2 (unirec_rec curenvnb CONV opt') substn tl1 tl2) bl1 bl2 + with ex when precatchable_exception ex -> + reduce curenvnb pb opt substn cM cN) + | App (f1,l1), _ when (isMeta sigma f1 && use_metas_pattern_unification sigma flags nb l1 || use_evars_pattern_unification flags && isAllowedEvar sigma flags f1) -> @@ -923,9 +948,9 @@ let rec unify_0_with_initial_metas (sigma,ms,es as subst : subst0) conv_at_top e and unify_not_same_head curenvnb pb opt (sigma, metas, evars as substn : subst0) cM cN = try canonical_projections curenvnb pb opt cM cN substn with ex when precatchable_exception ex -> - let sigma', b = constr_cmp cv_pb env sigma flags cM cN in - if b then (sigma', metas, evars) - else + match constr_cmp cv_pb env sigma flags cM cN with + | Some sigma -> (sigma, metas, evars) + | None -> try reduce curenvnb pb opt substn cM cN with ex when precatchable_exception ex -> let (f1,l1) = @@ -982,12 +1007,13 @@ let rec unify_0_with_initial_metas (sigma,ms,es as subst : subst0) conv_at_top e (* Renounce, maybe metas/evars prevents typing *) sigma else sigma in - let sigma, b = infer_conv ~pb ~ts:convflags curenv sigma m1 n1 in - if b then Some (sigma, metasubst, evarsubst) - else - if is_ground_term sigma m1 && is_ground_term sigma n1 then - error_cannot_unify curenv sigma (cM,cN) - else None + match infer_conv ~pb ~ts:convflags curenv sigma m1 n1 with + | Some sigma -> + Some (sigma, metasubst, evarsubst) + | None -> + if is_ground_term sigma m1 && is_ground_term sigma n1 then + error_cannot_unify curenv sigma (cM,cN) + else None in match res with | Some substn -> substn @@ -1060,7 +1086,7 @@ let rec unify_0_with_initial_metas (sigma,ms,es as subst : subst0) conv_at_top e (evd,t2::ks, m-1) else let mv = new_meta () in - let evd' = meta_declare mv (EConstr.Unsafe.to_constr (substl ks b)) evd in + let evd' = meta_declare mv (substl ks b) evd in (evd', mkMeta mv :: ks, m - 1)) (sigma,[],List.length bs) bs in @@ -1090,11 +1116,13 @@ let rec unify_0_with_initial_metas (sigma,ms,es as subst : subst0) conv_at_top e then None else - let sigma, b = match flags.modulo_conv_on_closed_terms with + let ans = match flags.modulo_conv_on_closed_terms with | Some convflags -> infer_conv ~pb:cv_pb ~ts:convflags env sigma m n | _ -> constr_cmp cv_pb env sigma flags m n in - if b then Some sigma - else if (match flags.modulo_conv_on_closed_terms, flags.modulo_delta with + match ans with + | Some sigma -> ans + | None -> + if (match flags.modulo_conv_on_closed_terms, flags.modulo_delta with | Some (cv_id, cv_k), (dl_id, dl_k) -> Id.Pred.subset dl_id cv_id && Cpred.subset dl_k cv_k | None,(dl_id, dl_k) -> @@ -1247,7 +1275,7 @@ let try_to_coerce env evd c cty tycon = let j = make_judge c cty in let (evd',j') = inh_conv_coerce_rigid_to true env evd j tycon in let evd' = Evarconv.solve_unif_constraints_with_heuristics env evd' in - let evd' = Evd.map_metas_fvalue (fun c -> EConstr.Unsafe.to_constr (nf_evar evd' (EConstr.of_constr c))) evd' in + let evd' = Evd.map_metas_fvalue (fun c -> nf_evar evd' c) evd' in (evd',j'.uj_val) let w_coerce_to_type env evd c cty mvty = @@ -1359,11 +1387,11 @@ let w_merge env with_types flags (evd,metas,evars : subst0) = if meta_defined evd mv then let {rebus=c'},(status',_) = meta_fvalue evd mv in let (take_left,st,(evd,metas',evars')) = - merge_instances env evd flags status' status (EConstr.of_constr c') c + merge_instances env evd flags status' status c' c in let evd' = if take_left then evd - else meta_reassign mv (EConstr.Unsafe.to_constr c,(st,TypeProcessed)) evd + else meta_reassign mv (c,(st,TypeProcessed)) evd in w_merge_rec evd' (metas'@metas@metas'') (evars'@evars'') eqns else @@ -1372,7 +1400,7 @@ let w_merge env with_types flags (evd,metas,evars : subst0) = if isMetaOf evd mv (whd_all env evd c) then evd else error_cannot_unify env evd (mkMeta mv,c) else - meta_assign mv (EConstr.Unsafe.to_constr c,(status,TypeProcessed)) evd in + meta_assign mv (c,(status,TypeProcessed)) evd in w_merge_rec evd' (metas''@metas) evars'' eqns | [] -> (* Process type eqns *) @@ -1392,21 +1420,21 @@ let w_merge env with_types flags (evd,metas,evars : subst0) = and mimick_undefined_evar evd flags hdc nargs sp = let ev = Evd.find_undefined evd sp in - let sp_env = Global.env_of_context ev.evar_hyps in + let sp_env = Global.env_of_context (evar_filtered_hyps ev) in let (evd', c) = applyHead sp_env evd nargs hdc in let (evd'',mc,ec) = unify_0 sp_env evd' CUMUL flags - (get_type_of sp_env evd' c) (EConstr.of_constr ev.evar_concl) in + (get_type_of sp_env evd' c) ev.evar_concl in let evd''' = w_merge_rec evd'' mc ec [] in if evd' == evd''' - then Evd.define sp (EConstr.Unsafe.to_constr c) evd''' - else Evd.define sp (EConstr.Unsafe.to_constr (Evarutil.nf_evar evd''' c)) evd''' in + then Evd.define sp c evd''' + else Evd.define sp (Evarutil.nf_evar evd''' c) evd''' in let check_types evd = let metas = Evd.meta_list evd in let eqns = List.fold_left (fun acc (mv, b) -> match b with - | Clval (n, (t, (c, TypeNotProcessed)), v) -> (mv, c, EConstr.of_constr t.rebus) :: acc + | Clval (n, (t, (c, TypeNotProcessed)), v) -> (mv, c, t.rebus) :: acc | _ -> acc) [] metas in w_merge_rec evd [] [] eqns in @@ -1417,11 +1445,6 @@ let w_merge env with_types flags (evd,metas,evars : subst0) = in if with_types then check_types res else res -let retract_coercible_metas evd = - let (metas, evd) = retract_coercible_metas evd in - let map (mv, c, st) = (mv, EConstr.of_constr c, st) in - (List.map map metas, evd) - let w_unify_meta_types env ?(flags=default_unify_flags ()) evd = let metas,evd = retract_coercible_metas evd in w_merge env true flags.merge_unify_flags (evd,metas,[]) @@ -1506,12 +1529,12 @@ let indirectly_dependent sigma c d decls = it is needed otherwise, as e.g. when abstracting over "2" in "forall H:0=2, H=H:>(0=1+1) -> 0=2." where there is now obvious way to see that the second hypothesis depends indirectly over 2 *) - List.exists (fun d' -> dependent_in_decl sigma (EConstr.mkVar (NamedDecl.get_id d')) d) decls + let open Context.Named.Declaration in + List.exists (fun d' -> exists (fun c -> Termops.local_occur_var sigma (NamedDecl.get_id d') c) d) decls let finish_evar_resolution ?(flags=Pretyping.all_and_fail_flags) env current_sigma (pending,c) = let sigma = Pretyping.solve_remaining_evars flags env current_sigma pending in - let sigma, subst = nf_univ_variables sigma in - (sigma, EConstr.of_constr (Universes.subst_univs_constr subst (EConstr.Unsafe.to_constr (nf_evar sigma c)))) + (sigma, nf_evar sigma c) let default_matching_core_flags sigma = let ts = Names.full_transparent_state in { @@ -1589,8 +1612,10 @@ let make_pattern_test from_prefix_of_ind is_correct_type env sigma (pending,c) = let merge_fun c1 c2 = match c1, c2 with | Some (evd,c1,x), Some (_,c2,_) -> - let (evd,b) = infer_conv ~pb:CONV env evd c1 c2 in - if b then Some (evd, c1, x) else raise (NotUnifiable None) + begin match infer_conv ~pb:CONV env evd c1 c2 with + | Some evd -> Some (evd, c1, x) + | None -> raise (NotUnifiable None) + end | Some _, None -> c1 | None, Some _ -> c2 | None, None -> None in @@ -1599,9 +1624,8 @@ let make_pattern_test from_prefix_of_ind is_correct_type env sigma (pending,c) = (fun test -> match test.testing_state with | None -> None | Some (sigma,_,l) -> - let c = applist (nf_evar sigma (local_strong whd_meta sigma c), l) in - let univs, subst = nf_univ_variables sigma in - Some (sigma,EConstr.of_constr (Universes.subst_univs_constr subst (EConstr.Unsafe.to_constr c)))) + let c = applist (local_strong whd_meta sigma c, l) in + Some (sigma, c)) let make_eq_test env evd c = let out cstr = @@ -1908,10 +1932,11 @@ let secondOrderAbstraction env evd flags typ (p, oplist) = let (evd',cllist) = w_unify_to_subterm_list env evd flags p oplist typ in let typp = Typing.meta_type evd' p in let evd',(pred,predtyp) = abstract_list_all env evd' typp typ cllist in - let evd', b = infer_conv ~pb:CUMUL env evd' predtyp typp in - if not b then + match infer_conv ~pb:CUMUL env evd' predtyp typp with + | None -> error_wrong_abstraction_type env evd' (Evd.meta_name evd p) pred typp predtyp; + | Some evd' -> w_merge env false flags.merge_unify_flags (evd',[p,pred,(Conv,TypeProcessed)],[]) diff --git a/pretyping/unification.mli b/pretyping/unification.mli index 16ce5c93d..e2e261ae7 100644 --- a/pretyping/unification.mli +++ b/pretyping/unification.mli @@ -8,6 +8,7 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) +open Names open Constr open EConstr open Environ @@ -40,7 +41,7 @@ val default_core_unify_flags : unit -> core_unify_flags val default_no_delta_core_unify_flags : unit -> core_unify_flags val default_unify_flags : unit -> unify_flags -val default_no_delta_unify_flags : unit -> unify_flags +val default_no_delta_unify_flags : transparent_state -> unify_flags val elim_flags : unit -> unify_flags val elim_no_delta_flags : unit -> unify_flags diff --git a/pretyping/univdecls.ml b/pretyping/univdecls.ml deleted file mode 100644 index 8864be576..000000000 --- a/pretyping/univdecls.ml +++ /dev/null @@ -1,52 +0,0 @@ -(************************************************************************) -(* * The Coq Proof Assistant / The Coq Development Team *) -(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) -(* <O___,, * (see CREDITS file for the list of authors) *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(* * (see LICENSE file for the text of the license) *) -(************************************************************************) - -open CErrors - -(** Local universes and constraints declarations *) -type universe_decl = - (Misctypes.lident list, Univ.Constraint.t) Misctypes.gen_universe_decl - -let default_univ_decl = - let open Misctypes in - { univdecl_instance = []; - univdecl_extensible_instance = true; - univdecl_constraints = Univ.Constraint.empty; - univdecl_extensible_constraints = true } - -let interp_univ_constraints env evd cstrs = - let interp (evd,cstrs) (u, d, u') = - let ul = Pretyping.interp_known_glob_level evd u in - let u'l = Pretyping.interp_known_glob_level evd u' in - let cstr = (ul,d,u'l) in - let cstrs' = Univ.Constraint.add cstr cstrs in - try let evd = Evd.add_constraints evd (Univ.Constraint.singleton cstr) in - evd, cstrs' - with Univ.UniverseInconsistency e -> - user_err ~hdr:"interp_constraint" - (Univ.explain_universe_inconsistency (Termops.pr_evd_level evd) e) - in - List.fold_left interp (evd,Univ.Constraint.empty) cstrs - -let interp_univ_decl env decl = - let open Misctypes in - let pl : lident list = decl.univdecl_instance in - let evd = Evd.from_ctx (UState.make_with_initial_binders (Environ.universes env) pl) in - let evd, cstrs = interp_univ_constraints env evd decl.univdecl_constraints in - let decl = { univdecl_instance = pl; - univdecl_extensible_instance = decl.univdecl_extensible_instance; - univdecl_constraints = cstrs; - univdecl_extensible_constraints = decl.univdecl_extensible_constraints } - in evd, decl - -let interp_univ_decl_opt env l = - match l with - | None -> Evd.from_env env, default_univ_decl - | Some decl -> interp_univ_decl env decl diff --git a/pretyping/vnorm.ml b/pretyping/vnorm.ml index 3c9b8bc33..14c9f49b1 100644 --- a/pretyping/vnorm.ml +++ b/pretyping/vnorm.ml @@ -205,7 +205,7 @@ and nf_univ_args ~nb_univs mk env sigma stk = and nf_evar env sigma evk stk = let evi = try Evd.find sigma evk with Not_found -> assert false in let hyps = Environ.named_context_of_val (Evd.evar_filtered_hyps evi) in - let concl = Evd.evar_concl evi in + let concl = EConstr.Unsafe.to_constr @@ Evd.evar_concl evi in if List.is_empty hyps then nf_stk env sigma (mkEvar (evk, [||])) concl stk else match stk with @@ -266,7 +266,6 @@ and nf_stk ?from:(from=0) env sigma c t stk = let nparamdecls = Context.Rel.length (Inductive.inductive_paramdecls (mib,u)) in let pT = hnf_prod_applist_assum env nparamdecls (type_of_ind env (ind,u)) (Array.to_list params) in - let pT = whd_all env pT in let dep, p = nf_predicate env sigma (ind,u) mip params (type_of_switch sw) pT in (* Calcul du type des branches *) let btypes = build_branches_type env sigma ind mib mip u params dep p in @@ -288,15 +287,24 @@ and nf_stk ?from:(from=0) env sigma c t stk = nf_stk env sigma (mkProj(p',c)) ty stk and nf_predicate env sigma ind mip params v pT = - match whd_val v, kind pT with - | Vfun f, Prod _ -> + match kind (whd_allnolet env pT) with + | LetIn (name,b,t,pT) -> + let dep,body = + nf_predicate (push_rel (LocalDef (name,b,t)) env) sigma ind mip params v pT in + dep, mkLetIn (name,b,t,body) + | Prod (name,dom,codom) -> begin + match whd_val v with + | Vfun f -> let k = nb_rel env in let vb = reduce_fun k f in - let name,dom,codom = decompose_prod env pT in let dep,body = nf_predicate (push_rel (LocalAssum (name,dom)) env) sigma ind mip params vb codom in dep, mkLambda(name,dom,body) - | Vfun f, _ -> + | _ -> assert false + end + | _ -> + match whd_val v with + | Vfun f -> let k = nb_rel env in let vb = reduce_fun k f in let name = Name (Id.of_string "c") in @@ -306,7 +314,7 @@ and nf_predicate env sigma ind mip params v pT = let dom = mkApp(mkIndU ind,Array.append params rargs) in let body = nf_vtype (push_rel (LocalAssum (name,dom)) env) sigma vb in true, mkLambda(name,dom,body) - | _, _ -> false, nf_val env sigma v crazy_type + | _ -> false, nf_val env sigma v crazy_type and nf_args env sigma vargs ?from:(f=0) t = let t = ref t in @@ -381,9 +389,9 @@ let cbv_vm env sigma c t = if Termops.occur_meta sigma c then CErrors.user_err Pp.(str "vm_compute does not support metas."); (** This evar-normalizes terms beforehand *) - let c = EConstr.to_constr sigma c in - let t = EConstr.to_constr sigma t in - let v = Vconv.val_of_constr env c in + let c = EConstr.to_constr ~abort_on_undefined_evars:false sigma c in + let t = EConstr.to_constr ~abort_on_undefined_evars:false sigma t in + let v = Csymtable.val_of_constr env c in EConstr.of_constr (nf_val env sigma v t) let vm_infer_conv ?(pb=Reduction.CUMUL) env sigma t1 t2 = diff --git a/printing/genprint.ml b/printing/genprint.ml index 1bb7838a4..fa53a8794 100644 --- a/printing/genprint.ml +++ b/printing/genprint.ml @@ -19,15 +19,15 @@ open Geninterp (* Printing generic values *) type 'a with_level = - { default_already_surrounded : Notation_term.tolerability; - default_ensure_surrounded : Notation_term.tolerability; + { default_already_surrounded : Notation_gram.tolerability; + default_ensure_surrounded : Notation_gram.tolerability; printer : 'a } type printer_result = | PrinterBasic of (unit -> Pp.t) -| PrinterNeedsLevel of (Notation_term.tolerability -> Pp.t) with_level +| PrinterNeedsLevel of (Notation_gram.tolerability -> Pp.t) with_level -type printer_fun_with_level = Environ.env -> Evd.evar_map -> Notation_term.tolerability -> Pp.t +type printer_fun_with_level = Environ.env -> Evd.evar_map -> Notation_gram.tolerability -> Pp.t type top_printer_result = | TopPrinterBasic of (unit -> Pp.t) diff --git a/printing/genprint.mli b/printing/genprint.mli index fd5dd7259..1a31025a9 100644 --- a/printing/genprint.mli +++ b/printing/genprint.mli @@ -13,15 +13,15 @@ open Genarg type 'a with_level = - { default_already_surrounded : Notation_term.tolerability; - default_ensure_surrounded : Notation_term.tolerability; + { default_already_surrounded : Notation_gram.tolerability; + default_ensure_surrounded : Notation_gram.tolerability; printer : 'a } type printer_result = | PrinterBasic of (unit -> Pp.t) -| PrinterNeedsLevel of (Notation_term.tolerability -> Pp.t) with_level +| PrinterNeedsLevel of (Notation_gram.tolerability -> Pp.t) with_level -type printer_fun_with_level = Environ.env -> Evd.evar_map -> Notation_term.tolerability -> Pp.t +type printer_fun_with_level = Environ.env -> Evd.evar_map -> Notation_gram.tolerability -> Pp.t type top_printer_result = | TopPrinterBasic of (unit -> Pp.t) diff --git a/printing/ppconstr.ml b/printing/ppconstr.ml index 412a1cbb4..605781993 100644 --- a/printing/ppconstr.ml +++ b/printing/ppconstr.ml @@ -18,11 +18,12 @@ open Nameops open Libnames open Pputils open Ppextend -open Notation_term +open Glob_term open Constrexpr open Constrexpr_ops +open Notation_gram open Decl_kinds -open Misctypes +open Namegen (*i*) module Tag = @@ -87,8 +88,6 @@ let tag_var = tag Tag.variable | Numeral (_,b) -> if b then lposint else lnegint | String _ -> latom - open Notation - let print_hunks n pr pr_patt pr_binders (terms, termlists, binders, binderlists) unps = let env = ref terms and envlist = ref termlists and bl = ref binders and bll = ref binderlists in let pop r = let a = List.hd !r in r := List.tl !r; a in @@ -170,13 +169,13 @@ let tag_var = tag Tag.variable let pr_univ_annot pr x = str "@{" ++ pr x ++ str "}" - let pr_glob_sort = function + let pr_glob_sort = let open Glob_term in function | 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 = function + let pr_glob_level = let open Glob_term in function | GProp -> tag_type (str "Prop") | GSet -> tag_type (str "Set") | GType UUnknown -> tag_type (str "Type") @@ -199,7 +198,7 @@ let tag_var = tag Tag.variable let pr_qualid = pr_qualid let pr_patvar = pr_id - let pr_glob_sort_instance = function + let pr_glob_sort_instance = let open Glob_term in function | GProp -> tag_type (str "Prop") | GSet -> @@ -229,7 +228,7 @@ let tag_var = tag Tag.variable str "(" ++ pr_id id ++ str ":=" ++ pr ltop a ++ str ")" let pr_opt_type_spc pr = function - | { CAst.v = CHole (_,Misctypes.IntroAnonymous,_) } -> mt () + | { CAst.v = CHole (_,IntroAnonymous,_) } -> mt () | t -> str " :" ++ pr_sep_com (fun()->brk(1,2)) (pr ltop) t let pr_lident {loc; v=id} = @@ -243,8 +242,8 @@ let tag_var = tag Tag.variable | x -> pr_ast Name.print x let pr_or_var pr = function - | ArgArg x -> pr x - | ArgVar id -> pr_lident id + | Locus.ArgArg x -> pr x + | Locus.ArgVar id -> pr_lident id let pr_prim_token = function | Numeral (n,s) -> str (if s then n else "-"^n) @@ -364,7 +363,7 @@ let tag_var = tag Tag.variable end | Default b -> match t with - | { CAst.v = CHole (_,Misctypes.IntroAnonymous,_) } -> + | { CAst.v = CHole (_,IntroAnonymous,_) } -> let s = prlist_with_sep spc pr_lname nal in hov 1 (surround_implicit b s) | _ -> @@ -458,7 +457,7 @@ let tag_var = tag Tag.variable let pr_case_type pr po = match po with - | None | Some { CAst.v = CHole (_,Misctypes.IntroAnonymous,_) } -> mt() + | None | Some { CAst.v = CHole (_,IntroAnonymous,_) } -> mt() | Some p -> spc() ++ hov 2 (keyword "return" ++ pr_sep_com spc (pr lsimpleconstr) p) @@ -593,7 +592,7 @@ let tag_var = tag Tag.variable hv 0 (str"{|" ++ pr_record_body_gen (pr spc) l ++ str" |}"), latom ) - | CCases (LetPatternStyle,rtntypopt,[c,as_clause,in_clause],[{v=([[p]],b)}]) -> + | CCases (Constr.LetPatternStyle,rtntypopt,[c,as_clause,in_clause],[{v=([[p]],b)}]) -> return ( hv 0 ( keyword "let" ++ spc () ++ str"'" ++ @@ -644,9 +643,9 @@ let tag_var = tag Tag.variable lif ) - | CHole (_,Misctypes.IntroIdentifier id,_) -> + | CHole (_,IntroIdentifier id,_) -> return (str "?[" ++ pr_id id ++ str "]", latom) - | CHole (_,Misctypes.IntroFresh id,_) -> + | CHole (_,IntroFresh id,_) -> return (str "?[?" ++ pr_id id ++ str "]", latom) | CHole (_,_,_) -> return (str "_", latom) diff --git a/printing/ppconstr.mli b/printing/ppconstr.mli index 1f1308b0d..ce37c3614 100644 --- a/printing/ppconstr.mli +++ b/printing/ppconstr.mli @@ -15,14 +15,13 @@ open Libnames open Constrexpr open Names -open Misctypes -open Notation_term +open Notation_gram val prec_less : precedence -> tolerability -> bool val pr_tight_coma : unit -> Pp.t -val pr_or_var : ('a -> Pp.t) -> 'a or_var -> Pp.t +val pr_or_var : ('a -> Pp.t) -> 'a Locus.or_var -> Pp.t val pr_lident : lident -> Pp.t val pr_lname : lname -> Pp.t @@ -39,10 +38,10 @@ val pr_name : Name.t -> Pp.t [@@ocaml.deprecated "alias of Names.Name.print"] val pr_qualid : qualid -> Pp.t -val pr_patvar : patvar -> Pp.t +val pr_patvar : Pattern.patvar -> Pp.t -val pr_glob_level : glob_level -> Pp.t -val pr_glob_sort : glob_sort -> Pp.t +val pr_glob_level : Glob_term.glob_level -> Pp.t +val pr_glob_sort : Glob_term.glob_sort -> Pp.t val pr_guard_annot : (constr_expr -> Pp.t) -> local_binder_expr list -> lident option * recursion_order_expr -> diff --git a/printing/pputils.ml b/printing/pputils.ml index c14aa318e..c6b8d5022 100644 --- a/printing/pputils.ml +++ b/printing/pputils.ml @@ -11,7 +11,6 @@ open Util open Pp open Genarg -open Misctypes open Locus open Genredexpr @@ -122,7 +121,7 @@ let pr_red_expr (pr_constr,pr_lconstr,pr_ref,pr_pattern) keyword = function let pr_red_expr_env env sigma (pr_constr,pr_lconstr,pr_ref,pr_pattern) = pr_red_expr (pr_constr env sigma, pr_lconstr env sigma, pr_ref, pr_pattern env sigma) -let pr_or_by_notation f = function +let pr_or_by_notation f = let open Constrexpr in function | {CAst.loc; v=AN v} -> f v | {CAst.loc; v=ByNotation (s,sc)} -> qs s ++ pr_opt (fun sc -> str "%" ++ str sc) sc diff --git a/printing/pputils.mli b/printing/pputils.mli index 6039168f8..5b1969e23 100644 --- a/printing/pputils.mli +++ b/printing/pputils.mli @@ -9,7 +9,6 @@ (************************************************************************) open Genarg -open Misctypes open Locus open Genredexpr @@ -18,7 +17,7 @@ val pr_ast : ('a -> Pp.t) -> 'a CAst.t -> Pp.t (** Prints an object surrounded by its commented location *) val pr_or_var : ('a -> Pp.t) -> 'a or_var -> Pp.t -val pr_or_by_notation : ('a -> Pp.t) -> 'a or_by_notation -> Pp.t +val pr_or_by_notation : ('a -> Pp.t) -> 'a Constrexpr.or_by_notation -> Pp.t val pr_with_occurrences : ('a -> Pp.t) -> (string -> Pp.t) -> 'a with_occurrences -> Pp.t diff --git a/printing/prettyp.ml b/printing/prettyp.ml index 1f17d844f..fe6cf73c7 100644 --- a/printing/prettyp.ml +++ b/printing/prettyp.ml @@ -26,7 +26,6 @@ open Libobject open Libnames open Globnames open Recordops -open Misctypes open Printer open Printmod open Context.Rel.Declaration @@ -35,8 +34,8 @@ open Context.Rel.Declaration module NamedDecl = Context.Named.Declaration type object_pr = { - print_inductive : MutInd.t -> Universes.univ_name_list option -> Pp.t; - print_constant_with_infos : Constant.t -> Universes.univ_name_list option -> Pp.t; + print_inductive : MutInd.t -> UnivNames.univ_name_list option -> Pp.t; + print_constant_with_infos : Constant.t -> UnivNames.univ_name_list option -> Pp.t; print_section_variable : env -> Evd.evar_map -> variable -> Pp.t; print_syntactic_def : env -> KerName.t -> Pp.t; print_module : bool -> ModPath.t -> Pp.t; @@ -77,7 +76,9 @@ let print_ref reduce ref udecl = let typ = EConstr.of_constr typ in let typ = if reduce then - let ctx,ccl = Reductionops.splay_prod_assum (Global.env()) Evd.empty typ + let env = Global.env () in + let sigma = Evd.from_env env in + let ctx,ccl = Reductionops.splay_prod_assum env sigma typ in EConstr.it_mkProd_or_LetIn ccl ctx else typ in let univs = Global.universes_of_global ref in @@ -93,7 +94,7 @@ let print_ref reduce ref udecl = let inst = Univ.AUContext.instance univs in let univs = Univ.UContext.make (inst, Univ.AUContext.instantiate inst univs) in let env = Global.env () in - let bl = Universes.universe_binders_with_opt_names ref + let bl = UnivNames.universe_binders_with_opt_names ref (Array.to_list (Univ.Instance.to_array inst)) udecl in let sigma = Evd.from_ctx (UState.of_binders bl) in let inst = @@ -328,7 +329,7 @@ type 'a locatable_info = { type locatable = Locatable : 'a locatable_info -> locatable type logical_name = - | Term of global_reference + | Term of GlobRef.t | Dir of global_dir_reference | Syntactic of KerName.t | ModuleType of ModPath.t @@ -376,7 +377,6 @@ let pr_located_qualid = function | DirOpenModtype { obj_dir ; _ } -> "Open Module Type", obj_dir | DirOpenSection { obj_dir ; _ } -> "Open Section", obj_dir | DirModule { obj_dir ; _ } -> "Module", obj_dir - | DirClosedSection dir -> "Closed Section", dir in str s ++ spc () ++ DirPath.print dir | ModuleType mp -> @@ -595,7 +595,7 @@ let print_constant with_values sep sp udecl = in let ctx = UState.of_binders - (Universes.universe_binders_with_opt_names (ConstRef sp) ulist udecl) + (UnivNames.universe_binders_with_opt_names (ConstRef sp) ulist udecl) in let env = Global.env () and sigma = Evd.from_ctx ctx in let pr_ltype = pr_ltype_env env sigma in @@ -718,7 +718,10 @@ let print_eval x = !object_pr.print_eval x (**** Printing declarations and judgments *) (**** Abstract layer *****) -let print_typed_value x = print_typed_value_in_env (Global.env ()) Evd.empty x +let print_typed_value x = + let env = Global.env () in + let sigma = Evd.from_env env in + print_typed_value_in_env env sigma x let print_judgment env sigma {uj_val=trm;uj_type=typ} = print_typed_value_in_env env sigma (trm, typ) @@ -839,12 +842,12 @@ let print_any_name env sigma na udecl = let print_name env sigma na udecl = match na with - | {loc; v=ByNotation (ntn,sc)} -> + | {loc; v=Constrexpr.ByNotation (ntn,sc)} -> print_any_name env sigma (Term (Notation.interp_notation_as_global_reference ?loc (fun _ -> true) ntn sc)) udecl - | {loc; v=AN ref} -> + | {loc; v=Constrexpr.AN ref} -> print_any_name env sigma (locate_any_name ref) udecl let print_opaque_name env sigma qid = @@ -892,11 +895,11 @@ let print_about_any ?loc env sigma k udecl = let print_about env sigma na udecl = match na with - | {loc;v=ByNotation (ntn,sc)} -> + | {loc;v=Constrexpr.ByNotation (ntn,sc)} -> print_about_any ?loc env sigma (Term (Notation.interp_notation_as_global_reference ?loc (fun _ -> true) ntn sc)) udecl - | {loc;v=AN ref} -> + | {loc;v=Constrexpr.AN ref} -> print_about_any ?loc env sigma (locate_any_name ref) udecl (* for debug *) diff --git a/printing/prettyp.mli b/printing/prettyp.mli index 213f0aeeb..0375cfc92 100644 --- a/printing/prettyp.mli +++ b/printing/prettyp.mli @@ -12,8 +12,6 @@ open Names open Environ open Reductionops open Libnames -open Globnames -open Misctypes open Evd (** A Pretty-Printer for the Calculus of Inductive Constructions. *) @@ -34,12 +32,12 @@ val print_eval : reduction_function -> env -> Evd.evar_map -> Constrexpr.constr_expr -> EConstr.unsafe_judgment -> Pp.t -val print_name : env -> Evd.evar_map -> reference or_by_notation -> - Universes.univ_name_list option -> Pp.t +val print_name : env -> Evd.evar_map -> reference Constrexpr.or_by_notation -> + UnivNames.univ_name_list option -> Pp.t val print_opaque_name : env -> Evd.evar_map -> reference -> Pp.t -val print_about : env -> Evd.evar_map -> reference or_by_notation -> - Universes.univ_name_list option -> Pp.t -val print_impargs : reference or_by_notation -> Pp.t +val print_about : env -> Evd.evar_map -> reference Constrexpr.or_by_notation -> + UnivNames.univ_name_list option -> Pp.t +val print_impargs : reference Constrexpr.or_by_notation -> Pp.t (** Pretty-printing functions for classes and coercions *) val print_graph : env -> evar_map -> Pp.t @@ -50,7 +48,7 @@ val print_canonical_projections : env -> Evd.evar_map -> Pp.t (** Pretty-printing functions for type classes and instances *) val print_typeclasses : unit -> Pp.t -val print_instances : global_reference -> Pp.t +val print_instances : GlobRef.t -> Pp.t val print_all_instances : unit -> Pp.t val inspect : env -> Evd.evar_map -> int -> Pp.t @@ -85,8 +83,8 @@ val print_located_module : reference -> Pp.t val print_located_other : string -> reference -> Pp.t type object_pr = { - print_inductive : MutInd.t -> Universes.univ_name_list option -> Pp.t; - print_constant_with_infos : Constant.t -> Universes.univ_name_list option -> Pp.t; + print_inductive : MutInd.t -> UnivNames.univ_name_list option -> Pp.t; + print_constant_with_infos : Constant.t -> UnivNames.univ_name_list option -> Pp.t; print_section_variable : env -> Evd.evar_map -> variable -> Pp.t; print_syntactic_def : env -> KerName.t -> Pp.t; print_module : bool -> ModPath.t -> Pp.t; diff --git a/printing/printer.ml b/printing/printer.ml index 199aa79c6..72030dc9f 100644 --- a/printing/printer.ml +++ b/printing/printer.ml @@ -93,13 +93,13 @@ let _ = Hook.set Refine.pr_constr pr_constr_env let pr_lconstr_goal_style_env env sigma c = pr_leconstr_core true env sigma (EConstr.of_constr c) let pr_constr_goal_style_env env sigma c = pr_econstr_core true env sigma (EConstr.of_constr c) -let pr_open_lconstr_env env sigma (_,c) = pr_lconstr_env env sigma c -let pr_open_constr_env env sigma (_,c) = pr_constr_env env sigma c - let pr_econstr_n_env env sigma c = pr_econstr_n_core false env sigma c let pr_leconstr_env env sigma c = pr_leconstr_core false env sigma c let pr_econstr_env env sigma c = pr_econstr_core false env sigma c +let pr_open_lconstr_env env sigma (_,c) = pr_leconstr_env env sigma c +let pr_open_constr_env env sigma (_,c) = pr_econstr_env env sigma c + (* NB do not remove the eta-redexes! Global.env() has side-effects... *) let pr_lconstr t = let (sigma, env) = Pfedit.get_current_context () in @@ -108,12 +108,12 @@ let pr_constr t = let (sigma, env) = Pfedit.get_current_context () in pr_constr_env env sigma t -let pr_open_lconstr (_,c) = pr_lconstr c -let pr_open_constr (_,c) = pr_constr c - let pr_leconstr c = pr_lconstr (EConstr.Unsafe.to_constr c) let pr_econstr c = pr_constr (EConstr.Unsafe.to_constr c) +let pr_open_lconstr (_,c) = pr_leconstr c +let pr_open_constr (_,c) = pr_econstr c + 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 *) @@ -293,14 +293,14 @@ let pr_global = pr_global_env Id.Set.empty let pr_puniverses f env (c,u) = f env c ++ (if !Constrextern.print_universes then - str"(*" ++ Univ.Instance.pr Universes.pr_with_global_universes u ++ str"*)" + str"(*" ++ Univ.Instance.pr UnivNames.pr_with_global_universes u ++ str"*)" else mt ()) let pr_constant env cst = pr_global_env (Termops.vars_of_env env) (ConstRef cst) let pr_existential_key = Termops.pr_existential_key let pr_existential env sigma ev = pr_lconstr_env env sigma (mkEvar ev) -let pr_inductive env ind = pr_lconstr_env env Evd.empty (mkInd ind) -let pr_constructor env cstr = pr_lconstr_env env Evd.empty (mkConstruct cstr) +let pr_inductive env ind = pr_lconstr_env env (Evd.from_env env) (mkInd ind) +let pr_constructor env cstr = pr_lconstr_env env (Evd.from_env env) (mkConstruct cstr) let pr_pconstant = pr_puniverses pr_constant let pr_pinductive = pr_puniverses pr_inductive @@ -494,7 +494,7 @@ let pr_transparent_state (ids, csts) = str"CONSTANTS: " ++ pr_cpred csts ++ fnl ()) (* display complete goal *) -let default_pr_goal gs = +let pr_goal gs = let g = sig_it gs in let sigma = project gs in let env = Goal.V82.env sigma g in @@ -541,12 +541,12 @@ let pr_evgl_sign sigma evi = if List.is_empty ids then mt () else (str " (" ++ prlist_with_sep pr_comma pr_id ids ++ str " cannot be used)") in - let pc = pr_lconstr_env env sigma evi.evar_concl in + let pc = pr_leconstr_env env sigma evi.evar_concl in let candidates = match evi.evar_body, evi.evar_candidates with | Evar_empty, Some l -> spc () ++ str "= {" ++ - prlist_with_sep (fun () -> str "|") (pr_lconstr_env env sigma) l ++ str "}" + prlist_with_sep (fun () -> str "|") (pr_leconstr_env env sigma) l ++ str "}" | _ -> mt () in @@ -591,11 +591,11 @@ let pr_ne_evar_set hd tl sigma l = mt () let pr_selected_subgoal name sigma g = - let pg = default_pr_goal { sigma=sigma ; it=g; } in + let pg = pr_goal { sigma=sigma ; it=g; } in let header = pr_goal_header name sigma g in v 0 (header ++ str " is:" ++ cut () ++ pg) -let default_pr_subgoal n sigma = +let pr_subgoal n sigma = let rec prrec p = function | [] -> user_err Pp.(str "No such goal.") | g::rest -> @@ -622,8 +622,8 @@ let print_evar_constraints gl sigma = end in let pr_evconstr (pbty,env,t1,t2) = - let t1 = Evarutil.nf_evar sigma (EConstr.of_constr t1) - and t2 = Evarutil.nf_evar sigma (EConstr.of_constr t2) in + let t1 = Evarutil.nf_evar sigma t1 + and t2 = Evarutil.nf_evar sigma t2 in let env = (** We currently allow evar instances to refer to anonymous de Bruijn indices, so we protect the error printing code in this case by giving @@ -695,7 +695,7 @@ let print_dependent_evars gl sigma seeds = (* spiwack: [seeds] is for printing dependent evars in emacs mode. *) (* spiwack: [pr_first] is true when the first goal must be singled out and printed in its entirety. *) -let default_pr_subgoals ?(pr_first=true) +let pr_subgoals ?(pr_first=true) close_cmd sigma ~seeds ~shelf ~stack ~unfocused ~goals = (** Printing functions for the extra informations. *) let rec print_stack a = function @@ -739,7 +739,7 @@ let default_pr_subgoals ?(pr_first=true) in let print_multiple_goals g l = if pr_first then - default_pr_goal { it = g ; sigma = sigma; } + pr_goal { it = g ; sigma = sigma; } ++ (if l=[] then mt () else cut ()) ++ pr_rec 2 l else @@ -780,33 +780,6 @@ let default_pr_subgoals ?(pr_first=true) ++ print_dependent_evars (Some g1) sigma seeds ) -(**********************************************************************) -(* Abstraction layer *) - - -type printer_pr = { - pr_subgoals : ?pr_first:bool -> Pp.t option -> evar_map -> seeds:goal list -> shelf:goal list -> stack:int list -> unfocused:goal list -> goals:goal list -> Pp.t; - pr_subgoal : int -> evar_map -> goal list -> Pp.t; - pr_goal : goal sigma -> Pp.t; -} - -let default_printer_pr = { - pr_subgoals = default_pr_subgoals; - pr_subgoal = default_pr_subgoal; - pr_goal = default_pr_goal; -} - -let printer_pr = ref default_printer_pr - -let set_printer_pr = (:=) printer_pr - -let pr_subgoals ?pr_first x = !printer_pr.pr_subgoals ?pr_first x -let pr_subgoal x = !printer_pr.pr_subgoal x -let pr_goal x = !printer_pr.pr_goal x - -(* End abstraction layer *) -(**********************************************************************) - let pr_open_subgoals ~proof = (* spiwack: it shouldn't be the job of the printer to look up stuff in the [evar_map], I did stuff that way because it was more diff --git a/printing/printer.mli b/printing/printer.mli index 41843680b..7a8b963d2 100644 --- a/printing/printer.mli +++ b/printing/printer.mli @@ -9,7 +9,6 @@ (************************************************************************) open Names -open Globnames open Constr open Environ open Pattern @@ -37,7 +36,7 @@ val pr_constr : constr -> Pp.t [@@ocaml.deprecated "The global printing API is deprecated, please use the _env functions"] val pr_constr_goal_style_env : env -> evar_map -> constr -> Pp.t -val pr_constr_n_env : env -> evar_map -> Notation_term.tolerability -> constr -> Pp.t +val pr_constr_n_env : env -> evar_map -> Notation_gram.tolerability -> constr -> Pp.t (** Same, but resilient to [Nametab] errors. Prints fully-qualified names when [shortest_qualid_of_global] has failed. Prints "??" @@ -58,7 +57,7 @@ val pr_leconstr_env : env -> evar_map -> EConstr.t -> Pp.t val pr_leconstr : EConstr.t -> Pp.t [@@ocaml.deprecated "The global printing API is deprecated, please use the _env functions"] -val pr_econstr_n_env : env -> evar_map -> Notation_term.tolerability -> EConstr.t -> Pp.t +val pr_econstr_n_env : env -> evar_map -> Notation_gram.tolerability -> EConstr.t -> Pp.t val pr_etype_env : env -> evar_map -> EConstr.types -> Pp.t val pr_letype_env : env -> evar_map -> EConstr.types -> Pp.t @@ -88,7 +87,7 @@ val pr_type_env : env -> evar_map -> types -> Pp.t val pr_type : types -> Pp.t [@@ocaml.deprecated "The global printing API is deprecated, please use the _env functions"] -val pr_closed_glob_n_env : env -> evar_map -> Notation_term.tolerability -> closed_glob_constr -> Pp.t +val pr_closed_glob_n_env : env -> evar_map -> Notation_gram.tolerability -> closed_glob_constr -> Pp.t val pr_closed_glob_env : env -> evar_map -> closed_glob_constr -> Pp.t val pr_closed_glob : closed_glob_constr -> Pp.t [@@ocaml.deprecated "The global printing API is deprecated, please use the _env functions"] @@ -130,8 +129,8 @@ val pr_cumulativity_info : evar_map -> Univ.CumulativityInfo.t -> Pp.t (** Printing global references using names as short as possible *) -val pr_global_env : Id.Set.t -> global_reference -> Pp.t -val pr_global : global_reference -> Pp.t +val pr_global_env : Id.Set.t -> GlobRef.t -> Pp.t +val pr_global : GlobRef.t -> Pp.t val pr_constant : env -> Constant.t -> Pp.t val pr_existential_key : evar_map -> Evar.t -> Pp.t @@ -223,14 +222,3 @@ val pr_assumptionset : env -> evar_map -> types ContextObjectMap.t -> Pp.t val pr_goal_by_id : proof:Proof.t -> Id.t -> Pp.t -type printer_pr = { - pr_subgoals : ?pr_first:bool -> Pp.t option -> evar_map -> seeds:goal list -> shelf:goal list -> stack:int list -> unfocused:goal list -> goals:goal list -> Pp.t; - - pr_subgoal : int -> evar_map -> goal list -> Pp.t; - pr_goal : goal sigma -> Pp.t; -} - -val set_printer_pr : printer_pr -> unit - -val default_printer_pr : printer_pr - diff --git a/printing/printing.mllib b/printing/printing.mllib index 86b68d8fb..b69d8a9ef 100644 --- a/printing/printing.mllib +++ b/printing/printing.mllib @@ -4,4 +4,3 @@ Ppconstr Printer Printmod Prettyp -Ppvernac diff --git a/printing/printmod.ml b/printing/printmod.ml index e076c10f3..be8bc1357 100644 --- a/printing/printmod.ml +++ b/printing/printmod.ml @@ -140,7 +140,7 @@ let print_mutual_inductive env mind mib udecl = (AUContext.instance (Declareops.inductive_polymorphic_context mib))) else [] in - let bl = Universes.universe_binders_with_opt_names (IndRef (mind, 0)) univs udecl in + let bl = UnivNames.universe_binders_with_opt_names (IndRef (mind, 0)) univs udecl in let sigma = Evd.from_ctx (UState.of_binders bl) in hov 0 (Printer.pr_polymorphic (Declareops.inductive_is_polymorphic mib) ++ Printer.pr_cumulative @@ -183,7 +183,7 @@ let print_record env mind mib udecl = let cstrtype = hnf_prod_applist_assum env nparamdecls cstrtypes.(0) args in let fields = get_fields cstrtype in let envpar = push_rel_context params env in - let bl = Universes.universe_binders_with_opt_names (IndRef (mind,0)) + let bl = UnivNames.universe_binders_with_opt_names (IndRef (mind,0)) (Array.to_list (Univ.Instance.to_array u)) udecl in let sigma = Evd.from_ctx (UState.of_binders bl) in let keyword = @@ -323,7 +323,6 @@ let print_body is_impl env mp (l,body) = else Univ.Instance.empty in let ctx = Univ.UContext.make (u, Univ.AUContext.instantiate u ctx) in - let sigma = Evd.empty in (match cb.const_body with | Def _ -> def "Definition" ++ spc () | OpaqueDef _ when is_impl -> def "Theorem" ++ spc () @@ -332,17 +331,17 @@ let print_body is_impl env mp (l,body) = | None -> mt () | Some env -> str " :" ++ spc () ++ - hov 0 (Printer.pr_ltype_env env sigma + hov 0 (Printer.pr_ltype_env env (Evd.from_env env) (Vars.subst_instance_constr u cb.const_type)) ++ (match cb.const_body with | Def l when is_impl -> spc () ++ hov 2 (str ":= " ++ - Printer.pr_lconstr_env env sigma + Printer.pr_lconstr_env env (Evd.from_env env) (Vars.subst_instance_constr u (Mod_subst.force_constr l))) | _ -> mt ()) ++ str "." ++ - Printer.pr_universe_ctx sigma ctx) + Printer.pr_universe_ctx (Evd.from_env env) ctx) | SFBmind mib -> try let env = Option.get env in @@ -387,7 +386,7 @@ let rec print_typ_expr env mp locals mty = let s = String.concat "." (List.map Id.to_string idl) in (* XXX: What should env and sigma be here? *) let env = Global.env () in - let sigma = Evd.empty in + let sigma = Evd.from_env env in hov 2 (print_typ_expr env' mp locals me ++ spc() ++ str "with" ++ spc() ++ def "Definition"++ spc() ++ str s ++ spc() ++ str ":="++ spc() ++ Printer.pr_lconstr_env env sigma c) diff --git a/printing/printmod.mli b/printing/printmod.mli index b0b0b0a35..48ba866cc 100644 --- a/printing/printmod.mli +++ b/printing/printmod.mli @@ -15,6 +15,6 @@ val printable_body : DirPath.t -> bool val pr_mutual_inductive_body : Environ.env -> MutInd.t -> Declarations.mutual_inductive_body -> - Universes.univ_name_list option -> Pp.t + UnivNames.univ_name_list option -> Pp.t val print_module : bool -> ModPath.t -> Pp.t val print_modtype : ModPath.t -> Pp.t diff --git a/proofs/clenv.ml b/proofs/clenv.ml index 03ff580ad..79b7e1599 100644 --- a/proofs/clenv.ml +++ b/proofs/clenv.ml @@ -13,8 +13,8 @@ open CErrors open Util open Names open Nameops -open Term open Termops +open Constr open Namegen open Environ open Evd @@ -26,7 +26,7 @@ open Tacred open Pretype_errors open Evarutil open Unification -open Misctypes +open Tactypes (******************************************************************) (* Clausal environments *) @@ -62,9 +62,6 @@ let clenv_get_type_of ce c = Retyping.get_type_of (cl_env ce) (cl_sigma ce) c exception NotExtensibleClause -let mk_freelisted c = - map_fl EConstr.of_constr (mk_freelisted (EConstr.Unsafe.to_constr c)) - let clenv_push_prod cl = let typ = whd_all (cl_env cl) (cl_sigma cl) (clenv_type cl) in let rec clrec typ = match EConstr.kind cl.evd typ with @@ -73,7 +70,7 @@ let clenv_push_prod cl = 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 e' = meta_declare mv (EConstr.Unsafe.to_constr t) ~name:na' cl.evd 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 { templval = mk_freelisted def; @@ -107,8 +104,7 @@ let clenv_environments evd bound t = let mv = new_meta () in let dep = not (noccurn evd 1 t2) in let na' = if dep then na else Anonymous in - let t1 = EConstr.Unsafe.to_constr t1 in - let e' = meta_declare mv t1 ~name:na' e 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) | (n, LetIn (na,b,_,t)) -> clrec (e,metas) n (subst1 b t) @@ -167,13 +163,13 @@ let clenv_assign mv rhs clenv = user_err Pp.(str "clenv_assign: circularity in unification"); try if meta_defined clenv.evd mv then - if not (EConstr.eq_constr clenv.evd (EConstr.of_constr (fst (meta_fvalue clenv.evd mv)).rebus) rhs) then + if not (EConstr.eq_constr clenv.evd (fst (meta_fvalue clenv.evd mv)).rebus rhs) then error_incompatible_inst clenv mv else clenv else let st = (Conv,TypeNotProcessed) in - {clenv with evd = meta_assign mv (EConstr.Unsafe.to_constr rhs_fls.rebus,st) clenv.evd} + {clenv with evd = meta_assign mv (rhs_fls.rebus,st) clenv.evd} with Not_found -> user_err Pp.(str "clenv_assign: undefined meta") @@ -218,7 +214,7 @@ let clenv_assign mv rhs clenv = *) let clenv_metas_in_type_of_meta evd mv = - (mk_freelisted (meta_instance evd (map_fl EConstr.of_constr (meta_ftype evd mv)))).freemetas + (mk_freelisted (meta_instance evd (meta_ftype evd mv))).freemetas let dependent_in_type_of_metas clenv mvs = List.fold_right @@ -288,11 +284,11 @@ let adjust_meta_source evd mv = function in situations like "ex_intro (fun x => P) ?ev p" *) let f = function (mv',(Cltyp (_,t) | Clval (_,_,t))) -> if Metaset.mem mv t.freemetas then - let f,l = decompose_app evd (EConstr.of_constr t.rebus) in + let f,l = decompose_app evd t.rebus in match EConstr.kind evd f with | Meta mv'' -> (match meta_opt_fvalue evd mv'' with - | Some (c,_) -> match_name (EConstr.of_constr c.rebus) l + | Some (c,_) -> match_name c.rebus l | None -> None) | _ -> None else None in @@ -502,7 +498,6 @@ let clenv_assign_binding clenv k c = let k_typ = clenv_hnf_constr clenv (clenv_meta_type clenv k) in let c_typ = nf_betaiota clenv.env clenv.evd (clenv_get_type_of clenv c) in let status,clenv',c = clenv_unify_binding_type clenv c c_typ k_typ in - let c = EConstr.Unsafe.to_constr c in { clenv' with evd = meta_assign k (c,(Conv,status)) clenv'.evd } let clenv_match_args bl clenv = @@ -515,7 +510,7 @@ let clenv_match_args bl clenv = (fun clenv {CAst.loc;v=(b,c)} -> let k = meta_of_binder clenv loc mvs b in if meta_defined clenv.evd k then - if EConstr.eq_constr clenv.evd (EConstr.of_constr (fst (meta_fvalue clenv.evd k)).rebus) c then clenv + if EConstr.eq_constr clenv.evd (fst (meta_fvalue clenv.evd k)).rebus c then clenv else error_already_defined b else clenv_assign_binding clenv k c) @@ -677,7 +672,7 @@ let define_with_type sigma env ev c = let j = Environ.make_judge c ty in let (sigma, j) = Coercion.inh_conv_coerce_to true env sigma j t in let (ev, _) = destEvar sigma ev in - let sigma = Evd.define ev (EConstr.Unsafe.to_constr j.Environ.uj_val) sigma in + let sigma = Evd.define ev j.Environ.uj_val sigma in sigma let solve_evar_clause env sigma hyp_only clause = function diff --git a/proofs/clenv.mli b/proofs/clenv.mli index b85c4fc51..f9506290a 100644 --- a/proofs/clenv.mli +++ b/proofs/clenv.mli @@ -18,7 +18,7 @@ open Environ open Evd open EConstr open Unification -open Misctypes +open Tactypes (** {6 The Type of Constructions clausale environments.} *) diff --git a/proofs/clenvtac.ml b/proofs/clenvtac.ml index 209104ac3..544175c6d 100644 --- a/proofs/clenvtac.ml +++ b/proofs/clenvtac.ml @@ -10,7 +10,7 @@ open Util open Names -open Term +open Constr open Termops open Evd open EConstr @@ -54,7 +54,7 @@ let clenv_cast_meta clenv = let clenv_value_cast_meta clenv = clenv_cast_meta clenv (clenv_value clenv) -let clenv_pose_dependent_evars with_evars clenv = +let clenv_pose_dependent_evars ?(with_evars=false) clenv = let dep_mvs = clenv_dependent clenv in let env, sigma = clenv.env, clenv.evd in if not (List.is_empty dep_mvs) && not with_evars then @@ -75,12 +75,12 @@ let check_tc evd = let has_typeclass = Evar.Map.exists check (Evd.undefined_map evd) in (has_typeclass, !has_resolvable) -let clenv_refine with_evars ?(with_classes=true) clenv = +let clenv_refine ?(with_evars=false) ?(with_classes=true) clenv = (** ppedrot: a Goal.enter here breaks things, because the tactic below may solve goals by side effects, while the compatibility layer keeps those useless goals. That deserves a FIXME. *) Proofview.V82.tactic begin fun gl -> - let clenv = clenv_pose_dependent_evars with_evars clenv in + let clenv = clenv_pose_dependent_evars ~with_evars clenv in let evd' = if with_classes then let (has_typeclass, has_resolvable) = check_tc clenv.evd in @@ -105,10 +105,10 @@ open Unification let dft = default_unify_flags -let res_pf ?(with_evars=false) ?(with_classes=true) ?(flags=dft ()) clenv = +let res_pf ?with_evars ?(with_classes=true) ?(flags=dft ()) clenv = Proofview.Goal.enter begin fun gl -> let clenv = clenv_unique_resolver ~flags clenv gl in - clenv_refine with_evars ~with_classes clenv + clenv_refine ?with_evars ~with_classes clenv end (* [unifyTerms] et [unify] ne semble pas gérer les Meta, en diff --git a/proofs/clenvtac.mli b/proofs/clenvtac.mli index 7c1e300b8..d17847842 100644 --- a/proofs/clenvtac.mli +++ b/proofs/clenvtac.mli @@ -13,12 +13,11 @@ open Clenv open EConstr open Unification -open Misctypes (** Tactics *) val unify : ?flags:unify_flags -> constr -> unit Proofview.tactic -val clenv_refine : evars_flag -> ?with_classes:bool -> clausenv -> unit Proofview.tactic -val res_pf : ?with_evars:evars_flag -> ?with_classes:bool -> ?flags:unify_flags -> clausenv -> unit Proofview.tactic +val clenv_refine : ?with_evars:bool -> ?with_classes:bool -> clausenv -> unit Proofview.tactic +val res_pf : ?with_evars:bool -> ?with_classes:bool -> ?flags:unify_flags -> clausenv -> unit Proofview.tactic -val clenv_pose_dependent_evars : evars_flag -> clausenv -> clausenv +val clenv_pose_dependent_evars : ?with_evars:bool -> clausenv -> clausenv val clenv_value_cast_meta : clausenv -> constr diff --git a/proofs/evar_refiner.ml b/proofs/evar_refiner.ml index 0d197c92c..c80f370fd 100644 --- a/proofs/evar_refiner.ml +++ b/proofs/evar_refiner.ml @@ -25,8 +25,6 @@ open Ltac_pretype type glob_constr_ltac_closure = ltac_var_map * glob_constr let depends_on_evar sigma evk _ (pbty,_,t1,t2) = - let t1 = EConstr.of_constr t1 in - let t2 = EConstr.of_constr t2 in try Evar.equal (head_evar sigma t1) evk with NoHeadEvar -> try Evar.equal (head_evar sigma t2) evk @@ -35,12 +33,12 @@ let depends_on_evar sigma evk _ (pbty,_,t1,t2) = let define_and_solve_constraints evk c env evd = if Termops.occur_evar evd evk c then Pretype_errors.error_occur_check env evd evk c; - let evd = define evk (EConstr.Unsafe.to_constr c) evd in + let evd = define evk c evd in let (evd,pbs) = extract_changed_conv_pbs evd (depends_on_evar evd evk) in match List.fold_left (fun p (pbty,env,t1,t2) -> match p with - | Success evd -> Evarconv.evar_conv_x full_transparent_state env evd pbty (EConstr.of_constr t1) (EConstr.of_constr t2) + | Success evd -> Evarconv.evar_conv_x full_transparent_state env evd pbty t1 t2 | UnifFailure _ as x -> x) (Success evd) pbs with @@ -59,7 +57,7 @@ let w_refine (evk,evi) (ltac_var,rawc) sigma = Pretyping.fail_evar = false; Pretyping.expand_evars = true } in try Pretyping.understand_ltac flags - env sigma ltac_var (Pretyping.OfType (EConstr.of_constr evi.evar_concl)) rawc + env sigma ltac_var (Pretyping.OfType evi.evar_concl) rawc with e when CErrors.noncritical e -> let loc = Glob_ops.loc_of_glob_constr rawc in user_err ?loc diff --git a/proofs/goal.ml b/proofs/goal.ml index ba7e458f3..1440d1636 100644 --- a/proofs/goal.ml +++ b/proofs/goal.ml @@ -48,7 +48,7 @@ module V82 = struct (* Access to ".evar_concl" *) let concl evars gl = let evi = Evd.find evars gl in - EConstr.of_constr evi.Evd.evar_concl + evi.Evd.evar_concl (* Access to ".evar_extra" *) let extra evars gl = @@ -61,7 +61,6 @@ module V82 = struct be shelved. It must not appear as a future_goal, so the future goals are restored to their initial value after the evar is created. *) - let concl = EConstr.Unsafe.to_constr concl in let prev_future_goals = Evd.save_future_goals evars in let evi = { Evd.evar_hyps = hyps; Evd.evar_concl = concl; @@ -86,7 +85,7 @@ module V82 = struct if not (Evarutil.occur_evar_upto sigma evk c) then () else Pretype_errors.error_occur_check Environ.empty_env sigma evk c in - Evd.define evk (EConstr.Unsafe.to_constr c) sigma + Evd.define evk c sigma (* Instantiates a goal with an open term, using name of goal for evk' *) let partial_solution_to sigma evk evk' c = @@ -100,7 +99,9 @@ module V82 = struct let same_goal evars1 gl1 evars2 gl2 = let evi1 = Evd.find evars1 gl1 in let evi2 = Evd.find evars2 gl2 in - Constr.equal evi1.Evd.evar_concl evi2.Evd.evar_concl && + let c1 = EConstr.Unsafe.to_constr evi1.Evd.evar_concl in + let c2 = EConstr.Unsafe.to_constr evi2.Evd.evar_concl in + Constr.equal c1 c2 && Environ.eq_named_context_val evi1.Evd.evar_hyps evi2.Evd.evar_hyps let weak_progress glss gls = @@ -117,20 +118,6 @@ module V82 = struct with a good implementation of them. *) - (* Used for congruence closure *) - let new_goal_with sigma gl extra_hyps = - let evi = Evd.find sigma gl in - let hyps = evi.Evd.evar_hyps in - let new_hyps = - List.fold_right Environ.push_named_context_val extra_hyps hyps in - let filter = evi.Evd.evar_filter in - let new_filter = Evd.Filter.extend (List.length extra_hyps) filter in - let new_evi = - { evi with Evd.evar_hyps = new_hyps; Evd.evar_filter = new_filter } in - let new_evi = Typeclasses.mark_unresolvable new_evi in - let (sigma, evk) = Evarutil.new_pure_evar_full Evd.empty new_evi in - { Evd.it = evk ; sigma = sigma; } - (* Used by the compatibility layer and typeclasses *) let nf_evar sigma gl = let evi = Evd.find sigma gl in diff --git a/proofs/goal.mli b/proofs/goal.mli index dc9863156..b8c979ad7 100644 --- a/proofs/goal.mli +++ b/proofs/goal.mli @@ -64,9 +64,6 @@ module V82 : sig (* Principal part of tclNOTSAMEGOAL *) val same_goal : Evd.evar_map -> goal -> Evd.evar_map -> goal -> bool - (* Used for congruence closure *) - val new_goal_with : Evd.evar_map -> goal -> Context.Named.t -> goal Evd.sigma - (* Used by the compatibility layer and typeclasses *) val nf_evar : Evd.evar_map -> goal -> goal * Evd.evar_map diff --git a/proofs/goal_select.ml b/proofs/goal_select.ml new file mode 100644 index 000000000..65a94a2c6 --- /dev/null +++ b/proofs/goal_select.ml @@ -0,0 +1,68 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +open Names + +(* spiwack: I'm choosing, for now, to have [goal_selector] be a + different type than [goal_reference] mostly because if it makes sense + to print a goal that is out of focus (or already solved) it doesn't + make sense to apply a tactic to it. Hence it the types may look very + similar, they do not seem to mean the same thing. *) +type t = + | SelectAlreadyFocused + | SelectNth of int + | SelectList of (int * int) list + | SelectId of Id.t + | SelectAll + +(* Default goal selector: selector chosen when a tactic is applied + without an explicit selector. *) +let default_goal_selector = ref (SelectNth 1) +let get_default_goal_selector () = !default_goal_selector + +let pr_range_selector (i, j) = + if i = j then Pp.int i + else Pp.(int i ++ str "-" ++ int j) + +let pr_goal_selector = function + | SelectAlreadyFocused -> Pp.str "!" + | SelectAll -> Pp.str "all" + | SelectNth i -> Pp.int i + | SelectList l -> + Pp.(str "[" + ++ prlist_with_sep pr_comma pr_range_selector l + ++ str "]") + | SelectId id -> Names.Id.print id + +let parse_goal_selector = function + | "!" -> SelectAlreadyFocused + | "all" -> SelectAll + | i -> + let err_msg = "The default selector must be \"all\" or a natural number." in + begin try + let i = int_of_string i in + if i < 0 then CErrors.user_err Pp.(str err_msg); + SelectNth i + with Failure _ -> CErrors.user_err Pp.(str err_msg) + end + +let _ = let open Goptions in + declare_string_option + { optdepr = false; + optname = "default goal selector" ; + optkey = ["Default";"Goal";"Selector"] ; + optread = begin fun () -> + Pp.string_of_ppcmds + (pr_goal_selector !default_goal_selector) + end; + optwrite = begin fun n -> + default_goal_selector := parse_goal_selector n + end + } diff --git a/proofs/goal_select.mli b/proofs/goal_select.mli new file mode 100644 index 000000000..b1c572388 --- /dev/null +++ b/proofs/goal_select.mli @@ -0,0 +1,26 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +open Names + +(* spiwack: I'm choosing, for now, to have [goal_selector] be a + different type than [goal_reference] mostly because if it makes sense + to print a goal that is out of focus (or already solved) it doesn't + make sense to apply a tactic to it. Hence it the types may look very + similar, they do not seem to mean the same thing. *) +type t = + | SelectAlreadyFocused + | SelectNth of int + | SelectList of (int * int) list + | SelectId of Id.t + | SelectAll + +val pr_goal_selector : t -> Pp.t +val get_default_goal_selector : unit -> t diff --git a/proofs/logic.ml b/proofs/logic.ml index e5294715e..e8ca71993 100644 --- a/proofs/logic.ml +++ b/proofs/logic.ml @@ -23,7 +23,6 @@ open Typing open Proof_type open Type_errors open Retyping -open Misctypes module NamedDecl = Context.Named.Declaration @@ -185,6 +184,22 @@ let check_decl_position env sigma sign d = * on the right side [right] if [toleft=false]. * If [with_dep] then dependent hypotheses are moved accordingly. *) +(** Move destination for hypothesis *) + +type 'id move_location = + | MoveAfter of 'id + | MoveBefore of 'id + | MoveFirst + | MoveLast (** can be seen as "no move" when doing intro *) + +(** Printing of [move_location] *) + +let pr_move_location pr_id = function + | MoveAfter id -> brk(1,1) ++ str "after " ++ pr_id id + | MoveBefore id -> brk(1,1) ++ str "before " ++ pr_id id + | MoveFirst -> str " at top" + | MoveLast -> str " at bottom" + let move_location_eq m1 m2 = match m1, m2 with | MoveAfter id1, MoveAfter id2 -> Id.equal id1 id2 | MoveBefore id1, MoveBefore id2 -> Id.equal id1 id2 @@ -236,7 +251,7 @@ let move_hyp sigma toleft (left,declfrom,right) hto = (first, d::middle) else user_err ~hdr:"move_hyp" (str "Cannot move " ++ Id.print (NamedDecl.get_id declfrom) ++ - Miscprint.pr_move_location Id.print hto ++ + pr_move_location Id.print hto ++ str (if toleft then ": it occurs in the type of " else ": it depends on ") ++ Id.print hyp ++ str ".") else @@ -289,7 +304,15 @@ let collect_meta_variables c = let rec collrec deep acc c = match kind c with | Meta mv -> if deep then error_unsupported_deep_meta () else mv::acc | Cast(c,_,_) -> collrec deep acc c - | (App _| Case _) -> Constr.fold (collrec deep) acc c + | Case(ci,p,c,br) -> + (* Hack assuming only two situations: the legacy one that branches, + if with Metas, are Meta, and the new one with eta-let-expanded + branches *) + let br = Array.map2 (fun n b -> try snd (Term.decompose_lam_n_decls n b) with UserError _ -> b) ci.ci_cstr_ndecls br in + Array.fold_left (collrec deep) + (Constr.fold (collrec deep) (Constr.fold (collrec deep) acc p) c) + br + | App _ -> Constr.fold (collrec deep) acc c | Proj (_, c) -> collrec deep acc c | _ -> Constr.fold (collrec true) acc c in @@ -301,9 +324,10 @@ let check_meta_variables env sigma c = let check_conv_leq_goal env sigma arg ty conclty = if !check then - let evm, b = Reductionops.infer_conv env sigma (EConstr.of_constr ty) (EConstr.of_constr conclty) in - if b then evm - else raise (RefinerError (env, sigma, BadType (arg,ty,conclty))) + let ans = Reductionops.infer_conv env sigma (EConstr.of_constr ty) (EConstr.of_constr conclty) in + match ans with + | Some evm -> evm + | None -> raise (RefinerError (env, sigma, BadType (arg,ty,conclty))) else sigma exception Stop of EConstr.t list @@ -387,12 +411,7 @@ let rec mk_refgoals sigma goal goalacc conclty trm = | Case (ci,p,c,lf) -> let (acc',lbrty,conclty',sigma,p',c') = mk_casegoals sigma goal goalacc p c in let sigma = check_conv_leq_goal env sigma trm conclty' conclty in - let (acc'',sigma, rbranches) = - Array.fold_left2 - (fun (lacc,sigma,bacc) ty fi -> - let (r,_,s,b') = mk_refgoals sigma goal lacc ty fi in r,s,(b'::bacc)) - (acc',sigma,[]) lbrty lf - in + let (acc'',sigma,rbranches) = treat_case sigma goal ci lbrty lf acc' in let lf' = Array.rev_of_list rbranches in let ans = if p' == p && c' == c && Array.equal (==) lf' lf then trm @@ -440,12 +459,7 @@ and mk_hdgoals sigma goal goalacc trm = | Case (ci,p,c,lf) -> let (acc',lbrty,conclty',sigma,p',c') = mk_casegoals sigma goal goalacc p c in - let (acc'',sigma,rbranches) = - Array.fold_left2 - (fun (lacc,sigma,bacc) ty fi -> - let (r,_,s,b') = mk_refgoals sigma goal lacc ty fi in r,s,(b'::bacc)) - (acc',sigma,[]) lbrty lf - in + let (acc'',sigma,rbranches) = treat_case sigma goal ci lbrty lf acc' in let lf' = Array.rev_of_list rbranches in let ans = if p' == p && c' == c && Array.equal (==) lf' lf then trm @@ -483,7 +497,7 @@ and mk_arggoals sigma goal goalacc funty allargs = let env = Goal.V82.env sigma goal in raise (RefinerError (env,sigma,CannotApply (t, harg))) in - Array.smartfoldmap foldmap (goalacc, funty, sigma) allargs + Array.Smart.fold_left_map foldmap (goalacc, funty, sigma) allargs and mk_casegoals sigma goal goalacc p c = let env = Goal.V82.env sigma goal in @@ -497,6 +511,50 @@ and mk_casegoals sigma goal goalacc p c = let (lbrty,conclty) = type_case_branches_with_names env sigma indspec p c in (acc'',lbrty,conclty,sigma,p',c') +and treat_case sigma goal ci lbrty lf acc' = + let rec strip_outer_cast c = match kind c with + | Cast (c,_,_) -> strip_outer_cast c + | _ -> c in + let decompose_app_vect c = match kind c with + | App (f,cl) -> (f, cl) + | _ -> (c,[||]) in + let env = Goal.V82.env sigma goal in + Array.fold_left3 + (fun (lacc,sigma,bacc) ty fi l -> + if isMeta (strip_outer_cast fi) then + (* Support for non-eta-let-expanded Meta as found in *) + (* destruct/case with an non eta-let expanded elimination scheme *) + let (r,_,s,fi') = mk_refgoals sigma goal lacc ty fi in + r,s,(fi'::bacc) + else + (* Deal with a branch in expanded form of the form + Case(ci,p,c,[|eta-let-exp(Meta);...;eta-let-exp(Meta)|]) as + if it were not so, so as to preserve compatibility with when + destruct/case generated schemes of the form + Case(ci,p,c,[|Meta;...;Meta|]; + CAUTION: it does not deal with the general case of eta-zeta + reduced branches having a form different from Meta, as it + would be theoretically the case with third-party code *) + let n = List.length l in + let ctx, body = Term.decompose_lam_n_decls n fi in + let head, args = decompose_app_vect body in + (* Strip cast because clenv_cast_meta adds a cast when the branch is + eta-expanded but when not when the branch has the single-meta + form [Meta] *) + let head = strip_outer_cast head in + if isMeta head then begin + assert (args = Context.Rel.to_extended_vect mkRel 0 ctx); + let head' = lift (-n) head in + let (r,_,s,head'') = mk_refgoals sigma goal lacc ty head' in + let fi' = it_mkLambda_or_LetIn (mkApp (head'',args)) ctx in + (r,s,fi'::bacc) + end + else + (* Supposed to be meta-free *) + let sigma, t'ty = goal_type_of env sigma fi in + let sigma = check_conv_leq_goal env sigma fi t'ty ty in + (lacc,sigma,fi::bacc)) + (acc',sigma,[]) lbrty lf ci.ci_pp_info.cstr_tags let convert_hyp check sign sigma d = let id = NamedDecl.get_id d in diff --git a/proofs/logic.mli b/proofs/logic.mli index dc471bb5f..9db54732b 100644 --- a/proofs/logic.mli +++ b/proofs/logic.mli @@ -58,12 +58,23 @@ val error_no_such_hypothesis : Environ.env -> evar_map -> Id.t -> 'a val catchable_exception : exn -> bool +(** Move destination for hypothesis *) + +type 'id move_location = + | MoveAfter of 'id + | MoveBefore of 'id + | MoveFirst + | MoveLast (** can be seen as "no move" when doing intro *) + +val pr_move_location : + ('a -> Pp.t) -> 'a move_location -> Pp.t + val convert_hyp : bool -> Environ.named_context_val -> evar_map -> EConstr.named_declaration -> Environ.named_context_val -val move_hyp_in_named_context : Environ.env -> Evd.evar_map -> Id.t -> Id.t Misctypes.move_location -> +val move_hyp_in_named_context : Environ.env -> Evd.evar_map -> Id.t -> Id.t move_location -> Environ.named_context_val -> Environ.named_context_val val insert_decl_in_named_context : Evd.evar_map -> - EConstr.named_declaration -> Id.t Misctypes.move_location -> + EConstr.named_declaration -> Id.t move_location -> Environ.named_context_val -> Environ.named_context_val diff --git a/proofs/miscprint.ml b/proofs/miscprint.ml index 1a63ff673..ec17b8076 100644 --- a/proofs/miscprint.ml +++ b/proofs/miscprint.ml @@ -10,7 +10,7 @@ open Pp open Names -open Misctypes +open Tactypes (** Printing of [intro_pattern] *) @@ -20,7 +20,7 @@ let rec pr_intro_pattern prc {CAst.v=pat} = match pat with | IntroNaming p -> pr_intro_pattern_naming p | IntroAction p -> pr_intro_pattern_action prc p -and pr_intro_pattern_naming = function +and pr_intro_pattern_naming = let open Namegen in function | IntroIdentifier id -> Id.print id | IntroFresh id -> str "?" ++ Id.print id | IntroAnonymous -> str "?" @@ -43,14 +43,6 @@ and pr_or_and_intro_pattern prc = function hv 0 (prlist_with_sep pr_bar (prlist_with_sep spc (pr_intro_pattern prc)) pll) ++ str "]" -(** Printing of [move_location] *) - -let pr_move_location pr_id = function - | MoveAfter id -> brk(1,1) ++ str "after " ++ pr_id id - | MoveBefore id -> brk(1,1) ++ str "before " ++ pr_id id - | MoveFirst -> str " at top" - | MoveLast -> str " at bottom" - (** Printing of bindings *) let pr_binding prc = let open CAst in function | {loc;v=(NamedHyp id, c)} -> hov 1 (Names.Id.print id ++ str " := " ++ cut () ++ prc c) diff --git a/proofs/miscprint.mli b/proofs/miscprint.mli index 79790a277..f4e2e683d 100644 --- a/proofs/miscprint.mli +++ b/proofs/miscprint.mli @@ -8,7 +8,7 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) -open Misctypes +open Tactypes (** Printing of [intro_pattern] *) @@ -18,13 +18,10 @@ val pr_intro_pattern : val pr_or_and_intro_pattern : ('a -> Pp.t) -> 'a or_and_intro_pattern_expr -> Pp.t -val pr_intro_pattern_naming : intro_pattern_naming_expr -> Pp.t +val pr_intro_pattern_naming : Namegen.intro_pattern_naming_expr -> Pp.t (** Printing of [move_location] *) -val pr_move_location : - ('a -> Pp.t) -> 'a move_location -> Pp.t - val pr_bindings : ('a -> Pp.t) -> ('a -> Pp.t) -> 'a bindings -> Pp.t diff --git a/proofs/pfedit.ml b/proofs/pfedit.ml index 8725f51cd..678c3ea3f 100644 --- a/proofs/pfedit.ml +++ b/proofs/pfedit.ml @@ -100,11 +100,23 @@ let solve ?with_end_tac gi info_lvl tac pr = | None -> tac | Some _ -> Proofview.Trace.record_info_trace tac in - let tac = match gi with - | Vernacexpr.SelectNth i -> Proofview.tclFOCUS i i tac - | Vernacexpr.SelectList l -> Proofview.tclFOCUSLIST l tac - | Vernacexpr.SelectId id -> Proofview.tclFOCUSID id tac - | Vernacexpr.SelectAll -> tac + let tac = let open Goal_select in match gi with + | SelectAlreadyFocused -> + let open Proofview.Notations in + Proofview.numgoals >>= fun n -> + if n == 1 then tac + else + let e = CErrors.UserError + (None, + Pp.(str "Expected a single focused goal but " ++ + int n ++ str " goals are focused.")) + in + Proofview.tclZERO e + + | SelectNth i -> Proofview.tclFOCUS i i tac + | SelectList l -> Proofview.tclFOCUSLIST l tac + | SelectId id -> Proofview.tclFOCUSID id tac + | SelectAll -> tac in let tac = if use_unification_heuristics () then @@ -121,7 +133,7 @@ let solve ?with_end_tac gi info_lvl tac pr = with Proof_global.NoCurrentProof -> CErrors.user_err Pp.(str "No focused proof") -let by tac = Proof_global.with_current_proof (fun _ -> solve (Vernacexpr.SelectNth 1) None tac) +let by tac = Proof_global.with_current_proof (fun _ -> solve (Goal_select.SelectNth 1) None tac) let instantiate_nth_evar_com n com = Proof_global.simple_with_current_proof (fun _ p -> Proof.V82.instantiate_evar n com p) @@ -188,8 +200,7 @@ let refine_by_tactic env sigma ty tac = | [c, _] -> c | _ -> assert false in - let ans = Reductionops.nf_evar sigma ans in - let ans = EConstr.Unsafe.to_constr ans in + let ans = EConstr.to_constr ~abort_on_undefined_evars:false sigma ans in (** [neff] contains the freshly generated side-effects *) let neff = Evd.eval_side_effects sigma in (** Reset the old side-effects *) @@ -233,7 +244,7 @@ let apply_implicit_tactic tac = (); fun env sigma evk -> (Environ.named_context env) -> let tac = Proofview.tclTHEN tac (Proofview.tclEXTEND [] (Proofview.tclZERO (CErrors.UserError (None,Pp.str"Proof is not complete."))) []) in (try - let c = Evarutil.nf_evars_universes sigma evi.evar_concl in + let c = Evarutil.nf_evars_universes sigma (EConstr.Unsafe.to_constr evi.evar_concl) in let c = EConstr.of_constr c in if Evarutil.has_undefined_evars sigma c then raise Exit; let (ans, _, ctx) = diff --git a/proofs/pfedit.mli b/proofs/pfedit.mli index 65cde3a3a..7b7973224 100644 --- a/proofs/pfedit.mli +++ b/proofs/pfedit.mli @@ -24,7 +24,7 @@ open Decl_kinds proof of mutually dependent theorems) *) val start_proof : - Id.t -> ?pl:Univdecls.universe_decl -> goal_kind -> Evd.evar_map -> named_context_val -> EConstr.constr -> + Id.t -> ?pl:UState.universe_decl -> goal_kind -> Evd.evar_map -> named_context_val -> EConstr.constr -> ?init_tac:unit Proofview.tactic -> Proof_global.proof_terminator -> unit @@ -75,7 +75,7 @@ val current_proof_statement : tac] applies [tac] to all subgoals. *) val solve : ?with_end_tac:unit Proofview.tactic -> - Vernacexpr.goal_selector -> int option -> unit Proofview.tactic -> + Goal_select.t -> int option -> unit Proofview.tactic -> Proof.t -> Proof.t * bool (** [by tac] applies tactic [tac] to the 1st subgoal of the current diff --git a/proofs/proof_bullet.ml b/proofs/proof_bullet.ml index e22d382f7..cc3e79f85 100644 --- a/proofs/proof_bullet.ml +++ b/proofs/proof_bullet.ml @@ -10,19 +10,22 @@ open Proof -type t = Vernacexpr.bullet +type t = + | Dash of int + | Star of int + | Plus of int let bullet_eq b1 b2 = match b1, b2 with -| Vernacexpr.Dash n1, Vernacexpr.Dash n2 -> n1 = n2 -| Vernacexpr.Star n1, Vernacexpr.Star n2 -> n1 = n2 -| Vernacexpr.Plus n1, Vernacexpr.Plus n2 -> n1 = n2 +| Dash n1, Dash n2 -> n1 = n2 +| Star n1, Star n2 -> n1 = n2 +| Plus n1, Plus n2 -> n1 = n2 | _ -> false let pr_bullet b = match b with - | Vernacexpr.Dash n -> Pp.(str (String.make n '-')) - | Vernacexpr.Star n -> Pp.(str (String.make n '*')) - | Vernacexpr.Plus n -> Pp.(str (String.make n '+')) + | Dash n -> Pp.(str (String.make n '-')) + | Star n -> Pp.(str (String.make n '*')) + | Plus n -> Pp.(str (String.make n '+')) type behavior = { @@ -195,52 +198,5 @@ let put p b = let suggest p = (!current_behavior).suggest p -(**********************************************************) -(* *) -(* Default goal selector *) -(* *) -(**********************************************************) - - -(* Default goal selector: selector chosen when a tactic is applied - without an explicit selector. *) -let default_goal_selector = ref (Vernacexpr.SelectNth 1) -let get_default_goal_selector () = !default_goal_selector - -let pr_range_selector (i, j) = - if i = j then Pp.int i - else Pp.(int i ++ str "-" ++ int j) - -let pr_goal_selector = function - | Vernacexpr.SelectAll -> Pp.str "all" - | Vernacexpr.SelectNth i -> Pp.int i - | Vernacexpr.SelectList l -> - Pp.(str "[" - ++ prlist_with_sep pr_comma pr_range_selector l - ++ str "]") - | Vernacexpr.SelectId id -> Names.Id.print id - -let parse_goal_selector = function - | "all" -> Vernacexpr.SelectAll - | i -> - let err_msg = "The default selector must be \"all\" or a natural number." in - begin try - let i = int_of_string i in - if i < 0 then CErrors.user_err Pp.(str err_msg); - Vernacexpr.SelectNth i - with Failure _ -> CErrors.user_err Pp.(str err_msg) - end - -let _ = - Goptions.(declare_string_option{optdepr = false; - optname = "default goal selector" ; - optkey = ["Default";"Goal";"Selector"] ; - optread = begin fun () -> - Pp.string_of_ppcmds - (pr_goal_selector !default_goal_selector) - end; - optwrite = begin fun n -> - default_goal_selector := parse_goal_selector n - end - }) - +let pr_goal_selector = Goal_select.pr_goal_selector +let get_default_goal_selector = Goal_select.get_default_goal_selector diff --git a/proofs/proof_bullet.mli b/proofs/proof_bullet.mli index ffbaa0fac..a09a7ec1d 100644 --- a/proofs/proof_bullet.mli +++ b/proofs/proof_bullet.mli @@ -14,7 +14,10 @@ (* *) (**********************************************************) -type t = Vernacexpr.bullet +type t = + | Dash of int + | Star of int + | Plus of int (** A [behavior] is the data of a put function which is called when a bullet prefixes a tactic, a suggest function @@ -42,12 +45,8 @@ val register_behavior : behavior -> unit val put : Proof.t -> t -> Proof.t val suggest : Proof.t -> Pp.t -(**********************************************************) -(* *) -(* Default goal selector *) -(* *) -(**********************************************************) - -val pr_goal_selector : Vernacexpr.goal_selector -> Pp.t -val get_default_goal_selector : unit -> Vernacexpr.goal_selector - +(** Deprecated *) +val pr_goal_selector : Goal_select.t -> Pp.t +[@@ocaml.deprecated "Please use [Goal_select.pr_goal_selector]"] +val get_default_goal_selector : unit -> Goal_select.t +[@@ocaml.deprecated "Please use [Goal_select.get_default_goal_selector]"] diff --git a/proofs/proof_global.ml b/proofs/proof_global.ml index d6c0e3341..3120c97b5 100644 --- a/proofs/proof_global.ml +++ b/proofs/proof_global.ml @@ -78,11 +78,14 @@ type proof_object = { universes: UState.t; } +type opacity_flag = Opaque | Transparent + type proof_ending = | Admitted of Names.Id.t * Decl_kinds.goal_kind * Entries.parameter_entry * UState.t - | Proved of Vernacexpr.opacity_flag * - Misctypes.lident option * + | Proved of opacity_flag * + lident option * proof_object + type proof_terminator = proof_ending -> unit type closed_proof = proof_object * proof_terminator @@ -94,7 +97,7 @@ type pstate = { proof : Proof.t; strength : Decl_kinds.goal_kind; mode : proof_mode CEphemeron.key; - universe_decl: Univdecls.universe_decl; + universe_decl: UState.universe_decl; } type t = pstate list @@ -235,13 +238,6 @@ let activate_proof_mode mode = let disactivate_current_proof_mode () = CEphemeron.iter_opt !current_proof_mode (fun x -> x.reset ()) -let default_universe_decl = - let open Misctypes in - { univdecl_instance = []; - univdecl_extensible_instance = true; - univdecl_constraints = Univ.Constraint.empty; - univdecl_extensible_constraints = true } - (** [start_proof sigma id pl str goals terminator] starts a proof of name [id] with goals [goals] (a list of pairs of environment and conclusion); [str] describes what kind of theorem/definition this @@ -250,7 +246,7 @@ let default_universe_decl = end of the proof to close the proof. The proof is started in the evar map [sigma] (which can typically contain universe constraints), and with universe bindings pl. *) -let start_proof sigma id ?(pl=default_universe_decl) str goals terminator = +let start_proof sigma id ?(pl=UState.default_univ_decl) str goals terminator = let initial_state = { pid = id; terminator = CEphemeron.create terminator; @@ -262,7 +258,7 @@ let start_proof sigma id ?(pl=default_universe_decl) str goals terminator = universe_decl = pl } in push initial_state pstates -let start_dependent_proof id ?(pl=default_universe_decl) str goals terminator = +let start_dependent_proof id ?(pl=UState.default_univ_decl) str goals terminator = let initial_state = { pid = id; terminator = CEphemeron.create terminator; @@ -340,8 +336,8 @@ let close_proof ~keep_body_ucst_separate ?feedback_id ~now have existential variables in the initial types of goals, we need to normalise them for the kernel. *) let subst_evar k = - Proof.in_proof proof (fun m -> Evd.existential_opt_value m k) in - let nf = Universes.nf_evars_and_universes_opt_subst subst_evar + Proof.in_proof proof (fun m -> Evd.existential_opt_value0 m k) in + let nf = UnivSubst.nf_evars_and_universes_opt_subst subst_evar (UState.subst universes) in let make_body = if poly || now then @@ -441,8 +437,8 @@ let return_proof ?(allow_partial=false) () = (** ppedrot: FIXME, this is surely wrong. There is no reason to duplicate side-effects... This may explain why one need to uniquize side-effects thereafter... *) - let proofs = - List.map (fun (c, _) -> (Evarutil.nf_evars_universes evd (EConstr.Unsafe.to_constr c), eff)) initial_goals in + let proofs = + List.map (fun (c, _) -> (EConstr.to_constr evd c, eff)) initial_goals in proofs, Evd.evar_universe_context evd let close_future_proof ~feedback_id proof = diff --git a/proofs/proof_global.mli b/proofs/proof_global.mli index bf35fd659..9e07ed2d0 100644 --- a/proofs/proof_global.mli +++ b/proofs/proof_global.mli @@ -22,7 +22,7 @@ val check_no_pending_proof : unit -> unit val get_current_proof_name : unit -> Names.Id.t val get_all_proof_names : unit -> Names.Id.t list -val discard : Misctypes.lident -> unit +val discard : Names.lident -> unit val discard_current : unit -> unit val discard_all : unit -> unit @@ -48,11 +48,13 @@ type proof_object = { universes: UState.t; } +type opacity_flag = Opaque | Transparent + type proof_ending = | Admitted of Names.Id.t * Decl_kinds.goal_kind * Entries.parameter_entry * UState.t - | Proved of Vernacexpr.opacity_flag * - Misctypes.lident option * + | Proved of opacity_flag * + Names.lident option * proof_object type proof_terminator type closed_proof = proof_object * proof_terminator @@ -69,14 +71,14 @@ val apply_terminator : proof_terminator -> proof_ending -> unit evar map [sigma] (which can typically contain universe constraints), and with universe bindings pl. *) val start_proof : - Evd.evar_map -> Names.Id.t -> ?pl:Univdecls.universe_decl -> + Evd.evar_map -> Names.Id.t -> ?pl:UState.universe_decl -> Decl_kinds.goal_kind -> (Environ.env * EConstr.types) list -> proof_terminator -> unit (** Like [start_proof] except that there may be dependencies between initial goals. *) val start_dependent_proof : - Names.Id.t -> ?pl:Univdecls.universe_decl -> Decl_kinds.goal_kind -> + Names.Id.t -> ?pl:UState.universe_decl -> Decl_kinds.goal_kind -> Proofview.telescope -> proof_terminator -> unit (** Update the proofs global environment after a side-effecting command @@ -124,11 +126,11 @@ val set_endline_tactic : Genarg.glob_generic_argument -> unit * (w.r.t. type dependencies and let-ins covered by it) + a list of * ids to be cleared *) val set_used_variables : - Names.Id.t list -> Context.Named.t * Misctypes.lident list + Names.Id.t list -> Context.Named.t * Names.lident list val get_used_variables : unit -> Context.Named.t option (** Get the universe declaration associated to the current proof. *) -val get_universe_decl : unit -> Univdecls.universe_decl +val get_universe_decl : unit -> UState.universe_decl module V82 : sig val get_current_initial_conclusions : unit -> Names.Id.t *(EConstr.types list * diff --git a/proofs/proofs.mllib b/proofs/proofs.mllib index 058e839b4..197f71ca9 100644 --- a/proofs/proofs.mllib +++ b/proofs/proofs.mllib @@ -5,6 +5,7 @@ Proof_type Logic Refine Proof +Goal_select Proof_bullet Proof_global Redexpr diff --git a/proofs/redexpr.ml b/proofs/redexpr.ml index 6fb411938..629b77be2 100644 --- a/proofs/redexpr.ml +++ b/proofs/redexpr.ml @@ -12,7 +12,7 @@ open Pp open CErrors open Util open Names -open Term +open Constr open EConstr open Declarations open Globnames @@ -23,7 +23,6 @@ open Tacred open CClosure open RedFlags open Libobject -open Misctypes (* call by value normalisation function using the virtual machine *) let cbv_vm env sigma c = @@ -92,9 +91,9 @@ let cache_strategy (_,str) = let subst_strategy (subs,(local,obj)) = local, - List.smartmap + List.Smart.map (fun (k,ql as entry) -> - let ql' = List.smartmap (Mod_subst.subst_evaluable_reference subs) ql in + let ql' = List.Smart.map (Mod_subst.subst_evaluable_reference subs) ql in if ql==ql' then entry else (k,ql')) obj @@ -200,8 +199,8 @@ let decl_red_expr s e = end let out_arg = function - | ArgVar _ -> anomaly (Pp.str "Unevaluated or_var variable.") - | ArgArg x -> x + | Locus.ArgVar _ -> anomaly (Pp.str "Unevaluated or_var variable.") + | Locus.ArgArg x -> x let out_with_occurrences (occs,c) = (Locusops.occurrences_map (List.map out_arg) occs, c) @@ -263,7 +262,7 @@ let subst_mps subst c = EConstr.of_constr (Mod_subst.subst_mps subst (EConstr.Unsafe.to_constr c)) let subst_red_expr subs = - Miscops.map_red_expr_gen + Redops.map_red_expr_gen (subst_mps subs) (Mod_subst.subst_evaluable_reference subs) (Patternops.subst_pattern subs) diff --git a/proofs/refine.ml b/proofs/refine.ml index 909556b1e..b64e7a2e5 100644 --- a/proofs/refine.ml +++ b/proofs/refine.ml @@ -15,7 +15,7 @@ open Context.Named.Declaration module NamedDecl = Context.Named.Declaration let extract_prefix env info = - let ctx1 = List.rev (Environ.named_context env) in + let ctx1 = List.rev (EConstr.named_context env) in let ctx2 = List.rev (Evd.evar_context info) in let rec share l1 l2 accu = match l1, l2 with | d1 :: l1, d2 :: l2 -> @@ -29,27 +29,20 @@ let typecheck_evar ev env sigma = let info = Evd.find sigma ev in (** Typecheck the hypotheses. *) let type_hyp (sigma, env) decl = - let t = EConstr.of_constr (NamedDecl.get_type decl) in - let evdref = ref sigma in - let _ = Typing.e_sort_of env evdref t in - let () = match decl with - | LocalAssum _ -> () - | LocalDef (_,body,_) -> Typing.e_check env evdref (EConstr.of_constr body) t + let t = NamedDecl.get_type decl in + let sigma, _ = Typing.sort_of env sigma t in + let sigma = match decl with + | LocalAssum _ -> sigma + | LocalDef (_,body,_) -> Typing.check env sigma body t in - (!evdref, Environ.push_named decl env) + (sigma, EConstr.push_named decl env) in let (common, changed) = extract_prefix env info in - let env = Environ.reset_with_named_context (Environ.val_of_named_context common) env in + let env = Environ.reset_with_named_context (EConstr.val_of_named_context common) env in let (sigma, env) = List.fold_left type_hyp (sigma, env) changed in (** Typecheck the conclusion *) - let evdref = ref sigma in - let _ = Typing.e_sort_of env evdref (EConstr.of_constr (Evd.evar_concl info)) in - !evdref - -let typecheck_proof c concl env sigma = - let evdref = ref sigma in - let () = Typing.e_check env evdref c concl in - !evdref + let sigma, _ = Typing.sort_of env sigma (Evd.evar_concl info) in + sigma let (pr_constrv,pr_constr) = Hook.make ~default:(fun _env _sigma _c -> Pp.str"<constr>") () @@ -93,7 +86,7 @@ let generic_refine ~typecheck f gl = let fold accu ev = typecheck_evar ev env accu in let sigma = if typecheck then Evd.fold_future_goals fold sigma evs else sigma in (** Check that the refined term is typesafe *) - let sigma = if typecheck then typecheck_proof c concl env sigma else sigma in + let sigma = if typecheck then Typing.check env sigma c concl else sigma in (** Check that the goal itself does not appear in the refined term *) let self = Proofview.Goal.goal gl in let _ = @@ -106,7 +99,6 @@ let generic_refine ~typecheck f gl = let evs = Evd.map_filter_future_goals (Proofview.Unsafe.advance sigma) evs in let comb,shelf,given_up,evkmain = Evd.dispatch_future_goals evs in (** Proceed to the refinement *) - let c = EConstr.Unsafe.to_constr c in let sigma = match Proofview.Unsafe.advance sigma self with | None -> (** Nothing to do, the goal has been solved by side-effect *) @@ -124,7 +116,8 @@ let generic_refine ~typecheck f gl = (** Mark goals *) let sigma = CList.fold_left Proofview.Unsafe.mark_as_goal sigma comb in let comb = CList.map (fun x -> Proofview.goal_with_state x state) comb in - let trace () = Pp.(hov 2 (str"simple refine"++spc()++ Hook.get pr_constrv env sigma c)) in + let trace () = Pp.(hov 2 (str"simple refine"++spc()++ + Hook.get pr_constrv env sigma (EConstr.Unsafe.to_constr c))) in Proofview.Trace.name_tactic trace (Proofview.tclUNIT v) >>= fun v -> Proofview.Unsafe.tclSETENV (Environ.reset_context env) <*> Proofview.Unsafe.tclEVARS sigma <*> diff --git a/proofs/refiner.mli b/proofs/refiner.mli index 5cd703a25..0f83e16ec 100644 --- a/proofs/refiner.mli +++ b/proofs/refiner.mli @@ -23,9 +23,12 @@ val pf_env : goal sigma -> Environ.env val pf_hyps : goal sigma -> named_context val unpackage : 'a sigma -> evar_map ref * 'a +[@@ocaml.deprecated "Do not use [evar_map ref]"] val repackage : evar_map ref -> 'a -> 'a sigma +[@@ocaml.deprecated "Do not use [evar_map ref]"] val apply_sig_tac : evar_map ref -> (goal sigma -> goal list sigma) -> goal -> goal list +[@@ocaml.deprecated "Do not use [evar_map ref]"] val refiner : rule -> tactic diff --git a/proofs/tacmach.ml b/proofs/tacmach.ml index 1889054f8..092bb5c27 100644 --- a/proofs/tacmach.ml +++ b/proofs/tacmach.ml @@ -33,9 +33,11 @@ let re_sig it gc = { it = it; sigma = gc; } type 'a sigma = 'a Evd.sigma;; type tactic = Proof_type.tactic;; +[@@@ocaml.warning "-3"] let unpackage = Refiner.unpackage let repackage = Refiner.repackage let apply_sig_tac = Refiner.apply_sig_tac +[@@@ocaml.warning "+3"] let sig_it = Refiner.sig_it let project = Refiner.project @@ -73,7 +75,7 @@ let pf_ids_set_of_hyps gls = let pf_get_new_id id gls = next_ident_away id (pf_ids_set_of_hyps gls) -let pf_global gls id = EConstr.of_constr (Universes.constr_of_global (Constrintern.construct_reference (pf_hyps gls) id)) +let pf_global gls id = EConstr.of_constr (UnivGen.constr_of_global (Constrintern.construct_reference (pf_hyps gls) id)) let pf_reduction_of_red_expr gls re c = let (redfun, _) = reduction_of_red_expr (pf_env gls) re in diff --git a/proofs/tacmach.mli b/proofs/tacmach.mli index 770d0940a..31496fb3d 100644 --- a/proofs/tacmach.mli +++ b/proofs/tacmach.mli @@ -30,9 +30,12 @@ val project : goal sigma -> evar_map val re_sig : 'a -> evar_map -> 'a sigma val unpackage : 'a sigma -> evar_map ref * 'a +[@@ocaml.deprecated "Do not use [evar_map ref]"] val repackage : evar_map ref -> 'a -> 'a sigma +[@@ocaml.deprecated "Do not use [evar_map ref]"] val apply_sig_tac : evar_map ref -> (goal sigma -> (goal list) sigma) -> goal -> (goal list) +[@@ocaml.deprecated "Do not use [evar_map ref]"] val pf_concl : goal sigma -> types val pf_env : goal sigma -> env @@ -95,7 +98,7 @@ val pr_glls : goal list sigma -> Pp.t (* Variants of [Tacmach] functions built with the new proof engine *) module New : sig val pf_apply : (env -> evar_map -> 'a) -> Proofview.Goal.t -> 'a - val pf_global : Id.t -> Proofview.Goal.t -> Globnames.global_reference + val pf_global : Id.t -> Proofview.Goal.t -> GlobRef.t (** FIXME: encapsulate the level in an existential type. *) val of_old : (Proof_type.goal Evd.sigma -> 'a) -> Proofview.Goal.t -> 'a diff --git a/interp/tactypes.ml b/proofs/tactypes.ml index 83e42be89..86a7e9c52 100644 --- a/interp/tactypes.ml +++ b/proofs/tactypes.ml @@ -13,15 +13,35 @@ meant to stay. *) open Names -open Constrexpr -open Pattern -open Misctypes -(** In globalize tactics, we need to keep the initial [constr_expr] to recompute - in the environment by the effective calls to Intro, Inversion, etc - The [constr_expr] field is [None] in TacDef though *) -type glob_constr_and_expr = Glob_term.glob_constr * constr_expr option -type glob_constr_pattern_and_expr = Id.Set.t * glob_constr_and_expr * constr_pattern +(** Introduction patterns *) + +type 'constr intro_pattern_expr = + | IntroForthcoming of bool + | IntroNaming of Namegen.intro_pattern_naming_expr + | IntroAction of 'constr intro_pattern_action_expr +and 'constr intro_pattern_action_expr = + | IntroWildcard + | IntroOrAndPattern of 'constr or_and_intro_pattern_expr + | IntroInjection of ('constr intro_pattern_expr) CAst.t list + | IntroApplyOn of 'constr CAst.t * 'constr intro_pattern_expr CAst.t + | IntroRewrite of bool +and 'constr or_and_intro_pattern_expr = + | IntroOrPattern of ('constr intro_pattern_expr) CAst.t list list + | IntroAndPattern of ('constr intro_pattern_expr) CAst.t list + +(** Bindings *) + +type quantified_hypothesis = AnonHyp of int | NamedHyp of Id.t + +type 'a explicit_bindings = (quantified_hypothesis * 'a) CAst.t list + +type 'a bindings = + | ImplicitBindings of 'a list + | ExplicitBindings of 'a explicit_bindings + | NoBindings + +type 'a with_bindings = 'a * 'a bindings type 'a delayed_open = Environ.env -> Evd.evar_map -> Evd.evar_map * 'a @@ -31,4 +51,4 @@ type delayed_open_constr_with_bindings = EConstr.constr with_bindings delayed_op type intro_pattern = delayed_open_constr intro_pattern_expr CAst.t type intro_patterns = delayed_open_constr intro_pattern_expr CAst.t list type or_and_intro_pattern = delayed_open_constr or_and_intro_pattern_expr CAst.t -type intro_pattern_naming = intro_pattern_naming_expr CAst.t +type intro_pattern_naming = Namegen.intro_pattern_naming_expr CAst.t diff --git a/stm/asyncTaskQueue.ml b/stm/asyncTaskQueue.ml index b3e1500ae..768d94d30 100644 --- a/stm/asyncTaskQueue.ml +++ b/stm/asyncTaskQueue.ml @@ -60,7 +60,7 @@ module Make(T : Task) () = struct type request = Request of T.request type more_data = - | MoreDataUnivLevel of Universes.universe_id list + | MoreDataUnivLevel of UnivGen.universe_id list let slave_respond (Request r) = let res = T.perform r in @@ -120,12 +120,11 @@ module Make(T : Task) () = struct let proc, ic, oc = let rec set_slave_opt = function | [] -> !async_proofs_flags_for_workers @ - ["-toploop"; !T.name^"top"; - "-worker-id"; name; + ["-worker-id"; name; "-async-proofs-worker-priority"; - CoqworkmgrApi.(string_of_priority !WorkerLoop.async_proofs_worker_priority)] - | ("-ideslave"|"-emacs"|"-emacs-U"|"-batch")::tl -> set_slave_opt tl - | ("-async-proofs" |"-toploop" |"-vio2vo" + CoqworkmgrApi.(string_of_priority !async_proofs_worker_priority)] + | ("-emacs"|"-emacs-U"|"-batch")::tl -> set_slave_opt tl + | ("-async-proofs" |"-vio2vo" |"-load-vernac-source" |"-l" |"-load-vernac-source-verbose" |"-lv" |"-compile" |"-compile-verbose" |"-async-proofs-worker-priority" |"-worker-id") :: _ :: tl -> @@ -134,7 +133,8 @@ module Make(T : Task) () = struct let args = Array.of_list (set_slave_opt (List.tl (Array.to_list Sys.argv))) in let env = Array.append (T.extra_env ()) (Unix.environment ()) in - Worker.spawn ~env Sys.argv.(0) args in + let worker_name = System.get_toplevel_path ("coq" ^ !T.name) in + Worker.spawn ~env worker_name args in name, proc, CThread.prepare_in_channel_for_thread_friendly_io ic, oc let manager cpanel (id, proc, ic, oc) = @@ -171,7 +171,7 @@ module Make(T : Task) () = struct | Unix.WSIGNALED sno -> Printf.sprintf "signalled(%d)" sno | Unix.WSTOPPED sno -> Printf.sprintf "stopped(%d)" sno) in let more_univs n = - CList.init n (fun _ -> Universes.new_univ_id ()) in + CList.init n (fun _ -> UnivGen.new_univ_id ()) in let rec kill_if () = if not (Worker.is_alive proc) then () @@ -310,7 +310,7 @@ module Make(T : Task) () = struct Marshal.to_channel oc (RespFeedback (debug_with_pid fb)) []; flush oc in ignore (Feedback.add_feeder (fun x -> slave_feeder (Option.get !slave_oc) x)); (* We ask master to allocate universe identifiers *) - Universes.set_remote_new_univ_id (bufferize (fun () -> + UnivGen.set_remote_new_univ_id (bufferize (fun () -> marshal_response (Option.get !slave_oc) RespGetCounterNewUnivLevel; match unmarshal_more_data (Option.get !slave_ic) with | MoreDataUnivLevel l -> l)); diff --git a/stm/coqworkmgrApi.ml b/stm/coqworkmgrApi.ml index 36b5d18ab..841cc08c0 100644 --- a/stm/coqworkmgrApi.ml +++ b/stm/coqworkmgrApi.ml @@ -11,6 +11,10 @@ let debug = false type priority = Low | High + +(* Default priority *) +let async_proofs_worker_priority = ref Low + let string_of_priority = function Low -> "low" | High -> "high" let priority_of_string = function | "low" -> Low diff --git a/stm/coqworkmgrApi.mli b/stm/coqworkmgrApi.mli index 2983b619d..be5b29177 100644 --- a/stm/coqworkmgrApi.mli +++ b/stm/coqworkmgrApi.mli @@ -14,6 +14,9 @@ type priority = Low | High val string_of_priority : priority -> string val priority_of_string : string -> priority +(* Default priority *) +val async_proofs_worker_priority : priority ref + (* Connects to a work manager if any. If no worker manager, then -async-proofs-j and -async-proofs-tac-j are used *) val init : priority -> unit diff --git a/stm/proofBlockDelimiter.ml b/stm/proofBlockDelimiter.ml index 23f976120..b8af2bcd5 100644 --- a/stm/proofBlockDelimiter.ml +++ b/stm/proofBlockDelimiter.ml @@ -23,8 +23,8 @@ val crawl : static_block_declaration option val unit_val : Stm.DynBlockData.t -val of_bullet_val : Vernacexpr.bullet -> Stm.DynBlockData.t -val to_bullet_val : Stm.DynBlockData.t -> Vernacexpr.bullet +val of_bullet_val : Proof_bullet.t -> Stm.DynBlockData.t +val to_bullet_val : Stm.DynBlockData.t -> Proof_bullet.t val of_vernac_control_val : Vernacexpr.vernac_control -> Stm.DynBlockData.t val to_vernac_control_val : Stm.DynBlockData.t -> Vernacexpr.vernac_control @@ -41,7 +41,7 @@ let simple_goal sigma g gs = let open Evd in let open Evarutil in let evi = Evd.find sigma g in - Set.is_empty (evars_of_term evi.evar_concl) && + Set.is_empty (evars_of_term (EConstr.Unsafe.to_constr evi.evar_concl)) && Set.is_empty (evars_of_filtered_evar_info (nf_evar_info sigma evi)) && not (List.exists (Proofview.depends_on sigma g) gs) diff --git a/stm/proofBlockDelimiter.mli b/stm/proofBlockDelimiter.mli index 9784de114..eacd3687a 100644 --- a/stm/proofBlockDelimiter.mli +++ b/stm/proofBlockDelimiter.mli @@ -38,6 +38,6 @@ val crawl : val unit_val : Stm.DynBlockData.t (* Bullets *) -val of_bullet_val : Vernacexpr.bullet -> Stm.DynBlockData.t -val to_bullet_val : Stm.DynBlockData.t -> Vernacexpr.bullet +val of_bullet_val : Proof_bullet.t -> Stm.DynBlockData.t +val to_bullet_val : Stm.DynBlockData.t -> Proof_bullet.t diff --git a/stm/proofworkertop.mllib b/stm/proofworkertop.mllib deleted file mode 100644 index f9f6c22d5..000000000 --- a/stm/proofworkertop.mllib +++ /dev/null @@ -1 +0,0 @@ -Proofworkertop diff --git a/stm/queryworkertop.mllib b/stm/queryworkertop.mllib deleted file mode 100644 index c2f73089b..000000000 --- a/stm/queryworkertop.mllib +++ /dev/null @@ -1 +0,0 @@ -Queryworkertop diff --git a/stm/stm.ml b/stm/stm.ml index ba0a2017a..c394be22e 100644 --- a/stm/stm.ml +++ b/stm/stm.ml @@ -92,11 +92,11 @@ let execution_error ?loc state_id msg = module Hooks = struct let state_computed, state_computed_hook = Hook.make - ~default:(fun state_id ~in_cache -> + ~default:(fun ~doc:_ state_id ~in_cache -> feedback ~id:state_id Processed) () let state_ready, state_ready_hook = Hook.make - ~default:(fun state_id -> ()) () + ~default:(fun ~doc:_ state_id -> ()) () let forward_feedback, forward_feedback_hook = let m = Mutex.create () in @@ -106,7 +106,7 @@ let forward_feedback, forward_feedback_hook = with e -> Mutex.unlock m; raise e) () let unreachable_state, unreachable_state_hook = Hook.make - ~default:(fun _ _ -> ()) () + ~default:(fun ~doc:_ _ _ -> ()) () include Hook @@ -578,7 +578,7 @@ end = struct (* {{{ *) | None -> raise Vcs_aux.Expired let set_state id s = (get_info id).state <- s; - if async_proofs_is_master !cur_opt then Hooks.(call state_ready id) + if async_proofs_is_master !cur_opt then Hooks.(call state_ready ~doc:dummy_doc (* XXX should be taken in input *) id) let get_state id = (get_info id).state let reached id = let info = get_info id in @@ -770,6 +770,7 @@ module State : sig Warning: an optimization in installed_cached requires that state modifying functions are always executed using this wrapper. *) val define : + doc:doc -> ?safe_id:Stateid.t -> ?redefine:bool -> ?cache:Summary.marshallable -> ?feedback_processed:bool -> (unit -> unit) -> Stateid.t -> unit @@ -919,7 +920,7 @@ end = struct (* {{{ *) let e2 = Summary.project_from_summary s2 Global.global_env_summary_tag in e1 == e2 - let define ?safe_id ?(redefine=false) ?(cache=`No) ?(feedback_processed=true) + let define ~doc ?safe_id ?(redefine=false) ?(cache=`No) ?(feedback_processed=true) f id = feedback ~id:id (ProcessingIn !Flags.async_proofs_worker_id); @@ -938,7 +939,7 @@ end = struct (* {{{ *) stm_prerr_endline (fun () -> "setting cur id to "^str_id); cur_id := id; if feedback_processed then - Hooks.(call state_computed id ~in_cache:false); + Hooks.(call state_computed ~doc id ~in_cache:false); VCS.reached id; if Proof_global.there_are_pending_proofs () then VCS.goals id (Proof_global.get_open_goals ()) @@ -954,7 +955,7 @@ end = struct (* {{{ *) | Some _, None -> (e, info) | Some (_,at), Some id -> (e, Stateid.add info ~valid:id at) in if cache = `Yes || cache = `Shallow then freeze_invalid id ie; - Hooks.(call unreachable_state id ie); + Hooks.(call unreachable_state ~doc id ie); Exninfo.iraise ie let init_state = ref None @@ -1352,6 +1353,7 @@ module rec ProofTask : sig and type request := request val build_proof_here : + doc:doc -> ?loc:Loc.t -> drop_pt:bool -> Stateid.t * Stateid.t -> Stateid.t -> @@ -1466,11 +1468,12 @@ end = struct (* {{{ *) execution_error start (Pp.strbrk s); feedback (InProgress ~-1) - let build_proof_here ?loc ~drop_pt (id,valid) eop = + let build_proof_here ~doc ?loc ~drop_pt (id,valid) eop = Future.create (State.exn_on id ~valid) (fun () -> let wall_clock1 = Unix.gettimeofday () in - if VCS.is_interactive () = `No then Reach.known_state ~cache:`No eop - else Reach.known_state ~cache:`Shallow eop; + if VCS.is_interactive () = `No + then Reach.known_state ~doc ~cache:`No eop + else Reach.known_state ~doc ~cache:`Shallow eop; let wall_clock2 = Unix.gettimeofday () in Aux_file.record_in_aux_at ?loc "proof_build_time" (Printf.sprintf "%.3f" (wall_clock2 -. wall_clock1)); @@ -1484,7 +1487,7 @@ end = struct (* {{{ *) VCS.print (); let proof, future_proof, time = let wall_clock = Unix.gettimeofday () in - let fp = build_proof_here ?loc ~drop_pt:drop exn_info stop in + let fp = build_proof_here ~doc:dummy_doc (* XXX should be document *) ?loc ~drop_pt:drop exn_info stop in let proof = Future.force fp in proof, fp, Unix.gettimeofday () -. wall_clock in (* We typecheck the proof with the kernel (in the worker) to spot @@ -1508,7 +1511,7 @@ end = struct (* {{{ *) stm_vernac_interp stop ~proof:(pobject, terminator) st { verbose = false; loc; indentation = 0; strlen = 0; - expr = VernacExpr ([], VernacEndProof (Proved (Opaque,None))) }) in + expr = VernacExpr ([], VernacEndProof (Proved (Proof_global.Opaque,None))) }) in ignore(Future.join checked_proof); end; (* STATE: Restore the state XXX: handle exn *) @@ -1577,7 +1580,7 @@ end = struct (* {{{ *) msg_warning Pp.(strbrk("Marshalling error: "^s^". "^ "The system state could not be sent to the worker process. "^ "Falling back to local, lazy, evaluation.")); - t_assign(`Comp(build_proof_here ?loc:t_loc ~drop_pt t_exn_info t_stop)); + t_assign(`Comp(build_proof_here ~doc:dummy_doc (* XXX should be stored in a closure, it is the same doc that was used to generate the task *) ?loc:t_loc ~drop_pt t_exn_info t_stop)); feedback (InProgress ~-1) end (* }}} *) @@ -1587,6 +1590,7 @@ and Slaves : sig (* (eventually) remote calls *) val build_proof : + doc:doc -> ?loc:Loc.t -> drop_pt:bool -> exn_info:(Stateid.t * Stateid.t) -> block_start:Stateid.t -> block_stop:Stateid.t -> name:string -> future_proof * AsyncTaskQueue.cancel_switch @@ -1634,7 +1638,7 @@ end = struct (* {{{ *) with VCS.Expired -> cur in aux stop in try - Reach.known_state ~cache:`No stop; + Reach.known_state ~doc:dummy_doc (* XXX should be document *) ~cache:`No stop; if drop then let _proof = Proof_global.return_proof ~allow_partial:true () in `OK_ADMITTED @@ -1647,7 +1651,7 @@ end = struct (* {{{ *) Proof_global.close_proof ~keep_body_ucst_separate:true (fun x -> x) in (* We jump at the beginning since the kernel handles side effects by also * looking at the ones that happen to be present in the current env *) - Reach.known_state ~cache:`No start; + Reach.known_state ~doc:dummy_doc (* XXX should be document *) ~cache:`No start; (* STATE SPEC: * - start: First non-expired state! [This looks very fishy] * - end : start + qed @@ -1657,7 +1661,7 @@ end = struct (* {{{ *) let st = Vernacstate.freeze_interp_state `No in ignore(stm_vernac_interp stop ~proof st { verbose = false; loc; indentation = 0; strlen = 0; - expr = VernacExpr ([], VernacEndProof (Proved (Opaque,None))) }); + expr = VernacExpr ([], VernacEndProof (Proved (Proof_global.Opaque,None))) }); `OK proof end with e -> @@ -1754,7 +1758,7 @@ end = struct (* {{{ *) BuildProof { t_states = s2 } -> overlap_rel s1 s2 | _ -> 0) - let build_proof ?loc ~drop_pt ~exn_info ~block_start ~block_stop ~name:pname = + let build_proof ~doc ?loc ~drop_pt ~exn_info ~block_start ~block_stop ~name:pname = let id, valid as t_exn_info = exn_info in let cancel_switch = ref false in if TaskQueue.n_workers (Option.get !queue) = 0 then @@ -1769,7 +1773,7 @@ end = struct (* {{{ *) TaskQueue.enqueue_task (Option.get !queue) task ~cancel_switch; f, cancel_switch end else - ProofTask.build_proof_here ?loc ~drop_pt t_exn_info block_stop, cancel_switch + ProofTask.build_proof_here ~doc ?loc ~drop_pt t_exn_info block_stop, cancel_switch else let f, t_assign = Future.create_delegate ~name:pname (State.exn_on id ~valid) in let t_uuid = Future.uuid f in @@ -1845,7 +1849,7 @@ end = struct (* {{{ *) | RespError of Pp.t | RespNoProgress - let name = ref "tacworker" + let name = ref "tacticworker" let extra_env () = [||] type competence = unit type worker_status = Fresh | Old of competence @@ -1892,11 +1896,11 @@ end = struct (* {{{ *) let perform { r_state = id; r_state_fb; r_document = vcs; r_ast; r_goal } = Option.iter VCS.restore vcs; try - Reach.known_state ~cache:`No id; + Reach.known_state ~doc:dummy_doc (* XXX should be vcs *) ~cache:`No id; stm_purify (fun () -> let _,_,_,_,sigma0 = Proof.proof (Proof_global.give_me_the_proof ()) in let g = Evd.find sigma0 r_goal in - let is_ground c = Evarutil.is_ground_term sigma0 (EConstr.of_constr c) in + let is_ground c = Evarutil.is_ground_term sigma0 c in if not ( is_ground Evd.(evar_concl g) && List.for_all (Context.Named.Declaration.for_all is_ground) @@ -1919,7 +1923,6 @@ end = struct (* {{{ *) match Evd.(evar_body (find sigma r_goal)) with | Evd.Evar_empty -> RespNoProgress | Evd.Evar_defined t -> - let t = EConstr.of_constr t in let t = Evarutil.nf_evar sigma t in if Evarutil.is_ground_term sigma t then let t = EConstr.Unsafe.to_constr t in @@ -2048,7 +2051,7 @@ end = struct (* {{{ *) let perform { r_where; r_doc; r_what; r_for } = VCS.restore r_doc; VCS.print (); - Reach.known_state ~cache:`No r_where; + Reach.known_state ~doc:dummy_doc (* XXX should be r_doc *) ~cache:`No r_where; (* STATE *) let st = Vernacstate.freeze_interp_state `No in try @@ -2093,7 +2096,8 @@ end (* }}} *) and Reach : sig val known_state : - ?redefine_qed:bool -> cache:Summary.marshallable -> Stateid.t -> unit + doc:doc -> ?redefine_qed:bool -> cache:Summary.marshallable -> + Stateid.t -> unit end = struct (* {{{ *) @@ -2109,12 +2113,6 @@ let delegate name = || VCS.is_vio_doc () || !cur_opt.async_proofs_full -let warn_deprecated_nested_proofs = - CWarnings.create ~name:"deprecated-nested-proofs" ~category:"deprecated" - (fun () -> - strbrk ("Nested proofs are deprecated and will "^ - "stop working in a future Coq version")) - let collect_proof keep cur hd brkind id = stm_prerr_endline (fun () -> "Collecting proof ending at "^Stateid.to_string id); let no_name = "" in @@ -2123,7 +2121,7 @@ let collect_proof keep cur hd brkind id = | id :: _ -> Names.Id.to_string id in let loc = (snd cur).loc in let is_defined_expr = function - | VernacEndProof (Proved (Transparent,_)) -> true + | VernacEndProof (Proved (Proof_global.Transparent,_)) -> true | _ -> false in let is_defined = function | _, { expr = e } -> is_defined_expr (Vernacprop.under_control e) @@ -2196,8 +2194,7 @@ let collect_proof keep cur hd brkind id = assert (VCS.Branch.equal hd hd' || VCS.Branch.equal hd VCS.edit_branch); let name = name ids in `MaybeASync (parent last, accn, name, delegate name) - | `Sideff _ -> - warn_deprecated_nested_proofs (); + | `Sideff (CherryPickEnv,_) -> `Sync (no_name,`NestedProof) | _ -> `Sync (no_name,`Unknown) in let make_sync why = function @@ -2251,7 +2248,7 @@ let log_processing_sync id name reason = log_string Printf.(sprintf let wall_clock_last_fork = ref 0.0 -let known_state ?(redefine_qed=false) ~cache id = +let known_state ~doc ?(redefine_qed=false) ~cache id = let error_absorbing_tactic id blockname exn = (* We keep the static/dynamic part of block detection separate, since @@ -2284,7 +2281,7 @@ let known_state ?(redefine_qed=false) ~cache id = Proof_global.unfreeze proof; Proof_global.with_current_proof (fun _ p -> feedback ~id:id Feedback.AddedAxiom; - fst (Pfedit.solve Vernacexpr.SelectAll None tac p), ()); + fst (Pfedit.solve Goal_select.SelectAll None tac p), ()); (* STATE SPEC: * - start: Modifies the input state adding a proof. * - end : maybe after recovery command. @@ -2346,7 +2343,7 @@ let known_state ?(redefine_qed=false) ~cache id = and reach ?safe_id ?(redefine_qed=false) ?(cache=cache) id = stm_prerr_endline (fun () -> "reaching: " ^ Stateid.to_string id); if not redefine_qed && State.is_cached ~cache id then begin - Hooks.(call state_computed id ~in_cache:true); + Hooks.(call state_computed ~doc id ~in_cache:true); stm_prerr_endline (fun () -> "reached (cache)"); State.install_cached id end else @@ -2427,7 +2424,7 @@ let known_state ?(redefine_qed=false) ~cache id = ^" proof. Reprocess the command declaring " ^"the proof's statement to avoid that.")); let fp, cancel = - Slaves.build_proof + Slaves.build_proof ~doc ?loc ~drop_pt ~exn_info ~block_start ~block_stop ~name in Future.replace ofp fp; qed.fproof <- Some (fp, cancel); @@ -2439,10 +2436,10 @@ let known_state ?(redefine_qed=false) ~cache id = reach ~cache:`Shallow block_start; let fp, cancel = if delegate then - Slaves.build_proof + Slaves.build_proof ~doc ?loc ~drop_pt ~exn_info ~block_start ~block_stop ~name else - ProofTask.build_proof_here ?loc + ProofTask.build_proof_here ~doc ?loc ~drop_pt exn_info block_stop, ref false in qed.fproof <- Some (fp, cancel); @@ -2512,7 +2509,7 @@ let known_state ?(redefine_qed=false) ~cache id = let cache_step = if !cur_opt.async_proofs_cache = Some Force then `Yes else cache_step in - State.define ?safe_id + State.define ~doc ?safe_id ~cache:cache_step ~redefine:redefine_qed ~feedback_processed step id; stm_prerr_endline (fun () -> "reached: "^ Stateid.to_string id) in reach ~redefine_qed id @@ -2601,7 +2598,7 @@ let new_doc { doc_type ; iload_path; require_libs; stm_options } = load_objs require_libs; (* We record the state at this point! *) - State.define ~cache:`Yes ~redefine:true (fun () -> ()) Stateid.initial; + State.define ~doc ~cache:`Yes ~redefine:true (fun () -> ()) Stateid.initial; Backtrack.record (); Slaves.init (); if async_proofs_is_master !cur_opt then begin @@ -2622,7 +2619,7 @@ let new_doc { doc_type ; iload_path; require_libs; stm_options } = let observe ~doc id = let vcs = VCS.backup () in try - Reach.known_state ~cache:(VCS.is_interactive ()) id; + Reach.known_state ~doc ~cache:(VCS.is_interactive ()) id; VCS.print (); doc with e -> @@ -2715,7 +2712,7 @@ let merge_proof_branch ~valid ?id qast keep brname = VCS.rewrite_merge qed_id ~ours:(Qed (qed ofp)) ~at:master_id brname; VCS.delete_branch brname; VCS.gc (); - let _st = Reach.known_state ~redefine_qed:true ~cache:`No qed_id in + let _st : unit = Reach.known_state ~doc:dummy_doc (* XXX should be taken in input *) ~redefine_qed:true ~cache:`No qed_id in VCS.checkout VCS.Branch.master; `Unfocus qed_id | { VCS.kind = `Master } -> @@ -2767,7 +2764,15 @@ let process_back_meta_command ~newtip ~head oid aast w = VCS.commit id (Alias (oid,aast)); Backtrack.record (); if w == VtNow then ignore(finish ~doc:dummy_doc); `Ok -let process_transaction ?(newtip=Stateid.fresh ()) +let allow_nested_proofs = ref false +let _ = Goptions.declare_bool_option + { Goptions.optdepr = false; + Goptions.optname = "Nested Proofs Allowed"; + Goptions.optkey = Vernac_classifier.stm_allow_nested_proofs_option_name; + Goptions.optread = (fun () -> !allow_nested_proofs); + Goptions.optwrite = (fun b -> allow_nested_proofs := b) } + +let process_transaction ~doc ?(newtip=Stateid.fresh ()) ({ verbose; loc; expr } as x) c = stm_pperr_endline (fun () -> str "{{{ processing: " ++ pr_ast x); let vcs = VCS.backup () in @@ -2798,6 +2803,15 @@ let process_transaction ?(newtip=Stateid.fresh ()) (* Proof *) | VtStartProof (mode, guarantee, names), w -> + + if not !allow_nested_proofs && VCS.proof_nesting () > 0 then + "Nested proofs are not allowed unless you turn option Nested Proofs Allowed on." + |> Pp.str + |> (fun s -> (UserError (None, s), Exninfo.null)) + |> State.exn_on ~valid:Stateid.dummy Stateid.dummy + |> Exninfo.iraise + else + let id = VCS.new_node ~id:newtip () in let bname = VCS.mk_branch_name x in VCS.checkout VCS.Branch.master; @@ -2872,11 +2886,11 @@ let process_transaction ?(newtip=Stateid.fresh ()) let in_proof = not (VCS.Branch.equal head VCS.Branch.master) in let id = VCS.new_node ~id:newtip () in let head_id = VCS.get_branch_pos head in - let _st = Reach.known_state ~cache:`Yes head_id in (* ensure it is ok *) + let _st : unit = Reach.known_state ~doc ~cache:`Yes head_id in (* ensure it is ok *) let step () = VCS.checkout VCS.Branch.master; let mid = VCS.get_branch_pos VCS.Branch.master in - let _st' = Reach.known_state ~cache:(VCS.is_interactive ()) mid in + let _st' : unit = Reach.known_state ~doc ~cache:(VCS.is_interactive ()) mid in let st = Vernacstate.freeze_interp_state `No in ignore(stm_vernac_interp id st x); (* Vernac x may or may not start a proof *) @@ -2902,7 +2916,7 @@ let process_transaction ?(newtip=Stateid.fresh ()) end; VCS.checkout_shallowest_proof_branch (); end in - State.define ~safe_id:head_id ~cache:`Yes step id; + State.define ~doc ~safe_id:head_id ~cache:`Yes step id; Backtrack.record (); `Ok | VtUnknown, VtLater -> @@ -2962,7 +2976,7 @@ let parse_sentence ~doc sid pa = str "All is good if not parsing changes occur between the two states, however if they do, a problem might occur."); Flags.with_option Flags.we_are_parsing (fun () -> try - match Pcoq.Gram.entry_parse Pcoq.main_entry pa with + match Pcoq.Gram.entry_parse Pvernac.main_entry pa with | None -> raise End_of_input | Some (loc, cmd) -> CAst.make ~loc cmd with e when CErrors.noncritical e -> @@ -3013,11 +3027,10 @@ let add ~doc ~ontop ?newtip verb { CAst.loc; v=ast } = str ") than the tip: " ++ str (Stateid.to_string cur_tip) ++ str "." ++ fnl () ++ str "This is not supported yet, sorry."); let indentation, strlen = compute_indentation ?loc ontop in - CWarnings.set_current_loc loc; (* XXX: Classifiy vernac should be moved inside process transaction *) let clas = Vernac_classifier.classify_vernac ast in let aast = { verbose = verb; indentation; strlen; loc; expr = ast } in - match process_transaction ?newtip aast clas with + match process_transaction ~doc ?newtip aast clas with | `Ok -> doc, VCS.cur_tip (), `NewTip | `Unfocus qed_id -> doc, qed_id, `Unfocus (VCS.cur_tip ()) @@ -3032,12 +3045,11 @@ type focus = { let query ~doc ~at ~route s = stm_purify (fun s -> if Stateid.equal at Stateid.dummy then ignore(finish ~doc:dummy_doc) - else Reach.known_state ~cache:`Yes at; + else Reach.known_state ~doc ~cache:`Yes at; try while true do let { CAst.loc; v=ast } = parse_sentence ~doc at s in let indentation, strlen = compute_indentation ?loc at in - CWarnings.set_current_loc loc; let st = State.get_cached at in let aast = { verbose = true; indentation; strlen; loc; expr = ast } in ignore(stm_vernac_interp ~route at st aast) @@ -3095,7 +3107,7 @@ let edit_at ~doc id = VCS.edit_branch (`Edit (mode, qed_id, master_id, keep, old_branch)); VCS.delete_boxes_of id; cancel_switch := true; - Reach.known_state ~cache:(VCS.is_interactive ()) id; + Reach.known_state ~doc ~cache:(VCS.is_interactive ()) id; VCS.checkout_shallowest_proof_branch (); `Focus { stop = qed_id; start = master_id; tip } in let no_edit = function @@ -3118,7 +3130,7 @@ let edit_at ~doc id = VCS.gc (); VCS.print (); if not !cur_opt.async_proofs_full then - Reach.known_state ~cache:(VCS.is_interactive ()) id; + Reach.known_state ~doc ~cache:(VCS.is_interactive ()) id; VCS.checkout_shallowest_proof_branch (); `NewTip in try @@ -3147,7 +3159,7 @@ let edit_at ~doc id = | true, None, _ -> if on_cur_branch id then begin VCS.reset_branch (VCS.current_branch ()) id; - Reach.known_state ~cache:(VCS.is_interactive ()) id; + Reach.known_state ~doc ~cache:(VCS.is_interactive ()) id; VCS.checkout_shallowest_proof_branch (); `NewTip end else if is_ancestor_of_cur_branch id then begin @@ -3210,4 +3222,9 @@ let forward_feedback_hook = Hooks.forward_feedback_hook let unreachable_state_hook = Hooks.unreachable_state_hook let () = Hook.set Obligations.stm_get_fix_exn (fun () -> !State.fix_exn_ref) +type document = VCS.vcs +let backup () = VCS.backup () +let restore d = VCS.restore d + + (* vim:set foldmethod=marker: *) diff --git a/stm/stm.mli b/stm/stm.mli index 7a720aa72..aed7274d0 100644 --- a/stm/stm.mli +++ b/stm/stm.mli @@ -263,11 +263,12 @@ val register_proof_block_delimiter : * the alternative toploop for the worker can be selected by changing * the name of the Task(s) above) *) -val state_computed_hook : (Stateid.t -> in_cache:bool -> unit) Hook.t -val unreachable_state_hook : (Stateid.t -> Exninfo.iexn -> unit) Hook.t +val state_computed_hook : (doc:doc -> Stateid.t -> in_cache:bool -> unit) Hook.t +val unreachable_state_hook : + (doc:doc -> Stateid.t -> Exninfo.iexn -> unit) Hook.t (* ready means that master has it at hand *) -val state_ready_hook : (Stateid.t -> unit) Hook.t +val state_ready_hook : (doc:doc -> Stateid.t -> unit) Hook.t (* Messages from the workers to the master *) val forward_feedback_hook : (Feedback.feedback -> unit) Hook.t @@ -283,3 +284,7 @@ val get_all_proof_names : doc:doc -> Id.t list (** Enable STM debugging *) val stm_debug : bool ref + +type document +val backup : unit -> document +val restore : document -> unit diff --git a/stm/stm.mllib b/stm/stm.mllib index 72b538016..4b254e811 100644 --- a/stm/stm.mllib +++ b/stm/stm.mllib @@ -5,7 +5,6 @@ TQueue WorkerPool Vernac_classifier CoqworkmgrApi -WorkerLoop AsyncTaskQueue Stm ProofBlockDelimiter diff --git a/stm/tacworkertop.mllib b/stm/tacworkertop.mllib deleted file mode 100644 index db38fde27..000000000 --- a/stm/tacworkertop.mllib +++ /dev/null @@ -1 +0,0 @@ -Tacworkertop diff --git a/stm/vernac_classifier.ml b/stm/vernac_classifier.ml index c08cc6e36..e01dcbcb6 100644 --- a/stm/vernac_classifier.ml +++ b/stm/vernac_classifier.ml @@ -54,13 +54,20 @@ let idents_of_name : Names.Name.t -> Names.Id.t list = | Names.Anonymous -> [] | Names.Name n -> [n] +let stm_allow_nested_proofs_option_name = ["Nested";"Proofs";"Allowed"] + +let options_affecting_stm_scheduling = + [ Vernacentries.universe_polymorphism_option_name; + stm_allow_nested_proofs_option_name ] + let classify_vernac e = let static_classifier ~poly e = match e with (* Univ poly compatibility: we run it now, so that we can just * look at Flags in stm.ml. Would be nicer to have the stm * look at the entire dag to detect this option. *) | ( VernacSetOption (_, l,_) | VernacUnsetOption (_, l)) - when CList.equal String.equal l Vernacentries.universe_polymorphism_option_name -> + when CList.exists (CList.equal String.equal l) + options_affecting_stm_scheduling -> VtSideff [], VtNow (* Qed *) | VernacAbort _ -> VtQed VtDrop, VtLater diff --git a/stm/vernac_classifier.mli b/stm/vernac_classifier.mli index abbc04e89..45fbfb42a 100644 --- a/stm/vernac_classifier.mli +++ b/stm/vernac_classifier.mli @@ -25,3 +25,4 @@ val classify_as_query : vernac_classification val classify_as_sideeff : vernac_classification val classify_as_proofstep : vernac_classification +val stm_allow_nested_proofs_option_name : string list diff --git a/stm/workerLoop.mli b/stm/workerLoop.mli index f02edb9bb..37ec6dacc 100644 --- a/stm/workerLoop.mli +++ b/stm/workerLoop.mli @@ -11,4 +11,6 @@ (* Default priority *) val async_proofs_worker_priority : CoqworkmgrApi.priority ref -val loop : (unit -> unit) -> Coqargs.coq_cmdopts -> string list -> string list +val loop : + (unit -> unit) -> Coqargs.coq_cmdopts -> string list -> + Coqargs.coq_cmdopts * string list diff --git a/tactics/auto.ml b/tactics/auto.ml index 0c0d9bcfc..d7de6c4fb 100644 --- a/tactics/auto.ml +++ b/tactics/auto.ml @@ -8,8 +8,6 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) -module CVars = Vars - open Pp open Util open Names @@ -81,15 +79,14 @@ let connect_hint_clenv poly (c, _, ctx) clenv gl = let clenv, c = if poly then (** Refresh the instance of the hint *) - let (subst, ctx) = Universes.fresh_universe_context_set_instance ctx in - let map c = CVars.subst_univs_level_constr subst c in + let (subst, ctx) = UnivGen.fresh_universe_context_set_instance ctx in let emap c = Vars.subst_univs_level_constr subst c in let evd = Evd.merge_context_set Evd.univ_flexible evd ctx in (** Only metas are mentioning the old universes. *) let clenv = { templval = Evd.map_fl emap clenv.templval; templtyp = Evd.map_fl emap clenv.templtyp; - evd = Evd.map_metas map evd; + evd = Evd.map_metas emap evd; env = Proofview.Goal.env gl; } in clenv, emap c @@ -102,7 +99,7 @@ let unify_resolve poly flags ((c : raw_hint), clenv) = Proofview.Goal.enter begin fun gl -> let clenv, c = connect_hint_clenv poly c clenv gl in let clenv = clenv_unique_resolver ~flags clenv gl in - Clenvtac.clenv_refine false clenv + Clenvtac.clenv_refine clenv end let unify_resolve_nodelta poly h = unify_resolve poly auto_unif_flags h diff --git a/tactics/autorewrite.ml b/tactics/autorewrite.ml index c3857e6b8..c8fd0b7a7 100644 --- a/tactics/autorewrite.ml +++ b/tactics/autorewrite.ml @@ -30,7 +30,7 @@ let subst_hint subst hint = let cst' = subst_mps subst hint.rew_lemma in let typ' = subst_mps subst hint.rew_type in let pat' = subst_mps subst hint.rew_pat in - let t' = Option.smartmap (Genintern.generic_substitute subst) hint.rew_tac in + let t' = Option.Smart.map (Genintern.generic_substitute subst) hint.rew_tac in if hint.rew_lemma == cst' && hint.rew_type == typ' && hint.rew_tac == t' then hint else { hint with rew_lemma = cst'; rew_type = typ'; @@ -93,7 +93,7 @@ let one_base general_rewrite_maybe_in tac_main bas = let try_rewrite dir ctx c tc = Proofview.Goal.enter begin fun gl -> let sigma = Proofview.Goal.sigma gl in - let subst, ctx' = Universes.fresh_universe_context_set_instance ctx in + let subst, ctx' = UnivGen.fresh_universe_context_set_instance ctx in let c' = Vars.subst_univs_level_constr subst c in let sigma = Evd.merge_context_set Evd.univ_flexible sigma ctx' in Proofview.tclTHEN (Proofview.Unsafe.tclEVARS sigma) @@ -228,7 +228,7 @@ let decompose_applied_relation metas env sigma c ctype left2right = if metas then eqclause else clenv_pose_metas_as_evars eqclause (Evd.undefined_metas eqclause.evd) in - let (equiv, args) = decompose_app (EConstr.Unsafe.to_constr (Clenv.clenv_type eqclause)) in + let (equiv, args) = EConstr.decompose_app sigma (Clenv.clenv_type eqclause) in let rec split_last_two = function | [c1;c2] -> [],(c1, c2) | x::y::z -> @@ -236,17 +236,19 @@ let decompose_applied_relation metas env sigma c ctype left2right = | _ -> raise Not_found in try - let others,(c1,c2) = split_last_two args in - let ty1, ty2 = - Typing.unsafe_type_of env eqclause.evd (EConstr.of_constr c1), Typing.unsafe_type_of env eqclause.evd (EConstr.of_constr c2) - in - let ty = EConstr.Unsafe.to_constr ty in - let ty1 = EConstr.Unsafe.to_constr ty1 in + let others,(c1,c2) = split_last_two args in + let ty1, ty2 = Typing.unsafe_type_of env eqclause.evd c1, Typing.unsafe_type_of env eqclause.evd c2 in + (* XXX: It looks like mk_clenv_from_env should be fixed instead? *) + let open EConstr in + let hyp_ty = Unsafe.to_constr ty in + let hyp_car = Unsafe.to_constr ty1 in + let hyp_prf = Unsafe.to_constr @@ Clenv.clenv_value eqclause in + let hyp_rel = Unsafe.to_constr @@ mkApp (equiv, Array.of_list others) in + let hyp_left = Unsafe.to_constr @@ c1 in + let hyp_right = Unsafe.to_constr @@ c2 in (* if not (evd_convertible env eqclause.evd ty1 ty2) then None *) (* else *) - Some { hyp_cl=eqclause; hyp_prf=EConstr.Unsafe.to_constr (Clenv.clenv_value eqclause); hyp_ty = ty; - hyp_car=ty1; hyp_rel=mkApp (equiv, Array.of_list others); - hyp_l2r=left2right; hyp_left=c1; hyp_right=c2; } + Some { hyp_cl=eqclause; hyp_prf; hyp_ty; hyp_car; hyp_rel; hyp_l2r=left2right; hyp_left; hyp_right; } with Not_found -> None in match find_rel ctype with diff --git a/tactics/btermdn.ml b/tactics/btermdn.ml index 8e50c977e..aca7f6c65 100644 --- a/tactics/btermdn.ml +++ b/tactics/btermdn.ml @@ -9,7 +9,7 @@ (************************************************************************) open Util -open Term +open Constr open EConstr open Names open Pattern @@ -22,7 +22,7 @@ open Globnames let dnet_depth = ref 8 type term_label = -| GRLabel of global_reference +| GRLabel of GlobRef.t | ProdLabel | LambdaLabel | SortLabel diff --git a/tactics/class_tactics.ml b/tactics/class_tactics.ml index 0260460e6..773fc1520 100644 --- a/tactics/class_tactics.ml +++ b/tactics/class_tactics.ml @@ -18,6 +18,7 @@ open CErrors open Util open Names open Term +open Constr open Termops open EConstr open Tacmach @@ -206,7 +207,7 @@ let clenv_unique_resolver_tac with_evars ~flags clenv' = try Proofview.tclUNIT (clenv_unique_resolver ~flags clenv' gls) with e -> Proofview.tclZERO e in resolve >>= fun clenv' -> - Clenvtac.clenv_refine with_evars ~with_classes:false clenv' + Clenvtac.clenv_refine ~with_evars ~with_classes:false clenv' end let unify_e_resolve poly flags = begin fun gls (c,_,clenv) -> @@ -226,7 +227,7 @@ let unify_resolve_refine poly flags gls ((c, t, ctx),n,clenv) = Refine.refine ~typecheck:false begin fun sigma -> let sigma, term, ty = if poly then - let (subst, ctx) = Universes.fresh_universe_context_set_instance ctx in + let (subst, ctx) = UnivGen.fresh_universe_context_set_instance ctx in let map c = Vars.subst_univs_level_constr subst c in let sigma = Evd.merge_context_set Evd.univ_flexible sigma ctx in sigma, map c, map t @@ -546,12 +547,7 @@ let make_resolve_hyp env sigma st flags only_classes pri decl = let hints = build_subclasses ~check:false env sigma (VarRef id) empty_hint_info in (List.map_append (fun (path,info,c) -> - let info = - { info with Vernacexpr.hint_pattern = - Option.map (Constrintern.intern_constr_pattern env sigma) - info.Vernacexpr.hint_pattern } - in - make_resolves env sigma ~name:(PathHints path) + make_resolves env sigma ~name:(PathHints path) (true,false,not !Flags.quiet) info false (IsConstr (EConstr.of_constr c,Univ.ContextSet.empty))) hints) @@ -653,17 +649,6 @@ module Search = struct Evd.add sigma gl evi') sigma goals - let fail_if_nonclass info = - Proofview.Goal.enter begin fun gl -> - let sigma = Proofview.Goal.sigma gl in - if is_class_type sigma (Proofview.Goal.concl gl) then - Proofview.tclUNIT () - else (if !typeclasses_debug > 1 then - Feedback.msg_debug (pr_depth info.search_depth ++ - str": failure due to non-class subgoal " ++ - pr_ev sigma (Proofview.Goal.goal gl)); - Proofview.tclZERO NoApplicableEx) end - (** The general hint application tactic. tac1 + tac2 .... The choice of OR or ORELSE is determined depending on the dependencies of the goal and the unique/Prop @@ -802,13 +787,8 @@ module Search = struct in if path_matches derivs [] then aux e tl else - let filter = - if false (* in 8.6, still allow non-class subgoals - info.search_only_classes *) then fail_if_nonclass info - else Proofview.tclUNIT () - in ortac - (with_shelf (tac <*> filter) >>= fun s -> + (with_shelf tac >>= fun s -> let i = !idx in incr idx; result s i None) (fun e' -> if CErrors.noncritical (fst e') then @@ -872,12 +852,9 @@ module Search = struct let search_tac_gl ?st only_classes dep hints depth i sigma gls gl : unit Proofview.tactic = let open Proofview in - if false (* In 8.6, still allow non-class goals only_classes && not (is_class_type sigma (Goal.concl gl)) *) then - Tacticals.New.tclZEROMSG (str"Not a subgoal for a class") - else - let dep = dep || Proofview.unifiable sigma (Goal.goal gl) gls in - let info = make_autogoal ?st only_classes dep (cut_of_hints hints) i gl in - search_tac hints depth 1 info + let dep = dep || Proofview.unifiable sigma (Goal.goal gl) gls in + let info = make_autogoal ?st only_classes dep (cut_of_hints hints) i gl in + search_tac hints depth 1 info let search_tac ?(st=full_transparent_state) only_classes dep hints depth = let open Proofview in @@ -1030,8 +1007,8 @@ module Intpart = Unionfind.Make(Evar.Set)(Evar.Map) let deps_of_constraints cstrs evm p = List.iter (fun (_, _, x, y) -> - let evx = Evarutil.undefined_evars_of_term evm (EConstr.of_constr x) in - let evy = Evarutil.undefined_evars_of_term evm (EConstr.of_constr y) in + let evx = Evarutil.undefined_evars_of_term evm x in + let evy = Evarutil.undefined_evars_of_term evm y in Intpart.union_set (Evar.Set.union evx evy) p) cstrs @@ -1076,7 +1053,7 @@ let error_unresolvable env comp evd = | Some s -> Evar.Set.mem ev s in let fold ev evi (found, accu) = - let ev_class = class_of_constr evd (EConstr.of_constr evi.evar_concl) in + let ev_class = class_of_constr evd evi.evar_concl in if not (Option.is_empty ev_class) && is_part ev then (* focus on one instance if only one was searched for *) if not found then (true, Some ev) @@ -1174,7 +1151,7 @@ let solve_inst env evd filter unique split fail = let _ = Hook.set Typeclasses.solve_all_instances_hook solve_inst -let resolve_one_typeclass env ?(sigma=Evd.empty) gl unique = +let resolve_one_typeclass env ?(sigma=Evd.from_env env) gl unique = let nc, gl, subst, _ = Evarutil.push_rel_context_to_named_context env sigma gl in let (gl,t,sigma) = Goal.V82.mk_goal sigma nc gl Store.empty in @@ -1229,8 +1206,11 @@ let is_ground c = let autoapply c i = let open Proofview.Notations in Proofview.Goal.enter begin fun gl -> + let hintdb = try Hints.searchtable_map i with Not_found -> + CErrors.user_err (Pp.str ("Unknown hint database " ^ i ^ ".")) + in let flags = auto_unif_flags Evar.Set.empty - (Hints.Hint_db.transparent_state (Hints.searchtable_map i)) in + (Hints.Hint_db.transparent_state hintdb) in let cty = Tacmach.New.pf_unsafe_type_of gl c in let ce = mk_clenv_from gl (c,cty) in unify_e_resolve false flags gl diff --git a/tactics/contradiction.ml b/tactics/contradiction.ml index c285f21e7..e12063fd4 100644 --- a/tactics/contradiction.ml +++ b/tactics/contradiction.ml @@ -8,13 +8,12 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) -open Term +open Constr open EConstr open Hipattern open Tactics open Coqlib open Reductionops -open Misctypes open Proofview.Notations module NamedDecl = Context.Named.Declaration @@ -120,7 +119,7 @@ let contradiction_term (c,lbind as cl) = else Proofview.tclORELSE begin - if lbind = NoBindings then + if lbind = Tactypes.NoBindings then filter_hyp (fun c -> is_negation_of env sigma typ c) (fun id -> simplest_elim (mkApp (mkVar id,[|c|]))) else diff --git a/tactics/contradiction.mli b/tactics/contradiction.mli index 2b3a94758..4bb3263fb 100644 --- a/tactics/contradiction.mli +++ b/tactics/contradiction.mli @@ -9,7 +9,7 @@ (************************************************************************) open EConstr -open Misctypes +open Tactypes val absurd : constr -> unit Proofview.tactic val contradiction : constr with_bindings option -> unit Proofview.tactic diff --git a/tactics/eauto.ml b/tactics/eauto.ml index dc310c542..80d07c5c0 100644 --- a/tactics/eauto.ml +++ b/tactics/eauto.ml @@ -12,7 +12,7 @@ open Pp open CErrors open Util open Names -open Term +open Constr open Termops open EConstr open Proof_type @@ -70,11 +70,10 @@ let first_goal gls = (* tactic -> tactic_list : Apply a tactic to the first goal in the list *) let apply_tac_list tac glls = - let (sigr,lg) = unpackage glls in - match lg with + match glls.it with | (g1::rest) -> - let gl = apply_sig_tac sigr tac g1 in - repackage sigr (gl@rest) + let pack = tac (re_sig g1 glls.sigma) in + re_sig (pack.it @ rest) pack.sigma | _ -> user_err Pp.(str "apply_tac_list") let one_step l gl = @@ -90,7 +89,7 @@ let rec prolog l n gl = let out_term env = function | IsConstr (c, _) -> c - | IsGlobRef gr -> EConstr.of_constr (fst (Universes.fresh_global_instance env gr)) + | IsGlobRef gr -> EConstr.of_constr (fst (UnivGen.fresh_global_instance env gr)) let prolog_tac l n = Proofview.V82.tactic begin fun gl -> diff --git a/tactics/elim.mli b/tactics/elim.mli index d6b67e5ba..ddfac3f2c 100644 --- a/tactics/elim.mli +++ b/tactics/elim.mli @@ -11,12 +11,11 @@ open Names open EConstr open Tacticals -open Misctypes open Tactypes (** Eliminations tactics. *) -val introCaseAssumsThen : evars_flag -> +val introCaseAssumsThen : Tactics.evars_flag -> (intro_patterns -> branch_assumptions -> unit Proofview.tactic) -> branch_args -> unit Proofview.tactic diff --git a/tactics/elimschemes.ml b/tactics/elimschemes.ml index 6bd4866c6..70f73df5c 100644 --- a/tactics/elimschemes.ml +++ b/tactics/elimschemes.ml @@ -46,8 +46,8 @@ let optimize_non_type_induction_scheme kind dep sort _ ind = mib.mind_nparams in let sigma, sort = Evd.fresh_sort_in_family env sigma sort in let sigma, t', c' = weaken_sort_scheme env sigma false sort npars c t in - let sigma, nf = Evarutil.nf_evars_and_universes sigma in - (nf c', Evd.evar_universe_context sigma), eff + let sigma = Evd.minimize_universes sigma in + (Evarutil.nf_evars_universes sigma c', Evd.evar_universe_context sigma), eff else let sigma, pind = Evd.fresh_inductive_instance env sigma ind in let sigma, c = build_induction_scheme env sigma pind dep sort in diff --git a/tactics/eqdecide.ml b/tactics/eqdecide.ml index b0deeed17..832014a61 100644 --- a/tactics/eqdecide.ml +++ b/tactics/eqdecide.ml @@ -17,18 +17,18 @@ open Util open Names open Namegen -open Term +open Constr open EConstr open Declarations open Tactics open Tacticals.New open Auto open Constr_matching -open Misctypes open Hipattern open Proofview.Notations open Tacmach.New open Coqlib +open Tactypes (* This file containts the implementation of the tactics ``Decide Equality'' and ``Compare''. They can be used to decide the @@ -58,14 +58,14 @@ let clear_last = let choose_eq eqonleft = if eqonleft then - left_with_bindings false Misctypes.NoBindings + left_with_bindings false NoBindings else - right_with_bindings false Misctypes.NoBindings + right_with_bindings false NoBindings let choose_noteq eqonleft = if eqonleft then - right_with_bindings false Misctypes.NoBindings + right_with_bindings false NoBindings else - left_with_bindings false Misctypes.NoBindings + left_with_bindings false NoBindings (* A surgical generalize which selects the right occurrences by hand *) (* This prevents issues where c2 is also a subterm of c1 (see e.g. #5449) *) diff --git a/tactics/eqschemes.ml b/tactics/eqschemes.ml index 477de6452..ad5239116 100644 --- a/tactics/eqschemes.ml +++ b/tactics/eqschemes.ml @@ -78,7 +78,7 @@ let build_dependent_inductive ind (mib,mip) = Context.Rel.to_extended_list mkRel mip.mind_nrealdecls mib.mind_params_ctxt @ Context.Rel.to_extended_list mkRel 0 realargs) -let named_hd env t na = named_hd env Evd.empty (EConstr.of_constr t) na +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) @@ -102,15 +102,20 @@ let get_coq_eq ctx = let eq = Globnames.destIndRef Coqlib.glob_eq in (* Do not force the lazy if they are not defined *) let eq, ctx = with_context_set ctx - (Universes.fresh_inductive_instance (Global.env ()) eq) in + (UnivGen.fresh_inductive_instance (Global.env ()) eq) in mkIndU eq, mkConstructUi (eq,1), ctx with Not_found -> user_err Pp.(str "eq not found.") let univ_of_eq env eq = - let eq = EConstr.of_constr eq in - match Constr.kind (EConstr.Unsafe.to_constr (Retyping.get_type_of env Evd.empty eq)) with - | Prod (_,t,_) -> (match Constr.kind t with Sort (Type u) -> u | _ -> assert false) + let open EConstr in + let eq = of_constr eq in + let sigma = Evd.from_env env in + match kind sigma (Retyping.get_type_of env sigma eq) with + | Prod (_,t,_) -> (match kind sigma t with + Sort k -> + (match ESorts.kind sigma k with Type u -> u | _ -> assert false) + | _ -> assert false) | _ -> assert false (**********************************************************************) @@ -192,7 +197,7 @@ let get_non_sym_eq_data env (ind,u) = (**********************************************************************) let build_sym_scheme env ind = - let (ind,u as indu), ctx = Universes.fresh_inductive_instance env ind in + let (ind,u as indu), ctx = UnivGen.fresh_inductive_instance env ind in let (mib,mip as specif),nrealargs,realsign,paramsctxt,paramsctxt1 = get_sym_eq_data env indu in let cstr n = @@ -241,11 +246,11 @@ let sym_scheme_kind = let const_of_scheme kind env ind ctx = let sym_scheme, eff = (find_scheme kind ind) in let sym, ctx = with_context_set ctx - (Universes.fresh_constant_instance (Global.env()) sym_scheme) in + (UnivGen.fresh_constant_instance (Global.env()) sym_scheme) in mkConstU sym, ctx, eff let build_sym_involutive_scheme env ind = - let (ind,u as indu), ctx = Universes.fresh_inductive_instance env ind in + let (ind,u as indu), ctx = UnivGen.fresh_inductive_instance env ind in let (mib,mip as specif),nrealargs,realsign,paramsctxt,paramsctxt1 = get_sym_eq_data env indu in let eq,eqrefl,ctx = get_coq_eq ctx in @@ -353,7 +358,7 @@ let sym_involutive_scheme_kind = (**********************************************************************) let build_l2r_rew_scheme dep env ind kind = - let (ind,u as indu), ctx = Universes.fresh_inductive_instance env ind in + let (ind,u as indu), ctx = UnivGen.fresh_inductive_instance env ind in let (mib,mip as specif),nrealargs,realsign,paramsctxt,paramsctxt1 = get_sym_eq_data env indu in let sym, ctx, eff = const_of_scheme sym_scheme_kind env ind ctx in @@ -392,7 +397,7 @@ let build_l2r_rew_scheme dep env ind kind = rel_vect (nrealargs+4) nrealargs; rel_vect 1 nrealargs; [|mkRel 1|]]) in - let s, ctx' = Universes.fresh_sort_in_family (Global.env ()) kind in + let s, ctx' = UnivGen.fresh_sort_in_family (Global.env ()) 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 @@ -469,7 +474,7 @@ let build_l2r_rew_scheme dep env ind kind = (**********************************************************************) let build_l2r_forward_rew_scheme dep env ind kind = - let (ind,u as indu), ctx = Universes.fresh_inductive_instance env ind in + let (ind,u as indu), ctx = UnivGen.fresh_inductive_instance env ind in let (mib,mip as specif),nrealargs,realsign,paramsctxt,paramsctxt1 = get_sym_eq_data env indu in let cstr n p = @@ -495,7 +500,7 @@ let build_l2r_forward_rew_scheme dep env ind kind = name_context env ((LocalAssum (Name varH,applied_ind))::realsign) in let realsign_ind_P n aP = name_context env ((LocalAssum (Name varH,aP))::realsign_P n) in - let s, ctx' = Universes.fresh_sort_in_family (Global.env ()) kind in + let s, ctx' = UnivGen.fresh_sort_in_family (Global.env ()) 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 @@ -561,7 +566,7 @@ let build_l2r_forward_rew_scheme dep env ind kind = (**********************************************************************) let build_r2l_forward_rew_scheme dep env ind kind = - let (ind,u as indu), ctx = Universes.fresh_inductive_instance env ind in + let (ind,u as indu), ctx = UnivGen.fresh_inductive_instance env ind in let ((mib,mip as specif),constrargs,realsign,paramsctxt,nrealargs) = get_non_sym_eq_data env indu in let cstr n = @@ -573,7 +578,7 @@ let build_r2l_forward_rew_scheme dep env ind kind = let applied_ind = build_dependent_inductive indu specif in let realsign_ind = name_context env ((LocalAssum (Name varH,applied_ind))::realsign) in - let s, ctx' = Universes.fresh_sort_in_family (Global.env ()) kind in + let s, ctx' = UnivGen.fresh_sort_in_family (Global.env ()) 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 @@ -620,7 +625,9 @@ let build_r2l_forward_rew_scheme dep env ind kind = (**********************************************************************) let fix_r2l_forward_rew_scheme (c, ctx') = - let t = Retyping.get_type_of (Global.env()) Evd.empty (EConstr.of_constr c) in + let env = Global.env () in + let sigma = Evd.from_env env in + let t = Retyping.get_type_of env sigma (EConstr.of_constr c) in let t = EConstr.Unsafe.to_constr t in let ctx,_ = decompose_prod_assum t in match ctx with @@ -630,7 +637,7 @@ let fix_r2l_forward_rew_scheme (c, ctx') = (mkLambda_or_LetIn (RelDecl.map_constr (liftn (-1) 1) p) (mkLambda_or_LetIn (RelDecl.map_constr (liftn (-1) 2) hp) (mkLambda_or_LetIn (RelDecl.map_constr (lift 2) ind) - (EConstr.Unsafe.to_constr (Reductionops.whd_beta Evd.empty + (EConstr.Unsafe.to_constr (Reductionops.whd_beta sigma (EConstr.of_constr (applist (c, Context.Rel.to_extended_list mkRel 3 indargs @ [mkRel 1;mkRel 3;mkRel 2])))))))) in c', ctx' @@ -755,7 +762,7 @@ let rew_r2l_scheme_kind = let build_congr env (eq,refl,ctx) ind = let (ind,u as indu), ctx = with_context_set ctx - (Universes.fresh_inductive_instance env ind) in + (UnivGen.fresh_inductive_instance env ind) in let (mib,mip) = lookup_mind_specif env ind in if not (Int.equal (Array.length mib.mind_packets) 1) || not (Int.equal (Array.length mip.mind_nf_lc) 1) then error "Not an inductive type with a single constructor."; @@ -778,7 +785,7 @@ let build_congr env (eq,refl,ctx) ind = 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 uni, ctx = Universes.extend_context (Universes.new_global_univ ()) ctx in + let uni, ctx = UnivGen.extend_context (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 diff --git a/tactics/equality.ml b/tactics/equality.ml index 98f627f21..91c577405 100644 --- a/tactics/equality.ml +++ b/tactics/equality.ml @@ -15,6 +15,7 @@ open Util open Names open Nameops open Term +open Constr open Termops open EConstr open Vars @@ -41,7 +42,7 @@ open Ind_tables open Eqschemes open Locus open Locusops -open Misctypes +open Tactypes open Proofview.Notations open Unification open Context.Named.Declaration @@ -153,7 +154,7 @@ let instantiate_lemma_all frzevars gl c ty l l2r concl = let c1 = args.(arglen - 2) in let c2 = args.(arglen - 1) in let try_occ (evd', c') = - Clenvtac.clenv_pose_dependent_evars true {eqclause with evd = evd'} + Clenvtac.clenv_pose_dependent_evars ~with_evars:true {eqclause with evd = evd'} in let flags = make_flags frzevars (Tacmach.New.project gl) rewrite_unif_flags eqclause in let occs = @@ -545,6 +546,12 @@ let apply_special_clear_request clear_flag f = e when catchable_exception e -> tclIDTAC end +type multi = + | Precisely of int + | UpTo of int + | RepeatStar + | RepeatPlus + let general_multi_rewrite with_evars l cl tac = let do1 l2r f = Proofview.Goal.enter begin fun gl -> @@ -1036,7 +1043,7 @@ let onEquality with_evars tac (c,lbindc) = let t = type_of c in let t' = try snd (reduce_to_quantified_ind t) with UserError _ -> t in let eq_clause = pf_apply make_clenv_binding gl (c,t') lbindc in - let eq_clause' = Clenvtac.clenv_pose_dependent_evars with_evars eq_clause in + let eq_clause' = Clenvtac.clenv_pose_dependent_evars ~with_evars eq_clause in let eqn = clenv_type eq_clause' in let (eq,u,eq_args) = find_this_eq_data_decompose gl eqn in tclTHEN @@ -1108,8 +1115,6 @@ let make_tuple env sigma (rterm,rty) lind = let p = mkLambda (na, a, rty) in let sigma, exist_term = Evd.fresh_global env sigma sigdata.intro in let sigma, sig_term = Evd.fresh_global env sigma sigdata.typ in - let exist_term = EConstr.of_constr exist_term in - let sig_term = EConstr.of_constr sig_term in sigma, (applist(exist_term,[a;p;(mkRel lind);rterm]), applist(sig_term,[a;p])) @@ -1178,35 +1183,35 @@ let minimal_free_rels_rec env sigma = let sig_clausal_form env sigma sort_of_ty siglen ty dflt = let sigdata = find_sigma_data env sort_of_ty in - let evdref = ref (Evd.clear_metas sigma) in - let rec sigrec_clausal_form siglen p_i = + let rec sigrec_clausal_form sigma siglen p_i = if Int.equal siglen 0 then (* is the default value typable with the expected type *) let dflt_typ = unsafe_type_of env sigma dflt in try - let () = evdref := Evarconv.the_conv_x_leq env dflt_typ p_i !evdref in - let () = - evdref := Evarconv.solve_unif_constraints_with_heuristics env !evdref in - dflt + let sigma = Evarconv.the_conv_x_leq env dflt_typ p_i sigma in + let sigma = + Evarconv.solve_unif_constraints_with_heuristics env sigma in + sigma, dflt with Evarconv.UnableToUnify _ -> user_err Pp.(str "Cannot solve a unification problem.") else - let (a,p_i_minus_1) = match whd_beta_stack !evdref p_i with + let (a,p_i_minus_1) = match whd_beta_stack sigma p_i with | (_sigS,[a;p]) -> (a, p) | _ -> anomaly ~label:"sig_clausal_form" (Pp.str "should be a sigma type.") in - let ev = Evarutil.e_new_evar env evdref a in + let sigma, ev = Evarutil.new_evar env sigma a in let rty = beta_applist sigma (p_i_minus_1,[ev]) in - let tuple_tail = sigrec_clausal_form (siglen-1) rty in - let evopt = match EConstr.kind !evdref ev with Evar _ -> None | _ -> Some ev in + let sigma, tuple_tail = sigrec_clausal_form sigma (siglen-1) rty in + let evopt = match EConstr.kind sigma ev with Evar _ -> None | _ -> Some ev in match evopt with | Some w -> - let w_type = unsafe_type_of env !evdref w in - if Evarconv.e_cumul env evdref w_type a then - let exist_term = Evarutil.evd_comb1 (Evd.fresh_global env) evdref sigdata.intro in - let exist_term = EConstr.of_constr exist_term in - applist(exist_term,[a;p_i_minus_1;w;tuple_tail]) - else + let w_type = unsafe_type_of env sigma w in + begin match Evarconv.cumul env sigma w_type a with + | Some sigma -> + let sigma, exist_term = Evd.fresh_global env sigma sigdata.intro in + sigma, applist(exist_term,[a;p_i_minus_1;w;tuple_tail]) + | None -> user_err Pp.(str "Cannot solve a unification problem.") + end | None -> (* This at least happens if what has been detected as a dependency is not one; use an evasive error message; @@ -1216,8 +1221,9 @@ let sig_clausal_form env sigma sort_of_ty siglen ty dflt = unsolved evars would mean not binding rel *) user_err Pp.(str "Cannot solve a unification problem.") in - let scf = sigrec_clausal_form siglen ty in - !evdref, Evarutil.nf_evar !evdref scf + let sigma = Evd.clear_metas sigma in + let sigma, scf = sigrec_clausal_form sigma siglen ty in + sigma, Evarutil.nf_evar sigma scf (* The problem is to build a destructor (a generalization of the predecessor) which, when applied to a term made of constructors @@ -1372,7 +1378,6 @@ let inject_at_positions env sigma l2r (eq,_,(t,t1,t2)) eq_clause posns tac = let sigma, (injbody,resty) = build_injector e_env !evdref t1' (mkVar e) cpath in let injfun = mkNamedLambda e t injbody in let sigma,congr = Evd.fresh_global env sigma eq.congr in - let congr = EConstr.of_constr congr in let pf = applist(congr,[t;resty;injfun;t1;t2]) in let sigma, pf_typ = Typing.type_of env sigma pf in let inj_clause = apply_on_clause (pf,pf_typ) eq_clause in @@ -1761,8 +1766,17 @@ type subst_tactic_flags = { let default_subst_tactic_flags = { only_leibniz = false; rewrite_dependent_proof = true } +let warn_deprecated_simple_subst = + CWarnings.create ~name:"deprecated-simple-subst" ~category:"deprecated" + (fun () -> strbrk"\"simple subst\" is deprecated") + let subst_all ?(flags=default_subst_tactic_flags) () = + let () = + if flags.only_leibniz || not flags.rewrite_dependent_proof then + warn_deprecated_simple_subst () + in + if !regular_subst_tactic then (* First step: find hypotheses to treat in linear time *) @@ -1774,7 +1788,7 @@ let subst_all ?(flags=default_subst_tactic_flags) () = try let lbeq,u,(_,x,y) = find_eq_data_decompose (NamedDecl.get_type decl) in let u = EInstance.kind sigma u in - let eq = Universes.constr_of_global_univ (lbeq.eq,u) in + let eq = UnivGen.constr_of_global_univ (lbeq.eq,u) in if flags.only_leibniz then restrict_to_eq_and_identity eq; match EConstr.kind sigma x, EConstr.kind sigma y with | Var z, _ when not (is_evaluable env (EvalVarRef z)) -> @@ -1800,9 +1814,9 @@ let subst_all ?(flags=default_subst_tactic_flags) () = (* J.F.: added to prevent failure on goal containing x=x as an hyp *) if EConstr.eq_constr sigma x y then Proofview.tclUNIT () else match EConstr.kind sigma x, EConstr.kind sigma y with - | Var x', _ when not (dependent sigma x y) && not (is_evaluable env (EvalVarRef x')) -> + | Var x', _ when not (Termops.local_occur_var sigma x' y) && not (is_evaluable env (EvalVarRef x')) -> subst_one flags.rewrite_dependent_proof x' (hyp,y,true) - | _, Var y' when not (dependent sigma y x) && not (is_evaluable env (EvalVarRef y')) -> + | _, Var y' when not (Termops.local_occur_var sigma y' x) && not (is_evaluable env (EvalVarRef y')) -> subst_one flags.rewrite_dependent_proof y' (hyp,x,false) | _ -> Proofview.tclUNIT () @@ -1825,7 +1839,7 @@ let subst_all ?(flags=default_subst_tactic_flags) () = try let lbeq,u,(_,x,y) = find_eq_data_decompose c in let u = EInstance.kind sigma u in - let eq = Universes.constr_of_global_univ (lbeq.eq,u) in + let eq = UnivGen.constr_of_global_univ (lbeq.eq,u) in if flags.only_leibniz then restrict_to_eq_and_identity eq; (* J.F.: added to prevent failure on goal containing x=x as an hyp *) if EConstr.eq_constr sigma x y then failwith "caught"; diff --git a/tactics/equality.mli b/tactics/equality.mli index ccf454c3e..6f3e08ea0 100644 --- a/tactics/equality.mli +++ b/tactics/equality.mli @@ -15,8 +15,8 @@ open EConstr open Environ open Ind_tables open Locus -open Misctypes open Tactypes +open Tactics (*i*) type dep_proof_flag = bool (* true = support rewriting dependent proofs *) @@ -61,6 +61,12 @@ val general_rewrite_in : val general_rewrite_clause : orientation -> evars_flag -> ?tac:(unit Proofview.tactic * conditions) -> constr with_bindings -> clause -> unit Proofview.tactic +type multi = + | Precisely of int + | UpTo of int + | RepeatStar + | RepeatPlus + val general_multi_rewrite : evars_flag -> (bool * multi * clear_flag * delayed_open_constr_with_bindings) list -> clause -> (unit Proofview.tactic * conditions) option -> unit Proofview.tactic diff --git a/tactics/hints.ml b/tactics/hints.ml index a285d6b93..d49c8aaa5 100644 --- a/tactics/hints.ml +++ b/tactics/hints.ml @@ -12,7 +12,7 @@ open Pp open Util open CErrors open Names -open Term +open Constr open Evd open EConstr open Vars @@ -23,17 +23,16 @@ open Libobject open Namegen open Libnames open Smartlocate -open Misctypes open Termops open Inductiveops open Typing open Decl_kinds +open Typeclasses open Pattern open Patternops open Clenv open Tacred open Printer -open Vernacexpr module NamedDecl = Context.Named.Declaration @@ -94,13 +93,14 @@ let secvars_of_hyps hyps = else pred let empty_hint_info = - let open Vernacexpr in { hint_priority = None; hint_pattern = None } (************************************************************************) (* The Type of Constructions Autotactic Hints *) (************************************************************************) +type hint_info_expr = Constrexpr.constr_pattern_expr hint_info_gen + type 'a hint_ast = | Res_pf of 'a (* Hint Apply *) | ERes_pf of 'a (* Hint EApply *) @@ -115,7 +115,7 @@ type 'a hints_path_atom_gen = (* For forward hints, their names is the list of projections *) | PathAny -type hints_path_atom = global_reference hints_path_atom_gen +type hints_path_atom = GlobRef.t hints_path_atom_gen type 'a hints_path_gen = | PathAtom of 'a hints_path_atom_gen @@ -126,10 +126,10 @@ type 'a hints_path_gen = | PathEpsilon type pre_hints_path = Libnames.reference hints_path_gen -type hints_path = global_reference hints_path_gen +type hints_path = GlobRef.t hints_path_gen type hint_term = - | IsGlobRef of global_reference + | IsGlobRef of GlobRef.t | IsConstr of constr * Univ.ContextSet.t type 'a with_uid = { @@ -153,9 +153,28 @@ type 'a with_metadata = { type full_hint = hint with_metadata -type hint_entry = global_reference option * +type hint_entry = GlobRef.t option * raw_hint hint_ast with_uid with_metadata +type reference_or_constr = + | HintsReference of reference + | HintsConstr of Constrexpr.constr_expr + +type hint_mode = + | ModeInput (* No evars *) + | ModeNoHeadEvar (* No evar at the head *) + | ModeOutput (* Anything *) + +type hints_expr = + | HintsResolve of (hint_info_expr * bool * reference_or_constr) list + | HintsResolveIFF of bool * reference list * int option + | HintsImmediate of reference_or_constr list + | HintsUnfold of reference list + | HintsTransparency of reference list * bool + | HintsMode of reference * hint_mode list + | HintsConstructors of reference list + | HintsExtern of int * Constrexpr.constr_expr option * Genarg.raw_generic_argument + type import_level = [ `LAX | `WARN | `STRICT ] let warn_hint : import_level ref = ref `LAX @@ -276,15 +295,15 @@ let strip_params env sigma c = | App (f, args) -> (match EConstr.kind sigma f with | Const (p,_) -> - let cb = lookup_constant p env in - (match cb.Declarations.const_proj with - | Some pb -> - let n = pb.Declarations.proj_npars in - if Array.length args > n then - mkApp (mkProj (Projection.make p false, args.(n)), - Array.sub args (n+1) (Array.length args - (n + 1))) - else c - | None -> c) + let p = Projection.make p false in + (match lookup_projection p env with + | pb -> + let n = pb.Declarations.proj_npars in + if Array.length args > n then + mkApp (mkProj (p, args.(n)), + Array.sub args (n+1) (Array.length args - (n + 1))) + else c + | exception Not_found -> c) | _ -> c) | _ -> c @@ -308,7 +327,7 @@ let instantiate_hint env sigma p = { p with code = { p.code with obj = code } } let hints_path_atom_eq h1 h2 = match h1, h2 with -| PathHints l1, PathHints l2 -> List.equal eq_gr l1 l2 +| PathHints l1, PathHints l2 -> List.equal GlobRef.equal l1 l2 | PathAny, PathAny -> true | _ -> false @@ -365,7 +384,7 @@ let path_seq p p' = let rec path_derivate hp hint = let rec derivate_atoms hints hints' = match hints, hints' with - | gr :: grs, gr' :: grs' when eq_gr gr gr' -> derivate_atoms grs grs' + | gr :: grs, gr' :: grs' when GlobRef.equal gr gr' -> derivate_atoms grs grs' | [], [] -> PathEpsilon | [], hints -> PathEmpty | grs, [] -> PathAtom (PathHints grs) @@ -448,7 +467,7 @@ let subst_path_atom subst p = | PathAny -> p | PathHints grs -> let gr' gr = fst (subst_global subst gr) in - let grs' = List.smartmap gr' grs in + let grs' = List.Smart.map gr' grs in if grs' == grs then p else PathHints grs' let rec subst_hints_path subst hp = @@ -474,28 +493,28 @@ module Hint_db : sig type t val empty : ?name:hint_db_name -> transparent_state -> bool -> t -val find : global_reference -> t -> search_entry +val find : GlobRef.t -> t -> search_entry val map_none : secvars:Id.Pred.t -> t -> full_hint list -val map_all : secvars:Id.Pred.t -> global_reference -> t -> full_hint list +val map_all : secvars:Id.Pred.t -> GlobRef.t -> t -> full_hint list val map_existential : evar_map -> secvars:Id.Pred.t -> - (global_reference * constr array) -> constr -> t -> full_hint list + (GlobRef.t * constr array) -> constr -> t -> full_hint list val map_eauto : evar_map -> secvars:Id.Pred.t -> - (global_reference * constr array) -> constr -> t -> full_hint list + (GlobRef.t * constr array) -> constr -> t -> full_hint list val map_auto : evar_map -> secvars:Id.Pred.t -> - (global_reference * constr array) -> constr -> t -> full_hint list + (GlobRef.t * constr array) -> constr -> t -> full_hint list val add_one : env -> evar_map -> hint_entry -> t -> t val add_list : env -> evar_map -> hint_entry list -> t -> t -val remove_one : global_reference -> t -> t -val remove_list : global_reference list -> t -> t -val iter : (global_reference option -> hint_mode array list -> full_hint list -> unit) -> t -> unit +val remove_one : GlobRef.t -> t -> t +val remove_list : GlobRef.t list -> t -> t +val iter : (GlobRef.t option -> hint_mode array list -> full_hint list -> unit) -> t -> unit val use_dn : t -> bool val transparent_state : t -> transparent_state val set_transparent_state : t -> transparent_state -> t val add_cut : hints_path -> t -> t -val add_mode : global_reference -> hint_mode array -> t -> t +val add_mode : GlobRef.t -> hint_mode array -> t -> t val cut : t -> hints_path val unfolds : t -> Id.Set.t * Cset.t -val fold : (global_reference option -> hint_mode array list -> full_hint list -> 'a -> 'a) -> +val fold : (GlobRef.t option -> hint_mode array list -> full_hint list -> 'a -> 'a) -> t -> 'a -> 'a end = @@ -510,7 +529,7 @@ struct hintdb_map : search_entry Constr_map.t; (* A list of unindexed entries starting with an unfoldable constant or with no associated pattern. *) - hintdb_nopat : (global_reference option * stored_data) list; + hintdb_nopat : (GlobRef.t option * stored_data) list; hintdb_name : string option; } @@ -654,7 +673,7 @@ struct let add_list env sigma l db = List.fold_left (fun db k -> add_one env sigma k db) db l - let remove_sdl p sdl = List.smartfilter p sdl + let remove_sdl p sdl = List.filter p sdl let remove_he st p se = let sl1' = remove_sdl p se.sentry_nopat in @@ -664,9 +683,9 @@ struct let remove_list grs db = let filter (_, h) = - match h.name with PathHints [gr] -> not (List.mem_f eq_gr gr grs) | _ -> true in + match h.name with PathHints [gr] -> not (List.mem_f GlobRef.equal gr grs) | _ -> true in let hintmap = Constr_map.map (remove_he db.hintdb_state filter) db.hintdb_map in - let hintnopat = List.smartfilter (fun (ge, sd) -> filter sd) db.hintdb_nopat in + let hintnopat = List.filter (fun (ge, sd) -> filter sd) db.hintdb_nopat in { db with hintdb_map = hintmap; hintdb_nopat = hintnopat } let remove_one gr db = remove_list [gr] db @@ -792,7 +811,7 @@ let make_exact_entry env sigma info poly ?(name=PathAny) (c, cty, ctx) = match EConstr.kind sigma cty with | Prod _ -> failwith "make_exact_entry" | _ -> - let pat = Patternops.pattern_of_constr env sigma (EConstr.to_constr sigma cty) in + let pat = Patternops.pattern_of_constr env sigma (EConstr.to_constr ~abort_on_undefined_evars:false sigma cty) in let hd = try head_pattern_bound pat with BoundPattern -> failwith "make_exact_entry" @@ -814,7 +833,7 @@ let make_apply_entry env sigma (eapply,hnf,verbose) info poly ?(name=PathAny) (c let sigma' = Evd.merge_context_set univ_flexible sigma ctx in let ce = mk_clenv_from_env env sigma' None (c,cty) in let c' = clenv_type (* ~reduce:false *) ce in - let pat = Patternops.pattern_of_constr env ce.evd (EConstr.to_constr sigma c') in + let pat = Patternops.pattern_of_constr env ce.evd (EConstr.to_constr ~abort_on_undefined_evars:false sigma c') in let hd = try head_pattern_bound pat with BoundPattern -> failwith "make_apply_entry" in @@ -876,7 +895,7 @@ let fresh_global_or_constr env sigma poly cr = let isgr, (c, ctx) = match cr with | IsGlobRef gr -> - let (c, ctx) = Universes.fresh_global_instance env gr in + let (c, ctx) = UnivGen.fresh_global_instance env gr in true, (EConstr.of_constr c, ctx) | IsConstr (c, ctx) -> false, (c, ctx) in @@ -1015,9 +1034,9 @@ type hint_action = | CreateDB of bool * transparent_state | AddTransparency of evaluable_global_reference list * bool | AddHints of hint_entry list - | RemoveHints of global_reference list + | RemoveHints of GlobRef.t list | AddCut of hints_path - | AddMode of global_reference * hint_mode array + | AddMode of GlobRef.t * hint_mode array let add_cut dbname path = let db = get_db dbname in @@ -1065,8 +1084,8 @@ let subst_autohint (subst, obj) = in if gr' == gr then gr else gr' in let subst_hint (k,data as hint) = - let k' = Option.smartmap subst_key k in - let pat' = Option.smartmap (subst_pattern subst) data.pat in + let k' = Option.Smart.map subst_key k in + let pat' = Option.Smart.map (subst_pattern subst) data.pat in let subst_mps subst c = EConstr.of_constr (subst_mps subst (EConstr.Unsafe.to_constr c)) in let code' = match data.code.obj with | Res_pf (c,t,ctx) -> @@ -1104,13 +1123,13 @@ let subst_autohint (subst, obj) = let action = match obj.hint_action with | CreateDB _ -> obj.hint_action | AddTransparency (grs, b) -> - let grs' = List.smartmap (subst_evaluable_reference subst) grs in + let grs' = List.Smart.map (subst_evaluable_reference subst) grs in if grs == grs' then obj.hint_action else AddTransparency (grs', b) | AddHints hintlist -> - let hintlist' = List.smartmap subst_hint hintlist in + let hintlist' = List.Smart.map subst_hint hintlist in if hintlist' == hintlist then obj.hint_action else AddHints hintlist' | RemoveHints grs -> - let grs' = List.smartmap (subst_global_reference subst) grs in + let grs' = List.Smart.map (subst_global_reference subst) grs in if grs == grs' then obj.hint_action else RemoveHints grs' | AddCut path -> let path' = subst_hints_path subst path in @@ -1218,7 +1237,7 @@ let add_trivials env sigma l local dbnames = type hnf = bool -type hint_info = (patvar list * constr_pattern) hint_info_gen +type nonrec hint_info = hint_info type hints_entry = | HintsResolveEntry of (hint_info * polymorphic * hnf * hints_path_atom * hint_term) list @@ -1226,7 +1245,7 @@ type hints_entry = | HintsCutEntry of hints_path | HintsUnfoldEntry of evaluable_global_reference list | HintsTransparencyEntry of evaluable_global_reference list * bool - | HintsModeEntry of global_reference * hint_mode list + | HintsModeEntry of GlobRef.t * hint_mode list | HintsExternEntry of hint_info * Genarg.glob_generic_argument let default_prepare_hint_ident = Id.of_string "H" @@ -1263,20 +1282,53 @@ let prepare_hint check (poly,local) env init (sigma,c) = subst := (evar,mkVar id)::!subst; mkNamedLambda id t (iter (replace_term sigma evar (mkVar id) c)) in let c' = iter c in - if check then Pretyping.check_evars (Global.env()) Evd.empty sigma c'; + let env = Global.env () in + let empty_sigma = Evd.from_env env in + if check then Pretyping.check_evars env empty_sigma sigma c'; let diff = Univ.ContextSet.diff (Evd.universe_context_set sigma) (Evd.universe_context_set init) in if poly then IsConstr (c', diff) else if local then IsConstr (c', diff) else (Lib.add_anonymous_leaf (input_context_set diff); IsConstr (c', Univ.ContextSet.empty)) +let project_hint ~poly pri l2r r = + let open EConstr in + let open Coqlib in + let gr = Smartlocate.global_with_alias r in + let env = Global.env() in + let sigma = Evd.from_env env in + let sigma, c = Evd.fresh_global env sigma gr in + let t = Retyping.get_type_of env sigma c in + let t = + Tacred.reduce_to_quantified_ref env sigma (Lazy.force coq_iff_ref) t in + let sign,ccl = decompose_prod_assum sigma t in + let (a,b) = match snd (decompose_app sigma ccl) with + | [a;b] -> (a,b) + | _ -> assert false in + let p = + if l2r then build_coq_iff_left_proj () else build_coq_iff_right_proj () in + 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 + let id = + Nameops.add_suffix (Nametab.basename_of_global gr) ("_proj_" ^ (if l2r then "l2r" else "r2l")) + in + let ctx = Evd.const_univ_entry ~poly sigma in + let c = EConstr.to_constr sigma c in + let c = Declare.declare_definition ~internal:Declare.InternalTacticRequest id (c,ctx) in + let info = {Typeclasses.hint_priority = pri; hint_pattern = None} in + (info,false,true,PathAny, IsGlobRef (Globnames.ConstRef c)) + let interp_hints poly = fun h -> let env = Global.env () in let sigma = Evd.from_env env in let f poly c = let evd,c = Constrintern.interp_open_constr env sigma c in - prepare_hint true (poly,false) (Global.env()) Evd.empty (evd,c) in + let env = Global.env () in + let sigma = Evd.from_env env in + prepare_hint true (poly,false) env sigma (evd,c) in let fref r = let gr = global_with_alias r in Dumpglob.add_glob ?loc:r.CAst.loc gr; @@ -1297,6 +1349,8 @@ let interp_hints poly = in match h with | HintsResolve lhints -> HintsResolveEntry (List.map fres lhints) + | HintsResolveIFF (l2r, lc, n) -> + HintsResolveEntry (List.map (project_hint ~poly n l2r) lc) | HintsImmediate lhints -> HintsImmediateEntry (List.map fi lhints) | HintsUnfold lhints -> HintsUnfoldEntry (List.map fr lhints) | HintsTransparency (lhints, b) -> @@ -1322,7 +1376,7 @@ let interp_hints poly = let _, tacexp = Genintern.generic_intern env tacexp in HintsExternEntry ({ hint_priority = Some pri; hint_pattern = pat }, tacexp) -let add_hints local dbnames0 h = +let add_hints ~local dbnames0 h = if String.List.mem "nocore" dbnames0 then user_err Pp.(str "The hint database \"nocore\" is meant to stay empty."); let dbnames = if List.is_empty dbnames0 then ["core"] else dbnames0 in @@ -1357,12 +1411,10 @@ let expand_constructor_hints env sigma lems = (* builds a hint database from a constr signature *) (* typically used with (lid, ltyp) = pf_hyps_types <some goal> *) -let add_hint_lemmas env sigma eapply lems hint_db = +let constructor_hints env sigma eapply lems = let lems = expand_constructor_hints env sigma lems in - let hintlist' = - List.map_append (fun (poly, lem) -> - make_resolves env sigma (eapply,true,false) empty_hint_info poly lem) lems in - Hint_db.add_list env sigma hintlist' hint_db + List.map_append (fun (poly, lem) -> + make_resolves env sigma (eapply,true,false) empty_hint_info poly lem) lems let make_local_hint_db env sigma ts eapply lems = let map c = c env sigma in @@ -1373,8 +1425,9 @@ let make_local_hint_db env sigma ts eapply lems = | Some ts -> ts in let hintlist = List.map_append (make_resolve_hyp env sigma) sign in - add_hint_lemmas env sigma eapply lems - (Hint_db.add_list env sigma hintlist (Hint_db.empty ts false)) + Hint_db.empty ts false + |> Hint_db.add_list env sigma hintlist + |> Hint_db.add_list env sigma (constructor_hints env sigma eapply lems) let make_local_hint_db env sigma ?ts eapply lems = make_local_hint_db env sigma ts eapply lems diff --git a/tactics/hints.mli b/tactics/hints.mli index 1811150c2..e958f986e 100644 --- a/tactics/hints.mli +++ b/tactics/hints.mli @@ -12,29 +12,29 @@ open Util open Names open EConstr open Environ -open Globnames open Decl_kinds open Evd -open Misctypes open Tactypes open Clenv open Pattern -open Vernacexpr +open Typeclasses (** {6 General functions. } *) exception Bound -val decompose_app_bound : evar_map -> constr -> global_reference * constr array +val decompose_app_bound : evar_map -> constr -> GlobRef.t * constr array type debug = Debug | Info | Off val secvars_of_hyps : ('c, 't) Context.Named.pt -> Id.Pred.t -val empty_hint_info : 'a hint_info_gen +val empty_hint_info : 'a Typeclasses.hint_info_gen (** Pre-created hint databases *) +type hint_info_expr = Constrexpr.constr_pattern_expr hint_info_gen + type 'a hint_ast = | Res_pf of 'a (* Hint Apply *) | ERes_pf of 'a (* Hint EApply *) @@ -51,7 +51,7 @@ type 'a hints_path_atom_gen = (* For forward hints, their names is the list of projections *) | PathAny -type hints_path_atom = global_reference hints_path_atom_gen +type hints_path_atom = GlobRef.t hints_path_atom_gen type hint_db_name = string type 'a with_metadata = private { @@ -72,6 +72,25 @@ type search_entry type hint_entry +type reference_or_constr = + | HintsReference of Libnames.reference + | HintsConstr of Constrexpr.constr_expr + +type hint_mode = + | ModeInput (* No evars *) + | ModeNoHeadEvar (* No evar at the head *) + | ModeOutput (* Anything *) + +type hints_expr = + | HintsResolve of (hint_info_expr * bool * reference_or_constr) list + | HintsResolveIFF of bool * Libnames.reference list * int option + | HintsImmediate of reference_or_constr list + | HintsUnfold of Libnames.reference list + | HintsTransparency of Libnames.reference list * bool + | HintsMode of Libnames.reference * hint_mode list + | HintsConstructors of Libnames.reference list + | HintsExtern of int * Constrexpr.constr_expr option * Genarg.raw_generic_argument + type 'a hints_path_gen = | PathAtom of 'a hints_path_atom_gen | PathStar of 'a hints_path_gen @@ -81,7 +100,7 @@ type 'a hints_path_gen = | PathEpsilon type pre_hints_path = Libnames.reference hints_path_gen -type hints_path = global_reference hints_path_gen +type hints_path = GlobRef.t hints_path_gen val normalize_path : hints_path -> hints_path val path_matches : hints_path -> hints_path_atom list -> bool @@ -91,15 +110,15 @@ val pp_hints_path_atom : ('a -> Pp.t) -> 'a hints_path_atom_gen -> Pp.t val pp_hints_path : hints_path -> Pp.t val pp_hint_mode : hint_mode -> Pp.t val glob_hints_path_atom : - Libnames.reference hints_path_atom_gen -> Globnames.global_reference hints_path_atom_gen + Libnames.reference hints_path_atom_gen -> GlobRef.t hints_path_atom_gen val glob_hints_path : - Libnames.reference hints_path_gen -> Globnames.global_reference hints_path_gen + Libnames.reference hints_path_gen -> GlobRef.t hints_path_gen module Hint_db : sig type t val empty : ?name:hint_db_name -> transparent_state -> bool -> t - val find : global_reference -> t -> search_entry + val find : GlobRef.t -> t -> search_entry (** All hints which have no pattern. * [secvars] represent the set of section variables that @@ -107,27 +126,27 @@ module Hint_db : val map_none : secvars:Id.Pred.t -> t -> full_hint list (** All hints associated to the reference *) - val map_all : secvars:Id.Pred.t -> global_reference -> t -> full_hint list + val map_all : secvars:Id.Pred.t -> GlobRef.t -> t -> full_hint list (** All hints associated to the reference, respecting modes if evars appear in the arguments, _not_ using the discrimination net. *) val map_existential : evar_map -> secvars:Id.Pred.t -> - (global_reference * constr array) -> constr -> t -> full_hint list + (GlobRef.t * constr array) -> constr -> t -> full_hint list (** All hints associated to the reference, respecting modes if evars appear in the arguments and using the discrimination net. *) - val map_eauto : evar_map -> secvars:Id.Pred.t -> (global_reference * constr array) -> constr -> t -> full_hint list + val map_eauto : evar_map -> secvars:Id.Pred.t -> (GlobRef.t * constr array) -> constr -> t -> full_hint list (** All hints associated to the reference, respecting modes if evars appear in the arguments. *) val map_auto : evar_map -> secvars:Id.Pred.t -> - (global_reference * constr array) -> constr -> t -> full_hint list + (GlobRef.t * constr array) -> constr -> t -> full_hint list val add_one : env -> evar_map -> hint_entry -> t -> t val add_list : env -> evar_map -> hint_entry list -> t -> t - val remove_one : global_reference -> t -> t - val remove_list : global_reference list -> t -> t - val iter : (global_reference option -> + val remove_one : GlobRef.t -> t -> t + val remove_list : GlobRef.t list -> t -> t + val iter : (GlobRef.t option -> hint_mode array list -> full_hint list -> unit) -> t -> unit val use_dn : t -> bool @@ -144,10 +163,8 @@ type hint_db = Hint_db.t type hnf = bool -type hint_info = (patvar list * constr_pattern) hint_info_gen - type hint_term = - | IsGlobRef of global_reference + | IsGlobRef of GlobRef.t | IsConstr of constr * Univ.ContextSet.t type hints_entry = @@ -157,7 +174,7 @@ type hints_entry = | HintsCutEntry of hints_path | HintsUnfoldEntry of evaluable_global_reference list | HintsTransparencyEntry of evaluable_global_reference list * bool - | HintsModeEntry of global_reference * hint_mode list + | HintsModeEntry of GlobRef.t * hint_mode list | HintsExternEntry of hint_info * Genarg.glob_generic_argument val searchtable_map : hint_db_name -> hint_db @@ -171,7 +188,7 @@ val searchtable_add : (hint_db_name * hint_db) -> unit val create_hint_db : bool -> hint_db_name -> transparent_state -> bool -> unit -val remove_hints : bool -> hint_db_name list -> global_reference list -> unit +val remove_hints : bool -> hint_db_name list -> GlobRef.t list -> unit val current_db_names : unit -> String.Set.t @@ -179,7 +196,7 @@ val current_pure_db : unit -> hint_db list val interp_hints : polymorphic -> hints_expr -> hints_entry -val add_hints : locality_flag -> hint_db_name list -> hints_entry -> unit +val add_hints : local:bool -> hint_db_name list -> hints_entry -> unit val prepare_hint : bool (* Check no remaining evars *) -> (bool * bool) (* polymorphic or monomorphic, local or global *) -> @@ -264,7 +281,7 @@ val rewrite_db : hint_db_name val pr_searchtable : env -> evar_map -> Pp.t val pr_applicable_hint : unit -> Pp.t -val pr_hint_ref : env -> evar_map -> global_reference -> Pp.t +val pr_hint_ref : env -> evar_map -> GlobRef.t -> Pp.t val pr_hint_db_by_name : env -> evar_map -> hint_db_name -> Pp.t val pr_hint_db_env : env -> evar_map -> Hint_db.t -> Pp.t val pr_hint_db : Hint_db.t -> Pp.t @@ -274,3 +291,5 @@ val pr_hint : env -> evar_map -> hint -> Pp.t (** Hook for changing the initialization of auto *) val add_hints_init : (unit -> unit) -> unit +type nonrec hint_info = hint_info +[@@ocaml.deprecated "Use [Typeclasses.hint_info]"] diff --git a/tactics/hipattern.ml b/tactics/hipattern.ml index b012a7ecd..f9c4bed35 100644 --- a/tactics/hipattern.ml +++ b/tactics/hipattern.ml @@ -12,7 +12,7 @@ open Pp open CErrors open Util open Names -open Term +open Constr open Termops open EConstr open Inductiveops @@ -263,7 +263,7 @@ open Evar_kinds let mkPattern c = snd (Patternops.pattern_of_glob_constr c) let mkGApp f args = DAst.make @@ GApp (f, args) let mkGHole = DAst.make @@ - GHole (QuestionMark (Define false,Anonymous), Misctypes.IntroAnonymous, None) + GHole (QuestionMark (Define false,Anonymous), Namegen.IntroAnonymous, None) let mkGProd id c1 c2 = DAst.make @@ GProd (Name (Id.of_string id), Explicit, c1, c2) let mkGArrow c1 c2 = DAst.make @@ @@ -294,13 +294,13 @@ let match_with_equation env sigma t = let (hdapp,args) = destApp sigma t in match EConstr.kind sigma hdapp with | Ind (ind,u) -> - if eq_gr (IndRef ind) glob_eq then + if GlobRef.equal (IndRef ind) glob_eq then Some (build_coq_eq_data()),hdapp, PolymorphicLeibnizEq(args.(0),args.(1),args.(2)) - else if eq_gr (IndRef ind) glob_identity then + else if GlobRef.equal (IndRef ind) glob_identity then Some (build_coq_identity_data()),hdapp, PolymorphicLeibnizEq(args.(0),args.(1),args.(2)) - else if eq_gr (IndRef ind) glob_jmeq then + else if GlobRef.equal (IndRef ind) glob_jmeq then Some (build_coq_jmeq_data()),hdapp, HeterogenousEq(args.(0),args.(1),args.(2),args.(3)) else diff --git a/tactics/hipattern.mli b/tactics/hipattern.mli index 0697d0f19..f04cda123 100644 --- a/tactics/hipattern.mli +++ b/tactics/hipattern.mli @@ -144,7 +144,7 @@ val is_matching_sigma : Environ.env -> evar_map -> constr -> bool (** Match a decidable equality judgement (e.g [{t=u:>T}+{~t=u}]), returns [t,u,T] and a boolean telling if equality is on the left side *) -val match_eqdec : Environ.env -> evar_map -> constr -> bool * Globnames.global_reference * constr * constr * constr +val match_eqdec : Environ.env -> evar_map -> constr -> bool * GlobRef.t * constr * constr * constr (** Match a negation *) val is_matching_not : Environ.env -> evar_map -> constr -> bool diff --git a/tactics/ind_tables.ml b/tactics/ind_tables.ml index 62ead57f3..21520f5d2 100644 --- a/tactics/ind_tables.ml +++ b/tactics/ind_tables.ml @@ -53,7 +53,7 @@ let subst_one_scheme subst (ind,const) = (subst_ind subst ind,subst_constant subst const) let subst_scheme (subst,(kind,l)) = - (kind,Array.map (subst_one_scheme subst) l) + (kind,Array.Smart.map (subst_one_scheme subst) l) let discharge_scheme (_,(kind,l)) = Some (kind,Array.map (fun (ind,const) -> @@ -123,7 +123,7 @@ let define internal id c p univs = let fd = declare_constant ~internal in let id = compute_name internal id in let ctx = UState.minimize univs in - let c = Universes.subst_opt_univs_constr (UState.subst ctx) c in + let c = UnivSubst.nf_evars_and_universes_opt_subst (fun _ -> None) (UState.subst ctx) c in let univs = if p then Polymorphic_const_entry (UState.context ctx) else Monomorphic_const_entry (UState.context_set ctx) diff --git a/tactics/inv.ml b/tactics/inv.ml index d76c9a697..755494c2d 100644 --- a/tactics/inv.ml +++ b/tactics/inv.ml @@ -14,6 +14,7 @@ open Util open Names open Term open Termops +open Constr open EConstr open Vars open Namegen @@ -25,7 +26,7 @@ open Tacticals.New open Tactics open Elim open Equality -open Misctypes +open Tactypes open Proofview.Notations module NamedDecl = Context.Named.Declaration @@ -124,12 +125,10 @@ let make_inv_predicate env evd indf realargs id status concl = in let eq_term = eqdata.Coqlib.eq in let eq = Evarutil.evd_comb1 (Evd.fresh_global env) evd eq_term in - let eq = EConstr.of_constr eq in let eqn = applist (eq,[eqnty;lhs;rhs]) in let eqns = (Anonymous, lift n eqn) :: eqns in let refl_term = eqdata.Coqlib.refl in let refl_term = Evarutil.evd_comb1 (Evd.fresh_global env) evd refl_term in - let refl_term = EConstr.of_constr refl_term in let refl = mkApp (refl_term, [|eqnty; rhs|]) in let _ = Evarutil.evd_comb1 (Typing.type_of env) evd refl in let args = refl :: args in @@ -294,7 +293,7 @@ let error_too_many_names pats = str "Unexpected " ++ str (String.plural (List.length pats) "introduction pattern") ++ str ": " ++ pr_enum (Miscprint.pr_intro_pattern - (fun c -> Printer.pr_constr_env env sigma (EConstr.Unsafe.to_constr (snd (c env Evd.empty))))) pats ++ + (fun c -> Printer.pr_econstr_env env sigma (snd (c env (Evd.from_env env))))) pats ++ str ".") let get_names (allow_conj,issimple) ({CAst.loc;v=pat} as x) = match pat with @@ -333,7 +332,7 @@ let rec tclMAP_i allow_conj n tacfun = function (tacfun (get_names allow_conj a)) (tclMAP_i allow_conj (n-1) tacfun l) -let remember_first_eq id x = if !x == MoveLast then x := MoveAfter id +let remember_first_eq id x = if !x == Logic.MoveLast then x := Logic.MoveAfter id (* invariant: ProjectAndApply is responsible for erasing the clause which it is given as input @@ -376,7 +375,7 @@ let projectAndApply as_mode thin avoid id eqname names depids = [if as_mode then clear [id] else tclIDTAC; (tclMAP_i (false,false) neqns (function (idopt,_) -> tclTRY (tclTHEN - (intro_move_avoid idopt avoid MoveLast) + (intro_move_avoid idopt avoid Logic.MoveLast) (* try again to substitute and if still not a variable after *) (* decomposition, arbitrarily try to rewrite RL !? *) (tclTRY (onLastHypId (substHypIfVariable (fun id -> subst_hyp false id)))))) @@ -405,7 +404,7 @@ let nLastDecls i tac = let rewrite_equations as_mode othin neqns names ba = Proofview.Goal.enter begin fun gl -> let (depids,nodepids) = split_dep_and_nodep ba.Tacticals.assums gl in - let first_eq = ref MoveLast in + let first_eq = ref Logic.MoveLast in let avoid = if as_mode then Id.Set.of_list (List.map NamedDecl.get_id nodepids) else Id.Set.empty in match othin with | Some thin -> @@ -417,20 +416,20 @@ let rewrite_equations as_mode othin neqns names ba = (nLastDecls neqns (fun ctx -> clear (ids_of_named_context ctx))); tclMAP_i (true,false) neqns (fun (idopt,names) -> (tclTHEN - (intro_move_avoid idopt avoid MoveLast) + (intro_move_avoid idopt avoid Logic.MoveLast) (onLastHypId (fun id -> tclTRY (projectAndApply as_mode thin avoid id first_eq names depids))))) names; tclMAP (fun d -> tclIDTAC >>= fun () -> (* delay for [first_eq]. *) let idopt = if as_mode then Some (NamedDecl.get_id d) else None in - intro_move idopt (if thin then MoveLast else !first_eq)) + intro_move idopt (if thin then Logic.MoveLast else !first_eq)) nodepids; (tclMAP (fun d -> tclTRY (clear [NamedDecl.get_id d])) depids)] | None -> (* simple inversion *) if as_mode then tclMAP_i (false,true) neqns (fun (idopt,_) -> - intro_move idopt MoveLast) names + intro_move idopt Logic.MoveLast) names else (tclTHENLIST [tclDO neqns intro; @@ -470,7 +469,7 @@ let raw_inversion inv_kind id status names = make_inv_predicate env evdref indf realargs id status concl in let sigma = !evdref in let (cut_concl,case_tac) = - if status != NoDep && (dependent sigma c concl) then + if status != NoDep && (local_occur_var sigma id concl) then Reductionops.beta_applist sigma (elim_predicate, realargs@[c]), case_then_using else @@ -498,9 +497,10 @@ let wrap_inv_error id = function (e, info) -> match e with | Indrec.RecursionSchemeError (Indrec.NotAllowedCaseAnalysis (_,(Type _ | Prop Pos as k),i)) -> Proofview.tclENV >>= fun env -> + Proofview.tclEVARMAP >>= fun sigma -> tclZEROMSG ( (strbrk "Inversion would require case analysis on sort " ++ - pr_sort Evd.empty k ++ + pr_sort sigma k ++ strbrk " which is not allowed for inductive definition " ++ pr_inductive env (fst i) ++ str ".")) | e -> Proofview.tclZERO ~info e diff --git a/tactics/inv.mli b/tactics/inv.mli index 9d4ffdd7b..bbd1f3352 100644 --- a/tactics/inv.mli +++ b/tactics/inv.mli @@ -10,7 +10,6 @@ open Names open EConstr -open Misctypes open Tactypes type inversion_status = Dep of constr option | NoDep diff --git a/tactics/leminv.ml b/tactics/leminv.ml index a4cdc1592..10937322e 100644 --- a/tactics/leminv.ml +++ b/tactics/leminv.ml @@ -12,9 +12,9 @@ open Pp open CErrors open Util open Names -open Term open Termops open Environ +open Constr open EConstr open Vars open Namegen @@ -232,9 +232,8 @@ let inversion_scheme env sigma t sort dep_option inv_op = let c = fill_holes pfterm in (* warning: side-effect on ownSign *) let invProof = it_mkNamedLambda_or_LetIn c !ownSign in - let invProof = EConstr.Unsafe.to_constr invProof in - let p = Evarutil.nf_evars_universes sigma invProof in - p, sigma + let p = EConstr.to_constr sigma invProof in + p, sigma let add_inversion_lemma ~poly name env sigma t sort dep inv_op = let invProof, sigma = inversion_scheme env sigma t sort dep inv_op in diff --git a/tactics/leminv.mli b/tactics/leminv.mli index 2337a7901..f42e5a8b0 100644 --- a/tactics/leminv.mli +++ b/tactics/leminv.mli @@ -11,7 +11,7 @@ open Names open EConstr open Constrexpr -open Misctypes +open Tactypes val lemInv_clause : quantified_hypothesis -> constr -> Id.t list -> unit Proofview.tactic diff --git a/tactics/tacticals.ml b/tactics/tacticals.ml index a97ae8f65..f34c83ae7 100644 --- a/tactics/tacticals.ml +++ b/tactics/tacticals.ml @@ -159,8 +159,6 @@ type branch_assumptions = { ba : branch_args; (* the branch args *) assums : named_context} (* the list of assumptions introduced *) -open Misctypes - let fix_empty_or_and_pattern nv l = (* 1- The syntax does not distinguish between "[ ]" for one clause with no names and "[ ]" for no clause at all *) @@ -194,7 +192,7 @@ let check_or_and_pattern_size ?loc check_and names branchsigns = if not (Int.equal p p1 || Int.equal p p2) then err1 p1 p2; if Int.equal p p1 then IntroAndPattern - (List.extend branchsigns.(0) (CAst.make @@ IntroNaming IntroAnonymous) l) + (List.extend branchsigns.(0) (CAst.make @@ IntroNaming Namegen.IntroAnonymous) l) else names else @@ -225,7 +223,7 @@ let compute_induction_names_gen check_and branchletsigns = function let compute_induction_names = compute_induction_names_gen true (* Compute the let-in signature of case analysis or standard induction scheme *) -let compute_constructor_signatures isrec ((_,k as ity),u) = +let compute_constructor_signatures ~rec_flag ((_,k as ity),u) = let rec analrec c recargs = match Constr.kind c, recargs with | Prod (_,_,c), recarg::rest -> @@ -233,7 +231,7 @@ let compute_constructor_signatures isrec ((_,k as ity),u) = begin match Declareops.dest_recarg recarg with | Norec | Imbr _ -> true :: rest | Mrec (_,j) -> - if isrec && Int.equal j k then true :: true :: rest + if rec_flag && Int.equal j k then true :: true :: rest else true :: rest end | LetIn (_,_,_,c), rest -> false :: analrec c rest @@ -263,7 +261,7 @@ let pf_with_evars glsev k gls = tclTHEN (Refiner.tclEVARS evd) (k a) gls let pf_constr_of_global gr k = - pf_with_evars (fun gls -> on_snd EConstr.of_constr (pf_apply Evd.fresh_global gls gr)) k + pf_with_evars (fun gls -> pf_apply Evd.fresh_global gls gr) k (** Tacticals of Ltac defined directly in term of Proofview *) module New = struct @@ -492,11 +490,13 @@ module New = struct Proofview.tclINDEPENDENT (Proofview.tclPROGRESS t) (* Select a subset of the goals *) - let tclSELECT = function - | Vernacexpr.SelectNth i -> Proofview.tclFOCUS i i - | Vernacexpr.SelectList l -> Proofview.tclFOCUSLIST l - | Vernacexpr.SelectId id -> Proofview.tclFOCUSID id - | Vernacexpr.SelectAll -> fun tac -> tac + let tclSELECT = let open Goal_select in function + | SelectNth i -> Proofview.tclFOCUS i i + | SelectList l -> Proofview.tclFOCUSLIST l + | SelectId id -> Proofview.tclFOCUSID id + | SelectAll -> anomaly ~label:"tclSELECT" Pp.(str "SelectAll not allowed here") + | SelectAlreadyFocused -> + anomaly ~label:"tclSELECT" Pp.(str "SelectAlreadyFocused not allowed here") (* Check that holes in arguments have been resolved *) @@ -506,8 +506,8 @@ module New = struct let evi = Evd.find sigma evk in match Evd.evar_body evi with | Evd.Evar_empty -> Some (evk,evi) - | Evd.Evar_defined c -> match Constr.kind c with - | Term.Evar (evk,l) -> is_undefined_up_to_restriction sigma evk + | Evd.Evar_defined c -> match Constr.kind (EConstr.Unsafe.to_constr c) with + | Evar (evk,l) -> is_undefined_up_to_restriction sigma evk | _ -> (* We make the assumption that there is no way to refine an evar remaining after typing from the initial term given to @@ -634,7 +634,7 @@ module New = struct (* Find the right elimination suffix corresponding to the sort of the goal *) (* c should be of type A1->.. An->B with B an inductive definition *) let general_elim_then_using mk_elim - isrec allnames tac predicate ind (c, t) = + rec_flag allnames tac predicate ind (c, t) = Proofview.Goal.enter begin fun gl -> let sigma, elim = mk_elim ind gl in let ind = on_snd (fun u -> EInstance.kind sigma u) ind in @@ -663,7 +663,7 @@ module New = struct (str "The elimination combinator " ++ str name_elim ++ str " is unknown.") in let elimclause' = clenv_fchain ~with_univs:false indmv elimclause indclause in - let branchsigns = compute_constructor_signatures isrec ind in + let branchsigns = compute_constructor_signatures ~rec_flag ind in let brnames = compute_induction_names_gen false branchsigns allnames in let flags = Unification.elim_flags () in let elimclause' = @@ -686,7 +686,7 @@ module New = struct in let branchtacs = List.init (Array.length branchsigns) after_tac in Proofview.tclTHEN - (Clenvtac.clenv_refine false clenv') + (Clenvtac.clenv_refine clenv') (Proofview.tclEXTEND [] tclIDTAC branchtacs) end) end @@ -709,7 +709,7 @@ module New = struct let gl_make_elim ind = begin fun gl -> let gr = Indrec.lookup_eliminator (fst ind) (elimination_sort_of_goal gl) in let (sigma, c) = pf_apply Evd.fresh_global gl gr in - (sigma, EConstr.of_constr c) + (sigma, c) end let gl_make_case_dep (ind, u) = begin fun gl -> @@ -769,7 +769,6 @@ module New = struct Proofview.tclEVARMAP >>= fun sigma -> Proofview.tclENV >>= fun env -> let (sigma, c) = Evd.fresh_global env sigma ref in - let c = EConstr.of_constr c in Proofview.Unsafe.tclEVARS sigma <*> Proofview.tclUNIT c end diff --git a/tactics/tacticals.mli b/tactics/tacticals.mli index 340d8fbf3..1e66c2b0b 100644 --- a/tactics/tacticals.mli +++ b/tactics/tacticals.mli @@ -14,7 +14,6 @@ open EConstr open Evd open Proof_type open Locus -open Misctypes open Tactypes (** Tacticals i.e. functions from tactics to tactics. *) @@ -124,7 +123,7 @@ val fix_empty_or_and_pattern : int -> delayed_open_constr or_and_intro_pattern_expr -> delayed_open_constr or_and_intro_pattern_expr -val compute_constructor_signatures : rec_flag -> inductive * 'a -> bool list array +val compute_constructor_signatures : rec_flag:bool -> inductive * 'a -> bool list array (** Useful for [as intro_pattern] modifier *) val compute_induction_names : @@ -135,7 +134,7 @@ val elimination_sort_of_hyp : Id.t -> goal sigma -> Sorts.family val elimination_sort_of_clause : Id.t option -> goal sigma -> Sorts.family val pf_with_evars : (goal sigma -> Evd.evar_map * 'a) -> ('a -> tactic) -> tactic -val pf_constr_of_global : Globnames.global_reference -> (constr -> tactic) -> tactic +val pf_constr_of_global : GlobRef.t -> (constr -> tactic) -> tactic (** Tacticals defined directly in term of Proofview *) @@ -223,7 +222,7 @@ module New : sig val tclCOMPLETE : 'a tactic -> 'a tactic val tclSOLVE : unit tactic list -> unit tactic val tclPROGRESS : unit tactic -> unit tactic - val tclSELECT : Vernacexpr.goal_selector -> 'a tactic -> 'a tactic + val tclSELECT : Goal_select.t -> 'a tactic -> 'a tactic val tclWITHHOLES : bool -> 'a tactic -> Evd.evar_map -> 'a tactic val tclDELAYEDWITHHOLES : bool -> 'a delayed_open -> ('a -> unit tactic) -> unit tactic @@ -268,5 +267,5 @@ module New : sig val elim_on_ba : (branch_assumptions -> unit Proofview.tactic) -> branch_args -> unit Proofview.tactic val case_on_ba : (branch_assumptions -> unit Proofview.tactic) -> branch_args -> unit Proofview.tactic - val pf_constr_of_global : Globnames.global_reference -> constr Proofview.tactic + val pf_constr_of_global : GlobRef.t -> constr Proofview.tactic end diff --git a/tactics/tactics.ml b/tactics/tactics.ml index d0ec3358a..770e31fea 100644 --- a/tactics/tactics.ml +++ b/tactics/tactics.ml @@ -43,7 +43,7 @@ open Pretype_errors open Unification open Locus open Locusops -open Misctypes +open Tactypes open Proofview.Notations open Context.Named.Declaration @@ -128,14 +128,14 @@ let unsafe_intro env store decl b = (sigma, mkNamedLambda_or_LetIn decl ev) end -let introduction ?(check=true) id = +let introduction id = Proofview.Goal.enter begin fun gl -> let concl = Proofview.Goal.concl gl in let sigma = Tacmach.New.project gl in let hyps = named_context_val (Proofview.Goal.env gl) in let store = Proofview.Goal.extra gl in let env = Proofview.Goal.env gl in - let () = if check && mem_named_context_val id hyps then + let () = if mem_named_context_val id hyps then user_err ~hdr:"Tactics.introduction" (str "Variable " ++ Id.print id ++ str " is already declared.") in @@ -158,9 +158,9 @@ let convert_concl ?(check=true) ty k = let sigma = if check then begin ignore (Typing.unsafe_type_of env sigma ty); - let sigma,b = Reductionops.infer_conv env sigma ty conclty in - if not b then error "Not convertible."; - sigma + match Reductionops.infer_conv env sigma ty conclty with + | None -> error "Not convertible." + | Some sigma -> sigma end else sigma in let (sigma, x) = Evarutil.new_evar env sigma ~principal:true ~store ty in let ans = if k == DEFAULTcast then x else mkCast(x,k,conclty) in @@ -186,11 +186,10 @@ let convert_hyp_no_check = convert_hyp ~check:false let convert_gen pb x y = Proofview.Goal.enter begin fun gl -> - try - let sigma, b = Tacmach.New.pf_apply (Reductionops.infer_conv ~pb) gl x y in - if b then Proofview.Unsafe.tclEVARS sigma - else Tacticals.New.tclFAIL 0 (str "Not convertible") - with (* Reduction.NotConvertible *) _ -> + match Tacmach.New.pf_apply (Reductionops.infer_conv ~pb) gl x y with + | Some sigma -> Proofview.Unsafe.tclEVARS sigma + | None -> Tacticals.New.tclFAIL 0 (str "Not convertible") + | exception _ -> (** FIXME: Sometimes an anomaly is raised from conversion *) Tacticals.New.tclFAIL 0 (str "Not convertible") end @@ -198,32 +197,40 @@ end let convert x y = convert_gen Reduction.CONV x y let convert_leq x y = convert_gen Reduction.CUMUL x y -let clear_dependency_msg env sigma id = function +let clear_in_global_msg = function + | None -> mt () + | Some ref -> str " implicitly in " ++ Printer.pr_global ref + +let clear_dependency_msg env sigma id err inglobal = + let pp = clear_in_global_msg inglobal in + match err with | Evarutil.OccurHypInSimpleClause None -> - Id.print id ++ str " is used in conclusion." + Id.print id ++ str " is used" ++ pp ++ str " in conclusion." | Evarutil.OccurHypInSimpleClause (Some id') -> - Id.print id ++ strbrk " is used in hypothesis " ++ Id.print id' ++ str"." + Id.print id ++ strbrk " is used" ++ pp ++ str " in hypothesis " ++ Id.print id' ++ str"." | Evarutil.EvarTypingBreak ev -> str "Cannot remove " ++ Id.print id ++ strbrk " without breaking the typing of " ++ Printer.pr_existential env sigma ev ++ str"." -let error_clear_dependency env sigma id err = - user_err (clear_dependency_msg env sigma id err) +let error_clear_dependency env sigma id err inglobal = + user_err (clear_dependency_msg env sigma id err inglobal) -let replacing_dependency_msg env sigma id = function +let replacing_dependency_msg env sigma id err inglobal = + let pp = clear_in_global_msg inglobal in + match err with | Evarutil.OccurHypInSimpleClause None -> - str "Cannot change " ++ Id.print id ++ str ", it is used in conclusion." + str "Cannot change " ++ Id.print id ++ str ", it is used" ++ pp ++ str " in conclusion." | Evarutil.OccurHypInSimpleClause (Some id') -> str "Cannot change " ++ Id.print id ++ - strbrk ", it is used in hypothesis " ++ Id.print id' ++ str"." + strbrk ", it is used" ++ pp ++ str " in hypothesis " ++ Id.print id' ++ str"." | Evarutil.EvarTypingBreak ev -> str "Cannot change " ++ Id.print id ++ strbrk " without breaking the typing of " ++ Printer.pr_existential env sigma ev ++ str"." -let error_replacing_dependency env sigma id err = - user_err (replacing_dependency_msg env sigma id err) +let error_replacing_dependency env sigma id err inglobal = + user_err (replacing_dependency_msg env sigma id err inglobal) (* This tactic enables the user to remove hypotheses from the signature. * Some care is taken to prevent him from removing variables that are @@ -239,13 +246,12 @@ let clear_gen fail = function let env = Proofview.Goal.env gl in let sigma = Tacmach.New.project gl in let concl = Proofview.Goal.concl gl in - let evdref = ref sigma in - let (hyps, concl) = - try clear_hyps_in_evi env evdref (named_context_val env) concl ids - with Evarutil.ClearDependencyError (id,err) -> fail env sigma id err + let (sigma, hyps, concl) = + try clear_hyps_in_evi env sigma (named_context_val env) concl ids + with Evarutil.ClearDependencyError (id,err,inglobal) -> fail env sigma id err inglobal in let env = reset_with_named_context hyps env in - Proofview.tclTHEN (Proofview.Unsafe.tclEVARS !evdref) + Proofview.tclTHEN (Proofview.Unsafe.tclEVARS sigma) (Refine.refine ~typecheck:false begin fun sigma -> Evarutil.new_evar env sigma ~principal:true concl end) @@ -423,11 +429,10 @@ let get_previous_hyp_position env sigma id = let clear_hyps2 env sigma ids sign t cl = try - let evdref = ref (Evd.clear_metas sigma) in - let (hyps,t,cl) = Evarutil.clear_hyps2_in_evi env evdref sign t cl ids in - (hyps, t, cl, !evdref) - with Evarutil.ClearDependencyError (id,err) -> - error_replacing_dependency env sigma id err + let sigma = Evd.clear_metas sigma in + Evarutil.clear_hyps2_in_evi env sigma sign t cl ids + with Evarutil.ClearDependencyError (id,err,inglobal) -> + error_replacing_dependency env sigma id err inglobal let internal_cut_gen ?(check=true) dir replace id t = Proofview.Goal.enter begin fun gl -> @@ -439,7 +444,7 @@ let internal_cut_gen ?(check=true) dir replace id t = let sign',t,concl,sigma = if replace then let nexthyp = get_next_hyp_position env sigma id (named_context_of_val sign) in - let sign',t,concl,sigma = clear_hyps2 env sigma (Id.Set.singleton id) sign t concl in + let sigma,sign',t,concl = clear_hyps2 env sigma (Id.Set.singleton id) sign t concl in let sign' = insert_decl_in_named_context sigma (LocalAssum (id,t)) nexthyp sign' in sign',t,concl,sigma else @@ -557,15 +562,7 @@ let mutual_fix f n rest j = Proofview.Goal.enter begin fun gl -> end end -let fix ido n = match ido with - | None -> - Proofview.Goal.enter begin fun gl -> - let name = Proof_global.get_current_proof_name () in - let id = new_fresh_id Id.Set.empty name gl in - mutual_fix id n [] 0 - end - | Some id -> - mutual_fix id n [] 0 +let fix id n = mutual_fix id n [] 0 let rec check_is_mutcoind env sigma cl = let b = whd_all env sigma cl in @@ -608,15 +605,7 @@ let mutual_cofix f others j = Proofview.Goal.enter begin fun gl -> end end -let cofix ido = match ido with - | None -> - Proofview.Goal.enter begin fun gl -> - let name = Proof_global.get_current_proof_name () in - let id = new_fresh_id Id.Set.empty name gl in - mutual_cofix id [] 0 - end - | Some id -> - mutual_cofix id [] 0 +let cofix id = mutual_cofix id [] 0 (**************************************************************) (* Reduction and conversion tactics *) @@ -806,15 +795,15 @@ let check_types env sigma mayneedglobalcheck deep newc origc = let t2 = Retyping.get_type_of env sigma origc in let sigma, t2 = Evarsolve.refresh_universes ~onlyalg:true (Some false) env sigma t2 in - let sigma, b = infer_conv ~pb:Reduction.CUMUL env sigma t1 t2 in - if not b then + match infer_conv ~pb:Reduction.CUMUL env sigma t1 t2 with + | None -> if isSort sigma (whd_all env sigma t1) && isSort sigma (whd_all env sigma t2) then (mayneedglobalcheck := true; sigma) else user_err ~hdr:"convert-check-hyp" (str "Types are incompatible.") - else sigma + | Some sigma -> sigma end else if not (isSort sigma (whd_all env sigma t1)) then @@ -825,9 +814,9 @@ let check_types env sigma mayneedglobalcheck deep newc origc = let change_and_check cv_pb mayneedglobalcheck deep t env sigma c = let (sigma, t') = t sigma in let sigma = check_types env sigma mayneedglobalcheck deep t' c in - let sigma, b = infer_conv ~pb:cv_pb env sigma t' c in - if not b then user_err ~hdr:"convert-check-hyp" (str "Not convertible."); - (sigma, t') + match infer_conv ~pb:cv_pb env sigma t' c with + | None -> user_err ~hdr:"convert-check-hyp" (str "Not convertible."); + | Some sigma -> (sigma, t') (* Use cumulativity only if changing the conclusion not a subterm *) let change_on_subterm cv_pb deep t where env sigma c = @@ -965,6 +954,11 @@ let rec intro_then_gen name_flag move_flag force_flag dep_flag tac = | LetIn (name,b,t,u) when not dep_flag || not (noccurn sigma 1 u) -> 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 + Tacticals.New.tclTHEN + (Proofview.Unsafe.tclEVARS sigma) + (intro_then_gen name_flag move_flag force_flag dep_flag tac) | _ -> begin if not force_flag then Proofview.tclZERO (RefinerError (env, sigma, IntroNeedsProduct)) (* Note: red_in_concl includes betaiotazeta and this was like *) @@ -1159,6 +1153,11 @@ let tactic_infer_flags with_evar = { Pretyping.fail_evar = not with_evar; Pretyping.expand_evars = true } +type evars_flag = bool (* true = pose evars false = fail on evars *) +type rec_flag = bool (* true = recursive false = not recursive *) +type advanced_flag = bool (* true = advanced false = basic *) +type clear_flag = bool option (* true = clear hyp, false = keep hyp, None = use default *) + type 'a core_destruction_arg = | ElimOnConstr of 'a | ElimOnIdent of lident @@ -1258,7 +1257,6 @@ let cut c = end let error_uninstantiated_metas t clenv = - let t = EConstr.Unsafe.to_constr t in let na = meta_name clenv.evd (List.hd (Metaset.elements (metavars_of t))) in let id = match na with Name id -> id | _ -> anomaly (Pp.str "unnamed dependent meta.") in user_err (str "Cannot find an instance for " ++ Id.print id ++ str".") @@ -1268,7 +1266,7 @@ let check_unresolved_evars_of_metas sigma clenv = (* Refiner.pose_all_metas_as_evars are resolved *) List.iter (fun (mv,b) -> match b with | Clval (_,(c,_),_) -> - (match Constr.kind c.rebus with + (match Constr.kind (EConstr.Unsafe.to_constr c.rebus) with | Evar (evk,_) when Evd.is_undefined clenv.evd evk && not (Evd.mem sigma evk) -> error_uninstantiated_metas (mkMeta mv) clenv @@ -1288,7 +1286,7 @@ let do_replace id = function let clenv_refine_in ?(sidecond_first=false) with_evars ?(with_classes=true) targetid id sigma0 clenv tac = - let clenv = Clenvtac.clenv_pose_dependent_evars with_evars clenv in + let clenv = Clenvtac.clenv_pose_dependent_evars ~with_evars clenv in let clenv = if with_classes then { clenv with evd = Typeclasses.resolve_typeclasses @@ -1445,9 +1443,7 @@ let is_nonrec mind = (Global.lookup_mind (fst mind)).mind_finite == Declarations let find_ind_eliminator ind s gl = let gr = lookup_eliminator ind s in - let evd, c = Tacmach.New.pf_apply Evd.fresh_global gl gr in - let c = EConstr.of_constr c in - evd, c + Tacmach.New.pf_apply Evd.fresh_global gl gr let find_eliminator c gl = let ((ind,u),t) = Tacmach.New.pf_reduce_to_quantified_ind gl (Tacmach.New.pf_unsafe_type_of gl c) in @@ -1646,13 +1642,11 @@ let tclORELSEOPT t k = Proofview.tclZERO ~info e | Some tac -> tac) -let general_apply with_delta with_destruct with_evars clear_flag - {CAst.loc;v=(c,lbind : EConstr.constr with_bindings)} = +let general_apply ?(respect_opaque=false) with_delta with_destruct with_evars + clear_flag {CAst.loc;v=(c,lbind : EConstr.constr with_bindings)} = Proofview.Goal.enter begin fun gl -> let concl = Proofview.Goal.concl gl in let sigma = Tacmach.New.project gl in - let flags = - if with_delta then default_unify_flags () else default_no_delta_unify_flags () in (* The actual type of the theorem. It will be matched against the goal. If this fails, then the head constant will be unfolded step by step. *) @@ -1661,7 +1655,12 @@ let general_apply with_delta with_destruct with_evars clear_flag Proofview.Goal.enter begin fun gl -> let env = Proofview.Goal.env gl in let sigma = Tacmach.New.project gl in - + let ts = + if respect_opaque then Conv_oracle.get_transp_state (oracle env) + else full_transparent_state + in + let flags = + if with_delta then default_unify_flags () else default_no_delta_unify_flags ts in let thm_ty0 = nf_betaiota env sigma (Retyping.get_type_of env sigma c) in let try_apply thm_ty nprod = try @@ -1727,14 +1726,14 @@ let rec apply_with_bindings_gen b e = function (general_apply b b e k cb) (apply_with_bindings_gen b e cbl) -let apply_with_delayed_bindings_gen b e l = +let apply_with_delayed_bindings_gen b e l = let one k {CAst.loc;v=f} = Proofview.Goal.enter begin fun gl -> let sigma = Tacmach.New.project gl in let env = Proofview.Goal.env gl in let (sigma, cb) = f env sigma in Tacticals.New.tclWITHHOLES e - (general_apply b b e k CAst.(make ?loc cb)) sigma + (general_apply ~respect_opaque:(not b) b b e k CAst.(make ?loc cb)) sigma end in let rec aux = function @@ -1809,14 +1808,12 @@ let apply_in_once_main flags innerclause env sigma (loc,d,lbind) = in aux (make_clenv_binding env sigma (d,thm) lbind) -let apply_in_once sidecond_first with_delta with_destruct with_evars naming - id (clear_flag,{ CAst.loc; v= d,lbind}) tac = +let apply_in_once ?(respect_opaque = false) sidecond_first with_delta + with_destruct with_evars naming id (clear_flag,{ CAst.loc; v= d,lbind}) tac = let open Context.Rel.Declaration in Proofview.Goal.enter begin fun gl -> let env = Proofview.Goal.env gl in let sigma = Tacmach.New.project gl in - let flags = - if with_delta then default_unify_flags () else default_no_delta_unify_flags () 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 @@ -1824,6 +1821,12 @@ let apply_in_once sidecond_first with_delta with_destruct with_evars naming Proofview.Goal.enter begin fun gl -> let env = Proofview.Goal.env gl in let sigma = Tacmach.New.project gl in + let ts = + if respect_opaque then Conv_oracle.get_transp_state (oracle env) + else full_transparent_state + in + let flags = + if with_delta then default_unify_flags () else default_no_delta_unify_flags ts in try let clause = apply_in_once_main flags innerclause env sigma (loc,c,lbind) in clenv_refine_in ~sidecond_first with_evars targetid id sigma clause @@ -1843,14 +1846,14 @@ let apply_in_once sidecond_first with_delta with_destruct with_evars naming aux [] with_destruct d end -let apply_in_delayed_once sidecond_first with_delta with_destruct with_evars naming - id (clear_flag,{CAst.loc;v=f}) tac = +let apply_in_delayed_once ?(respect_opaque = false) sidecond_first with_delta + with_destruct with_evars naming id (clear_flag,{CAst.loc;v=f}) tac = Proofview.Goal.enter begin fun gl -> let env = Proofview.Goal.env gl in let sigma = Tacmach.New.project gl in let (sigma, c) = f env sigma in Tacticals.New.tclWITHHOLES with_evars - (apply_in_once sidecond_first with_delta with_destruct with_evars + (apply_in_once ~respect_opaque sidecond_first with_delta with_destruct with_evars naming id (clear_flag,CAst.(make ?loc c)) tac) sigma end @@ -1918,8 +1921,8 @@ let cast_no_check cast c = exact_no_check (mkCast (c, cast, concl)) end -let vm_cast_no_check c = cast_no_check Term.VMcast c -let native_cast_no_check c = cast_no_check Term.NATIVEcast c +let vm_cast_no_check c = cast_no_check VMcast c +let native_cast_no_check c = cast_no_check NATIVEcast c let exact_proof c = let open Tacmach.New in @@ -1942,16 +1945,19 @@ let assumption = let t = NamedDecl.get_type decl in let concl = Proofview.Goal.concl gl in let sigma = Tacmach.New.project gl in - let (sigma, is_same_type) = - if only_eq then (sigma, EConstr.eq_constr sigma t concl) + let ans = + if only_eq then + if EConstr.eq_constr sigma t concl then Some sigma + else None else let env = Proofview.Goal.env gl in infer_conv env sigma t concl in - if is_same_type then + match ans with + | Some sigma -> (Proofview.Unsafe.tclEVARS sigma) <*> exact_no_check (mkVar (NamedDecl.get_id decl)) - else arec gl only_eq rest + | None -> arec gl only_eq rest in let assumption_tac gl = let hyps = Proofview.Goal.hyps gl in @@ -1971,24 +1977,22 @@ let on_the_bodies = function exception DependsOnBody of Id.t option let check_is_type env sigma ty = - let evdref = ref sigma in try - let _ = Typing.e_sort_of env evdref ty in - !evdref + let sigma, _ = Typing.sort_of env sigma ty in + sigma with e when CErrors.noncritical e -> raise (DependsOnBody None) let check_decl env sigma decl = let open Context.Named.Declaration in let ty = NamedDecl.get_type decl in - let evdref = ref sigma in try - let _ = Typing.e_sort_of env evdref ty in - let _ = match decl with - | LocalAssum _ -> () - | LocalDef (_,c,_) -> Typing.e_check env evdref c ty + let sigma, _ = Typing.sort_of env sigma ty in + let sigma = match decl with + | LocalAssum _ -> sigma + | LocalDef (_,c,_) -> Typing.check env sigma c ty in - !evdref + sigma with e when CErrors.noncritical e -> let id = NamedDecl.get_id decl in raise (DependsOnBody (Some id)) @@ -2259,7 +2263,7 @@ let intro_or_and_pattern ?loc with_evars bracketed ll thin tac id = let c = mkVar id in let t = Tacmach.New.pf_unsafe_type_of gl c in let (ind,t) = Tacmach.New.pf_reduce_to_quantified_ind gl t in - let branchsigns = compute_constructor_signatures false ind in + let branchsigns = compute_constructor_signatures ~rec_flag:false ind in let nv_with_let = Array.map List.length branchsigns in let ll = fix_empty_or_and_pattern (Array.length branchsigns) ll in let ll = get_and_check_or_and_pattern ?loc ll branchsigns in @@ -2539,11 +2543,11 @@ let assert_as first hd ipat t = (* apply in as *) -let general_apply_in sidecond_first with_delta with_destruct with_evars - id lemmas ipat = +let general_apply_in ?(respect_opaque=false) sidecond_first with_delta + with_destruct with_evars id lemmas ipat = let tac (naming,lemma) tac id = - apply_in_delayed_once sidecond_first with_delta with_destruct with_evars - naming id lemma tac in + apply_in_delayed_once ~respect_opaque sidecond_first with_delta + with_destruct with_evars naming id lemma tac in Proofview.Goal.enter begin fun gl -> let destopt = if with_evars then MoveLast (* evars would depend on the whole context *) @@ -2574,7 +2578,7 @@ let apply_in simple with_evars id lemmas ipat = general_apply_in false simple simple with_evars id lemmas ipat let apply_delayed_in simple with_evars id lemmas ipat = - general_apply_in false simple simple with_evars id lemmas ipat + general_apply_in ~respect_opaque:true false simple simple with_evars id lemmas ipat (*****************************) (* Tactics abstracting terms *) @@ -2612,9 +2616,7 @@ let letin_tac_gen with_eq (id,depdecls,lastlhyp,ccl,c) ty = let eqdata = build_coq_eq_data () in let args = if lr then [t;mkVar id;c] else [t;c;mkVar id]in let (sigma, eq) = Evd.fresh_global env sigma eqdata.eq in - let eq = EConstr.of_constr eq in let (sigma, refl) = Evd.fresh_global env sigma eqdata.refl in - let refl = EConstr.of_constr 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 @@ -2648,6 +2650,15 @@ let insert_before decls lasthyp env = push_named d env) ~init:(reset_context env) env +let mk_eq_name env id {CAst.loc;v=ido} = + match ido with + | IntroAnonymous -> fresh_id_in_env (Id.Set.singleton id) (add_prefix "Heq" id) env + | IntroFresh heq_base -> fresh_id_in_env (Id.Set.singleton id) heq_base env + | IntroIdentifier id -> + if List.mem id (ids_of_named_context (named_context env)) then + user_err ?loc (Id.print id ++ str" is already used."); + id + (* unsafe *) let mkletin_goal env sigma store with_eq dep (id,lastlhyp,ccl,c) ty = @@ -2657,20 +2668,11 @@ let mkletin_goal env sigma store with_eq dep (id,lastlhyp,ccl,c) ty = else LocalAssum (id,t) in match with_eq with - | Some (lr,{CAst.loc;v=ido}) -> - let heq = match ido with - | IntroAnonymous -> fresh_id_in_env (Id.Set.singleton id) (add_prefix "Heq" id) env - | IntroFresh heq_base -> fresh_id_in_env (Id.Set.singleton id) heq_base env - | IntroIdentifier id -> - if List.mem id (ids_of_named_context (named_context env)) then - user_err ?loc (Id.print id ++ str" is already used."); - id in + | Some (lr,heq) -> let eqdata = build_coq_eq_data () in let args = if lr then [t;mkVar id;c] else [t;c;mkVar id]in let (sigma, eq) = Evd.fresh_global env sigma eqdata.eq in - let eq = EConstr.of_constr eq in let (sigma, refl) = Evd.fresh_global env sigma eqdata.refl in - let refl = EConstr.of_constr 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 @@ -3008,8 +3010,24 @@ let unfold_body x = end end +let warn_cannot_remove_as_expected = + CWarnings.create ~name:"cannot-remove-as-expected" ~category:"tactics" + (fun (id,inglobal) -> + let pp = match inglobal with + | None -> mt () + | Some ref -> str ", it is used implicitly in " ++ Printer.pr_global ref in + str "Cannot remove " ++ Id.print id ++ pp ++ str ".") + +let clear_for_destruct ids = + Proofview.tclORELSE + (clear_gen (fun env sigma id err inglobal -> raise (ClearDependencyError (id,err,inglobal))) ids) + (function + | ClearDependencyError (id,err,inglobal),_ -> warn_cannot_remove_as_expected (id,inglobal); Proofview.tclUNIT () + | e -> iraise e) + (* Either unfold and clear if defined or simply clear if not a definition *) -let expand_hyp id = Tacticals.New.tclTRY (unfold_body id) <*> clear [id] +let expand_hyp id = + Tacticals.New.tclTRY (unfold_body id) <*> clear_for_destruct [id] (*****************************) (* High-level induction *) @@ -3425,7 +3443,7 @@ let cook_sign hyp0_opt inhyps indvars env sigma = type elim_scheme = { elimc: constr with_bindings option; elimt: types; - indref: global_reference option; + indref: GlobRef.t option; params: rel_context; (* (prm1,tprm1);(prm2,tprm2)...(prmp,tprmp) *) nparams: int; (* number of parameters *) predicates: rel_context; (* (Qq, (Tq_1 -> Tq_2 ->...-> Tq_nq)), (Q1,...) *) @@ -3787,7 +3805,10 @@ let specialize_eqs id = let ty = Tacmach.New.pf_get_hyp_typ id gl in let evars = ref (Proofview.Goal.sigma gl) in let unif env evars c1 c2 = - compare_upto_variables !evars c1 c2 && Evarconv.e_conv env evars c1 c2 + compare_upto_variables !evars c1 c2 && + (match Evarconv.conv env !evars c1 c2 with + | Some sigma -> evars := sigma; true + | None -> false) in let rec aux in_eqs ctx acc ty = match EConstr.kind !evars ty with @@ -3812,7 +3833,8 @@ let specialize_eqs id = | _ -> if in_eqs then acc, in_eqs, ctx, ty else - let e = e_new_evar (push_rel_context ctx env) evars t in + 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) | t -> acc, in_eqs, ctx, ty in @@ -4181,7 +4203,7 @@ let induction_tac with_evars params indvars elim = let elimclause' = recolle_clenv i params indvars elimclause gl in (* one last resolution (useless?) *) let resolved = clenv_unique_resolver ~flags:(elim_flags ()) elimclause' gl in - Clenvtac.clenv_refine with_evars resolved + Clenvtac.clenv_refine ~with_evars resolved end (* Apply induction "in place" taking into account dependent @@ -4339,7 +4361,7 @@ let check_expected_type env sigma (elimc,bl) elimt = let sigma,cl = make_evar_clause env sigma ~len:(n - 1) elimt in let sigma = solve_evar_clause env sigma true cl bl in let (_,u,_) = destProd sigma cl.cl_concl in - fun t -> Evarconv.e_cumul env (ref sigma) t u + fun t -> Option.has_some (Evarconv.cumul env sigma t u) let check_enough_applied env sigma elim = (* A heuristic to decide whether the induction arg is enough applied *) @@ -4381,7 +4403,8 @@ let pose_induction_arg_then isrec with_evars (is_arg_pure_hyp,from_prefix) elim match res with | None -> (* pattern not found *) - let with_eq = Option.map (fun eq -> (false,eq)) eqname in + let with_eq = Option.map (fun eq -> (false,mk_eq_name env id eq)) eqname in + let inhyps = if List.is_empty inhyps then inhyps else Option.fold_left (fun inhyps (_,heq) -> heq::inhyps) inhyps with_eq in (* we restart using bindings after having tried type-class resolution etc. on the term given by the user *) let flags = tactic_infer_flags (with_evars && (* do not give a success semantics to edestruct on an open term yet *) false) in @@ -4406,21 +4429,22 @@ let pose_induction_arg_then isrec with_evars (is_arg_pure_hyp,from_prefix) elim else Proofview.tclUNIT (); if isrec then Proofview.cycle (-1) else Proofview.tclUNIT () ]) - tac + (tac inhyps) in Proofview.tclTHEN (Proofview.Unsafe.tclEVARS sigma) tac | Some (sigma', c) -> (* pattern found *) - let with_eq = Option.map (fun eq -> (false,eq)) eqname in (* TODO: if ind has predicate parameters, use JMeq instead of eq *) let env = reset_with_named_context sign env in + let with_eq = Option.map (fun eq -> (false,mk_eq_name env id eq)) eqname in + let inhyps = if List.is_empty inhyps then inhyps else Option.fold_left (fun inhyps (_,heq) -> heq::inhyps) inhyps with_eq in let tac = Tacticals.New.tclTHENLIST [ Refine.refine ~typecheck:false begin fun sigma -> mkletin_goal env sigma store with_eq true (id,lastlhyp,ccl,c) None end; - tac + (tac inhyps) ] in Proofview.tclTHEN (Proofview.Unsafe.tclEVARS sigma') tac @@ -4470,7 +4494,7 @@ let induction_gen clear_flag isrec with_evars elim pose_induction_arg_then isrec with_evars info_arg elim id arg t inhyps cls (induction_with_atomization_of_ind_arg - isrec with_evars elim names id inhyps) + isrec with_evars elim names id) end (* Induction on a list of arguments. First make induction arguments @@ -4930,9 +4954,9 @@ let cache_term_by_tactic_then ~opaque ?(goal_type=None) id gk tac tacK = let evd, ctx, concl = (* FIXME: should be done only if the tactic succeeds *) - let evd, nf = nf_evars_and_universes !evdref in + let evd = Evd.minimize_universes !evdref in let ctx = Evd.universe_context_set evd in - evd, ctx, nf concl + evd, ctx, Evarutil.nf_evars_universes evd concl in let concl = EConstr.of_constr concl in let solve_tac = tclCOMPLETE (tclTHEN (tclDO (List.length sign) intro) tac) in diff --git a/tactics/tactics.mli b/tactics/tactics.mli index 7809dbf48..8d4302450 100644 --- a/tactics/tactics.mli +++ b/tactics/tactics.mli @@ -16,10 +16,8 @@ open Proof_type open Evd open Clenv open Redexpr -open Globnames open Pattern open Unification -open Misctypes open Tactypes open Locus open Ltac_pretype @@ -35,16 +33,16 @@ val is_quantified_hypothesis : Id.t -> Proofview.Goal.t -> bool (** {6 Primitive tactics. } *) -val introduction : ?check:bool -> Id.t -> unit Proofview.tactic +val introduction : Id.t -> unit Proofview.tactic val convert_concl : ?check:bool -> types -> cast_kind -> unit Proofview.tactic val convert_hyp : ?check:bool -> named_declaration -> unit Proofview.tactic val convert_concl_no_check : types -> cast_kind -> unit Proofview.tactic val convert_hyp_no_check : named_declaration -> unit Proofview.tactic val mutual_fix : Id.t -> int -> (Id.t * int * constr) list -> int -> unit Proofview.tactic -val fix : Id.t option -> int -> unit Proofview.tactic +val fix : Id.t -> int -> unit Proofview.tactic val mutual_cofix : Id.t -> (Id.t * constr) list -> int -> unit Proofview.tactic -val cofix : Id.t option -> unit Proofview.tactic +val cofix : Id.t -> unit Proofview.tactic val convert : constr -> constr -> unit Proofview.tactic val convert_leq : constr -> constr -> unit Proofview.tactic @@ -57,8 +55,8 @@ val find_intro_names : rel_context -> goal sigma -> Id.t list val intro : unit Proofview.tactic val introf : unit Proofview.tactic -val intro_move : Id.t option -> Id.t move_location -> unit Proofview.tactic -val intro_move_avoid : Id.t option -> Id.Set.t -> Id.t move_location -> unit Proofview.tactic +val intro_move : Id.t option -> Id.t Logic.move_location -> unit Proofview.tactic +val intro_move_avoid : Id.t option -> Id.Set.t -> Id.t Logic.move_location -> unit Proofview.tactic (** [intro_avoiding idl] acts as intro but prevents the new Id.t to belong to [idl] *) @@ -92,6 +90,11 @@ val intros_clearing : bool list -> unit Proofview.tactic val try_intros_until : (Id.t -> unit Proofview.tactic) -> quantified_hypothesis -> unit Proofview.tactic +type evars_flag = bool (* true = pose evars false = fail on evars *) +type rec_flag = bool (* true = recursive false = not recursive *) +type advanced_flag = bool (* true = advanced false = basic *) +type clear_flag = bool option (* true = clear hyp, false = keep hyp, None = use default *) + (** Apply a tactic on a quantified hypothesis, an hypothesis in context or a term with bindings *) @@ -118,11 +121,11 @@ val use_clear_hyp_by_default : unit -> bool (** {6 Introduction tactics with eliminations. } *) val intro_patterns : evars_flag -> intro_patterns -> unit Proofview.tactic -val intro_patterns_to : evars_flag -> Id.t move_location -> intro_patterns -> +val intro_patterns_to : evars_flag -> Id.t Logic.move_location -> intro_patterns -> unit Proofview.tactic -val intro_patterns_bound_to : evars_flag -> int -> Id.t move_location -> intro_patterns -> +val intro_patterns_bound_to : evars_flag -> int -> Id.t Logic.move_location -> intro_patterns -> unit Proofview.tactic -val intro_pattern_to : evars_flag -> Id.t move_location -> delayed_open_constr intro_pattern_expr -> +val intro_pattern_to : evars_flag -> Id.t Logic.move_location -> delayed_open_constr intro_pattern_expr -> unit Proofview.tactic (** Implements user-level "intros", with [] standing for "**" *) @@ -177,7 +180,7 @@ val change : val pattern_option : (occurrences * constr) list -> goal_location -> unit Proofview.tactic val reduce : red_expr -> clause -> unit Proofview.tactic -val unfold_constr : global_reference -> unit Proofview.tactic +val unfold_constr : GlobRef.t -> unit Proofview.tactic (** {6 Modification of the local context. } *) @@ -189,7 +192,7 @@ val apply_clear_request : clear_flag -> bool -> constr -> unit Proofview.tactic val specialize : constr with_bindings -> intro_pattern option -> unit Proofview.tactic -val move_hyp : Id.t -> Id.t move_location -> unit Proofview.tactic +val move_hyp : Id.t -> Id.t Logic.move_location -> unit Proofview.tactic val rename_hyp : (Id.t * Id.t) list -> unit Proofview.tactic val revert : Id.t list -> unit Proofview.tactic @@ -253,7 +256,7 @@ val apply_delayed_in : type elim_scheme = { elimc: constr with_bindings option; elimt: types; - indref: global_reference option; + indref: GlobRef.t option; params: rel_context; (** (prm1,tprm1);(prm2,tprm2)...(prmp,tprmp) *) nparams: int; (** number of parameters *) predicates: rel_context; (** (Qq, (Tq_1 -> Tq_2 ->...-> Tq_nq)), (Q1,...) *) diff --git a/tactics/term_dnet.ml b/tactics/term_dnet.ml index 753c608ad..8bdcc6321 100644 --- a/tactics/term_dnet.ml +++ b/tactics/term_dnet.ml @@ -37,7 +37,7 @@ struct type 't t = | DRel | DSort - | DRef of global_reference + | DRef of GlobRef.t | DCtx of 't * 't (* (binding list, subterm) = Prods and LetIns *) | DLambda of 't * 't | DApp of 't * 't (* binary app *) @@ -290,7 +290,7 @@ struct | Const (c,u) -> Term (DRef (ConstRef c)) | Ind (i,u) -> Term (DRef (IndRef i)) | Construct (c,u)-> Term (DRef (ConstructRef c)) - | Term.Meta _ -> assert false + | Meta _ -> assert false | Evar (i,_) -> let meta = try Evar.Map.find i !metas diff --git a/tactics/term_dnet.mli b/tactics/term_dnet.mli index 2c748f9c9..7bce57789 100644 --- a/tactics/term_dnet.mli +++ b/tactics/term_dnet.mli @@ -26,7 +26,7 @@ open Mod_subst The results returned here are perfect, since post-filtering is done inside here. - See lib/dnet.mli for more details. + See tactics/dnet.mli for more details. *) (** Identifiers to store (right hand side of the association) *) diff --git a/test-suite/Makefile b/test-suite/Makefile index 8239600b1..32e245e36 100644 --- a/test-suite/Makefile +++ b/test-suite/Makefile @@ -8,9 +8,6 @@ ## # (see LICENSE file for the text of the license) ## ########################################################################## -# This is a standalone Makefile to run the test-suite. It can be used -# outside of the Coq source tree (if BIN is overridden). - # There is one %.v.log target per %.v test file. The target will be # filled with the output, timings and status of the test. There is # also one target per directory containing %.v files, that runs all @@ -23,6 +20,14 @@ # The "run" target runs all tests that have not been run yet. To force # all tests to be run, use the "clean" target. + +########################################################################### +# Includes +########################################################################### + +-include ../config/Makefile +include ../Makefile.common + ####################################################################### # Variables ####################################################################### @@ -79,6 +84,8 @@ log_anomaly = "==========> FAILURE <==========" log_failure = "==========> FAILURE <==========" log_intro = "==========> TESTING $(1) <==========" +FAIL = >&2 echo 'FAILED $@' + ####################################################################### # Testing subsystems ####################################################################### @@ -92,10 +99,10 @@ INTERACTIVE := interactive VSUBSYSTEMS := prerequisite success failure $(BUGS) output \ output-modulo-time $(INTERACTIVE) micromega $(COMPLEXITY) modules stm \ - coqdoc + coqdoc ssr # All subsystems -SUBSYSTEMS := $(VSUBSYSTEMS) misc bugs ide vio coqchk coqwc coq-makefile +SUBSYSTEMS := $(VSUBSYSTEMS) misc bugs ide vio coqchk coqwc coq-makefile unit-tests PREREQUISITELOG = prerequisite/admit.v.log \ prerequisite/make_local.v.log prerequisite/make_notation.v.log \ @@ -115,25 +122,27 @@ run: $(SUBSYSTEMS) bugs: $(BUGS) clean: - rm -f trace .lia.cache - $(SHOW) "RM <**/*.stamp> <**/*.vo> <**/*.vio> <**/*.log>" + rm -f trace .lia.cache output/MExtraction.out + $(SHOW) 'RM <**/*.stamp> <**/*.vo> <**/*.vio> <**/*.log> <**/*.glob>' $(HIDE)find . \( \ - -name '*.stamp' -o -name '*.vo' -o -name '*.vio' -o -name '*.log' \ - \) -print0 | xargs -0 rm -f - + -name '*.stamp' -o -name '*.vo' -o -name '*.vio' -o -name '*.log' -o -name '*.glob' \ + \) -print0 | xargs -0 rm -f + $(SHOW) 'RM <**/*.cmx> <**/*.cmi> <**/*.o> <**/*.test>' + $(HIDE)find unit-tests \( \ + -name '*.cmx' -o -name '*.cmi' -o -name '*.o' -o -name '*.test' \ + \) -print0 | xargs -0 rm -f distclean: clean - $(HIDE)find . -name '*.log' -print0 | xargs -0 rm -f + $(SHOW) 'RM <**/*.aux>' + $(HIDE)find . -name '*.aux' -print0 | xargs -0 rm -f ####################################################################### # Per-subsystem targets ####################################################################### -define mkstamp -$(1): $(1).stamp ; @true -$(1).stamp: $(patsubst %.v,%.v.log,$(wildcard $(1)/*.v)) ; \ - $(HIDE)touch $$@ +define vdeps +$(1): $(patsubst %.v,%.v.log,$(wildcard $(1)/*.v)) endef -$(foreach S,$(VSUBSYSTEMS),$(eval $(call mkstamp,$(S)))) +$(foreach S,$(VSUBSYSTEMS),$(eval $(call vdeps,$(S)))) ####################################################################### # Summary @@ -157,18 +166,20 @@ summary: $(call summary_dir, "Complexity tests", complexity); \ $(call summary_dir, "Module tests", modules); \ $(call summary_dir, "STM tests", stm); \ + $(call summary_dir, "SSR tests", ssr); \ $(call summary_dir, "IDE tests", ide); \ $(call summary_dir, "VI tests", vio); \ $(call summary_dir, "Coqchk tests", coqchk); \ $(call summary_dir, "Coqwc tests", coqwc); \ $(call summary_dir, "Coq makefile", coq-makefile); \ $(call summary_dir, "Coqdoc tests", coqdoc); \ + $(call summary_dir, "Unit tests", unit-tests); \ nb_success=`find . -name '*.log' -exec tail -n2 '{}' \; | grep -e $(log_success) | wc -l`; \ nb_failure=`find . -name '*.log' -exec tail -n2 '{}' \; | grep -e $(log_failure) | wc -l`; \ nb_tests=`expr $$nb_success + $$nb_failure`; \ - pourcentage=`expr 100 \* $$nb_success / $$nb_tests`; \ + percentage=`expr 100 \* $$nb_success / $$nb_tests`; \ echo; \ - echo "$$nb_success tests passed over $$nb_tests, i.e. $$pourcentage %"; \ + echo "$$nb_success tests passed over $$nb_tests, i.e. $$percentage %"; \ } summary.log: @@ -221,6 +232,7 @@ $(addsuffix .log,$(wildcard bugs/opened/*.v)): %.v.log: %.v else \ echo $(log_failure); \ echo " $<...Error! (bug seems to be closed, please check)"; \ + $(FAIL); \ fi; \ } > "$@" @@ -236,10 +248,49 @@ $(addsuffix .log,$(wildcard bugs/closed/*.v)): %.v.log: %.v else \ echo $(log_failure); \ echo " $<...Error! (bug seems to be opened, please check)"; \ + $(FAIL); \ fi; \ } > "$@" ####################################################################### +# Unit tests +####################################################################### + +OCAMLOPT := $(OCAMLFIND) opt $(CAMLFLAGS) +SYSMOD:=-package num,str,unix,dynlink,threads + +COQSRCDIRS:=$(addprefix -I $(LIB)/,$(CORESRCDIRS)) +COQCMXS:=$(addprefix $(LIB)/,$(LINKCMX)) + +# ML files from unit-test framework, not containing tests +UNIT_SRCFILES:=$(shell find ./unit-tests/src -name *.ml) +UNIT_ALLMLFILES:=$(shell find ./unit-tests -name *.ml) +UNIT_MLFILES:=$(filter-out $(UNIT_SRCFILES),$(UNIT_ALLMLFILES)) +UNIT_LOGFILES:=$(patsubst %.ml,%.ml.log,$(UNIT_MLFILES)) + +UNIT_CMXS=utest.cmx + +unit-tests/src/utest.cmx: unit-tests/src/utest.ml unit-tests/src/utest.cmi + $(SHOW) 'OCAMLOPT $<' + $(HIDE)$(OCAMLOPT) -c -I unit-tests/src -package oUnit $< +unit-tests/src/utest.cmi: unit-tests/src/utest.mli + $(SHOW) 'OCAMLOPT $<' + $(HIDE)$(OCAMLOPT) -package oUnit $< + +$(UNIT_LOGFILES): unit-tests/src/utest.cmx + +unit-tests: $(UNIT_LOGFILES) + +# Build executable, run it to generate log file +unit-tests/%.ml.log: unit-tests/%.ml + $(SHOW) 'TEST $<' + $(HIDE)$(OCAMLOPT) -linkall -linkpkg -cclib -lcoqrun \ + $(SYSMOD) -package camlp5.gramlib,oUnit \ + -I unit-tests/src $(COQSRCDIRS) $(COQCMXS) \ + $(UNIT_CMXS) $< -o $<.test; + $(HIDE)./$<.test + +####################################################################### # Other generic tests ####################################################################### @@ -251,13 +302,15 @@ $(addsuffix .log,$(wildcard prerequisite/*.v)): %.v.log: %.v if [ $$R != 0 ]; then \ echo $(log_failure); \ echo " $<...could not be prepared" ; \ + $(FAIL); \ else \ echo $(log_success); \ echo " $<...correctly prepared" ; \ fi; \ } > "$@" -$(addsuffix .log,$(wildcard success/*.v micromega/*.v modules/*.v)): %.v.log: %.v $(PREREQUISITELOG) +ssr: $(wildcard ssr/*.v:%.v=%.v.log) +$(addsuffix .log,$(wildcard ssr/*.v success/*.v micromega/*.v modules/*.v)): %.v.log: %.v $(PREREQUISITELOG) @echo "TEST $< $(call get_coq_prog_args_in_parens,"$<")" $(HIDE){ \ opts="$(if $(findstring modules/,$<),-R modules Mods -impredicative-set)"; \ @@ -269,6 +322,7 @@ $(addsuffix .log,$(wildcard success/*.v micromega/*.v modules/*.v)): %.v.log: %. else \ echo $(log_failure); \ echo " $<...Error! (should be accepted)"; \ + $(FAIL); \ fi; \ } > "$@" @@ -285,6 +339,7 @@ $(addsuffix .log,$(wildcard stm/*.v)): %.v.log: %.v else \ echo $(log_failure); \ echo " $<...Error! (should be accepted)"; \ + $(FAIL); \ fi; \ } > "$@" @@ -299,6 +354,7 @@ $(addsuffix .log,$(wildcard failure/*.v)): %.v.log: %.v $(PREREQUISITELOG) else \ echo $(log_failure); \ echo " $<...Error! (should be rejected)"; \ + $(FAIL); \ fi; \ } > "$@" @@ -306,25 +362,33 @@ $(addsuffix .log,$(wildcard output/*.v)): %.v.log: %.v %.out $(PREREQUISITELOG) @echo "TEST $< $(call get_coq_prog_args_in_parens,"$<")" $(HIDE){ \ echo $(call log_intro,$<); \ - tmpoutput=`mktemp /tmp/coqcheck.XXXXXX`; \ + output=$*.out.real; \ $(call get_command_based_on_flags,"$<") "$<" $(call get_coq_prog_args,"$<") 2>&1 \ | grep -v "Welcome to Coq" \ | grep -v "\[Loading ML file" \ | grep -v "Skipping rcfile loading" \ | grep -v "^<W>" \ | sed 's/File "[^"]*"/File "stdin"/' \ - > $$tmpoutput; \ - diff -u --strip-trailing-cr $*.out $$tmpoutput 2>&1; R=$$?; times; \ + > $$output; \ + diff -u --strip-trailing-cr $*.out $$output 2>&1; R=$$?; times; \ if [ $$R = 0 ]; then \ echo $(log_success); \ echo " $<...Ok"; \ + rm $$output; \ else \ echo $(log_failure); \ echo " $<...Error! (unexpected output)"; \ + $(FAIL); \ fi; \ - rm $$tmpoutput; \ } > "$@" +.PHONY: approve-output +approve-output: output + $(HIDE)for f in output/*.out.real; do \ + mv "$$f" "$${f%.real}"; \ + echo "Updated $${f%.real}!"; \ + done + # the expected output for the MExtraction test is # /plugins/micromega/micromega.ml except with additional newline output/MExtraction.out: ../plugins/micromega/micromega.ml @@ -363,6 +427,7 @@ $(addsuffix .log,$(wildcard output-modulo-time/*.v)): %.v.log: %.v %.out else \ echo $(log_failure); \ echo " $<...Error! (unexpected output)"; \ + $(FAIL); \ fi; \ rm $$tmpoutput; \ rm $$tmpexpected; \ @@ -379,6 +444,7 @@ $(addsuffix .log,$(wildcard interactive/*.v)): %.v.log: %.v $(PREREQUISITELOG) else \ echo $(log_failure); \ echo " $<...Error! (should be accepted)"; \ + $(FAIL); \ fi; \ } > "$@" @@ -411,6 +477,7 @@ $(addsuffix .log,$(wildcard complexity/*.v)): %.v.log: %.v $(PREREQUISITELOG) else \ echo $(log_failure); \ echo " $<...Error! (should run faster)"; \ + $(FAIL); \ fi; \ fi; \ } > "$@" @@ -428,6 +495,7 @@ $(addsuffix .log,$(wildcard ideal-features/*.v)): %.v.log: %.v $(PREREQUISITELOG else \ echo $(log_failure); \ echo " $<...Good news! (wish seems to be granted, please check)"; \ + $(FAIL); \ fi; \ } > "$@" @@ -462,6 +530,7 @@ $(patsubst %.sh,%.log,$(wildcard misc/*.sh)): %.log: %.sh $(PREREQUISITELOG) else \ echo $(log_failure); \ echo " $<...Error!"; \ + $(FAIL); \ fi; \ } > "$@" @@ -480,6 +549,7 @@ ide : $(patsubst %.fake,%.fake.log,$(wildcard ide/*.fake)) else \ echo $(log_failure); \ echo " $<...Error!"; \ + $(FAIL); \ fi; \ } > "$@" @@ -499,6 +569,7 @@ vio: $(patsubst %.v,%.vio.log,$(wildcard vio/*.v)) else \ echo $(log_failure); \ echo " $<...Error!"; \ + $(FAIL); \ fi; \ } > "$@" @@ -517,6 +588,7 @@ coqchk: $(patsubst %.v,%.chk.log,$(wildcard coqchk/*.v)) else \ echo $(log_failure); \ echo " $<...Error!"; \ + $(FAIL); \ fi; \ } > "$@" @@ -536,6 +608,7 @@ coqwc/%.v.log : coqwc/%.v else \ echo $(log_failure); \ echo " $<...Error! (unexpected output)"; \ + $(FAIL); \ fi; \ rm $$tmpoutput; \ } > "$@" @@ -556,6 +629,7 @@ coq-makefile/%.log : coq-makefile/%/run.sh else \ echo $(log_failure); \ echo " $<...Error!"; \ + $(FAIL); \ fi; \ ) > "$@" @@ -580,5 +654,6 @@ $(addsuffix .log,$(wildcard coqdoc/*.v)): %.v.log: %.v %.html.out %.tex.out $(PR else \ echo $(log_failure); \ echo " $<...Error! (unexpected output)"; \ + $(FAIL); \ fi; \ } > "$@" diff --git a/test-suite/README.md b/test-suite/README.md index 1d1195646..e81da0830 100644 --- a/test-suite/README.md +++ b/test-suite/README.md @@ -62,14 +62,37 @@ BUILDING SUMMARY FILE NO FAILURES ``` -See [`test-suite/Makefile`](/test-suite/Makefile) for more information. +See [`test-suite/Makefile`](Makefile) for more information. ## Adding a test -Regression tests for closed bugs should be added to `test-suite/bugs/closed`, as `1234.v` where `1234` is the bug number. +Regression tests for closed bugs should be added to +[`bugs/closed`](bugs/closed), as `1234.v` where `1234` is the bug number. Files in this directory are tested for successful compilation. When you fix a bug, you should usually add a regression test here as well. -The error "(bug seems to be opened, please check)" when running `make test-suite` means that a test in `bugs/closed` failed to compile. +The error "(bug seems to be opened, please check)" when running +`make test-suite` means that a test in [`bugs/closed`](bugs/closed) failed to +compile. -There are also output tests in `test-suite/output` which consist of a `.v` file and a `.out` file with the expected output. +There are also output tests in [`output`](output) which consist of a `.v` file +and a `.out` file with the expected output. + +There are unit tests of OCaml code in [`unit-tests`](unit-tests). These tests +are contained in `.ml` files, and rely on the `OUnit` unit-test framework, as +described at <http://ounit.forge.ocamlcore.org/>. Use `make unit-tests` in the +[`unit-tests`](unit-tests) directory to run them. + +## Fixing output tests + +When an output test `output/foo.v` fails, the output is stored in +`output/foo.out.real`. Move that file to the reference file +`output/foo.out` to update the test, approving the new output. Target +`approve-output` will do this for all failing output tests +automatically. + +Don't forget to check the updated `.out` files into git! + +Note that `output/MExtraction.out` is special: it is copied from +[`micromega/micromega.ml`](../plugins/micromega/micromega.ml) in the plugin +source directory. Automatic approval will incorrectly update the copy. diff --git a/test-suite/bugs/7333.v b/test-suite/bugs/7333.v new file mode 100644 index 000000000..fba5b9029 --- /dev/null +++ b/test-suite/bugs/7333.v @@ -0,0 +1,39 @@ +Module Example1. + +CoInductive wrap : Type := + | item : unit -> wrap. + +Definition extract (t : wrap) : unit := +match t with +| item x => x +end. + +CoFixpoint close u : unit -> wrap := +match u with +| tt => item +end. + +Definition table : wrap := close tt tt. + +Eval vm_compute in (extract table). +Eval vm_compute in (extract table). + +End Example1. + +Module Example2. + +Set Primitive Projections. +CoInductive wrap : Type := + item { extract : unit }. + +CoFixpoint close u : unit -> wrap := +match u with +| tt => item +end. + +Definition table : wrap := close tt tt. + +Eval vm_compute in (extract table). +Eval vm_compute in (extract table). + +End Example2. diff --git a/test-suite/bugs/opened/1501.v b/test-suite/bugs/closed/1501.v index b36f21da1..e771e192d 100644 --- a/test-suite/bugs/opened/1501.v +++ b/test-suite/bugs/closed/1501.v @@ -3,6 +3,7 @@ Set Implicit Arguments. Require Export Relation_Definitions. Require Export Setoid. +Require Import Morphisms. Section Essais. @@ -40,57 +41,27 @@ Parameter Hint Resolve equiv_refl equiv_sym equiv_trans: monad. -Instance equiv_rel A: Equivalence (@equiv A). -Proof. - constructor. - intros xa; apply equiv_refl. - intros xa xb; apply equiv_sym. - intros xa xb xc; apply equiv_trans. -Defined. - -Definition fequiv (A B: Type) (f g: A -> K B) := forall (x:A), (equiv (f x) (g -x)). - -Lemma fequiv_refl : forall (A B: Type) (f : A -> K B), fequiv f f. -Proof. - unfold fequiv; auto with monad. -Qed. - -Lemma fequiv_sym : forall (A B: Type) (x y : A -> K B), fequiv x y -> fequiv y -x. -Proof. - unfold fequiv; auto with monad. -Qed. +Add Parametric Relation A : (K A) (@equiv A) + reflexivity proved by (@equiv_refl A) + symmetry proved by (@equiv_sym A) + transitivity proved by (@equiv_trans A) + as equiv_rel. -Lemma fequiv_trans : forall (A B: Type) (x y z : A -> K B), fequiv x y -> -fequiv -y z -> fequiv x z. +Add Parametric Morphism A B : (@bind A B) + with signature (@equiv A) ==> (pointwise_relation A (@equiv B)) ==> (@equiv B) + as bind_mor. Proof. - unfold fequiv; intros; eapply equiv_trans; auto with monad. -Qed. - -Instance fequiv_re A B: Equivalence (@fequiv A B). -Proof. - constructor. - intros f; apply fequiv_refl. - intros f g; apply fequiv_sym. - intros f g h; apply fequiv_trans. -Defined. - -Instance bind_mor A B: Morphisms.Proper (@equiv _ ==> @fequiv _ _ ==> @equiv _) (@bind A B). -Proof. - unfold fequiv; intros x y xy_equiv f g fg_equiv; apply bind_compat; auto. + unfold pointwise_relation; intros; apply bind_compat; auto. Qed. Lemma test: forall (A B: Type) (m1 m2 m3: K A) (f: A -> A -> K B), - (equiv m1 m2) -> (equiv m2 m3) -> - equiv (bind m1 (fun a => bind m2 (fun a' => f a a'))) - (bind m2 (fun a => bind m3 (fun a' => f a a'))). + (equiv m1 m2) -> (equiv m2 m3) -> + equiv (bind m1 (fun a => bind m2 (fun a' => f a a'))) + (bind m2 (fun a => bind m3 (fun a' => f a a'))). Proof. intros A B m1 m2 m3 f H1 H2. setoid_rewrite H1. (* this works *) - Fail setoid_rewrite H2. -Abort. -(* trivial by equiv_refl. -Qed.*) + setoid_rewrite H2. + reflexivity. +Qed. diff --git a/test-suite/bugs/closed/2001.v b/test-suite/bugs/closed/2001.v index d0b3bf173..652c65706 100644 --- a/test-suite/bugs/closed/2001.v +++ b/test-suite/bugs/closed/2001.v @@ -7,7 +7,7 @@ Inductive T : Set := | v : T. Definition f (s:nat) (t:T) : nat. -fix 2. +fix f 2. intros s t. refine match t with diff --git a/test-suite/bugs/opened/2456.v b/test-suite/bugs/closed/2456.v index 5294adefd..e5a392c4d 100644 --- a/test-suite/bugs/opened/2456.v +++ b/test-suite/bugs/closed/2456.v @@ -50,4 +50,9 @@ Fail dependent destruction commute1; dependent destruction catchCommuteDetails; dependent destruction commute2; dependent destruction catchCommuteDetails generalizing X. -Admitted. +revert X. +dependent destruction commute1; +dependent destruction catchCommuteDetails; +dependent destruction commute2; +dependent destruction catchCommuteDetails. +Abort. diff --git a/test-suite/bugs/opened/2814.v b/test-suite/bugs/closed/2814.v index a740b4384..99da1e3e4 100644 --- a/test-suite/bugs/opened/2814.v +++ b/test-suite/bugs/closed/2814.v @@ -3,3 +3,4 @@ Require Import Program. Goal forall (x : Type) (f g : Type -> Type) (H : f x ~= g x), False. intros. Fail induction H. +Abort. diff --git a/test-suite/bugs/closed/2969.v b/test-suite/bugs/closed/2969.v index a03adbd73..7b1a26178 100644 --- a/test-suite/bugs/closed/2969.v +++ b/test-suite/bugs/closed/2969.v @@ -12,6 +12,7 @@ eexists. reflexivity. Grab Existential Variables. admit. +Admitted. (* Alternative variant which failed but without raising anomaly *) @@ -24,3 +25,4 @@ clearbody n n0. exact I. Grab Existential Variables. admit. +Admitted. diff --git a/test-suite/bugs/opened/3100.v b/test-suite/bugs/closed/3100.v index 6f35a74dc..6f35a74dc 100644 --- a/test-suite/bugs/opened/3100.v +++ b/test-suite/bugs/closed/3100.v diff --git a/test-suite/bugs/opened/3230.v b/test-suite/bugs/closed/3230.v index 265310b1a..265310b1a 100644 --- a/test-suite/bugs/opened/3230.v +++ b/test-suite/bugs/closed/3230.v diff --git a/test-suite/bugs/opened/3320.v b/test-suite/bugs/closed/3320.v index 05cf73281..a5c243d8e 100644 --- a/test-suite/bugs/opened/3320.v +++ b/test-suite/bugs/closed/3320.v @@ -1,4 +1,5 @@ Goal forall x : nat, True. - fix 1. + fix goal 1. assumption. Fail Qed. +Undo. diff --git a/test-suite/bugs/closed/3350.v b/test-suite/bugs/closed/3350.v index c041c401f..c1ff292b3 100644 --- a/test-suite/bugs/closed/3350.v +++ b/test-suite/bugs/closed/3350.v @@ -55,7 +55,7 @@ Lemma lower_ind (P: forall n (p i:Fin.t (S n)), option (Fin.t n) -> Prop) P (S n) (Fin.FS p) (Fin.FS i) None) : forall n (p i:Fin.t (S n)), P n p i (lower p i). Proof. - fix 2. intros n p. + fix lower_ind 2. intros n p. refine (match p as p1 in Fin.t (S n1) return forall (i1:Fin.t (S n1)), P n1 p1 i1 (lower p1 i1) with diff --git a/test-suite/bugs/closed/3377.v b/test-suite/bugs/closed/3377.v index 8e9e3933c..abfcf1d35 100644 --- a/test-suite/bugs/closed/3377.v +++ b/test-suite/bugs/closed/3377.v @@ -5,6 +5,7 @@ Record prod A B := pair { fst : A; snd : B}. Goal fst (@pair Type Type Type Type). Set Printing All. match goal with |- ?f ?x => set (foo := f x) end. +Abort. Goal forall x : prod Set Set, x = @pair _ _ (fst x) (snd x). Proof. @@ -12,6 +13,6 @@ Proof. lazymatch goal with | [ |- ?x = @pair _ _ (?f ?x) (?g ?x) ] => pose f end. - (* Toplevel input, characters 7-44: Error: No matching clauses for match. *) +Abort. diff --git a/test-suite/bugs/closed/4069.v b/test-suite/bugs/closed/4069.v index 606c6e084..668f6bb42 100644 --- a/test-suite/bugs/closed/4069.v +++ b/test-suite/bugs/closed/4069.v @@ -41,6 +41,8 @@ Proof. f_equal. 8.5: 2 goals, skipn n l = l -> k ++ skipn n l = skipn n l and skipn n l = l *) +Abort. + Require Import List. Fixpoint replicate {A} (n : nat) (x : A) : list A := match n with 0 => nil | S n => x :: replicate n x end. diff --git a/test-suite/bugs/closed/4198.v b/test-suite/bugs/closed/4198.v index eb37141bc..28800ac05 100644 --- a/test-suite/bugs/closed/4198.v +++ b/test-suite/bugs/closed/4198.v @@ -13,6 +13,7 @@ Goal forall A (x x' : A) (xs xs' : list A) (H : x::xs = x'::xs'), match goal with | [ |- context G[@hd] ] => idtac end. +Abort. (* This second example comes from CFGV where inspecting subterms of a match is expecting to inspect first the term to match (even though @@ -35,3 +36,4 @@ Ltac mydestruct := Goal forall x, match x with 0 => 0 | _ => 0 end = 0. intros. mydestruct. +Abort. diff --git a/test-suite/bugs/closed/4403.v b/test-suite/bugs/closed/4403.v new file mode 100644 index 000000000..a80f38fe2 --- /dev/null +++ b/test-suite/bugs/closed/4403.v @@ -0,0 +1,3 @@ +(* -*- coq-prog-args: ("-type-in-type"); -*- *) + +Definition some_prop : Prop := Type. diff --git a/test-suite/bugs/closed/4722.v b/test-suite/bugs/closed/4722.v deleted file mode 100644 index 2d41828f1..000000000 --- a/test-suite/bugs/closed/4722.v +++ /dev/null @@ -1 +0,0 @@ -(* -*- coq-prog-args: ("-R" "4722" "Foo") -*- *) diff --git a/test-suite/bugs/closed/4722/tata b/test-suite/bugs/closed/4722/tata deleted file mode 120000 index b38e66e75..000000000 --- a/test-suite/bugs/closed/4722/tata +++ /dev/null @@ -1 +0,0 @@ -toto
\ No newline at end of file diff --git a/test-suite/bugs/closed/4782.v b/test-suite/bugs/closed/4782.v index dbd71035d..1e1a4cb9c 100644 --- a/test-suite/bugs/closed/4782.v +++ b/test-suite/bugs/closed/4782.v @@ -6,6 +6,7 @@ Inductive p : Prop := consp : forall (e : r) (x : type e), cond e x -> p. Goal p. Fail apply consp with (fun _ : bool => mk_r unit (fun x => True)) nil. +Abort. (* A simplification of an example from coquelicot, which was failing at some time after a fix #4782 was committed. *) @@ -21,4 +22,5 @@ Set Typeclasses Debug. Goal forall (A:T) (x:dom A), pairT A A = pairT A A. intros. apply (F _ _) with (x,x). +Abort. diff --git a/test-suite/bugs/closed/4882.v b/test-suite/bugs/closed/4882.v deleted file mode 100644 index 8c26af708..000000000 --- a/test-suite/bugs/closed/4882.v +++ /dev/null @@ -1,50 +0,0 @@ - -Definition Foo {T}{a : T} : T := a. - -Module A. - - Declare Implicit Tactic eauto. - - Goal forall A (x : A), A. - intros. - apply Foo. (* Check defined evars are normalized *) - (* Qed. *) - Abort. - -End A. - -Module B. - - Definition Foo {T}{a : T} : T := a. - - Declare Implicit Tactic eassumption. - - Goal forall A (x : A), A. - intros. - apply Foo. - (* Qed. *) - Abort. - -End B. - -Module C. - - Declare Implicit Tactic first [exact True|assumption]. - - Goal forall (x : True), True. - intros. - apply (@Foo _ _). - Qed. - -End C. - -Module D. - - Declare Implicit Tactic assumption. - - Goal forall A (x : A), A. - intros. - exact _. - Qed. - -End D. diff --git a/test-suite/bugs/closed/5500.v b/test-suite/bugs/closed/5500.v new file mode 100644 index 000000000..aa63e2ab0 --- /dev/null +++ b/test-suite/bugs/closed/5500.v @@ -0,0 +1,35 @@ +(* Too weak check on the correctness of return clause was leading to an anomaly *) + +Inductive Vector A: nat -> Type := + nil: Vector A O +| cons: forall n, A -> Vector A n -> Vector A (S n). + +(* This could be made working with a better inference of inner return + predicates from the return predicate at the higher level of the + nested matching. Currently, we only check that it does not raise an + anomaly, but eventually, the "Fail" could be removed. *) + +Fail Definition hd_fst A x n (v: A * Vector A (S n)) := + match v as v0 return match v0 with + (l, r) => + match r in Vector _ n return match n with 0 => Type | S _ => Type end with + nil _ => A + | cons _ _ _ _ => A + end + end with + (_, nil _) => x + | (_, cons _ n hd tl) => hd + end. + +(* This is another example of failure but involving beta-reduction and + not iota-reduction. Thus, for this one, I don't see how it could be + solved by small inversion, whatever smart is small inversion. *) + +Inductive A : (Type->Type) -> Type := J : A (fun x => x). + +Fail Check fun x : nat * A (fun x => x) => + match x return match x with + (y,z) => match z in A f return f Type with J => bool end + end with + (y,J) => true + end. diff --git a/test-suite/bugs/closed/5539.v b/test-suite/bugs/closed/5539.v new file mode 100644 index 000000000..48e5568e9 --- /dev/null +++ b/test-suite/bugs/closed/5539.v @@ -0,0 +1,15 @@ +Set Universe Polymorphism. + +Inductive D : nat -> Type := +| DO : D O +| DS n : D n -> D (S n). + +Fixpoint follow (n : nat) : D n -> Prop := + match n with + | O => fun d => let 'DO := d in True + | S n' => fun d => (let 'DS _ d' := d in fun f => f d') (follow n') + end. + +Definition step (n : nat) (d : D n) (H : follow n d) : + follow (S n) (DS n d) + := H. diff --git a/test-suite/bugs/closed/5547.v b/test-suite/bugs/closed/5547.v new file mode 100644 index 000000000..79633f489 --- /dev/null +++ b/test-suite/bugs/closed/5547.v @@ -0,0 +1,16 @@ +(* Checking typability of intermediate return predicates in nested pattern-matching *) + +Inductive A : (Type->Type) -> Type := J : A (fun x => x). +Definition ret (x : nat * A (fun x => x)) + := match x return Type with + | (y,z) => match z in A f return f Type with + | J => bool + end + end. +Definition foo : forall x, ret x. +Proof. +Fail refine (fun x + => match x return ret x with + | (y,J) => true + end + ). diff --git a/test-suite/bugs/closed/6770.v b/test-suite/bugs/closed/6770.v new file mode 100644 index 000000000..9bcc74083 --- /dev/null +++ b/test-suite/bugs/closed/6770.v @@ -0,0 +1,7 @@ +Section visibility. + + Let Fixpoint by_proof (n:nat) : True. + Proof. exact I. Defined. +End visibility. + +Fail Check by_proof. diff --git a/test-suite/bugs/closed/6951.v b/test-suite/bugs/closed/6951.v new file mode 100644 index 000000000..419f8d7c4 --- /dev/null +++ b/test-suite/bugs/closed/6951.v @@ -0,0 +1,2 @@ +Record float2 : Set := Float2 { Fnum : unit }. +Scheme Equality for float2. diff --git a/test-suite/bugs/closed/6956.v b/test-suite/bugs/closed/6956.v new file mode 100644 index 000000000..ee21adbbf --- /dev/null +++ b/test-suite/bugs/closed/6956.v @@ -0,0 +1,13 @@ +(** Used to trigger an anomaly with VM compilation *) + +Set Universe Polymorphism. + +Inductive t A : nat -> Type := +| nil : t A 0 +| cons : forall (h : A) (n : nat), t A n -> t A (S n). + +Definition case0 {A} (P : t A 0 -> Type) (H : P (nil A)) v : P v := +match v with +| nil _ => H +| _ => fun devil => False_ind (@IDProp) devil +end. diff --git a/test-suite/bugs/closed/7011.v b/test-suite/bugs/closed/7011.v new file mode 100644 index 000000000..296e4e11e --- /dev/null +++ b/test-suite/bugs/closed/7011.v @@ -0,0 +1,16 @@ +(* Fix and Cofix were missing in tactic unification *) + +Goal exists e, (fix foo (n : nat) : nat := match n with O => e | S n' => foo n' end) + = (fix foo (n : nat) : nat := match n with O => O | S n' => foo n' end). +Proof. + eexists. + reflexivity. +Qed. + +CoInductive stream := cons : nat -> stream -> stream. + +Goal exists e, (cofix foo := cons e foo) = (cofix foo := cons 0 foo). +Proof. + eexists. + reflexivity. +Qed. diff --git a/test-suite/bugs/closed/7068.v b/test-suite/bugs/closed/7068.v new file mode 100644 index 000000000..9fadb195b --- /dev/null +++ b/test-suite/bugs/closed/7068.v @@ -0,0 +1,6 @@ +(* These tests are only about a subset of #7068 *) +(* The original issue is still open *) + +Inductive foo : let T := Type in T := . +Definition bob1 := Eval vm_compute in foo_rect. +Definition bob2 := Eval native_compute in foo_rect. diff --git a/test-suite/bugs/closed/7076.v b/test-suite/bugs/closed/7076.v new file mode 100644 index 000000000..0abc88c28 --- /dev/null +++ b/test-suite/bugs/closed/7076.v @@ -0,0 +1,4 @@ +(* These calls were raising an anomaly at some time *) +Inductive A : nat -> id (nat->Type) := . +Eval vm_compute in fun x => match x in A y z return y = z with end. +Eval native_compute in fun x => match x in A y z return y = z with end. diff --git a/test-suite/bugs/closed/7113.v b/test-suite/bugs/closed/7113.v new file mode 100644 index 000000000..976e60f20 --- /dev/null +++ b/test-suite/bugs/closed/7113.v @@ -0,0 +1,10 @@ +Require Import Program.Tactics. +Section visibility. + + (* used to anomaly *) + Program Let Fixpoint ev' (n : nat) : bool := _. + Next Obligation. exact true. Qed. + + Check ev'. +End visibility. +Fail Check ev'. diff --git a/test-suite/bugs/closed/7195.v b/test-suite/bugs/closed/7195.v new file mode 100644 index 000000000..ea97747ac --- /dev/null +++ b/test-suite/bugs/closed/7195.v @@ -0,0 +1,12 @@ +(* A disjoint-names condition was missing when matching names in Ltac + pattern-matching *) + +Goal True. + let x := (eval cbv beta zeta in (fun P => let Q := P in fun P => P + Q)) in + unify x (fun a b => b + a); (* success *) + let x' := lazymatch x with + | (fun (a : ?A) (b : ?B) => ?k) + => constr:(fun (a : A) (b : B) => k) + end in + unify x x'. +Abort. diff --git a/test-suite/bugs/closed/7392.v b/test-suite/bugs/closed/7392.v new file mode 100644 index 000000000..cf465c658 --- /dev/null +++ b/test-suite/bugs/closed/7392.v @@ -0,0 +1,9 @@ +Inductive R : nat -> Prop := ER : forall n, R n -> R (S n). + +Goal (forall (n : nat), R n -> False) -> True -> False. +Proof. +intros H0 H1. +eapply H0. +clear H1. +apply ER. +simpl. diff --git a/test-suite/bugs/closed/7462.v b/test-suite/bugs/closed/7462.v new file mode 100644 index 000000000..40ca39e38 --- /dev/null +++ b/test-suite/bugs/closed/7462.v @@ -0,0 +1,13 @@ +(* Adding an only-printing notation should not override existing + interpretations for the same notation. *) + +Notation "$ x" := (@id nat x) (only parsing, at level 0). +Notation "$ x" := (@id bool x) (only printing, at level 0). +Check $1. (* Was: Error: Unknown interpretation for notation "$ _". *) + +(* Adding an only-printing notation should not let believe + that a parsing rule has been given *) + +Notation "$ x" := (@id bool x) (only printing, at level 0). +Notation "$ x" := (@id nat x) (only parsing, at level 0). +Check $1. (* Was: Error: Syntax Error: Lexer: Undefined token *) diff --git a/test-suite/bugs/closed/7554.v b/test-suite/bugs/closed/7554.v new file mode 100644 index 000000000..12b0aa2cb --- /dev/null +++ b/test-suite/bugs/closed/7554.v @@ -0,0 +1,12 @@ +Require Import Coq.Program.Tactics. + +(* these should not result in anomalies *) + +Fail Program Lemma foo: + forall P, forall H, forall (n:nat), P n. + +Fail Program Lemma foo: + forall a (P : list a -> Prop), forall H, forall (n:list a), P n. + +Fail Program Lemma foo: + forall (a : Type) (P : list a -> Prop), forall H, forall (n:list a), P n. diff --git a/test-suite/bugs/closed/7631.v b/test-suite/bugs/closed/7631.v new file mode 100644 index 000000000..34eb8b867 --- /dev/null +++ b/test-suite/bugs/closed/7631.v @@ -0,0 +1,21 @@ +Module NamedContext. + +Definition foo := true. + +Section Foo. + +Let bar := foo. + +Eval native_compute in bar. + +End Foo. + +End NamedContext. + +Module RelContext. + +Definition foo := true. + +Definition bar (x := foo) := Eval native_compute in x. + +End RelContext. diff --git a/test-suite/bugs/closed/7700.v b/test-suite/bugs/closed/7700.v new file mode 100644 index 000000000..56f5481ba --- /dev/null +++ b/test-suite/bugs/closed/7700.v @@ -0,0 +1,9 @@ +(* Abbreviations to section variables were not located *) +Section foo. + Let x := Set. + Notation y := x. + Check y. + Variable x' : Set. + Notation y' := x'. + Check y'. +End foo. diff --git a/test-suite/bugs/closed/7779.v b/test-suite/bugs/closed/7779.v new file mode 100644 index 000000000..78936b595 --- /dev/null +++ b/test-suite/bugs/closed/7779.v @@ -0,0 +1,15 @@ +(* Checking that the "in" clause takes the "eqn" clause into account *) + +Definition test (x: nat): {y: nat | False }. Admitted. + +Parameter x: nat. +Parameter z: nat. + +Goal + proj1_sig (test x) = z -> + False. +Proof. + intro H. + destruct (test x) eqn:Heqs in H. + change (test x = exist (fun _ : nat => False) x0 f) in Heqs. (* Check it has the expected statement *) +Abort. diff --git a/test-suite/bugs/closed/7780.v b/test-suite/bugs/closed/7780.v new file mode 100644 index 000000000..2318f4d6e --- /dev/null +++ b/test-suite/bugs/closed/7780.v @@ -0,0 +1,16 @@ +(* A lift was missing in expanding aliases under binders for unification *) + +(* Below, the lift was missing while expanding the reference to + [mkcons] in [?N] which was under binder [arg] *) + +Goal forall T (t : T) (P P0 : T -> Set), option (option (list (P0 t)) -> option (list (P t))). + intros ????. + refine (Some + (fun rls + => let mkcons := ?[M] in + let default arg := ?[N] in + match rls as rls (* 2 *) return option (list (P ?[O])) with + | Some _ => None + | None => None + end)). +Abort. diff --git a/test-suite/bugs/opened/3209.v b/test-suite/bugs/opened/3209.v deleted file mode 100644 index 3203afa13..000000000 --- a/test-suite/bugs/opened/3209.v +++ /dev/null @@ -1,17 +0,0 @@ -Inductive eqT {A} (x : A) : A -> Type := - reflT : eqT x x. -Definition Bi_inv (A B : Type) (f : (A -> B)) := - sigT (fun (g : B -> A) => - sigT (fun (h : B -> A) => - sigT (fun (α : forall b : B, eqT (f (g b)) b) => - forall a : A, eqT (h (f a)) a))). -Definition TEquiv (A B : Type) := sigT (fun (f : A -> B) => Bi_inv _ _ f). - -Axiom UA : forall (A B : Type), TEquiv (TEquiv A B) (eqT A B). -Definition idtoeqv {A B} (e : eqT A B) : TEquiv A B := - sigT_rect (fun _ => TEquiv A B) - (fun (f : TEquiv A B -> eqT A B) H => - sigT_rect (fun _ => TEquiv A B) - (fun g _ => g e) - H) - (UA A B). diff --git a/test-suite/bugs/opened/3263.v b/test-suite/bugs/opened/3263.v deleted file mode 100644 index f0c707bd1..000000000 --- a/test-suite/bugs/opened/3263.v +++ /dev/null @@ -1,232 +0,0 @@ -Require Import TestSuite.admit. -(* File reduced by coq-bug-finder from originally 10918 lines, then 3649 lines to 3177 lines, then from 3189 lines to 3164 lines, then from 2653 lines to 2496 lines, 2653 lines, then from 1642 lines to 651 lines, then from 736 lines to 473 lines, then from 433 lines to 275 lines, then from 258 lines to 235 lines. *) -Generalizable All Variables. -Set Implicit Arguments. - -Arguments fst {_ _} _. -Arguments snd {_ _} _. - -Axiom cheat : forall {T}, T. - -Reserved Notation "g 'o' f" (at level 40, left associativity). - -Inductive paths {A : Type} (a : A) : A -> Type := idpath : paths a a. -Arguments idpath {A a} , [A] a. -Notation "x = y" := (paths x y) : type_scope. - -Definition symmetry {A : Type} {x y : A} (p : x = y) : y = x - := match p with idpath => idpath end. - -Delimit Scope morphism_scope with morphism. -Delimit Scope category_scope with category. -Delimit Scope object_scope with object. -Record PreCategory (object : Type) := - Build_PreCategory' { - object :> Type := object; - morphism : object -> object -> Type; - identity : forall x, morphism x x; - compose : forall s d d', - morphism d d' - -> morphism s d - -> morphism s d' - where "f 'o' g" := (compose f g); - associativity : forall x1 x2 x3 x4 - (m1 : morphism x1 x2) - (m2 : morphism x2 x3) - (m3 : morphism x3 x4), - (m3 o m2) o m1 = m3 o (m2 o m1); - associativity_sym : forall x1 x2 x3 x4 - (m1 : morphism x1 x2) - (m2 : morphism x2 x3) - (m3 : morphism x3 x4), - m3 o (m2 o m1) = (m3 o m2) o m1; - left_identity : forall a b (f : morphism a b), identity b o f = f; - right_identity : forall a b (f : morphism a b), f o identity a = f; - identity_identity : forall x, identity x o identity x = identity x - }. -Bind Scope category_scope with PreCategory. -Arguments PreCategory {_}. -Arguments identity {_} [!C%category] x%object : rename. - -Arguments compose {_} [!C%category s%object d%object d'%object] m1%morphism m2%morphism : rename. - -Infix "o" := compose : morphism_scope. - -Delimit Scope functor_scope with functor. -Local Open Scope morphism_scope. -Record Functor `(C : @PreCategory objC, D : @PreCategory objD) := - { - object_of :> C -> D; - morphism_of : forall s d, morphism C s d - -> morphism D (object_of s) (object_of d); - composition_of : forall s d d' - (m1 : morphism C s d) (m2: morphism C d d'), - morphism_of _ _ (m2 o m1) - = (morphism_of _ _ m2) o (morphism_of _ _ m1); - identity_of : forall x, morphism_of _ _ (identity x) - = identity (object_of x) - }. -Bind Scope functor_scope with Functor. - -Arguments morphism_of {_} [C%category] {_} [D%category] F%functor [s%object d%object] m%morphism : rename, simpl nomatch. - -Notation "F '_1' m" := (morphism_of F m) (at level 10, no associativity) : morphism_scope. - -Class IsIsomorphism `{C : @PreCategory objC} {s d} (m : morphism C s d) := - { - morphism_inverse : morphism C d s; - left_inverse : morphism_inverse o m = identity _; - right_inverse : m o morphism_inverse = identity _ - }. - -Definition opposite `(C : @PreCategory objC) : PreCategory - := @Build_PreCategory' - C - (fun s d => morphism C d s) - (identity (C := C)) - (fun _ _ _ m1 m2 => m2 o m1) - (fun _ _ _ _ _ _ _ => @associativity_sym _ _ _ _ _ _ _ _ _) - (fun _ _ _ _ _ _ _ => @associativity _ _ _ _ _ _ _ _ _) - (fun _ _ => @right_identity _ _ _ _) - (fun _ _ => @left_identity _ _ _ _) - (@identity_identity _ C). - -Notation "C ^op" := (opposite C) (at level 3) : category_scope. - -Definition prod `(C : @PreCategory objC, D : @PreCategory objD) : @PreCategory (objC * objD). - refine (@Build_PreCategory' - (C * D)%type - (fun s d => (morphism C (fst s) (fst d) - * morphism D (snd s) (snd d))%type) - (fun x => (identity (fst x), identity (snd x))) - (fun s d d' m2 m1 => (fst m2 o fst m1, snd m2 o snd m1)) - _ - _ - _ - _ - _); admit. -Defined. -Infix "*" := prod : category_scope. - -Definition compose_functor `(C : @PreCategory objC, D : @PreCategory objD, E : @PreCategory objE) (G : Functor D E) (F : Functor C D) : Functor C E - := Build_Functor - C E - (fun c => G (F c)) - (fun _ _ m => morphism_of G (morphism_of F m)) - cheat - cheat. - -Infix "o" := compose_functor : functor_scope. - -Record NaturalTransformation `(C : @PreCategory objC, D : @PreCategory objD) (F G : Functor C D) := - Build_NaturalTransformation' { - components_of :> forall c, morphism D (F c) (G c); - commutes : forall s d (m : morphism C s d), - components_of d o F _1 m = G _1 m o components_of s; - - commutes_sym : forall s d (m : C.(morphism) s d), - G _1 m o components_of s = components_of d o F _1 m - }. -Definition functor_category `(C : @PreCategory objC, D : @PreCategory objD) : PreCategory - := @Build_PreCategory' (Functor C D) - (@NaturalTransformation _ C _ D) - cheat - cheat - cheat - cheat - cheat - cheat - cheat. - -Definition opposite_functor `(F : @Functor objC C objD D) : Functor C^op D^op - := Build_Functor (C^op) (D^op) - (object_of F) - (fun s d => morphism_of F (s := d) (d := s)) - (fun d' d s m1 m2 => composition_of F s d d' m2 m1) - (identity_of F). - -Definition opposite_invL `(F : @Functor objC C^op objD D) : Functor C D^op - := Build_Functor C (D^op) - (object_of F) - (fun s d => morphism_of F (s := d) (d := s)) - (fun d' d s m1 m2 => composition_of F s d d' m2 m1) - (identity_of F). -Notation "F ^op" := (opposite_functor F) : functor_scope. - -Notation "F ^op'L" := (opposite_invL F) (at level 3) : functor_scope. -Definition fst `{C : @PreCategory objC, D : @PreCategory objD} : Functor (C * D) C - := Build_Functor (C * D) C - (@fst _ _) - (fun _ _ => @fst _ _) - (fun _ _ _ _ _ => idpath) - (fun _ => idpath). - -Definition snd `{C : @PreCategory objC, D : @PreCategory objD} : Functor (C * D) D - := Build_Functor (C * D) D - (@snd _ _) - (fun _ _ => @snd _ _) - (fun _ _ _ _ _ => idpath) - (fun _ => idpath). -Definition prod_functor `(F : @Functor objC C objD D, F' : @Functor objC C objD' D') -: Functor C (D * D') - := Build_Functor - C (D * D') - (fun c => (F c, F' c)) - (fun s d m => (F _1 m, F' _1 m))%morphism - cheat - cheat. -Definition pair `(F : @Functor objC C objD D, F' : @Functor objC' C' objD' D') : Functor (C * C') (D * D') - := (prod_functor (F o fst) (F' o snd))%functor. -Notation cat_of obj := - (@Build_PreCategory' obj - (fun x y => forall _ : x, y) - (fun _ x => x) - (fun _ _ _ f g x => f (g x))%core - (fun _ _ _ _ _ _ _ => idpath) - (fun _ _ _ _ _ _ _ => idpath) - (fun _ _ _ => idpath) - (fun _ _ _ => idpath) - (fun _ => idpath)). - -Definition hom_functor `(C : @PreCategory objC) : Functor (C^op * C) (cat_of Type) - := Build_Functor _ _ cheat cheat cheat cheat. - -Definition induced_hom_natural_transformation `(F : @Functor objC C objD D) -: NaturalTransformation (hom_functor C) (hom_functor D o pair F^op F) - := Build_NaturalTransformation' _ _ cheat cheat cheat. - -Class IsFullyFaithful `(F : @Functor objC C objD D) - := is_fully_faithful - : forall x y : C, - IsIsomorphism (induced_hom_natural_transformation F (x, y)). - -Definition coyoneda `(A : @PreCategory objA) : Functor A^op (@functor_category _ A _ (cat_of Type)) - := cheat. - -Definition yoneda `(A : @PreCategory objA) : Functor A (@functor_category _ A^op _ (cat_of Type)) - := (((coyoneda A^op)^op'L)^op'L)%functor. -Definition coyoneda_embedding `(A : @PreCategory objA) : @IsFullyFaithful _ _ _ _ (@coyoneda _ A). -Admitted. - -Definition yoneda_embedding_fast `(A : @PreCategory objA) : @IsFullyFaithful _ _ _ _ (@yoneda _ A). -Proof. - intros a b. - pose proof (coyoneda_embedding A^op a b) as CYE. - unfold yoneda. - Time let t := (type of CYE) in - let t' := (eval simpl in t) in pose proof ((fun (x : t) => (x : t')) CYE) as CYE'. (* Finished transaction in 0. secs (0.216013u,0.004s) *) - Fail Timeout 1 let t := match goal with |- ?G => constr:(G) end in - let t' := (eval simpl in t) in exact ((fun (x : t') => (x : t)) CYE'). - Time let t := match goal with |- ?G => constr:(G) end in - let t' := (eval simpl in t) in exact ((fun (x : t') => (x : t)) CYE'). (* Finished transaction in 0. secs (0.248016u,0.s) *) -Fail Timeout 2 Defined. -Time Defined. (* Finished transaction in 1. secs (0.432027u,0.s) *) - -Definition yoneda_embedding `(A : @PreCategory objA) : @IsFullyFaithful _ _ _ _ (@yoneda _ A). -Proof. - intros a b. - pose proof (coyoneda_embedding A^op a b) as CYE. - unfold yoneda; simpl in *. - Fail Timeout 1 exact CYE. - Time exact CYE. (* Finished transaction in 0. secs (0.012001u,0.s) *) -Fail Timeout 60 Defined. (* Timeout! *) diff --git a/test-suite/bugs/opened/3916.v b/test-suite/bugs/opened/3916.v deleted file mode 100644 index fd95503e6..000000000 --- a/test-suite/bugs/opened/3916.v +++ /dev/null @@ -1,3 +0,0 @@ -Require Import List. - -Fail Hint Resolve -> in_map. (* Also happens when using <- instead of -> *) diff --git a/test-suite/bugs/opened/3948.v b/test-suite/bugs/opened/3948.v deleted file mode 100644 index 5c4b4277b..000000000 --- a/test-suite/bugs/opened/3948.v +++ /dev/null @@ -1,25 +0,0 @@ -Module Type S. -Parameter t : Type. -End S. - -Module Bar(X : S). -Proof. - Definition elt := X.t. - Axiom fold : elt. -End Bar. - -Module Make (X: S) := Bar(X). - -Declare Module X : S. - -Module Type Interface. - Parameter constant : unit. -End Interface. - -Module DepMap : Interface. - Module Dom := Make(X). - Definition constant : unit := - let _ := @Dom.fold in tt. -End DepMap. - -Print Assumptions DepMap.constant. diff --git a/test-suite/bugs/opened/4813.v b/test-suite/bugs/opened/4813.v index b75170179..2ac553593 100644 --- a/test-suite/bugs/opened/4813.v +++ b/test-suite/bugs/opened/4813.v @@ -1,5 +1,5 @@ -(* An example one would like to see succeeding *) +Require Import Program.Tactics. Record T := BT { t : Set }. Record U (x : T) := BU { u : t x -> Prop }. -Fail Definition A (H : unit -> Prop) : U (BT unit) := BU _ H. +Program Definition A (H : unit -> Prop) : U (BT unit) := BU _ H. diff --git a/test-suite/check b/test-suite/check deleted file mode 100755 index 3d14f6bc0..000000000 --- a/test-suite/check +++ /dev/null @@ -1,7 +0,0 @@ -#!/bin/sh - -MAKE="${MAKE:=make}" - -${MAKE} clean > /dev/null 2>&1 -${MAKE} all > /dev/null 2>&1 -cat summary.log diff --git a/test-suite/coq-makefile/coqdoc1/run.sh b/test-suite/coq-makefile/coqdoc1/run.sh index dc5a500db..88237815b 100755 --- a/test-suite/coq-makefile/coqdoc1/run.sh +++ b/test-suite/coq-makefile/coqdoc1/run.sh @@ -9,7 +9,15 @@ make html mlihtml make install DSTROOT="$PWD/tmp" make install-doc DSTROOT="$PWD/tmp" #make debug -(for d in `find tmp -name user-contrib` ; do pushd $d >/dev/null && find . && popd >/dev/null; done) | sort -u > actual + +# to learn about <(cmd) see https://www.gnu.org/software/bash/manual/html_node/Process-Substitution.html +( + while IFS= read -r -d '' d + do + pushd "$d" >/dev/null && find . && popd >/dev/null + done < <(find tmp -name user-contrib -print0) +) | sort -u > actual + sort -u > desired <<EOT . ./test diff --git a/test-suite/coq-makefile/coqdoc2/run.sh b/test-suite/coq-makefile/coqdoc2/run.sh index dc5a500db..5811dd17e 100755 --- a/test-suite/coq-makefile/coqdoc2/run.sh +++ b/test-suite/coq-makefile/coqdoc2/run.sh @@ -9,7 +9,13 @@ make html mlihtml make install DSTROOT="$PWD/tmp" make install-doc DSTROOT="$PWD/tmp" #make debug -(for d in `find tmp -name user-contrib` ; do pushd $d >/dev/null && find . && popd >/dev/null; done) | sort -u > actual +( + while IFS= read -r -d '' d + do + pushd "$d" >/dev/null && find . && popd >/dev/null + done < <(find tmp -name user-contrib -print0) +) | sort -u > actual + sort -u > desired <<EOT . ./test diff --git a/test-suite/coq-makefile/findlib-package/run.sh b/test-suite/coq-makefile/findlib-package/run.sh index 5b24df639..5cab400cc 100755 --- a/test-suite/coq-makefile/findlib-package/run.sh +++ b/test-suite/coq-makefile/findlib-package/run.sh @@ -7,7 +7,8 @@ export OCAMLPATH=$OCAMLPATH:$PWD/findlib if which cygpath 2>/dev/null; then # the only way I found to pass OCAMLPATH on win is to have it contain # only one entry - export OCAMLPATH=`cygpath -w $PWD/findlib` + OCAMLPATH=$(cygpath -w "$PWD"/findlib) + export OCAMLPATH fi make -C findlib/foo clean coq_makefile -f _CoqProject -o Makefile diff --git a/test-suite/coq-makefile/mlpack1/run.sh b/test-suite/coq-makefile/mlpack1/run.sh index 03df9cf05..bbd2fc460 100755 --- a/test-suite/coq-makefile/mlpack1/run.sh +++ b/test-suite/coq-makefile/mlpack1/run.sh @@ -8,7 +8,7 @@ make make html mlihtml make install DSTROOT="$PWD/tmp" #make debug -(cd `find tmp -name user-contrib` && find .) | sort > actual +(cd "$(find tmp -name user-contrib)" && find .) | sort > actual sort > desired <<EOT . ./test diff --git a/test-suite/coq-makefile/mlpack2/run.sh b/test-suite/coq-makefile/mlpack2/run.sh index 03df9cf05..bbd2fc460 100755 --- a/test-suite/coq-makefile/mlpack2/run.sh +++ b/test-suite/coq-makefile/mlpack2/run.sh @@ -8,7 +8,7 @@ make make html mlihtml make install DSTROOT="$PWD/tmp" #make debug -(cd `find tmp -name user-contrib` && find .) | sort > actual +(cd "$(find tmp -name user-contrib)" && find .) | sort > actual sort > desired <<EOT . ./test diff --git a/test-suite/coq-makefile/multiroot/run.sh b/test-suite/coq-makefile/multiroot/run.sh index d3bb53106..45bf1481d 100755 --- a/test-suite/coq-makefile/multiroot/run.sh +++ b/test-suite/coq-makefile/multiroot/run.sh @@ -11,7 +11,12 @@ make html mlihtml make install DSTROOT="$PWD/tmp" make install-doc DSTROOT="$PWD/tmp" #make debug -(for d in `find tmp -name user-contrib` ; do pushd $d >/dev/null && find . && popd >/dev/null; done) | sort -u > actual +( + while IFS= read -r -d '' d + do + pushd "$d" >/dev/null && find . && popd >/dev/null + done < <(find tmp -name user-contrib -print0) +) | sort -u > actual sort > desired <<EOT . ./test diff --git a/test-suite/coq-makefile/native1/run.sh b/test-suite/coq-makefile/native1/run.sh index 89bafe9ad..8f9ab9a71 100755 --- a/test-suite/coq-makefile/native1/run.sh +++ b/test-suite/coq-makefile/native1/run.sh @@ -1,17 +1,17 @@ #!/usr/bin/env bash -NATIVECOMP=`grep "let no_native_compiler = false" ../../../config/coq_config.ml`||true -if [[ `which ocamlopt` && $NATIVECOMP ]]; then +NATIVECOMP=$(grep "let no_native_compiler = false" ../../../config/coq_config.ml)||true +if [[ $(which ocamlopt) && $NATIVECOMP ]]; then . ../template/init.sh - + coq_makefile -f _CoqProject -o Makefile cat Makefile.conf make make html mlihtml make install DSTROOT="$PWD/tmp" #make debug -(cd `find tmp -name user-contrib` && find .) | sort > actual +(cd "$(find tmp -name user-contrib)" && find .) | sort > actual sort > desired <<EOT . ./test diff --git a/test-suite/coq-makefile/plugin1/run.sh b/test-suite/coq-makefile/plugin1/run.sh index 5433d9e92..1e2bd979b 100755 --- a/test-suite/coq-makefile/plugin1/run.sh +++ b/test-suite/coq-makefile/plugin1/run.sh @@ -9,7 +9,7 @@ make make html mlihtml make install DSTROOT="$PWD/tmp" #make debug -(cd `find tmp -name user-contrib` && find .) | sort > actual +(cd "$(find tmp -name user-contrib)" && find .) | sort > actual sort > desired <<EOT . ./test diff --git a/test-suite/coq-makefile/plugin2/run.sh b/test-suite/coq-makefile/plugin2/run.sh index 5433d9e92..1e2bd979b 100755 --- a/test-suite/coq-makefile/plugin2/run.sh +++ b/test-suite/coq-makefile/plugin2/run.sh @@ -9,7 +9,7 @@ make make html mlihtml make install DSTROOT="$PWD/tmp" #make debug -(cd `find tmp -name user-contrib` && find .) | sort > actual +(cd "$(find tmp -name user-contrib)" && find .) | sort > actual sort > desired <<EOT . ./test diff --git a/test-suite/coq-makefile/plugin3/run.sh b/test-suite/coq-makefile/plugin3/run.sh index 5433d9e92..1e2bd979b 100755 --- a/test-suite/coq-makefile/plugin3/run.sh +++ b/test-suite/coq-makefile/plugin3/run.sh @@ -9,7 +9,7 @@ make make html mlihtml make install DSTROOT="$PWD/tmp" #make debug -(cd `find tmp -name user-contrib` && find .) | sort > actual +(cd "$(find tmp -name user-contrib)" && find .) | sort > actual sort > desired <<EOT . ./test diff --git a/test-suite/coq-makefile/quick2vo/run.sh b/test-suite/coq-makefile/quick2vo/run.sh index 9e681223b..dda51dd2e 100755 --- a/test-suite/coq-makefile/quick2vo/run.sh +++ b/test-suite/coq-makefile/quick2vo/run.sh @@ -1,11 +1,11 @@ #!/usr/bin/env bash -a=`uname` +a=$(uname) . ../template/init.sh coq_makefile -f _CoqProject -o Makefile # vio2vo is broken on Windows (#6720) -if [ "$a" = "Darwin" -o "$a" = "Linux" ]; then +if [ "$a" = "Darwin" ] || [ "$a" = "Linux" ]; then make quick2vo J=2 test -f theories/test.vo make validate diff --git a/test-suite/coq-makefile/template/init.sh b/test-suite/coq-makefile/template/init.sh index e19d168cf..2e066d30d 100755 --- a/test-suite/coq-makefile/template/init.sh +++ b/test-suite/coq-makefile/template/init.sh @@ -1,10 +1,11 @@ +#!/bin/sh . ../template/path-init.sh rm -rf _test mkdir _test find . -maxdepth 1 -not -name . -not -name _test -exec cp -r '{}' -t _test ';' -cd _test +cd _test || exit 1 mkdir -p src mkdir -p theories/sub diff --git a/test-suite/coq-makefile/template/path-init.sh b/test-suite/coq-makefile/template/path-init.sh index dd19ab2b1..c79b56652 100755 --- a/test-suite/coq-makefile/template/path-init.sh +++ b/test-suite/coq-makefile/template/path-init.sh @@ -1,3 +1,4 @@ +#!/bin/sh set -e set -o pipefail diff --git a/test-suite/coq-makefile/timing/precomputed-time-tests/run.sh b/test-suite/coq-makefile/timing/precomputed-time-tests/run.sh index a918cceb6..9f3b648aa 100755 --- a/test-suite/coq-makefile/timing/precomputed-time-tests/run.sh +++ b/test-suite/coq-makefile/timing/precomputed-time-tests/run.sh @@ -4,7 +4,8 @@ set -x set -e cd "$(dirname "${BASH_SOURCE[0]}")" -export COQLIB="$(cd ../../../.. && pwd)" +COQLIB="$(cd ../../../.. && pwd)" +export COQLIB -./001-correct-diff-sorting-order/run.sh || exit $? -./002-single-file-sorting/run.sh || exit $? +./001-correct-diff-sorting-order/run.sh +./002-single-file-sorting/run.sh diff --git a/test-suite/coq-makefile/timing/run.sh b/test-suite/coq-makefile/timing/run.sh index 43c83e412..6737197ee 100755 --- a/test-suite/coq-makefile/timing/run.sh +++ b/test-suite/coq-makefile/timing/run.sh @@ -44,6 +44,7 @@ TO_SED_IN_BOTH=( -e s'/ *$//g' # the number of trailing spaces depends on how many digits percentages end up being; since this varies across runs, we remove trailing spaces -e s'/[0-9]*\.[0-9]*//g' # the precise timing numbers vary, so we strip them out -e s'/^-*$/------/g' # When none of the numbers get over 100 (or 1000, in per-file), the width of the table is different, so we normalize the number of dashes for table separators + -e s'/+/-/g' # some code lines don't really change, but this can show up as either -0m00.01s or +0m00.01s, so we need to normalize the signs; additionally, some N/A's show up where we expect to get -∞ on the per-line file, and so the ∞-replacement gets the sign wrong, so we must correct it ) TO_SED_IN_PER_FILE=( @@ -55,19 +56,16 @@ TO_SED_IN_PER_FILE=( TO_SED_IN_PER_LINE=( -e s'/0//g' # unclear whether this is actually needed above and beyond s'/[0-9]*\.[0-9]*//g'; it's been here from the start -e s'/ */ /g' # Sometimes 0 will show up as 0m00.s, sometimes it'll end up being more like 0m00.001s; we must strip out the spaces that result from left-aligning numbers of different widths based on how many digits Coq's [-time] gives - -e s'/+/-/g' # some code lines don't really change, but this can show up as either -0m00.01s or +0m00.01s, so we need to normalize the signs ) -for ext in "" .desired; do - for file in time-of-build-before.log time-of-build-after.log time-of-build-both.log; do - cat ${file}${ext} | grep -v 'warning: undefined variable' | sed "${TO_SED_IN_BOTH[@]}" "${TO_SED_IN_PER_FILE[@]}" > ${file}${ext}.processed - done -done for file in time-of-build-before.log time-of-build-after.log time-of-build-both.log; do - echo "cat $file" - cat "$file" - echo - diff -u $file.desired.processed $file.processed || exit $? + for ext in "" .desired; do + grep -v 'warning: undefined variable' < ${file}${ext} | sed "${TO_SED_IN_BOTH[@]}" "${TO_SED_IN_PER_FILE[@]}" > ${file}${ext}.processed + done + echo "cat $file" + cat "$file" + echo + diff -u $file.desired.processed $file.processed || exit $? done cd ../per-file-before @@ -92,13 +90,12 @@ echo "cat A.v.timing.diff" cat A.v.timing.diff echo +file=A.v.timing.diff + for ext in "" .desired; do - for file in A.v.timing.diff; do - cat ${file}${ext} | sed "${TO_SED_IN_BOTH[@]}" "${TO_SED_IN_PER_LINE[@]}" | sort > ${file}${ext}.processed - done -done -for file in A.v.timing.diff; do - diff -u $file.desired.processed $file.processed || exit $? + sed "${TO_SED_IN_BOTH[@]}" "${TO_SED_IN_PER_LINE[@]}" < "${file}${ext}" | sort > "${file}${ext}.processed" done +diff -u "$file.desired.processed" "$file.processed" || exit $? + exit 0 diff --git a/test-suite/coq-makefile/uninstall1/run.sh b/test-suite/coq-makefile/uninstall1/run.sh index 5354f794f..fc95d84b9 100755 --- a/test-suite/coq-makefile/uninstall1/run.sh +++ b/test-suite/coq-makefile/uninstall1/run.sh @@ -11,7 +11,12 @@ make install-doc DSTROOT="$PWD/tmp" make uninstall DSTROOT="$PWD/tmp" make uninstall-doc DSTROOT="$PWD/tmp" #make debug -(for d in `find tmp -name user-contrib` ; do pushd $d >/dev/null && find . && popd >/dev/null; done) | sort -u > actual +( + while IFS= read -r -d '' d + do + pushd "$d" >/dev/null && find . && popd >/dev/null + done < <(find tmp -name user-contrib -print0) +) | sort -u > actual sort -u > desired <<EOT . EOT diff --git a/test-suite/coq-makefile/uninstall2/run.sh b/test-suite/coq-makefile/uninstall2/run.sh index 5354f794f..fc95d84b9 100755 --- a/test-suite/coq-makefile/uninstall2/run.sh +++ b/test-suite/coq-makefile/uninstall2/run.sh @@ -11,7 +11,12 @@ make install-doc DSTROOT="$PWD/tmp" make uninstall DSTROOT="$PWD/tmp" make uninstall-doc DSTROOT="$PWD/tmp" #make debug -(for d in `find tmp -name user-contrib` ; do pushd $d >/dev/null && find . && popd >/dev/null; done) | sort -u > actual +( + while IFS= read -r -d '' d + do + pushd "$d" >/dev/null && find . && popd >/dev/null + done < <(find tmp -name user-contrib -print0) +) | sort -u > actual sort -u > desired <<EOT . EOT diff --git a/test-suite/coq-makefile/vio2vo/run.sh b/test-suite/coq-makefile/vio2vo/run.sh index 85656da41..e555d62f3 100755 --- a/test-suite/coq-makefile/vio2vo/run.sh +++ b/test-suite/coq-makefile/vio2vo/run.sh @@ -1,12 +1,12 @@ #!/usr/bin/env bash -a=`uname` +a=$(uname) . ../template/init.sh coq_makefile -f _CoqProject -o Makefile make quick # vio2vo is broken on Windows (#6720) -if [ "$a" = "Darwin" -o "$a" = "Linux" ]; then +if [ "$a" = "Darwin" ] || [ "$a" = "Linux" ]; then make vio2vo J=2 test -f theories/test.vo make validate diff --git a/test-suite/coqchk/bug_7539.v b/test-suite/coqchk/bug_7539.v new file mode 100644 index 000000000..74ebe9290 --- /dev/null +++ b/test-suite/coqchk/bug_7539.v @@ -0,0 +1,26 @@ +Set Primitive Projections. + +CoInductive Stream : Type := Cons { tl : Stream }. + +Fixpoint Str_nth_tl (n:nat) (s:Stream) : Stream := + match n with + | O => s + | S m => Str_nth_tl m (tl s) + end. + +CoInductive EqSt (s1 s2: Stream) : Prop := eqst { + eqst_tl : EqSt (tl s1) (tl s2); +}. + +Axiom EqSt_reflex : forall (s : Stream), EqSt s s. + +CoFixpoint map (s:Stream) : Stream := Cons (map (tl s)). + +Lemma Str_nth_tl_map : forall n s, EqSt (Str_nth_tl n (map s)) (map (Str_nth_tl n s)). +Proof. +induction n. ++ intros; apply EqSt_reflex. ++ cbn; intros s; apply IHn. +Qed. + +Definition boom : forall s, tl (map s) = map (tl s) := fun s => eq_refl. diff --git a/test-suite/coqchk/univ.v b/test-suite/coqchk/univ.v index 19eea94b1..216338615 100644 --- a/test-suite/coqchk/univ.v +++ b/test-suite/coqchk/univ.v @@ -46,3 +46,44 @@ Inductive constraint4 : (Type -> Type) -> Type := mk_constraint4 : let U1 := Type in let U2 := Type in constraint4 (fun x : U1 => (x : U2)). + +Module CMP_CON. + (* Comparison of opaque constants MUST be up to the universe graph. + See #6798. *) + Universe big. + + Polymorphic Lemma foo@{u} : Type@{big}. + Proof. exact Type@{u}. Qed. + + Universes U V. + + Definition yo : foo@{U} = foo@{V} := eq_refl. +End CMP_CON. + +Set Universe Polymorphism. + +Module POLY_SUBTYP. + + Module Type T. + Axiom foo : Type. + Parameter bar@{u v|u = v} : foo@{u}. + End T. + + Module M. + Axiom foo : Type. + Axiom bar@{u v|u = v} : foo@{v}. + End M. + + Module F (A:T). End F. + + Module X := F M. + +End POLY_SUBTYP. + +Module POLY_IND. + + Polymorphic Inductive ind@{u v | u < v} : Prop := . + + Polymorphic Definition cst@{u v | v < u} := Prop. + +End POLY_IND. diff --git a/test-suite/ide/undo012.fake b/test-suite/ide/undo012.fake index b3d1c6d53..c95df1b11 100644 --- a/test-suite/ide/undo012.fake +++ b/test-suite/ide/undo012.fake @@ -3,6 +3,7 @@ # # Test backtracking in presence of nested proofs # +ADD { Set Nested Proofs Allowed. } ADD { Lemma aa : True -> True /\ True. } ADD { intro H. } ADD { split. } diff --git a/test-suite/ide/undo013.fake b/test-suite/ide/undo013.fake index 921a9d0f0..a3ccefd2c 100644 --- a/test-suite/ide/undo013.fake +++ b/test-suite/ide/undo013.fake @@ -4,6 +4,7 @@ # Test backtracking in presence of nested proofs # Second, trigger the undo of an inner proof # +ADD { Set Nested Proofs Allowed. } ADD { Lemma aa : True -> True /\ True. } ADD { intro H. } ADD { split. } diff --git a/test-suite/ide/undo014.fake b/test-suite/ide/undo014.fake index f5fe77470..13e718229 100644 --- a/test-suite/ide/undo014.fake +++ b/test-suite/ide/undo014.fake @@ -4,6 +4,7 @@ # Test backtracking in presence of nested proofs # Third, undo inside an inner proof # +ADD { Set Nested Proofs Allowed. } ADD { Lemma aa : True -> True /\ True. } ADD { intro H. } ADD { split. } diff --git a/test-suite/ide/undo015.fake b/test-suite/ide/undo015.fake index a1e5c947b..9cbd64460 100644 --- a/test-suite/ide/undo015.fake +++ b/test-suite/ide/undo015.fake @@ -4,6 +4,7 @@ # Test backtracking in presence of nested proofs # Fourth, undo from an inner proof to a above proof # +ADD { Set Nested Proofs Allowed. } ADD { Lemma aa : True -> True /\ True. } ADD { intro H. } ADD { split. } diff --git a/test-suite/ide/undo016.fake b/test-suite/ide/undo016.fake index f9414c1ea..15bd3cc92 100644 --- a/test-suite/ide/undo016.fake +++ b/test-suite/ide/undo016.fake @@ -4,6 +4,7 @@ # Test backtracking in presence of nested proofs # Fifth, undo from an inner proof to a previous inner proof # +ADD { Set Nested Proofs Allowed. } ADD { Lemma aa : True -> True /\ True. } ADD { intro H. } ADD { split. } diff --git a/test-suite/misc/.gitignore b/test-suite/misc/.gitignore new file mode 100644 index 000000000..a4083e931 --- /dev/null +++ b/test-suite/misc/.gitignore @@ -0,0 +1,2 @@ +4722/ +4722.v diff --git a/test-suite/misc/4722.sh b/test-suite/misc/4722.sh new file mode 100755 index 000000000..86bc50b5c --- /dev/null +++ b/test-suite/misc/4722.sh @@ -0,0 +1,15 @@ +#!/bin/sh +set -e + +# create test files +mkdir -p misc/4722 +ln -sf toto misc/4722/tata +touch misc/4722.v + +# run test +$coqtop "-R" "misc/4722" "Foo" -top Top -load-vernac-source misc/4722.v + +# clean up test files +rm misc/4722/tata +rmdir misc/4722 +rm misc/4722.v diff --git a/test-suite/misc/7595.sh b/test-suite/misc/7595.sh new file mode 100755 index 000000000..836e354ee --- /dev/null +++ b/test-suite/misc/7595.sh @@ -0,0 +1,5 @@ +#!/bin/sh +set -e + +$coqc -R misc/7595 Test misc/7595/base.v +$coqc -R misc/7595 Test misc/7595/FOO.v diff --git a/test-suite/misc/7595/FOO.v b/test-suite/misc/7595/FOO.v new file mode 100644 index 000000000..30c957d3b --- /dev/null +++ b/test-suite/misc/7595/FOO.v @@ -0,0 +1,39 @@ +Require Import Test.base. + +Lemma dec_stable `{Decision P} : ¬¬P → P. +Proof. firstorder. Qed. + +(** The tactic [destruct_decide] destructs a sumbool [dec]. If one of the +components is double negated, it will try to remove the double negation. *) +Tactic Notation "destruct_decide" constr(dec) "as" ident(H) := + destruct dec as [H|H]; + try match type of H with + | ¬¬_ => apply dec_stable in H + end. +Tactic Notation "destruct_decide" constr(dec) := + let H := fresh in destruct_decide dec as H. + + +(** * Monadic operations *) +Instance option_guard: MGuard option := λ P dec A f, + match dec with left H => f H | _ => None end. + +(** * Tactics *) +Tactic Notation "case_option_guard" "as" ident(Hx) := + match goal with + | H : context C [@mguard option _ ?P ?dec] |- _ => + change (@mguard option _ P dec) with (λ A (f : P → option A), + match @decide P dec with left H' => f H' | _ => None end) in *; + destruct_decide (@decide P dec) as Hx + | |- context C [@mguard option _ ?P ?dec] => + change (@mguard option _ P dec) with (λ A (f : P → option A), + match @decide P dec with left H' => f H' | _ => None end) in *; + destruct_decide (@decide P dec) as Hx + end. +Tactic Notation "case_option_guard" := + let H := fresh in case_option_guard as H. + +(* This proof failed depending on the name of the module. *) +Lemma option_guard_True {A} P `{Decision P} (mx : option A) : + P → (guard P; mx) = mx. +Proof. intros. case_option_guard. reflexivity. contradiction. Qed. diff --git a/test-suite/misc/7595/base.v b/test-suite/misc/7595/base.v new file mode 100644 index 000000000..6a6b7b79d --- /dev/null +++ b/test-suite/misc/7595/base.v @@ -0,0 +1,28 @@ +From Coq Require Export Morphisms RelationClasses List Bool Utf8 Setoid. +Set Default Proof Using "Type". +Export ListNotations. +From Coq.Program Require Export Basics Syntax. +Global Generalizable All Variables. + +(** * Type classes *) +(** ** Decidable propositions *) +(** This type class by (Spitters/van der Weegen, 2011) collects decidable +propositions. *) +Class Decision (P : Prop) := decide : {P} + {¬P}. +Hint Mode Decision ! : typeclass_instances. +Arguments decide _ {_} : simpl never, assert. + +(** ** Proof irrelevant types *) +(** This type class collects types that are proof irrelevant. That means, all +elements of the type are equal. We use this notion only used for propositions, +but by universe polymorphism we can generalize it. *) +Class ProofIrrel (A : Type) : Prop := proof_irrel (x y : A) : x = y. +Hint Mode ProofIrrel ! : typeclass_instances. + +Class MGuard (M : Type → Type) := + mguard: ∀ P {dec : Decision P} {A}, (P → M A) → M A. +Arguments mguard _ _ _ !_ _ _ / : assert. +Notation "'guard' P ; z" := (mguard P (λ _, z)) + (at level 20, z at level 200, only parsing, right associativity) . +Notation "'guard' P 'as' H ; z" := (mguard P (λ H, z)) + (at level 20, z at level 200, only parsing, right associativity) . diff --git a/test-suite/misc/coqc_dash_o.sh b/test-suite/misc/coqc_dash_o.sh new file mode 100755 index 000000000..0ae7873fd --- /dev/null +++ b/test-suite/misc/coqc_dash_o.sh @@ -0,0 +1,15 @@ +#!/usr/bin/env bash + +DOUT=misc/tmp_coqc_dash_o/ +OUT=${DOUT}coqc_dash_o.vo + + +mkdir -p "${DOUT}" +rm -f "${OUT}" +$coqc misc/coqc_dash_o.v -o "${OUT}" +if [ ! -f "${OUT}" ]; then + printf "coqc -o not working" + exit 1 +fi +rm -fr "${DOUT}" +exit 0 diff --git a/test-suite/misc/coqc_dash_o.v b/test-suite/misc/coqc_dash_o.v new file mode 100644 index 000000000..7426dff1a --- /dev/null +++ b/test-suite/misc/coqc_dash_o.v @@ -0,0 +1 @@ +Definition x := nat. diff --git a/test-suite/misc/deps-checksum.sh b/test-suite/misc/deps-checksum.sh index e07612b84..a15a8fbee 100755 --- a/test-suite/misc/deps-checksum.sh +++ b/test-suite/misc/deps-checksum.sh @@ -1,3 +1,4 @@ +#!/bin/sh rm -f misc/deps/A/*.vo misc/deps/B/*.vo $coqc -R misc/deps/A A misc/deps/A/A.v $coqc -R misc/deps/B A misc/deps/B/A.v diff --git a/test-suite/misc/deps-order.sh b/test-suite/misc/deps-order.sh index 299f49469..6bb2ba2da 100755 --- a/test-suite/misc/deps-order.sh +++ b/test-suite/misc/deps-order.sh @@ -1,17 +1,18 @@ +#!/bin/sh # Check that both coqdep and coqtop/coqc supports -R # Check that both coqdep and coqtop/coqc takes the later -R # See bugs 2242, 2337, 2339 rm -f misc/deps/lib/*.vo misc/deps/client/*.vo -tmpoutput=`mktemp /tmp/coqcheck.XXXXXX` -$coqdep -R misc/deps/lib lib -R misc/deps/client client misc/deps/client/bar.v 2>&1 | head -n 1 > $tmpoutput -diff -u --strip-trailing-cr misc/deps/deps.out $tmpoutput 2>&1 +tmpoutput=$(mktemp /tmp/coqcheck.XXXXXX) +$coqdep -R misc/deps/lib lib -R misc/deps/client client misc/deps/client/bar.v 2>&1 | head -n 1 > "$tmpoutput" +diff -u --strip-trailing-cr misc/deps/deps.out "$tmpoutput" 2>&1 R=$? times $coqc -R misc/deps/lib lib misc/deps/lib/foo.v 2>&1 $coqc -R misc/deps/lib lib -R misc/deps/client client misc/deps/client/foo.v 2>&1 $coqtop -R misc/deps/lib lib -R misc/deps/client client -load-vernac-source misc/deps/client/bar.v 2>&1 S=$? -if [ $R = 0 -a $S = 0 ]; then +if [ $R = 0 ] && [ $S = 0 ]; then printf "coqdep and coqtop agree\n" exit 0 else diff --git a/test-suite/misc/deps-utf8.sh b/test-suite/misc/deps-utf8.sh index 13e264c09..acb45b229 100755 --- a/test-suite/misc/deps-utf8.sh +++ b/test-suite/misc/deps-utf8.sh @@ -1,15 +1,16 @@ +#!/bin/sh # Check reading directories matching non pure ascii idents # See bug #5715 (utf-8 working on macos X and linux) # Windows is still not compliant -a=`uname` -if [ "$a" = "Darwin" -o "$a" = "Linux" ]; then +a=$(uname) +if [ "$a" = "Darwin" ] || [ "$a" = "Linux" ]; then rm -f misc/deps/théorèmes/*.v -tmpoutput=`mktemp /tmp/coqcheck.XXXXXX` +tmpoutput=$(mktemp /tmp/coqcheck.XXXXXX) $coqc -R misc/deps AlphaBêta misc/deps/αβ/γδ.v R=$? $coqtop -R misc/deps AlphaBêta -load-vernac-source misc/deps/αβ/εζ.v S=$? -if [ $R = 0 -a $S = 0 ]; then +if [ $R = 0 ] && [ $S = 0 ]; then exit 0 else exit 1 diff --git a/test-suite/misc/exitstatus.sh b/test-suite/misc/exitstatus.sh index cea1de862..a327f4248 100755 --- a/test-suite/misc/exitstatus.sh +++ b/test-suite/misc/exitstatus.sh @@ -1,7 +1,8 @@ +#!/bin/sh $coqtop -load-vernac-source misc/exitstatus/illtyped.v N=$? $coqc misc/exitstatus/illtyped.v P=$? -printf "On ill-typed input, coqtop returned $N.\n" -printf "On ill-typed input, coqc returned $P.\n" -if [ $N = 1 -a $P = 1 ]; then exit 0; else exit 1; fi +printf "On ill-typed input, coqtop returned %s.\n" "$N" +printf "On ill-typed input, coqc returned %s.\n" "$P" +if [ $N = 1 ] && [ $P = 1 ]; then exit 0; else exit 1; fi diff --git a/test-suite/misc/printers.sh b/test-suite/misc/printers.sh index 28e7dc362..ef3f056d8 100755 --- a/test-suite/misc/printers.sh +++ b/test-suite/misc/printers.sh @@ -1,3 +1,2 @@ -printf "Drop. #use\"include\";; #quit;;\n" | $coqtopbyte 2>&1 | egrep "Error|Unbound" -if [ $? = 0 ]; then exit 1; else exit 0; fi - +#!/bin/sh +if printf "Drop. #use\"include\";; #quit;;\n" | $coqtopbyte 2>&1 | grep -E "Error|Unbound" ; then exit 1; else exit 0; fi diff --git a/test-suite/misc/universes.sh b/test-suite/misc/universes.sh index d87a86035..ef61ca624 100755 --- a/test-suite/misc/universes.sh +++ b/test-suite/misc/universes.sh @@ -1,8 +1,9 @@ +#!/bin/sh # Sort universes for the whole standard library EXPECTED_UNIVERSES=4 # Prop is not counted $coqc -R misc/universes Universes misc/universes/all_stdlib 2>&1 $coqc -R misc/universes Universes misc/universes/universes 2>&1 mv universes.txt misc/universes -N=`awk '{print $3}' misc/universes/universes.txt | sort -u | wc -l` -printf "Found %s/%s universes\n" $N $EXPECTED_UNIVERSES +N=$(awk '{print $3}' misc/universes/universes.txt | sort -u | wc -l) +printf "Found %s/%s universes\n" "$N" "$EXPECTED_UNIVERSES" if [ "$N" -eq $EXPECTED_UNIVERSES ]; then exit 0; else exit 1; fi diff --git a/test-suite/output/Arguments_renaming.out b/test-suite/output/Arguments_renaming.out index e73312c67..c0b04eb53 100644 --- a/test-suite/output/Arguments_renaming.out +++ b/test-suite/output/Arguments_renaming.out @@ -1,6 +1,5 @@ The command has indeed failed with message: -To rename arguments the "rename" flag must be specified. -Argument A renamed to B. +Flag "rename" expected to rename A into B. File "stdin", line 2, characters 0-25: Warning: This command is just asserting the names of arguments of identity. If this is what you want add ': assert' to silence the warning. If you want @@ -113,5 +112,4 @@ Argument z cannot be declared implicit. The command has indeed failed with message: Extra arguments: y. The command has indeed failed with message: -To rename arguments the "rename" flag must be specified. -Argument A renamed to R. +Flag "rename" expected to rename A into R. diff --git a/test-suite/output/Cases.v b/test-suite/output/Cases.v index caf3b2870..4740c009a 100644 --- a/test-suite/output/Cases.v +++ b/test-suite/output/Cases.v @@ -163,6 +163,7 @@ match goal with |- ?y + _ = _ => pose (match y as y with 0 => 0 | S n => 0 end) match goal with |- ?y + _ = _ => pose (match y as y return y=y with 0 => eq_refl | S n => eq_refl end) end. match goal with |- ?y + _ = _ => pose (match y return y=y with 0 => eq_refl | S n => eq_refl end) end. Show. +Abort. Lemma lem5 (p:nat) : eq_refl p = eq_refl p. let y := fresh "n" in (* Checking that y is hidden *) diff --git a/test-suite/output/Notations3.out b/test-suite/output/Notations3.out index 1987b6a6e..996af5927 100644 --- a/test-suite/output/Notations3.out +++ b/test-suite/output/Notations3.out @@ -223,3 +223,21 @@ fun S : nat => [[S | S.S]] : Set exists2 '{{y, z}} : nat * nat, y > z & z > y : Prop +foo = +fun l : list nat => match l with + | _ :: (_ :: _) as l1 => l1 + | _ => l + end + : list nat -> list nat + +Argument scope is [list_scope] +Notation +"'exists' x .. y , p" := ex (fun x => .. (ex (fun y => p)) ..) : type_scope +(default interpretation) +"'exists' ! x .. y , p" := ex + (unique + (fun x => .. (ex (unique (fun y => p))) ..)) +: type_scope (default interpretation) +Notation +"( x , y , .. , z )" := pair .. (pair x y) .. z : core_scope +(default interpretation) diff --git a/test-suite/output/Notations3.v b/test-suite/output/Notations3.v index c165f9553..3cf0c913f 100644 --- a/test-suite/output/Notations3.v +++ b/test-suite/output/Notations3.v @@ -278,10 +278,12 @@ Set Printing Notations. (* Check insensitivity of "match" clauses to order *) +Module IfPat. Notation "'if' t 'is' n .+ 1 'then' p 'else' q" := (match t with S n => p | 0 => q end) (at level 200). Check fun x => if x is n.+1 then n else 1. +End IfPat. (* Examples with binding patterns *) @@ -338,11 +340,13 @@ Check ∀ '(((x,y),true)|((x,y),false)), x>y. (* Check Georges' printability of a "if is then else" notation *) +Module IfPat2. Notation "'if' c 'is' p 'then' u 'else' v" := (match c with p => u | _ => v end) (at level 200, p pattern at level 100). Check fun p => if p is S n then n else 0. Check fun p => if p is Lt then 1 else 0. +End IfPat2. (* Check that mixed binders and terms defaults to ident and not pattern *) Module F. @@ -364,3 +368,20 @@ Check {'(x,y)|x+y=0}. (* Check exists2 with a pattern *) Check ex2 (fun x => let '(y,z) := x in y>z) (fun x => let '(y,z) := x in z>y). + +Module Issue7110. +Open Scope list_scope. +Notation "[ :: x1 , x2 , .. , xn & s ]" := (x1 :: x2 :: .. (xn :: s) ..) + (at level 0). +Definition foo (l : list nat) := + match l with + | a :: (b :: l) as l1 => l1 + | _ => l +end. +Print foo. +End Issue7110. + +Module LocateNotations. +Locate "exists". +Locate "( _ , _ , .. , _ )". +End LocateNotations. diff --git a/test-suite/output/UnclosedBlocks.out b/test-suite/output/UnclosedBlocks.out index b83e94ad4..31481e84a 100644 --- a/test-suite/output/UnclosedBlocks.out +++ b/test-suite/output/UnclosedBlocks.out @@ -1,3 +1,2 @@ - Error: The section Baz, module type Bar and module Foo need to be closed. diff --git a/test-suite/output/Unicode.out b/test-suite/output/Unicode.out new file mode 100644 index 000000000..a57b3bbad --- /dev/null +++ b/test-suite/output/Unicode.out @@ -0,0 +1,41 @@ +1 subgoal + + very_very_long_type_name1 : Type + very_very_long_type_name2 : Type + f : very_very_long_type_name1 → very_very_long_type_name2 → Prop + ============================ + True + → True + → ∀ (x : very_very_long_type_name1) (y : very_very_long_type_name2), + f x y ∧ f x y ∧ f x y ∧ f x y ∧ f x y ∧ f x y +1 subgoal + + very_very_long_type_name1 : Type + very_very_long_type_name2 : Type + f : very_very_long_type_name1 → very_very_long_type_name2 → Prop + ============================ + True + → True + → ∀ (x : very_very_long_type_name2) (y : very_very_long_type_name1) + (z : very_very_long_type_name2), f y x ∧ f y z +1 subgoal + + very_very_long_type_name1 : Type + very_very_long_type_name2 : Type + f : very_very_long_type_name1 → very_very_long_type_name2 → Prop + ============================ + True + → True + → ∀ (x : very_very_long_type_name2) (y : very_very_long_type_name1) + (z : very_very_long_type_name2), + f y x ∧ f y z ∧ f y x ∧ f y z ∧ f y x ∧ f y z +1 subgoal + + very_very_long_type_name1 : Type + very_very_long_type_name2 : Type + f : very_very_long_type_name1 → very_very_long_type_name2 → Prop + ============================ + True + → True + → ∃ (x : very_very_long_type_name1) (y : very_very_long_type_name2), + f x y ∧ f x y ∧ f x y ∧ f x y ∧ f x y ∧ f x y diff --git a/test-suite/output/Unicode.v b/test-suite/output/Unicode.v new file mode 100644 index 000000000..42b07e5a0 --- /dev/null +++ b/test-suite/output/Unicode.v @@ -0,0 +1,28 @@ +Require Import Coq.Unicode.Utf8. + +Section test. +Context (very_very_long_type_name1 : Type) (very_very_long_type_name2 : Type). +Context (f : very_very_long_type_name1 -> very_very_long_type_name2 -> Prop). + +Lemma test : True -> True -> + forall (x : very_very_long_type_name1) (y : very_very_long_type_name2), + f x y /\ f x y /\ f x y /\ f x y /\ f x y /\ f x y. +Proof. Show. Abort. + +Lemma test : True -> True -> + forall (x : very_very_long_type_name2) (y : very_very_long_type_name1) + (z : very_very_long_type_name2), + f y x /\ f y z. +Proof. Show. Abort. + +Lemma test : True -> True -> + forall (x : very_very_long_type_name2) (y : very_very_long_type_name1) + (z : very_very_long_type_name2), + f y x /\ f y z /\ f y x /\ f y z /\ f y x /\ f y z. +Proof. Show. Abort. + +Lemma test : True -> True -> + exists (x : very_very_long_type_name1) (y : very_very_long_type_name2), + f x y /\ f x y /\ f x y /\ f x y /\ f x y /\ f x y. +Proof. Show. Abort. +End test. diff --git a/test-suite/output/ltac.v b/test-suite/output/ltac.v index 6adbe95dd..901b1e3aa 100644 --- a/test-suite/output/ltac.v +++ b/test-suite/output/ltac.v @@ -37,17 +37,20 @@ Fail g1 I. Fail f1 I. Fail g2 I. Fail f2 I. +Abort. Ltac h x := injection x. Goal True -> False. Fail h I. intro H. Fail h H. +Abort. (* Check printing of the "var" argument "Hx" *) Ltac m H := idtac H; exact H. Goal True. let a:=constr:(let Hx := 0 in ltac:(m Hx)) in idtac. +Abort. (* Check consistency of interpretation scopes (#4398) *) diff --git a/test-suite/output/ssr_clear.out b/test-suite/output/ssr_clear.out new file mode 100644 index 000000000..151595406 --- /dev/null +++ b/test-suite/output/ssr_clear.out @@ -0,0 +1,3 @@ +The command has indeed failed with message: +Ltac call to "move (ssrmovearg) (ssrclauses)" failed. +No assumption is named NO_SUCH_NAME diff --git a/test-suite/output/ssr_clear.v b/test-suite/output/ssr_clear.v new file mode 100644 index 000000000..573ec47e0 --- /dev/null +++ b/test-suite/output/ssr_clear.v @@ -0,0 +1,6 @@ +Require Import ssreflect. + +Example foo : True -> True. +Proof. +Fail move=> {NO_SUCH_NAME}. +Abort. diff --git a/test-suite/output/ssr_explain_match.out b/test-suite/output/ssr_explain_match.out new file mode 100644 index 000000000..fa2393b91 --- /dev/null +++ b/test-suite/output/ssr_explain_match.out @@ -0,0 +1,55 @@ +File "stdin", line 12, characters 0-61: +Warning: Notation _ - _ was already used in scope nat_scope. +[notation-overridden,parsing] +File "stdin", line 12, characters 0-61: +Warning: Notation _ <= _ was already used in scope nat_scope. +[notation-overridden,parsing] +File "stdin", line 12, characters 0-61: +Warning: Notation _ < _ was already used in scope nat_scope. +[notation-overridden,parsing] +File "stdin", line 12, characters 0-61: +Warning: Notation _ >= _ was already used in scope nat_scope. +[notation-overridden,parsing] +File "stdin", line 12, characters 0-61: +Warning: Notation _ > _ was already used in scope nat_scope. +[notation-overridden,parsing] +File "stdin", line 12, characters 0-61: +Warning: Notation _ <= _ <= _ was already used in scope nat_scope. +[notation-overridden,parsing] +File "stdin", line 12, characters 0-61: +Warning: Notation _ < _ <= _ was already used in scope nat_scope. +[notation-overridden,parsing] +File "stdin", line 12, characters 0-61: +Warning: Notation _ <= _ < _ was already used in scope nat_scope. +[notation-overridden,parsing] +File "stdin", line 12, characters 0-61: +Warning: Notation _ < _ < _ was already used in scope nat_scope. +[notation-overridden,parsing] +File "stdin", line 12, characters 0-61: +Warning: Notation _ + _ was already used in scope nat_scope. +[notation-overridden,parsing] +File "stdin", line 12, characters 0-61: +Warning: Notation _ * _ was already used in scope nat_scope. +[notation-overridden,parsing] +BEGIN INSTANCES +instance: (x + y + z) matches: (x + y + z) +instance: (x + y) matches: (x + y) +instance: (x + y) matches: (x + y) +END INSTANCES +BEGIN INSTANCES +instance: (addnC (x + y) z) matches: (x + y + z) +instance: (addnC x y) matches: (x + y) +instance: (addnC x y) matches: (x + y) +END INSTANCES +BEGIN INSTANCES +instance: (addnA x y z) matches: (x + y + z) +END INSTANCES +BEGIN INSTANCES +instance: (addnA x y z) matches: (x + y + z) +instance: (addnC z (x + y)) matches: (x + y + z) +instance: (addnC y x) matches: (x + y) +instance: (addnC y x) matches: (x + y) +END INSTANCES +The command has indeed failed with message: +Ltac call to "ssrinstancesoftpat (cpattern)" failed. +Not supported diff --git a/test-suite/output/ssr_explain_match.v b/test-suite/output/ssr_explain_match.v new file mode 100644 index 000000000..56ca24b6e --- /dev/null +++ b/test-suite/output/ssr_explain_match.v @@ -0,0 +1,23 @@ +(************************************************************************) +(* * 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) *) +(************************************************************************) + +Require Import ssrmatching. +Require Import ssreflect ssrbool TestSuite.ssr_mini_mathcomp. + +Definition addnAC := (addnA, addnC). + +Lemma test x y z : x + y + z = x + y. + +ssrinstancesoftpat (_ + _). +ssrinstancesofruleL2R addnC. +ssrinstancesofruleR2L addnA. +ssrinstancesofruleR2L addnAC. +Fail ssrinstancesoftpat (_ + _ in RHS). (* Not implemented *) +Admitted. diff --git a/test-suite/prerequisite/ssr_mini_mathcomp.v b/test-suite/prerequisite/ssr_mini_mathcomp.v new file mode 100644 index 000000000..cb2c56736 --- /dev/null +++ b/test-suite/prerequisite/ssr_mini_mathcomp.v @@ -0,0 +1,1472 @@ +(************************************************************************) +(* * 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) *) +(************************************************************************) + +(* Some code from mathcomp needed in order to run ssr_* tests *) + +Require Import ssreflect ssrfun ssrbool. + +Global Set SsrOldRewriteGoalsOrder. +Global Set Asymmetric Patterns. +Global Set Bullet Behavior "None". + +Set Implicit Arguments. +Unset Strict Implicit. +Unset Printing Implicit Defensive. + +(* eqtype ---------------------------------------------------------- *) + +Module Equality. + +Definition axiom T (e : rel T) := forall x y, reflect (x = y) (e x y). + +Structure mixin_of T := Mixin {op : rel T; _ : axiom op}. +Notation class_of := mixin_of (only parsing). + +Section ClassDef. + +Structure type := Pack {sort; _ : class_of sort; _ : Type}. +Local Coercion sort : type >-> Sortclass. +Variables (T : Type) (cT : type). + +Definition class := let: Pack _ c _ := cT return class_of cT in c. + +Definition pack c := @Pack T c T. +Definition clone := fun c & cT -> T & phant_id (pack c) cT => pack c. + +End ClassDef. + +Module Exports. +Coercion sort : type >-> Sortclass. +Notation eqType := type. +Notation EqMixin := Mixin. +Notation EqType T m := (@pack T m). +Notation "[ 'eqMixin' 'of' T ]" := (class _ : mixin_of T) + (at level 0, format "[ 'eqMixin' 'of' T ]") : form_scope. +Notation "[ 'eqType' 'of' T 'for' C ]" := (@clone T C _ idfun id) + (at level 0, format "[ 'eqType' 'of' T 'for' C ]") : form_scope. +Notation "[ 'eqType' 'of' T ]" := (@clone T _ _ id id) + (at level 0, format "[ 'eqType' 'of' T ]") : form_scope. +End Exports. + +End Equality. +Export Equality.Exports. + +Definition eq_op T := Equality.op (Equality.class T). + +Lemma eqE T x : eq_op x = Equality.op (Equality.class T) x. +Proof. by []. Qed. + +Lemma eqP T : Equality.axiom (@eq_op T). +Proof. by case: T => ? []. Qed. +Arguments eqP [T x y]. + +Delimit Scope eq_scope with EQ. +Open Scope eq_scope. + +Notation "x == y" := (eq_op x y) + (at level 70, no associativity) : bool_scope. +Notation "x == y :> T" := ((x : T) == (y : T)) + (at level 70, y at next level) : bool_scope. +Notation "x != y" := (~~ (x == y)) + (at level 70, no associativity) : bool_scope. +Notation "x != y :> T" := (~~ (x == y :> T)) + (at level 70, y at next level) : bool_scope. +Notation "x =P y" := (eqP : reflect (x = y) (x == y)) + (at level 70, no associativity) : eq_scope. +Notation "x =P y :> T" := (eqP : reflect (x = y :> T) (x == y :> T)) + (at level 70, y at next level, no associativity) : eq_scope. + +Prenex Implicits eq_op eqP. + +Lemma eq_refl (T : eqType) (x : T) : x == x. Proof. exact/eqP. Qed. +Notation eqxx := eq_refl. + +Lemma eq_sym (T : eqType) (x y : T) : (x == y) = (y == x). +Proof. exact/eqP/eqP. Qed. + +Hint Resolve eq_refl eq_sym. + + +Definition eqb b := addb (~~ b). + +Lemma eqbP : Equality.axiom eqb. +Proof. by do 2!case; constructor. Qed. + +Canonical bool_eqMixin := EqMixin eqbP. +Canonical bool_eqType := Eval hnf in EqType bool bool_eqMixin. + +Section ProdEqType. + +Variable T1 T2 : eqType. + +Definition pair_eq := [rel u v : T1 * T2 | (u.1 == v.1) && (u.2 == v.2)]. + +Lemma pair_eqP : Equality.axiom pair_eq. +Proof. +move=> [x1 x2] [y1 y2] /=; apply: (iffP andP) => [[]|[<- <-]] //=. +by do 2!move/eqP->. +Qed. + +Definition prod_eqMixin := EqMixin pair_eqP. +Canonical prod_eqType := Eval hnf in EqType (T1 * T2) prod_eqMixin. + +End ProdEqType. + +Section OptionEqType. + +Variable T : eqType. + +Definition opt_eq (u v : option T) : bool := + oapp (fun x => oapp (eq_op x) false v) (~~ v) u. + +Lemma opt_eqP : Equality.axiom opt_eq. +Proof. +case=> [x|] [y|] /=; by [constructor | apply: (iffP eqP) => [|[]] ->]. +Qed. + +Canonical option_eqMixin := EqMixin opt_eqP. +Canonical option_eqType := Eval hnf in EqType (option T) option_eqMixin. + +End OptionEqType. + +Notation xpred1 := (fun a1 x => x == a1). +Notation xpredU1 := (fun a1 (p : pred _) x => (x == a1) || p x). + +Section EqPred. + +Variable T : eqType. + +Definition pred1 (a1 : T) := SimplPred (xpred1 a1). +Definition predU1 (a1 : T) p := SimplPred (xpredU1 a1 p). + +End EqPred. + +Section TransferEqType. + +Variables (T : Type) (eT : eqType) (f : T -> eT). + +Lemma inj_eqAxiom : injective f -> Equality.axiom (fun x y => f x == f y). +Proof. by move=> f_inj x y; apply: (iffP eqP) => [|-> //]; apply: f_inj. Qed. + +Definition InjEqMixin f_inj := EqMixin (inj_eqAxiom f_inj). + +Definition PcanEqMixin g (fK : pcancel f g) := InjEqMixin (pcan_inj fK). + +Definition CanEqMixin g (fK : cancel f g) := InjEqMixin (can_inj fK). + +End TransferEqType. + +(* We use the module system to circumvent a silly limitation that *) +(* forbids using the same constant to coerce to different targets. *) +Module Type EqTypePredSig. +Parameter sort : eqType -> predArgType. +End EqTypePredSig. +Module MakeEqTypePred (eqmod : EqTypePredSig). +Coercion eqmod.sort : eqType >-> predArgType. +End MakeEqTypePred. +Module Export EqTypePred := MakeEqTypePred Equality. + + +Section SubType. + +Variables (T : Type) (P : pred T). + +Structure subType : Type := SubType { + sub_sort :> Type; + val : sub_sort -> T; + Sub : forall x, P x -> sub_sort; + _ : forall K (_ : forall x Px, K (@Sub x Px)) u, K u; + _ : forall x Px, val (@Sub x Px) = x +}. + +Arguments Sub [s]. +Lemma vrefl : forall x, P x -> x = x. Proof. by []. Qed. +Definition vrefl_rect := vrefl. + +Definition clone_subType U v := + fun sT & sub_sort sT -> U => + fun c Urec cK (sT' := @SubType U v c Urec cK) & phant_id sT' sT => sT'. + +Variable sT : subType. + +CoInductive Sub_spec : sT -> Type := SubSpec x Px : Sub_spec (Sub x Px). + +Lemma SubP u : Sub_spec u. +Proof. by case: sT Sub_spec SubSpec u => T' _ C rec /= _. Qed. + +Lemma SubK x Px : @val sT (Sub x Px) = x. +Proof. by case: sT. Qed. + +Definition insub x := + if @idP (P x) is ReflectT Px then @Some sT (Sub x Px) else None. + +Definition insubd u0 x := odflt u0 (insub x). + +CoInductive insub_spec x : option sT -> Type := + | InsubSome u of P x & val u = x : insub_spec x (Some u) + | InsubNone of ~~ P x : insub_spec x None. + +Lemma insubP x : insub_spec x (insub x). +Proof. +by rewrite /insub; case: {-}_ / idP; [left; rewrite ?SubK | right; apply/negP]. +Qed. + +Lemma insubT x Px : insub x = Some (Sub x Px). +Admitted. + +Lemma insubF x : P x = false -> insub x = None. +Proof. by move/idP; case: insubP. Qed. + +Lemma insubN x : ~~ P x -> insub x = None. +Proof. by move/negPf/insubF. Qed. + +Lemma isSome_insub : ([eta insub] : pred T) =1 P. +Proof. by apply: fsym => x; case: insubP => // /negPf. Qed. + +Lemma insubK : ocancel insub (@val _). +Proof. by move=> x; case: insubP. Qed. + +Lemma valP (u : sT) : P (val u). +Proof. by case/SubP: u => x Px; rewrite SubK. Qed. + +Lemma valK : pcancel (@val _) insub. +Proof. by case/SubP=> x Px; rewrite SubK; apply: insubT. Qed. + +Lemma val_inj : injective (@val sT). +Proof. exact: pcan_inj valK. Qed. + +Lemma valKd u0 : cancel (@val _) (insubd u0). +Proof. by move=> u; rewrite /insubd valK. Qed. + +Lemma val_insubd u0 x : val (insubd u0 x) = if P x then x else val u0. +Proof. by rewrite /insubd; case: insubP => [u -> | /negPf->]. Qed. + +Lemma insubdK u0 : {in P, cancel (insubd u0) (@val _)}. +Proof. by move=> x Px; rewrite /= val_insubd [P x]Px. Qed. + +Definition insub_eq x := + let Some_sub Px := Some (Sub x Px : sT) in + let None_sub _ := None in + (if P x as Px return P x = Px -> _ then Some_sub else None_sub) (erefl _). + +Lemma insub_eqE : insub_eq =1 insub. +Proof. +rewrite /insub_eq /insub => x; case: {2 3}_ / idP (erefl _) => // Px Px'. +by congr (Some _); apply: val_inj; rewrite !SubK. +Qed. + +End SubType. + +Arguments SubType [T P]. +Arguments Sub [T P s]. +Arguments vrefl [T P]. +Arguments vrefl_rect [T P]. +Arguments clone_subType [T P] U v [sT] _ [c Urec cK]. +Arguments insub [T P sT]. +Arguments insubT [T] P [sT x]. +Arguments val_inj [T P sT]. +Prenex Implicits val Sub vrefl vrefl_rect insub insubd val_inj. + +Local Notation inlined_sub_rect := + (fun K K_S u => let (x, Px) as u return K u := u in K_S x Px). + +Local Notation inlined_new_rect := + (fun K K_S u => let (x) as u return K u := u in K_S x). + +Notation "[ 'subType' 'for' v ]" := (SubType _ v _ inlined_sub_rect vrefl_rect) + (at level 0, only parsing) : form_scope. + +Notation "[ 'sub' 'Type' 'for' v ]" := (SubType _ v _ _ vrefl_rect) + (at level 0, format "[ 'sub' 'Type' 'for' v ]") : form_scope. + +Notation "[ 'subType' 'for' v 'by' rec ]" := (SubType _ v _ rec vrefl) + (at level 0, format "[ 'subType' 'for' v 'by' rec ]") : form_scope. + +Notation "[ 'subType' 'of' U 'for' v ]" := (clone_subType U v id idfun) + (at level 0, format "[ 'subType' 'of' U 'for' v ]") : form_scope. + +(* +Notation "[ 'subType' 'for' v ]" := (clone_subType _ v id idfun) + (at level 0, format "[ 'subType' 'for' v ]") : form_scope. +*) +Notation "[ 'subType' 'of' U ]" := (clone_subType U _ id id) + (at level 0, format "[ 'subType' 'of' U ]") : form_scope. + +Definition NewType T U v c Urec := + let Urec' P IH := Urec P (fun x : T => IH x isT : P _) in + SubType U v (fun x _ => c x) Urec'. +Arguments NewType [T U]. + +Notation "[ 'newType' 'for' v ]" := (NewType v _ inlined_new_rect vrefl_rect) + (at level 0, only parsing) : form_scope. + +Notation "[ 'new' 'Type' 'for' v ]" := (NewType v _ _ vrefl_rect) + (at level 0, format "[ 'new' 'Type' 'for' v ]") : form_scope. + +Notation "[ 'newType' 'for' v 'by' rec ]" := (NewType v _ rec vrefl) + (at level 0, format "[ 'newType' 'for' v 'by' rec ]") : form_scope. + +Definition innew T nT x := @Sub T predT nT x (erefl true). +Arguments innew [T nT]. +Prenex Implicits innew. + +Lemma innew_val T nT : cancel val (@innew T nT). +Proof. by move=> u; apply: val_inj; apply: SubK. Qed. + +(* Prenex Implicits and renaming. *) +Notation sval := (@proj1_sig _ _). +Notation "@ 'sval'" := (@proj1_sig) (at level 10, format "@ 'sval'"). + +Section SubEqType. + +Variables (T : eqType) (P : pred T) (sT : subType P). + +Local Notation ev_ax := (fun T v => @Equality.axiom T (fun x y => v x == v y)). +Lemma val_eqP : ev_ax sT val. Proof. exact: inj_eqAxiom val_inj. Qed. + +Definition sub_eqMixin := EqMixin val_eqP. +Canonical sub_eqType := Eval hnf in EqType sT sub_eqMixin. + +Definition SubEqMixin := + (let: SubType _ v _ _ _ as sT' := sT + return ev_ax sT' val -> Equality.class_of sT' in + fun vP : ev_ax _ v => EqMixin vP + ) val_eqP. + +Lemma val_eqE (u v : sT) : (val u == val v) = (u == v). +Proof. by []. Qed. + +End SubEqType. + +Arguments val_eqP [T P sT x y]. +Prenex Implicits val_eqP. + +Notation "[ 'eqMixin' 'of' T 'by' <: ]" := (SubEqMixin _ : Equality.class_of T) + (at level 0, format "[ 'eqMixin' 'of' T 'by' <: ]") : form_scope. + +(* ssrnat ---------------------------------------------------------- *) + +Notation succn := Datatypes.S. +Notation predn := Peano.pred. + +Notation "n .+1" := (succn n) (at level 2, left associativity, + format "n .+1") : nat_scope. +Notation "n .+2" := n.+1.+1 (at level 2, left associativity, + format "n .+2") : nat_scope. +Notation "n .+3" := n.+2.+1 (at level 2, left associativity, + format "n .+3") : nat_scope. +Notation "n .+4" := n.+2.+2 (at level 2, left associativity, + format "n .+4") : nat_scope. + +Notation "n .-1" := (predn n) (at level 2, left associativity, + format "n .-1") : nat_scope. +Notation "n .-2" := n.-1.-1 (at level 2, left associativity, + format "n .-2") : nat_scope. + +Fixpoint eqn m n {struct m} := + match m, n with + | 0, 0 => true + | m'.+1, n'.+1 => eqn m' n' + | _, _ => false + end. + +Lemma eqnP : Equality.axiom eqn. +Proof. +move=> n m; apply: (iffP idP) => [|<-]; last by elim n. +by elim: n m => [|n IHn] [|m] //= /IHn->. +Qed. + +Canonical nat_eqMixin := EqMixin eqnP. +Canonical nat_eqType := Eval hnf in EqType nat nat_eqMixin. + +Arguments eqnP [x y]. +Prenex Implicits eqnP. + +Coercion nat_of_bool (b : bool) := if b then 1 else 0. + +Fixpoint odd n := if n is n'.+1 then ~~ odd n' else false. + +Lemma oddb (b : bool) : odd b = b. Proof. by case: b. Qed. + +Definition subn_rec := minus. +Notation "m - n" := (subn_rec m n) : nat_rec_scope. + +Definition subn := nosimpl subn_rec. +Notation "m - n" := (subn m n) : nat_scope. + +Definition leq m n := m - n == 0. + +Notation "m <= n" := (leq m n) : nat_scope. +Notation "m < n" := (m.+1 <= n) : nat_scope. +Notation "m >= n" := (n <= m) (only parsing) : nat_scope. +Notation "m > n" := (n < m) (only parsing) : nat_scope. + + +Notation "m <= n <= p" := ((m <= n) && (n <= p)) : nat_scope. +Notation "m < n <= p" := ((m < n) && (n <= p)) : nat_scope. +Notation "m <= n < p" := ((m <= n) && (n < p)) : nat_scope. +Notation "m < n < p" := ((m < n) && (n < p)) : nat_scope. + +Open Scope nat_scope. + + +Lemma ltnS m n : (m < n.+1) = (m <= n). Proof. by []. Qed. +Lemma leq0n n : 0 <= n. Proof. by []. Qed. +Lemma ltn0Sn n : 0 < n.+1. Proof. by []. Qed. +Lemma ltn0 n : n < 0 = false. Proof. by []. Qed. +Lemma leqnn n : n <= n. Proof. by elim: n. Qed. +Hint Resolve leqnn. +Lemma leqnSn n : n <= n.+1. Proof. by elim: n. Qed. + +Lemma leq_trans n m p : m <= n -> n <= p -> m <= p. +Admitted. +Lemma leqW m n : m <= n -> m <= n.+1. +Admitted. +Hint Resolve leqnSn. +Lemma ltnW m n : m < n -> m <= n. +Proof. exact: leq_trans. Qed. +Hint Resolve ltnW. + +Definition addn_rec := plus. +Notation "m + n" := (addn_rec m n) : nat_rec_scope. + +Definition addn := nosimpl addn_rec. +Notation "m + n" := (addn m n) : nat_scope. + +Lemma addn0 : right_id 0 addn. Proof. by move=> n; apply/eqP; elim: n. Qed. +Lemma add0n : left_id 0 addn. Proof. by []. Qed. +Lemma addSn m n : m.+1 + n = (m + n).+1. Proof. by []. Qed. +Lemma addnS m n : m + n.+1 = (m + n).+1. Proof. by elim: m. Qed. + +Lemma addnCA : left_commutative addn. +Proof. by move=> m n p; elim: m => //= m; rewrite addnS => <-. Qed. + +Lemma addnC : commutative addn. +Proof. by move=> m n; rewrite -{1}[n]addn0 addnCA addn0. Qed. + +Lemma addnA : associative addn. +Proof. by move=> m n p; rewrite (addnC n) addnCA addnC. Qed. + +Lemma subnK m n : m <= n -> (n - m) + m = n. +Admitted. + + +Definition muln_rec := mult. +Notation "m * n" := (muln_rec m n) : nat_rec_scope. + +Definition muln := nosimpl muln_rec. +Notation "m * n" := (muln m n) : nat_scope. + +Lemma mul0n : left_zero 0 muln. Proof. by []. Qed. +Lemma muln0 : right_zero 0 muln. Proof. by elim. Qed. +Lemma mul1n : left_id 1 muln. Proof. exact: addn0. Qed. + +Lemma mulSn m n : m.+1 * n = n + m * n. Proof. by []. Qed. +Lemma mulSnr m n : m.+1 * n = m * n + n. Proof. exact: addnC. Qed. + +Lemma mulnS m n : m * n.+1 = m + m * n. +Proof. by elim: m => // m; rewrite !mulSn !addSn addnCA => ->. Qed. + +Lemma mulnSr m n : m * n.+1 = m * n + m. +Proof. by rewrite addnC mulnS. Qed. + +Lemma muln1 : right_id 1 muln. +Proof. by move=> n; rewrite mulnSr muln0. Qed. + +Lemma mulnC : commutative muln. +Proof. +by move=> m n; elim: m => [|m]; rewrite (muln0, mulnS) // mulSn => ->. +Qed. + +Lemma mulnDl : left_distributive muln addn. +Proof. by move=> m1 m2 n; elim: m1 => //= m1 IHm; rewrite -addnA -IHm. Qed. + +Lemma mulnDr : right_distributive muln addn. +Proof. by move=> m n1 n2; rewrite !(mulnC m) mulnDl. Qed. + +Lemma mulnA : associative muln. +Proof. by move=> m n p; elim: m => //= m; rewrite mulSn mulnDl => ->. Qed. + +Lemma mulnCA : left_commutative muln. +Proof. by move=> m n1 n2; rewrite !mulnA (mulnC m). Qed. + +Lemma mulnAC : right_commutative muln. +Proof. by move=> m n p; rewrite -!mulnA (mulnC n). Qed. + +Lemma mulnACA : interchange muln muln. +Proof. by move=> m n p q; rewrite -!mulnA (mulnCA n). Qed. + +(* seq ------------------------------------------------------------- *) + +Delimit Scope seq_scope with SEQ. +Open Scope seq_scope. + +(* Inductive seq (T : Type) : Type := Nil | Cons of T & seq T. *) +Notation seq := list. +Prenex Implicits cons. +Notation Cons T := (@cons T) (only parsing). +Notation Nil T := (@nil T) (only parsing). + +Bind Scope seq_scope with list. +Arguments cons _%type _ _%SEQ. + +(* As :: and ++ are (improperly) declared in Init.datatypes, we only rebind *) +(* them here. *) +Infix "::" := cons : seq_scope. + +(* GG - this triggers a camlp4 warning, as if this Notation had been Reserved *) +Notation "[ :: ]" := nil (at level 0, format "[ :: ]") : seq_scope. + +Notation "[ :: x1 ]" := (x1 :: [::]) + (at level 0, format "[ :: x1 ]") : seq_scope. + +Notation "[ :: x & s ]" := (x :: s) (at level 0, only parsing) : seq_scope. + +Notation "[ :: x1 , x2 , .. , xn & s ]" := (x1 :: x2 :: .. (xn :: s) ..) + (at level 0, format + "'[hv' [ :: '[' x1 , '/' x2 , '/' .. , '/' xn ']' '/ ' & s ] ']'" + ) : seq_scope. + +Notation "[ :: x1 ; x2 ; .. ; xn ]" := (x1 :: x2 :: .. [:: xn] ..) + (at level 0, format "[ :: '[' x1 ; '/' x2 ; '/' .. ; '/' xn ']' ]" + ) : seq_scope. + +Section Sequences. + +Variable n0 : nat. (* numerical parameter for take, drop et al *) +Variable T : Type. (* must come before the implicit Type *) +Variable x0 : T. (* default for head/nth *) + +Implicit Types x y z : T. +Implicit Types m n : nat. +Implicit Type s : seq T. + +Fixpoint size s := if s is _ :: s' then (size s').+1 else 0. + +Fixpoint cat s1 s2 := if s1 is x :: s1' then x :: s1' ++ s2 else s2 +where "s1 ++ s2" := (cat s1 s2) : seq_scope. + +Lemma cat0s s : [::] ++ s = s. Proof. by []. Qed. + +Lemma cats0 s : s ++ [::] = s. +Proof. by elim: s => //= x s ->. Qed. + +Lemma catA s1 s2 s3 : s1 ++ s2 ++ s3 = (s1 ++ s2) ++ s3. +Proof. by elim: s1 => //= x s1 ->. Qed. + +Fixpoint nth s n {struct n} := + if s is x :: s' then if n is n'.+1 then @nth s' n' else x else x0. + +Fixpoint rcons s z := if s is x :: s' then x :: rcons s' z else [:: z]. + +CoInductive last_spec : seq T -> Type := + | LastNil : last_spec [::] + | LastRcons s x : last_spec (rcons s x). + +Lemma lastP s : last_spec s. +Proof using. Admitted. + +Lemma last_ind P : + P [::] -> (forall s x, P s -> P (rcons s x)) -> forall s, P s. +Proof using. Admitted. + + +Section Map. + +Variables (T2 : Type) (f : T -> T2). + +Fixpoint map s := if s is x :: s' then f x :: map s' else [::]. + +End Map. + +Section SeqFind. + +Variable a : pred T. + +Fixpoint count s := if s is x :: s' then a x + count s' else 0. + +Fixpoint filter s := + if s is x :: s' then if a x then x :: filter s' else filter s' else [::]. + +End SeqFind. + +End Sequences. + +Infix "++" := cat : seq_scope. + +Notation count_mem x := (count (pred_of_simpl (pred1 x))). + +Section EqSeq. + +Variables (n0 : nat) (T : eqType) (x0 : T). +Local Notation nth := (nth x0). +Implicit Type s : seq T. +Implicit Types x y z : T. + +Fixpoint eqseq s1 s2 {struct s2} := + match s1, s2 with + | [::], [::] => true + | x1 :: s1', x2 :: s2' => (x1 == x2) && eqseq s1' s2' + | _, _ => false + end. + +Lemma eqseqP : Equality.axiom eqseq. +Proof. +move; elim=> [|x1 s1 IHs] [|x2 s2]; do [by constructor | simpl]. +case: (x1 =P x2) => [<-|neqx]; last by right; case. +by apply: (iffP (IHs s2)) => [<-|[]]. +Qed. + +Canonical seq_eqMixin := EqMixin eqseqP. +Canonical seq_eqType := Eval hnf in EqType (seq T) seq_eqMixin. + +Fixpoint mem_seq (s : seq T) := + if s is y :: s' then xpredU1 y (mem_seq s') else xpred0. + +Definition eqseq_class := seq T. +Identity Coercion seq_of_eqseq : eqseq_class >-> seq. +Coercion pred_of_eq_seq (s : eqseq_class) : pred_class := [eta mem_seq s]. + +Canonical seq_predType := @mkPredType T (seq T) pred_of_eq_seq. + +Fixpoint uniq s := if s is x :: s' then (x \notin s') && uniq s' else true. + +End EqSeq. + +Definition bitseq := seq bool. +Canonical bitseq_eqType := Eval hnf in [eqType of bitseq]. +Canonical bitseq_predType := Eval hnf in [predType of bitseq]. + +Section Pmap. + +Variables (aT rT : Type) (f : aT -> option rT) (g : rT -> aT). + +Fixpoint pmap s := + if s is x :: s' then let r := pmap s' in oapp (cons^~ r) r (f x) else [::]. + +End Pmap. + +Fixpoint iota m n := if n is n'.+1 then m :: iota m.+1 n' else [::]. + +Section FoldRight. + +Variables (T : Type) (R : Type) (f : T -> R -> R) (z0 : R). + +Fixpoint foldr s := if s is x :: s' then f x (foldr s') else z0. + +End FoldRight. + +Lemma mem_iota m n i : (i \in iota m n) = (m <= i) && (i < m + n). +Admitted. + + +(* choice ------------------------------------------------------------- *) + +Module Choice. + +Section ClassDef. + +Record mixin_of T := Mixin { + find : pred T -> nat -> option T; + _ : forall P n x, find P n = Some x -> P x; + _ : forall P : pred T, (exists x, P x) -> exists n, find P n; + _ : forall P Q : pred T, P =1 Q -> find P =1 find Q +}. + +Record class_of T := Class {base : Equality.class_of T; mixin : mixin_of T}. +Local Coercion base : class_of >-> Equality.class_of. + +Structure type := Pack {sort; _ : class_of sort; _ : Type}. +Local Coercion sort : type >-> Sortclass. +Variables (T : Type) (cT : type). +Definition class := let: Pack _ c _ as cT' := cT return class_of cT' in c. +Definition clone c of phant_id class c := @Pack T c T. +Let xT := let: Pack T _ _ := cT in T. +Notation xclass := (class : class_of xT). + +Definition pack m := + fun b bT & phant_id (Equality.class bT) b => Pack (@Class T b m) T. + +(* Inheritance *) +Definition eqType := @Equality.Pack cT xclass xT. + +End ClassDef. + +Module Import Exports. +Coercion base : class_of >-> Equality.class_of. +Coercion sort : type >-> Sortclass. +Coercion eqType : type >-> Equality.type. +Canonical eqType. +Notation choiceType := type. +Notation choiceMixin := mixin_of. +Notation ChoiceType T m := (@pack T m _ _ id). +Notation "[ 'choiceType' 'of' T 'for' cT ]" := (@clone T cT _ idfun) + (at level 0, format "[ 'choiceType' 'of' T 'for' cT ]") : form_scope. +Notation "[ 'choiceType' 'of' T ]" := (@clone T _ _ id) + (at level 0, format "[ 'choiceType' 'of' T ]") : form_scope. + +End Exports. + +End Choice. +Export Choice.Exports. + +Section ChoiceTheory. + +Variable T : choiceType. + +Section CanChoice. + +Variables (sT : Type) (f : sT -> T). + +Lemma PcanChoiceMixin f' : pcancel f f' -> choiceMixin sT. +Admitted. + +Definition CanChoiceMixin f' (fK : cancel f f') := + PcanChoiceMixin (can_pcan fK). + +End CanChoice. + +Section SubChoice. + +Variables (P : pred T) (sT : subType P). + +Definition sub_choiceMixin := PcanChoiceMixin (@valK T P sT). +Definition sub_choiceClass := @Choice.Class sT (sub_eqMixin sT) sub_choiceMixin. +Canonical sub_choiceType := Choice.Pack sub_choiceClass sT. + +End SubChoice. + + +Fact seq_choiceMixin : choiceMixin (seq T). +Admitted. +Canonical seq_choiceType := Eval hnf in ChoiceType (seq T) seq_choiceMixin. +End ChoiceTheory. + +Fact nat_choiceMixin : choiceMixin nat. +Proof. +pose f := [fun (P : pred nat) n => if P n then Some n else None]. +exists f => [P n m | P [n Pn] | P Q eqPQ n] /=; last by rewrite eqPQ. + by case: ifP => // Pn [<-]. +by exists n; rewrite Pn. +Qed. +Canonical nat_choiceType := Eval hnf in ChoiceType nat nat_choiceMixin. + +Definition bool_choiceMixin := CanChoiceMixin oddb. +Canonical bool_choiceType := Eval hnf in ChoiceType bool bool_choiceMixin. +Canonical bitseq_choiceType := Eval hnf in [choiceType of bitseq]. + + +Notation "[ 'choiceMixin' 'of' T 'by' <: ]" := + (sub_choiceMixin _ : choiceMixin T) + (at level 0, format "[ 'choiceMixin' 'of' T 'by' <: ]") : form_scope. + + + + +Module Countable. + +Record mixin_of (T : Type) : Type := Mixin { + pickle : T -> nat; + unpickle : nat -> option T; + pickleK : pcancel pickle unpickle +}. + +Definition EqMixin T m := PcanEqMixin (@pickleK T m). +Definition ChoiceMixin T m := PcanChoiceMixin (@pickleK T m). + +Section ClassDef. + +Record class_of T := Class { base : Choice.class_of T; mixin : mixin_of T }. +Local Coercion base : class_of >-> Choice.class_of. + +Structure type : Type := Pack {sort : Type; _ : class_of sort; _ : Type}. +Local Coercion sort : type >-> Sortclass. +Variables (T : Type) (cT : type). +Definition class := let: Pack _ c _ as cT' := cT return class_of cT' in c. +Definition clone c of phant_id class c := @Pack T c T. +Let xT := let: Pack T _ _ := cT in T. +Notation xclass := (class : class_of xT). + +Definition pack m := + fun bT b & phant_id (Choice.class bT) b => Pack (@Class T b m) T. + +Definition eqType := @Equality.Pack cT xclass xT. +Definition choiceType := @Choice.Pack cT xclass xT. + +End ClassDef. + +Module Exports. +Coercion base : class_of >-> Choice.class_of. +Coercion mixin : class_of >-> mixin_of. +Coercion sort : type >-> Sortclass. +Coercion eqType : type >-> Equality.type. +Canonical eqType. +Coercion choiceType : type >-> Choice.type. +Canonical choiceType. +Notation countType := type. +Notation CountType T m := (@pack T m _ _ id). +Notation CountMixin := Mixin. +Notation CountChoiceMixin := ChoiceMixin. +Notation "[ 'countType' 'of' T 'for' cT ]" := (@clone T cT _ idfun) + (at level 0, format "[ 'countType' 'of' T 'for' cT ]") : form_scope. +Notation "[ 'countType' 'of' T ]" := (@clone T _ _ id) + (at level 0, format "[ 'countType' 'of' T ]") : form_scope. + +End Exports. + +End Countable. +Export Countable.Exports. + +Definition unpickle T := Countable.unpickle (Countable.class T). +Definition pickle T := Countable.pickle (Countable.class T). +Arguments unpickle [T]. +Prenex Implicits pickle unpickle. + +Section CountableTheory. + +Variable T : countType. + +Lemma pickleK : @pcancel nat T pickle unpickle. +Proof. exact: Countable.pickleK. Qed. + +Definition pickle_inv n := + obind (fun x : T => if pickle x == n then Some x else None) (unpickle n). + +Lemma pickle_invK : ocancel pickle_inv pickle. +Proof. +by rewrite /pickle_inv => n; case def_x: (unpickle n) => //= [x]; case: eqP. +Qed. + +Lemma pickleK_inv : pcancel pickle pickle_inv. +Proof. by rewrite /pickle_inv => x; rewrite pickleK /= eqxx. Qed. + +Lemma pcan_pickleK sT f f' : + @pcancel T sT f f' -> pcancel (pickle \o f) (pcomp f' unpickle). +Proof. by move=> fK x; rewrite /pcomp pickleK /= fK. Qed. + +Definition PcanCountMixin sT f f' (fK : pcancel f f') := + @CountMixin sT _ _ (pcan_pickleK fK). + +Definition CanCountMixin sT f f' (fK : cancel f f') := + @PcanCountMixin sT _ _ (can_pcan fK). + +Definition sub_countMixin P sT := PcanCountMixin (@valK T P sT). + +End CountableTheory. +Notation "[ 'countMixin' 'of' T 'by' <: ]" := + (sub_countMixin _ : Countable.mixin_of T) + (at level 0, format "[ 'countMixin' 'of' T 'by' <: ]") : form_scope. + +Section SubCountType. + +Variables (T : choiceType) (P : pred T). +Import Countable. + +Structure subCountType : Type := + SubCountType {subCount_sort :> subType P; _ : mixin_of subCount_sort}. + +Coercion sub_countType (sT : subCountType) := + Eval hnf in pack (let: SubCountType _ m := sT return mixin_of sT in m) id. +Canonical sub_countType. + +Definition pack_subCountType U := + fun sT cT & sub_sort sT * sort cT -> U * U => + fun b m & phant_id (Class b m) (class cT) => @SubCountType sT m. + +End SubCountType. + +(* This assumes that T has both countType and subType structures. *) +Notation "[ 'subCountType' 'of' T ]" := + (@pack_subCountType _ _ T _ _ id _ _ id) + (at level 0, format "[ 'subCountType' 'of' T ]") : form_scope. + +Lemma nat_pickleK : pcancel id (@Some nat). Proof. by []. Qed. +Definition nat_countMixin := CountMixin nat_pickleK. +Canonical nat_countType := Eval hnf in CountType nat nat_countMixin. + +(* fintype --------------------------------------------------------- *) + +Module Finite. + +Section RawMixin. + +Variable T : eqType. + +Definition axiom e := forall x : T, count_mem x e = 1. + +Lemma uniq_enumP e : uniq e -> e =i T -> axiom e. +Admitted. + +Record mixin_of := Mixin { + mixin_base : Countable.mixin_of T; + mixin_enum : seq T; + _ : axiom mixin_enum +}. + +End RawMixin. + +Section Mixins. + +Variable T : countType. + +Definition EnumMixin := + let: Countable.Pack _ (Countable.Class _ m) _ as cT := T + return forall e : seq cT, axiom e -> mixin_of cT in + @Mixin (EqType _ _) m. + +Definition UniqMixin e Ue eT := @EnumMixin e (uniq_enumP Ue eT). + +Variable n : nat. + +End Mixins. + +Section ClassDef. + +Record class_of T := Class { + base : Choice.class_of T; + mixin : mixin_of (Equality.Pack base T) +}. +Definition base2 T c := Countable.Class (@base T c) (mixin_base (mixin c)). +Local Coercion base : class_of >-> Choice.class_of. + +Structure type : Type := Pack {sort; _ : class_of sort; _ : Type}. +Local Coercion sort : type >-> Sortclass. +Variables (T : Type) (cT : type). +Definition class := let: Pack _ c _ as cT' := cT return class_of cT' in c. +Definition clone c of phant_id class c := @Pack T c T. +Let xT := let: Pack T _ _ := cT in T. +Notation xclass := (class : class_of xT). + +Definition pack b0 (m0 : mixin_of (EqType T b0)) := + fun bT b & phant_id (Choice.class bT) b => + fun m & phant_id m0 m => Pack (@Class T b m) T. + +Definition eqType := @Equality.Pack cT xclass xT. +Definition choiceType := @Choice.Pack cT xclass xT. +Definition countType := @Countable.Pack cT (base2 xclass) xT. + +End ClassDef. + +Module Import Exports. +Coercion mixin_base : mixin_of >-> Countable.mixin_of. +Coercion base : class_of >-> Choice.class_of. +Coercion mixin : class_of >-> mixin_of. +Coercion base2 : class_of >-> Countable.class_of. +Coercion sort : type >-> Sortclass. +Coercion eqType : type >-> Equality.type. +Canonical eqType. +Coercion choiceType : type >-> Choice.type. +Canonical choiceType. +Coercion countType : type >-> Countable.type. +Canonical countType. +Notation finType := type. +Notation FinType T m := (@pack T _ m _ _ id _ id). +Notation FinMixin := EnumMixin. +Notation UniqFinMixin := UniqMixin. +Notation "[ 'finType' 'of' T 'for' cT ]" := (@clone T cT _ idfun) + (at level 0, format "[ 'finType' 'of' T 'for' cT ]") : form_scope. +Notation "[ 'finType' 'of' T ]" := (@clone T _ _ id) + (at level 0, format "[ 'finType' 'of' T ]") : form_scope. +End Exports. + +Module Type EnumSig. +Parameter enum : forall cT : type, seq cT. +Axiom enumDef : enum = fun cT => mixin_enum (class cT). +End EnumSig. + +Module EnumDef : EnumSig. +Definition enum cT := mixin_enum (class cT). +Definition enumDef := erefl enum. +End EnumDef. + +Notation enum := EnumDef.enum. + +End Finite. +Export Finite.Exports. + +Section SubFinType. + +Variables (T : choiceType) (P : pred T). +Import Finite. + +Structure subFinType := SubFinType { + subFin_sort :> subType P; + _ : mixin_of (sub_eqType subFin_sort) +}. + +Definition pack_subFinType U := + fun cT b m & phant_id (class cT) (@Class U b m) => + fun sT m' & phant_id m' m => @SubFinType sT m'. + +Implicit Type sT : subFinType. + +Definition subFin_mixin sT := + let: SubFinType _ m := sT return mixin_of (sub_eqType sT) in m. + +Coercion subFinType_subCountType sT := @SubCountType _ _ sT (subFin_mixin sT). +Canonical subFinType_subCountType. + +Coercion subFinType_finType sT := + Pack (@Class sT (sub_choiceClass sT) (subFin_mixin sT)) sT. +Canonical subFinType_finType. + +Definition enum_mem T (mA : mem_pred _) := filter mA (Finite.enum T). +Definition image_mem T T' f mA : seq T' := map f (@enum_mem T mA). +Definition codom T T' f := @image_mem T T' f (mem T). + +Lemma codom_val sT x : (x \in codom (val : sT -> T)) = P x. +Admitted. + +End SubFinType. + + +(* This assumes that T has both finType and subCountType structures. *) +Notation "[ 'subFinType' 'of' T ]" := (@pack_subFinType _ _ T _ _ _ id _ _ id) + (at level 0, format "[ 'subFinType' 'of' T ]") : form_scope. + + + +Section OrdinalSub. + +Variable n : nat. + +Inductive ordinal : predArgType := Ordinal m of m < n. + +Coercion nat_of_ord i := let: Ordinal m _ := i in m. + +Canonical ordinal_subType := [subType for nat_of_ord]. +Definition ordinal_eqMixin := Eval hnf in [eqMixin of ordinal by <:]. +Canonical ordinal_eqType := Eval hnf in EqType ordinal ordinal_eqMixin. +Definition ordinal_choiceMixin := [choiceMixin of ordinal by <:]. +Canonical ordinal_choiceType := + Eval hnf in ChoiceType ordinal ordinal_choiceMixin. +Definition ordinal_countMixin := [countMixin of ordinal by <:]. +Canonical ordinal_countType := Eval hnf in CountType ordinal ordinal_countMixin. +Canonical ordinal_subCountType := [subCountType of ordinal]. + +Lemma ltn_ord (i : ordinal) : i < n. Proof. exact: valP i. Qed. + +Lemma ord_inj : injective nat_of_ord. Proof. exact: val_inj. Qed. + +Definition ord_enum : seq ordinal := pmap insub (iota 0 n). + +Lemma val_ord_enum : map val ord_enum = iota 0 n. +Admitted. + +Lemma ord_enum_uniq : uniq ord_enum. +Admitted. + +Lemma mem_ord_enum i : i \in ord_enum. +Admitted. + +Definition ordinal_finMixin := + Eval hnf in UniqFinMixin ord_enum_uniq mem_ord_enum. +Canonical ordinal_finType := Eval hnf in FinType ordinal ordinal_finMixin. +Canonical ordinal_subFinType := Eval hnf in [subFinType of ordinal]. + +End OrdinalSub. + +Notation "''I_' n" := (ordinal n) + (at level 8, n at level 2, format "''I_' n"). + +(* bigop ----------------------------------------------------------------- *) + +Reserved Notation "\big [ op / idx ]_ i F" + (at level 36, F at level 36, op, idx at level 10, i at level 0, + right associativity, + format "'[' \big [ op / idx ]_ i '/ ' F ']'"). +Reserved Notation "\big [ op / idx ]_ ( i <- r | P ) F" + (at level 36, F at level 36, op, idx at level 10, i, r at level 50, + format "'[' \big [ op / idx ]_ ( i <- r | P ) '/ ' F ']'"). +Reserved Notation "\big [ op / idx ]_ ( i <- r ) F" + (at level 36, F at level 36, op, idx at level 10, i, r at level 50, + format "'[' \big [ op / idx ]_ ( i <- r ) '/ ' F ']'"). +Reserved Notation "\big [ op / idx ]_ ( m <= i < n | P ) F" + (at level 36, F at level 36, op, idx at level 10, m, i, n at level 50, + format "'[' \big [ op / idx ]_ ( m <= i < n | P ) F ']'"). +Reserved Notation "\big [ op / idx ]_ ( m <= i < n ) F" + (at level 36, F at level 36, op, idx at level 10, i, m, n at level 50, + format "'[' \big [ op / idx ]_ ( m <= i < n ) '/ ' F ']'"). +Reserved Notation "\big [ op / idx ]_ ( i | P ) F" + (at level 36, F at level 36, op, idx at level 10, i at level 50, + format "'[' \big [ op / idx ]_ ( i | P ) '/ ' F ']'"). +Reserved Notation "\big [ op / idx ]_ ( i : t | P ) F" + (at level 36, F at level 36, op, idx at level 10, i at level 50, + format "'[' \big [ op / idx ]_ ( i : t | P ) '/ ' F ']'"). +Reserved Notation "\big [ op / idx ]_ ( i : t ) F" + (at level 36, F at level 36, op, idx at level 10, i at level 50, + format "'[' \big [ op / idx ]_ ( i : t ) '/ ' F ']'"). +Reserved Notation "\big [ op / idx ]_ ( i < n | P ) F" + (at level 36, F at level 36, op, idx at level 10, i, n at level 50, + format "'[' \big [ op / idx ]_ ( i < n | P ) '/ ' F ']'"). +Reserved Notation "\big [ op / idx ]_ ( i < n ) F" + (at level 36, F at level 36, op, idx at level 10, i, n at level 50, + format "'[' \big [ op / idx ]_ ( i < n ) F ']'"). +Reserved Notation "\big [ op / idx ]_ ( i 'in' A | P ) F" + (at level 36, F at level 36, op, idx at level 10, i, A at level 50, + format "'[' \big [ op / idx ]_ ( i 'in' A | P ) '/ ' F ']'"). +Reserved Notation "\big [ op / idx ]_ ( i 'in' A ) F" + (at level 36, F at level 36, op, idx at level 10, i, A at level 50, + format "'[' \big [ op / idx ]_ ( i 'in' A ) '/ ' F ']'"). + +Module Monoid. + +Section Definitions. +Variables (T : Type) (idm : T). + +Structure law := Law { + operator : T -> T -> T; + _ : associative operator; + _ : left_id idm operator; + _ : right_id idm operator +}. +Local Coercion operator : law >-> Funclass. + +Structure com_law := ComLaw { + com_operator : law; + _ : commutative com_operator +}. +Local Coercion com_operator : com_law >-> law. + +Structure mul_law := MulLaw { + mul_operator : T -> T -> T; + _ : left_zero idm mul_operator; + _ : right_zero idm mul_operator +}. +Local Coercion mul_operator : mul_law >-> Funclass. + +Structure add_law (mul : T -> T -> T) := AddLaw { + add_operator : com_law; + _ : left_distributive mul add_operator; + _ : right_distributive mul add_operator +}. +Local Coercion add_operator : add_law >-> com_law. + +Let op_id (op1 op2 : T -> T -> T) := phant_id op1 op2. + +Definition clone_law op := + fun (opL : law) & op_id opL op => + fun opmA op1m opm1 (opL' := @Law op opmA op1m opm1) + & phant_id opL' opL => opL'. + +Definition clone_com_law op := + fun (opL : law) (opC : com_law) & op_id opL op & op_id opC op => + fun opmC (opC' := @ComLaw opL opmC) & phant_id opC' opC => opC'. + +Definition clone_mul_law op := + fun (opM : mul_law) & op_id opM op => + fun op0m opm0 (opM' := @MulLaw op op0m opm0) & phant_id opM' opM => opM'. + +Definition clone_add_law mop aop := + fun (opC : com_law) (opA : add_law mop) & op_id opC aop & op_id opA aop => + fun mopDm mopmD (opA' := @AddLaw mop opC mopDm mopmD) + & phant_id opA' opA => opA'. + +End Definitions. + +Module Import Exports. +Coercion operator : law >-> Funclass. +Coercion com_operator : com_law >-> law. +Coercion mul_operator : mul_law >-> Funclass. +Coercion add_operator : add_law >-> com_law. +Notation "[ 'law' 'of' f ]" := (@clone_law _ _ f _ id _ _ _ id) + (at level 0, format"[ 'law' 'of' f ]") : form_scope. +Notation "[ 'com_law' 'of' f ]" := (@clone_com_law _ _ f _ _ id id _ id) + (at level 0, format "[ 'com_law' 'of' f ]") : form_scope. +Notation "[ 'mul_law' 'of' f ]" := (@clone_mul_law _ _ f _ id _ _ id) + (at level 0, format"[ 'mul_law' 'of' f ]") : form_scope. +Notation "[ 'add_law' m 'of' a ]" := (@clone_add_law _ _ m a _ _ id id _ _ id) + (at level 0, format "[ 'add_law' m 'of' a ]") : form_scope. +End Exports. + +Section CommutativeAxioms. + +Variable (T : Type) (zero one : T) (mul add : T -> T -> T) (inv : T -> T). +Hypothesis mulC : commutative mul. + +Lemma mulC_id : left_id one mul -> right_id one mul. +Proof. by move=> mul1x x; rewrite mulC. Qed. + +Lemma mulC_zero : left_zero zero mul -> right_zero zero mul. +Proof. by move=> mul0x x; rewrite mulC. Qed. + +Lemma mulC_dist : left_distributive mul add -> right_distributive mul add. +Proof. by move=> mul_addl x y z; rewrite !(mulC x). Qed. + +End CommutativeAxioms. +Module Theory. + +Section Theory. +Variables (T : Type) (idm : T). + +Section Plain. +Variable mul : law idm. +Lemma mul1m : left_id idm mul. Proof. by case mul. Qed. +Lemma mulm1 : right_id idm mul. Proof. by case mul. Qed. +Lemma mulmA : associative mul. Proof. by case mul. Qed. +(*Lemma iteropE n x : iterop n mul x idm = iter n (mul x) idm.*) + +End Plain. + +Section Commutative. +Variable mul : com_law idm. +Lemma mulmC : commutative mul. Proof. by case mul. Qed. +Lemma mulmCA : left_commutative mul. +Proof. by move=> x y z; rewrite !mulmA (mulmC x). Qed. +Lemma mulmAC : right_commutative mul. +Proof. by move=> x y z; rewrite -!mulmA (mulmC y). Qed. +Lemma mulmACA : interchange mul mul. +Proof. by move=> x y z t; rewrite -!mulmA (mulmCA y). Qed. +End Commutative. + +Section Mul. +Variable mul : mul_law idm. +Lemma mul0m : left_zero idm mul. Proof. by case mul. Qed. +Lemma mulm0 : right_zero idm mul. Proof. by case mul. Qed. +End Mul. + +Section Add. +Variables (mul : T -> T -> T) (add : add_law idm mul). +Lemma addmA : associative add. Proof. exact: mulmA. Qed. +Lemma addmC : commutative add. Proof. exact: mulmC. Qed. +Lemma addmCA : left_commutative add. Proof. exact: mulmCA. Qed. +Lemma addmAC : right_commutative add. Proof. exact: mulmAC. Qed. +Lemma add0m : left_id idm add. Proof. exact: mul1m. Qed. +Lemma addm0 : right_id idm add. Proof. exact: mulm1. Qed. +Lemma mulm_addl : left_distributive mul add. Proof. by case add. Qed. +Lemma mulm_addr : right_distributive mul add. Proof. by case add. Qed. +End Add. + +Definition simpm := (mulm1, mulm0, mul1m, mul0m, mulmA). + +End Theory. + +End Theory. +Include Theory. + +End Monoid. +Export Monoid.Exports. + +Section PervasiveMonoids. + +Import Monoid. + +Canonical andb_monoid := Law andbA andTb andbT. +Canonical andb_comoid := ComLaw andbC. + +Canonical andb_muloid := MulLaw andFb andbF. +Canonical orb_monoid := Law orbA orFb orbF. +Canonical orb_comoid := ComLaw orbC. +Canonical orb_muloid := MulLaw orTb orbT. +Canonical addb_monoid := Law addbA addFb addbF. +Canonical addb_comoid := ComLaw addbC. +Canonical orb_addoid := AddLaw andb_orl andb_orr. +Canonical andb_addoid := AddLaw orb_andl orb_andr. +Canonical addb_addoid := AddLaw andb_addl andb_addr. + +Canonical addn_monoid := Law addnA add0n addn0. +Canonical addn_comoid := ComLaw addnC. +Canonical muln_monoid := Law mulnA mul1n muln1. +Canonical muln_comoid := ComLaw mulnC. +Canonical muln_muloid := MulLaw mul0n muln0. +Canonical addn_addoid := AddLaw mulnDl mulnDr. + +Canonical cat_monoid T := Law (@catA T) (@cat0s T) (@cats0 T). + +End PervasiveMonoids. +Delimit Scope big_scope with BIG. +Open Scope big_scope. + +(* The bigbody wrapper is a workaround for a quirk of the Coq pretty-printer, *) +(* which would fail to redisplay the \big notation when the <general_term> or *) +(* <condition> do not depend on the bound index. The BigBody constructor *) +(* packages both in in a term in which i occurs; it also depends on the *) +(* iterated <op>, as this can give more information on the expected type of *) +(* the <general_term>, thus allowing for the insertion of coercions. *) +CoInductive bigbody R I := BigBody of I & (R -> R -> R) & bool & R. + +Definition applybig {R I} (body : bigbody R I) x := + let: BigBody _ op b v := body in if b then op v x else x. + +Definition reducebig R I idx r (body : I -> bigbody R I) := + foldr (applybig \o body) idx r. + +Module Type BigOpSig. +Parameter bigop : forall R I, R -> seq I -> (I -> bigbody R I) -> R. +Axiom bigopE : bigop = reducebig. +End BigOpSig. + +Module BigOp : BigOpSig. +Definition bigop := reducebig. +Lemma bigopE : bigop = reducebig. Proof. by []. Qed. +End BigOp. + +Notation bigop := BigOp.bigop (only parsing). +Canonical bigop_unlock := Unlockable BigOp.bigopE. + +Definition index_iota m n := iota m (n - m). + +Definition index_enum (T : finType) := Finite.enum T. + +Lemma mem_index_iota m n i : i \in index_iota m n = (m <= i < n). +Admitted. + +Lemma mem_index_enum T i : i \in index_enum T. +Admitted. + +Hint Resolve mem_index_enum. + +(* +Lemma filter_index_enum T P : filter P (index_enum T) = enum P. +Proof. by []. Qed. +*) + +Notation "\big [ op / idx ]_ ( i <- r | P ) F" := + (bigop idx r (fun i => BigBody i op P%B F)) : big_scope. +Notation "\big [ op / idx ]_ ( i <- r ) F" := + (bigop idx r (fun i => BigBody i op true F)) : big_scope. +Notation "\big [ op / idx ]_ ( m <= i < n | P ) F" := + (bigop idx (index_iota m n) (fun i : nat => BigBody i op P%B F)) + : big_scope. +Notation "\big [ op / idx ]_ ( m <= i < n ) F" := + (bigop idx (index_iota m n) (fun i : nat => BigBody i op true F)) + : big_scope. +Notation "\big [ op / idx ]_ ( i | P ) F" := + (bigop idx (index_enum _) (fun i => BigBody i op P%B F)) : big_scope. +Notation "\big [ op / idx ]_ i F" := + (bigop idx (index_enum _) (fun i => BigBody i op true F)) : big_scope. +Notation "\big [ op / idx ]_ ( i : t | P ) F" := + (bigop idx (index_enum _) (fun i : t => BigBody i op P%B F)) + (only parsing) : big_scope. +Notation "\big [ op / idx ]_ ( i : t ) F" := + (bigop idx (index_enum _) (fun i : t => BigBody i op true F)) + (only parsing) : big_scope. +Notation "\big [ op / idx ]_ ( i < n | P ) F" := + (\big[op/idx]_(i : ordinal n | P%B) F) : big_scope. +Notation "\big [ op / idx ]_ ( i < n ) F" := + (\big[op/idx]_(i : ordinal n) F) : big_scope. +Notation "\big [ op / idx ]_ ( i 'in' A | P ) F" := + (\big[op/idx]_(i | (i \in A) && P) F) : big_scope. +Notation "\big [ op / idx ]_ ( i 'in' A ) F" := + (\big[op/idx]_(i | i \in A) F) : big_scope. + +Notation BIG_F := (F in \big[_/_]_(i <- _ | _) F i)%pattern. +Notation BIG_P := (P in \big[_/_]_(i <- _ | P i) _)%pattern. + +(* Induction loading *) +Lemma big_load R (K K' : R -> Type) idx op I r (P : pred I) F : + K (\big[op/idx]_(i <- r | P i) F i) * K' (\big[op/idx]_(i <- r | P i) F i) + -> K' (\big[op/idx]_(i <- r | P i) F i). +Proof. by case. Qed. + +Arguments big_load [R] K [K'] idx op [I]. + +Section Elim3. + +Variables (R1 R2 R3 : Type) (K : R1 -> R2 -> R3 -> Type). +Variables (id1 : R1) (op1 : R1 -> R1 -> R1). +Variables (id2 : R2) (op2 : R2 -> R2 -> R2). +Variables (id3 : R3) (op3 : R3 -> R3 -> R3). + +Hypothesis Kid : K id1 id2 id3. + +Lemma big_rec3 I r (P : pred I) F1 F2 F3 + (K_F : forall i y1 y2 y3, P i -> K y1 y2 y3 -> + K (op1 (F1 i) y1) (op2 (F2 i) y2) (op3 (F3 i) y3)) : + K (\big[op1/id1]_(i <- r | P i) F1 i) + (\big[op2/id2]_(i <- r | P i) F2 i) + (\big[op3/id3]_(i <- r | P i) F3 i). +Proof. by rewrite unlock; elim: r => //= i r; case: ifP => //; apply: K_F. Qed. + +Hypothesis Kop : forall x1 x2 x3 y1 y2 y3, + K x1 x2 x3 -> K y1 y2 y3-> K (op1 x1 y1) (op2 x2 y2) (op3 x3 y3). +Lemma big_ind3 I r (P : pred I) F1 F2 F3 + (K_F : forall i, P i -> K (F1 i) (F2 i) (F3 i)) : + K (\big[op1/id1]_(i <- r | P i) F1 i) + (\big[op2/id2]_(i <- r | P i) F2 i) + (\big[op3/id3]_(i <- r | P i) F3 i). +Proof. by apply: big_rec3 => i x1 x2 x3 /K_F; apply: Kop. Qed. + +End Elim3. + +Arguments big_rec3 [R1 R2 R3] K [id1 op1 id2 op2 id3 op3] _ [I r P F1 F2 F3]. +Arguments big_ind3 [R1 R2 R3] K [id1 op1 id2 op2 id3 op3] _ _ [I r P F1 F2 F3]. + +Section Elim2. + +Variables (R1 R2 : Type) (K : R1 -> R2 -> Type) (f : R2 -> R1). +Variables (id1 : R1) (op1 : R1 -> R1 -> R1). +Variables (id2 : R2) (op2 : R2 -> R2 -> R2). + +Hypothesis Kid : K id1 id2. + +Lemma big_rec2 I r (P : pred I) F1 F2 + (K_F : forall i y1 y2, P i -> K y1 y2 -> + K (op1 (F1 i) y1) (op2 (F2 i) y2)) : + K (\big[op1/id1]_(i <- r | P i) F1 i) (\big[op2/id2]_(i <- r | P i) F2 i). +Proof. by rewrite unlock; elim: r => //= i r; case: ifP => //; apply: K_F. Qed. + +Hypothesis Kop : forall x1 x2 y1 y2, + K x1 x2 -> K y1 y2 -> K (op1 x1 y1) (op2 x2 y2). +Lemma big_ind2 I r (P : pred I) F1 F2 (K_F : forall i, P i -> K (F1 i) (F2 i)) : + K (\big[op1/id1]_(i <- r | P i) F1 i) (\big[op2/id2]_(i <- r | P i) F2 i). +Proof. by apply: big_rec2 => i x1 x2 /K_F; apply: Kop. Qed. + +Hypotheses (f_op : {morph f : x y / op2 x y >-> op1 x y}) (f_id : f id2 = id1). +Lemma big_morph I r (P : pred I) F : + f (\big[op2/id2]_(i <- r | P i) F i) = \big[op1/id1]_(i <- r | P i) f (F i). +Proof. by rewrite unlock; elim: r => //= i r <-; rewrite -f_op -fun_if. Qed. + +End Elim2. + +Arguments big_rec2 [R1 R2] K [id1 op1 id2 op2] _ [I r P F1 F2]. +Arguments big_ind2 [R1 R2] K [id1 op1 id2 op2] _ _ [I r P F1 F2]. +Arguments big_morph [R1 R2] f [id1 op1 id2 op2] _ _ [I]. + +Section Elim1. + +Variables (R : Type) (K : R -> Type) (f : R -> R). +Variables (idx : R) (op op' : R -> R -> R). + +Hypothesis Kid : K idx. + +Lemma big_rec I r (P : pred I) F + (Kop : forall i x, P i -> K x -> K (op (F i) x)) : + K (\big[op/idx]_(i <- r | P i) F i). +Proof. by rewrite unlock; elim: r => //= i r; case: ifP => //; apply: Kop. Qed. + +Hypothesis Kop : forall x y, K x -> K y -> K (op x y). +Lemma big_ind I r (P : pred I) F (K_F : forall i, P i -> K (F i)) : + K (\big[op/idx]_(i <- r | P i) F i). +Proof. by apply: big_rec => // i x /K_F /Kop; apply. Qed. + +Hypothesis Kop' : forall x y, K x -> K y -> op x y = op' x y. +Lemma eq_big_op I r (P : pred I) F (K_F : forall i, P i -> K (F i)) : + \big[op/idx]_(i <- r | P i) F i = \big[op'/idx]_(i <- r | P i) F i. +Proof. +by elim/(big_load K): _; elim/big_rec2: _ => // i _ y Pi [Ky <-]; auto. +Qed. + +Hypotheses (fM : {morph f : x y / op x y}) (f_id : f idx = idx). +Lemma big_endo I r (P : pred I) F : + f (\big[op/idx]_(i <- r | P i) F i) = \big[op/idx]_(i <- r | P i) f (F i). +Proof. exact: big_morph. Qed. + +End Elim1. + +Arguments big_rec [R] K [idx op] _ [I r P F]. +Arguments big_ind [R] K [idx op] _ _ [I r P F]. +Arguments eq_big_op [R] K [idx op] op' _ _ _ [I]. +Arguments big_endo [R] f [idx op] _ _ [I]. + +(* zmodp -------------------------------------------------------------------- *) + +Lemma ord1 : all_equal_to (@Ordinal 1 0 is_true_true : 'I_1). +Admitted. diff --git a/test-suite/prerequisite/ssr_ssrsyntax1.v b/test-suite/prerequisite/ssr_ssrsyntax1.v new file mode 100644 index 000000000..2b404e2de --- /dev/null +++ b/test-suite/prerequisite/ssr_ssrsyntax1.v @@ -0,0 +1,36 @@ +(************************************************************************) +(* * 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) *) +(************************************************************************) + +(* (c) Copyright 2006-2016 Microsoft Corporation and Inria. *) + +Require ssreflect. +Require Import Arith. + +Goal (forall a b, a + b = b + a). +intros. +rewrite plus_comm, plus_comm. +split. +Abort. + +Module Foo. +Import ssreflect. + +Goal (forall a b, a + b = b + a). +intros. +rewrite 2![_ + _]plus_comm. +split. +Abort. +End Foo. + +Goal (forall a b, a + b = b + a). +intros. +rewrite plus_comm, plus_comm. +split. +Abort. diff --git a/test-suite/save-logs.sh b/test-suite/save-logs.sh index b61362108..9b8fff09f 100755 --- a/test-suite/save-logs.sh +++ b/test-suite/save-logs.sh @@ -9,7 +9,7 @@ mkdir "$SAVEDIR" # keep this synced with test-suite/Makefile FAILMARK="==========> FAILURE <==========" -FAILED=$(mktemp /tmp/coq-check-XXXXX) +FAILED=$(mktemp /tmp/coq-check-XXXXXX) find . '(' -path ./bugs/opened -prune ')' -o '(' -name '*.log' -exec grep "$FAILMARK" -q '{}' ';' -print0 ')' > "$FAILED" rsync -a --from0 --files-from="$FAILED" . "$SAVEDIR" diff --git a/test-suite/ssr/absevarprop.v b/test-suite/ssr/absevarprop.v new file mode 100644 index 000000000..fa1de0095 --- /dev/null +++ b/test-suite/ssr/absevarprop.v @@ -0,0 +1,96 @@ +(************************************************************************) +(* * 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) *) +(************************************************************************) + +(* (c) Copyright 2006-2016 Microsoft Corporation and Inria. *) + +Require Import ssreflect ssrbool ssrfun. +Require Import TestSuite.ssr_mini_mathcomp. + +Lemma test15: forall (y : nat) (x : 'I_2), y < 1 -> val x = y -> Some x = insub y. +move=> y x le_1 defx; rewrite insubT ?(leq_trans le_1) // => ?. +by congr (Some _); apply: val_inj=> /=; exact: defx. +Qed. + +Axiom P : nat -> Prop. +Axiom Q : forall n, P n -> Prop. +Definition R := fun (x : nat) (p : P x) m (q : P (x+1)) => m > 0. + +Inductive myEx : Type := ExI : forall n (pn : P n) pn', Q n pn -> R n pn n pn' -> myEx. + +Variable P1 : P 1. +Variable P11 : P (1 + 1). +Variable Q1 : forall P1, Q 1 P1. + +Lemma testmE1 : myEx. +Proof. +apply: ExI 1 _ _ _ _. + match goal with |- P 1 => exact: P1 | _ => fail end. + match goal with |- P (1+1) => exact: P11 | _ => fail end. + match goal with |- forall p : P 1, Q 1 p => move=> *; exact: Q1 | _ => fail end. +match goal with |- forall (p : P 1) (q : P (1+1)), is_true (R 1 p 1 q) => done | _ => fail end. +Qed. + +Lemma testE2 : exists y : { x | P x }, sval y = 1. +Proof. +apply: ex_intro (exist _ 1 _) _. + match goal with |- P 1 => exact: P1 | _ => fail end. +match goal with |- forall p : P 1, @sval _ _ (@exist _ _ 1 p) = 1 => done | _ => fail end. +Qed. + +Lemma testE3 : exists y : { x | P x }, sval y = 1. +Proof. +have := (ex_intro _ (exist _ 1 _) _); apply. + match goal with |- P 1 => exact: P1 | _ => fail end. +match goal with |- forall p : P 1, @sval _ _ (@exist _ _ 1 p) = 1 => done | _ => fail end. +Qed. + +Lemma testE4 : P 2 -> exists y : { x | P x }, sval y = 2. +Proof. +move=> P2; apply: ex_intro (exist _ 2 _) _. +match goal with |- @sval _ _ (@exist _ _ 2 P2) = 2 => done | _ => fail end. +Qed. + +Hint Resolve P1. + +Lemma testmE12 : myEx. +Proof. +apply: ExI 1 _ _ _ _. + match goal with |- P (1+1) => exact: P11 | _ => fail end. + match goal with |- Q 1 P1 => exact: Q1 | _ => fail end. +match goal with |- forall (q : P (1+1)), is_true (R 1 P1 1 q) => done | _ => fail end. +Qed. + +Create HintDb SSR. + +Hint Resolve P11 : SSR. + +Ltac ssrautoprop := trivial with SSR. + +Lemma testmE13 : myEx. +Proof. +apply: ExI 1 _ _ _ _. + match goal with |- Q 1 P1 => exact: Q1 | _ => fail end. +match goal with |- is_true (R 1 P1 1 P11) => done | _ => fail end. +Qed. + +Definition R1 := fun (x : nat) (p : P x) m (q : P (x+1)) (r : Q x p) => m > 0. + +Inductive myEx1 : Type := + ExI1 : forall n (pn : P n) pn' (q : Q n pn), R1 n pn n pn' q -> myEx1. + +Hint Resolve (Q1 P1) : SSR. + +(* tests that goals in prop are solved in the right order, propagating instantiations, + thus the goal Q 1 ?p1 is faced by trivial after ?p1, and is thus evar free *) +Lemma testmE14 : myEx1. +Proof. +apply: ExI1 1 _ _ _ _. +match goal with |- is_true (R1 1 P1 1 P11 (Q1 P1)) => done | _ => fail end. +Qed. diff --git a/test-suite/ssr/abstract_var2.v b/test-suite/ssr/abstract_var2.v new file mode 100644 index 000000000..7c57d2024 --- /dev/null +++ b/test-suite/ssr/abstract_var2.v @@ -0,0 +1,25 @@ +(************************************************************************) +(* * 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) *) +(************************************************************************) + +Require Import ssreflect. + +Set Implicit Arguments. + +Axiom P : nat -> nat -> Prop. + +Axiom tr : + forall x y z, P x y -> P y z -> P x z. + +Lemma test a b c : P a c -> P a b. +Proof. +intro H. +Fail have [: s1 s2] H1 : P a b := @tr _ _ _ s1 s2. +have [: w s1 s2] H1 : P a b := @tr _ w _ s1 s2. +Abort. diff --git a/test-suite/ssr/binders.v b/test-suite/ssr/binders.v new file mode 100644 index 000000000..97b7d830f --- /dev/null +++ b/test-suite/ssr/binders.v @@ -0,0 +1,55 @@ +(************************************************************************) +(* * 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) *) +(************************************************************************) + +(* (c) Copyright 2006-2016 Microsoft Corporation and Inria. *) + +Require Import ssreflect. +Require Import ssrbool TestSuite.ssr_mini_mathcomp. + +Lemma test (x : bool) : True. +have H1 x := x. +have (x) := x => H2. +have H3 T (x : T) := x. +have ? : bool := H1 _ x. +have ? : bool := H2 _ x. +have ? : bool := H3 _ x. +have ? (z : bool) : forall y : bool, z = z := fun y => refl_equal _. +have ? w : w = w := @refl_equal nat w. +have ? y : true by []. +have ? (z : bool) : z = z. + exact: (@refl_equal _ z). +have ? (z w : bool) : z = z by exact: (@refl_equal _ z). +have H w (a := 3) (_ := 4) : w && true = w. + by rewrite andbT. +exact I. +Qed. + +Lemma test1 : True. +suff (x : bool): x = x /\ True. + by move/(_ true); case=> _. +split; first by exact: (@refl_equal _ x). +suff H y : y && true = y /\ True. + by case: (H true). +suff H1 /= : true && true /\ True. + by rewrite andbT; split; [exact: (@refl_equal _ y) | exact: I]. +match goal with |- is_true true /\ True => idtac end. +by split. +Qed. + +Lemma foo n : n >= 0. +have f i (j := i + n) : j < n. + match goal with j := i + n |- _ => idtac end. +Undo 2. +suff f i (j := i + n) : j < n. + done. +match goal with j := i + n |- _ => idtac end. +Undo 3. +done. +Qed. diff --git a/test-suite/ssr/binders_of.v b/test-suite/ssr/binders_of.v new file mode 100644 index 000000000..69b52eace --- /dev/null +++ b/test-suite/ssr/binders_of.v @@ -0,0 +1,23 @@ +(************************************************************************) +(* * 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) *) +(************************************************************************) + +(* (c) Copyright 2006-2016 Microsoft Corporation and Inria. *) + + +Require Import ssreflect. +Require Import TestSuite.ssr_mini_mathcomp. + +Lemma test1 : True. +have f of seq nat & nat : nat. + exact 3. +have g of nat := 3. +have h of nat : nat := 3. +have _ : f [::] 3 = g 3 + h 4. +Admitted. diff --git a/test-suite/ssr/caseview.v b/test-suite/ssr/caseview.v new file mode 100644 index 000000000..94b064b02 --- /dev/null +++ b/test-suite/ssr/caseview.v @@ -0,0 +1,17 @@ +(************************************************************************) +(* * 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) *) +(************************************************************************) + +(* (c) Copyright 2006-2016 Microsoft Corporation and Inria. *) + +Require Import ssreflect. + + +Lemma test (A B : Prop) : A /\ B -> True. +Proof. by case=> _ /id _. Qed. diff --git a/test-suite/ssr/congr.v b/test-suite/ssr/congr.v new file mode 100644 index 000000000..7e60b04a6 --- /dev/null +++ b/test-suite/ssr/congr.v @@ -0,0 +1,34 @@ +(************************************************************************) +(* * 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) *) +(************************************************************************) + +(* (c) Copyright 2006-2016 Microsoft Corporation and Inria. *) + +Require Import ssreflect. +Require Import ssrbool TestSuite.ssr_mini_mathcomp. + +Lemma test1 : forall a b : nat, a == b -> a == 0 -> b == 0. +Proof. move=> a b Eab Eac; congr (_ == 0) : Eac; exact: eqP Eab. Qed. + +Definition arrow A B := A -> B. + +Lemma test2 : forall a b : nat, a == b -> arrow (a == 0) (b == 0). +Proof. move=> a b Eab; congr (_ == 0); exact: eqP Eab. Qed. + +Definition equals T (A B : T) := A = B. + +Lemma test3 : forall a b : nat, a = b -> equals nat (a + b) (b + b). +Proof. move=> a b E; congr (_ + _); exact E. Qed. + +Variable S : eqType. +Variable f : nat -> S. +Coercion f : nat >-> Equality.sort. + +Lemma test4 : forall a b : nat, b = a -> @eq S (b + b) (a + a). +Proof. move=> a b Eba; congr (_ + _); exact: Eba. Qed. diff --git a/test-suite/ssr/deferclear.v b/test-suite/ssr/deferclear.v new file mode 100644 index 000000000..85353dadf --- /dev/null +++ b/test-suite/ssr/deferclear.v @@ -0,0 +1,37 @@ +(************************************************************************) +(* * 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) *) +(************************************************************************) + +(* (c) Copyright 2006-2016 Microsoft Corporation and Inria. *) + +Require Import ssreflect. + +Require Import ssrbool TestSuite.ssr_mini_mathcomp. + +Variable T : Type. + +Lemma test0 : forall a b c d : T, True. +Proof. by move=> a b {a} a c; exact I. Qed. + +Variable P : T -> Prop. + +Lemma test1 : forall a b c : T, P a -> forall d : T, True. +Proof. move=> a b {a} a _ d; exact I. Qed. + +Definition Q := forall x y : nat, x = y. +Axiom L : 0 = 0 -> Q. +Axiom L' : 0 = 0 -> forall x y : nat, x = y. +Lemma test3 : Q. +by apply/L. +Undo. +rewrite /Q. +by apply/L. +Undo 2. +by apply/L'. +Qed. diff --git a/test-suite/ssr/dependent_type_err.v b/test-suite/ssr/dependent_type_err.v new file mode 100644 index 000000000..a5789d8dd --- /dev/null +++ b/test-suite/ssr/dependent_type_err.v @@ -0,0 +1,20 @@ +(************************************************************************) +(* * 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) *) +(************************************************************************) + +(* (c) Copyright 2006-2016 Microsoft Corporation and Inria. *) + +Require Import ssreflect. +Require Import ssrfun ssrbool TestSuite.ssr_mini_mathcomp. + +Lemma ltn_leq_trans : forall n m p : nat, m < n -> n <= p -> m < p. +move=> n m p Hmn Hnp; rewrite -ltnS. +Fail rewrite (_ : forall n0 m0 p0 : nat, m0 <= n0 -> n0 < p0 -> m0 < p0). +Fail rewrite leq_ltn_trans. +Admitted. diff --git a/test-suite/ssr/derive_inversion.v b/test-suite/ssr/derive_inversion.v new file mode 100644 index 000000000..abf63a20c --- /dev/null +++ b/test-suite/ssr/derive_inversion.v @@ -0,0 +1,29 @@ +(************************************************************************) +(* * 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) *) +(************************************************************************) + +Require Import ssreflect ssrbool. + +Set Implicit Arguments. + + Inductive wf T : bool -> option T -> Type := + | wf_f : wf false None + | wf_t : forall x, wf true (Some x). + + Derive Inversion wf_inv with (forall T b (o : option T), wf b o) Sort Prop. + + Lemma Problem T b (o : option T) : + wf b o -> + match b with + | true => exists x, o = Some x + | false => o = None + end. + Proof. + by case: b; elim/wf_inv=> //; case: o=> // a *; exists a. + Qed. diff --git a/test-suite/ssr/elim.v b/test-suite/ssr/elim.v new file mode 100644 index 000000000..908249a36 --- /dev/null +++ b/test-suite/ssr/elim.v @@ -0,0 +1,279 @@ +(************************************************************************) +(* * 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) *) +(************************************************************************) + +(* (c) Copyright 2006-2016 Microsoft Corporation and Inria. *) + +Require Import ssreflect. +Require Import ssrbool ssrfun TestSuite.ssr_mini_mathcomp. +Axiom daemon : False. Ltac myadmit := case: daemon. + +(* Ltac debugging feature: recursive elim + eq generation *) +Lemma testL1 : forall A (s : seq A), s = s. +Proof. +move=> A s; elim branch: s => [|x xs _]. +match goal with _ : _ = [::] |- [::] = [::] => move: branch => // | _ => fail end. +match goal with _ : _ = _ :: _ |- _ :: _ = _ :: _ => move: branch => // | _ => fail end. +Qed. + +(* The same but with explicit eliminator and a conflict in the intro pattern *) +Lemma testL2 : forall A (s : seq A), s = s. +Proof. +move=> A s; elim/last_ind branch: s => [|x s _]. +match goal with _ : _ = [::] |- [::] = [::] => move: branch => // | _ => fail end. +match goal with _ : _ = rcons _ _ |- rcons _ _ = rcons _ _ => move: branch => // | _ => fail end. +Qed. + +(* The same but without names for variables involved in the generated eq *) +Lemma testL3 : forall A (s : seq A), s = s. +Proof. +move=> A s; elim branch: s; move: (s) => _. +match goal with _ : _ = [::] |- [::] = [::] => move: branch => // | _ => fail end. +move=> _; match goal with _ : _ = _ :: _ |- _ :: _ = _ :: _ => move: branch => // | _ => fail end. +Qed. + +Inductive foo : Type := K1 : foo | K2 : foo -> foo -> foo | K3 : (nat -> foo) -> foo. + +(* The same but with more intros to be done *) +Lemma testL4 : forall (o : foo), o = o. +Proof. +move=> o; elim branch: o. +match goal with _ : _ = K1 |- K1 = K1 => move: branch => // | _ => fail end. +move=> _; match goal with _ : _ = K2 _ _ |- K2 _ _ = K2 _ _ => move: branch => // | _ => fail end. +move=> _; match goal with _ : _ = K3 _ |- K3 _ = K3 _ => move: branch => // | _ => fail end. +Qed. + +(* Occurrence counting *) +Lemma testO1: forall (b : bool), b = b. +Proof. +move=> b; case: (b) / idP. +match goal with |- is_true b -> true = true => done | _ => fail end. +match goal with |- ~ is_true b -> false = false => done | _ => fail end. +Qed. + +(* The same but only the second occ *) +Lemma testO2: forall (b : bool), b = b. +Proof. +move=> b; case: {2}(b) / idP. +match goal with |- is_true b -> b = true => done | _ => fail end. +match goal with |- ~ is_true b -> b = false => move/(introF idP) => // | _ => fail end. +Qed. + +(* The same but with eq generation *) +Lemma testO3: forall (b : bool), b = b. +Proof. +move=> b; case E: {2}(b) / idP. +match goal with _ : is_true b, _ : b = true |- b = true => move: E => _; done | _ => fail end. +match goal with H : ~ is_true b, _ : b = false |- b = false => move: E => _; move/(introF idP): H => // | _ => fail end. +Qed. + +(* Views *) +Lemma testV1 : forall A (s : seq A), s = s. +Proof. +move=> A s; case/lastP E: {1}s => [| x xs]. +match goal with _ : s = [::] |- [::] = s => symmetry; exact E | _ => fail end. +match goal with _ : s = rcons x xs |- rcons _ _ = s => symmetry; exact E | _ => fail end. +Qed. + +Lemma testV2 : forall A (s : seq A), s = s. +Proof. +move=> A s; case/lastP E: s => [| x xs]. +match goal with _ : s = [::] |- [::] = [::] => done | _ => fail end. +match goal with _ : s = rcons x xs |- rcons _ _ = rcons _ _ => done | _ => fail end. +Qed. + +Lemma testV3 : forall A (s : seq A), s = s. +Proof. +move=> A s; case/lastP: s => [| x xs]. +match goal with |- [::] = [::] => done | _ => fail end. +match goal with |- rcons _ _ = rcons _ _ => done | _ => fail end. +Qed. + +(* Patterns *) +Lemma testP1: forall (x y : nat), (y == x) && (y == x) -> y == x. +move=> x y; elim: {2}(_ == _) / eqP. +match goal with |- (y = x -> is_true ((y == x) && true) -> is_true (y == x)) => move=> -> // | _ => fail end. +match goal with |- (y <> x -> is_true ((y == x) && false) -> is_true (y == x)) => move=> _; rewrite andbC // | _ => fail end. +Qed. + +(* The same but with an implicit pattern *) +Lemma testP2 : forall (x y : nat), (y == x) && (y == x) -> y == x. +move=> x y; elim: {2}_ / eqP. +match goal with |- (y = x -> is_true ((y == x) && true) -> is_true (y == x)) => move=> -> // | _ => fail end. +match goal with |- (y <> x -> is_true ((y == x) && false) -> is_true (y == x)) => move=> _; rewrite andbC // | _ => fail end. +Qed. + +(* The same but with an eq generation switch *) +Lemma testP3 : forall (x y : nat), (y == x) && (y == x) -> y == x. +move=> x y; elim E: {2}_ / eqP. +match goal with _ : y = x |- (is_true ((y == x) && true) -> is_true (y == x)) => rewrite E; reflexivity | _ => fail end. +match goal with _ : y <> x |- (is_true ((y == x) && false) -> is_true (y == x)) => rewrite E => /= H; exact H | _ => fail end. +Qed. + +Inductive spec : nat -> nat -> nat -> Prop := +| specK : forall a b c, a = 0 -> b = 2 -> c = 4 -> spec a b c. +Lemma specP : spec 0 2 4. Proof. by constructor. Qed. + +Lemma testP4 : (1+1) * 4 = 2 + (1+1) + (2 + 2). +Proof. +case: specP => a b c defa defb defc. +match goal with |- (a.+1 + a.+1) * c = b + (a.+1 + a.+1) + (b + b) => subst; done | _ => fail end. +Qed. + +Lemma testP5 : (1+1) * 4 = 2 + (1+1) + (2 + 2). +Proof. +case: (1 + 1) _ / specP => a b c defa defb defc. +match goal with |- b * c = a.+2 + b + (a.+2 + a.+2) => subst; done | _ => fail end. +Qed. + +Lemma testP6 : (1+1) * 4 = 2 + (1+1) + (2 + 2). +Proof. +case: {2}(1 + 1) _ / specP => a b c defa defb defc. +match goal with |- (a.+1 + a.+1) * c = a.+2 + b + (a.+2 + a.+2) => subst; done | _ => fail end. +Qed. + +Lemma testP7 : (1+1) * 4 = 2 + (1+1) + (2 + 2). +Proof. +case: _ (1 + 1) (2 + _) / specP => a b c defa defb defc. +match goal with |- b * a.+4 = c + c => subst; done | _ => fail end. +Qed. + +Lemma testP8 : (1+1) * 4 = 2 + (1+1) + (2 + 2). +Proof. +case E: (1 + 1) (2 + _) / specP=> [a b c defa defb defc]. +match goal with |- b * a.+4 = c + c => subst; done | _ => fail end. +Qed. + +Variables (T : Type) (tr : T -> T). + +Inductive exec (cf0 cf1 : T) : seq T -> Prop := +| exec_step : tr cf0 = cf1 -> exec cf0 cf1 [::] +| exec_star : forall cf2 t, tr cf0 = cf2 -> + exec cf2 cf1 t -> exec cf0 cf1 (cf2 :: t). + +Inductive execr (cf0 cf1 : T) : seq T -> Prop := +| execr_step : tr cf0 = cf1 -> execr cf0 cf1 [::] +| execr_star : forall cf2 t, execr cf0 cf2 t -> + tr cf2 = cf1 -> execr cf0 cf1 (t ++ [:: cf2]). + +Lemma execP : forall cf0 cf1 t, exec cf0 cf1 t <-> execr cf0 cf1 t. +Proof. +move=> cf0 cf1 t; split => [] Ecf. + elim: Ecf. + match goal with |- forall cf2 cf3 : T, tr cf2 = cf3 -> + execr cf2 cf3 [::] => myadmit | _ => fail end. + match goal with |- forall (cf2 cf3 cf4 : T) (t0 : seq T), + tr cf2 = cf4 -> exec cf4 cf3 t0 -> execr cf4 cf3 t0 -> + execr cf2 cf3 (cf4 :: t0) => myadmit | _ => fail end. +elim: Ecf. + match goal with |- forall cf2 : T, + tr cf0 = cf2 -> exec cf0 cf2 [::] => myadmit | _ => fail end. +match goal with |- forall (cf2 cf3 : T) (t0 : seq T), + execr cf0 cf3 t0 -> exec cf0 cf3 t0 -> tr cf3 = cf2 -> + exec cf0 cf2 (t0 ++ [:: cf3]) => myadmit | _ => fail end. +Qed. + +Fixpoint plus (m n : nat) {struct n} : nat := + match n with + | 0 => m + | S p => S (plus m p) + end. + +Definition plus_equation : +forall m n : nat, + plus m n = + match n with + | 0 => m + | p.+1 => (plus m p).+1 + end +:= +fun m n : nat => +match + n as n0 + return + (forall m0 : nat, + plus m0 n0 = + match n0 with + | 0 => m0 + | p.+1 => (plus m0 p).+1 + end) +with +| 0 => @erefl nat +| n0.+1 => fun m0 : nat => erefl (plus m0 n0).+1 +end m. + +Definition plus_rect : +forall (m : nat) (P : nat -> nat -> Type), + (forall n : nat, n = 0 -> P 0 m) -> + (forall n p : nat, + n = p.+1 -> P p (plus m p) -> P p.+1 (plus m p).+1) -> + forall n : nat, P n (plus m n) +:= +fun (m : nat) (P : nat -> nat -> Type) + (f0 : forall n : nat, n = 0 -> P 0 m) + (f : forall n p : nat, + n = p.+1 -> P p (plus m p) -> P p.+1 (plus m p).+1) => +fix plus0 (n : nat) : P n (plus m n) := + eq_rect_r [eta P n] + (let f1 := f0 n in + let f2 := f n in + match + n as n0 + return + (n = n0 -> + (forall p : nat, + n0 = p.+1 -> P p (plus m p) -> P p.+1 (plus m p).+1) -> + (n0 = 0 -> P 0 m) -> + P n0 match n0 with + | 0 => m + | p.+1 => (plus m p).+1 + end) + with + | 0 => + fun (_ : n = 0) + (_ : forall p : nat, + 0 = p.+1 -> + P p (plus m p) -> P p.+1 (plus m p).+1) + (f4 : 0 = 0 -> P 0 m) => unkeyed (f4 (erefl 0)) + | n0.+1 => + fun (_ : n = n0.+1) + (f3 : forall p : nat, + n0.+1 = p.+1 -> + P p (plus m p) -> P p.+1 (plus m p).+1) + (_ : n0.+1 = 0 -> P 0 m) => + let f5 := + let p := n0 in + let H := erefl n0.+1 : n0.+1 = p.+1 in f3 p H in + unkeyed (let Hrec := plus0 n0 in f5 Hrec) + end (erefl n) f2 f1) (plus_equation m n). + +Definition plus_ind := plus_rect. + +Lemma exF x y z: plus (plus x y) z = plus x (plus y z). +elim/plus_ind: z / (plus _ z). +match goal with |- forall n : nat, n = 0 -> plus x y = plus x (plus y 0) => idtac end. +Undo 2. +elim/plus_ind: (plus _ z). +match goal with |- forall n : nat, n = 0 -> plus x y = plus x (plus y 0) => idtac end. +Undo 2. +elim/plus_ind: {z}(plus _ z). +match goal with |- forall n : nat, n = 0 -> plus x y = plus x (plus y 0) => idtac end. +Undo 2. +elim/plus_ind: {z}_. +match goal with |- forall n : nat, n = 0 -> plus x y = plus x (plus y 0) => idtac end. +Undo 2. +elim/plus_ind: z / _. +match goal with |- forall n : nat, n = 0 -> plus x y = plus x (plus y 0) => idtac end. + done. +by move=> _ p _ ->. +Qed. + +(* BUG elim-False *) +Lemma testeF : False -> 1 = 0. +Proof. by elim. Qed. diff --git a/test-suite/ssr/elim2.v b/test-suite/ssr/elim2.v new file mode 100644 index 000000000..c7c20d8f8 --- /dev/null +++ b/test-suite/ssr/elim2.v @@ -0,0 +1,74 @@ +(************************************************************************) +(* * 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) *) +(************************************************************************) + +(* (c) Copyright 2006-2016 Microsoft Corporation and Inria. *) + +Require Import ssreflect. +Require Import ssrbool TestSuite.ssr_mini_mathcomp. +(* div fintype finfun path bigop. *) + +Axiom daemon : False. Ltac myadmit := case: daemon. + +Lemma big_load R (K K' : R -> Type) idx op I r (P : pred I) F : + let s := \big[op/idx]_(i <- r | P i) F i in + K s * K' s -> K' s. +Proof. by move=> /= [_]. Qed. +Arguments big_load [R] K [K' idx op I r P F]. + +Section Elim1. + +Variables (R : Type) (K : R -> Type) (f : R -> R). +Variables (idx : R) (op op' : R -> R -> R). + +Hypothesis Kid : K idx. + +Ltac ASSERT1 := match goal with |- (K idx) => myadmit end. +Ltac ASSERT2 K := match goal with |- (forall x1 : R, R -> + forall y1 : R, R -> K x1 -> K y1 -> K (op x1 y1)) => myadmit end. + + +Lemma big_rec I r (P : pred I) F + (Kop : forall i x, P i -> K x -> K (op (F i) x)) : + K (\big[op/idx]_(i <- r | P i) F i). +Proof. +elim/big_ind2: {-}_. + ASSERT1. ASSERT2 K. match goal with |- (forall i : I, is_true (P i) -> K (F i)) => myadmit end. Undo 4. +elim/big_ind2: _ / {-}_. + ASSERT1. ASSERT2 K. match goal with |- (forall i : I, is_true (P i) -> K (F i)) => myadmit end. Undo 4. + +elim/big_rec2: (\big[op/idx]_(i <- r | P i) op idx (F i)) + / (\big[op/idx]_(i <- r | P i) F i). + ASSERT1. match goal with |- (forall i : I, R -> forall y2 : R, is_true (P i) -> K y2 -> K (op (F i) y2)) => myadmit end. Undo 3. + +elim/(big_load (phantom R)): _. + Undo. + +Fail elim/big_rec2: {2}_. + +elim/big_rec2: (\big[op/idx]_(i <- r | P i) F i) + / {1}(\big[op/idx]_(i <- r | P i) F i). + Undo. + +elim/(big_load (phantom R)): _. +Undo. + +Fail elim/big_rec2: _ / {2}(\big[op/idx]_(i <- r | P i) F i). +Admitted. + +Definition morecomplexthannecessary A (P : A -> A -> Prop) x y := P x y. + +Lemma grab A (P : A -> A -> Prop) n m : (n = m) -> (P n n) -> morecomplexthannecessary A P n m. +by move->. +Qed. + +Goal forall n m, m + (n + m) = m + (n * 1 + m). +Proof. move=> n m; elim/grab : (_ * _) / {1}n => //; exact: muln1. Qed. + +End Elim1. diff --git a/test-suite/ssr/elim_pattern.v b/test-suite/ssr/elim_pattern.v new file mode 100644 index 000000000..ef4658287 --- /dev/null +++ b/test-suite/ssr/elim_pattern.v @@ -0,0 +1,27 @@ +(************************************************************************) +(* * 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) *) +(************************************************************************) + +(* (c) Copyright 2006-2016 Microsoft Corporation and Inria. *) + +Require Import ssreflect. +Require Import ssrbool TestSuite.ssr_mini_mathcomp. +Axiom daemon : False. Ltac myadmit := case: daemon. + +Lemma test x : (x == x) = (x + x.+1 == 2 * x + 1). +case: (X in _ = X) / eqP => _. +match goal with |- (x == x) = true => myadmit end. +match goal with |- (x == x) = false => myadmit end. +Qed. + +Lemma test1 x : (x == x) = (x + x.+1 == 2 * x + 1). +elim: (x in RHS). +match goal with |- (x == x) = _ => myadmit end. +match goal with |- forall n, (x == x) = _ -> (x == x) = _ => myadmit end. +Qed. diff --git a/test-suite/ssr/first_n.v b/test-suite/ssr/first_n.v new file mode 100644 index 000000000..4971add91 --- /dev/null +++ b/test-suite/ssr/first_n.v @@ -0,0 +1,21 @@ +(************************************************************************) +(* * 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) *) +(************************************************************************) + +(* (c) Copyright 2006-2016 Microsoft Corporation and Inria. *) + +Require Import ssreflect. +Require Import ssrbool. + +Lemma test : False -> (bool -> False -> True -> True) -> True. +move=> F; let w := constr:(2) in apply; last w first. +- by apply: F. +- by apply: I. +- by apply: true. +Qed. diff --git a/test-suite/ssr/gen_have.v b/test-suite/ssr/gen_have.v new file mode 100644 index 000000000..249e006f9 --- /dev/null +++ b/test-suite/ssr/gen_have.v @@ -0,0 +1,174 @@ +(************************************************************************) +(* * 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) *) +(************************************************************************) + +(* (c) Copyright 2006-2016 Microsoft Corporation and Inria. *) + +Require Import ssreflect. +Require Import ssrfun ssrbool TestSuite.ssr_mini_mathcomp. +Axiom daemon : False. Ltac myadmit := case: daemon. + +Axiom P : nat -> Prop. +Lemma clear_test (b1 b2 : bool) : b2 = b2. +Proof. +(* wlog gH : (b3 := b2) / b2 = b3. myadmit. *) +gen have {b1} H, gH : (b3 := b2) (w := erefl 3) / b2 = b3. + myadmit. +Fail exact (H b1). +exact (H b2 (erefl _)). +Qed. + + +Lemma test1 n (ngt0 : 0 < n) : P n. +gen have lt2le, /andP[H1 H2] : n ngt0 / (0 <= n) && (n != 0). + match goal with |- is_true((0 <= n) && (n != 0)) => myadmit end. +Check (lt2le : forall n : nat, 0 < n -> (0 <= n) && (n != 0)). +Check (H1 : 0 <= n). +Check (H2 : n != 0). +myadmit. +Qed. + +Lemma test2 n (ngt0 : 0 < n) : P n. +gen have _, /andP[H1 H2] : n ngt0 / (0 <= n) && (n != 0). + match goal with |- is_true((0 <= n) && (n != 0)) => myadmit end. +lazymatch goal with + | lt2le : forall n : nat, is_true(0 < n) -> is_true((0 <= n) && (n != 0)) + |- _ => fail "not cleared" + | _ => idtac end. +Check (H1 : 0 <= n). +Check (H2 : n != 0). +myadmit. +Qed. + +Lemma test3 n (ngt0 : 0 < n) : P n. +gen have H : n ngt0 / (0 <= n) && (n != 0). + match goal with |- is_true((0 <= n) && (n != 0)) => myadmit end. +Check (H : forall n : nat, 0 < n -> (0 <= n) && (n != 0)). +myadmit. +Qed. + +Lemma test4 n (ngt0 : 0 < n) : P n. +gen have : n ngt0 / (0 <= n) && (n != 0). + match goal with |- is_true((0 <= n) && (n != 0)) => myadmit end. +move=> H. +Check(H : forall n : nat, 0 < n -> (0 <= n) && (n != 0)). +myadmit. +Qed. + +Lemma test4bis n (ngt0 : 0 < n) : P n. +wlog suff : n ngt0 / (0 <= n) && (n != 0); last first. + match goal with |- is_true((0 <= n) && (n != 0)) => myadmit end. +move=> H. +Check(H : forall n : nat, 0 < n -> (0 <= n) && (n != 0)). +myadmit. +Qed. + +Lemma test5 n (ngt0 : 0 < n) : P n. +Fail gen have : / (0 <= n) && (n != 0). +Abort. + +Lemma test6 n (ngt0 : 0 < n) : P n. +gen have : n ngt0 / (0 <= n) && (n != 0) by myadmit. +Abort. + +Lemma test7 n (ngt0 : 0 < n) : P n. +Fail gen have : n / (0 <= n) && (n != 0). +Abort. + +Lemma test3wlog2 n (ngt0 : 0 < n) : P n. +gen have H : (m := n) ngt0 / (0 <= m) && (m != 0). + match goal with + ngt0 : is_true(0 < m) |- is_true((0 <= m) && (m != 0)) => myadmit end. +Check (H : forall n : nat, 0 < n -> (0 <= n) && (n != 0)). +myadmit. +Qed. + +Lemma test3wlog3 n (ngt0 : 0 < n) : P n. +gen have H : {n} (m := n) (n := 0) ngt0 / (0 <= m) && (m != n). + match goal with + ngt0 : is_true(n < m) |- is_true((0 <= m) && (m != n)) => myadmit end. +Check (H : forall m n : nat, n < m -> (0 <= m) && (m != n)). +myadmit. +Qed. + +Lemma testw1 n (ngt0 : 0 < n) : n <= 0. +wlog H : (z := 0) (m := n) ngt0 / m != 0. + match goal with + |- (forall z m, + is_true(z < m) -> is_true(m != 0) -> is_true(m <= z)) -> + is_true(n <= 0) => myadmit end. +Check(n : nat). +Check(m : nat). +Check(z : nat). +Check(ngt0 : z < m). +Check(H : m != 0). +myadmit. +Qed. + +Lemma testw2 n (ngt0 : 0 < n) : n <= 0. +wlog H : (m := n) (z := (X in n <= X)) ngt0 / m != z. + match goal with + |- (forall m z : nat, + is_true(0 < m) -> is_true(m != z) -> is_true(m <= z)) -> + is_true(n <= 0) => idtac end. +Restart. +wlog H : (m := n) (one := (X in X <= _)) ngt0 / m != one. + match goal with + |- (forall m one : nat, + is_true(one <= m) -> is_true(m != one) -> is_true(m <= 0)) -> + is_true(n <= 0) => idtac end. +Restart. +wlog H : {n} (m := n) (z := (X in _ <= X)) ngt0 / m != z. + match goal with + |- (forall m z : nat, + is_true(0 < z) -> is_true(m != z) -> is_true(m <= 0)) -> + is_true(n <= 0) => idtac end. + myadmit. +Fail Check n. +myadmit. +Qed. + +Section Test. +Variable x : nat. +Definition addx y := y + x. + +Lemma testw3 (m n : nat) (ngt0 : 0 < n) : n <= addx x. +wlog H : (n0 := n) (y := x) (@twoy := (id _ as X in _ <= X)) / twoy = 2 * y. + myadmit. +myadmit. +Qed. + + +Definition twox := x + x. +Definition bis := twox. + +Lemma testw3x n (ngt0 : 0 < n) : n + x <= twox. +wlog H : (y := x) (@twoy := (X in _ <= X)) / twoy = 2 * y. + match goal with + |- (forall y : nat, + let twoy := y + y in + twoy = 2 * y -> is_true(n + y <= twoy)) -> + is_true(n + x <= twox) => myadmit end. +Restart. +wlog H : (y := x) (@twoy := (id _ as X in _ <= X)) / twoy = 2 * y. + match goal with + |- (forall y : nat, + let twoy := twox in + twoy = 2 * y -> is_true(n + y <= twoy)) -> + is_true(n + x <= twox) => myadmit end. +myadmit. +Qed. + +End Test. + +Lemma test_in n k (def_k : k = 0) (ngtk : k < n) : P n. +rewrite -(add0n n) in {def_k k ngtk} (m := k) (def_m := def_k) (ngtm := ngtk). +rewrite def_m add0n in {ngtm} (e := erefl 0 ) (ngt0 := ngtm) => {def_m}. +myadmit. +Qed. diff --git a/test-suite/ssr/gen_pattern.v b/test-suite/ssr/gen_pattern.v new file mode 100644 index 000000000..c0592e884 --- /dev/null +++ b/test-suite/ssr/gen_pattern.v @@ -0,0 +1,33 @@ +(************************************************************************) +(* * 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) *) +(************************************************************************) + +(* (c) Copyright 2006-2016 Microsoft Corporation and Inria. *) + +Require Import ssreflect. +Require Import ssrbool TestSuite.ssr_mini_mathcomp. + +Notation "( a 'in' c )" := (a + c) (only parsing) : myscope. +Delimit Scope myscope with myscope. + +Notation "( a 'in' c )" := (a + c) (only parsing). + +Lemma foo x y : x + x.+1 = x.+1 + y. +move: {x} (x.+1) {1}x y (x.+1 in RHS). + match goal with |- forall a b c d, b + a = d + c => idtac end. +Admitted. + +Lemma bar x y : x + x.+1 = x.+1 + y. +move E: ((x.+1 in y)) => w. + match goal with |- x + x.+1 = w => rewrite -{w}E end. +move E: (x.+1 in y)%myscope => w. + match goal with |- x + x.+1 = w => rewrite -{w}E end. +move E: ((x + y).+1 as RHS) => w. + match goal with |- x + x.+1 = w => rewrite -{}E -addSn end. +Admitted. diff --git a/test-suite/ssr/have_TC.v b/test-suite/ssr/have_TC.v new file mode 100644 index 000000000..b3a26ed2c --- /dev/null +++ b/test-suite/ssr/have_TC.v @@ -0,0 +1,50 @@ +(************************************************************************) +(* * 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) *) +(************************************************************************) + +(* (c) Copyright 2006-2016 Microsoft Corporation and Inria. *) + +Require Import ssreflect. + +Axiom daemon : False. Ltac myadmit := case: daemon. + +Class foo (T : Type) := { n : nat }. +Instance five : foo nat := {| n := 5 |}. + +Definition bar T {f : foo T} m : Prop := + @n _ f = m. + +Eval compute in (bar nat 7). + +Lemma a : True. +set toto := bar _ 8. +have titi : bar _ 5. + reflexivity. +have titi2 : bar _ 5 := . + Fail reflexivity. + by myadmit. +have totoc (H : bar _ 5) : 3 = 3 := eq_refl. +move/totoc: nat => _. +exact I. +Qed. + +Set SsrHave NoTCResolution. + +Lemma a' : True. +set toto := bar _ 8. +have titi : bar _ 5. + Fail reflexivity. + by myadmit. +have titi2 : bar _ 5 := . + Fail reflexivity. + by myadmit. +have totoc (H : bar _ 5) : 3 = 3 := eq_refl. +move/totoc: nat => _. +exact I. +Qed. diff --git a/test-suite/ssr/have_transp.v b/test-suite/ssr/have_transp.v new file mode 100644 index 000000000..1c998da71 --- /dev/null +++ b/test-suite/ssr/have_transp.v @@ -0,0 +1,48 @@ +(************************************************************************) +(* * 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) *) +(************************************************************************) + +(* (c) Copyright 2006-2016 Microsoft Corporation and Inria. *) + +Require Import ssreflect. +Require Import ssrfun ssrbool TestSuite.ssr_mini_mathcomp. + + +Lemma test1 n : n >= 0. +Proof. +have [:s1] @h m : 'I_(n+m).+1. + apply: Sub 0 _. + abstract: s1 m. + by auto. +cut (forall m, 0 < (n+m).+1); last assumption. +rewrite [_ 1 _]/= in s1 h *. +by []. +Qed. + +Lemma test2 n : n >= 0. +Proof. +have [:s1] @h m : 'I_(n+m).+1 := Sub 0 (s1 m). + move=> m; reflexivity. +cut (forall m, 0 < (n+m).+1); last assumption. +by []. +Qed. + +Lemma test3 n : n >= 0. +Proof. +Fail have [:s1] @h m : 'I_(n+m).+1 by apply: (Sub 0 (s1 m)); auto. +have [:s1] @h m : 'I_(n+m).+1 by apply: (Sub 0); abstract: s1 m; auto. +cut (forall m, 0 < (n+m).+1); last assumption. +by []. +Qed. + +Lemma test4 n : n >= 0. +Proof. +have @h m : 'I_(n+m).+1 by apply: (Sub 0); abstract auto. +by []. +Qed. diff --git a/test-suite/ssr/have_view_idiom.v b/test-suite/ssr/have_view_idiom.v new file mode 100644 index 000000000..3d6c9d980 --- /dev/null +++ b/test-suite/ssr/have_view_idiom.v @@ -0,0 +1,18 @@ +(************************************************************************) +(* * 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) *) +(************************************************************************) + +(* (c) Copyright 2006-2016 Microsoft Corporation and Inria. *) + +Require Import ssreflect. +Require Import ssrbool. + +Lemma test (a b : bool) (pab : a && b) : b. +have {pab} /= /andP [pa -> //] /= : true && (a && b) := pab. +Qed. diff --git a/test-suite/ssr/havesuff.v b/test-suite/ssr/havesuff.v new file mode 100644 index 000000000..aa1f71879 --- /dev/null +++ b/test-suite/ssr/havesuff.v @@ -0,0 +1,85 @@ +(************************************************************************) +(* * 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) *) +(************************************************************************) + +(* (c) Copyright 2006-2016 Microsoft Corporation and Inria. *) + +Require Import ssreflect. + + +Variables P G : Prop. + +Lemma test1 : (P -> G) -> P -> G. +Proof. +move=> pg p. +have suff {pg} H : P. + match goal with |- P -> G => move=> _; exact: pg p | _ => fail end. +match goal with H : P -> G |- G => exact: H p | _ => fail end. +Qed. + +Lemma test2 : (P -> G) -> P -> G. +Proof. +move=> pg p. +have suffices {pg} H : P. + match goal with |- P -> G => move=> _; exact: pg p | _ => fail end. +match goal with H : P -> G |- G => exact: H p | _ => fail end. +Qed. + +Lemma test3 : (P -> G) -> P -> G. +Proof. +move=> pg p. +suff have {pg} H : P. + match goal with H : P |- G => exact: pg H | _ => fail end. +match goal with |- (P -> G) -> G => move=> H; exact: H p | _ => fail end. +Qed. + +Lemma test4 : (P -> G) -> P -> G. +Proof. +move=> pg p. +suffices have {pg} H: P. + match goal with H : P |- G => exact: pg H | _ => fail end. +match goal with |- (P -> G) -> G => move=> H; exact: H p | _ => fail end. +Qed. + +(* +Lemma test5 : (P -> G) -> P -> G. +Proof. +move=> pg p. +suff have {pg} H : P := pg H. +match goal with |- (P -> G) -> G => move=> H; exact: H p | _ => fail end. +Qed. +*) + +(* +Lemma test6 : (P -> G) -> P -> G. +Proof. +move=> pg p. +suff have {pg} H := pg H. +match goal with |- (P -> G) -> G => move=> H; exact: H p | _ => fail end. +Qed. +*) + +Lemma test7 : (P -> G) -> P -> G. +Proof. +move=> pg p. +have suff {pg} H : P := pg. +match goal with H : P -> G |- G => exact: H p | _ => fail end. +Qed. + +Lemma test8 : (P -> G) -> P -> G. +Proof. +move=> pg p. +have suff {pg} H := pg. +match goal with H : P -> G |- G => exact: H p | _ => fail end. +Qed. + +Goal forall x y : bool, x = y -> x = y. +move=> x y E. +by have {x E} -> : x = y by []. +Qed. diff --git a/test-suite/ssr/if_isnt.v b/test-suite/ssr/if_isnt.v new file mode 100644 index 000000000..b8f6b7739 --- /dev/null +++ b/test-suite/ssr/if_isnt.v @@ -0,0 +1,22 @@ +(************************************************************************) +(* * 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) *) +(************************************************************************) + +(* (c) Copyright 2006-2016 Microsoft Corporation and Inria. *) + +Require Import ssreflect. + + +Definition unopt (x : option bool) := + if x isn't Some x then false else x. + +Lemma test1 : unopt None = false /\ + unopt (Some false) = false /\ + unopt (Some true) = true. +Proof. by auto. Qed. diff --git a/test-suite/ssr/intro_beta.v b/test-suite/ssr/intro_beta.v new file mode 100644 index 000000000..8a164bd80 --- /dev/null +++ b/test-suite/ssr/intro_beta.v @@ -0,0 +1,25 @@ +(************************************************************************) +(* * 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) *) +(************************************************************************) + +(* (c) Copyright 2006-2016 Microsoft Corporation and Inria. *) + +Require Import ssreflect. + + +Axiom T : Type. + +Definition C (P : T -> Prop) := forall x, P x. + +Axiom P : T -> T -> Prop. + +Lemma foo : C (fun x => forall y, let z := x in P y x). +move=> a b. +match goal with |- (let y := _ in _) => idtac end. +Admitted. diff --git a/test-suite/ssr/intro_noop.v b/test-suite/ssr/intro_noop.v new file mode 100644 index 000000000..fdc85173a --- /dev/null +++ b/test-suite/ssr/intro_noop.v @@ -0,0 +1,37 @@ +(************************************************************************) +(* * 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) *) +(************************************************************************) + +(* (c) Copyright 2006-2016 Microsoft Corporation and Inria. *) + +Require Import ssreflect. +Require Import ssrbool. +Axiom daemon : False. Ltac myadmit := case: daemon. + +Lemma v : True -> bool -> bool. Proof. by []. Qed. + +Reserved Notation " a -/ b " (at level 0). +Reserved Notation " a -// b " (at level 0). +Reserved Notation " a -/= b " (at level 0). +Reserved Notation " a -//= b " (at level 0). + +Lemma test : forall a b c, a || b || c. +Proof. +move=> ---a--- - -/=- -//- -/=- -//=- b [|-]. +move: {-}a => /v/v-H; have _ := H I I. +Fail move: {-}a {H} => /v-/v-H. +have - -> : a = (id a) by []. +have --> : a = (id a) by []. +have - - _ : a = (id a) by []. +have -{1}-> : a = (id a) by []. + by myadmit. +move: a. +case: b => -[] //. +by myadmit. +Qed. diff --git a/test-suite/ssr/ipatalternation.v b/test-suite/ssr/ipatalternation.v new file mode 100644 index 000000000..6aa9a954c --- /dev/null +++ b/test-suite/ssr/ipatalternation.v @@ -0,0 +1,18 @@ +(************************************************************************) +(* * 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) *) +(************************************************************************) + +(* (c) Copyright 2006-2016 Microsoft Corporation and Inria. *) + +Require Import ssreflect. + + +Lemma test1 : Prop -> Prop -> Prop -> Prop -> Prop -> True = False -> Prop -> True \/ True. +by move=> A /= /= /= B C {A} {B} ? _ {C} {1}-> *; right. +Qed. diff --git a/test-suite/ssr/ltac_have.v b/test-suite/ssr/ltac_have.v new file mode 100644 index 000000000..380e52af4 --- /dev/null +++ b/test-suite/ssr/ltac_have.v @@ -0,0 +1,39 @@ +(************************************************************************) +(* * 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) *) +(************************************************************************) + +(* (c) Copyright 2006-2016 Microsoft Corporation and Inria. *) + +Require Import ssreflect. +Require Import ssrbool TestSuite.ssr_mini_mathcomp. + +Ltac SUFF1 h t := suff h x (p := x < 0) : t. +Ltac SUFF2 h t := suff h x (p := x < 0) : t by apply h. +Ltac HAVE1 h t u := have h x (p := x < 0) : t := u. +Ltac HAVE2 h t := have h x (p := x < 0) : t by []. +Ltac HAVE3 h t := have h x (p := x < 0) : t. +Ltac HAVES h t := have suff h : t. +Ltac SUFFH h t := suff have h : t. + +Lemma foo z : z < 0. +SUFF1 h1 (z+1 < 0). +Undo. +SUFF2 h2 (z < 0). +Undo. +HAVE1 h3 (z = z) (refl_equal z). +Undo. +HAVE2 h4 (z = z). +Undo. +HAVE3 h5 (z < 0). +Undo. +HAVES h6 (z < 1). +Undo. +SUFFH h7 (z < 1). +Undo. +Admitted. diff --git a/pretyping/univdecls.mli b/test-suite/ssr/ltac_in.v index 305d045b1..bcdf96dde 100644 --- a/pretyping/univdecls.mli +++ b/test-suite/ssr/ltac_in.v @@ -8,14 +8,19 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) -(** Local universe and constraint declarations. *) -type universe_decl = - (Misctypes.lident list, Univ.Constraint.t) Misctypes.gen_universe_decl +(* (c) Copyright 2006-2016 Microsoft Corporation and Inria. *) -val default_univ_decl : universe_decl +Require Import ssreflect. +Require Import ssrbool TestSuite.ssr_mini_mathcomp. -val interp_univ_decl : Environ.env -> Constrexpr.universe_decl_expr -> - Evd.evar_map * universe_decl +Set Implicit Arguments. +Unset Strict Implicit. +Import Prenex Implicits. -val interp_univ_decl_opt : Environ.env -> Constrexpr.universe_decl_expr option -> - Evd.evar_map * universe_decl +(* error 1 *) + +Ltac subst1 H := move: H; rewrite {1} addnC; move => H. +Ltac subst2 H := rewrite addnC in H. + +Goal ( forall a b: nat, b+a = 0 -> b+a=0). +Proof. move=> a b hyp. subst1 hyp. subst2 hyp. done. Qed. diff --git a/test-suite/ssr/move_after.v b/test-suite/ssr/move_after.v new file mode 100644 index 000000000..a7a9afea0 --- /dev/null +++ b/test-suite/ssr/move_after.v @@ -0,0 +1,19 @@ +(************************************************************************) +(* * 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) *) +(************************************************************************) + +(* (c) Copyright 2006-2016 Microsoft Corporation and Inria. *) + +Require Import ssreflect. + + +Goal True -> True -> True. +move=> H1 H2. +move H1 after H2. +Admitted. diff --git a/test-suite/ssr/multiview.v b/test-suite/ssr/multiview.v new file mode 100644 index 000000000..f4e717b38 --- /dev/null +++ b/test-suite/ssr/multiview.v @@ -0,0 +1,58 @@ +(************************************************************************) +(* * 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) *) +(************************************************************************) + +(* (c) Copyright 2006-2016 Microsoft Corporation and Inria. *) + +Require Import ssreflect. +Require Import ssrbool TestSuite.ssr_mini_mathcomp. + +Goal forall m n p, n <= p -> m <= n -> m <= p. +by move=> m n p le_n_p /leq_trans; apply. +Undo 1. +by move=> m n p le_n_p /leq_trans /(_ le_n_p) le_m_p; exact: le_m_p. +Undo 1. +by move=> m n p le_n_p /leq_trans ->. +Qed. + +Goal forall P Q X : Prop, Q -> (True -> X -> Q = P) -> X -> P. +by move=> P Q X q V /V <-. +Qed. + +Lemma test0: forall a b, a && a && b -> b. +by move=> a b; repeat move=> /andP []; move=> *. +Qed. + +Lemma test1 : forall a b, a && b -> b. +by move=> a b /andP /andP /andP [] //. +Qed. + +Lemma test2 : forall a b, a && b -> b. +by move=> a b /andP /andP /(@andP a) [] //. +Qed. + +Lemma test3 : forall a b, a && (b && b) -> b. +by move=> a b /andP [_ /andP [_ //]]. +Qed. + +Lemma test4: forall a b, a && b = b && a. +by move=> a b; apply/andP/andP=> ?; apply/andP/andP/andP; rewrite andbC; apply/andP. +Qed. + +Lemma test5: forall C I A O, (True -> O) -> (O -> A) -> (True -> A -> I) -> (I -> C) -> C. +by move=> c i a o O A I C; apply/C/I/A/O. +Qed. + +Lemma test6: forall A B, (A -> B) -> A -> B. +move=> A B A_to_B a; move/A_to_B in a; exact: a. +Qed. + +Lemma test7: forall A B, (A -> B) -> A -> B. +move=> A B A_to_B a; apply A_to_B in a; exact: a. +Qed. diff --git a/test-suite/ssr/occarrow.v b/test-suite/ssr/occarrow.v new file mode 100644 index 000000000..49af7ae08 --- /dev/null +++ b/test-suite/ssr/occarrow.v @@ -0,0 +1,23 @@ +(************************************************************************) +(* * 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) *) +(************************************************************************) + +(* (c) Copyright 2006-2016 Microsoft Corporation and Inria. *) + +Require Import ssreflect. +Require Import TestSuite.ssr_mini_mathcomp. + +Lemma test1 : forall n m : nat, n = m -> m * m + n * n = n * n + n * n. +move=> n m E; have [{2}-> _] : n * n = m * n /\ True by move: E => {1}<-. +by move: E => {3}->. +Qed. + +Lemma test2 : forall n m : nat, True /\ (n = m -> n * n = n * m). +by move=> n m; constructor=> [|{2}->]. +Qed. diff --git a/test-suite/ssr/patnoX.v b/test-suite/ssr/patnoX.v new file mode 100644 index 000000000..d69f03ac3 --- /dev/null +++ b/test-suite/ssr/patnoX.v @@ -0,0 +1,18 @@ +(************************************************************************) +(* * 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) *) +(************************************************************************) + +(* (c) Copyright 2006-2016 Microsoft Corporation and Inria. *) + +Require Import ssreflect. +Require Import ssrbool. +Goal forall x, x && true = x. +move=> x. +Fail (rewrite [X in _ && _]andbT). +Abort. diff --git a/test-suite/ssr/pattern.v b/test-suite/ssr/pattern.v new file mode 100644 index 000000000..396f4f032 --- /dev/null +++ b/test-suite/ssr/pattern.v @@ -0,0 +1,32 @@ +(************************************************************************) +(* * 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) *) +(************************************************************************) + +Require Import ssrmatching. + +(*Set Debug SsrMatching.*) + +Tactic Notation "at" "[" ssrpatternarg(pat) "]" tactic(t) := + let name := fresh in + let def_name := fresh in + ssrpattern pat; + intro name; + pose proof (refl_equal name) as def_name; + unfold name at 1 in def_name; + t def_name; + [ rewrite <- def_name | idtac.. ]; + clear name def_name. + +Lemma test (H : True -> True -> 3 = 7) : 28 = 3 * 4. +Proof. +at [ X in X * 4 ] ltac:(fun place => rewrite -> H in place). +- reflexivity. +- trivial. +- trivial. +Qed. diff --git a/test-suite/ssr/primproj.v b/test-suite/ssr/primproj.v new file mode 100644 index 000000000..cf61eb436 --- /dev/null +++ b/test-suite/ssr/primproj.v @@ -0,0 +1,164 @@ +(************************************************************************) +(* * 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) *) +(************************************************************************) + + + +Require Import Setoid. +Set Primitive Projections. + + +Module CoqBug. +Record foo A := Foo { foo_car : A }. + +Definition bar : foo _ := Foo nat 10. + +Variable alias : forall A, foo A -> A. + +Parameter e : @foo_car = alias. + +Goal foo_car _ bar = alias _ bar. +Proof. +(* Coq equally fails *) +Fail rewrite -> e. +Fail rewrite e at 1. +Fail setoid_rewrite e. +Fail setoid_rewrite e at 1. +Set Keyed Unification. +Fail rewrite -> e. +Fail rewrite e at 1. +Fail setoid_rewrite e. +Fail setoid_rewrite e at 1. +Admitted. + +End CoqBug. + +(* ----------------------------------------------- *) +Require Import ssreflect. + +Set Primitive Projections. + +Module T1. + +Record foo A := Foo { foo_car : A }. + +Definition bar : foo _ := Foo nat 10. + +Goal foo_car _ bar = 10. +Proof. +match goal with +| |- foo_car _ bar = 10 => idtac +end. +rewrite /foo_car. +(* +Fail match goal with +| |- foo_car _ bar = 10 => idtac +end. +*) +Admitted. + +End T1. + + +Module T2. + +Record foo {A} := Foo { foo_car : A }. + +Definition bar : foo := Foo nat 10. + +Goal foo_car bar = 10. +match goal with +| |- foo_car bar = 10 => idtac +end. +rewrite /foo_car. +(* +Fail match goal with +| |- foo_car bar = 10 => idtac +end. +*) +Admitted. + +End T2. + + +Module T3. + +Record foo {A} := Foo { foo_car : A }. + +Definition bar : foo := Foo nat 10. + +Goal foo_car bar = 10. +Proof. +rewrite -[foo_car _]/(id _). +match goal with |- id _ = 10 => idtac end. +Admitted. + +Goal foo_car bar = 10. +Proof. +set x := foo_car _. +match goal with |- x = 10 => idtac end. +Admitted. + +End T3. + +Module T4. + +Inductive seal {A} (f : A) := { unseal : A; seal_eq : unseal = f }. +Arguments unseal {_ _} _. +Arguments seal_eq {_ _} _. + +Record uPred : Type := IProp { uPred_holds :> Prop }. + +Definition uPred_or_def (P Q : uPred) : uPred := + {| uPred_holds := P \/ Q |}. +Definition uPred_or_aux : seal (@uPred_or_def). by eexists. Qed. +Definition uPred_or := unseal uPred_or_aux. +Definition uPred_or_eq: @uPred_or = @uPred_or_def := seal_eq uPred_or_aux. + +Lemma foobar (P1 P2 Q : uPred) : + (P1 <-> P2) -> (uPred_or P1 Q) <-> (uPred_or P2 Q). +Proof. + rewrite uPred_or_eq. (* This fails. *) +Admitted. + +End T4. + + +Module DesignFlaw. + +Record foo A := Foo { foo_car : A }. +Definition bar : foo _ := Foo nat 10. + +Definition app (f : foo nat -> nat) x := f x. + +Goal app (foo_car _) bar = 10. +Proof. +unfold app. (* mkApp should produce a Proj *) +Fail set x := (foo_car _ _). +Admitted. + +End DesignFlaw. + + +Module Bug. + +Record foo A := Foo { foo_car : A }. + +Definition bar : foo _ := Foo nat 10. + +Variable alias : forall A, foo A -> A. + +Parameter e : @foo_car = alias. + +Goal foo_car _ bar = alias _ bar. +Proof. +Fail rewrite e. (* Issue: #86 *) +Admitted. + +End Bug. diff --git a/test-suite/ssr/rewpatterns.v b/test-suite/ssr/rewpatterns.v new file mode 100644 index 000000000..f7993f402 --- /dev/null +++ b/test-suite/ssr/rewpatterns.v @@ -0,0 +1,146 @@ +(************************************************************************) +(* * 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) *) +(************************************************************************) + +(* (c) Copyright 2006-2016 Microsoft Corporation and Inria. *) + + +Require Import ssreflect. +Require Import ssrbool ssrfun TestSuite.ssr_mini_mathcomp. + +Lemma test1 : forall x y (f : nat -> nat), f (x + y).+1 = f (y + x.+1). +by move=> x y f; rewrite [_.+1](addnC x.+1). +Qed. + +Lemma test2 : forall x y f, x + y + f (y + x) + f (y + x) = x + y + f (y + x) + f (x + y). +by move=> x y f; rewrite {2}[in f _]addnC. +Qed. + +Lemma test2' : forall x y f, true && f (x * (y + x)) = true && f(x * (x + y)). +by move=> x y f; rewrite [in f _](addnC y). +Qed. + +Lemma test2'' : forall x y f, f (y + x) + f(y + x) + f(y + x) = f(x + y) + f(y + x) + f(x + y). +by move=> x y f; rewrite {1 3}[in f _](addnC y). +Qed. + +(* patterns catching bound vars not supported *) +Lemma test2_1 : forall x y f, true && (let z := x in f (z * (y + x))) = true && f(x * (x + y)). +by move=> x y f; rewrite [in f _](addnC x). (* put y when bound var will be OK *) +Qed. + +Lemma test3 : forall x y f, x + f (x + y) (f (y + x) x) = x + f (x + y) (f (x + y) x). +by move=> x y f; rewrite [in X in (f _ X)](addnC y). +Qed. + +Lemma test3' : forall x y f, x = y -> x + f (x + x) x + f (x + x) x = + x + f (x + y) x + f (y + x) x. +by move=> x y f E; rewrite {2 3}[in X in (f X _)]E. +Qed. + +Lemma test3'' : forall x y f, x = y -> x + f (x + y) x + f (x + y) x = + x + f (x + y) x + f (y + y) x. +by move=> x y f E; rewrite {2}[in X in (f X _)]E. +Qed. + +Lemma test4 : forall x y f, x = y -> x + f (fun _ : nat => x + x) x + f (fun _ => x + x) x = + x + f (fun _ => x + y) x + f (fun _ => y + x) x. +by move=> x y f E; rewrite {2 3}[in X in (f X _)]E. +Qed. + +Lemma test4' : forall x y f, x = y -> x + f (fun _ _ _ : nat => x + x) x = + x + f (fun _ _ _ => x + y) x. +by move=> x y f E; rewrite {2}[in X in (f X _)]E. +Qed. + +Lemma test5 : forall x y f, x = y -> x + f (y + x) x + f (y + x) x = + x + f (x + y) x + f (y + x) x. +by move=> x y f E; rewrite {1}[X in (f X _)]addnC. +Qed. + +Lemma test3''' : forall x y f, x = y -> x + f (x + y) x + f (x + y) (x + y) = + x + f (x + y) x + f (y + y) (x + y). +by move=> x y f E; rewrite {1}[in X in (f X X)]E. +Qed. + +Lemma test3'''' : forall x y f, x = y -> x + f (x + y) x + f (x + y) (x + y) = + x + f (x + y) x + f (y + y) (y + y). +by move=> x y f E; rewrite [in X in (f X X)]E. +Qed. + +Lemma test3x : forall x y f, y+y = x+y -> x + f (x + y) x + f (x + y) (x + y) = + x + f (x + y) x + f (y + y) (y + y). +by move=> x y f E; rewrite -[X in (f X X)]E. +Qed. + +Lemma test6 : forall x y (f : nat -> nat), f (x + y).+1 = f (y.+1 + x). +by move=> x y f; rewrite [(x + y) in X in (f X)]addnC. +Qed. + +Lemma test7 : forall x y (f : nat -> nat), f (x + y).+1 = f (y + x.+1). +by move=> x y f; rewrite [(x.+1 + y) as X in (f X)]addnC. +Qed. + +Lemma manual x y z (f : nat -> nat -> nat) : (x + y).+1 + f (x.+1 + y) (z + (x + y).+1) = 0. +Proof. +rewrite [in f _]addSn. +match goal with |- (x + y).+1 + f (x + y).+1 (z + (x + y).+1) = 0 => idtac end. +rewrite -[X in _ = X]addn0. +match goal with |- (x + y).+1 + f (x + y).+1 (z + (x + y).+1) = 0 + 0 => idtac end. +rewrite -{2}[in X in _ = X](addn0 0). +match goal with |- (x + y).+1 + f (x + y).+1 (z + (x + y).+1) = 0 + (0 + 0) => idtac end. +rewrite [_.+1 in X in f _ X](addnC x.+1). +match goal with |- (x + y).+1 + f (x + y).+1 (z + (y + x.+1)) = 0 + (0 + 0) => idtac end. +rewrite [x.+1 + y as X in f X _]addnC. +match goal with |- (x + y).+1 + f (y + x.+1) (z + (y + x.+1)) = 0 + (0 + 0) => idtac end. +Admitted. + +Goal (exists x : 'I_3, x > 0). +apply: (ex_intro _ (@Ordinal _ 2 _)). +Admitted. + +Goal (forall y, 1 < y < 2 -> exists x : 'I_3, x > 0). +move=> y; case/andP=> y_gt1 y_lt2; apply: (ex_intro _ (@Ordinal _ y _)). + by apply: leq_trans y_lt2 _. +by move=> y_lt3; apply: leq_trans _ y_gt1. +Qed. + +Goal (forall x y : nat, forall P : nat -> Prop, x = y -> True). +move=> x y P E. +have: P x -> P y by suff: x = y by move=> ?; congr (P _). +Admitted. + +Goal forall a : bool, a -> true && a || false && a. +by move=> a ?; rewrite [true && _]/= [_ && a]/= orbC [_ || _]//=. +Qed. + +Goal forall a : bool, a -> true && a || false && a. +by move=> a ?; rewrite [X in X || _]/= [X in _ || X]/= orbC [false && a as X in X || _]//=. +Qed. + +Variable a : bool. +Definition f x := x || a. +Definition g x := f x. + +Goal a -> g false. +by move=> Ha; rewrite [g _]/f orbC Ha. +Qed. + +Goal a -> g false || g false. +move=> Ha; rewrite {2}[g _]/f orbC Ha. +match goal with |- (is_true (false || true || g false)) => done end. +Qed. + +Goal a -> (a && a || true && a) && true. +by move=> Ha; rewrite -[_ || _]/(g _) andbC /= Ha [g _]/f. +Qed. + +Goal a -> (a || a) && true. +by move=> Ha; rewrite -[in _ || _]/(f _) Ha andbC /f. +Qed. diff --git a/test-suite/ssr/set_lamda.v b/test-suite/ssr/set_lamda.v new file mode 100644 index 000000000..a012ec680 --- /dev/null +++ b/test-suite/ssr/set_lamda.v @@ -0,0 +1,27 @@ +(************************************************************************) +(* * 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) *) +(************************************************************************) + +(* (c) Copyright 2006-2016 Microsoft Corporation and Inria. *) + +Require Import ssreflect. +Require Import ssrbool ssrfun. +Require Import TestSuite.ssr_mini_mathcomp. + +Set Implicit Arguments. +Unset Strict Implicit. +Import Prenex Implicits. + +(* error 2 *) + +Goal (exists f: Set -> nat, f nat = 0). +Proof. set (f:= fun _:Set =>0). by exists f. Qed. + +Goal (exists f: Set -> nat, f nat = 0). +Proof. set f := (fun _:Set =>0). by exists f. Qed. diff --git a/test-suite/ssr/set_pattern.v b/test-suite/ssr/set_pattern.v new file mode 100644 index 000000000..3ce75e879 --- /dev/null +++ b/test-suite/ssr/set_pattern.v @@ -0,0 +1,64 @@ +(************************************************************************) +(* * 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) *) +(************************************************************************) + +(* (c) Copyright 2006-2016 Microsoft Corporation and Inria. *) + +Require Import ssreflect. + +Axiom daemon : False. Ltac myadmit := case: daemon. + +Ltac T1 x := match goal with |- _ => set t := (x in X in _ = X) end. +Ltac T2 x := first [set t := (x in RHS)]. +Ltac T3 x := first [set t := (x in Y in _ = Y)|idtac]. +Ltac T4 x := set t := (x in RHS); idtac. +Ltac T5 x := match goal with |- _ => set t := (x in RHS) | |- _ => idtac end. + +Require Import ssrbool TestSuite.ssr_mini_mathcomp. + +Open Scope nat_scope. + +Lemma foo x y : x.+1 = y + x.+1. +set t := (_.+1 in RHS). match goal with |- x.+1 = y + t => rewrite /t {t} end. +set t := (x in RHS). match goal with |- x.+1 = y + t.+1 => rewrite /t {t} end. +set t := (x in _ = x). match goal with |- x.+1 = t => rewrite /t {t} end. +set t := (x in X in _ = X). + match goal with |- x.+1 = y + t.+1 => rewrite /t {t} end. +set t := (x in RHS). match goal with |- x.+1 = y + t.+1 => rewrite /t {t} end. +set t := (y + (1 + x) as X in _ = X). + match goal with |- x.+1 = t => rewrite /t addSn add0n {t} end. +set t := x.+1. match goal with |- t = y + t => rewrite /t {t} end. +set t := (x).+1. match goal with |- t = y + t => rewrite /t {t} end. +set t := ((x).+1 in X in _ = X). + match goal with |- x.+1 = y + t => rewrite /t {t} end. +set t := (x.+1 in RHS). match goal with |- x.+1 = y + t => rewrite /t {t} end. +T1 (x.+1). match goal with |- x.+1 = y + t => rewrite /t {t} end. +T2 (x.+1). match goal with |- x.+1 = y + t => rewrite /t {t} end. +T3 (x.+1). match goal with |- x.+1 = y + t => rewrite /t {t} end. +T4 (x.+1). match goal with |- x.+1 = y + t => rewrite /t {t} end. +T5 (x.+1). match goal with |- x.+1 = y + t => rewrite /t {t} end. +rewrite [RHS]addnC. + match goal with |- x.+1 = x.+1 + y => rewrite -[RHS]addnC end. +rewrite -[in RHS](@subnK 1 x.+1) //. + match goal with |- x.+1 = y + (x.+1 - 1 + 1) => rewrite subnK // end. +have H : x.+1 = y by myadmit. +set t := _.+1 in H |- *. + match goal with H : t = y |- t = y + t => rewrite /t {t} in H * end. +set t := (_.+1 in X in _ + X) in H |- *. + match goal with H : x.+1 = y |- x.+1 = y + t => rewrite /t {t} in H * end. +set t := 0. match goal with t := 0 |- x.+1 = y + x.+1 => clear t end. +set t := y + _. match goal with |- x.+1 = t => rewrite /t {t} end. +set t : nat := 0. clear t. +set t : nat := (x in RHS). + match goal with |- x.+1 = y + t.+1 => rewrite /t {t} end. +set t : nat := RHS. match goal with |- x.+1 = t => rewrite /t {t} end. +(* set t := 0 + _. *) +(* set t := (x).+1 in X in _ + X in H |-. *) +(* set t := (x).+1 in X in _ = X.*) +Admitted. diff --git a/test-suite/ssr/ssrsyntax2.v b/test-suite/ssr/ssrsyntax2.v new file mode 100644 index 000000000..af839fabd --- /dev/null +++ b/test-suite/ssr/ssrsyntax2.v @@ -0,0 +1,20 @@ +(************************************************************************) +(* * 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) *) +(************************************************************************) + +(* (c) Copyright 2006-2016 Microsoft Corporation and Inria. *) + +Require Import TestSuite.ssr_ssrsyntax1. +Require Import Arith. + +Goal (forall a b, a + b = b + a). +intros. +rewrite plus_comm, plus_comm. +split. +Qed. diff --git a/test-suite/ssr/tc.v b/test-suite/ssr/tc.v new file mode 100644 index 000000000..ae4589ef3 --- /dev/null +++ b/test-suite/ssr/tc.v @@ -0,0 +1,39 @@ +(************************************************************************) +(* * 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) *) +(************************************************************************) + +(* (c) Copyright 2006-2016 Microsoft Corporation and Inria. *) + +Require Import ssreflect. + + +Class foo (A : Type) : Type := mkFoo { val : A }. +Instance foo_pair {A B} {f1 : foo A} {f2 : foo B} : foo (A * B) | 2 := + {| val := (@val _ f1, @val _ f2) |}. +Instance foo_nat : foo nat | 3 := {| val := 0 |}. + +Definition id {A} (x : A) := x. +Axiom E : forall A {f : foo A} (a : A), id a = (@val _ f). + +Lemma test (x : nat) : id true = true -> id x = 0. +Proof. +Fail move=> _; reflexivity. +Timeout 2 rewrite E => _; reflexivity. +Qed. + +Definition P {A} (x : A) : Prop := x = x. +Axiom V : forall A {f : foo A} (x:A), P x -> P (id x). + +Lemma test1 (x : nat) : P x -> P (id x). +Proof. +move=> px. +Timeout 2 Fail move/V: px. +Timeout 2 move/V : (px) => _. +move/(V nat) : px => H; exact H. +Qed. diff --git a/test-suite/ssr/typeof.v b/test-suite/ssr/typeof.v new file mode 100644 index 000000000..ca121fdb3 --- /dev/null +++ b/test-suite/ssr/typeof.v @@ -0,0 +1,22 @@ +(************************************************************************) +(* * 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) *) +(************************************************************************) + +(* (c) Copyright 2006-2016 Microsoft Corporation and Inria. *) + +Require Import ssreflect. + +Ltac mycut x := + let tx := type of x in + cut tx. + +Lemma test : True. +Proof. +by mycut I=> [ x | ]; [ exact x | exact I ]. +Qed. diff --git a/ide/ide_slave.mli b/test-suite/ssr/unfold_Opaque.v index 9db9ecd12..7c2b51de4 100644 --- a/ide/ide_slave.mli +++ b/test-suite/ssr/unfold_Opaque.v @@ -8,5 +8,11 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) -(* This empty file avoids a race condition that occurs when compiling a .ml file - that does not have a corresponding .mli file *) +Require Import ssreflect. + +Definition x := 3. +Opaque x. + +Goal x = 3. +Fail rewrite /x. +Admitted. diff --git a/test-suite/ssr/unkeyed.v b/test-suite/ssr/unkeyed.v new file mode 100644 index 000000000..710941c30 --- /dev/null +++ b/test-suite/ssr/unkeyed.v @@ -0,0 +1,31 @@ +(************************************************************************) +(* * 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) *) +(************************************************************************) + +(* (c) Copyright 2006-2016 Microsoft Corporation and Inria. *) + +Require Import ssreflect. +Require Import ssrfun ssrbool TestSuite.ssr_mini_mathcomp. + +Set Implicit Arguments. +Unset Strict Implicit. +Import Prenex Implicits. + +Lemma test0 (a b : unit) f : a = f b. +Proof. by rewrite !unitE. Qed. + +Lemma phE T : all_equal_to (Phant T). Proof. by case. Qed. + +Lemma test1 (a b : phant nat) f : a = f b. +Proof. by rewrite !phE. Qed. + +Lemma eq_phE (T : eqType) : all_equal_to (Phant T). Proof. by case. Qed. + +Lemma test2 (a b : phant bool) f : a = locked (f b). +Proof. by rewrite !eq_phE. Qed. diff --git a/test-suite/ssr/view_case.v b/test-suite/ssr/view_case.v new file mode 100644 index 000000000..2721470c4 --- /dev/null +++ b/test-suite/ssr/view_case.v @@ -0,0 +1,31 @@ +(************************************************************************) +(* * 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) *) +(************************************************************************) + +(* (c) Copyright 2006-2016 Microsoft Corporation and Inria. *) + +Require Import ssreflect. +Require Import ssrbool TestSuite.ssr_mini_mathcomp. + +Axiom P : forall T, seq T -> Prop. + +Goal (forall T (s : seq T), P _ s). +move=> T s. +elim: s => [| x /lastP [| s] IH]. +Admitted. + +Goal forall x : 'I_1, x = 0 :> nat. +move=> /ord1 -> /=; exact: refl_equal. +Qed. + +Goal forall x : 'I_1, x = 0 :> nat. +move=> x. +move=> /ord1 -> in x |- *. +exact: refl_equal. +Qed. diff --git a/test-suite/ssr/wlog_suff.v b/test-suite/ssr/wlog_suff.v new file mode 100644 index 000000000..43a8f3b8b --- /dev/null +++ b/test-suite/ssr/wlog_suff.v @@ -0,0 +1,28 @@ +(************************************************************************) +(* * 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) *) +(************************************************************************) + +(* (c) Copyright 2006-2016 Microsoft Corporation and Inria. *) + +Require Import ssreflect. +Require Import ssrbool. + +Lemma test b : b || ~~b. +wlog _ : b / b = true. + case: b; [ by apply | by rewrite orbC ]. +wlog suff: b / b || ~~b. + by case: b. +by case: b. +Qed. + +Lemma test2 b c (H : c = b) : b || ~~b. +wlog _ : b {c H} / b = true. + by case: b H. +by case: b. +Qed. diff --git a/test-suite/ssr/wlogletin.v b/test-suite/ssr/wlogletin.v new file mode 100644 index 000000000..64e1ea84f --- /dev/null +++ b/test-suite/ssr/wlogletin.v @@ -0,0 +1,50 @@ +(************************************************************************) +(* * 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) *) +(************************************************************************) + +(* (c) Copyright 2006-2016 Microsoft Corporation and Inria. *) + +Require Import ssreflect. +Require Import ssrbool. +Require Import TestSuite.ssr_mini_mathcomp. + +Variable T : Type. +Variables P : T -> Prop. + +Definition f := fun x y : T => x. + +Lemma test1 : forall x y : T, P (f x y) -> P x. +Proof. +move=> x y; set fxy := f x y; move=> Pfxy. +wlog H : @fxy Pfxy / P x. + match goal with |- (let fxy0 := f x y in P fxy0 -> P x -> P x) -> P x => by auto | _ => fail end. +exact: H. +Qed. + +Lemma test2 : forall x y : T, P (f x y) -> P x. +Proof. +move=> x y; set fxy := f x y; move=> Pfxy. +wlog H : fxy Pfxy / P x. + match goal with |- (forall fxy, P fxy -> P x -> P x) -> P x => by auto | _ => fail end. +exact: H. +Qed. + +Lemma test3 : forall x y : T, P (f x y) -> P x. +Proof. +move=> x y; set fxy := f x y; move=> Pfxy. +move: {1}@fxy (Pfxy) (Pfxy). +match goal with |- (let fxy0 := f x y in P fxy0 -> P fxy -> P x) => by auto | _ => fail end. +Qed. + +Lemma test4 : forall n m z: bool, n = z -> let x := n in x = m && n -> x = m && n. +move=> n m z E x H. +case: true. + by rewrite {1 2}E in (x) H |- *. +by rewrite {1}E in x H |- *. +Qed. diff --git a/test-suite/ssr/wlong_intro.v b/test-suite/ssr/wlong_intro.v new file mode 100644 index 000000000..dd80f0435 --- /dev/null +++ b/test-suite/ssr/wlong_intro.v @@ -0,0 +1,20 @@ +(************************************************************************) +(* * 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) *) +(************************************************************************) + +(* (c) Copyright 2006-2016 Microsoft Corporation and Inria. *) + +Require Import ssreflect. +Require Import ssrbool. +Require Import TestSuite.ssr_mini_mathcomp. + +Goal (forall x y : nat, True). +move=> x y. +wlog suff: x y / x <= y. +Admitted. diff --git a/test-suite/success/Fixpoint.v b/test-suite/success/Fixpoint.v index 5fc703cf0..efb32ef6f 100644 --- a/test-suite/success/Fixpoint.v +++ b/test-suite/success/Fixpoint.v @@ -91,3 +91,33 @@ apply Cons2. exact b. apply (ex1 (S n) (negb b)). Defined. + +Section visibility. + + Let Fixpoint imm (n:nat) : True := I. + + Let Fixpoint by_proof (n:nat) : True. + Proof. exact I. Defined. +End visibility. + +Fail Check imm. +Fail Check by_proof. + +Module Import mod_local. + Fixpoint imm_importable (n:nat) : True := I. + + Local Fixpoint imm_local (n:nat) : True := I. + + Fixpoint by_proof_importable (n:nat) : True. + Proof. exact I. Defined. + + Local Fixpoint by_proof_local (n:nat) : True. + Proof. exact I. Defined. +End mod_local. + +Check imm_importable. +Fail Check imm_local. +Check mod_local.imm_local. +Check by_proof_importable. +Fail Check by_proof_local. +Check mod_local.by_proof_local. diff --git a/test-suite/success/ImplicitTactic.v b/test-suite/success/ImplicitTactic.v deleted file mode 100644 index d8fa3043d..000000000 --- a/test-suite/success/ImplicitTactic.v +++ /dev/null @@ -1,16 +0,0 @@ -(* A Wiedijk-Cruz-Filipe style tactic for solving implicit arguments *) - -(* Declare a term expression with a hole *) -Parameter quo : nat -> forall n:nat, n<>0 -> nat. -Notation "x / y" := (quo x y _) : nat_scope. - -(* Declare the tactic for resolving implicit arguments still - unresolved after type-checking; it must complete the subgoal to - succeed *) -Declare Implicit Tactic assumption. - -Goal forall n d, d<>0 -> { q:nat & { r:nat | d * q + r = n }}. -intros. -(* Here, assumption is used to solve the implicit argument of quo *) -exists (n / d). - diff --git a/test-suite/success/Inversion.v b/test-suite/success/Inversion.v index ca8da3948..ee540d710 100644 --- a/test-suite/success/Inversion.v +++ b/test-suite/success/Inversion.v @@ -107,6 +107,7 @@ Goal forall o, foo2 o -> 0 = 1. intros. eapply trans_eq. inversion H. +Abort. (* Check that the part of "injection" that is called by "inversion" does the same number of intros as the number of equations @@ -136,6 +137,7 @@ Goal True -> True. intro. Fail inversion H using False. Fail inversion foo using True_ind. +Abort. (* Was failing at some time between 7 and 10 September 2014 *) (* even though, it is not clear that the resulting context is interesting *) diff --git a/test-suite/success/RecTutorial.v b/test-suite/success/RecTutorial.v index 29350d620..6370cab6b 100644 --- a/test-suite/success/RecTutorial.v +++ b/test-suite/success/RecTutorial.v @@ -589,6 +589,8 @@ Close Scope Z_scope. Theorem S_is_not_O : forall n, S n <> 0. +Set Nested Proofs Allowed. + Definition Is_zero (x:nat):= match x with | 0 => True | _ => False diff --git a/test-suite/success/ShowExtraction.v b/test-suite/success/ShowExtraction.v index e34c240c5..a4a35003d 100644 --- a/test-suite/success/ShowExtraction.v +++ b/test-suite/success/ShowExtraction.v @@ -12,7 +12,7 @@ Fail Show Extraction. Lemma decListA : forall (xs ys : list A), {xs=ys}+{xs<>ys}. Proof. Show Extraction. -fix 1. +fix decListA 1. destruct xs as [|x xs], ys as [|y ys]. Show Extraction. - now left. diff --git a/test-suite/success/cc.v b/test-suite/success/cc.v index bbfe5ec42..49a8b9cf4 100644 --- a/test-suite/success/cc.v +++ b/test-suite/success/cc.v @@ -151,3 +151,17 @@ Section JLeivant. congruence. Qed. End JLeivant. + +(* An example with primitive projections *) + +Module PrimitiveProjections. +Set Primitive Projections. +Record t (A:Type) := { f : A }. +Goal forall g (a:t nat), @f nat = g -> f a = 0 -> g a = 0. +congruence. +Undo. +intros. +unfold f in H0. (* internally turn the projection to unfolded form *) +congruence. +Qed. +End PrimitiveProjections. diff --git a/test-suite/success/destruct.v b/test-suite/success/destruct.v index 6fbe61a9b..d1d384659 100644 --- a/test-suite/success/destruct.v +++ b/test-suite/success/destruct.v @@ -422,6 +422,7 @@ Abort. Goal forall b:bool, b = b. intros. destruct b eqn:H. +Abort. (* Check natural instantiation behavior when the goal has already an evar *) diff --git a/test-suite/success/evars.v b/test-suite/success/evars.v index 5b13f35d5..253b48e4d 100644 --- a/test-suite/success/evars.v +++ b/test-suite/success/evars.v @@ -421,3 +421,8 @@ Goal exists n : nat, n = n -> True. eexists. set (H := _ = _). Abort. + +(* Check interpretation of default evar instance in pretyping *) +(* (reported as bug #7356) *) + +Check fun (P : nat -> Prop) (x:nat) (h:P x) => exist _ ?[z] (h : P ?z). diff --git a/test-suite/success/goal_selector.v b/test-suite/success/goal_selector.v index 868140517..0951c5c8d 100644 --- a/test-suite/success/goal_selector.v +++ b/test-suite/success/goal_selector.v @@ -53,3 +53,17 @@ Goal True -> exists (x : Prop), x. Proof. intro H; eexists ?[x]; only [x]: exact True. 1: assumption. Qed. + +(* Strict focusing! *) +Set Default Goal Selector "!". + +Goal True -> True /\ True /\ True. +Proof. + intro. + split;only 2:split. + Fail exact I. + Fail !:exact I. + 1:exact I. + - !:exact H. + - exact I. +Qed. diff --git a/test-suite/success/intros.v b/test-suite/success/intros.v index a329894aa..d37ad9f52 100644 --- a/test-suite/success/intros.v +++ b/test-suite/success/intros.v @@ -127,4 +127,28 @@ induction 1 as (n,H,IH). exact Logic.I. Qed. +(* Make "intro"/"intros" progress on existential variables *) +Module Evar. + +Goal exists (A:Prop), A. +eexists. +unshelve (intro x). +- exact nat. +- exact (x=x). +- auto. +Qed. + +Goal exists (A:Prop), A. +eexists. +unshelve (intros x). +- exact nat. +- exact (x=x). +- auto. +Qed. + +Definition d := ltac:(intro x; exact (x*x)). + +Definition d' : nat -> _ := ltac:(intros;exact 0). + +End Evar. diff --git a/test-suite/success/name_mangling.v b/test-suite/success/name_mangling.v index 571dde880..e98241420 100644 --- a/test-suite/success/name_mangling.v +++ b/test-suite/success/name_mangling.v @@ -122,8 +122,7 @@ Lemma a : forall n, n = 0. Proof. fix a 1. Check a. -fix 1. -Fail Check a0. +Fail fix a 1. Abort. (* Test stability of "induction" *) diff --git a/test-suite/success/refine.v b/test-suite/success/refine.v index 22fb4d757..40986e57c 100644 --- a/test-suite/success/refine.v +++ b/test-suite/success/refine.v @@ -121,14 +121,16 @@ Abort. (* Wish 1988: that fun forces unfold in refine *) Goal (forall A : Prop, A -> ~~A). -Proof. refine(fun A a f => _). +Proof. refine(fun A a f => _). Abort. (* Checking beta-iota normalization of hypotheses in created evars *) Goal {x|x=0} -> True. refine (fun y => let (x,a) := y in _). match goal with a:_=0 |- _ => idtac end. +Abort. Goal (forall P, {P 0}+{P 1}) -> True. refine (fun H => if H (fun x => x=x) then _ else _). match goal with _:0=0 |- _ => idtac end. +Abort. diff --git a/test-suite/success/sideff.v b/test-suite/success/sideff.v index 3c0b81568..b9a1273b1 100644 --- a/test-suite/success/sideff.v +++ b/test-suite/success/sideff.v @@ -5,6 +5,8 @@ Proof. apply (const tt tt). Qed. +Set Nested Proofs Allowed. + Lemma foobar' : unit. Lemma aux : forall A : Type, A -> unit. Proof. intros. pose (foo := idw A). exact tt. Show Universes. Qed. diff --git a/test-suite/success/ssr_delayed_clear_rename.v b/test-suite/success/ssr_delayed_clear_rename.v new file mode 100644 index 000000000..951e5aff7 --- /dev/null +++ b/test-suite/success/ssr_delayed_clear_rename.v @@ -0,0 +1,5 @@ +Require Import ssreflect. +Example foo (t t1 t2 : True) : True /\ True -> True -> True. +Proof. +move=>[{t1 t2 t} t1 t2] t. +Abort. diff --git a/test-suite/unit-tests/.merlin b/test-suite/unit-tests/.merlin new file mode 100644 index 000000000..b2279de74 --- /dev/null +++ b/test-suite/unit-tests/.merlin @@ -0,0 +1,6 @@ +REC + +S ** +B ** + +PKG oUnit diff --git a/test-suite/unit-tests/clib/inteq.ml b/test-suite/unit-tests/clib/inteq.ml new file mode 100644 index 000000000..c07ec293f --- /dev/null +++ b/test-suite/unit-tests/clib/inteq.ml @@ -0,0 +1,13 @@ +open Utest + +let eq0 = mk_bool_test "clib-inteq0" + "Int.equal on 0" + (Int.equal 0 0) + +let eq42 = mk_bool_test "clib-inteq42" + "Int.equal on 42" + (Int.equal 42 42) + +let tests = [ eq0; eq42 ] + +let _ = run_tests __FILE__ tests diff --git a/test-suite/unit-tests/clib/unicode_tests.ml b/test-suite/unit-tests/clib/unicode_tests.ml new file mode 100644 index 000000000..9ae405977 --- /dev/null +++ b/test-suite/unit-tests/clib/unicode_tests.ml @@ -0,0 +1,15 @@ +open Utest + +let unicode0 = mk_eq_test "clib-unicode0" + "split_at_first_letter, first letter is character" + None + (Unicode.split_at_first_letter "ident") + +let unicode1 = mk_eq_test "clib-unicode1" + "split_at_first_letter, first letter not character" + (Some ("__","ident")) + (Unicode.split_at_first_letter "__ident") + +let tests = [ unicode0; unicode1 ] + +let _ = run_tests __FILE__ tests diff --git a/test-suite/unit-tests/src/utest.ml b/test-suite/unit-tests/src/utest.ml new file mode 100644 index 000000000..069e6a4bf --- /dev/null +++ b/test-suite/unit-tests/src/utest.ml @@ -0,0 +1,74 @@ +open OUnit + +(* general case to build a test *) +let mk_test nm test = nm >: test + +(* common cases for building tests *) +let mk_eq_test nm descr expected actual = + mk_test nm (TestCase (fun _ -> assert_equal ~msg:descr expected actual)) + +let mk_bool_test nm descr actual = + mk_test nm (TestCase (fun _ -> assert_bool descr actual)) + +let cfprintf oc = Printf.(kfprintf (fun oc -> fprintf oc "\n%!") oc) + +(* given test result, print message, return success boolean *) +let logger out_ch result = + let cprintf s = cfprintf out_ch s in + match result with + | RSuccess path -> + cprintf "TEST SUCCEEDED: %s" (string_of_path path); + true + | RError (path,msg) + | RFailure (path,msg) -> + cprintf "TEST FAILED: %s (%s)" (string_of_path path) msg; + false + | RSkip (path,msg) + | RTodo (path,msg) -> + cprintf "TEST DID NOT SUCCEED: %s (%s)" (string_of_path path) msg; + false + +(* run one OUnit test case, return successes, no. of tests *) +(* notionally one test, which might be a TestList *) +let run_one logit test = + let rec process_results rs = + match rs with + [] -> (0,0) + | (r::rest) -> + let succ = if logit r then 1 else 0 in + let succ_results,tot_results = process_results rest in + (succ + succ_results,tot_results + 1) + in + let results = perform_test (fun _ -> ()) test in + process_results results + +(* run list of OUnit test cases, log results *) +let run_tests ml_fn tests = + let log_fn = ml_fn ^ ".log" in + let out_ch = open_out log_fn in + let cprintf s = cfprintf out_ch s in + let ceprintf s = cfprintf stderr s in + let logit = logger out_ch in + let rec run_some tests succ tot = + match tests with + [] -> (succ,tot) + | (t::ts) -> + let succ_one,tot_one = run_one logit t in + run_some ts (succ + succ_one) (tot + tot_one) + in + (* format for test-suite summary to find status + success if all tests succeeded, else failure + *) + let succ,tot = run_some tests 0 0 in + cprintf + "*** Ran %d tests, with %d successes and %d failures ***" + tot succ (tot - succ); + if succ = tot then + cprintf + "==========> SUCCESS <==========\n %s...Ok" ml_fn + else begin + cprintf + "==========> FAILURE <==========\n %s...Error!" ml_fn; + ceprintf "FAILED %s.log" ml_fn + end; + close_out out_ch diff --git a/test-suite/unit-tests/src/utest.mli b/test-suite/unit-tests/src/utest.mli new file mode 100644 index 000000000..70928228b --- /dev/null +++ b/test-suite/unit-tests/src/utest.mli @@ -0,0 +1,12 @@ +(** give a name to a unit test *) +val mk_test : string -> OUnit.test -> OUnit.test + +(** simple ways to build a test *) +val mk_eq_test : string -> string -> 'a -> 'a -> OUnit.test +val mk_bool_test : string -> string -> bool -> OUnit.test + +(** run unit tests *) +(* the string argument should be the name of the .ml file + containing the tests; use __FILE__ for that purpose. + *) +val run_tests : string -> OUnit.test list -> unit diff --git a/theories/Arith/Div2.v b/theories/Arith/Div2.v index 42956c475..a5e457831 100644 --- a/theories/Arith/Div2.v +++ b/theories/Arith/Div2.v @@ -30,7 +30,7 @@ Lemma ind_0_1_SS : P 0 -> P 1 -> (forall n, P n -> P (S (S n))) -> forall n, P n. Proof. intros P H0 H1 H2. - fix 1. + fix ind_0_1_SS 1. destruct n as [|[|n]]. - exact H0. - exact H1. @@ -105,7 +105,7 @@ Hint Resolve double_S: arith. Lemma even_odd_double n : (even n <-> n = double (div2 n)) /\ (odd n <-> n = S (double (div2 n))). Proof. - revert n. fix 1. destruct n as [|[|n]]. + revert n. fix even_odd_double 1. destruct n as [|[|n]]. - (* n = 0 *) split; split; auto with arith. inversion 1. - (* n = 1 *) diff --git a/theories/Arith/Even.v b/theories/Arith/Even.v index baf119732..a1d0e9fcc 100644 --- a/theories/Arith/Even.v +++ b/theories/Arith/Even.v @@ -38,7 +38,7 @@ Hint Constructors odd: arith. Lemma even_equiv : forall n, even n <-> Nat.Even n. Proof. - fix 1. + fix even_equiv 1. destruct n as [|[|n]]; simpl. - split; [now exists 0 | constructor]. - split. @@ -52,7 +52,7 @@ Qed. Lemma odd_equiv : forall n, odd n <-> Nat.Odd n. Proof. - fix 1. + fix odd_equiv 1. destruct n as [|[|n]]; simpl. - split. + inversion_clear 1. diff --git a/theories/Arith/PeanoNat.v b/theories/Arith/PeanoNat.v index 4e4938a99..bc58995fd 100644 --- a/theories/Arith/PeanoNat.v +++ b/theories/Arith/PeanoNat.v @@ -315,7 +315,7 @@ Import Private_Parity. Lemma even_spec : forall n, even n = true <-> Even n. Proof. - fix 1. + fix even_spec 1. destruct n as [|[|n]]; simpl. - split; [ now exists 0 | trivial ]. - split; [ discriminate | intro H; elim (Even_1 H) ]. @@ -325,7 +325,7 @@ Qed. Lemma odd_spec : forall n, odd n = true <-> Odd n. Proof. unfold odd. - fix 1. + fix odd_spec 1. destruct n as [|[|n]]; simpl. - split; [ discriminate | intro H; elim (Odd_0 H) ]. - split; [ now exists 0 | trivial ]. @@ -473,7 +473,7 @@ Notation "( x | y )" := (divide x y) (at level 0) : nat_scope. Lemma gcd_divide : forall a b, (gcd a b | a) /\ (gcd a b | b). Proof. - fix 1. + fix gcd_divide 1. intros [|a] b; simpl. split. now exists 0. @@ -502,7 +502,7 @@ Qed. Lemma gcd_greatest : forall a b c, (c|a) -> (c|b) -> (c|gcd a b). Proof. - fix 1. + fix gcd_greatest 1. intros [|a] b; simpl; auto. fold (b mod (S a)). intros c H H'. apply gcd_greatest; auto. @@ -536,7 +536,7 @@ Qed. Lemma le_div2 n : div2 (S n) <= n. Proof. revert n. - fix 1. + fix le_div2 1. destruct n; simpl; trivial. apply lt_succ_r. destruct n; [simpl|]; trivial. now constructor. Qed. diff --git a/theories/Lists/Streams.v b/theories/Lists/Streams.v index 310c651e8..8a01b8fb1 100644 --- a/theories/Lists/Streams.v +++ b/theories/Lists/Streams.v @@ -196,7 +196,7 @@ Lemma ForAll_map : forall (P:Stream B -> Prop) (S:Stream A), ForAll (fun s => P (map s)) S <-> ForAll P (map S). Proof. intros P S. -split; generalize S; clear S; cofix; intros S; constructor; +split; generalize S; clear S; cofix ForAll_map; intros S; constructor; destruct H as [H0 H]; firstorder. Qed. diff --git a/theories/Logic/Berardi.v b/theories/Logic/Berardi.v index c6836a1c7..ed4d69ab0 100644 --- a/theories/Logic/Berardi.v +++ b/theories/Logic/Berardi.v @@ -82,7 +82,7 @@ End Retracts. (** This lemma is basically a commutation of implication and existential quantification: (EX x | A -> P(x)) <=> (A -> EX x | P(x)) which is provable in classical logic ( => is already provable in - intuitionnistic logic). *) + intuitionistic logic). *) Lemma L1 : forall A B:Prop, retract_cond (pow A) (pow B). Proof. @@ -136,7 +136,7 @@ trivial. Qed. -Theorem classical_proof_irrelevence : T = F. +Theorem classical_proof_irrelevance : T = F. Proof. generalize not_has_fixpoint. unfold Not_b. @@ -148,4 +148,7 @@ intros not_true is_true. elim not_true; trivial. Qed. + +Notation classical_proof_irrelevence := classical_proof_irrelevance (compat "8.8"). + End Berardis_paradox. diff --git a/theories/Logic/Diaconescu.v b/theories/Logic/Diaconescu.v index 3317766c9..66e82ddbf 100644 --- a/theories/Logic/Diaconescu.v +++ b/theories/Logic/Diaconescu.v @@ -234,8 +234,6 @@ Qed. (** An alternative more concise proof can be done by directly using the guarded relational choice *) -Declare Implicit Tactic auto. - Lemma proof_irrel_rel_choice_imp_eq_dec' : a1=a2 \/ ~a1=a2. Proof. assert (decide: forall x:A, x=a1 \/ x=a2 -> diff --git a/theories/PArith/BinPos.v b/theories/PArith/BinPos.v index 8d0896db7..000d895e1 100644 --- a/theories/PArith/BinPos.v +++ b/theories/PArith/BinPos.v @@ -1655,7 +1655,7 @@ Qed. Lemma sqrtrem_spec p : SqrtSpec (sqrtrem p) p. Proof. -revert p. fix 1. +revert p. fix sqrtrem_spec 1. destruct p; try destruct p; try (constructor; easy); apply sqrtrem_step_spec; auto. Qed. diff --git a/theories/Sorting/Heap.v b/theories/Sorting/Heap.v index d9e5ad676..2ef162be4 100644 --- a/theories/Sorting/Heap.v +++ b/theories/Sorting/Heap.v @@ -148,10 +148,10 @@ Section defs. forall l1:list A, Sorted leA l1 -> forall l2:list A, Sorted leA l2 -> merge_lem l1 l2. Proof. - fix 1; intros; destruct l1. + fix merge 1; intros; destruct l1. apply merge_exist with l2; auto with datatypes. rename l1 into l. - revert l2 H0. fix 1. intros. + revert l2 H0. fix merge0 1. intros. destruct l2 as [|a0 l0]. apply merge_exist with (a :: l); simpl; auto with datatypes. induction (leA_dec a a0) as [Hle|Hle]. diff --git a/theories/Unicode/Utf8_core.v b/theories/Unicode/Utf8_core.v index 5a8931a8c..d4cdb064f 100644 --- a/theories/Unicode/Utf8_core.v +++ b/theories/Unicode/Utf8_core.v @@ -14,10 +14,10 @@ (* Logic *) Notation "∀ x .. y , P" := (forall x, .. (forall y, P) ..) (at level 200, x binder, y binder, right associativity, - format "'[ ' ∀ x .. y ']' , P") : type_scope. + format "'[ ' '[ ' ∀ x .. y ']' , '/' P ']'") : type_scope. Notation "∃ x .. y , P" := (exists x, .. (exists y, P) ..) (at level 200, x binder, y binder, right associativity, - format "'[ ' ∃ x .. y ']' , P") : type_scope. + format "'[ ' '[ ' ∃ x .. y ']' , '/' P ']'") : type_scope. Notation "x ∨ y" := (x \/ y) (at level 85, right associativity) : type_scope. Notation "x ∧ y" := (x /\ y) (at level 80, right associativity) : type_scope. @@ -31,4 +31,4 @@ Notation "x ≠ y" := (x <> y) (at level 70) : type_scope. (* Abstraction *) Notation "'λ' x .. y , t" := (fun x => .. (fun y => t) ..) (at level 200, x binder, y binder, right associativity, - format "'[ ' 'λ' x .. y ']' , t"). + format "'[ ' '[ ' 'λ' x .. y ']' , '/' t ']'"). diff --git a/tools/CoqMakefile.in b/tools/CoqMakefile.in index f6539d80b..8e60d3932 100644 --- a/tools/CoqMakefile.in +++ b/tools/CoqMakefile.in @@ -227,7 +227,7 @@ ifdef DSTROOT DESTDIR := $(DSTROOT) endif -concat_path = $(if $(1),$(1)/$(subst $(COQMF_WINDRIVE),/,$(2)),$(2)) +concat_path = $(if $(1),$(1)/$(if $(COQMF_WINDRIVE),$(subst $(COQMF_WINDRIVE),/,$(2)),$(2)),$(2)) COQLIBINSTALL = $(call concat_path,$(DESTDIR),$(COQLIB)user-contrib) COQDOCINSTALL = $(call concat_path,$(DESTDIR),$(DOCDIR)user-contrib) @@ -382,7 +382,7 @@ real-all: $(VOFILES) $(if $(USEBYTE),bytefiles,optfiles) .PHONY: real-all real-all.timing.diff: $(VOFILES:.vo=.v.timing.diff) -.PHONE: real-all.timing.diff +.PHONY: real-all.timing.diff bytefiles: $(CMOFILES) $(CMAFILES) .PHONY: bytefiles diff --git a/tools/coq_makefile.ml b/tools/coq_makefile.ml index 6cd520d60..6f11ee397 100644 --- a/tools/coq_makefile.ml +++ b/tools/coq_makefile.ml @@ -215,7 +215,7 @@ let generate_conf_includes oc { ml_includes; r_includes; q_includes } = let windrive s = if Coq_config.arch_is_win32 && Str.(string_match (regexp "^[a-zA-Z]:") s 0) then Str.matched_string s - else s + else "" ;; let generate_conf_coq_config oc args = diff --git a/tools/coqdep.ml b/tools/coqdep.ml index 12b5cab0a..7db0b2890 100644 --- a/tools/coqdep.ml +++ b/tools/coqdep.ml @@ -8,15 +8,24 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) -open Printf +open Format open Coqdep_lexer open Coqdep_common -open System +open Minisys (** The basic parts of coqdep (i.e. the parts used by [coqdep -boot]) are now in [Coqdep_common]. The code that remains here concerns the other options. Calling this complete coqdep with the [-boot] option should be equivalent to calling [coqdep_boot]. + + As of today, this module depends on the following Coq modules: + + - Flags + - Envars + - CoqProject_file + + All of it for `coqlib` handling. Ideally we would like to clean + coqlib handling up so this can be bootstrapped earlier. *) let option_D = ref false @@ -31,8 +40,7 @@ let warning_mult suf iter = let d' = Hashtbl.find tab f in if (Filename.dirname (file_name f d)) <> (Filename.dirname (file_name f d')) then begin - eprintf "*** Warning : the file %s is defined twice!\n" (f ^ suf); - flush stderr + coqdep_warning "the file %s is defined twice!" (f ^ suf) end with Not_found -> () end; Hashtbl.add tab f d @@ -80,9 +88,7 @@ let mL_dep_list b f = while true do let (Use_module str) = caml_action buf in if str = b then begin - eprintf "*** Warning : in file %s the" f; - eprintf " notation %s. is useless !\n" b; - flush stderr + coqdep_warning "in file %s the notation %s. is useless !\n" f b end else if not (List.mem str !deja_vu) then addQueue deja_vu str done; [] @@ -98,16 +104,13 @@ let affiche_Declare f dcl = printf "\n*** In file %s: \n" f; printf "Declare ML Module"; List.iter (fun str -> printf " \"%s\"" str) dcl; - printf ".\n"; - flush stdout + printf ".\n%!" let warning_Declare f dcl = - eprintf "*** Warning : in file %s, the ML modules" f; - eprintf " declaration should be\n"; + eprintf "*** Warning : in file %s, the ML modules declaration should be\n" f; eprintf "*** Declare ML Module"; List.iter (fun str -> eprintf " \"%s\"" str) dcl; - eprintf ".\n"; - flush stderr + eprintf ".\n%!" let traite_Declare f = let decl_list = ref ([] : string list) in @@ -149,7 +152,7 @@ let declare_dependencies () = List.iter (fun (name,_) -> traite_Declare (name^".v"); - flush stdout) + pp_print_flush std_formatter ()) (List.rev !vAccu) (** DAGs guaranteed to be transitive reductions *) @@ -426,11 +429,11 @@ let coq_dependencies_dump chan dumpboxes = (DAG.empty, List.fold_left (fun ih (file, _) -> insert_raw_graph file ih) [] !vAccu, List.map fst !vAccu) !vAccu in - fprintf chan "digraph dependencies {\n"; flush chan; + fprintf chan "digraph dependencies {\n"; if dumpboxes then print_graphs chan (pop_common_prefix graphs) else List.iter (fun (name, _) -> fprintf chan "\"%s\"[label=\"%s\"]\n" name (basename_noext name)) !vAccu; DAG.iter (fun name dep -> fprintf chan "\"%s\" -> \"%s\"\n" dep name) deps; - fprintf chan "}\n" + fprintf chan "}\n%!" end @@ -498,7 +501,7 @@ let rec parse = function | "-suffix" :: s :: ll -> suffixe := s ; parse ll | "-suffix" :: [] -> usage () | "-slash" :: ll -> - Printf.eprintf "warning: option -slash has no effect and is deprecated.\n"; + coqdep_warning "warning: option -slash has no effect and is deprecated."; parse ll | "-dyndep" :: "no" :: ll -> option_dynlink := No; parse ll | "-dyndep" :: "opt" :: ll -> option_dynlink := Opt; parse ll @@ -509,6 +512,9 @@ let rec parse = function | f :: ll -> treat_file None f; parse ll | [] -> () +(* Exception to be raised by Envars *) +exception CoqlibError of string + let coqdep () = if Array.length Sys.argv < 2 then usage (); if not Coq_config.has_natdynlink then option_dynlink := No; @@ -520,18 +526,17 @@ let coqdep () = if !option_boot then begin add_rec_dir_import add_known "theories" ["Coq"]; add_rec_dir_import add_known "plugins" ["Coq"]; - add_caml_dir "tactics"; add_rec_dir_import (fun _ -> add_caml_known) "theories" ["Coq"]; add_rec_dir_import (fun _ -> add_caml_known) "plugins" ["Coq"]; end else begin - Envars.set_coqlib ~fail:(fun msg -> CErrors.user_err Pp.(str msg)); + Envars.set_coqlib ~fail:(fun msg -> raise (CoqlibError msg)); let coqlib = Envars.coqlib () in add_rec_dir_import add_coqlib_known (coqlib//"theories") ["Coq"]; add_rec_dir_import add_coqlib_known (coqlib//"plugins") ["Coq"]; let user = coqlib//"user-contrib" in if Sys.file_exists user then add_rec_dir_no_import add_coqlib_known user []; List.iter (fun s -> add_rec_dir_no_import add_coqlib_known s []) - (Envars.xdg_dirs ~warn:(fun x -> Feedback.msg_warning (Pp.str x))); + (Envars.xdg_dirs ~warn:(fun x -> coqdep_warning "%s" x)); List.iter (fun s -> add_rec_dir_no_import add_coqlib_known s []) Envars.coqpath; end; List.iter (fun (f,d) -> add_mli_known f d ".mli") !mliAccu; @@ -547,13 +552,13 @@ let coqdep () = | None -> () | Some (box, file) -> let chan = open_out file in - try Graph.coq_dependencies_dump chan box; close_out chan + let chan_fmt = formatter_of_out_channel chan in + try Graph.coq_dependencies_dump chan_fmt box; close_out chan with e -> close_out chan; raise e end let _ = try coqdep () - with CErrors.UserError(s,p) -> - let pp = (match s with | None -> p | Some s -> Pp.(str s ++ str ": " ++ p)) in - Format.eprintf "%a@\n%!" Pp.pp_with pp + with CoqlibError msg -> + eprintf "*** Error: %s@\n%!" msg diff --git a/tools/coqdep_common.ml b/tools/coqdep_common.ml index 70c983175..23b8bc112 100644 --- a/tools/coqdep_common.ml +++ b/tools/coqdep_common.ml @@ -8,9 +8,9 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) -open Printf -open Coqdep_lexer +open Format open Unix +open Coqdep_lexer open Minisys (** [coqdep_boot] is a stripped-down version of [coqdep], whose @@ -20,14 +20,15 @@ open Minisys options (see for instance [option_dynlink] below). *) +let coqdep_warning args = + eprintf "*** Warning: @["; + kfprintf (fun fmt -> fprintf fmt "@]\n%!") err_formatter args + module StrSet = Set.Make(String) module StrList = struct type t = string list let compare = compare end module StrListMap = Map.Make(StrList) -let stderr = Pervasives.stderr -let stdout = Pervasives.stdout - type dynlink = Opt | Byte | Both | No | Variable let option_c = ref false @@ -102,10 +103,19 @@ let safe_hash_add cmp clq q (k, (v, b)) = For the ML files, the string is the basename without extension. *) +let same_path_opt s s' = + let nf s = (* ./foo/a.ml and foo/a.ml are the same file *) + if Filename.is_implicit s + then "." // s + else s + in + let s = match s with None -> "." | Some s -> nf s in + let s' = match s' with None -> "." | Some s' -> nf s' in + s = s' + let warning_ml_clash x s suff s' suff' = - if suff = suff' then - eprintf - "*** Warning: %s%s already found in %s (discarding %s%s)\n" x suff + if suff = suff' && not (same_path_opt s s') then + coqdep_warning "%s%s already found in %s (discarding %s%s)\n" x suff (match s with None -> "." | Some d -> d) ((match s' with None -> "." | Some d -> d) // x) suff @@ -170,13 +180,11 @@ let error_cannot_parse s (i,j) = exit 1 let warning_module_notfound f s = - eprintf "*** Warning: in file %s, library %s is required and has not been found in the loadpath!\n%!" + coqdep_warning "in file %s, library %s is required and has not been found in the loadpath!" f (String.concat "." s) let warning_declare f s = - eprintf "*** Warning: in file %s, declared ML module " f; - eprintf "%s has not been found!\n" s; - flush stderr + coqdep_warning "in file %s, declared ML module %s has not been found!" f s let warning_clash file dir = match StrListMap.find dir !clash_v with @@ -193,8 +201,7 @@ let warning_clash file dir = | _ -> assert false let warning_cannot_open_dir dir = - eprintf "*** Warning: cannot open %s\n" dir; - flush stderr + coqdep_warning "cannot open %s" dir let safe_assoc from verbose file k = if verbose && StrListMap.mem k !clash_v then warning_clash file k; @@ -441,15 +448,13 @@ let mL_dependencies () = in let efullname = escape fullname in printf "%s.cmo:%s%s\n" efullname dep intf; - printf "%s.cmx:%s%s\n" efullname dep_opt intf; - flush stdout) + printf "%s.cmx:%s%s\n%!" efullname dep_opt intf) (List.rev !mlAccu); List.iter (fun (name,dirname) -> let fullname = file_name name dirname in let (dep,_) = traite_fichier_ML fullname ".mli" in - printf "%s.cmi:%s\n" (escape fullname) dep; - flush stdout) + printf "%s.cmi:%s\n%!" (escape fullname) dep) (List.rev !mliAccu); List.iter (fun (name,dirname) -> @@ -458,8 +463,7 @@ let mL_dependencies () = let efullname = escape fullname in printf "%s_MLLIB_DEPENDENCIES:=%s\n" efullname (String.concat " " dep); printf "%s.cma:$(addsuffix .cmo,$(%s_MLLIB_DEPENDENCIES))\n" efullname efullname; - printf "%s.cmxa:$(addsuffix .cmx,$(%s_MLLIB_DEPENDENCIES))\n" efullname efullname; - flush stdout) + printf "%s.cmxa:$(addsuffix .cmx,$(%s_MLLIB_DEPENDENCIES))\n%!" efullname efullname) (List.rev !mllibAccu); List.iter (fun (name,dirname) -> @@ -473,7 +477,7 @@ let mL_dependencies () = List.iter (fun dep -> printf "%s.cmx : FOR_PACK=-for-pack %s\n" dep efullname_capital) dep; - flush stdout) + printf "%!") (List.rev !mlpackAccu) let coq_dependencies () = @@ -486,8 +490,7 @@ let coq_dependencies () = printf "\n"; printf "%s.vio: %s.v" ename ename; traite_fichier_Coq ".vio" true (name ^ ".v"); - printf "\n"; - flush stdout) + printf "\n%!") (List.rev !vAccu) let rec suffixes = function diff --git a/tools/coqdep_common.mli b/tools/coqdep_common.mli index d0d793243..91d2b4587 100644 --- a/tools/coqdep_common.mli +++ b/tools/coqdep_common.mli @@ -10,6 +10,8 @@ module StrSet : Set.S with type elt = string +val coqdep_warning : ('a, Format.formatter, unit, unit) format4 -> 'a + (** [find_dir_logpath dir] Return the logical path of directory [dir] if it has been given one. Raise [Not_found] otherwise. In particular we can check if "." has been attributed a logical path diff --git a/tools/fake_ide.ml b/tools/fake_ide.ml index d48c6d0af..016201128 100644 --- a/tools/fake_ide.ml +++ b/tools/fake_ide.ml @@ -8,7 +8,7 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) -(** Fake_ide : Simulate a [coqide] talking to a [coqtop -ideslave] *) +(** Fake_ide : Simulate a [coqide] talking to a [coqidetop] *) let error s = prerr_endline ("fake_id: error: "^s); @@ -284,7 +284,7 @@ let read_command inc = Parser.parse grammar inc let usage () = error (Printf.sprintf - "A fake coqide process talking to a coqtop -ideslave.\n\ + "A fake coqide process talking to a coqtop -toploop coqidetop.\n\ Usage: %s (file|-) [<coqtop>]\n\ Input syntax is the following:\n%s\n" (Filename.basename Sys.argv.(0)) @@ -296,20 +296,8 @@ let main = if Sys.os_type = "Unix" then Sys.set_signal Sys.sigpipe (Sys.Signal_handle (fun _ -> prerr_endline "Broken Pipe (coqtop died ?)"; exit 1)); - let def_args = ["--xml_format=Ppcmds"; "-ideslave"] in - let coqtop_name = (* from ide/ideutils.ml *) - let prog_name = "fake_ide" in - let len_prog_name = String.length prog_name in - let fake_ide_path = Sys.executable_name in - let fake_ide_path_len = String.length fake_ide_path in - let pos = fake_ide_path_len - len_prog_name in - let rex = Str.regexp_string prog_name in - try - let i = Str.search_backward rex fake_ide_path pos in - String.sub fake_ide_path 0 i ^ "coqtop" ^ - String.sub fake_ide_path (i + len_prog_name) - (fake_ide_path_len - i - len_prog_name) - with Not_found -> assert false in + let def_args = ["--xml_format=Ppcmds"] in + let idetop_name = System.get_toplevel_path "coqidetop" in let coqtop_args, input_file = match Sys.argv with | [| _; f |] -> Array.of_list def_args, f | [| _; f; ct |] -> @@ -318,7 +306,7 @@ let main = | _ -> usage () in let inc = if input_file = "-" then stdin else open_in input_file in let coq = - let _p, cin, cout = Coqide.spawn coqtop_name coqtop_args in + let _p, cin, cout = Coqide.spawn idetop_name coqtop_args in let ip = Xml_parser.make (Xml_parser.SChannel cin) in let op = Xml_printer.make (Xml_printer.TChannel cout) in Xml_parser.check_eof ip false; diff --git a/tools/make-both-single-timing-files.py b/tools/make-both-single-timing-files.py index 32c52c7a1..c6af2ff1f 100755 --- a/tools/make-both-single-timing-files.py +++ b/tools/make-both-single-timing-files.py @@ -1,4 +1,4 @@ -#!/usr/bin/env python +#!/usr/bin/env python2 import sys from TimeFileMaker import * diff --git a/tools/make-both-time-files.py b/tools/make-both-time-files.py index f730a8d6b..643429679 100755 --- a/tools/make-both-time-files.py +++ b/tools/make-both-time-files.py @@ -1,4 +1,4 @@ -#!/usr/bin/env python +#!/usr/bin/env python2 import sys from TimeFileMaker import * diff --git a/tools/make-one-time-file.py b/tools/make-one-time-file.py index e66136df9..c9905249e 100755 --- a/tools/make-one-time-file.py +++ b/tools/make-one-time-file.py @@ -1,4 +1,4 @@ -#!/usr/bin/env python +#!/usr/bin/env python2 import sys from TimeFileMaker import * diff --git a/tools/ocamllibdep.mll b/tools/ocamllibdep.mll index 125c1452d..382c39d3f 100644 --- a/tools/ocamllibdep.mll +++ b/tools/ocamllibdep.mll @@ -116,8 +116,18 @@ let error_cannot_parse s (i,j) = Printf.eprintf "File \"%s\", characters %i-%i: Syntax error\n" s i j; exit 1 +let same_path_opt s s' = + let nf s = (* ./foo/a.ml and foo/a.ml are the same file *) + if Filename.is_implicit s + then "." // s + else s + in + let s = match s with None -> "." | Some s -> nf s in + let s' = match s' with None -> "." | Some s' -> nf s' in + s = s' + let warning_ml_clash x s suff s' suff' = - if suff = suff' then + if suff = suff' && not (same_path_opt s s') then eprintf "*** Warning: %s%s already found in %s (discarding %s%s)\n" x suff (match s with None -> "." | Some d -> d) diff --git a/stm/proofworkertop.ml b/topbin/coqproofworker_bin.ml index 4b85a05ac..7ae91cfbd 100644 --- a/stm/proofworkertop.ml +++ b/topbin/coqproofworker_bin.ml @@ -10,7 +10,5 @@ module W = AsyncTaskQueue.MakeWorker(Stm.ProofTask) () -let () = Coqtop.toploop_init := WorkerLoop.loop W.init_stdout - -let () = Coqtop.toploop_run := (fun _ ~state:_ -> W.main_loop ()) - +let () = + WorkerLoop.start ~init:W.init_stdout ~loop:W.main_loop diff --git a/stm/queryworkertop.ml b/topbin/coqqueryworker_bin.ml index aa00102aa..98c858121 100644 --- a/stm/queryworkertop.ml +++ b/topbin/coqqueryworker_bin.ml @@ -10,7 +10,4 @@ module W = AsyncTaskQueue.MakeWorker(Stm.QueryTask) () -let () = Coqtop.toploop_init := WorkerLoop.loop W.init_stdout - -let () = Coqtop.toploop_run := (fun _ ~state:_ -> W.main_loop ()) - +let () = WorkerLoop.start ~init:W.init_stdout ~loop:W.main_loop diff --git a/stm/tacworkertop.ml b/topbin/coqtacticworker_bin.ml index 3b91df86e..2634baa83 100644 --- a/stm/tacworkertop.ml +++ b/topbin/coqtacticworker_bin.ml @@ -10,7 +10,4 @@ module W = AsyncTaskQueue.MakeWorker(Stm.TacTask) () -let () = Coqtop.toploop_init := WorkerLoop.loop W.init_stdout - -let () = Coqtop.toploop_run := (fun _ ~state:_ -> W.main_loop ()) - +let () = WorkerLoop.start ~init:W.init_stdout ~loop:W.main_loop diff --git a/toplevel/coqtop_opt_bin.ml b/topbin/coqtop_bin.ml index ea4c0ea52..4490db59e 100644 --- a/toplevel/coqtop_opt_bin.ml +++ b/topbin/coqtop_bin.ml @@ -13,4 +13,4 @@ let drop_setup () = Mltop.remove () (* Main coqtop initialization *) let _ = drop_setup (); - Coqtop.start() + Coqtop.(start_coq coqtop_toplevel) diff --git a/toplevel/coqtop_byte_bin.ml b/topbin/coqtop_byte_bin.ml index 0b65cebbb..abe397830 100644 --- a/toplevel/coqtop_byte_bin.ml +++ b/topbin/coqtop_byte_bin.ml @@ -31,4 +31,4 @@ let drop_setup () = (* Main coqtop initialization *) let _ = drop_setup (); - Coqtop.start() + Coqtop.(start_coq coqtop_toplevel) diff --git a/toplevel/coqargs.ml b/toplevel/coqargs.ml index a1a07fce8..89602c9b5 100644 --- a/toplevel/coqargs.ml +++ b/toplevel/coqargs.ml @@ -10,8 +10,8 @@ let warning s = Flags.(with_option warn Feedback.msg_warning (Pp.strbrk s)) -let fatal_error ?extra exn = - Topfmt.print_err_exn ?extra exn; +let fatal_error exn = + Topfmt.print_err_exn Topfmt.ParsingCommandLine exn; let exit_code = if CErrors.(is_anomaly exn || not (handled exn)) then 129 else 1 in exit exit_code @@ -52,7 +52,6 @@ type coq_cmdopts = { compilation_mode : compilation_mode; toplevel_name : Names.DirPath.t; - toploop : string option; compile_list: (string * bool) list; (* bool is verbosity *) compilation_output_name : string option; @@ -81,6 +80,8 @@ type coq_cmdopts = { print_config: bool; output_context : bool; + print_emacs : bool; + inputstate : string option; outputstate : string option; @@ -100,7 +101,6 @@ let init_args = { compilation_mode = BuildVo; toplevel_name = Names.(DirPath.make [Id.of_string "Top"]); - toploop = None; compile_list = []; compilation_output_name = None; @@ -129,6 +129,8 @@ let init_args = { print_config = false; output_context = false; + print_emacs = false; + inputstate = None; outputstate = None; } @@ -191,11 +193,8 @@ let set_vio_checking_j opts opt j = (** Options for proof general *) let set_emacs opts = - if not (Option.is_empty opts.toploop) then - CErrors.user_err Pp.(str "Flag -emacs is incompatible with a custom toplevel loop"); - Coqloop.print_emacs := true; Printer.enable_goal_tags_printing := true; - { opts with color = `OFF } + { opts with color = `OFF; print_emacs = true } let set_color opts = function | "yes" | "on" -> { opts with color = `ON } @@ -310,12 +309,9 @@ let usage batch = let lp = Coqinit.toplevel_init_load_path () in (* Necessary for finding the toplevels below *) List.iter Mltop.add_coq_path lp; - if batch then Usage.print_usage_coqc () - else begin - Mltop.load_ml_objects_raw_rex - (Str.regexp (if Mltop.is_native then "^.*top.cmxs$" else "^.*top.cma$")); - Usage.print_usage_coqtop () - end + if batch + then Usage.print_usage_coqc () + else Usage.print_usage_coqtop () (* Main parsing routine *) let parse_args arglist : coq_cmdopts * string list = @@ -401,7 +397,7 @@ let parse_args arglist : coq_cmdopts * string list = }} |"-async-proofs-worker-priority" -> - WorkerLoop.async_proofs_worker_priority := get_priority opt (next ()); + CoqworkmgrApi.async_proofs_worker_priority := get_priority opt (next ()); oval |"-async-proofs-private-flags" -> @@ -500,11 +496,6 @@ let parse_args arglist : coq_cmdopts * string list = let oval = add_compile oval false (next ()) in { oval with compilation_mode = Vio2Vo } - |"-toploop" -> - if !Coqloop.print_emacs then - CErrors.user_err Pp.(str "Flags -toploop and -emacs are incompatible"); - { oval with toploop = Some (next ()) } - |"-w" | "-W" -> let w = next () in if w = "none" then @@ -538,12 +529,6 @@ let parse_args arglist : coq_cmdopts * string list = |"-stm-debug" -> Stm.stm_debug := true; oval |"-emacs" -> set_emacs oval |"-filteropts" -> { oval with filter_opts = true } - |"-ideslave" -> - if !Coqloop.print_emacs then - CErrors.user_err Pp.(str "Flags -ideslave and -emacs are incompatible"); - Flags.ide_slave := true; - { oval with toploop = Some "coqidetop" } - |"-impredicative-set" -> { oval with impredicative_set = Declarations.ImpredicativeSet } |"-indices-matter" -> Indtypes.enforce_indices_matter (); oval diff --git a/toplevel/coqargs.mli b/toplevel/coqargs.mli index de9b6a682..9fb6219a6 100644 --- a/toplevel/coqargs.mli +++ b/toplevel/coqargs.mli @@ -27,7 +27,6 @@ type coq_cmdopts = { compilation_mode : compilation_mode; toplevel_name : Names.DirPath.t; - toploop : string option; compile_list: (string * bool) list; (* bool is verbosity *) compilation_output_name : string option; @@ -56,6 +55,8 @@ type coq_cmdopts = { print_config: bool; output_context : bool; + print_emacs : bool; + inputstate : string option; outputstate : string option; diff --git a/toplevel/coqinit.ml b/toplevel/coqinit.ml index 3e7a83085..e61f830f3 100644 --- a/toplevel/coqinit.ml +++ b/toplevel/coqinit.ml @@ -75,16 +75,12 @@ let ml_path_if c p = let f x = { recursive = false; path_spec = MlPath x } in if c then List.map f p else [] -(* LoadPath for toploop toplevels *) +(* LoadPath for developers *) let toplevel_init_load_path () = let coqlib = Envars.coqlib () in (* NOTE: These directories are searched from last to first *) (* first, developer specific directory to open *) - ml_path_if Coq_config.local [coqlib/"dev"] @ - - (* main loops *) - ml_path_if (Coq_config.local || !Flags.boot) [coqlib/"stm"; coqlib/"ide"] @ - ml_path_if (System.exists_dir (coqlib/"toploop")) [coqlib/"toploop"] + ml_path_if Coq_config.local [coqlib/"dev"] (* LoadPath for Coq user libraries *) let libs_init_load_path ~load_init = diff --git a/toplevel/coqloop.ml b/toplevel/coqloop.ml index d0989cfcc..d7ede1c2e 100644 --- a/toplevel/coqloop.ml +++ b/toplevel/coqloop.ml @@ -150,29 +150,28 @@ let print_highlight_location ib loc = let valid_buffer_loc ib loc = let (b,e) = Loc.unloc loc in b-ib.start >= 0 && e-ib.start < ib.len && b<=e - (* Toplevel error explanation. *) -let error_info_for_buffer ?loc buf = - Option.map (fun loc -> +let error_info_for_buffer ?loc phase buf = + match loc with + | None -> Topfmt.pr_phase ?loc phase + | Some loc -> let fname = loc.Loc.fname in - let hl, loc = (* We are in the toplevel *) - match fname with - | Loc.ToplevelInput -> - let nloc = adjust_loc_buf buf loc in - if valid_buffer_loc buf loc then - (fnl () ++ print_highlight_location buf nloc, nloc) - (* in the toplevel, but not a valid buffer *) - else (mt (), nloc) - (* we are in batch mode, don't adjust location *) - | Loc.InFile _ -> - (mt (), loc) - in Topfmt.pr_loc loc ++ hl - ) loc + match fname with + | Loc.ToplevelInput -> + let nloc = adjust_loc_buf buf loc in + if valid_buffer_loc buf loc then + match Topfmt.pr_phase ~loc:nloc phase with + | None -> None + | Some hd -> Some (hd ++ fnl () ++ print_highlight_location buf nloc) + (* in the toplevel, but not a valid buffer *) + else Topfmt.pr_phase ~loc phase + (* we are in batch mode, don't adjust location *) + | Loc.InFile _ -> Topfmt.pr_phase ~loc phase (* Actual printing routine *) -let print_error_for_buffer ?loc lvl msg buf = - let pre_hdr = error_info_for_buffer ?loc buf in +let print_error_for_buffer ?loc phase lvl msg buf = + let pre_hdr = error_info_for_buffer ?loc phase buf in if !print_emacs then Topfmt.emacs_logger ?pre_hdr lvl msg else Topfmt.std_logger ?pre_hdr lvl msg @@ -272,8 +271,17 @@ let read_sentence ~state input = (* TopErr.print_toplevel_parse_error reraise top_buffer; *) Exninfo.iraise reraise +let extract_default_loc loc doc_id sid : Loc.t option = + match loc with + | Some _ -> loc + | None -> + try + let doc = Stm.get_doc doc_id in + Option.cata fst None Stm.(get_ast ~doc sid) + with _ -> loc + (** Coqloop Console feedback handler *) -let coqloop_feed (fb : Feedback.feedback) = let open Feedback in +let coqloop_feed phase (fb : Feedback.feedback) = let open Feedback in match fb.contents with | Processed -> () | Incomplete -> () @@ -290,8 +298,11 @@ let coqloop_feed (fb : Feedback.feedback) = let open Feedback in (* Re-enable when we switch back to feedback-based error printing *) | Message (Error,loc,msg) -> () (* TopErr.print_error_for_buffer ?loc lvl msg top_buffer *) + | Message (Warning,loc,msg) -> + let loc = extract_default_loc loc fb.doc_id fb.span_id in + TopErr.print_error_for_buffer ?loc phase Warning msg top_buffer | Message (lvl,loc,msg) -> - TopErr.print_error_for_buffer ?loc lvl msg top_buffer + TopErr.print_error_for_buffer ?loc phase lvl msg top_buffer (** Main coq loop : read vernacular expressions until Drop is entered. Ctrl-C is handled internally as Sys.Break instead of aborting Coq. @@ -341,7 +352,7 @@ let top_goal_print oldp newp = let (e, info) = CErrors.push exn in let loc = Loc.get_loc info in let msg = CErrors.iprint (e, info) in - TopErr.print_error_for_buffer ?loc Feedback.Error msg top_buffer + TopErr.print_error_for_buffer ?loc Topfmt.InteractiveLoop Feedback.Error msg top_buffer (* Careful to keep this loop tail-rec *) let rec vernac_loop ~state = @@ -383,7 +394,7 @@ let rec vernac_loop ~state = let (e, info) = CErrors.push any in let loc = Loc.get_loc info in let msg = CErrors.iprint (e, info) in - TopErr.print_error_for_buffer ?loc Feedback.Error msg top_buffer; + TopErr.print_error_for_buffer ?loc Topfmt.InteractiveLoop Feedback.Error msg top_buffer; vernac_loop ~state let rec loop ~state = @@ -399,3 +410,25 @@ let rec loop ~state = str (Printexc.to_string any)) ++ spc () ++ hov 0 (str "Please report at " ++ str Coq_config.wwwbugtracker ++ str ".")); loop ~state + +(* Default toplevel loop *) +let warning s = Flags.(with_option warn Feedback.msg_warning (strbrk s)) + +let drop_args = ref None +let loop ~opts ~state = + drop_args := Some opts; + let open Coqargs in + print_emacs := opts.print_emacs; + (* We initialize the console only if we run the toploop_run *) + let tl_feed = Feedback.add_feeder (coqloop_feed Topfmt.InteractiveLoop) in + if Dumpglob.dump () then begin + Flags.if_verbose warning "Dumpglob cannot be used in interactive mode."; + Dumpglob.noglob () + end; + let _ = loop ~state in + (* Initialise and launch the Ocaml toplevel *) + Coqinit.init_ocaml_path(); + Mltop.ocaml_toploop(); + (* We delete the feeder after the OCaml toploop has ended so users + of Drop can see the feedback. *) + Feedback.del_feeder tl_feed diff --git a/toplevel/coqloop.mli b/toplevel/coqloop.mli index 39a9de4f8..5c07a8bf3 100644 --- a/toplevel/coqloop.mli +++ b/toplevel/coqloop.mli @@ -10,9 +10,6 @@ (** The Coq toplevel loop. *) -(** -emacs option: printing includes emacs tags. *) -val print_emacs : bool ref - (** A buffer for the character read from a channel. We store the command * entered to be able to report errors without pretty-printing. *) @@ -30,10 +27,11 @@ val top_buffer : input_buffer val set_prompt : (unit -> string) -> unit (** Toplevel feedback printer. *) -val coqloop_feed : Feedback.feedback -> unit - -(** Main entry point of Coq: read and execute vernac commands. *) -val loop : state:Vernac.State.t -> Vernac.State.t +val coqloop_feed : Topfmt.execution_phase -> Feedback.feedback -> unit (** Last document seen after `Drop` *) val drop_last_doc : Vernac.State.t option ref +val drop_args : Coqargs.coq_cmdopts option ref + +(** Main entry point of Coq: read and execute vernac commands. *) +val loop : opts:Coqargs.coq_cmdopts -> state:Vernac.State.t -> unit diff --git a/toplevel/coqtop.ml b/toplevel/coqtop.ml index a08cfa9f4..e979d0e54 100644 --- a/toplevel/coqtop.ml +++ b/toplevel/coqtop.ml @@ -30,29 +30,14 @@ let print_header () = Feedback.msg_notice (str "Welcome to Coq " ++ str ver ++ str " (" ++ str rev ++ str ")"); flush_all () -let warning s = Flags.(with_option warn Feedback.msg_warning (strbrk s)) - (* Feedback received in the init stage, this is different as the STM will not be generally be initialized, thus stateid, etc... may be bogus. For now we just print to the console too *) -let coqtop_init_feed = Coqloop.coqloop_feed - -(* Default toplevel loop *) -let console_toploop_run opts ~state = - (* We initialize the console only if we run the toploop_run *) - let tl_feed = Feedback.add_feeder Coqloop.coqloop_feed in - if Dumpglob.dump () then begin - Flags.if_verbose warning "Dumpglob cannot be used in interactive mode."; - Dumpglob.noglob () - end; - let _ = Coqloop.loop ~state in - (* Initialise and launch the Ocaml toplevel *) - Coqinit.init_ocaml_path(); - Mltop.ocaml_toploop(); - (* We let the feeder in place for users of Drop *) - Feedback.del_feeder tl_feed +let coqtop_init_feed = Coqloop.coqloop_feed Topfmt.Initialization + +let coqtop_doc_feed = Coqloop.coqloop_feed Topfmt.LoadingPrelude -let toploop_run = ref console_toploop_run +let coqtop_rcfile_feed = Coqloop.coqloop_feed Topfmt.LoadingRcFile let memory_stat = ref false let print_memory_stat () = @@ -101,9 +86,16 @@ let load_vernacular opts ~state = else load_vernac s ) state (List.rev opts.load_vernacular_list) -let load_init_vernaculars opts ~state = - let state = if opts.load_rcfile then - Coqinit.load_rcfile ~rcfile:opts.rcfile ~state +let load_init_vernaculars cur_feeder opts ~state = + let state = + if opts.load_rcfile then begin + Feedback.del_feeder !cur_feeder; + let rc_feeder = Feedback.add_feeder coqtop_rcfile_feed in + let state = Coqinit.load_rcfile ~rcfile:opts.rcfile ~state in + Feedback.del_feeder rc_feeder; + cur_feeder := Feedback.add_feeder coqtop_init_feed; + state + end else begin Flags.if_verbose Feedback.msg_info (str"Skipping rcfile loading."); state @@ -147,8 +139,8 @@ let fatal_error msg = flush_all (); exit 1 -let fatal_error_exn ?extra exn = - Topfmt.print_err_exn ?extra exn; +let fatal_error_exn exn = + Topfmt.print_err_exn Topfmt.Initialization exn; flush_all (); let exit_code = if CErrors.(is_anomaly exn || not (handled exn)) then 129 else 1 @@ -194,7 +186,7 @@ let ensure_exists f = fatal_error (hov 0 (str "Can't find file" ++ spc () ++ str f)) (* Compile a vernac file *) -let compile opts ~echo ~f_in ~f_out = +let compile cur_feeder opts ~echo ~f_in ~f_out = let open Vernac.State in let check_pending_proofs () = let pfs = Proof_global.get_all_proof_names () in @@ -218,13 +210,18 @@ let compile opts ~echo ~f_in ~f_out = | None -> long_f_dot_v ^ "o" | Some f -> ensure_vo long_f_dot_v f in - let doc, sid = Stm.(new_doc + Feedback.del_feeder !cur_feeder; + let doc_feeder = Feedback.add_feeder coqtop_doc_feed in + let doc, sid = + Stm.(new_doc { doc_type = VoDoc long_f_dot_vo; iload_path; require_libs; stm_options; }) in + Feedback.del_feeder doc_feeder; + cur_feeder := Feedback.add_feeder coqtop_init_feed; let state = { doc; sid; proof = None; time = opts.time } in - let state = load_init_vernaculars opts ~state in + let state = load_init_vernaculars cur_feeder opts ~state in let ldir = Stm.get_ldir ~doc:state.doc in Aux_file.(start_aux_file ~aux_file:(aux_file_name_for long_f_dot_vo) @@ -265,13 +262,18 @@ let compile opts ~echo ~f_in ~f_out = async_proofs_tac_error_resilience = `None; } in - let doc, sid = Stm.(new_doc + Feedback.del_feeder !cur_feeder; + let doc_feeder = Feedback.add_feeder coqtop_doc_feed in + let doc, sid = + Stm.(new_doc { doc_type = VioDoc long_f_dot_vio; iload_path; require_libs; stm_options; }) in + Feedback.del_feeder doc_feeder; + cur_feeder := Feedback.add_feeder coqtop_init_feed; let state = { doc; sid; proof = None; time = opts.time } in - let state = load_init_vernaculars opts ~state in + let state = load_init_vernaculars cur_feeder opts ~state in let ldir = Stm.get_ldir ~doc:state.doc in let state = Vernac.load_vernac ~echo ~check:false ~interactive:false ~state long_f_dot_v in let doc = Stm.finish ~doc:state.doc in @@ -288,21 +290,22 @@ let compile opts ~echo ~f_in ~f_out = let univs, proofs = Stm.finish_tasks lfdv univs disch proofs tasks in Library.save_library_raw lfdv sum lib univs proofs -let compile opts ~echo ~f_in ~f_out = +let compile cur_feeder opts ~echo ~f_in ~f_out = ignore(CoqworkmgrApi.get 1); - compile opts ~echo ~f_in ~f_out; + compile cur_feeder opts ~echo ~f_in ~f_out; CoqworkmgrApi.giveback 1 -let compile_file opts (f_in, echo) = +let compile_file cur_feeder opts (f_in, echo) = + let f_out = opts.compilation_output_name in if !Flags.beautify then Flags.with_option Flags.beautify_file - (fun f_in -> compile opts ~echo ~f_in ~f_out:None) f_in + (fun f_in -> compile cur_feeder opts ~echo ~f_in ~f_out) f_in else - compile opts ~echo ~f_in ~f_out:None + compile cur_feeder opts ~echo ~f_in ~f_out -let compile_files opts = +let compile_files cur_feeder opts = let compile_list = List.rev opts.compile_list in - List.iter (compile_file opts) compile_list + List.iter (compile_file cur_feeder opts) compile_list (******************************************************************************) (* VIO Dispatching *) @@ -315,16 +318,24 @@ let check_vio_tasks opts = (* vio files *) let schedule_vio opts = - (* We must add update the loadpath here as the scheduling process - happens outside of the STM *) - let iload_path = build_load_path opts in - List.iter Mltop.add_coq_path iload_path; - if opts.vio_checking then Vio_checking.schedule_vio_checking opts.vio_files_j opts.vio_files else Vio_checking.schedule_vio_compilation opts.vio_files_j opts.vio_files +let do_vio opts = + (* We must initialize the loadpath here as the vio scheduling + process happens outside of the STM *) + if opts.vio_files <> [] || opts.vio_tasks <> [] then + let iload_path = build_load_path opts in + List.iter Mltop.add_coq_path iload_path; + + (* Vio compile pass *) + if opts.vio_files <> [] then schedule_vio opts; + (* Vio task pass *) + if opts.vio_tasks <> [] then check_vio_tasks opts + + (******************************************************************************) (* Color Options *) (******************************************************************************) @@ -357,12 +368,6 @@ let init_color color_mode = else Topfmt.init_terminal_output ~color:false -let toploop_init = ref begin fun opts x -> - let () = init_color opts.color in - let () = CoqworkmgrApi.init !WorkerLoop.async_proofs_worker_priority in - x - end - let print_style_tags opts = let () = init_color opts.color in let tags = Topfmt.dump_tags () in @@ -405,14 +410,14 @@ let init_gc () = Gc.space_overhead = 120} (** Main init routine *) -let init_toplevel arglist = +let init_toplevel custom_init arglist = (* Coq's init process, phase 1: OCaml parameters, basic structures, and IO *) CProfile.init_profile (); init_gc (); Sys.catch_break false; (* Ctrl-C is fatal during the initialisation *) - let init_feeder = Feedback.add_feeder coqtop_init_feed in + let init_feeder = ref (Feedback.add_feeder coqtop_init_feed) in Lib.init(); (* Coq's init process, phase 2: @@ -427,14 +432,25 @@ let init_toplevel arglist = * early since the master waits us to connect back *) Spawned.init_channels (); Envars.set_coqlib ~fail:(fun msg -> CErrors.user_err Pp.(str msg)); - if opts.print_where then (print_endline(Envars.coqlib ()); exit(exitcode opts)); - if opts.print_config then (Envars.print_config stdout Coq_config.all_src_dirs; exit (exitcode opts)); - if opts.print_tags then (print_style_tags opts; exit (exitcode opts)); - if opts.filter_opts then (print_string (String.concat "\n" extras); exit 0); + if opts.print_where then begin + print_endline (Envars.coqlib ()); + exit (exitcode opts) + end; + if opts.print_config then begin + Envars.print_config stdout Coq_config.all_src_dirs; + exit (exitcode opts) + end; + if opts.print_tags then begin + print_style_tags opts; + exit (exitcode opts) + end; + if opts.filter_opts then begin + print_string (String.concat "\n" extras); + exit 0; + end; let top_lp = Coqinit.toplevel_init_load_path () in List.iter Mltop.add_coq_path top_lp; - Option.iter Mltop.load_ml_object_raw opts.toploop; - let extras = !toploop_init opts extras in + let opts, extras = custom_init ~opts extras in if not (CList.is_empty extras) then begin prerr_endline ("Don't know what to do with "^String.concat " " extras); prerr_endline "See -help for the list of supported options"; @@ -469,42 +485,52 @@ let init_toplevel arglist = let iload_path = build_load_path opts in let require_libs = require_libs opts in let stm_options = opts.stm_flags in - try - let open Vernac.State in - let doc, sid = - Stm.(new_doc - { doc_type = Interactive opts.toplevel_name; - iload_path; require_libs; stm_options; - }) in - let state = { doc; sid; proof = None; time = opts.time } in - Some (load_init_vernaculars opts ~state), opts - with any -> flush_all(); fatal_error_exn any + let open Vernac.State in + Feedback.del_feeder !init_feeder; + let doc_feeder = Feedback.add_feeder coqtop_doc_feed in + let doc, sid = + Stm.(new_doc + { doc_type = Interactive opts.toplevel_name; + iload_path; require_libs; stm_options; + }) in + Feedback.del_feeder doc_feeder; + init_feeder := Feedback.add_feeder coqtop_init_feed; + let state = { doc; sid; proof = None; time = opts.time } in + Some (load_init_vernaculars init_feeder opts ~state), opts (* Non interactive: we perform a sequence of compilation steps *) end else begin - try - compile_files opts; - (* Vio compile pass *) - if opts.vio_files <> [] then schedule_vio opts; - (* Vio task pass *) - check_vio_tasks opts; - (* Allow the user to output an arbitrary state *) - outputstate opts; - None, opts - with any -> flush_all(); fatal_error_exn any + compile_files init_feeder opts; + (* Careful this will modify the load-path and state so after + this point some stuff may not be safe anymore. *) + do_vio opts; + (* Allow the user to output an arbitrary state *) + outputstate opts; + None, opts end; with any -> flush_all(); - let extra = Some (str "Error during initialization: ") in - fatal_error_exn ?extra any + fatal_error_exn any end in - Feedback.del_feeder init_feeder; + Feedback.del_feeder !init_feeder; res -let start () = - match init_toplevel (List.tl (Array.to_list Sys.argv)) with +type custom_toplevel = { + init : opts:coq_cmdopts -> string list -> coq_cmdopts * string list; + run : opts:coq_cmdopts -> state:Vernac.State.t -> unit; +} + +let coqtop_init ~opts extra = + init_color opts.color; + CoqworkmgrApi.(init !async_proofs_worker_priority); + opts, extra + +let coqtop_toplevel = { init = coqtop_init; run = Coqloop.loop; } + +let start_coq custom = + match init_toplevel custom.init (List.tl (Array.to_list Sys.argv)) with (* Batch mode *) | Some state, opts when not opts.batch_mode -> - !toploop_run opts ~state; + custom.run ~opts ~state; exit 1 | _ , opts -> flush_all(); diff --git a/toplevel/coqtop.mli b/toplevel/coqtop.mli index 056279bbd..641448f10 100644 --- a/toplevel/coqtop.mli +++ b/toplevel/coqtop.mli @@ -8,15 +8,21 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) -(** The Coq main module. The following function [start] will parse the - command line, print the banner, initialize the load path, load the input - state, load the files given on the command line, load the resource file, - produce the output state if any, and finally will launch [Coqloop.loop]. *) +(** Definition of custom toplevels. + [init] is used to do custom command line argument parsing. + [run] launches a custom toplevel. +*) +type custom_toplevel = { + init : opts:Coqargs.coq_cmdopts -> string list -> Coqargs.coq_cmdopts * string list; + run : opts:Coqargs.coq_cmdopts -> state:Vernac.State.t -> unit; +} -val init_toplevel : string list -> Vernac.State.t option * Coqargs.coq_cmdopts +val coqtop_toplevel : custom_toplevel -val start : unit -> unit +(** The Coq main module. [start custom] will parse the command line, + print the banner, initialize the load path, load the input state, + load the files given on the command line, load the resource file, + produce the output state if any, and finally will launch + [custom.run]. *) -(* For other toploops *) -val toploop_init : (Coqargs.coq_cmdopts -> string list -> string list) ref -val toploop_run : (Coqargs.coq_cmdopts -> state:Vernac.State.t -> unit) ref +val start_coq : custom_toplevel -> unit diff --git a/toplevel/g_toplevel.ml4 b/toplevel/g_toplevel.ml4 index d5d558b9b..e3cefe236 100644 --- a/toplevel/g_toplevel.ml4 +++ b/toplevel/g_toplevel.ml4 @@ -35,7 +35,7 @@ GEXTEND Gram | IDENT "Quit"; "." -> CAst.make VernacQuit | IDENT "Backtrack"; n = natural ; m = natural ; p = natural; "." -> CAst.make (VernacBacktrack (n,m,p)) - | cmd = main_entry -> + | cmd = Pvernac.main_entry -> match cmd with | None -> raise Stm.End_of_input | Some (loc,c) -> CAst.make ~loc (VernacControl c) diff --git a/toplevel/toplevel.mllib b/toplevel/toplevel.mllib index 78b96e5e2..597173e5f 100644 --- a/toplevel/toplevel.mllib +++ b/toplevel/toplevel.mllib @@ -1,7 +1,8 @@ Vernac Usage -G_toplevel -Coqloop Coqinit Coqargs +G_toplevel +Coqloop Coqtop +WorkerLoop diff --git a/stm/workerLoop.ml b/toplevel/workerLoop.ml index 5445925b1..ee6d5e884 100644 --- a/stm/workerLoop.ml +++ b/toplevel/workerLoop.ml @@ -8,18 +8,22 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) -(* Default priority *) -open CoqworkmgrApi -let async_proofs_worker_priority = ref Low - let rec parse = function | "--xml_format=Ppcmds" :: rest -> parse rest | x :: rest -> x :: parse rest | [] -> [] -let loop init _coq_args extra_args = - let args = parse extra_args in +let arg_init init ~opts extra_args = + let extra_args = parse extra_args in Flags.quiet := true; init (); - CoqworkmgrApi.init !async_proofs_worker_priority; - args + CoqworkmgrApi.(init !async_proofs_worker_priority); + opts, extra_args + +let start ~init ~loop = + let open Coqtop in + let custom = { + init = arg_init init; + run = (fun ~opts:_ ~state:_ -> loop ()); + } in + start_coq custom diff --git a/toplevel/workerLoop.mli b/toplevel/workerLoop.mli new file mode 100644 index 000000000..e497dee6d --- /dev/null +++ b/toplevel/workerLoop.mli @@ -0,0 +1,14 @@ +(************************************************************************) +(* * 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) *) +(************************************************************************) + +(* Register a STM worker *) +val start : + init:(unit -> unit) -> + loop:(unit -> unit) -> unit diff --git a/vernac/assumptions.mli b/vernac/assumptions.mli index 7e13f8f28..0e2b0c80e 100644 --- a/vernac/assumptions.mli +++ b/vernac/assumptions.mli @@ -30,4 +30,4 @@ val traverse : {!traverse} also applies. *) val assumptions : ?add_opaque:bool -> ?add_transparent:bool -> transparent_state -> - global_reference -> constr -> types ContextObjectMap.t + GlobRef.t -> constr -> types ContextObjectMap.t diff --git a/vernac/auto_ind_decl.ml b/vernac/auto_ind_decl.ml index 1a6b4dcdb..ee578669c 100644 --- a/vernac/auto_ind_decl.ml +++ b/vernac/auto_ind_decl.ml @@ -24,7 +24,8 @@ open Globnames open Inductiveops open Tactics open Ind_tables -open Misctypes +open Namegen +open Tactypes open Proofview.Notations module RelDecl = Context.Rel.Declaration @@ -54,20 +55,20 @@ exception EqUnknown of string exception UndefinedCst of string exception InductiveWithProduct exception InductiveWithSort -exception ParameterWithoutEquality of global_reference +exception ParameterWithoutEquality of GlobRef.t exception NonSingletonProp of inductive exception DecidabilityMutualNotSupported exception NoDecidabilityCoInductive -let constr_of_global g = lazy (Universes.constr_of_global g) +let constr_of_global g = lazy (UnivGen.constr_of_global g) (* Some pre declaration of constant we are going to use *) let bb = constr_of_global Coqlib.glob_bool -let andb_prop = fun _ -> Universes.constr_of_global (Coqlib.build_bool_type()).Coqlib.andb_prop +let andb_prop = fun _ -> UnivGen.constr_of_global (Coqlib.build_bool_type()).Coqlib.andb_prop let andb_true_intro = fun _ -> - Universes.constr_of_global + UnivGen.constr_of_global (Coqlib.build_bool_type()).Coqlib.andb_true_intro let tt = constr_of_global Coqlib.glob_true @@ -76,9 +77,9 @@ let ff = constr_of_global Coqlib.glob_false let eq = constr_of_global Coqlib.glob_eq -let sumbool () = Universes.constr_of_global (Coqlib.build_coq_sumbool ()) +let sumbool () = UnivGen.constr_of_global (Coqlib.build_coq_sumbool ()) -let andb = fun _ -> Universes.constr_of_global (Coqlib.build_bool_type()).Coqlib.andb +let andb = fun _ -> UnivGen.constr_of_global (Coqlib.build_bool_type()).Coqlib.andb let induct_on c = induction false None c None None @@ -186,10 +187,10 @@ let build_beq_scheme mode kn = *) let compute_A_equality rel_list nlist eqA ndx t = let lifti = ndx in - let sigma = Evd.empty (** FIXME *) in let rec aux c = - let (c,a) = Reductionops.whd_betaiota_stack Evd.empty c in - match EConstr.kind sigma c with + let (c,a) = Reductionops.whd_betaiota_stack Evd.empty EConstr.(of_constr c) in + let (c,a) = EConstr.Unsafe.(to_constr c, List.map to_constr a) in + match Constr.kind c with | Rel x -> mkRel (x-nlist+ndx), Safe_typing.empty_private_constants | Var x -> let eid = Id.of_string ("eq_"^(Id.to_string x)) in @@ -198,7 +199,7 @@ let build_beq_scheme mode kn = with Not_found -> raise (ParameterWithoutEquality (VarRef x)) in mkVar eid, Safe_typing.empty_private_constants - | Cast (x,_,_) -> aux (EConstr.applist (x,a)) + | Cast (x,_,_) -> aux (Term.applist (x,a)) | App _ -> assert false | Ind ((kn',i as ind'),u) (*FIXME: universes *) -> if MutInd.equal kn kn' then mkRel(eqA-nlist-i+nb_ind-1), Safe_typing.empty_private_constants @@ -213,8 +214,8 @@ let build_beq_scheme mode kn = List.fold_left Safe_typing.concat_private eff (List.rev effs) in let args = - Array.append - (Array.of_list (List.map (fun x -> lift lifti (EConstr.Unsafe.to_constr x)) a)) eqa in + Array.append + (Array.of_list (List.map (fun x -> lift lifti x) a)) eqa in if Int.equal (Array.length args) 0 then eq, eff else mkApp (eq, args), eff with Not_found -> raise(EqNotFound (ind', fst ind)) @@ -224,10 +225,9 @@ let build_beq_scheme mode kn = | Lambda _-> raise (EqUnknown "abstraction") | LetIn _ -> raise (EqUnknown "let-in") | Const (kn, u) -> - let u = EConstr.EInstance.kind sigma u in (match Environ.constant_opt_value_in env (kn, u) with | None -> raise (ParameterWithoutEquality (ConstRef kn)) - | Some c -> aux (EConstr.applist (EConstr.of_constr c,a))) + | Some c -> aux (Term.applist (c,a))) | Proj _ -> raise (EqUnknown "projection") | Construct _ -> raise (EqUnknown "constructor") | Case _ -> raise (EqUnknown "match") @@ -271,7 +271,7 @@ let build_beq_scheme mode kn = nparrec (nparrec+3+2*nb_cstr_args) (nb_cstr_args+ndx+1) - (EConstr.of_constr cc) + cc in eff := Safe_typing.concat_private eff' !eff; Array.set eqs ndx @@ -319,9 +319,17 @@ let build_beq_scheme mode kn = let kelim = Inductive.elim_sorts (mib,mib.mind_packets.(i)) in if not (Sorts.List.mem InSet kelim) then raise (NonSingletonProp (kn,i)); - if mib.mind_finite = CoFinite then + let fix = match mib.mind_finite with + | CoFinite -> raise NoDecidabilityCoInductive; - let fix = mkFix (((Array.make nb_ind 0),i),(names,types,cores)) in + | Finite -> + mkFix (((Array.make nb_ind 0),i),(names,types,cores)) + | BiFinite -> + (** If the inductive type is not recursive, the fixpoint is not + used, so let's replace it with garbage *) + let subst = List.init nb_ind (fun _ -> mkProp) in + Vars.substl subst cores.(i) + in create_input fix), UState.make (Global.universes ())), !eff @@ -400,9 +408,9 @@ let do_replace_lb mode lb_scheme_key aavoid narg p q = lb_type_of_p >>= fun (lb_type_of_p,eff) -> Proofview.tclEVARMAP >>= fun sigma -> let lb_args = Array.append (Array.append - (Array.map (fun x -> x) v) - (Array.map (fun x -> do_arg sigma x 1) v)) - (Array.map (fun x -> do_arg sigma x 2) v) + v + (Array.Smart.map (fun x -> do_arg sigma x 1) v)) + (Array.Smart.map (fun x -> do_arg sigma x 2) v) in let app = if Array.is_empty lb_args then lb_type_of_p else mkApp (lb_type_of_p,lb_args) in @@ -471,9 +479,9 @@ let do_replace_bl mode bl_scheme_key (ind,u as indu) aavoid narg lft rgt = user_err err_msg in let bl_args = Array.append (Array.append - (Array.map (fun x -> x) v) - (Array.map (fun x -> do_arg sigma x 1) v)) - (Array.map (fun x -> do_arg sigma x 2) v ) + v + (Array.Smart.map (fun x -> do_arg sigma x 1) v)) + (Array.Smart.map (fun x -> do_arg sigma x 2) v ) in let app = if Array.is_empty bl_args then bl_t1 else mkApp (bl_t1,bl_args) @@ -635,7 +643,7 @@ repeat ( apply andb_prop in z;let z1:= fresh "Z" in destruct z as [z1 z]). | App (c,ca) -> ( match EConstr.kind sigma c with | Ind (indeq, u) -> - if eq_gr (IndRef indeq) Coqlib.glob_eq + if GlobRef.equal (IndRef indeq) Coqlib.glob_eq then Tacticals.New.tclTHEN (do_replace_bl mode bl_scheme_key ind @@ -863,7 +871,7 @@ let compute_dec_goal ind lnamesparrec nparrec = create_input ( mkNamedProd n (mkFullInd ind (2*nparrec)) ( mkNamedProd m (mkFullInd ind (2*nparrec+1)) ( - mkApp(sumbool(),[|eqnm;mkApp (Universes.constr_of_global @@ Coqlib.build_coq_not(),[|eqnm|])|]) + mkApp(sumbool(),[|eqnm;mkApp (UnivGen.constr_of_global @@ Coqlib.build_coq_not(),[|eqnm|])|]) ) ) ) @@ -923,7 +931,7 @@ let compute_dec_tact ind lnamesparrec nparrec = (* left *) Tacticals.New.tclTHENLIST [ simplest_left; - apply (EConstr.of_constr (mkApp(blI,Array.map(fun x->mkVar x) xargs))); + apply (EConstr.of_constr (mkApp(blI,Array.map mkVar xargs))); Auto.default_auto ] ; @@ -939,7 +947,7 @@ let compute_dec_tact ind lnamesparrec nparrec = assert_by (Name freshH3) (EConstr.of_constr (mkApp(eq,[|bb;mkApp(eqI,[|mkVar freshm;mkVar freshm|]);tt|]))) (Tacticals.New.tclTHENLIST [ - apply (EConstr.of_constr (mkApp(lbI,Array.map (fun x->mkVar x) xargs))); + apply (EConstr.of_constr (mkApp(lbI,Array.map mkVar xargs))); Auto.default_auto ]); Equality.general_rewrite_bindings_in true diff --git a/vernac/auto_ind_decl.mli b/vernac/auto_ind_decl.mli index 5cc783df7..11f26c7c3 100644 --- a/vernac/auto_ind_decl.mli +++ b/vernac/auto_ind_decl.mli @@ -23,7 +23,7 @@ exception EqUnknown of string exception UndefinedCst of string exception InductiveWithProduct exception InductiveWithSort -exception ParameterWithoutEquality of Globnames.global_reference +exception ParameterWithoutEquality of GlobRef.t exception NonSingletonProp of inductive exception DecidabilityMutualNotSupported exception NoDecidabilityCoInductive diff --git a/vernac/class.ml b/vernac/class.ml index 59d933108..133726702 100644 --- a/vernac/class.ml +++ b/vernac/class.ml @@ -37,7 +37,7 @@ type coercion_error_kind = | ForbiddenSourceClass of cl_typ | NoTarget | WrongTarget of cl_typ * cl_typ - | NotAClass of global_reference + | NotAClass of GlobRef.t exception CoercionError of coercion_error_kind @@ -67,7 +67,7 @@ let explain_coercion_error g = function let check_reference_arity ref = let env = Global.env () in let c, _ = Global.type_of_global_in_context env ref in - if not (Reductionops.is_arity env Evd.empty (EConstr.of_constr c)) (** FIXME *) then + if not (Reductionops.is_arity env (Evd.from_env env) (EConstr.of_constr c)) (** FIXME *) then raise (CoercionError (NotAClass ref)) let check_arity = function @@ -181,6 +181,7 @@ let build_id_coercion idf_opt source poly = let sigma, vs = match source with | CL_CONST sp -> Evd.fresh_global env sigma (ConstRef sp) | _ -> error_not_transparent source in + let vs = EConstr.Unsafe.to_constr vs in let c = match constant_opt_value_in env (destConst vs) with | Some c -> c | None -> error_not_transparent source in diff --git a/vernac/class.mli b/vernac/class.mli index 33d31fe1f..f7e837f3b 100644 --- a/vernac/class.mli +++ b/vernac/class.mli @@ -10,19 +10,18 @@ open Names open Classops -open Globnames (** Classes and coercions. *) (** [try_add_new_coercion_with_target ref s src tg] declares [ref] as a coercion from [src] to [tg] *) -val try_add_new_coercion_with_target : global_reference -> local:bool -> +val try_add_new_coercion_with_target : GlobRef.t -> local:bool -> Decl_kinds.polymorphic -> source:cl_typ -> target:cl_typ -> unit (** [try_add_new_coercion ref s] declares [ref], assumed to be of type [(x1:T1)...(xn:Tn)src->tg], as a coercion from [src] to [tg] *) -val try_add_new_coercion : global_reference -> local:bool -> +val try_add_new_coercion : GlobRef.t -> local:bool -> Decl_kinds.polymorphic -> unit (** [try_add_new_coercion_subclass cst s] expects that [cst] denotes a @@ -34,7 +33,7 @@ val try_add_new_coercion_subclass : cl_typ -> local:bool -> (** [try_add_new_coercion_with_source ref s src] declares [ref] as a coercion from [src] to [tg] where the target is inferred from the type of [ref] *) -val try_add_new_coercion_with_source : global_reference -> local:bool -> +val try_add_new_coercion_with_source : GlobRef.t -> local:bool -> Decl_kinds.polymorphic -> source:cl_typ -> unit (** [try_add_new_identity_coercion id s src tg] enriches the @@ -47,4 +46,4 @@ val add_coercion_hook : Decl_kinds.polymorphic -> unit Lemmas.declaration_hook val add_subclass_hook : Decl_kinds.polymorphic -> unit Lemmas.declaration_hook -val class_of_global : global_reference -> cl_typ +val class_of_global : GlobRef.t -> cl_typ diff --git a/vernac/classes.ml b/vernac/classes.ml index 76d427add..8cf3895fb 100644 --- a/vernac/classes.ml +++ b/vernac/classes.ml @@ -41,7 +41,7 @@ let _ = Goptions.declare_bool_option { let typeclasses_db = "typeclass_instances" let set_typeclass_transparency c local b = - Hints.add_hints local [typeclasses_db] + Hints.add_hints ~local [typeclasses_db] (Hints.HintsTransparencyEntry ([c], b)) let _ = @@ -50,24 +50,25 @@ let _ = let inst' = match inst with IsConstr c -> Hints.IsConstr (EConstr.of_constr c, Univ.ContextSet.empty) | IsGlobal gr -> Hints.IsGlobRef gr in - let info = - let open Vernacexpr in - { info with hint_pattern = - Option.map - (Constrintern.intern_constr_pattern (Global.env()) Evd.(from_env Global.(env()))) - info.hint_pattern } in Flags.silently (fun () -> - Hints.add_hints local [typeclasses_db] + Hints.add_hints ~local [typeclasses_db] (Hints.HintsResolveEntry [info, poly, false, Hints.PathHints path, inst'])) ()); Hook.set Typeclasses.set_typeclass_transparency_hook set_typeclass_transparency; Hook.set Typeclasses.classes_transparent_state_hook (fun () -> Hints.Hint_db.transparent_state (Hints.searchtable_map typeclasses_db)) +let intern_info {hint_priority;hint_pattern} = + let env = Global.env() in + let sigma = Evd.from_env env in + let hint_pattern = Option.map (Constrintern.intern_constr_pattern env sigma) hint_pattern in + {hint_priority;hint_pattern} + (** TODO: add subinstances *) let existing_instance glob g info = let c = global g in let info = Option.default Hints.empty_hint_info info in + let info = intern_info info in let instance, _ = Global.type_of_global_in_context (Global.env ()) c in let _, r = Term.decompose_prod_assum instance in match class_of_constr Evd.empty (EConstr.of_constr r) with @@ -76,8 +77,8 @@ let existing_instance glob g info = ~hdr:"declare_instance" (Pp.str "Constant does not build instances of a declared type class.") -let mismatched_params env n m = mismatched_ctx_inst env Parameters n m -let mismatched_props env n m = mismatched_ctx_inst env Properties n m +let mismatched_params env n m = Implicit_quantifiers.mismatched_ctx_inst_err env Parameters n m +let mismatched_props env n m = Implicit_quantifiers.mismatched_ctx_inst_err env Properties n m (* Declare everything in the parameters as implicit, and the class instance as well *) @@ -108,6 +109,7 @@ open Pp let instance_hook k info global imps ?hook cst = Impargs.maybe_declare_manual_implicits false cst ~enriching:false imps; + let info = intern_info info in Typeclasses.declare_instance (Some info) (not global) cst; (match hook with Some h -> h cst | None -> ()) @@ -135,7 +137,7 @@ let new_instance ?(abstract=false) ?(global=false) ?(refine= !refine_instance) ?(tac:unit Proofview.tactic option) ?hook pri = let env = Global.env() in let ({CAst.loc;v=instid}, pl) = instid in - let sigma, decl = Univdecls.interp_univ_decl_opt env pl in + let sigma, decl = Constrexpr_ops.interp_univ_decl_opt env pl in let tclass, ids = match bk with | Decl_kinds.Implicit -> @@ -143,7 +145,7 @@ let new_instance ?(abstract=false) ?(global=false) ?(refine= !refine_instance) (fun avoid (clname, _) -> match clname with | Some cl -> - let t = CAst.make @@ CHole (None, Misctypes.IntroAnonymous, None) in + let t = CAst.make @@ CHole (None, Namegen.IntroAnonymous, None) in t, avoid | None -> failwith ("new instance: under-applied typeclass")) cl @@ -196,8 +198,8 @@ let new_instance ?(abstract=false) ?(global=false) ?(refine= !refine_instance) in let (_, ty_constr) = instance_constructor (k,u) subst in let termtype = it_mkProd_or_LetIn ty_constr (ctx' @ ctx) in - let sigma,_ = Evarutil.nf_evars_and_universes sigma in - Pretyping.check_evars env Evd.empty sigma termtype; + let sigma = Evd.minimize_universes sigma in + Pretyping.check_evars env (Evd.from_env env) sigma termtype; let univs = Evd.check_univ_decl ~poly sigma decl in let termtype = to_constr sigma termtype in let cst = Declare.declare_constant ~internal:Declare.InternalTacticRequest id @@ -253,7 +255,7 @@ let new_instance ?(abstract=false) ?(global=false) ?(refine= !refine_instance) k.cl_projs; c :: props, rest' with Not_found -> - ((CAst.make @@ CHole (None(* Some Evar_kinds.GoalEvar *), Misctypes.IntroAnonymous, None)) :: props), rest + ((CAst.make @@ CHole (None(* Some Evar_kinds.GoalEvar *), Namegen.IntroAnonymous, None)) :: props), rest else props, rest) ([], props) k.cl_props in @@ -289,11 +291,11 @@ let new_instance ?(abstract=false) ?(global=false) ?(refine= !refine_instance) let sigma = Typeclasses.resolve_typeclasses ~filter:Typeclasses.all_evars ~fail:false env sigma in let sigma = Evarutil.nf_evar_map_undefined sigma in (* Beware of this step, it is required as to minimize universes. *) - let sigma, _nf = Evarutil.nf_evar_map_universes sigma in + let sigma = Evd.minimize_universes sigma in (* Check that the type is free of evars now. *) - Pretyping.check_evars env Evd.empty sigma termtype; + Pretyping.check_evars env (Evd.from_env env) sigma termtype; let termtype = to_constr sigma termtype in - let term = Option.map (to_constr sigma) term in + let term = Option.map (to_constr ~abort_on_undefined_evars:false sigma) term in if not (Evd.has_undefined sigma) && not (Option.is_empty term) then declare_instance_constant k pri global imps ?hook id decl poly sigma (Option.get term) termtype @@ -302,7 +304,8 @@ let new_instance ?(abstract=false) ?(global=false) ?(refine= !refine_instance) if program_mode then let hook vis gr _ = let cst = match gr with ConstRef kn -> kn | _ -> assert false in - Impargs.declare_manual_implicits false gr ~enriching:false [imps]; + Impargs.declare_manual_implicits false gr ~enriching:false [imps]; + let pri = intern_info pri in Typeclasses.declare_instance (Some pri) (not global) (ConstRef cst) in let obls, constr, typ = @@ -365,8 +368,8 @@ let context poly l = let sigma = Evd.from_env env in let sigma, (_, ((env', fullctx), impls)) = interp_context_evars env sigma l in (* Note, we must use the normalized evar from now on! *) - let sigma,_ = Evarutil.nf_evars_and_universes sigma in - let ce t = Pretyping.check_evars env Evd.empty sigma t in + let sigma = Evd.minimize_universes sigma in + let ce t = Pretyping.check_evars env (Evd.from_env env) sigma t in let () = List.iter (fun decl -> Context.Rel.Declaration.iter_constr ce decl) fullctx in let ctx = try named_of_rel_context fullctx @@ -424,13 +427,13 @@ let context poly l = let decl = (Discharge, poly, Definitional) in let nstatus = match b with | None -> - pi3 (ComAssumption.declare_assumption false decl (t, univs) Universes.empty_binders [] impl - Vernacexpr.NoInline (CAst.make id)) + pi3 (ComAssumption.declare_assumption false decl (t, univs) UnivNames.empty_binders [] impl + Declaremods.NoInline (CAst.make id)) | Some b -> let decl = (Discharge, poly, Definition) in let entry = Declare.definition_entry ~univs ~types:t b in let hook = Lemmas.mk_hook (fun _ gr -> gr) in - let _ = DeclareDef.declare_definition id decl entry Universes.empty_binders [] hook in + let _ = DeclareDef.declare_definition id decl entry UnivNames.empty_binders [] hook in Lib.sections_are_opened () || Lib.is_modtype_strict () in status && nstatus diff --git a/vernac/classes.mli b/vernac/classes.mli index 0342c840e..eea2a211d 100644 --- a/vernac/classes.mli +++ b/vernac/classes.mli @@ -22,17 +22,17 @@ val mismatched_props : env -> constr_expr list -> Context.Rel.t -> 'a (** Instance declaration *) -val existing_instance : bool -> reference -> Vernacexpr.hint_info_expr option -> unit +val existing_instance : bool -> reference -> Hints.hint_info_expr option -> unit (** globality, reference, optional priority and pattern information *) val declare_instance_constant : typeclass -> - Vernacexpr.hint_info_expr -> (** priority *) + Hints.hint_info_expr -> (** priority *) bool -> (** globality *) Impargs.manual_explicitation list -> (** implicits *) - ?hook:(Globnames.global_reference -> unit) -> + ?hook:(GlobRef.t -> unit) -> Id.t -> (** name *) - Univdecls.universe_decl -> + UState.universe_decl -> bool -> (* polymorphic *) Evd.evar_map -> (* Universes *) Constr.t -> (** body *) @@ -50,8 +50,8 @@ val new_instance : (bool * constr_expr) option -> ?generalize:bool -> ?tac:unit Proofview.tactic -> - ?hook:(Globnames.global_reference -> unit) -> - Vernacexpr.hint_info_expr -> + ?hook:(GlobRef.t -> unit) -> + Hints.hint_info_expr -> Id.t (** Setting opacity *) diff --git a/vernac/comAssumption.ml b/vernac/comAssumption.ml index 6a590758f..a8ac52846 100644 --- a/vernac/comAssumption.ml +++ b/vernac/comAssumption.ml @@ -20,7 +20,6 @@ open Constrintern open Impargs open Decl_kinds open Pretyping -open Vernacexpr open Entries (* 2| Variable/Hypothesis/Parameter/Axiom declarations *) @@ -66,7 +65,7 @@ match local with | Global | Local | Discharge -> let do_instance = should_axiom_into_instance local in let local = DeclareDef.get_locality ident ~kind:"axiom" local in - let inl = match nl with + let inl = let open Declaremods in match nl with | NoInline -> None | DefaultInline -> Some (Flags.get_inline_level()) | InlineAt i -> Some i @@ -137,7 +136,7 @@ let do_assumptions kind nl l = let open Context.Named.Declaration in let env = Global.env () in let udecl, l = process_assumptions_udecls kind l in - let sigma, udecl = Univdecls.interp_univ_decl_opt env udecl in + let sigma, udecl = interp_univ_decl_opt env udecl in let l = if pi2 kind (* poly *) then (* Separate declarations so that A B : Type puts A and B in different levels. *) @@ -158,7 +157,7 @@ let do_assumptions kind nl l = ((sigma,env,ienv),((is_coe,idl),t,imps))) (sigma,env,empty_internalization_env) l in - let sigma = solve_remaining_evars all_and_fail_flags env sigma Evd.empty in + let sigma = solve_remaining_evars all_and_fail_flags env sigma (Evd.from_env env) in (* The universe constraints come from the whole telescope. *) let sigma = Evd.minimize_universes sigma in let nf_evar c = EConstr.to_constr sigma c in @@ -175,7 +174,7 @@ let do_assumptions kind nl l = let t = replace_vars subst t in let refs, status' = declare_assumptions idl is_coe kind (t,uctx) ubinders imps nl in let subst' = List.map2 - (fun {CAst.v=id} (c,u) -> (id, Universes.constr_of_global_univ (c,u))) + (fun {CAst.v=id} (c,u) -> (id, UnivGen.constr_of_global_univ (c,u))) idl refs in subst'@subst, status' && status, next_uctx uctx) diff --git a/vernac/comAssumption.mli b/vernac/comAssumption.mli index 56e324376..56932360a 100644 --- a/vernac/comAssumption.mli +++ b/vernac/comAssumption.mli @@ -11,7 +11,6 @@ open Names open Constr open Entries -open Globnames open Vernacexpr open Constrexpr open Decl_kinds @@ -19,7 +18,7 @@ open Decl_kinds (** {6 Parameters/Assumptions} *) val do_assumptions : locality * polymorphic * assumption_object_kind -> - Vernacexpr.inline -> (ident_decl list * constr_expr) with_coercion list -> bool + Declaremods.inline -> (ident_decl list * constr_expr) with_coercion list -> bool (************************************************************************) (** Internal API *) @@ -31,6 +30,6 @@ val do_assumptions : locality * polymorphic * assumption_object_kind -> nor in a module type and meant to be instantiated. *) val declare_assumption : coercion_flag -> assumption_kind -> types in_constant_universes_entry -> - Universes.universe_binders -> Impargs.manual_implicits -> - bool (** implicit *) -> Vernacexpr.inline -> variable CAst.t -> - global_reference * Univ.Instance.t * bool + UnivNames.universe_binders -> Impargs.manual_implicits -> + bool (** implicit *) -> Declaremods.inline -> variable CAst.t -> + GlobRef.t * Univ.Instance.t * bool diff --git a/vernac/comDefinition.ml b/vernac/comDefinition.ml index b18a60a1f..f55c852c0 100644 --- a/vernac/comDefinition.ml +++ b/vernac/comDefinition.ml @@ -65,7 +65,7 @@ let interp_definition pl bl poly red_option c ctypopt = let open EConstr in let env = Global.env() in (* Explicitly bound universes and constraints *) - let evd, decl = Univdecls.interp_univ_decl_opt env pl in + let evd, decl = Constrexpr_ops.interp_univ_decl_opt env pl in (* Build the parameters *) let evd, (impls, ((env_bl, ctx), imps1)) = interp_context_evars env evd bl in (* Build the type *) @@ -88,9 +88,9 @@ let interp_definition pl bl poly red_option c ctypopt = let evd = Evd.minimize_universes evd in (* Substitute evars and universes, and add parameters. Note: in program mode some evars may remain. *) - let ctx = List.map (EConstr.to_rel_decl evd) ctx in - let c = Term.it_mkLambda_or_LetIn (EConstr.to_constr evd c) ctx in - let tyopt = Option.map (fun ty -> Term.it_mkProd_or_LetIn (EConstr.to_constr evd ty) ctx) tyopt in + let ctx = List.map Termops.(map_rel_decl (to_constr ~abort_on_undefined_evars:false evd)) ctx in + let c = Term.it_mkLambda_or_LetIn (EConstr.to_constr ~abort_on_undefined_evars:false evd c) ctx in + let tyopt = Option.map (fun ty -> Term.it_mkProd_or_LetIn (EConstr.to_constr ~abort_on_undefined_evars:false evd ty) ctx) tyopt in (* Keep only useful universes. *) let uvars_fold uvars c = Univ.LSet.union uvars (universes_of_constr env evd (of_constr c)) @@ -104,7 +104,9 @@ let interp_definition pl bl poly red_option c ctypopt = (red_constant_entry (Context.Rel.length ctx) ce evd red_option, evd, decl, imps) let check_definition (ce, evd, _, imps) = - check_evars_are_solved (Global.env ()) evd Evd.empty; + let env = Global.env () in + let empty_sigma = Evd.from_env env in + check_evars_are_solved env evd empty_sigma; ce let do_definition ~program_mode ident k univdecl bl red_option c ctypopt hook = @@ -118,7 +120,7 @@ let do_definition ~program_mode ident k univdecl bl red_option c ctypopt hook = assert(Univ.ContextSet.is_empty ctx); let typ = match ce.const_entry_type with | Some t -> t - | None -> EConstr.to_constr evd (Retyping.get_type_of env evd (EConstr.of_constr c)) + | None -> EConstr.to_constr ~abort_on_undefined_evars:false evd (Retyping.get_type_of env evd (EConstr.of_constr c)) in Obligations.check_evars env evd; let obls, _, c, cty = diff --git a/vernac/comDefinition.mli b/vernac/comDefinition.mli index 6f81c4575..7f1c902c0 100644 --- a/vernac/comDefinition.mli +++ b/vernac/comDefinition.mli @@ -29,4 +29,4 @@ val do_definition : program_mode:bool -> val interp_definition : universe_decl_expr option -> local_binder_expr list -> polymorphic -> red_expr option -> constr_expr -> constr_expr option -> Safe_typing.private_constants definition_entry * Evd.evar_map * - Univdecls.universe_decl * Impargs.manual_implicits + UState.universe_decl * Impargs.manual_implicits diff --git a/vernac/comFixpoint.ml b/vernac/comFixpoint.ml index a794c2db0..1d1cc62de 100644 --- a/vernac/comFixpoint.ml +++ b/vernac/comFixpoint.ml @@ -13,7 +13,6 @@ open Decl_kinds open Pretyping open Evarutil open Evarconv -open Misctypes module RelDecl = Context.Rel.Declaration @@ -173,11 +172,12 @@ let interp_recursive ~program_mode ~cofix fixl notations = | None , acc -> acc | x , None -> x | Some ls , Some us -> - let lsu = ls.univdecl_instance and usu = us.univdecl_instance in + let open UState in + let lsu = ls.univdecl_instance and usu = us.univdecl_instance in if not (CList.for_all2eq (fun x y -> Id.equal x.CAst.v y.CAst.v) lsu usu) then user_err Pp.(str "(co)-recursive definitions should all have the same universe binders"); Some us) fixl None in - let sigma, decl = Univdecls.interp_univ_decl_opt env all_universes in + let sigma, decl = interp_univ_decl_opt env all_universes in let sigma, (fixctxs, fiximppairs, fixannots) = on_snd List.split3 @@ List.fold_left_map (fun sigma -> interp_fix_context env sigma ~cofix) sigma fixl in @@ -199,9 +199,7 @@ let interp_recursive ~program_mode ~cofix fixl notations = try let sigma, h_term = fix_proto sigma in let app = mkApp (h_term, [|sort; t|]) in - let _evd = ref sigma in - let res = Typing.e_solve_evars env _evd app in - !_evd, res + Typing.solve_evars env sigma app with e when CErrors.noncritical e -> sigma, t in sigma, LocalAssum (id,fixprot) :: env' @@ -224,8 +222,9 @@ let interp_recursive ~program_mode ~cofix fixl notations = (* Instantiate evars and check all are resolved *) let sigma = solve_unif_constraints_with_heuristics env_rec sigma in - let sigma, _ = nf_evars_and_universes sigma in - let fixdefs = List.map (fun c -> Option.map EConstr.(to_constr sigma) c) fixdefs in + let sigma = Evd.minimize_universes sigma in + (* XXX: We still have evars here in Program *) + let fixdefs = List.map (fun c -> Option.map EConstr.(to_constr ~abort_on_undefined_evars:false sigma) c) fixdefs in let fixtypes = List.map EConstr.(to_constr sigma) fixtypes in let fixctxs = List.map (fun (_,ctx) -> ctx) fixctxs in @@ -233,7 +232,7 @@ let interp_recursive ~program_mode ~cofix fixl notations = (env,rec_sign,decl,sigma), (fixnames,fixdefs,fixtypes), List.combine3 fixctxs fiximps fixannots let check_recursive isfix env evd (fixnames,fixdefs,_) = - check_evars_are_solved env evd Evd.empty; + check_evars_are_solved env evd (Evd.from_env env); 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) @@ -254,7 +253,7 @@ let declare_fixpoint local poly ((fixnames,fixdefs,fixtypes),pl,ctx,fiximps) ind Some (List.map (Option.cata (EConstr.of_constr %> Tactics.exact_no_check) Tacticals.New.tclIDTAC) fixdefs) in let evd = Evd.from_ctx ctx in - Lemmas.start_proof_with_initialization (Global,poly,DefinitionBody Fixpoint) + Lemmas.start_proof_with_initialization (local,poly,DefinitionBody Fixpoint) evd pl (Some(false,indexes,init_tac)) thms None (Lemmas.mk_hook (fun _ _ -> ())) else begin (* We shortcut the proof process *) diff --git a/vernac/comFixpoint.mli b/vernac/comFixpoint.mli index 36c2993af..f51bfbad5 100644 --- a/vernac/comFixpoint.mli +++ b/vernac/comFixpoint.mli @@ -33,7 +33,7 @@ val do_cofixpoint : type structured_fixpoint_expr = { fix_name : Id.t; fix_univs : Constrexpr.universe_decl_expr option; - fix_annot : Misctypes.lident option; + fix_annot : lident option; fix_binders : local_binder_expr list; fix_body : constr_expr option; fix_type : constr_expr @@ -49,7 +49,7 @@ val interp_recursive : structured_fixpoint_expr list -> decl_notation list -> (* env / signature / univs / evar_map *) - (Environ.env * EConstr.named_context * Univdecls.universe_decl * Evd.evar_map) * + (Environ.env * EConstr.named_context * UState.universe_decl * Evd.evar_map) * (* names / defs / types *) (Id.t list * Constr.constr option list * Constr.types list) * (* ctx per mutual def / implicits / struct annotations *) @@ -74,19 +74,19 @@ type recursive_preentry = val interp_fixpoint : cofix:bool -> structured_fixpoint_expr list -> decl_notation list -> - recursive_preentry * Univdecls.universe_decl * UState.t * + recursive_preentry * UState.universe_decl * UState.t * (EConstr.rel_context * Impargs.manual_implicits * int option) list (** Registering fixpoints and cofixpoints in the environment *) (** [Not used so far] *) val declare_fixpoint : locality -> polymorphic -> - recursive_preentry * Univdecls.universe_decl * UState.t * + recursive_preentry * UState.universe_decl * UState.t * (Context.Rel.t * Impargs.manual_implicits * int option) list -> Proof_global.lemma_possible_guards -> decl_notation list -> unit val declare_cofixpoint : locality -> polymorphic -> - recursive_preentry * Univdecls.universe_decl * UState.t * + recursive_preentry * UState.universe_decl * UState.t * (Context.Rel.t * Impargs.manual_implicits * int option) list -> decl_notation list -> unit diff --git a/vernac/comInductive.ml b/vernac/comInductive.ml index db2f16525..b93e8d9ac 100644 --- a/vernac/comInductive.ml +++ b/vernac/comInductive.ml @@ -27,9 +27,7 @@ open Impargs open Reductionops open Indtypes open Pretyping -open Evarutil open Indschemes -open Misctypes open Context.Rel.Declaration open Entries @@ -159,7 +157,7 @@ let sign_level env evd sign = | LocalDef _ -> lev, push_rel d env | LocalAssum _ -> let s = destSort (Reduction.whd_all env - (EConstr.Unsafe.to_constr (nf_evar evd (Retyping.get_type_of env evd (EConstr.of_constr (RelDecl.get_type d)))))) + (EConstr.to_constr evd (Retyping.get_type_of env evd (EConstr.of_constr (RelDecl.get_type d))))) in let u = univ_of_sort s in (Univ.sup u lev, push_rel d env)) @@ -178,6 +176,72 @@ let is_flexible_sort evd u = | Some l -> Evd.is_flexible_level evd l | None -> false +(**********************************************************************) +(* Tools for template polymorphic inductive types *) + +(* Miscellaneous functions to remove or test local univ assumed to + occur only in the le constraints *) + +(* + Solve a system of universe constraint of the form + + u_s11, ..., u_s1p1, w1 <= u1 + ... + u_sn1, ..., u_snpn, wn <= un + +where + + - the ui (1 <= i <= n) are universe variables, + - the sjk select subsets of the ui for each equations, + - the wi are arbitrary complex universes that do not mention the ui. +*) + +let is_direct_sort_constraint s v = match s with + | Some u -> Univ.univ_level_mem u v + | None -> false + +let solve_constraints_system levels level_bounds = + let open Univ in + let levels = + Array.mapi (fun i o -> + match o with + | Some u -> + (match Universe.level u with + | Some u -> Some u + | _ -> level_bounds.(i) <- Universe.sup level_bounds.(i) u; None) + | None -> None) + levels in + let v = Array.copy level_bounds in + let nind = Array.length v in + let clos = Array.map (fun _ -> Int.Set.empty) levels in + (* First compute the transitive closure of the levels dependencies *) + for i=0 to nind-1 do + for j=0 to nind-1 do + if not (Int.equal i j) && is_direct_sort_constraint levels.(j) v.(i) then + clos.(i) <- Int.Set.add j clos.(i); + done; + done; + let rec closure () = + let continue = ref false in + Array.iteri (fun i deps -> + let deps' = + Int.Set.fold (fun j acc -> Int.Set.union acc clos.(j)) deps deps + in + if Int.Set.equal deps deps' then () + else (clos.(i) <- deps'; continue := true)) + clos; + if !continue then closure () + else () + in + closure (); + for i=0 to nind-1 do + for j=0 to nind-1 do + if not (Int.equal i j) && Int.Set.mem j clos.(i) then + (v.(i) <- Universe.sup v.(i) level_bounds.(j)); + done; + done; + v + 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)) -> @@ -206,8 +270,8 @@ let inductive_levels env evd poly arities inds = in (* Take the transitive closure of the system of constructors *) (* level constraints and remove the recursive dependencies *) - let levels' = Universes.solve_constraints_system (Array.of_list levels) - (Array.of_list cstrs_levels) (Array.of_list min_levels) + let levels' = solve_constraints_system (Array.of_list levels) + (Array.of_list cstrs_levels) in let evd, arities = CList.fold_left3 (fun (evd, arities) cu (arity,(ctx,du)) len -> @@ -261,14 +325,14 @@ let check_param = function | CLocalAssum (nas, Default _, _) -> List.iter check_named nas | CLocalAssum (nas, Generalized _, _) -> () | CLocalPattern {CAst.loc} -> - Loc.raise ?loc (Stream.Error "pattern with quote not allowed here.") + Loc.raise ?loc (Stream.Error "pattern with quote not allowed here") let interp_mutual_inductive (paramsl,indl) notations cum poly prv finite = check_all_names_different indl; List.iter check_param paramsl; let env0 = Global.env() in let pl = (List.hd indl).ind_univs in - let sigma, decl = Univdecls.interp_univ_decl_opt env0 pl in + let sigma, decl = interp_univ_decl_opt env0 pl in let sigma, (impls, ((env_params, ctx_params), userimpls)) = interp_context_evars env0 sigma paramsl in @@ -302,22 +366,24 @@ let interp_mutual_inductive (paramsl,indl) notations cum poly prv finite = () in (* Try further to solve evars, and instantiate them *) - let sigma = solve_remaining_evars all_and_fail_flags env_params sigma Evd.empty in + let sigma = solve_remaining_evars all_and_fail_flags env_params sigma (Evd.from_env env_params) in (* Compute renewed arities *) - let sigma, nf = nf_evars_and_universes sigma in + let sigma = Evd.minimize_universes sigma in + let nf = Evarutil.nf_evars_universes sigma in let constructors = List.map (fun (idl,cl,impsl) -> (idl,List.map nf cl,impsl)) constructors in let arities = List.map EConstr.(to_constr sigma) arities in let sigma = List.fold_left2 (fun sigma ty poly -> make_conclusion_flexible sigma ty poly) sigma arities aritypoly in let sigma, arities = inductive_levels env_ar_params sigma poly arities constructors in - let sigma, nf' = nf_evars_and_universes sigma in - let arities = List.map nf' arities in - let constructors = List.map (fun (idl,cl,impsl) -> (idl,List.map nf' cl,impsl)) constructors in + let sigma = Evd.minimize_universes sigma in + let nf = Evarutil.nf_evars_universes sigma in + let arities = List.map nf arities in + let constructors = List.map (fun (idl,cl,impsl) -> (idl,List.map nf cl,impsl)) constructors in let ctx_params = List.map Termops.(map_rel_decl (EConstr.to_constr sigma)) ctx_params in let uctx = Evd.check_univ_decl ~poly sigma decl in - List.iter (fun c -> check_evars env_params Evd.empty sigma (EConstr.of_constr c)) arities; - Context.Rel.iter (fun c -> check_evars env0 Evd.empty sigma (EConstr.of_constr c)) ctx_params; + List.iter (fun c -> check_evars env_params (Evd.from_env env_params) sigma (EConstr.of_constr c)) arities; + Context.Rel.iter (fun c -> check_evars env0 (Evd.from_env env0) sigma (EConstr.of_constr c)) ctx_params; List.iter (fun (_,ctyps,_) -> - List.iter (fun c -> check_evars env_ar_params Evd.empty sigma (EConstr.of_constr c)) ctyps) + List.iter (fun c -> check_evars env_ar_params (Evd.from_env env_ar_params) sigma (EConstr.of_constr c)) ctyps) constructors; (* Build the inductive entries *) @@ -378,7 +444,7 @@ let extract_params indl = let extract_inductive indl = List.map (fun (({CAst.v=indname},pl),_,ar,lc) -> { ind_name = indname; ind_univs = pl; - ind_arity = Option.cata (fun x -> x) (CAst.make @@ CSort (GType [])) ar; + ind_arity = Option.cata (fun x -> x) (CAst.make @@ CSort (Glob_term.GType [])) ar; ind_lc = List.map (fun (_,({CAst.v=id},t)) -> (id,t)) lc }) indl diff --git a/vernac/comInductive.mli b/vernac/comInductive.mli index 833935724..7ae8e8f71 100644 --- a/vernac/comInductive.mli +++ b/vernac/comInductive.mli @@ -37,7 +37,7 @@ type one_inductive_impls = Impargs.manual_implicits list (** for constrs *) val declare_mutual_inductive_with_eliminations : - mutual_inductive_entry -> Universes.universe_binders -> one_inductive_impls list -> + mutual_inductive_entry -> UnivNames.universe_binders -> one_inductive_impls list -> MutInd.t (** Exported for Funind *) @@ -64,4 +64,4 @@ val extract_mutual_inductive_declaration_components : val interp_mutual_inductive : structured_inductive_expr -> decl_notation list -> cumulative_inductive_flag -> polymorphic -> private_flag -> Declarations.recursivity_kind -> - mutual_inductive_entry * Universes.universe_binders * one_inductive_impls list + mutual_inductive_entry * UnivNames.universe_binders * one_inductive_impls list diff --git a/vernac/comProgramFixpoint.ml b/vernac/comProgramFixpoint.ml index b95741ca4..a6d7fccf3 100644 --- a/vernac/comProgramFixpoint.ml +++ b/vernac/comProgramFixpoint.ml @@ -91,7 +91,7 @@ let build_wellfounded (recname,pl,n,bl,arityc,body) poly r measure notation = let lift_rel_context n l = Termops.map_rel_context_with_binders (liftn n) l in Coqlib.check_required_library ["Coq";"Program";"Wf"]; let env = Global.env() in - let sigma, decl = Univdecls.interp_univ_decl_opt env pl in + let sigma, decl = Constrexpr_ops.interp_univ_decl_opt env pl in let sigma, (_, ((env', binders_rel), impls)) = interp_context_evars env sigma bl in let len = List.length binders_rel in let top_env = push_rel_context binders_rel env in @@ -190,9 +190,7 @@ let build_wellfounded (recname,pl,n,bl,arityc,body) poly r measure notation = ~src:(Loc.tag @@ Evar_kinds.QuestionMark (Evar_kinds.Define false,Anonymous)) wf_proof in sigma, mkApp (h_a_term, [| argtyp ; wf_rel ; h_e_term; prop |]) in - let _evd = ref sigma in - let def = Typing.e_solve_evars env _evd def in - let sigma = !_evd in + let sigma, def = Typing.solve_evars env sigma def in let sigma = Evarutil.nf_evar_map sigma in let def = mkApp (def, [|intern_body_lam|]) in let binders_rel = nf_evar_context sigma binders_rel in @@ -214,7 +212,7 @@ let build_wellfounded (recname,pl,n,bl,arityc,body) poly r measure notation = (** FIXME: include locality *) let c = Declare.declare_constant recname (DefinitionEntry ce, IsDefinition Definition) in let gr = ConstRef c in - let () = Universes.register_universe_binders gr (Evd.universe_binders sigma) in + let () = UnivNames.register_universe_binders gr (Evd.universe_binders sigma) in if Impargs.is_implicit_args () || not (List.is_empty impls) then Impargs.declare_manual_implicits false gr [impls] in @@ -229,7 +227,8 @@ let build_wellfounded (recname,pl,n,bl,arityc,body) poly r measure notation = in (* XXX: Capturing sigma here... bad bad *) let hook = Lemmas.mk_hook (hook sigma) in - let fullcoqc = EConstr.to_constr sigma def in + (* XXX: Grounding non-ground terms here... bad bad *) + let fullcoqc = EConstr.to_constr ~abort_on_undefined_evars:false sigma def in let fullctyp = EConstr.to_constr sigma typ in Obligations.check_evars env sigma; let evars, _, evars_def, evars_typ = @@ -261,9 +260,10 @@ let do_program_recursive local poly fixkind fixl ntns = let collect_evars id def typ imps = (* Generalize by the recursive prototypes *) let def = - EConstr.to_constr evd (Termops.it_mkNamedLambda_or_LetIn (EConstr.of_constr def) rec_sign) + EConstr.to_constr ~abort_on_undefined_evars:false evd (Termops.it_mkNamedLambda_or_LetIn (EConstr.of_constr def) rec_sign) and typ = - EConstr.to_constr evd (Termops.it_mkNamedProd_or_LetIn (EConstr.of_constr typ) rec_sign) + (* Worrying... *) + EConstr.to_constr ~abort_on_undefined_evars:false evd (Termops.it_mkNamedProd_or_LetIn (EConstr.of_constr typ) rec_sign) in let evm = collect_evars_of_term evd def typ in let evars, _, def, typ = diff --git a/vernac/declareDef.mli b/vernac/declareDef.mli index 010874e23..c5e704a5e 100644 --- a/vernac/declareDef.mli +++ b/vernac/declareDef.mli @@ -8,17 +8,17 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) -open Decl_kinds open Names +open Decl_kinds val get_locality : Id.t -> kind:string -> Decl_kinds.locality -> bool val declare_definition : Id.t -> definition_kind -> - Safe_typing.private_constants Entries.definition_entry -> Universes.universe_binders -> Impargs.manual_implicits -> - Globnames.global_reference Lemmas.declaration_hook -> Globnames.global_reference + Safe_typing.private_constants Entries.definition_entry -> UnivNames.universe_binders -> Impargs.manual_implicits -> + GlobRef.t Lemmas.declaration_hook -> GlobRef.t val declare_fix : ?opaque:bool -> definition_kind -> - Universes.universe_binders -> Entries.constant_universes_entry -> + UnivNames.universe_binders -> Entries.constant_universes_entry -> Id.t -> Safe_typing.private_constants Entries.proof_output -> Constr.types -> Impargs.manual_implicits -> - Globnames.global_reference + GlobRef.t diff --git a/parsing/egramcoq.ml b/vernac/egramcoq.ml index 5f63d21c4..434e836d8 100644 --- a/parsing/egramcoq.ml +++ b/vernac/egramcoq.ml @@ -8,14 +8,14 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) -open CErrors open Util -open Pcoq +open CErrors +open Names +open Libnames open Constrexpr -open Notation_term open Extend -open Libnames -open Names +open Notation_gram +open Pcoq (**********************************************************************) (* This determines (depending on the associativity of the current @@ -228,7 +228,7 @@ type _ target = type prod_info = production_level * production_position type (_, _) entry = -| TTName : ('self, Misctypes.lname) entry +| TTName : ('self, lname) entry | TTReference : ('self, reference) entry | TTBigint : ('self, Constrexpr.raw_natural_number) entry | TTConstr : prod_info * 'r target -> ('r, 'r) entry diff --git a/parsing/egramcoq.mli b/vernac/egramcoq.mli index e15add10f..b0341e6a1 100644 --- a/parsing/egramcoq.mli +++ b/vernac/egramcoq.mli @@ -15,5 +15,5 @@ (** {5 Adding notations} *) -val extend_constr_grammar : Notation_term.one_notation_grammar -> unit +val extend_constr_grammar : Notation_gram.one_notation_grammar -> unit (** Add a term notation rule to the parsing system. *) diff --git a/parsing/egramml.ml b/vernac/egramml.ml index 90cd7d10b..048d4d93a 100644 --- a/parsing/egramml.ml +++ b/vernac/egramml.ml @@ -77,7 +77,7 @@ let get_extend_vernac_rule (s, i) = | Failure _ -> raise Not_found let extend_vernac_command_grammar s nt gl = - let nt = Option.default Vernac_.command nt in + let nt = Option.default Pvernac.Vernac_.command nt in vernac_exts := (s,gl) :: !vernac_exts; let mkact loc l = VernacExtend (s, l) in let rules = [make_rule mkact gl] in diff --git a/parsing/egramml.mli b/vernac/egramml.mli index 31aa1a989..31aa1a989 100644 --- a/parsing/egramml.mli +++ b/vernac/egramml.mli diff --git a/vernac/explainErr.ml b/vernac/explainErr.ml index f9167f969..504e7095b 100644 --- a/vernac/explainErr.ml +++ b/vernac/explainErr.ml @@ -55,7 +55,7 @@ let process_vernac_interp_error exn = match fst exn with let msg = if !Constrextern.print_universes then str "." ++ spc() ++ - Univ.explain_universe_inconsistency Universes.pr_with_global_universes i + Univ.explain_universe_inconsistency UnivNames.pr_with_global_universes i else mt() in wrap_vernac_error exn (str "Universe inconsistency" ++ msg ++ str ".") @@ -66,6 +66,8 @@ let process_vernac_interp_error exn = match fst exn with wrap_vernac_error exn (Himsg.explain_pretype_error ctx sigma te) | Typeclasses_errors.TypeClassError(env, te) -> wrap_vernac_error exn (Himsg.explain_typeclass_error env te) + | Implicit_quantifiers.MismatchedContextInstance(e,c,l,x) -> + wrap_vernac_error exn (Himsg.explain_mismatched_contexts e c l x) | InductiveError e -> wrap_vernac_error exn (Himsg.explain_inductive_error e) | Modops.ModuleTypingError e -> diff --git a/parsing/g_proofs.ml4 b/vernac/g_proofs.ml4 index e393c2bbf..4b11276af 100644 --- a/parsing/g_proofs.ml4 +++ b/vernac/g_proofs.ml4 @@ -8,14 +8,15 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) +open Glob_term open Constrexpr open Vernacexpr -open Misctypes +open Proof_global open Pcoq open Pcoq.Prim open Pcoq.Constr -open Pcoq.Vernac_ +open Pvernac.Vernac_ let thm_token = G_vernac.thm_token @@ -97,15 +98,8 @@ GEXTEND Gram VernacCreateHintDb (id, b) | IDENT "Remove"; IDENT "Hints"; ids = LIST1 global; dbnames = opt_hintbases -> VernacRemoveHints (dbnames, ids) - | IDENT "Hint"; h = hint; - dbnames = opt_hintbases -> + | IDENT "Hint"; h = hint; dbnames = opt_hintbases -> VernacHints (dbnames, h) - (* Declare "Resolve" explicitly so as to be able to later extend with - "Resolve ->" and "Resolve <-" *) - | IDENT "Hint"; IDENT "Resolve"; lc = LIST1 reference_or_constr; - info = hint_info; dbnames = opt_hintbases -> - VernacHints (dbnames, - HintsResolve (List.map (fun x -> (info, true, x)) lc)) ] ]; reference_or_constr: [ [ r = global -> HintsReference r @@ -114,6 +108,10 @@ GEXTEND Gram hint: [ [ IDENT "Resolve"; lc = LIST1 reference_or_constr; info = hint_info -> HintsResolve (List.map (fun x -> (info, true, x)) lc) + | IDENT "Resolve"; "->"; lc = LIST1 global; n = OPT natural -> + HintsResolveIFF (true, lc, n) + | IDENT "Resolve"; "<-"; lc = LIST1 global; n = OPT natural -> + HintsResolveIFF (false, lc, n) | IDENT "Immediate"; lc = LIST1 reference_or_constr -> HintsImmediate lc | IDENT "Transparent"; lc = LIST1 global -> HintsTransparency (lc, true) | IDENT "Opaque"; lc = LIST1 global -> HintsTransparency (lc, false) diff --git a/parsing/g_vernac.ml4 b/vernac/g_vernac.ml4 index 593dcbf58..3a59242de 100644 --- a/parsing/g_vernac.ml4 +++ b/vernac/g_vernac.ml4 @@ -12,20 +12,22 @@ open Pp open CErrors open Util open Names +open Glob_term open Vernacexpr open Constrexpr open Constrexpr_ops open Extend open Decl_kinds +open Declaremods open Declarations -open Misctypes +open Namegen open Tok (* necessary for camlp5 *) open Pcoq open Pcoq.Prim open Pcoq.Constr -open Pcoq.Vernac_ open Pcoq.Module +open Pvernac.Vernac_ let vernac_kw = [ ";"; ","; ">->"; ":<"; "<:"; "where"; "at" ] let _ = List.iter CLexer.add_keyword vernac_kw @@ -47,6 +49,7 @@ let instance_name = Gram.entry_create "vernac:instance_name" let section_subset_expr = Gram.entry_create "vernac:section_subset_expr" let make_bullet s = + let open Proof_bullet in let n = String.length s in match s.[0] with | '-' -> Dash n @@ -228,6 +231,7 @@ GEXTEND Gram ext = [ "+" -> true | -> false ]; "}" -> (l',ext) | ext = [ "}" -> true | "|}" -> false ] -> ([], ext) ] -> + let open UState in { univdecl_instance = l; univdecl_extensible_instance = ext; univdecl_constraints = fst cs; @@ -335,7 +339,7 @@ GEXTEND Gram ; type_cstr: [ [ ":"; c=lconstr -> c - | -> CAst.make ~loc:!@loc @@ CHole (None, Misctypes.IntroAnonymous, None) ] ] + | -> CAst.make ~loc:!@loc @@ CHole (None, IntroAnonymous, None) ] ] ; (* Inductive schemes *) scheme: @@ -391,7 +395,7 @@ GEXTEND Gram (None,DefExpr(id,mkCLambdaN ~loc:!@loc l b,None)) ] ] ; record_binder: - [ [ id = name -> (None,AssumExpr(id, CAst.make ~loc:!@loc @@ CHole (None, Misctypes.IntroAnonymous, None))) + [ [ id = name -> (None,AssumExpr(id, CAst.make ~loc:!@loc @@ CHole (None, IntroAnonymous, None))) | id = name; f = record_binder_body -> f id ] ] ; assum_list: @@ -410,7 +414,7 @@ GEXTEND Gram t= [ coe = of_type_with_opt_coercion; c = lconstr -> fun l id -> (not (Option.is_empty coe),(id,mkCProdN ~loc:!@loc l c)) | -> - fun l id -> (false,(id,mkCProdN ~loc:!@loc l (CAst.make ~loc:!@loc @@ CHole (None, Misctypes.IntroAnonymous, None)))) ] + fun l id -> (false,(id,mkCProdN ~loc:!@loc l (CAst.make ~loc:!@loc @@ CHole (None, IntroAnonymous, None)))) ] -> t l ]] ; @@ -628,8 +632,8 @@ GEXTEND Gram t = class_rawexpr -> VernacCoercion (CAst.make ~loc:!@loc @@ ByNotation ntn, s, t) - | IDENT "Context"; c = binders -> - VernacContext c + | IDENT "Context"; c = LIST1 binder -> + VernacContext (List.flatten c) | IDENT "Instance"; namesup = instance_name; ":"; expl = [ "!" -> Decl_kinds.Implicit | -> Decl_kinds.Explicit ] ; t = operconstr LEVEL "200"; @@ -644,7 +648,7 @@ GEXTEND Gram | IDENT "Existing"; IDENT "Instances"; ids = LIST1 global; pri = OPT [ "|"; i = natural -> i ] -> - let info = { hint_priority = pri; hint_pattern = None } in + let info = { Typeclasses.hint_priority = pri; hint_pattern = None } in let insts = List.map (fun i -> (i, info)) ids in VernacDeclareInstances insts @@ -769,8 +773,8 @@ GEXTEND Gram ; hint_info: [ [ "|"; i = OPT natural; pat = OPT constr_pattern -> - { hint_priority = i; hint_pattern = pat } - | -> { hint_priority = None; hint_pattern = None } ] ] + { Typeclasses.hint_priority = i; hint_pattern = pat } + | -> { Typeclasses.hint_priority = None; hint_pattern = None } ] ] ; reserv_list: [ [ bl = LIST1 reserv_tuple -> bl | b = simple_reserv -> [b] ] ] @@ -1145,8 +1149,8 @@ GEXTEND Gram [ [ "at"; n = level -> n ] ] ; constr_as_binder_kind: - [ [ "as"; IDENT "ident" -> AsIdent - | "as"; IDENT "pattern" -> AsIdentOrPattern - | "as"; IDENT "strict"; IDENT "pattern" -> AsStrictPattern ] ] + [ [ "as"; IDENT "ident" -> Notation_term.AsIdent + | "as"; IDENT "pattern" -> Notation_term.AsIdentOrPattern + | "as"; IDENT "strict"; IDENT "pattern" -> Notation_term.AsStrictPattern ] ] ; END diff --git a/vernac/himsg.ml b/vernac/himsg.ml index 698ee4703..5d671ef52 100644 --- a/vernac/himsg.ml +++ b/vernac/himsg.ml @@ -75,11 +75,7 @@ let rec contract3' env sigma a b c = function | MetaOccurInBody _ | InstanceNotSameType _ | ProblemBeyondCapabilities | UnifUnivInconsistency _ as x -> contract3 env sigma a b c, x | CannotSolveConstraint ((pb,env',t,u),x) -> - let t = EConstr.of_constr t in - let u = EConstr.of_constr u in let env',t,u = contract2 env' sigma t u in - let t = EConstr.Unsafe.to_constr t in - let u = EConstr.Unsafe.to_constr u in let y,x = contract3' env sigma a b c x in y,CannotSolveConstraint ((pb,env',t,u),x) @@ -90,7 +86,7 @@ let j_nf_betaiotaevar env sigma j = uj_type = Reductionops.nf_betaiota env sigma j.uj_type } let jv_nf_betaiotaevar env sigma jl = - Array.map (fun j -> j_nf_betaiotaevar env sigma j) jl + Array.Smart.map (fun j -> j_nf_betaiotaevar env sigma j) jl (** Printers *) @@ -201,7 +197,7 @@ let rec pr_disjunction pr = function let pr_puniverses f env (c,u) = f env c ++ (if Flags.is_universe_polymorphism () && not (Univ.Instance.is_empty u) then - str"(*" ++ Univ.Instance.pr Universes.pr_with_global_universes u ++ str"*)" + str"(*" ++ Univ.Instance.pr UnivNames.pr_with_global_universes u ++ str"*)" else mt()) let explain_elim_arity env sigma ind sorts c pj okinds = @@ -318,12 +314,10 @@ let explain_unification_error env sigma p1 p2 = function | UnifUnivInconsistency p -> if !Constrextern.print_universes then [str "universe inconsistency: " ++ - Univ.explain_universe_inconsistency Universes.pr_with_global_universes p] + Univ.explain_universe_inconsistency UnivNames.pr_with_global_universes p] else [str "universe inconsistency"] | CannotSolveConstraint ((pb,env,t,u),e) -> - let t = EConstr.of_constr t in - let u = EConstr.of_constr u in let env = make_all_name_different env sigma in (strbrk "cannot satisfy constraint " ++ pr_leconstr_env env sigma t ++ str " == " ++ pr_leconstr_env env sigma u) @@ -562,9 +556,9 @@ let rec explain_evar_kind env sigma evk ty = function | Evar_kinds.SubEvar (where,evk') -> let evi = Evd.find sigma evk' in let pc = match evi.evar_body with - | Evar_defined c -> pr_leconstr_env env sigma (EConstr.of_constr c) + | Evar_defined c -> pr_leconstr_env env sigma c | Evar_empty -> assert false in - let ty' = EConstr.of_constr evi.evar_concl in + let ty' = evi.evar_concl in (match where with | Some Evar_kinds.Body -> str "the body of " | Some Evar_kinds.Domain -> str "the domain of " @@ -577,11 +571,11 @@ let rec explain_evar_kind env sigma evk ty = function (pr_leconstr_env env sigma ty') (snd evi.evar_source) let explain_typeclass_resolution env sigma evi k = - match Typeclasses.class_of_constr sigma (EConstr.of_constr evi.evar_concl) with + match Typeclasses.class_of_constr sigma evi.evar_concl with | Some _ -> let env = Evd.evar_filtered_env evi in fnl () ++ str "Could not find an instance for " ++ - pr_lconstr_env env sigma evi.evar_concl ++ + pr_leconstr_env env sigma evi.evar_concl ++ pr_trailing_ne_context_of env sigma | _ -> mt() @@ -590,14 +584,14 @@ let explain_placeholder_kind env sigma c e = | Some (SeveralInstancesFound n) -> strbrk " (several distinct possible type class instances found)" | None -> - match Typeclasses.class_of_constr sigma (EConstr.of_constr c) with + match Typeclasses.class_of_constr sigma c with | Some _ -> strbrk " (no type class instance found)" | _ -> mt () let explain_unsolvable_implicit env sigma evk explain = let evi = Evarutil.nf_evar_info sigma (Evd.find_undefined sigma evk) in let env = Evd.evar_filtered_env evi in - let type_of_hole = pr_lconstr_env env sigma evi.evar_concl in + let type_of_hole = pr_leconstr_env env sigma evi.evar_concl in let pe = pr_trailing_ne_context_of env sigma in strbrk "Cannot infer " ++ explain_evar_kind env sigma evk type_of_hole (snd evi.evar_source) ++ @@ -640,8 +634,7 @@ let explain_refiner_cannot_generalize env sigma ty = pr_leconstr_env env sigma ty ++ str "." let explain_no_occurrence_found env sigma c id = - let c = EConstr.to_constr sigma c in - str "Found no subterm matching " ++ pr_lconstr_env env sigma c ++ + str "Found no subterm matching " ++ pr_leconstr_env env sigma c ++ str " in " ++ (match id with | Some id -> Id.print id @@ -766,7 +759,7 @@ let pr_constraints printenv env sigma evars cstrs = let evs = prlist (fun (ev, evi) -> fnl () ++ pr_existential_key sigma ev ++ - str " : " ++ pr_lconstr_env env' sigma evi.evar_concl ++ fnl ()) l + str " : " ++ pr_leconstr_env env' sigma evi.evar_concl ++ fnl ()) l in h 0 (pe ++ evs ++ pr_evar_constraints sigma cstrs) else @@ -855,9 +848,9 @@ let explain_not_match_error = function str "the body of definitions differs" | NotConvertibleTypeField (env, typ1, typ2) -> str "expected type" ++ spc () ++ - quote (Printer.safe_pr_lconstr_env env Evd.empty typ2) ++ spc () ++ + quote (Printer.safe_pr_lconstr_env env (Evd.from_env env) typ2) ++ spc () ++ str "but found type" ++ spc () ++ - quote (Printer.safe_pr_lconstr_env env Evd.empty typ1) + quote (Printer.safe_pr_lconstr_env env (Evd.from_env env) typ1) | NotSameConstructorNamesField -> str "constructor names differ" | NotSameInductiveNameInBlockField -> @@ -893,12 +886,12 @@ let explain_not_match_error = function str"polymorphic universe instances do not match" | IncompatibleUniverses incon -> str"the universe constraints are inconsistent: " ++ - Univ.explain_universe_inconsistency Universes.pr_with_global_universes incon + Univ.explain_universe_inconsistency UnivNames.pr_with_global_universes incon | IncompatiblePolymorphism (env, t1, t2) -> str "conversion of polymorphic values generates additional constraints: " ++ - quote (Printer.safe_pr_lconstr_env env Evd.empty t1) ++ spc () ++ + quote (Printer.safe_pr_lconstr_env env (Evd.from_env env) t1) ++ spc () ++ str "compared to " ++ spc () ++ - quote (Printer.safe_pr_lconstr_env env Evd.empty t2) + quote (Printer.safe_pr_lconstr_env env (Evd.from_env env) t2) | IncompatibleConstraints cst -> str " the expected (polymorphic) constraints do not imply " ++ let cst = Univ.AUContext.instantiate (Univ.AUContext.instance cst) cst in @@ -1018,8 +1011,9 @@ let explain_module_internalization_error = function (* Typeclass errors *) let explain_not_a_class env c = - let c = EConstr.to_constr Evd.empty c in - pr_constr_env env Evd.empty c ++ str" is not a declared type class." + let sigma = Evd.from_env env in + let c = EConstr.to_constr sigma c in + pr_constr_env env sigma c ++ str" is not a declared type class." let explain_unbound_method env cid { CAst.v = id } = str "Unbound method name " ++ Id.print (id) ++ spc () ++ @@ -1032,14 +1026,13 @@ let pr_constr_exprs exprs = let explain_mismatched_contexts env c i j = str"Mismatched contexts while declaring instance: " ++ brk (1,1) ++ - hov 1 (str"Expected:" ++ brk (1, 1) ++ pr_rel_context env Evd.empty j) ++ + hov 1 (str"Expected:" ++ brk (1, 1) ++ pr_rel_context env (Evd.from_env env) j) ++ fnl () ++ brk (1,1) ++ hov 1 (str"Found:" ++ brk (1, 1) ++ pr_constr_exprs i) let explain_typeclass_error env = function | NotAClass c -> explain_not_a_class env c | UnboundMethod (cid, id) -> explain_unbound_method env cid id - | MismatchedContextInstance (c,i,j) -> explain_mismatched_contexts env c i j (* Refiner errors *) @@ -1094,19 +1087,19 @@ let explain_refiner_error env sigma = function (* Inductive errors *) let error_non_strictly_positive env c v = - let pc = pr_lconstr_env env Evd.empty c in - let pv = pr_lconstr_env env Evd.empty v in + let pc = pr_lconstr_env env (Evd.from_env env) c in + let pv = pr_lconstr_env env (Evd.from_env env) v in str "Non strictly positive occurrence of " ++ pv ++ str " in" ++ brk(1,1) ++ pc ++ str "." let error_ill_formed_inductive env c v = - let pc = pr_lconstr_env env Evd.empty c in - let pv = pr_lconstr_env env Evd.empty v in + let pc = pr_lconstr_env env (Evd.from_env env) c in + let pv = pr_lconstr_env env (Evd.from_env env) v in str "Not enough arguments applied to the " ++ pv ++ str " in" ++ brk(1,1) ++ pc ++ str "." let error_ill_formed_constructor env id c v nparams nargs = - let pv = pr_lconstr_env env Evd.empty v in + let pv = pr_lconstr_env env (Evd.from_env env) v in let atomic = Int.equal (nb_prod Evd.empty (EConstr.of_constr c)) (** FIXME *) 0 in str "The type of constructor" ++ brk(1,1) ++ Id.print id ++ brk(1,1) ++ str "is not valid;" ++ brk(1,1) ++ @@ -1126,12 +1119,12 @@ let error_ill_formed_constructor env id c v nparams nargs = let pr_ltype_using_barendregt_convention_env env c = (* Use goal_concl_style as an approximation of Barendregt's convention (?) *) - quote (pr_goal_concl_style_env env Evd.empty (EConstr.of_constr c)) + quote (pr_goal_concl_style_env env (Evd.from_env env) (EConstr.of_constr c)) let error_bad_ind_parameters env c n v1 v2 = let pc = pr_ltype_using_barendregt_convention_env env c in - let pv1 = pr_lconstr_env env Evd.empty v1 in - let pv2 = pr_lconstr_env env Evd.empty v2 in + let pv1 = pr_lconstr_env env (Evd.from_env env) v1 in + let pv2 = pr_lconstr_env env (Evd.from_env env) v2 in str "Last occurrence of " ++ pv2 ++ str " must have " ++ pv1 ++ str " as " ++ pr_nth n ++ str " argument in" ++ brk(1,1) ++ pc ++ str "." @@ -1149,7 +1142,7 @@ let error_same_names_overlap idl = prlist_with_sep pr_comma Id.print idl ++ str "." let error_not_an_arity env c = - str "The type" ++ spc () ++ pr_lconstr_env env Evd.empty c ++ spc () ++ + str "The type" ++ spc () ++ pr_lconstr_env env (Evd.from_env env) c ++ spc () ++ str "is not an arity." let error_bad_entry () = @@ -1323,4 +1316,4 @@ let explain_reduction_tactic_error = function str "The abstracted term" ++ spc () ++ quote (pr_goal_concl_style_env env sigma c) ++ spc () ++ str "is not well typed." ++ fnl () ++ - explain_type_error env' Evd.empty e + explain_type_error env' (Evd.from_env env') e diff --git a/vernac/himsg.mli b/vernac/himsg.mli index 0e20d18c6..1d3807502 100644 --- a/vernac/himsg.mli +++ b/vernac/himsg.mli @@ -25,6 +25,8 @@ val explain_pretype_error : env -> Evd.evar_map -> pretype_error -> Pp.t val explain_inductive_error : inductive_error -> Pp.t +val explain_mismatched_contexts : env -> contexts -> Constrexpr.constr_expr list -> Context.Rel.t -> Pp.t + val explain_typeclass_error : env -> typeclass_error -> Pp.t val explain_recursion_scheme_error : recursion_scheme_error -> Pp.t diff --git a/vernac/indschemes.ml b/vernac/indschemes.ml index 32885ab88..2deca1e06 100644 --- a/vernac/indschemes.ml +++ b/vernac/indschemes.ml @@ -380,7 +380,7 @@ let do_mutual_induction_scheme lnamedepindsort = match inst with | None -> let _, ctx = Global.type_of_global_in_context env0 (IndRef ind) in - let u, ctx = Universes.fresh_instance_from ctx None in + let u, ctx = UnivGen.fresh_instance_from ctx None in let evd = Evd.from_ctx (UState.of_context_set ctx) in evd, (ind,u), Some u | Some ui -> evd, (ind, ui), inst diff --git a/vernac/indschemes.mli b/vernac/indschemes.mli index bd4249cac..261c3d813 100644 --- a/vernac/indschemes.mli +++ b/vernac/indschemes.mli @@ -32,17 +32,17 @@ val declare_rewriting_schemes : inductive -> unit (** Mutual Minimality/Induction scheme *) val do_mutual_induction_scheme : - (Misctypes.lident * bool * inductive * Sorts.family) list -> unit + (lident * bool * inductive * Sorts.family) list -> unit (** Main calls to interpret the Scheme command *) -val do_scheme : (Misctypes.lident option * scheme) list -> unit +val do_scheme : (lident option * scheme) list -> unit (** Combine a list of schemes into a conjunction of them *) val build_combined_scheme : env -> Constant.t list -> Evd.evar_map * constr * types -val do_combined_scheme : Misctypes.lident -> Misctypes.lident list -> unit +val do_combined_scheme : lident -> lident list -> unit (** Hook called at each inductive type definition *) diff --git a/vernac/lemmas.ml b/vernac/lemmas.ml index 30dd6ec74..ce74f2344 100644 --- a/vernac/lemmas.ml +++ b/vernac/lemmas.ml @@ -34,7 +34,7 @@ open Impargs module RelDecl = Context.Rel.Declaration module NamedDecl = Context.Named.Declaration -type 'a declaration_hook = Decl_kinds.locality -> Globnames.global_reference -> 'a +type 'a declaration_hook = Decl_kinds.locality -> GlobRef.t -> 'a let mk_hook hook = hook let call_hook fix_exn hook l c = try hook l c @@ -334,8 +334,8 @@ let universe_proof_terminator compute_guard hook = Feedback.feedback Feedback.AddedAxiom | Proved (opaque,idopt,proof) -> let is_opaque, export_seff = match opaque with - | Vernacexpr.Transparent -> false, true - | Vernacexpr.Opaque -> true, false + | Transparent -> false, true + | Opaque -> true, false in let proof = get_proof proof compute_guard (hook (Some (proof.Proof_global.universes))) is_opaque in @@ -436,7 +436,7 @@ let start_proof_with_initialization kind sigma decl recguard thms snl hook = let start_proof_com ?inference_hook kind thms hook = let env0 = Global.env () in let decl = fst (List.hd thms) in - let evd, decl = Univdecls.interp_univ_decl_opt env0 (snd decl) in + let evd, decl = Constrexpr_ops.interp_univ_decl_opt env0 (snd decl) in let evd, thms = List.fold_left_map (fun evd ((id, _), (bl, t)) -> let evd, (impls, ((env, ctx), imps)) = interp_context_evars env0 evd bl in let evd, (t', imps') = interp_type_evars_impls ~impls env evd t in @@ -451,12 +451,12 @@ let start_proof_com ?inference_hook kind thms hook = (ids, imps @ lift_implicits (Context.Rel.nhyps ctx) imps')))) evd thms in let recguard,thms,snl = look_for_possibly_mutual_statements evd thms in - let evd, _nf = Evarutil.nf_evars_and_universes evd in + let evd = Evd.minimize_universes evd in (* XXX: This nf_evar is critical too!! We are normalizing twice if you look at the previous lines... *) let thms = List.map (fun (n, (t, info)) -> (n, (nf_evar evd t, info))) thms in let () = - let open Misctypes in + let open UState in if not (decl.univdecl_extensible_instance && decl.univdecl_extensible_constraints) then ignore (Evd.check_univ_decl ~poly:(pi2 kind) evd decl) in diff --git a/vernac/lemmas.mli b/vernac/lemmas.mli index ad4c278e0..c9e4876ee 100644 --- a/vernac/lemmas.mli +++ b/vernac/lemmas.mli @@ -13,21 +13,21 @@ open Decl_kinds type 'a declaration_hook val mk_hook : - (Decl_kinds.locality -> Globnames.global_reference -> 'a) -> 'a declaration_hook + (Decl_kinds.locality -> GlobRef.t -> 'a) -> 'a declaration_hook val call_hook : - Future.fix_exn -> 'a declaration_hook -> Decl_kinds.locality -> Globnames.global_reference -> 'a + Future.fix_exn -> 'a declaration_hook -> Decl_kinds.locality -> GlobRef.t -> 'a (** A hook start_proof calls on the type of the definition being started *) val set_start_hook : (EConstr.types -> unit) -> unit -val start_proof : Id.t -> ?pl:Univdecls.universe_decl -> goal_kind -> Evd.evar_map -> +val start_proof : Id.t -> ?pl:UState.universe_decl -> goal_kind -> Evd.evar_map -> ?terminator:(Proof_global.lemma_possible_guards -> unit declaration_hook -> Proof_global.proof_terminator) -> ?sign:Environ.named_context_val -> EConstr.types -> ?init_tac:unit Proofview.tactic -> ?compute_guard:Proof_global.lemma_possible_guards -> unit declaration_hook -> unit -val start_proof_univs : Id.t -> ?pl:Univdecls.universe_decl -> goal_kind -> Evd.evar_map -> +val start_proof_univs : Id.t -> ?pl:UState.universe_decl -> goal_kind -> Evd.evar_map -> ?terminator:(Proof_global.lemma_possible_guards -> (UState.t option -> unit declaration_hook) -> Proof_global.proof_terminator) -> ?sign:Environ.named_context_val -> EConstr.types -> ?init_tac:unit Proofview.tactic -> ?compute_guard:Proof_global.lemma_possible_guards -> @@ -39,7 +39,7 @@ val start_proof_com : unit declaration_hook -> unit val start_proof_with_initialization : - goal_kind -> Evd.evar_map -> Univdecls.universe_decl -> + goal_kind -> Evd.evar_map -> UState.universe_decl -> (bool * Proof_global.lemma_possible_guards * unit Proofview.tactic list option) option -> (Id.t (* name of thm *) * (EConstr.types (* type of thm *) * (Name.t list (* names to pre-introduce *) * Impargs.manual_explicitation list))) list diff --git a/vernac/metasyntax.ml b/vernac/metasyntax.ml index feeca6075..8f64f5519 100644 --- a/vernac/metasyntax.ml +++ b/vernac/metasyntax.ml @@ -15,6 +15,7 @@ open Names open Constrexpr open Constrexpr_ops open Notation_term +open Notation_gram open Notation_ops open Ppextend open Extend @@ -76,22 +77,22 @@ let pr_grammar = function pr_entry Pcoq.Constr.pattern | "vernac" -> str "Entry vernac_control is" ++ fnl () ++ - pr_entry Pcoq.Vernac_.vernac_control ++ + pr_entry Pvernac.Vernac_.vernac_control ++ str "Entry command is" ++ fnl () ++ - pr_entry Pcoq.Vernac_.command ++ + pr_entry Pvernac.Vernac_.command ++ str "Entry syntax is" ++ fnl () ++ - pr_entry Pcoq.Vernac_.syntax ++ + pr_entry Pvernac.Vernac_.syntax ++ str "Entry gallina is" ++ fnl () ++ - pr_entry Pcoq.Vernac_.gallina ++ + pr_entry Pvernac.Vernac_.gallina ++ str "Entry gallina_ext is" ++ fnl () ++ - pr_entry Pcoq.Vernac_.gallina_ext + pr_entry Pvernac.Vernac_.gallina_ext | name -> pr_registered_grammar name (**********************************************************************) (* Parse a format (every terminal starting with a letter or a single quote (except a single quote alone) must be quoted) *) -let parse_format ({CAst.loc;v=str} : Misctypes.lstring) = +let parse_format ({CAst.loc;v=str} : lstring) = let len = String.length str in (* TODO: update the line of the location when the string contains newlines *) let make_loc i j = Option.map (Loc.shift_loc (i+1) (j-len)) loc in @@ -709,7 +710,7 @@ let error_parsing_incompatible_level ntn ntn' oldprec prec = pr_level ntn prec ++ str ".") type syntax_extension = { - synext_level : Notation_term.level; + synext_level : Notation_gram.level; synext_notation : notation; synext_notgram : notation_grammar; synext_unparsing : unparsing list; @@ -728,8 +729,8 @@ let check_and_extend_constr_grammar ntn rule = let ntn_for_grammar = rule.notgram_notation in if String.equal ntn ntn_for_grammar then raise Not_found; let prec = rule.notgram_level in - let oldprec = Notation.level_of_notation ntn_for_grammar in - if not (Notation.level_eq prec oldprec) then error_parsing_incompatible_level ntn ntn_for_grammar oldprec prec; + let oldprec = Notgram_ops.level_of_notation ntn_for_grammar in + if not (Notgram_ops.level_eq prec oldprec) then error_parsing_incompatible_level ntn ntn_for_grammar oldprec prec; with Not_found -> Egramcoq.extend_constr_grammar rule @@ -738,16 +739,16 @@ let cache_one_syntax_extension se = let prec = se.synext_level in let onlyprint = se.synext_notgram.notgram_onlyprinting in try - let oldprec = Notation.level_of_notation ntn in - if not (Notation.level_eq prec oldprec) then error_incompatible_level ntn oldprec prec; + let oldprec = Notgram_ops.level_of_notation ~onlyprint ntn in + if not (Notgram_ops.level_eq prec oldprec) then error_incompatible_level ntn oldprec prec; with Not_found -> if is_active_compat se.synext_compat then begin (* Reserve the notation level *) - Notation.declare_notation_level ntn prec; + Notgram_ops.declare_notation_level ntn prec ~onlyprint; (* Declare the parsing rule *) if not onlyprint then List.iter (check_and_extend_constr_grammar ntn) se.synext_notgram.notgram_rules; (* Declare the notation rule *) - Notation.declare_notation_rule ntn + declare_notation_rule ntn ~extra:se.synext_extra (se.synext_unparsing, pi1 prec) se.synext_notgram end @@ -791,7 +792,7 @@ type notation_modifier = { only_parsing : bool; only_printing : bool; compat : Flags.compat_version option; - format : Misctypes.lstring option; + format : lstring option; extra : (string * string) list; } @@ -1061,7 +1062,7 @@ let find_precedence lev etyps symbols onlyprint = [],Option.get lev let check_curly_brackets_notation_exists () = - try let _ = Notation.level_of_notation "{ _ }" in () + try let _ = Notgram_ops.level_of_notation "{ _ }" in () with Not_found -> user_err Pp.(str "Notations involving patterns of the form \"{ _ }\" are treated \n\ specially and require that the notation \"{ _ }\" is already reserved.") @@ -1103,7 +1104,7 @@ module SynData = struct only_parsing : bool; only_printing : bool; compat : Flags.compat_version option; - format : Misctypes.lstring option; + format : lstring option; extra : (string * string) list; (* XXX: Callback to printing, must remove *) @@ -1274,10 +1275,10 @@ exception NoSyntaxRule let recover_notation_syntax ntn = try - let prec = Notation.level_of_notation ntn in - let pp_rule,_ = Notation.find_notation_printing_rule ntn in - let pp_extra_rules = Notation.find_notation_extra_printing_rules ntn in - let pa_rule = Notation.find_notation_parsing_rules ntn in + let prec = Notgram_ops.level_of_notation ~onlyprint:true ntn (* Be as little restrictive as possible *) in + let pp_rule,_ = find_notation_printing_rule ntn in + let pp_extra_rules = find_notation_extra_printing_rules ntn in + let pa_rule = find_notation_parsing_rules ntn in { synext_level = prec; synext_notation = ntn; synext_notgram = pa_rule; @@ -1444,7 +1445,7 @@ let add_notation_extra_printing_rule df k v = let notk = let _,_, symbs = analyze_notation_tokens ~onlyprint:true df in make_notation_key symbs in - Notation.add_notation_extra_printing_rule notk k v + add_notation_extra_printing_rule notk k v (* Infix notations *) diff --git a/vernac/metasyntax.mli b/vernac/metasyntax.mli index a6c12e089..f6de75b07 100644 --- a/vernac/metasyntax.mli +++ b/vernac/metasyntax.mli @@ -14,7 +14,6 @@ open Notation open Constrexpr open Notation_term open Environ -open Misctypes val add_token_obj : string -> unit diff --git a/vernac/misctypes.ml b/vernac/misctypes.ml new file mode 100644 index 000000000..ae725efaa --- /dev/null +++ b/vernac/misctypes.ml @@ -0,0 +1,75 @@ +(* Compat module, to be removed in 8.10 *) +open Names + +type lident = Names.lident +[@@ocaml.deprecated "use [Names.lident"] +type lname = Names.lname +[@@ocaml.deprecated "use [Names.lname]"] +type lstring = Names.lstring +[@@ocaml.deprecated "use [Names.lstring]"] + +type 'a or_by_notation_r = 'a Constrexpr.or_by_notation_r = + | AN of 'a [@ocaml.deprecated "use version in [Constrexpr]"] + | ByNotation of (string * string option) [@ocaml.deprecated "use version in [Constrexpr]"] +[@@ocaml.deprecated "use [Constrexpr.or_by_notation_r]"] + +type 'a or_by_notation = 'a Constrexpr.or_by_notation +[@@ocaml.deprecated "use [Constrexpr.or_by_notation]"] + +type intro_pattern_naming_expr = Namegen.intro_pattern_naming_expr = + | IntroIdentifier of Id.t [@ocaml.deprecated "Use version in [Evarutil]"] + | IntroFresh of Id.t [@ocaml.deprecated "Use version in [Evarutil]"] + | IntroAnonymous [@ocaml.deprecated "Use version in [Evarutil]"] +[@@ocaml.deprecated "use [Evarutil.intro_pattern_naming_expr]"] + +type 'a or_var = 'a Locus.or_var = + | ArgArg of 'a [@ocaml.deprecated "Use version in [Locus]"] + | ArgVar of Names.lident [@ocaml.deprecated "Use version in [Locus]"] +[@@ocaml.deprecated "use [Locus.or_var]"] + +type quantified_hypothesis = Tactypes.quantified_hypothesis = + AnonHyp of int [@ocaml.deprecated "Use version in [Tactypes]"] + | NamedHyp of Id.t [@ocaml.deprecated "Use version in [Tactypes]"] +[@@ocaml.deprecated "use [Tactypes.quantified_hypothesis]"] + +type multi = Equality.multi = + | Precisely of int [@ocaml.deprecated "use version in [Equality]"] + | UpTo of int [@ocaml.deprecated "use version in [Equality]"] + | RepeatStar [@ocaml.deprecated "use version in [Equality]"] + | RepeatPlus [@ocaml.deprecated "use version in [Equality]"] +[@@ocaml.deprecated "use [Equality.multi]"] + +type 'a bindings = 'a Tactypes.bindings = + | ImplicitBindings of 'a list [@ocaml.deprecated "use version in [Tactypes]"] + | ExplicitBindings of 'a Tactypes.explicit_bindings [@ocaml.deprecated "use version in [Tactypes]"] + | NoBindings [@ocaml.deprecated "use version in [Tactypes]"] +[@@ocaml.deprecated "use [Tactypes.bindings]"] + +type 'constr intro_pattern_expr = 'constr Tactypes.intro_pattern_expr = + | IntroForthcoming of bool [@ocaml.deprecated "use version in [Tactypes]"] + | IntroNaming of Namegen.intro_pattern_naming_expr [@ocaml.deprecated "use version in [Tactypes]"] + | IntroAction of 'constr Tactypes.intro_pattern_action_expr [@ocaml.deprecated "use version in [Tactypes]"] +and 'constr intro_pattern_action_expr = 'constr Tactypes.intro_pattern_action_expr = + | IntroWildcard [@ocaml.deprecated "use [Tactypes]"] + | IntroOrAndPattern of 'constr Tactypes.or_and_intro_pattern_expr [@ocaml.deprecated "use [Tactypes]"] + | IntroInjection of ('constr intro_pattern_expr) CAst.t list [@ocaml.deprecated "use [Tactypes]"] + | IntroApplyOn of 'constr CAst.t * 'constr intro_pattern_expr CAst.t [@ocaml.deprecated "use [Tactypes]"] + | IntroRewrite of bool [@ocaml.deprecated "use [Tactypes]"] +and 'constr or_and_intro_pattern_expr = 'constr Tactypes.or_and_intro_pattern_expr = + | IntroOrPattern of ('constr intro_pattern_expr) CAst.t list list [@ocaml.deprecated "use [Tactypes]"] + | IntroAndPattern of ('constr intro_pattern_expr) CAst.t list [@ocaml.deprecated "use [Tactypes]"] +[@@ocaml.deprecated "use version in [Tactypes]"] + +type 'id move_location = 'id Logic.move_location = + | MoveAfter of 'id [@ocaml.deprecated "use version in [Logic]"] + | MoveBefore of 'id [@ocaml.deprecated "use version in [Logic]"] + | MoveFirst [@ocaml.deprecated "use version in [Logic]"] + | MoveLast [@ocaml.deprecated "use version in [Logic]"] +[@@ocaml.deprecated "use version in [Logic]"] + +type 'a cast_type = 'a Glob_term.cast_type = + | CastConv of 'a [@ocaml.deprecated "use version in [Glob_term]"] + | CastVM of 'a [@ocaml.deprecated "use version in [Glob_term]"] + | CastCoerce [@ocaml.deprecated "use version in [Glob_term]"] + | CastNative of 'a [@ocaml.deprecated "use version in [Glob_term]"] +[@@ocaml.deprecated "use version in [Glob_term]"] diff --git a/vernac/mltop.ml b/vernac/mltop.ml index 343b0925d..d25dea141 100644 --- a/vernac/mltop.ml +++ b/vernac/mltop.ml @@ -345,13 +345,6 @@ let load_ml_object mname ?path fname= let dir_ml_load m = ignore(dir_ml_load m) let add_known_module m = add_known_module m None -let load_ml_object_raw fname = dir_ml_load (file_of_name fname) -let load_ml_objects_raw_rex rex = - List.iter (fun (_,fp) -> - let name = file_of_name (Filename.basename fp) in - try dir_ml_load name - with e -> prerr_endline (Printexc.to_string e)) - (System.where_in_path_rex !coq_mlpath_copy rex) (* Summary of declared ML Modules *) @@ -396,8 +389,6 @@ let trigger_ml_object verb cache reinit ?path name = if cache then perform_cache_obj name end -let load_ml_object n m = ignore(load_ml_object n m) - let unfreeze_ml_modules x = reset_loaded_modules (); List.iter diff --git a/vernac/mltop.mli b/vernac/mltop.mli index da195f4fc..ed1f9a12d 100644 --- a/vernac/mltop.mli +++ b/vernac/mltop.mli @@ -68,9 +68,6 @@ val add_coq_path : coq_path -> unit (** List of modules linked to the toplevel *) val add_known_module : string -> unit val module_is_known : string -> bool -val load_ml_object : string -> string -> unit -val load_ml_object_raw : string -> unit -val load_ml_objects_raw_rex : Str.regexp -> unit (** {5 Initialization functions} *) diff --git a/vernac/obligations.ml b/vernac/obligations.ml index 064e40b9b..1ab24b670 100644 --- a/vernac/obligations.ml +++ b/vernac/obligations.ml @@ -209,8 +209,10 @@ let eterm_obligations env name evm fs ?status t ty = List.fold_right (fun (id, (n, nstr), ev) l -> let hyps = Evd.evar_filtered_context ev in - let hyps = trunc_named_context nc_len hyps in - let evtyp, deps, transp = etype_of_evar l hyps ev.evar_concl in + let hyps = trunc_named_context nc_len hyps in + let hyps = EConstr.Unsafe.to_named_context hyps in + let concl = EConstr.Unsafe.to_constr ev.evar_concl in + let evtyp, deps, transp = etype_of_evar l hyps concl in let evtyp, hyps, chop = match chop_product fs evtyp with | Some t -> t, trunc_named_context fs hyps, fs @@ -257,14 +259,16 @@ let eterm_obligations env name evm fs ?status t ty = let tactics_module = ["Program";"Tactics"] let safe_init_constant md name () = Coqlib.check_required_library ("Coq"::md); - Universes.constr_of_global (Coqlib.coq_reference "Obligations" md name) + UnivGen.constr_of_global (Coqlib.coq_reference "Obligations" md name) let hide_obligation = safe_init_constant tactics_module "obligation" let pperror cmd = CErrors.user_err ~hdr:"Program" cmd let error s = pperror (str s) let reduce c = - EConstr.Unsafe.to_constr (Reductionops.clos_norm_flags CClosure.betaiota (Global.env ()) Evd.empty (EConstr.of_constr c)) + let env = Global.env () in + let sigma = Evd.from_env env in + EConstr.Unsafe.to_constr (Reductionops.clos_norm_flags CClosure.betaiota env sigma (EConstr.of_constr c)) exception NoObligations of Id.t option @@ -294,17 +298,17 @@ type obligation = type obligations = (obligation array * int) type fixpoint_kind = - | IsFixpoint of (Misctypes.lident option * Constrexpr.recursion_order_expr) list + | IsFixpoint of (lident option * Constrexpr.recursion_order_expr) list | IsCoFixpoint -type notations = (Misctypes.lstring * Constrexpr.constr_expr * Notation_term.scope_name option) list +type notations = (lstring * Constrexpr.constr_expr * Notation_term.scope_name option) list type program_info_aux = { prg_name: Id.t; prg_body: constr; prg_type: constr; prg_ctx: UState.t; - prg_univdecl: Univdecls.universe_decl; + prg_univdecl: UState.universe_decl; prg_obligations: obligations; prg_deps : Id.t list; prg_fixkind : fixpoint_kind option ; @@ -356,7 +360,7 @@ let _ = optread = get_shrink_obligations; optwrite = set_shrink_obligations; } -let evar_of_obligation o = make_evar (Global.named_context_val ()) o.obl_type +let evar_of_obligation o = make_evar (Global.named_context_val ()) (EConstr.of_constr o.obl_type) let get_obligation_body expand obl = match obl.obl_body with @@ -470,7 +474,7 @@ let subst_body expand prg = let declare_definition prg = let body, typ = subst_body true prg in - let nf = Universes.nf_evars_and_universes_opt_subst (fun x -> None) + let nf = UnivSubst.nf_evars_and_universes_opt_subst (fun x -> None) (UState.subst prg.prg_ctx) in let opaque = prg.prg_opaque in let fix_exn = Hook.get get_fix_exn () in @@ -519,8 +523,10 @@ let declare_mutual_definition l = List.split3 (List.map (fun x -> let subs, typ = (subst_body true x) in - let term = snd (Reductionops.splay_lam_n (Global.env ()) Evd.empty len (EConstr.of_constr subs)) in - let typ = snd (Reductionops.splay_prod_n (Global.env ()) Evd.empty len (EConstr.of_constr typ)) in + let env = Global.env () in + let sigma = Evd.from_env env 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.Unsafe.to_constr term in let typ = EConstr.Unsafe.to_constr typ in x.prg_reduce term, x.prg_reduce typ, x.prg_implicits) l) @@ -553,15 +559,14 @@ let declare_mutual_definition l = (* Declare the recursive definitions *) let univs = UState.const_univ_entry ~poly first.prg_ctx in let fix_exn = Hook.get get_fix_exn () in - let kns = List.map4 (DeclareDef.declare_fix ~opaque (local, poly, kind) Universes.empty_binders univs) + let kns = List.map4 (DeclareDef.declare_fix ~opaque (local, poly, kind) UnivNames.empty_binders univs) fixnames fixdecls fixtypes fiximps in (* Declare notations *) List.iter (Metasyntax.add_notation_interpretation (Global.env())) first.prg_notations; Declare.recursive_message (fixkind != IsCoFixpoint) indexes fixnames; let gr = List.hd kns in - let kn = match gr with ConstRef kn -> kn | _ -> assert false in Lemmas.call_hook fix_exn first.prg_hook local gr first.prg_ctx; - List.iter progmap_remove l; kn + List.iter progmap_remove l; gr let decompose_lam_prod c ty = let open Context.Rel.Declaration in @@ -610,7 +615,7 @@ let shrink_body c ty = let unfold_entry cst = Hints.HintsUnfoldEntry [EvalConstRef cst] let add_hint local prg cst = - Hints.add_hints local [Id.to_string prg.prg_name] (unfold_entry cst) + Hints.add_hints ~local [Id.to_string prg.prg_name] (unfold_entry cst) let it_mkLambda_or_LetIn_or_clean t ctx = let open Context.Rel.Declaration in @@ -742,7 +747,7 @@ let all_programs () = type progress = | Remain of int | Dependent - | Defined of global_reference + | Defined of GlobRef.t let obligations_message rem = if rem > 0 then @@ -768,8 +773,8 @@ let update_obls prg obls rem = let progs = List.map (fun x -> get_info (ProgMap.find x !from_prg)) prg'.prg_deps in if List.for_all (fun x -> obligations_solved x) progs then let kn = declare_mutual_definition progs in - Defined (ConstRef kn) - else Dependent) + Defined kn + else Dependent) let is_defined obls x = not (Option.is_empty obls.(x).obl_body) @@ -813,10 +818,9 @@ let rec string_of_list sep f = function let solve_by_tac name evi t poly ctx = let id = name in - let concl = EConstr.of_constr evi.evar_concl in (* spiwack: the status is dropped. *) let (entry,_,ctx') = Pfedit.build_constant_by_tactic - id ~goal_kind:(goal_kind poly) ctx evi.evar_hyps concl (Tacticals.New.tclCOMPLETE t) in + id ~goal_kind:(goal_kind poly) ctx evi.evar_hyps evi.evar_concl (Tacticals.New.tclCOMPLETE t) in let env = Global.env () in let entry = Safe_typing.inline_private_constants_in_definition_entry env entry in let body, () = Future.force entry.const_entry_body in @@ -848,12 +852,12 @@ let obligation_terminator name num guard hook auto pf = let obl = obls.(num) in let status = match obl.obl_status, opq with - | (_, Evar_kinds.Expand), Vernacexpr.Opaque -> err_not_transp () - | (true, _), Vernacexpr.Opaque -> err_not_transp () - | (false, _), Vernacexpr.Opaque -> Evar_kinds.Define true - | (_, Evar_kinds.Define true), Vernacexpr.Transparent -> + | (_, Evar_kinds.Expand), Opaque -> err_not_transp () + | (true, _), Opaque -> err_not_transp () + | (false, _), Opaque -> Evar_kinds.Define true + | (_, Evar_kinds.Define true), Transparent -> Evar_kinds.Define false - | (_, status), Vernacexpr.Transparent -> status + | (_, status), Transparent -> status in let obl = { obl with obl_status = false, status } in let ctx = @@ -890,7 +894,7 @@ let obligation_terminator name num guard hook auto pf = let obligation_hook prg obl num auto ctx' _ gr = let obls, rem = prg.prg_obligations in - let cst = match gr with ConstRef cst -> cst | _ -> assert false in + let cst = match gr with GlobRef.ConstRef cst -> cst | _ -> assert false in let transparent = evaluable_constant cst (Global.env ()) in let () = match obl.obl_status with (true, Evar_kinds.Expand) @@ -957,7 +961,7 @@ and obligation (user_num, name, typ) tac = let num = pred user_num in let prg = get_prog_err name in let obls, rem = prg.prg_obligations in - if num < Array.length obls then + if num >= 0 && num < Array.length obls then let obl = obls.(num) in match obl.obl_body with None -> solve_obligation prg num tac @@ -1068,9 +1072,11 @@ let show_obligations_of_prg ?(msg=true) prg = if !showed > 0 then ( decr showed; let x = subst_deps_obl obls x in + let env = Global.env () in + let sigma = Evd.from_env env in Feedback.msg_info (str "Obligation" ++ spc() ++ int (succ i) ++ spc () ++ str "of" ++ spc() ++ Id.print n ++ str ":" ++ spc () ++ - hov 1 (Printer.pr_constr_env (Global.env ()) Evd.empty x.obl_type ++ + hov 1 (Printer.pr_constr_env env sigma x.obl_type ++ str "." ++ fnl ()))) | Some _ -> ()) obls @@ -1086,11 +1092,13 @@ let show_obligations ?(msg=true) n = let show_term n = let prg = get_prog_err n in let n = prg.prg_name in + let env = Global.env () in + let sigma = Evd.from_env env in (Id.print n ++ spc () ++ str":" ++ spc () ++ - Printer.pr_constr_env (Global.env ()) Evd.empty prg.prg_type ++ spc () ++ str ":=" ++ fnl () - ++ Printer.pr_constr_env (Global.env ()) Evd.empty prg.prg_body) + Printer.pr_constr_env env sigma prg.prg_type ++ spc () ++ str ":=" ++ fnl () + ++ Printer.pr_constr_env env sigma prg.prg_body) -let add_definition n ?term t ctx ?(univdecl=Univdecls.default_univ_decl) +let add_definition n ?term t ctx ?(univdecl=UState.default_univ_decl) ?(implicits=[]) ?(kind=Global,false,Definition) ?tactic ?(reduce=reduce) ?(hook=Lemmas.mk_hook (fun _ _ _ -> ())) ?(opaque = false) obls = let sign = Decls.initialize_named_context_for_proof () in @@ -1110,7 +1118,7 @@ let add_definition n ?term t ctx ?(univdecl=Univdecls.default_univ_decl) | Remain rem -> Flags.if_verbose (fun () -> show_obligations ~msg:false (Some n)) (); res | _ -> res) -let add_mutual_definitions l ctx ?(univdecl=Univdecls.default_univ_decl) ?tactic +let add_mutual_definitions l ctx ?(univdecl=UState.default_univ_decl) ?tactic ?(kind=Global,false,Definition) ?(reduce=reduce) ?(hook=Lemmas.mk_hook (fun _ _ _ -> ())) ?(opaque = false) notations fixkind = let sign = Decls.initialize_named_context_for_proof () in diff --git a/vernac/obligations.mli b/vernac/obligations.mli index cc2cacd86..a37c30aaf 100644 --- a/vernac/obligations.mli +++ b/vernac/obligations.mli @@ -12,7 +12,6 @@ open Environ open Constr open Evd open Names -open Globnames (* This is a hack to make it possible for Obligations to craft a Qed * behind the scenes. The fix_exn the Stm attaches to the Future proof @@ -49,13 +48,13 @@ type obligation_info = type progress = (* Resolution status of a program *) | Remain of int (* n obligations remaining *) | Dependent (* Dependent on other definitions *) - | Defined of global_reference (* Defined as id *) + | Defined of GlobRef.t (* Defined as id *) val default_tactic : unit Proofview.tactic ref val add_definition : Names.Id.t -> ?term:constr -> types -> UState.t -> - ?univdecl:Univdecls.universe_decl -> (* Universe binders and constraints *) + ?univdecl:UState.universe_decl -> (* Universe binders and constraints *) ?implicits:(Constrexpr.explicitation * (bool * bool * bool)) list -> ?kind:Decl_kinds.definition_kind -> ?tactic:unit Proofview.tactic -> @@ -63,17 +62,17 @@ val add_definition : Names.Id.t -> ?term:constr -> types -> ?hook:(UState.t -> unit) Lemmas.declaration_hook -> ?opaque:bool -> obligation_info -> progress type notations = - (Misctypes.lstring * Constrexpr.constr_expr * Notation_term.scope_name option) list + (lstring * Constrexpr.constr_expr * Notation_term.scope_name option) list type fixpoint_kind = - | IsFixpoint of (Misctypes.lident option * Constrexpr.recursion_order_expr) list + | IsFixpoint of (lident option * Constrexpr.recursion_order_expr) list | IsCoFixpoint val add_mutual_definitions : (Names.Id.t * constr * types * (Constrexpr.explicitation * (bool * bool * bool)) list * obligation_info) list -> UState.t -> - ?univdecl:Univdecls.universe_decl -> (* Universe binders and constraints *) + ?univdecl:UState.universe_decl -> (* Universe binders and constraints *) ?tactic:unit Proofview.tactic -> ?kind:Decl_kinds.definition_kind -> ?reduce:(constr -> constr) -> diff --git a/printing/ppvernac.ml b/vernac/ppvernac.ml index 7eb8396ac..d0c423650 100644 --- a/printing/ppvernac.ml +++ b/vernac/ppvernac.ml @@ -16,12 +16,13 @@ open Util open CAst open Extend -open Vernacexpr -open Pputils open Libnames +open Decl_kinds open Constrexpr open Constrexpr_ops -open Decl_kinds +open Vernacexpr +open Declaremods +open Pputils open Ppconstr @@ -54,7 +55,7 @@ open Decl_kinds (if extensible then str"+" else mt()) let pr_universe_decl l = - let open Misctypes in + let open UState in match l with | None -> mt () | Some l -> @@ -101,7 +102,7 @@ open Decl_kinds | NumLevel n -> keyword "at" ++ spc () ++ keyword "level" ++ spc () ++ int n | NextLevel -> keyword "at" ++ spc () ++ keyword "next" ++ spc () ++ keyword "level" - let pr_constr_as_binder_kind = function + let pr_constr_as_binder_kind = let open Notation_term in function | AsIdent -> keyword "as ident" | AsIdentOrPattern -> keyword "as pattern" | AsStrictPattern -> keyword "as strict pattern" @@ -144,14 +145,14 @@ open Decl_kinds | SearchString (s,sc) -> qs s ++ pr_opt (fun sc -> str "%" ++ str sc) sc let pr_search a gopt b pr_p = - pr_opt (fun g -> Proof_bullet.pr_goal_selector g ++ str ":"++ spc()) gopt + pr_opt (fun g -> Goal_select.pr_goal_selector g ++ str ":"++ spc()) gopt ++ match a with | SearchHead c -> keyword "SearchHead" ++ spc() ++ pr_p c ++ pr_in_out_modules b | SearchPattern c -> keyword "SearchPattern" ++ spc() ++ pr_p c ++ pr_in_out_modules b | SearchRewrite c -> keyword "SearchRewrite" ++ spc() ++ pr_p c ++ pr_in_out_modules b | SearchAbout sl -> - keyword "Search" ++ spc() ++ prlist_with_sep spc pr_search_about sl ++ pr_in_out_modules b + keyword "Search" ++ spc() ++ prlist_with_sep spc pr_search_about sl ++ pr_in_out_modules b let pr_locality local = if local then keyword "Local" else keyword "Global" @@ -187,7 +188,7 @@ open Decl_kinds | ModeNoHeadEvar -> str"!" | ModeOutput -> str"-" - let pr_hint_info pr_pat { hint_priority = pri; hint_pattern = pat } = + let pr_hint_info pr_pat { Typeclasses.hint_priority = pri; hint_pattern = pat } = pr_opt (fun x -> str"|" ++ int x) pri ++ pr_opt (fun y -> (if Option.is_empty pri then str"| " else mt()) ++ pr_pat y) pat @@ -199,6 +200,9 @@ open Decl_kinds keyword "Resolve " ++ prlist_with_sep sep (fun (info, _, c) -> pr_reference_or_constr pr_c c ++ pr_hint_info pr_pat info) l + | HintsResolveIFF (l2r, l, n) -> + keyword "Resolve " ++ str (if l2r then "->" else "<-") + ++ prlist_with_sep sep pr_reference l | HintsImmediate l -> keyword "Immediate" ++ spc() ++ prlist_with_sep sep (fun c -> pr_reference_or_constr pr_c c) l @@ -282,7 +286,7 @@ open Decl_kinds prlist_strict (pr_module_vardecls pr_c) l let pr_type_option pr_c = function - | { v = CHole (k, Misctypes.IntroAnonymous, _) } -> mt() + | { v = CHole (k, Namegen.IntroAnonymous, _) } -> mt() | _ as c -> brk(0,2) ++ str" :" ++ pr_c c let pr_decl_notation prc ({loc; v=ntn},c,scopt) = @@ -507,7 +511,7 @@ open Decl_kinds | PrintVisibility s -> keyword "Print Visibility" ++ pr_opt str s | PrintAbout (qid,l,gopt) -> - pr_opt (fun g -> Proof_bullet.pr_goal_selector g ++ str ":"++ spc()) gopt + pr_opt (fun g -> Goal_select.pr_goal_selector g ++ str ":"++ spc()) gopt ++ keyword "About" ++ spc() ++ pr_smart_global qid ++ pr_univ_name_list l | PrintImplicit qid -> keyword "Print Implicit" ++ spc() ++ pr_smart_global qid @@ -716,6 +720,7 @@ open Decl_kinds return (keyword "Admitted") | VernacEndProof (Proved (opac,o)) -> return ( + let open Proof_global in match o with | None -> (match opac with | Transparent -> keyword "Defined" @@ -1121,7 +1126,7 @@ open Decl_kinds | None -> hov 2 (keyword "Check" ++ spc() ++ pr_lconstr c) in let pr_i = match io with None -> mt () - | Some i -> Proof_bullet.pr_goal_selector i ++ str ": " in + | Some i -> Goal_select.pr_goal_selector i ++ str ": " in return (pr_i ++ pr_mayeval r c) | VernacGlobalCheck c -> return (hov 2 (keyword "Type" ++ pr_constrarg c)) @@ -1175,7 +1180,8 @@ open Decl_kinds | VernacProofMode s -> return (keyword "Proof Mode" ++ str s) | VernacBullet b -> - return (begin match b with + (* XXX: Redundant with Proof_bullet.print *) + return (let open Proof_bullet in begin match b with | Dash n -> str (String.make n '-') | Star n -> str (String.make n '*') | Plus n -> str (String.make n '+') @@ -1183,7 +1189,7 @@ open Decl_kinds | VernacSubproof None -> return (str "{") | VernacSubproof (Some i) -> - return (Proof_bullet.pr_goal_selector i ++ str ":" ++ spc () ++ str "{") + return (Goal_select.pr_goal_selector i ++ str ":" ++ spc () ++ str "{") | VernacEndSubproof -> return (str "}") diff --git a/printing/ppvernac.mli b/vernac/ppvernac.mli index 4aa24bf5d..4aa24bf5d 100644 --- a/printing/ppvernac.mli +++ b/vernac/ppvernac.mli diff --git a/vernac/pvernac.ml b/vernac/pvernac.ml new file mode 100644 index 000000000..bac882381 --- /dev/null +++ b/vernac/pvernac.ml @@ -0,0 +1,56 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +open Pcoq + +let uncurry f (x,y) = f x y + +let uvernac = create_universe "vernac" + +module Vernac_ = + struct + let gec_vernac s = Gram.entry_create ("vernac:" ^ s) + + (* The different kinds of vernacular commands *) + let gallina = gec_vernac "gallina" + let gallina_ext = gec_vernac "gallina_ext" + let command = gec_vernac "command" + let syntax = gec_vernac "syntax_command" + let vernac_control = gec_vernac "Vernac.vernac_control" + let rec_definition = gec_vernac "Vernac.rec_definition" + let red_expr = new_entry utactic "red_expr" + let hint_info = gec_vernac "hint_info" + (* Main vernac entry *) + let main_entry = Gram.entry_create "vernac" + let noedit_mode = gec_vernac "noedit_command" + + let () = + let act_vernac = Gram.action (fun v loc -> Some (to_coqloc loc, v)) in + let act_eoi = Gram.action (fun _ loc -> None) in + let rule = [ + ([ Symbols.stoken Tok.EOI ], act_eoi); + ([ Symbols.snterm (Gram.Entry.obj vernac_control) ], act_vernac ); + ] in + uncurry (Gram.extend main_entry) (None, [None, None, rule]) + + let command_entry_ref = ref noedit_mode + let command_entry = + Gram.Entry.of_parser "command_entry" + (fun strm -> Gram.parse_tokens_after_filter !command_entry_ref strm) + + end + +let main_entry = Vernac_.main_entry + +let set_command_entry e = Vernac_.command_entry_ref := e +let get_command_entry () = !Vernac_.command_entry_ref + +let () = + register_grammar Stdarg.wit_red_expr (Vernac_.red_expr); diff --git a/vernac/pvernac.mli b/vernac/pvernac.mli new file mode 100644 index 000000000..2993a1661 --- /dev/null +++ b/vernac/pvernac.mli @@ -0,0 +1,36 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +open Pcoq +open Genredexpr +open Vernacexpr + +val uvernac : gram_universe + +module Vernac_ : + sig + val gallina : vernac_expr Gram.entry + val gallina_ext : vernac_expr Gram.entry + val command : vernac_expr Gram.entry + val syntax : vernac_expr Gram.entry + val vernac_control : vernac_control Gram.entry + val rec_definition : (fixpoint_expr * decl_notation list) Gram.entry + val noedit_mode : vernac_expr Gram.entry + val command_entry : vernac_expr Gram.entry + val red_expr : raw_red_expr Gram.entry + val hint_info : Hints.hint_info_expr Gram.entry + end + +(** The main entry: reads an optional vernac command *) +val main_entry : (Loc.t * vernac_control) option Gram.entry + +(** Handling of the proof mode entry *) +val get_command_entry : unit -> vernac_expr Gram.entry +val set_command_entry : vernac_expr Gram.entry -> unit diff --git a/vernac/record.ml b/vernac/record.ml index 6e745b2af..940859723 100644 --- a/vernac/record.ml +++ b/vernac/record.ml @@ -96,13 +96,13 @@ let binder_of_decl = function | Vernacexpr.AssumExpr(n,t) -> (n,None,t) | Vernacexpr.DefExpr(n,c,t) -> (n,Some c, match t with Some c -> c - | None -> CAst.make ?loc:n.CAst.loc @@ CHole (None, Misctypes.IntroAnonymous, None)) + | None -> CAst.make ?loc:n.CAst.loc @@ CHole (None, Namegen.IntroAnonymous, None)) let binders_of_decls = List.map binder_of_decl let typecheck_params_and_fields finite def id poly pl t ps nots fs = let env0 = Global.env () in - let sigma, decl = Univdecls.interp_univ_decl_opt env0 pl in + let sigma, decl = Constrexpr_ops.interp_univ_decl_opt env0 pl in let _ = let error bk {CAst.loc; v=name} = match bk, name with @@ -114,7 +114,7 @@ let typecheck_params_and_fields finite def id poly pl t ps nots fs = (function CLocalDef (b, _, _) -> error default_binder_kind b | CLocalAssum (ls, bk, ce) -> List.iter (error bk) ls | CLocalPattern {CAst.loc} -> - Loc.raise ?loc (Stream.Error "pattern with quote not allowed in record parameters.")) ps + Loc.raise ?loc (Stream.Error "pattern with quote not allowed in record parameters")) ps in let sigma, (impls_env, ((env1,newps), imps)) = interp_context_evars env0 sigma ps in let sigma, typ, sort, template = match t with @@ -122,7 +122,7 @@ let typecheck_params_and_fields finite def id poly pl t ps nots fs = let env = EConstr.push_rel_context newps env0 in let poly = match t with - | { CAst.v = CSort (Misctypes.GType []) } -> true | _ -> false in + | { CAst.v = CSort (Glob_term.GType []) } -> true | _ -> false in let sigma, s = interp_type_evars env sigma ~impls:empty_internalization_env t in let sred = Reductionops.whd_allnolet env sigma s in (match EConstr.kind sigma sred with @@ -152,7 +152,7 @@ let typecheck_params_and_fields finite def id poly pl t ps nots fs = interp_fields_evars env_ar sigma impls_env nots (binders_of_decls fs) in let sigma = - Pretyping.solve_remaining_evars Pretyping.all_and_fail_flags env_ar sigma Evd.empty in + Pretyping.solve_remaining_evars Pretyping.all_and_fail_flags env_ar sigma (Evd.from_env env_ar) in let sigma, typ = let _, univ = compute_constructor_level sigma env_ar newfs in if not def && (Sorts.is_prop sort || @@ -168,11 +168,11 @@ let typecheck_params_and_fields finite def id poly pl t ps nots fs = EConstr.mkSort (Sorts.sort_of_univ univ) else sigma, typ in - let sigma, _ = Evarutil.nf_evars_and_universes sigma in + let sigma = Evd.minimize_universes sigma in let newfs = List.map (EConstr.to_rel_decl sigma) newfs in let newps = List.map (EConstr.to_rel_decl sigma) newps in let typ = EConstr.to_constr sigma typ in - let ce t = Pretyping.check_evars env0 Evd.empty sigma (EConstr.of_constr t) in + let ce t = Pretyping.check_evars env0 (Evd.from_env env0) sigma (EConstr.of_constr t) in let univs = Evd.check_univ_decl ~poly sigma decl in let ubinders = Evd.universe_binders sigma in List.iter (iter_constr ce) (List.rev newps); @@ -316,7 +316,7 @@ let declare_projections indsp ctx ?(kind=StructureComponent) binder_name coers u let gr = Nametab.locate (Libnames.qualid_of_ident fid) in let kn = destConstRef gr in Declare.definition_message fid; - Universes.register_universe_binders gr ubinders; + UnivNames.register_universe_binders gr ubinders; kn, mkProj (Projection.make kn false,mkRel 1) else let ccl = subst_projection fid subst ti in @@ -352,7 +352,7 @@ let declare_projections indsp ctx ?(kind=StructureComponent) binder_name coers u applist (mkConstU (kn,u),proj_args) in Declare.definition_message fid; - Universes.register_universe_binders (ConstRef kn) ubinders; + UnivNames.register_universe_binders (ConstRef kn) ubinders; kn, constr_fip with Type_errors.TypeError (ctx,te) -> raise (NotDefinable (BadTypedProj (fid,ctx,te))) @@ -465,9 +465,9 @@ let declare_class finite def cum ubinders univs id idbuild paramimpls params ari in let cref = ConstRef cst in Impargs.declare_manual_implicits false cref [paramimpls]; - Universes.register_universe_binders cref ubinders; + UnivNames.register_universe_binders cref ubinders; Impargs.declare_manual_implicits false (ConstRef proj_cst) [List.hd fieldimpls]; - Universes.register_universe_binders (ConstRef proj_cst) ubinders; + UnivNames.register_universe_binders (ConstRef proj_cst) ubinders; Classes.set_typeclass_transparency (EvalConstRef cst) false false; let sub = match List.hd coers with | Some b -> Some ((if b then Backward else Forward), List.hd priorities) diff --git a/vernac/record.mli b/vernac/record.mli index 992da2aa5..b2c039f0b 100644 --- a/vernac/record.mli +++ b/vernac/record.mli @@ -11,7 +11,6 @@ open Names open Vernacexpr open Constrexpr -open Globnames val primitive_flag : bool ref @@ -21,7 +20,7 @@ val declare_projections : ?kind:Decl_kinds.definition_object_kind -> Id.t -> bool list -> - Universes.universe_binders -> + UnivNames.universe_binders -> Impargs.manual_implicits list -> Context.Rel.t -> (Name.t * bool) list * Constant.t option list @@ -30,6 +29,6 @@ val definition_structure : inductive_kind * Decl_kinds.cumulative_inductive_flag * Decl_kinds.polymorphic * Declarations.recursivity_kind * ident_decl with_coercion * local_binder_expr list * (local_decl_expr with_instance with_priority with_notation) list * - Id.t * constr_expr option -> global_reference + Id.t * constr_expr option -> GlobRef.t -val declare_existing_class : global_reference -> unit +val declare_existing_class : GlobRef.t -> unit diff --git a/vernac/search.ml b/vernac/search.ml index a2a4fb40f..e8ccec11c 100644 --- a/vernac/search.ml +++ b/vernac/search.ml @@ -22,8 +22,8 @@ open Nametab module NamedDecl = Context.Named.Declaration -type filter_function = global_reference -> env -> constr -> bool -type display_function = global_reference -> env -> constr -> unit +type filter_function = GlobRef.t -> env -> constr -> bool +type display_function = GlobRef.t -> env -> constr -> unit (* This option restricts the output of [SearchPattern ...], [SearchAbout ...], etc. to the names of the symbols matching the @@ -61,7 +61,7 @@ let iter_named_context_name_type f = List.iter (fun decl -> f (NamedDecl.get_id decl) (NamedDecl.get_type decl)) (* General search over hypothesis of a goal *) -let iter_hypothesis glnum (fn : global_reference -> env -> constr -> unit) = +let iter_hypothesis glnum (fn : GlobRef.t -> env -> constr -> unit) = let env = Global.env () in let iter_hyp idh typ = fn (VarRef idh) env typ in let evmap,e = Pfedit.get_goal_context glnum in @@ -69,7 +69,7 @@ let iter_hypothesis glnum (fn : global_reference -> env -> constr -> unit) = iter_named_context_name_type iter_hyp pfctxt (* General search over declarations *) -let iter_declarations (fn : global_reference -> env -> constr -> unit) = +let iter_declarations (fn : GlobRef.t -> env -> constr -> unit) = let env = Global.env () in let iter_obj (sp, kn) lobj = match object_tag lobj with | "VARIABLE" -> @@ -117,8 +117,7 @@ module ConstrPriority = struct (* The priority is memoised here. Because of the very localised use of this module, it is not worth it making a convenient interface. *) - type t = - Globnames.global_reference * Environ.env * Constr.t * priority + type t = GlobRef.t * Environ.env * Constr.t * priority and priority = int module ConstrSet = CSet.Make(Constr) @@ -216,7 +215,7 @@ let name_of_reference ref = Id.to_string (basename_of_global ref) let search_about_filter query gr env typ = match query with | GlobSearchSubPattern pat -> - Constr_matching.is_matching_appsubterm ~closed:false env Evd.empty pat (EConstr.of_constr typ) + Constr_matching.is_matching_appsubterm ~closed:false env (Evd.from_env env) pat (EConstr.of_constr typ) | GlobSearchString s -> String.string_contains ~where:(name_of_reference gr) ~what:s @@ -227,7 +226,7 @@ let search_pattern gopt pat mods pr_search = let blacklist_filter = blacklist_filter_aux () in let filter ref env typ = module_filter mods ref env typ && - pattern_filter pat ref env Evd.empty (* FIXME *) (EConstr.of_constr typ) && + pattern_filter pat ref env (Evd.from_env env) (* FIXME *) (EConstr.of_constr typ) && blacklist_filter ref env typ in let iter ref env typ = @@ -251,8 +250,8 @@ let search_rewrite gopt pat mods pr_search = let blacklist_filter = blacklist_filter_aux () in let filter ref env typ = module_filter mods ref env typ && - (pattern_filter pat1 ref env Evd.empty (* FIXME *) (EConstr.of_constr typ) || - pattern_filter pat2 ref env Evd.empty (EConstr.of_constr typ)) && + (pattern_filter pat1 ref env (Evd.from_env env) (* FIXME *) (EConstr.of_constr typ) || + pattern_filter pat2 ref env (Evd.from_env env) (EConstr.of_constr typ)) && blacklist_filter ref env typ in let iter ref env typ = @@ -266,7 +265,7 @@ let search_by_head gopt pat mods pr_search = let blacklist_filter = blacklist_filter_aux () in let filter ref env typ = module_filter mods ref env typ && - head_filter pat ref env Evd.empty (* FIXME *) (EConstr.of_constr typ) && + head_filter pat ref env (Evd.from_env env) (* FIXME *) (EConstr.of_constr typ) && blacklist_filter ref env typ in let iter ref env typ = @@ -330,12 +329,12 @@ let interface_search = toggle (Str.string_match regexp id 0) flag in let match_type (pat, flag) = - toggle (Constr_matching.is_matching env Evd.empty pat (EConstr.of_constr constr)) flag + toggle (Constr_matching.is_matching env (Evd.from_env env) pat (EConstr.of_constr constr)) flag in let match_subtype (pat, flag) = toggle (Constr_matching.is_matching_appsubterm ~closed:false - env Evd.empty pat (EConstr.of_constr constr)) flag + env (Evd.from_env env) pat (EConstr.of_constr constr)) flag in let match_module (mdl, flag) = toggle (Libnames.is_dirpath_prefix_of mdl path) flag diff --git a/vernac/search.mli b/vernac/search.mli index a1fb7ed3e..0dc82c1c3 100644 --- a/vernac/search.mli +++ b/vernac/search.mli @@ -12,7 +12,6 @@ open Names open Constr open Environ open Pattern -open Globnames (** {6 Search facilities. } *) @@ -20,8 +19,8 @@ type glob_search_about_item = | GlobSearchSubPattern of constr_pattern | GlobSearchString of string -type filter_function = global_reference -> env -> constr -> bool -type display_function = global_reference -> env -> constr -> unit +type filter_function = GlobRef.t -> env -> constr -> bool +type display_function = GlobRef.t -> env -> constr -> unit (** {6 Generic filter functions} *) diff --git a/vernac/topfmt.ml b/vernac/topfmt.ml index 055f6676e..609dac69a 100644 --- a/vernac/topfmt.ml +++ b/vernac/topfmt.ml @@ -89,12 +89,14 @@ let set_margin v = Format.pp_set_margin Format.str_formatter v; Format.pp_set_margin !std_ft v; Format.pp_set_margin !deep_ft v; + Format.pp_set_margin !err_ft v; (* Heuristic, based on usage: the column on the right of max_indent column is 20% of width, capped to 30 characters *) let m = max (64 * v / 100) (v-30) in Format.pp_set_max_indent Format.str_formatter m; Format.pp_set_max_indent !std_ft m; - Format.pp_set_max_indent !deep_ft m + Format.pp_set_max_indent !deep_ft m; + Format.pp_set_max_indent !err_ft m (** Console display of feedback *) @@ -289,6 +291,14 @@ let init_terminal_output ~color = let emacs_logger = gen_logger Emacs.quote_info Emacs.quote_warning (* This is specific to the toplevel *) + +type execution_phase = + | ParsingCommandLine + | Initialization + | LoadingPrelude + | LoadingRcFile + | InteractiveLoop + let pr_loc loc = let fname = loc.Loc.fname in match fname with @@ -301,13 +311,28 @@ let pr_loc loc = int (loc.bp-loc.bol_pos) ++ str"-" ++ int (loc.ep-loc.bol_pos) ++ str":") -let print_err_exn ?extra any = +let pr_phase ?loc phase = + match phase, loc with + | LoadingRcFile, loc -> + (* For when all errors go through feedback: + str "While loading rcfile:" ++ + Option.cata (fun loc -> fnl () ++ pr_loc loc) (mt ()) loc *) + Option.map pr_loc loc + | LoadingPrelude, loc -> + Some (str "While loading initial state:" ++ Option.cata (fun loc -> fnl () ++ pr_loc loc) (mt ()) loc) + | _, Some loc -> Some (pr_loc loc) + | ParsingCommandLine, _ + | Initialization, _ -> None + | InteractiveLoop, _ -> + (* Note: interactive messages such as "foo is defined" are not located *) + None + +let print_err_exn phase any = let (e, info) = CErrors.push any in let loc = Loc.get_loc info in - let msg_loc = Option.cata pr_loc (mt ()) loc in - let pre_hdr = pr_opt_no_spc (fun x -> x) extra ++ msg_loc in + let pre_hdr = pr_phase ?loc phase in let msg = CErrors.iprint (e, info) ++ fnl () in - std_logger ~pre_hdr Feedback.Error msg + std_logger ?pre_hdr Feedback.Error msg let with_output_to_file fname func input = let channel = open_out (String.concat "." [fname; "out"]) in diff --git a/vernac/topfmt.mli b/vernac/topfmt.mli index 579b456a2..73dcb0064 100644 --- a/vernac/topfmt.mli +++ b/vernac/topfmt.mli @@ -53,8 +53,17 @@ val init_terminal_output : color:bool -> unit (** Error printing *) (* To be deprecated when we can fully move to feedback-based error printing. *) + +type execution_phase = + | ParsingCommandLine + | Initialization + | LoadingPrelude + | LoadingRcFile + | InteractiveLoop + val pr_loc : Loc.t -> Pp.t -val print_err_exn : ?extra:Pp.t -> exn -> unit +val pr_phase : ?loc:Loc.t -> execution_phase -> Pp.t option +val print_err_exn : execution_phase -> exn -> unit (** [with_output_to_file file f x] executes [f x] with logging redirected to a file [file] *) diff --git a/vernac/vernac.mllib b/vernac/vernac.mllib index f001b572a..356951b69 100644 --- a/vernac/vernac.mllib +++ b/vernac/vernac.mllib @@ -1,10 +1,18 @@ +Vernacexpr +Pvernac +G_vernac +G_proofs Vernacprop -Proof_using -Lemmas Himsg ExplainErr -Class Locality +Egramml +Vernacinterp +Ppvernac +Proof_using +Lemmas +Class +Egramcoq Metasyntax Auto_ind_decl Search @@ -20,7 +28,8 @@ Classes Record Assumptions Vernacstate -Vernacinterp Mltop Topfmt Vernacentries + +Misctypes diff --git a/vernac/vernacentries.ml b/vernac/vernacentries.ml index b44c7cccb..94eb45fd3 100644 --- a/vernac/vernacentries.ml +++ b/vernac/vernacentries.ml @@ -29,7 +29,6 @@ open Decl_kinds open Constrexpr open Redexpr open Lemmas -open Misctypes open Locality open Vernacinterp @@ -266,7 +265,7 @@ let print_namespace ns = let matches mp = match match_modulepath ns mp with | Some [] -> true | _ -> false in - let constants = (Environ.pre_env (Global.env ())).Pre_env.env_globals.Pre_env.env_constants in + let constants = (Global.env ()).Environ.env_globals.Environ.env_constants in let constants_in_namespace = Cmap_env.fold (fun c (body,_) acc -> let kn = Constant.user c in @@ -449,7 +448,7 @@ let start_proof_and_print k l hook = let evi = Evarutil.nf_evar_info sigma evi in let env = Evd.evar_filtered_env evi in try - let concl = EConstr.of_constr evi.Evd.evar_concl in + let concl = evi.Evd.evar_concl in if not (Evarutil.is_ground_env sigma env && Evarutil.is_ground_term sigma concl) then raise Exit; @@ -518,7 +517,7 @@ let vernac_exact_proof c = (* spiwack: for simplicity I do not enforce that "Proof proof_term" is called only at the begining of a proof. *) let status = Pfedit.by (Tactics.exact_proof c) in - save_proof (Vernacexpr.(Proved(Opaque,None))); + save_proof (Vernacexpr.(Proved(Proof_global.Opaque,None))); if not status then Feedback.feedback Feedback.AddedAxiom let vernac_assumption ~atts discharge kind l nl = @@ -637,7 +636,7 @@ let vernac_scheme l = let vernac_combined_scheme lid l = if Dumpglob.dump () then (Dumpglob.dump_definition lid false "def"; - List.iter (fun {loc;v=id} -> dump_global (make ?loc @@ Misctypes.AN (make ?loc @@ Ident id))) l); + List.iter (fun {loc;v=id} -> dump_global (make ?loc @@ AN (make ?loc @@ Ident id))) l); Indschemes.do_combined_scheme lid l let vernac_universe ~atts l = @@ -672,7 +671,7 @@ let vernac_declare_module export {loc;v=id} binders_ast mty_ast = else (idl,ty)) binders_ast in let mp = Declaremods.declare_module Modintern.interp_module_ast - id binders_ast (Enforce mty_ast) [] + id binders_ast (Declaremods.Enforce mty_ast) [] in Dumpglob.dump_moddef ?loc mp "mod"; Flags.if_verbose Feedback.msg_info (str "Module " ++ Id.print id ++ str " is declared"); @@ -855,7 +854,7 @@ let vernac_identity_coercion ~atts id qids qidt = let vernac_instance ~atts abst sup inst props pri = let global = not (make_section_locality atts.locality) in - Dumpglob.dump_constraint inst false "inst"; + Dumpglob.dump_constraint (fst (pi1 inst)) false "inst"; let program_mode = Flags.is_program_mode () in ignore(Classes.new_instance ~program_mode ~abstract:abst ~global atts.polymorphic sup inst props pri) @@ -909,7 +908,7 @@ let vernac_set_used_variables e = if List.is_empty to_clear then (p, ()) else let tac = Tactics.clear to_clear in - fst (Pfedit.solve SelectAll None tac p), () + fst (Pfedit.solve Goal_select.SelectAll None tac p), () end (*****************************) @@ -977,7 +976,7 @@ let vernac_remove_hints ~atts dbs ids = let vernac_hints ~atts lb h = let local = enforce_module_locality atts.locality in - Hints.add_hints local lb (Hints.interp_hints atts.polymorphic h) + Hints.add_hints ~local lb (Hints.interp_hints atts.polymorphic h) let vernac_syntactic_definition ~atts lid x y = Dumpglob.dump_definition lid false "syndef"; @@ -1131,15 +1130,16 @@ let vernac_arguments ~atts reference args more_implicits nargs_for_red flags = let names = rename prev_names names in let renaming_specified = Option.has_some !example_renaming in - if !rename_flag_required && not rename_flag then - user_err ~hdr:"vernac_declare_arguments" - (strbrk "To rename arguments the \"rename\" flag must be specified." - ++ spc () ++ - match !example_renaming with - | None -> mt () - | Some (o,n) -> - str "Argument " ++ Name.print o ++ - str " renamed to " ++ Name.print n ++ str "."); + if !rename_flag_required && not rename_flag then begin + let msg = + match !example_renaming with + | None -> + strbrk "To rename arguments the \"rename\" flag must be specified." + | Some (o,n) -> + strbrk "Flag \"rename\" expected to rename " ++ Name.print o ++ + strbrk " into " ++ Name.print n ++ str "." + in user_err ~hdr:"vernac_declare_arguments" msg + end; let duplicate_names = List.duplicates Name.equal (List.filter ((!=) Anonymous) names) @@ -1268,7 +1268,7 @@ let vernac_reserve bl = let vernac_generalizable ~atts = let local = make_non_locality atts.locality in - Implicit_quantifiers.declare_generalizable local + Implicit_quantifiers.declare_generalizable ~local let _ = declare_bool_option @@ -1465,22 +1465,22 @@ let _ = optkey = ["Printing";"Universes"]; optread = (fun () -> !Constrextern.print_universes); optwrite = (fun b -> Constrextern.print_universes:=b) } - + let _ = declare_bool_option { optdepr = false; optname = "dumping bytecode after compilation"; optkey = ["Dump";"Bytecode"]; - optread = Flags.get_dump_bytecode; - optwrite = Flags.set_dump_bytecode } + optread = (fun () -> !Cbytegen.dump_bytecode); + optwrite = (:=) Cbytegen.dump_bytecode } let _ = declare_bool_option { optdepr = false; optname = "dumping VM lambda code after compilation"; optkey = ["Dump";"Lambda"]; - optread = Flags.get_dump_lambda; - optwrite = Flags.set_dump_lambda } + optread = (fun () -> !Clambda.dump_lambda); + optwrite = (:=) Clambda.dump_lambda } let _ = declare_bool_option @@ -1611,7 +1611,7 @@ let get_current_context_of_args = function let query_command_selector ?loc = function | None -> None - | Some (SelectNth n) -> Some n + | Some (Goal_select.SelectNth n) -> Some n | _ -> user_err ?loc ~hdr:"query_command_selector" (str "Query commands only support the single numbered goal selector.") @@ -1619,17 +1619,16 @@ let vernac_check_may_eval ~atts redexp glopt rc = let glopt = query_command_selector ?loc:atts.loc glopt in let (sigma, env) = get_current_context_of_args glopt in let sigma', c = interp_open_constr env sigma rc in - let c = EConstr.Unsafe.to_constr c in let sigma' = Evarconv.solve_unif_constraints_with_heuristics env sigma' in Evarconv.check_problems_are_solved env sigma'; - let sigma',nf = Evarutil.nf_evars_and_universes sigma' in + let sigma' = Evd.minimize_universes sigma' in let uctx = Evd.universe_context_set sigma' in let env = Environ.push_context_set uctx (Evarutil.nf_env_evar sigma' env) in - let c = nf c in let j = - if Evarutil.has_undefined_evars sigma' (EConstr.of_constr c) then - Evarutil.j_nf_evar sigma' (Retyping.get_judgment_of env sigma' (EConstr.of_constr c)) + if Evarutil.has_undefined_evars sigma' c then + Evarutil.j_nf_evar sigma' (Retyping.get_judgment_of env sigma' c) else + let c = EConstr.to_constr sigma' c in (* OK to call kernel which does not support evars *) Termops.on_judgment EConstr.of_constr (Arguments_renaming.rename_typing env c) in @@ -1652,7 +1651,9 @@ let vernac_check_may_eval ~atts redexp glopt rc = let vernac_declare_reduction ~atts s r = let local = make_locality atts.locality in - declare_red_expr local s (snd (Hook.get f_interp_redexp (Global.env()) Evd.empty r)) + let env = Global.env () in + let sigma = Evd.from_env env in + declare_red_expr local s (snd (Hook.get f_interp_redexp env sigma r)) (* The same but avoiding the current goal context if any *) let vernac_global_check c = @@ -1742,7 +1743,7 @@ let vernac_print ~atts env sigma = else str"There may remain asynchronous universe constraints" in begin match dst with - | None -> UGraph.pr_universes Universes.pr_with_global_universes univ ++ pr_remaining + | None -> UGraph.pr_universes UnivNames.pr_with_global_universes univ ++ pr_remaining | Some s -> dump_universes_gen univ s end | PrintHint r -> Hints.pr_hint_ref env sigma (smart_global r) @@ -1912,7 +1913,7 @@ let vernac_subproof gln = Proof_global.simple_with_current_proof (fun _ p -> match gln with | None -> Proof.focus subproof_cond () 1 p - | Some (SelectNth n) -> Proof.focus subproof_cond () n p + | Some (Goal_select.SelectNth n) -> Proof.focus subproof_cond () n p | _ -> user_err ~hdr:"bracket_selector" (str "Brackets only support the single numbered goal selector.")) @@ -1970,7 +1971,7 @@ let vernac_load interp fname = interp x in let parse_sentence = Flags.with_option Flags.we_are_parsing (fun po -> - match Pcoq.Gram.entry_parse Pcoq.main_entry po with + match Pcoq.Gram.entry_parse Pvernac.main_entry po with | Some x -> x | None -> raise End_of_input) in let fname = @@ -2244,7 +2245,7 @@ let with_fail st b f = | HasNotFailed -> user_err ~hdr:"Fail" (str "The command has not failed!") | HasFailed msg -> - if not !Flags.quiet || !Flags.test_mode || !Flags.ide_slave then Feedback.msg_info + if not !Flags.quiet || !Flags.test_mode then Feedback.msg_info (str "The command has indeed failed with message:" ++ fnl () ++ msg) | _ -> assert false end diff --git a/vernac/vernacentries.mli b/vernac/vernacentries.mli index f6199e820..3c88a3443 100644 --- a/vernac/vernacentries.mli +++ b/vernac/vernacentries.mli @@ -8,9 +8,7 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) -open Misctypes - -val dump_global : Libnames.reference or_by_notation -> unit +val dump_global : Libnames.reference Constrexpr.or_by_notation -> unit (** Vernacular entries *) val vernac_require : diff --git a/intf/vernacexpr.ml b/vernac/vernacexpr.ml index 06f969f19..5acac9e25 100644 --- a/intf/vernacexpr.ml +++ b/vernac/vernacexpr.ml @@ -9,23 +9,19 @@ (************************************************************************) open Names -open Misctypes open Constrexpr open Libnames (** Vernac expressions, produced by the parser *) type class_rawexpr = FunClass | SortClass | RefClass of reference or_by_notation -(* spiwack: I'm choosing, for now, to have [goal_selector] be a - different type than [goal_reference] mostly because if it makes sense - to print a goal that is out of focus (or already solved) it doesn't - make sense to apply a tactic to it. Hence it the types may look very - similar, they do not seem to mean the same thing. *) -type goal_selector = +type goal_selector = Goal_select.t = + | SelectAlreadyFocused | SelectNth of int | SelectList of (int * int) list | SelectId of Id.t | SelectAll +[@@ocaml.deprecated "Use Goal_select.t"] type goal_identifier = string type scope_name = string @@ -35,8 +31,8 @@ type goal_reference = | NthGoal of int | GoalId of Id.t -type univ_name_list = Universes.univ_name_list -[@@ocaml.deprecated "Use [Universes.univ_name_list]"] +type univ_name_list = UnivNames.univ_name_list +[@@ocaml.deprecated "Use [UnivNames.univ_name_list]"] type printable = | PrintTables @@ -52,7 +48,7 @@ type printable = | PrintMLLoadPath | PrintMLModules | PrintDebugGC - | PrintName of reference or_by_notation * Universes.univ_name_list option + | PrintName of reference or_by_notation * UnivNames.univ_name_list option | PrintGraph | PrintClasses | PrintTypeClasses @@ -68,7 +64,7 @@ type printable = | PrintScopes | PrintScope of string | PrintVisibility of string option - | PrintAbout of reference or_by_notation * Universes.univ_name_list option * goal_selector option + | PrintAbout of reference or_by_notation * UnivNames.univ_name_list option * Goal_select.t option | PrintImplicit of reference or_by_notation | PrintAssumptions of bool * bool * reference or_by_notation | PrintStrategy of reference or_by_notation option @@ -106,29 +102,35 @@ type comment = | CommentString of string | CommentInt of int -type reference_or_constr = +type reference_or_constr = Hints.reference_or_constr = | HintsReference of reference | HintsConstr of constr_expr +[@@ocaml.deprecated "Please use [Hints.reference_or_constr]"] -type hint_mode = +type hint_mode = Hints.hint_mode = | ModeInput (* No evars *) | ModeNoHeadEvar (* No evar at the head *) | ModeOutput (* Anything *) +[@@ocaml.deprecated "Please use [Hints.hint_mode]"] -type 'a hint_info_gen = +type 'a hint_info_gen = 'a Typeclasses.hint_info_gen = { hint_priority : int option; hint_pattern : 'a option } +[@@ocaml.deprecated "Please use [Typeclasses.hint_info_gen]"] -type hint_info_expr = constr_pattern_expr hint_info_gen +type hint_info_expr = Hints.hint_info_expr +[@@ocaml.deprecated "Please use [Hints.hint_info_expr]"] -type hints_expr = - | HintsResolve of (hint_info_expr * bool * reference_or_constr) list - | HintsImmediate of reference_or_constr list +type hints_expr = Hints.hints_expr = + | HintsResolve of (Hints.hint_info_expr * bool * Hints.reference_or_constr) list + | HintsResolveIFF of bool * reference list * int option + | HintsImmediate of Hints.reference_or_constr list | HintsUnfold of reference list | HintsTransparency of reference list * bool - | HintsMode of reference * hint_mode list + | HintsMode of reference * Hints.hint_mode list | HintsConstructors of reference list | HintsExtern of int * constr_expr option * Genarg.raw_generic_argument +[@@ocaml.deprecated "Please use [Hints.hints_expr]"] type search_restriction = | SearchInside of reference list @@ -136,7 +138,8 @@ type search_restriction = type rec_flag = bool (* true = Rec; false = NoRec *) type verbose_flag = bool (* true = Verbose; false = Silent *) -type opacity_flag = Opaque | Transparent +type opacity_flag = Proof_global.opacity_flag = Opaque | Transparent + [@ocaml.deprecated "Please use [Proof_global.opacity_flag]"] type coercion_flag = bool (* true = AddCoercion false = NoCoercion *) type instance_flag = bool option (* Some true = Backward instance; Some false = Forward instance, None = NoInstance *) @@ -197,7 +200,6 @@ type one_inductive_expr = ident_decl * local_binder_expr list * constr_expr option * constructor_expr list type typeclass_constraint = name_decl * Decl_kinds.binding_kind * constr_expr - and typeclass_context = typeclass_constraint list type proof_expr = @@ -205,7 +207,7 @@ type proof_expr = type syntax_modifier = | SetItemLevel of string list * Extend.production_level - | SetItemLevelAsBinder of string list * Extend.constr_as_binder_kind * Extend.production_level option + | SetItemLevelAsBinder of string list * Notation_term.constr_as_binder_kind * Extend.production_level option | SetLevel of int | SetAssoc of Extend.gram_assoc | SetEntryType of string * Extend.simple_constr_prod_entry_key @@ -217,7 +219,7 @@ type syntax_modifier = type proof_end = | Admitted (* name in `Save ident` when closing goal *) - | Proved of opacity_flag * lident option + | Proved of Proof_global.opacity_flag * lident option type scheme = | InductionScheme of bool * reference or_by_notation * sort_expr @@ -269,32 +271,32 @@ type extend_name = (* This type allows registering the inlining of constants in native compiler. It will be extended with primitive inductive types and operators *) -type register_kind = +type register_kind = | RegisterInline -type bullet = - | Dash of int - | Star of int - | Plus of int +type bullet = Proof_bullet.t +[@@ocaml.deprecated "Alias type, please use [Proof_bullet.t]"] (** {6 Types concerning the module layer} *) (** Rigid / flexible module signature *) -type 'a module_signature = +type 'a module_signature = 'a Declaremods.module_signature = | Enforce of 'a (** ... : T *) | Check of 'a list (** ... <: T1 <: T2, possibly empty *) +[@@ocaml.deprecated "please use [Declaremods.module_signature]."] (** Which module inline annotations should we honor, either None or the ones whose level is less or equal to the given integer *) -type inline = +type inline = Declaremods.inline = | NoInline | DefaultInline | InlineAt of int +[@@ocaml.deprecated "please use [Declaremods.inline]."] -type module_ast_inl = module_ast * inline +type module_ast_inl = module_ast * Declaremods.inline type module_binder = bool option * lident list * module_ast_inl (** [Some b] if locally enabled/disabled according to [b], [None] if @@ -333,14 +335,14 @@ type nonrec vernac_expr = | VernacEndProof of proof_end | VernacExactProof of constr_expr | VernacAssumption of (Decl_kinds.discharge * Decl_kinds.assumption_object_kind) * - inline * (ident_decl list * constr_expr) with_coercion list + Declaremods.inline * (ident_decl list * constr_expr) with_coercion list | VernacInductive of vernac_cumulative option * Decl_kinds.private_flag * inductive_flag * (inductive_expr * decl_notation list) list | VernacFixpoint of Decl_kinds.discharge * (fixpoint_expr * decl_notation list) list | VernacCoFixpoint of Decl_kinds.discharge * (cofixpoint_expr * decl_notation list) list | VernacScheme of (lident option * scheme) list | VernacCombinedScheme of lident * lident list | VernacUniverse of lident list - | VernacConstraint of glob_constraint list + | VernacConstraint of Glob_term.glob_constraint list (* Gallina extensions *) | VernacBeginSection of lident @@ -352,20 +354,20 @@ type nonrec vernac_expr = | VernacCoercion of reference or_by_notation * class_rawexpr * class_rawexpr | VernacIdentityCoercion of lident * class_rawexpr * class_rawexpr - | VernacNameSectionHypSet of lident * section_subset_expr + | VernacNameSectionHypSet of lident * section_subset_expr (* Type classes *) | VernacInstance of bool * (* abstract instance *) local_binder_expr list * (* super *) - typeclass_constraint * (* instance name, class name, params *) - (bool * constr_expr) option * (* props *) - hint_info_expr + typeclass_constraint * (* instance name, class name, params *) + (bool * constr_expr) option * (* props *) + Hints.hint_info_expr | VernacContext of local_binder_expr list | VernacDeclareInstances of - (reference * hint_info_expr) list (* instances names, priorities and patterns *) + (reference * Hints.hint_info_expr) list (* instances names, priorities and patterns *) | VernacDeclareClass of reference (* inductive or definition name *) @@ -373,7 +375,7 @@ type nonrec vernac_expr = | VernacDeclareModule of bool option * lident * module_binder list * module_ast_inl | VernacDefineModule of bool option * lident * module_binder list * - module_ast_inl module_signature * module_ast_inl list + module_ast_inl Declaremods.module_signature * module_ast_inl list | VernacDeclareModuleType of lident * module_binder list * module_ast_inl list * module_ast_inl list | VernacInclude of module_ast_inl list @@ -402,7 +404,7 @@ type nonrec vernac_expr = (* Commands *) | VernacCreateHintDb of string * bool | VernacRemoveHints of string list * reference list - | VernacHints of string list * hints_expr + | VernacHints of string list * Hints.hints_expr | VernacSyntacticDefinition of lident * (Id.t list * constr_expr) * onlyparsing_flag | VernacArguments of reference or_by_notation * @@ -423,11 +425,11 @@ type nonrec vernac_expr = | VernacRemoveOption of Goptions.option_name * option_ref_value list | VernacMemOption of Goptions.option_name * option_ref_value list | VernacPrintOption of Goptions.option_name - | VernacCheckMayEval of Genredexpr.raw_red_expr option * goal_selector option * constr_expr + | VernacCheckMayEval of Genredexpr.raw_red_expr option * Goal_select.t option * constr_expr | VernacGlobalCheck of constr_expr | VernacDeclareReduction of string * Genredexpr.raw_red_expr | VernacPrint of printable - | VernacSearch of searchable * goal_selector option * search_restriction + | VernacSearch of searchable * Goal_select.t option * search_restriction | VernacLocate of locatable | VernacRegister of lident * register_kind | VernacComments of comment list @@ -441,8 +443,8 @@ type nonrec vernac_expr = | VernacFocus of int option | VernacUnfocus | VernacUnfocused - | VernacBullet of bullet - | VernacSubproof of goal_selector option + | VernacBullet of Proof_bullet.t + | VernacSubproof of Goal_select.t option | VernacEndSubproof | VernacShow of showable | VernacCheckGuard @@ -518,14 +520,3 @@ type vernac_when = | VtNow | VtLater type vernac_classification = vernac_type * vernac_when - - -(** Deprecated stuff *) -type universe_decl_expr = Constrexpr.universe_decl_expr -[@@ocaml.deprecated "alias of Constrexpr.universe_decl_expr"] - -type ident_decl = Constrexpr.ident_decl -[@@ocaml.deprecated "alias of Constrexpr.ident_decl"] - -type name_decl = Constrexpr.name_decl -[@@ocaml.deprecated "alias of Constrexpr.name_decl"] |
