diff --git a/.github/workflows/build.yml b/.github/workflows/build.yml index 43991e0f8..dbd6e781b 100644 --- a/.github/workflows/build.yml +++ b/.github/workflows/build.yml @@ -1,8 +1,23 @@ name: MetaCoq CI -on: [push, pull_request] +on: + push: + pull_request: + types: [opened, synchronize, reopened, ready_for_review] jobs: + checktodos: + if: github.event_name != 'pull_request' || github.event.pull_request.draft == false + runs-on: ubuntu-latest + steps: + - name: Checkout code + uses: actions/checkout@v2 + with: + fetch-depth: 1 + + - name: Check for todos + run: ./checktodos.sh + build: runs-on: ubuntu-latest @@ -11,7 +26,7 @@ jobs: coq_version: - 'dev' ocaml_version: - - '4.12-flambda' + - '4.14-flambda' target: [ local, opam, quick ] fail-fast: true @@ -32,6 +47,10 @@ jobs: sudo chown -R coq:coq . # <-- opam exec -- ocamlfind list endGroup + before_install: | + startGroup "Print opam config" + opam config list; opam repo list; opam list + endGroup script: | startGroup "Build project" opam exec -- ./configure.sh --enable-${{matrix.target}} diff --git a/.github/workflows/nix-action-coq-8.16-macos.yml b/.github/workflows/nix-action-coq-8.16-macos.yml new file mode 100644 index 000000000..0b8c2358b --- /dev/null +++ b/.github/workflows/nix-action-coq-8.16-macos.yml @@ -0,0 +1,153 @@ +jobs: + coq: + needs: [] + runs-on: macos-latest + steps: + - name: Determine which commit to test + run: "if [ ${{ github.event_name }} = \"push\" ]; then\n echo \"tested_commit=${{\ + \ github.sha }}\" >> $GITHUB_ENV\nelse\n merge_commit=$(git ls-remote ${{\ + \ github.event.repository.html_url }} refs/pull/${{ github.event.number }}/merge\ + \ | cut -f1)\n if [ -z \"$merge_commit\" ]; then\n echo \"tested_commit=${{\ + \ github.event.pull_request.head.sha }}\" >> $GITHUB_ENV\n else\n echo\ + \ \"tested_commit=$merge_commit\" >> $GITHUB_ENV\n fi\nfi\n" + - name: Git checkout + uses: actions/checkout@v2 + with: + fetch-depth: 0 + ref: ${{ env.tested_commit }} + - name: Cachix install + uses: cachix/install-nix-action@v16 + with: + nix_path: nixpkgs=channel:nixpkgs-unstable + - name: Cachix setup metacoq + uses: cachix/cachix-action@v10 + with: + authToken: ${{ secrets.CACHIX_AUTH_TOKEN }} + extraPullNames: coq, coq-community + name: metacoq + - id: stepCheck + name: Checking presence of CI target coq + run: "nb_dry_run=$(NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link \\\n --argstr\ + \ bundle \"coq-dev\" --argstr job \"coq\" \\\n --dry-run 2>&1 > /dev/null)\n\ + echo $nb_dry_run\necho ::set-output name=status::$(echo $nb_dry_run | grep\ + \ \"built:\" | sed \"s/.*/built/\")\n" + - if: steps.stepCheck.outputs.status == 'built' + name: Building/fetching current CI target + run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-dev" + --argstr job "coq" + equations: + needs: + - coq + runs-on: macos-latest + steps: + - name: Determine which commit to test + run: "if [ ${{ github.event_name }} = \"push\" ]; then\n echo \"tested_commit=${{\ + \ github.sha }}\" >> $GITHUB_ENV\nelse\n merge_commit=$(git ls-remote ${{\ + \ github.event.repository.html_url }} refs/pull/${{ github.event.number }}/merge\ + \ | cut -f1)\n if [ -z \"$merge_commit\" ]; then\n echo \"tested_commit=${{\ + \ github.event.pull_request.head.sha }}\" >> $GITHUB_ENV\n else\n echo\ + \ \"tested_commit=$merge_commit\" >> $GITHUB_ENV\n fi\nfi\n" + - name: Git checkout + uses: actions/checkout@v2 + with: + fetch-depth: 0 + ref: ${{ env.tested_commit }} + - name: Cachix install + uses: cachix/install-nix-action@v16 + with: + nix_path: nixpkgs=channel:nixpkgs-unstable + - name: Cachix setup metacoq + uses: cachix/cachix-action@v10 + with: + authToken: ${{ secrets.CACHIX_AUTH_TOKEN }} + extraPullNames: coq, coq-community + name: metacoq + - id: stepCheck + name: Checking presence of CI target equations + run: "nb_dry_run=$(NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link \\\n --argstr\ + \ bundle \"coq-dev\" --argstr job \"equations\" \\\n --dry-run 2>&1 > /dev/null)\n\ + echo $nb_dry_run\necho ::set-output name=status::$(echo $nb_dry_run | grep\ + \ \"built:\" | sed \"s/.*/built/\")\n" + - if: steps.stepCheck.outputs.status == 'built' + name: 'Building/fetching previous CI target: coq' + run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-dev" + --argstr job "coq" + - if: steps.stepCheck.outputs.status == 'built' + name: Building/fetching current CI target + run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-dev" + --argstr job "equations" + metacoq: + needs: + - coq + - equations + runs-on: macos-latest + steps: + - name: Determine which commit to test + run: "if [ ${{ github.event_name }} = \"push\" ]; then\n echo \"tested_commit=${{\ + \ github.sha }}\" >> $GITHUB_ENV\nelse\n merge_commit=$(git ls-remote ${{\ + \ github.event.repository.html_url }} refs/pull/${{ github.event.number }}/merge\ + \ | cut -f1)\n if [ -z \"$merge_commit\" ]; then\n echo \"tested_commit=${{\ + \ github.event.pull_request.head.sha }}\" >> $GITHUB_ENV\n else\n echo\ + \ \"tested_commit=$merge_commit\" >> $GITHUB_ENV\n fi\nfi\n" + - name: Git checkout + uses: actions/checkout@v2 + with: + fetch-depth: 0 + ref: ${{ env.tested_commit }} + - name: Cachix install + uses: cachix/install-nix-action@v16 + with: + nix_path: nixpkgs=channel:nixpkgs-unstable + - name: Cachix setup metacoq + uses: cachix/cachix-action@v10 + with: + authToken: ${{ secrets.CACHIX_AUTH_TOKEN }} + extraPullNames: coq, coq-community + name: metacoq + - id: stepCheck + name: Checking presence of CI target metacoq + run: "nb_dry_run=$(NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link \\\n --argstr\ + \ bundle \"coq-dev\" --argstr job \"metacoq\" \\\n --dry-run 2>&1 > /dev/null)\n\ + echo $nb_dry_run\necho ::set-output name=status::$(echo $nb_dry_run | grep\ + \ \"built:\" | sed \"s/.*/built/\")\n" + - if: steps.stepCheck.outputs.status == 'built' + name: 'Building/fetching previous CI target: coq' + run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-dev" + --argstr job "coq" + - if: steps.stepCheck.outputs.status == 'built' + name: 'Building/fetching previous CI target: equations' + run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-dev" + --argstr job "equations" + - if: steps.stepCheck.outputs.status == 'built' + name: 'Building/fetching previous CI target: metacoq-template-coq' + run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-dev" + --argstr job "metacoq-template-coq" + - if: steps.stepCheck.outputs.status == 'built' + name: 'Building/fetching previous CI target: metacoq-pcuic' + run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-dev" + --argstr job "metacoq-pcuic" + - if: steps.stepCheck.outputs.status == 'built' + name: 'Building/fetching previous CI target: metacoq-safechecker' + run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-dev" + --argstr job "metacoq-safechecker" + - if: steps.stepCheck.outputs.status == 'built' + name: 'Building/fetching previous CI target: metacoq-erasure' + run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-dev" + --argstr job "metacoq-erasure" + - if: steps.stepCheck.outputs.status == 'built' + name: Building/fetching current CI target + run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-dev" + --argstr job "metacoq" +name: Nix CI for bundle coq-dev +'on': + pull_request: + paths: + - .github/workflows/** + pull_request_target: + types: + - opened + - synchronize + - reopened + push: + branches: + - master diff --git a/.github/workflows/nix-action-coq-8.16-ubuntu.yml b/.github/workflows/nix-action-coq-8.16-ubuntu.yml new file mode 100644 index 000000000..6b0b0cb27 --- /dev/null +++ b/.github/workflows/nix-action-coq-8.16-ubuntu.yml @@ -0,0 +1,153 @@ +jobs: + coq: + needs: [] + runs-on: ubuntu-latest + steps: + - name: Determine which commit to test + run: "if [ ${{ github.event_name }} = \"push\" ]; then\n echo \"tested_commit=${{\ + \ github.sha }}\" >> $GITHUB_ENV\nelse\n merge_commit=$(git ls-remote ${{\ + \ github.event.repository.html_url }} refs/pull/${{ github.event.number }}/merge\ + \ | cut -f1)\n if [ -z \"$merge_commit\" ]; then\n echo \"tested_commit=${{\ + \ github.event.pull_request.head.sha }}\" >> $GITHUB_ENV\n else\n echo\ + \ \"tested_commit=$merge_commit\" >> $GITHUB_ENV\n fi\nfi\n" + - name: Git checkout + uses: actions/checkout@v2 + with: + fetch-depth: 0 + ref: ${{ env.tested_commit }} + - name: Cachix install + uses: cachix/install-nix-action@v16 + with: + nix_path: nixpkgs=channel:nixpkgs-unstable + - name: Cachix setup metacoq + uses: cachix/cachix-action@v10 + with: + authToken: ${{ secrets.CACHIX_AUTH_TOKEN }} + extraPullNames: coq, coq-community + name: metacoq + - id: stepCheck + name: Checking presence of CI target coq + run: "nb_dry_run=$(NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link \\\n --argstr\ + \ bundle \"coq-dev\" --argstr job \"coq\" \\\n --dry-run 2>&1 > /dev/null)\n\ + echo $nb_dry_run\necho ::set-output name=status::$(echo $nb_dry_run | grep\ + \ \"built:\" | sed \"s/.*/built/\")\n" + - if: steps.stepCheck.outputs.status == 'built' + name: Building/fetching current CI target + run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-dev" + --argstr job "coq" + equations: + needs: + - coq + runs-on: ubuntu-latest + steps: + - name: Determine which commit to test + run: "if [ ${{ github.event_name }} = \"push\" ]; then\n echo \"tested_commit=${{\ + \ github.sha }}\" >> $GITHUB_ENV\nelse\n merge_commit=$(git ls-remote ${{\ + \ github.event.repository.html_url }} refs/pull/${{ github.event.number }}/merge\ + \ | cut -f1)\n if [ -z \"$merge_commit\" ]; then\n echo \"tested_commit=${{\ + \ github.event.pull_request.head.sha }}\" >> $GITHUB_ENV\n else\n echo\ + \ \"tested_commit=$merge_commit\" >> $GITHUB_ENV\n fi\nfi\n" + - name: Git checkout + uses: actions/checkout@v2 + with: + fetch-depth: 0 + ref: ${{ env.tested_commit }} + - name: Cachix install + uses: cachix/install-nix-action@v16 + with: + nix_path: nixpkgs=channel:nixpkgs-unstable + - name: Cachix setup metacoq + uses: cachix/cachix-action@v10 + with: + authToken: ${{ secrets.CACHIX_AUTH_TOKEN }} + extraPullNames: coq, coq-community + name: metacoq + - id: stepCheck + name: Checking presence of CI target equations + run: "nb_dry_run=$(NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link \\\n --argstr\ + \ bundle \"coq-dev\" --argstr job \"equations\" \\\n --dry-run 2>&1 > /dev/null)\n\ + echo $nb_dry_run\necho ::set-output name=status::$(echo $nb_dry_run | grep\ + \ \"built:\" | sed \"s/.*/built/\")\n" + - if: steps.stepCheck.outputs.status == 'built' + name: 'Building/fetching previous CI target: coq' + run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-dev" + --argstr job "coq" + - if: steps.stepCheck.outputs.status == 'built' + name: Building/fetching current CI target + run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-dev" + --argstr job "equations" + metacoq: + needs: + - coq + - equations + runs-on: ubuntu-latest + steps: + - name: Determine which commit to test + run: "if [ ${{ github.event_name }} = \"push\" ]; then\n echo \"tested_commit=${{\ + \ github.sha }}\" >> $GITHUB_ENV\nelse\n merge_commit=$(git ls-remote ${{\ + \ github.event.repository.html_url }} refs/pull/${{ github.event.number }}/merge\ + \ | cut -f1)\n if [ -z \"$merge_commit\" ]; then\n echo \"tested_commit=${{\ + \ github.event.pull_request.head.sha }}\" >> $GITHUB_ENV\n else\n echo\ + \ \"tested_commit=$merge_commit\" >> $GITHUB_ENV\n fi\nfi\n" + - name: Git checkout + uses: actions/checkout@v2 + with: + fetch-depth: 0 + ref: ${{ env.tested_commit }} + - name: Cachix install + uses: cachix/install-nix-action@v16 + with: + nix_path: nixpkgs=channel:nixpkgs-unstable + - name: Cachix setup metacoq + uses: cachix/cachix-action@v10 + with: + authToken: ${{ secrets.CACHIX_AUTH_TOKEN }} + extraPullNames: coq, coq-community + name: metacoq + - id: stepCheck + name: Checking presence of CI target metacoq + run: "nb_dry_run=$(NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link \\\n --argstr\ + \ bundle \"coq-dev\" --argstr job \"metacoq\" \\\n --dry-run 2>&1 > /dev/null)\n\ + echo $nb_dry_run\necho ::set-output name=status::$(echo $nb_dry_run | grep\ + \ \"built:\" | sed \"s/.*/built/\")\n" + - if: steps.stepCheck.outputs.status == 'built' + name: 'Building/fetching previous CI target: coq' + run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-dev" + --argstr job "coq" + - if: steps.stepCheck.outputs.status == 'built' + name: 'Building/fetching previous CI target: equations' + run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-dev" + --argstr job "equations" + - if: steps.stepCheck.outputs.status == 'built' + name: 'Building/fetching previous CI target: metacoq-template-coq' + run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-dev" + --argstr job "metacoq-template-coq" + - if: steps.stepCheck.outputs.status == 'built' + name: 'Building/fetching previous CI target: metacoq-pcuic' + run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-dev" + --argstr job "metacoq-pcuic" + - if: steps.stepCheck.outputs.status == 'built' + name: 'Building/fetching previous CI target: metacoq-safechecker' + run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-dev" + --argstr job "metacoq-safechecker" + - if: steps.stepCheck.outputs.status == 'built' + name: 'Building/fetching previous CI target: metacoq-erasure' + run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-dev" + --argstr job "metacoq-erasure" + - if: steps.stepCheck.outputs.status == 'built' + name: Building/fetching current CI target + run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-dev" + --argstr job "metacoq" +name: Nix CI for bundle coq-dev +'on': + pull_request: + paths: + - .github/workflows/** + pull_request_target: + types: + - opened + - synchronize + - reopened + push: + branches: + - master diff --git a/.gitignore b/.gitignore index e92c1e871..6445c4f38 100644 --- a/.gitignore +++ b/.gitignore @@ -356,3 +356,10 @@ erasure/src/eGlobalEnv.ml Makefile.conf test-suite/plugin-demo/src/META.coq-metacoq-demo-plugin pcuic/src/META.coq-metacoq-pcuic +examples/_CoqProject +test-suite/_CoqProject +examples/metacoq-config +test-suite/metacoq-config +test-suite/plugin-demo/_CoqProject +test-suite/plugin-demo/_PluginProject +test-suite/plugin-demo/metacoq-config diff --git a/.nix/cachedMake.sh b/.nix/cachedMake.sh new file mode 100755 index 000000000..20c4ae9d4 --- /dev/null +++ b/.nix/cachedMake.sh @@ -0,0 +1,52 @@ +#! /usr/bin/bash + +# USAGE: To be run from the top directory of metacoq + +# This whole file is a hack around coq-nix-toolbox to manage the +# structure of metacoq directories + +export currentDir=$PWD +export configDir=$currentDir/.nix + +#Assume that the bundles are of the shape coq-version +# (e.g. coq-8.14 with version being major) +coq_version=${selectedBundle#*-} + +my-nix-build-with-target (){ + target=$1 + shift + env -i PATH=$PATH NIX_PATH=$NIX_PATH nix-build -A $target \ + --argstr bundle "$selectedBundle" --no-out-link\ + --option narinfo-cache-negative-ttl 0 $* +} + +my-cachedMake (){ + cproj=$currentDir/$coqproject + cprojDir=$(dirname $cproj) + nb_dry_run=$(my-nix-build-with-target $1 --dry-run 2>&1 > /dev/null) + if echo $nb_dry_run | grep -q "built:"; then + echo "The compilation result is not in cache." + echo "Either it is not in cache (yet) or your must check your cachix configuration." + kill -INT $$ + else + build=$(my-nix-build-with-target $1) + realpath=$2 + namespace=$3 + logpath=${namespace/.//} + vopath="$build/lib/coq/$coq_version/user-contrib/$logpath" + dest=$cprojDir/$realpath + if [[ -d $vopath ]] + then echo "Compiling/Fetching and copying vo from $vopath to $realpath" + cp -nr --no-preserve=mode,ownership $vopath/* $dest + else echo "Error: cannot find compiled $logpath at $vopath, check your .nix/config.nix" + fi + fi +} + +my-cachedMake 'template-coq' 'template-coq/theories' 'MetaCoq.Template' +my-cachedMake 'pcuic' 'pcuic/theories' 'MetaCoq.PCUIC' +my-cachedMake 'safechecker' 'safechecker/theories' 'MetaCoq.SafeChecker' +my-cachedMake 'erasure' 'erasure/theories' 'MetaCoq.Erasure' + +unset -f my-nix-build-with-target +unset -f my-cachedMake diff --git a/.nix/config.nix b/.nix/config.nix new file mode 100644 index 000000000..833af0b45 --- /dev/null +++ b/.nix/config.nix @@ -0,0 +1,102 @@ +{ + ## DO NOT CHANGE THIS + format = "1.0.0"; + ## unless you made an automated or manual update + ## to another supported format. + + ## The attribute to build from the local sources, + ## either using nixpkgs data or the overlays located in `.nix/coq-overlays` + ## Will determine the default main-job of the bundles defined below + attribute = "metacoq"; + + ## If you want to select a different attribute (to build from the local sources as well) + ## when calling `nix-shell` and `nix-build` without the `--argstr job` argument + # shell-attribute = "{{nix_name}}"; + + ## Maybe the shortname of the library is different from + ## the name of the nixpkgs attribute, if so, set it here: + # pname = "{{shortname}}"; + + ## Lists the dependencies, phrased in terms of nix attributes. + ## No need to list Coq, it is already included. + ## These dependencies will systematically be added to the currently + ## known dependencies, if any more than Coq. + ## /!\ Remove this field as soon as the package is available on nixpkgs. + ## /!\ Manual overlays in `.nix/coq-overlays` should be preferred then. + # buildInputs = [ ]; + + ## Indicate the relative location of your _CoqProject + ## If not specified, it defaults to "_CoqProject" + # coqproject = "_CoqProject"; + + ## select an entry to build in the following `bundles` set + ## defaults to "default" + default-bundle = "coq-dev"; + + # MetaCoq is expected to be compatible with a single coq version + # The name of the bundle should finish with the coq version to use + # cachedMake.sh + bundles."coq-dev" = { + + ## You can override Coq and other Coq coqPackages + ## through the following attribute + coqPackages.coq.override.version = "master"; + coqPackages.equations.override.version = "master"; + + ## In some cases, light overrides are not available/enough + ## in which case you can use either + # coqPackages..overrideAttrs = o: ; + # coqPackages.equations.overrideAttrs = o: ; + ## or a "long" overlay to put in `.nix/coq-overlays + ## you may use `nix-shell --run fetchOverlay ` + ## to automatically retrieve the one from nixpkgs + ## if it exists and is correctly named/located + + ## You can override Coq and other coqPackages + ## through the following attribute + ## If does not support light overrides, + ## you may use `overrideAttrs` or long overlays + ## located in `.nix/ocaml-overlays` + ## (there is no automation for this one) + # ocamlPackages..override.version = "x.xx"; + + ## You can also override packages from the nixpkgs toplevel + # .override.overrideAttrs = o: ; + ## Or put an overlay in `.nix/overlays` + + ## you may mark a package as a main CI job (one to take deps and + ## rev deps from) as follows + # coqPackages..main-job = true; + ## by default the current package and its shell attributes are main jobs + + ## you may mark a package as a CI job as follows + # coqPackages..job = "test"; + ## It can then built through + ## nix-build --argstr bundle "default" --arg job "test"; + ## in the absence of such a directive, the job "another-pkg" will + ## is still available, but will be automatically included in the CI + ## via the command genNixActions only if it is a dependency or a + ## reverse dependency of a job flagged as "main-job" (see above). + + }; + + ## Cachix caches to use in CI + ## Below we list some standard ones + cachix.coq = {}; + # cachix.math-comp = {}; + cachix.coq-community = {}; + + ## If you have write access to one of these caches you can + ## provide the auth token or signing key through a secret + ## variable on GitHub. Then, you should give the variable + ## name here. For instance, coq-community projects can use + ## the following line instead of the one above: + cachix.metacoq.authToken = "CACHIX_AUTH_TOKEN"; + + ## Or if you have a signing key for a given Cachix cache: + # cachix.my-cache.signingKey = "CACHIX_SIGNING_KEY" + + ## Note that here, CACHIX_AUTH_TOKEN and CACHIX_SIGNING_KEY + ## are the names of secret variables. They are set in + ## GitHub's web interface. +} diff --git a/.nix/coq-nix-toolbox.nix b/.nix/coq-nix-toolbox.nix new file mode 100644 index 000000000..ca847615b --- /dev/null +++ b/.nix/coq-nix-toolbox.nix @@ -0,0 +1 @@ +"39243d0edb4cb0b872d299c4b128fe232f0d8101" diff --git a/.nix/coq-overlays/equations/default.nix b/.nix/coq-overlays/equations/default.nix new file mode 100644 index 000000000..ffe72ad33 --- /dev/null +++ b/.nix/coq-overlays/equations/default.nix @@ -0,0 +1,67 @@ +{ lib, mkCoqDerivation, coq, version ? null }: + +with lib; (mkCoqDerivation { + pname = "equations"; + owner = "mattam82"; + repo = "Coq-Equations"; + inherit version; + defaultVersion = switch coq.coq-version [ + { case = "8.16"; out = "1.3+8.16"; } + { case = "8.15"; out = "1.3+8.15"; } + { case = "8.14"; out = "1.3+8.14"; } + { case = "8.13"; out = "1.3+8.13"; } + { case = "8.12"; out = "1.2.4+coq8.12"; } + { case = "8.11"; out = "1.2.4+coq8.11"; } + { case = "8.10"; out = "1.2.1+coq8.10-2"; } + { case = "8.9"; out = "1.2.1+coq8.9"; } + { case = "8.8"; out = "1.2+coq8.8"; } + { case = "8.7"; out = "1.0+coq8.7"; } + { case = "8.6"; out = "1.0+coq8.6"; } + ] null; + + release."1.0+coq8.6".version = "1.0"; + release."1.0+coq8.6".rev = "v1.0"; + release."1.0+coq8.6".sha256 = "19ylw9v9g35607w4hm86j7mmkghh07hmkc1ls5bqlz3dizh5q4pj"; + release."1.0+coq8.7".version = "1.0"; + release."1.0+coq8.7".rev = "v1.0-8.7"; + release."1.0+coq8.7".sha256 = "1bavg4zl1xn0jqrdq8iw7xqzdvdf39ligj9saz5m9c507zri952h"; + release."1.2+coq8.8".version = "1.2"; + release."1.2+coq8.8".rev = "v1.2-8.8"; + release."1.2+coq8.8".sha256 = "06452fyzalz7zcjjp73qb7d6xvmqb6skljkivf8pfm55fsc8s7kx"; + release."1.2.1+coq8.9".version = "1.2.1"; + release."1.2.1+coq8.9".rev = "v1.2.1-8.9"; + release."1.2.1+coq8.9".sha256 = "0d8ddj6nc6p0k25cd8fs17cq427zhzbc3v9pk2wd2fnvk70nlfij"; + release."1.2.1+coq8.10-2".version = "1.2.1"; + release."1.2.1+coq8.10-2".rev = "v1.2.1-8.10-2"; + release."1.2.1+coq8.10-2".sha256 = "0j3z4l5nrbyi9zbbyqkc6kassjanwld2188mwmrbqspaypm2ys68"; + release."1.2.3+coq8.11".version = "1.2.3"; + release."1.2.3+coq8.11".rev = "v1.2.3-8.11"; + release."1.2.3+coq8.11".sha256 = "1srxz1rws8jsh7402g2x2vcqgjbbsr64dxxj5d2zs48pmhb20csf"; + release."1.2.3+coq8.12".version = "1.2.3"; + release."1.2.3+coq8.12".rev = "v1.2.3-8.12"; + release."1.2.3+coq8.12".sha256 = "1y0jkvzyz5ssv5vby41p1i8zs7nsdc8g3pzyq73ih9jz8h252643"; + release."1.2.4+coq8.11".rev = "v1.2.4-8.11"; + release."1.2.4+coq8.11".sha256 = "01fihyav8jbjinycgjc16adpa0zy5hcav5mlkf4s9zvqxka21i52"; + release."1.2.4+coq8.12".rev = "v1.2.4-8.12"; + release."1.2.4+coq8.12".sha256 = "1n0w8is464qcq8mk2mv7amaf0khbjz5mpc9phf0rhpjm0lb22cb3"; + release."1.2.4+coq8.13".rev = "v1.2.4-8.13"; + release."1.2.4+coq8.13".sha256 = "0i014lshsdflzw6h0qxra9d2f0q82vffxv2f29awbb9ad0p4rq4q"; + release."1.3+8.13".rev = "v1.3-8.13"; + release."1.3+8.13".sha256 = "1jwjbkkkk4bwf6pz4zzz8fy5bb17aqyf4smkja59rgj9ya6nrdhg"; + release."1.3+8.14".rev = "v1.3-8.14"; + release."1.3+8.14".sha256 = "19bj9nncd1r9g4273h5qx35gs3i4bw5z9bhjni24b413hyj55hkv"; + release."1.3+8.15".rev = "v1.3-8.15"; + release."1.3+8.15".sha256 = "1vfcfpsp9zyj0sw0cwibk76nj6n0r6gwh8m1aa3lbvc0b1kbm32k"; + release."1.3+8.16".rev = "v1.3-8.16"; + release."1.3+8.16".sha256 = "sha256-zyMGeRObtSGWh7n3WCqesBZL5EgLvKwmnTy09rYpxyE="; + + mlPlugin = true; + + meta = { + homepage = "https://mattam82.github.io/Coq-Equations/"; + description = "A plugin for Coq to add dependent pattern-matching"; + maintainers = with maintainers; [ jwiegley ]; + }; +}).overrideAttrs (o: { + preBuild = "coq_makefile -f _CoqProject -o Makefile${optionalString (versionAtLeast o.version "1.2.1" || o.version == "dev") ".coq"}"; +}) diff --git a/.nix/coq-overlays/metacoq/default.nix b/.nix/coq-overlays/metacoq/default.nix new file mode 100644 index 000000000..5d41abec2 --- /dev/null +++ b/.nix/coq-overlays/metacoq/default.nix @@ -0,0 +1,88 @@ +{ lib, fetchzip, + mkCoqDerivation, recurseIntoAttrs, single ? false, + coqPackages, coq, equations, version ? null }@args: +with builtins // lib; +let + repo = "metacoq"; + owner = "MetaCoq"; + defaultVersion = with versions; switch coq.coq-version [ + { case = "8.11"; out = "1.0-beta2-8.11"; } + { case = "8.12"; out = "1.0-beta2-8.12"; } + # Do not provide 8.13 because it does not compile with equations 1.3 provided by default (only 1.2.3) + # { case = "8.13"; out = "1.0-beta2-8.13"; } + { case = "8.14"; out = "1.0-8.14"; } + { case = "8.15"; out = "1.0-8.15"; } + { case = "8.16"; out = "1.0-8.16"; } + { case = "dev"; out = "dev"; } + ] null; + release = { + "1.0-beta2-8.11".sha256 = "sha256-I9YNk5Di6Udvq5/xpLSNflfjRyRH8fMnRzbo3uhpXNs="; + "1.0-beta2-8.12".sha256 = "sha256-I8gpmU9rUQJh0qfp5KOgDNscVvCybm5zX4TINxO1TVA="; + "1.0-beta2-8.13".sha256 = "sha256-IC56/lEDaAylUbMCfG/3cqOBZniEQk8jmI053DBO5l8="; + "1.0-8.14".sha256 = "sha256-iRnaNeHt22JqxMNxOGPPycrO9EoCVjusR2s0GfON1y0="; + "1.0-8.15".sha256 = "sha256-8RUC5dHNfLJtJh+IZG4nPTAVC8ZKVh2BHedkzjwLf/k="; + "1.0-8.16".sha256 = "sha256-7rkCAN4PNnMgsgUiiLe2TnAliknN75s2SfjzyKCib/o="; + }; + releaseRev = v: "v${v}"; + + # list of core metacoq packages sorted by dependency order + packages = [ "template-coq" "pcuic" "safechecker" "erasure" "all" ]; + + template-coq = metacoq_ "template-coq"; + + metacoq_ = package: let + metacoq-deps = if package == "single" then [] + else map metacoq_ (head (splitList (pred.equal package) packages)); + pkgpath = if package == "single" then "./" else "./${package}"; + pname = if package == "all" then "metacoq" else "metacoq-${package}"; + pkgallMake = '' + mkdir all + echo "all:" > all/Makefile + echo "install:" >> all/Makefile + '' ; + derivation = (mkCoqDerivation ({ + inherit version pname defaultVersion release releaseRev repo owner; + + mlPlugin = true; + propagatedBuildInputs = [ equations coq.ocamlPackages.zarith ] ++ metacoq-deps; + + patchPhase = '' + patchShebangs ./configure.sh + patchShebangs ./template-coq/update_plugin.sh + patchShebangs ./template-coq/gen-src/to-lower.sh + patchShebangs ./pcuic/clean_extraction.sh + patchShebangs ./safechecker/clean_extraction.sh + patchShebangs ./erasure/clean_extraction.sh + echo "CAMLFLAGS+=-w -60 # Unused module" >> ./safechecker/Makefile.plugin.local + sed -i -e 's/mv $i $newi;/mv $i tmp; mv tmp $newi;/' ./template-coq/gen-src/to-lower.sh ./pcuic/clean_extraction.sh ./safechecker/clean_extraction.sh ./erasure/clean_extraction.sh + '' ; + + configurePhase = optionalString (package == "all") pkgallMake + '' + touch ${pkgpath}/metacoq-config + '' + optionalString (elem package ["safechecker" "erasure"]) '' + echo "-I ${template-coq}/lib/coq/${coq.coq-version}/user-contrib/MetaCoq/Template/" > ${pkgpath}/metacoq-config + '' + optionalString (package == "single") '' + ./configure.sh local + ''; + + preBuild = '' + cd ${pkgpath} + '' ; + + meta = { + homepage = "https://metacoq.github.io/"; + license = licenses.mit; + maintainers = with maintainers; [ cohencyril ]; + }; + } // optionalAttrs (package != "single") + { passthru = genAttrs packages metacoq_; }) + ).overrideAttrs (o: + let requiresOcamlStdlibShims = versionAtLeast o.version "1.0-8.16" || + (o.version == "dev" && (versionAtLeast coq.coq-version "8.16" || coq.coq-version == "dev")) ; + in + { + propagatedBuildInputs = o.propagatedBuildInputs ++ optional requiresOcamlStdlibShims coq.ocamlPackages.stdlib-shims; + }); + in derivation; +in +metacoq_ (if single then "single" else "all") diff --git a/.nix/nixpkgs.nix b/.nix/nixpkgs.nix new file mode 100644 index 000000000..142eb30ba --- /dev/null +++ b/.nix/nixpkgs.nix @@ -0,0 +1,4 @@ +fetchTarball { + url = https://github.com/NixOS/nixpkgs/archive/61fcca66117a68f7189b93ff199c8147754be14c.tar.gz; + sha256 = "1byvy3g4wd6p283z5p6jp8j2fyk1rn7y5a2wis2ja0ws5bymbfv4"; + } diff --git a/.nix/renameNixActions.sh b/.nix/renameNixActions.sh new file mode 100755 index 000000000..9c16e6368 --- /dev/null +++ b/.nix/renameNixActions.sh @@ -0,0 +1,10 @@ +#! /usr/bin/bash + +cd .github/workflows + +for f in $(find . -name 'nix-action*.yml') +do + name=${f%.yml} + sed 's/ubuntu/macos/g' $f > "$name-macos.yml" + mv $f "$name-ubuntu.yml" +done diff --git a/.vscode/metacoq.code-workspace b/.vscode/metacoq.code-workspace index e51f9f5b8..cb90e4fbb 100644 --- a/.vscode/metacoq.code-workspace +++ b/.vscode/metacoq.code-workspace @@ -6,6 +6,7 @@ ], "settings": { "coqtop.args": [ + "-I", "template-coq", // "-bt", get backtraces from Coq on errors "-I", "template-coq/build", "-R", "template-coq/theories", "MetaCoq.Template", diff --git a/DOC.md b/DOC.md index fc525a99f..2fa24e5a3 100644 --- a/DOC.md +++ b/DOC.md @@ -2,7 +2,7 @@ ## Branches and compatibility -**tl;dr** You should do your PRs against [coq-8.11](https://github.com/MetaCoq/metacoq/tree/coq-8.11). +**tl;dr** You should do your PRs against [coq-8.16](https://github.com/MetaCoq/metacoq/tree/coq-8.16). Coq's kernel API is not stable yet, and changes there are reflected in MetaCoq's reified structures, @@ -11,9 +11,8 @@ so we do not ensure any compatibility from version to version. There is one bran The *main branch* or *current branch* is the one which appers when you go on [https://github.com/MetaCoq/metacoq](https://github.com/MetaCoq/metacoq). Currently (unless you are reading the README of an outdated branch), -it is the [coq-8.11](https://github.com/MetaCoq/metacoq/tree/coq-8.11). +it is the [coq-8.16](https://github.com/MetaCoq/metacoq/tree/coq-8.16). You should use it both for usage of MetaCoq and development of MetaCoq. -We should move soon to [coq-8.13](https://github.com/MetaCoq/metacoq/tree/coq-8.12). The [master](https://github.com/MetaCoq/metacoq/tree/master) branch is following Coq's master branch and gets regular updates from the the main development branch which follows the latest @@ -23,29 +22,25 @@ stable release of Coq. +The branches [coq-8.14](https://github.com/MetaCoq/metacoq/tree/coq-8.14), [coq-8.15](https://github.com/MetaCoq/metacoq/tree/coq-8.15) +and [coq-8.16](https://github.com/MetaCoq/metacoq/tree/coq-8.16) are being kept in sync. The branches [coq-8.6](https://github.com/MetaCoq/metacoq/tree/coq-8.6), [coq-8.7](https://github.com/MetaCoq/metacoq/tree/coq-8.7), [coq-8.8](https://github.com/MetaCoq/metacoq/tree/coq-8.8) -and [coq-8.9](https://github.com/MetaCoq/metacoq/tree/coq-8.9), and [coq-8.10](https://github.com/MetaCoq/metacoq/tree/coq-8.10) are frozen. - +and [coq-8.9](https://github.com/MetaCoq/metacoq/tree/coq-8.9), [coq-8.10](https://github.com/MetaCoq/metacoq/tree/coq-8.10), +[coq-8.11](https://github.com/MetaCoq/metacoq/tree/coq-8.11), [coq-8.12](https://github.com/MetaCoq/metacoq/tree/coq-8.12) +and [coq-8.13](https://github.com/MetaCoq/metacoq/tree/coq-8.13) are frozen. ## Program and Equations -MetaCoq relies on `Program` and `Equations` plugins. - -**Important**: We keep the `template-coq` folder not relying on Equations so that -it compiles without external dependency. -That's why first lemmas involving Equations are in `PCUICUtils.v`. - -Besides, try to avoid `Program`. It inserts some JMeq and UIP axioms silently. You can -use `Equations` to do some dependent induction (`dependent induction`, +MetaCoq relies on `Program` and `Equations` plugins, however try to avoid `Program` as it +inserts some JMeq and UIP axioms silently, whereas we try to keep the development axiom-free. +You can use `Equations` to do some dependent induction (`dependent induction`, `dependent destruction`, `depelim`). You may need to add: ``` Require Import Equations.Prop.DepElim. ``` - - ## ident vs. qualid. vs kername MetaCoq uses three types convertible to `string` which have a different intended meaning: @@ -56,7 +51,7 @@ MetaCoq uses three types convertible to `string` which have a different intended - `qualid` is the type of partially qualified names. E.g. `Datatypes.nat` -- `kername` is the type of fully qualified names. +- `kername` is a structured type of fully qualified names. E.g. `Coq.Init.Datatypes.nat` Quoting always produce fully qualified names. On the converse, unquoting allow to @@ -100,10 +95,10 @@ a fresh level when `MetaCoq Strict Unquote Universe Mode` is off. ## Dependency graph between files -Generated on 2020/09/24, sources [there](https://github.com/MetaCoq/metacoq/tree/coq-8.11/dependency-graph). +Generated on 2022/07/01, sources [there](https://github.com/MetaCoq/metacoq/tree/coq-8.16/dependency-graph).
-Dependency graph
@@ -115,6 +110,6 @@ The file `README.md` in https://github.com/MetaCoq/metacoq.github.io is supposed `README.md` in [https://github.com/MetaCoq/metacoq/](https://github.com/MetaCoq/metacoq/). That's why we can't use relative links and have to use absolute ones. -E.g. [INSTALL.md](https://github.com/MetaCoq/metacoq/tree/coq-8.11/INSTALL.md) and not [INSTALL.md](INSTALL.md). +E.g. [INSTALL.md](https://github.com/MetaCoq/metacoq/tree/coq-8.16/INSTALL.md) and not [INSTALL.md](INSTALL.md). Thus, when switching to a new default branch, we have to search and replace the old branch with the new one. diff --git a/INSTALL.md b/INSTALL.md index a550810ef..334ffae8e 100644 --- a/INSTALL.md +++ b/INSTALL.md @@ -72,12 +72,12 @@ To setup a fresh `opam` installation, you might want to create a one yet. You need to use **opam 2** to obtain the right version of `Equations`. - # opam switch create coq.8.14 4.07.1 + # opam switch create coq.8.16 --packages=ocaml-variants.4.13.1+options,ocaml-option-flambda # eval $(opam env) -This creates the `coq.8.14` switch which initially contains only the -basic `OCaml` `4.07.1` compiler, and puts you in the right environment -(check with `ocamlc -v`). +This creates the `coq.8.16` switch which initially contains only the +basic `OCaml` `4.13.1` compiler with the `flambda` option enabled, +and puts you in the right environment (check with `ocamlc -v`). Once in the right switch, you can install `Coq` and the `Equations` package using: diff --git a/Makefile b/Makefile index be78882f1..10d86da31 100644 --- a/Makefile +++ b/Makefile @@ -1,5 +1,5 @@ -all: template-coq pcuic safechecker erasure examples test-suite translations +all: printconf template-coq pcuic safechecker erasure examples test-suite translations -include Makefile.conf @@ -12,8 +12,6 @@ ifeq '$(METACOQ_CONFIG)' 'local' export OCAMLPATH endif -all: printconf template-coq pcuic safechecker erasure examples - .PHONY: printconf all template-coq pcuic erasure install html clean mrproper .merlin test-suite translations printconf: @@ -43,13 +41,15 @@ uninstall: all $(MAKE) -C translations uninstall html: all - "coqdoc" -toc -utf8 -interpolate -l -html \ + "coqdoc" --multi-index -toc -utf8 -html \ + --with-header ./html/resources/header.html --with-footer ./html/resources/footer.html \ -R template-coq/theories MetaCoq.Template \ -R pcuic/theories MetaCoq.PCUIC \ -R safechecker/theories MetaCoq.SafeChecker \ -R erasure/theories MetaCoq.Erasure \ -R translations MetaCoq.Translations \ - -d html */theories/*.v translations/*.v + -R examples MetaCoq.Examples \ + -d html */theories/*.v */theories/*/*.v translations/*.v examples/*.v clean: $(MAKE) -C template-coq clean @@ -119,7 +119,7 @@ ci-local-noclean: ./configure.sh local $(MAKE) all test-suite TIMED=pretty-timed -ci-local: ci-local-noclean +ci-local: ci-local-noclean $(MAKE) clean ci-quick: @@ -128,5 +128,8 @@ ci-quick: ci-opam: # Use -v so that regular output is produced - opam install -v -y . + opam install --with-test -v -y . opam remove -y coq-metacoq coq-metacoq-template + +checktodos: + sh checktodos.sh diff --git a/README.md b/README.md index ece9fd46a..0d2f21e43 100644 --- a/README.md +++ b/README.md @@ -4,7 +4,8 @@ MetaCoq

-[![Build status](https://github.com/MetaCoq/metacoq/workflows/Test%20compilation/badge.svg?branch=coq-8.13)](https://github.com/MetaCoq/metacoq/actions) [![MetaCoq Chat](https://img.shields.io/badge/zulip-join_chat-brightgreen.svg)](https://coq.zulipchat.com) +[![Build status](https://github.com/MetaCoq/metacoq/actions/workflows/build.yml/badge.svg?branch=master)](https://github.com/MetaCoq/metacoq/actions) [![MetaCoq Chat](https://img.shields.io/badge/zulip-join_chat-brightgreen.svg)](https://coq.zulipchat.com) +[![Open in Visual Studio Code](https://img.shields.io/static/v1?logo=visualstudiocode&label=&message=Open%20in%20Visual%20Studio%20Code&labelColor=2c2c32&color=007acc&logoColor=007acc)](https://open.vscode.dev/metacoq/metacoq) MetaCoq is a project formalizing Coq in Coq and providing tools for manipulating Coq terms and developing certified plugins @@ -24,7 +25,7 @@ manipulating Coq terms and developing certified plugins ## Getting started -- You may want to start with a [demo](https://github.com/MetaCoq/metacoq/tree/coq-8.13/examples/demo.v). +- You may want to start with a [demo](https://github.com/MetaCoq/metacoq/tree/master/examples/demo.v). - The current branch [documentation (as light coqdoc files)](https://metacoq.github.io/html/toc.html). @@ -34,13 +35,13 @@ manipulating Coq terms and developing certified plugins ## Installation instructions -See [INSTALL.md](https://github.com/MetaCoq/metacoq/tree/coq-8.13/INSTALL.md) +See [INSTALL.md](https://github.com/MetaCoq/metacoq/tree/master/INSTALL.md) ## Documentation -See [DOC.md](https://github.com/MetaCoq/metacoq/tree/coq-8.13/DOC.md) +See [DOC.md](https://github.com/MetaCoq/metacoq/tree/master/DOC.md) @@ -48,29 +49,38 @@ See [DOC.md](https://github.com/MetaCoq/metacoq/tree/coq-8.13/DOC.md) At the center of this project is the Template-Coq quoting library for Coq. The project currently has a single repository extending -Template-Coq with additional features. Each extension is in dedicated folder. +Template-Coq with additional features. Each extension is in a dedicated folder. +The [dependency graph](https://raw.githubusercontent.com/MetaCoq/metacoq.github.io/master/assets/depgraph-2022-07-01.png) +might be useful to navigate the project. +Statistics: ~150kLoC of Coq, ~30kLoC of OCaml. -### [Template-Coq](https://github.com/MetaCoq/metacoq/tree/coq-8.13/template-coq) +### [Template-Coq](https://github.com/MetaCoq/metacoq/tree/master/template-coq/theories) Template-Coq is a quoting library for [Coq](http://coq.inria.fr). It takes `Coq` terms and constructs a representation of their syntax tree as -a `Coq` inductive data type. The representation is based on the kernel's +an inductive data type. The representation is based on the kernel's term representation. +After importing `MetaCoq.Template.Loader` there are commands `MetaCoq Test Quote t.`, +`MetaCoq Quote Definition name := (t).` and `MetaCoq Quote Recursively Definition name := (t).` as +well as a tactic `quote_term t k`, +where in all cases `t` is a term and `k` a continuation tactic. + In addition to this representation of terms, Template Coq includes: - Reification of the environment structures, for constant and inductive - declarations. + declarations along with their universe structures. -- Denotation of terms and global declarations +- Denotation of terms and global declarations. -- A monad for manipulating global declarations, calling the type +- A monad for querying the environment, manipulating global declarations, calling the type checker, and inserting them in the global environment, in - the style of MTac. + the style of MTac. Monadic programs `p : TemplateMonad A` can be run using `MetaCoq Run p`. -- A formalisation of the expected typing rules reflecting the ones of Coq +- A formalisation of the typing rules reflecting the ones of Coq, covering all of Coq + except eta-expansion and template polymorphism. -### [PCUIC](https://github.com/MetaCoq/metacoq/tree/coq-8.11/pcuic) +### [PCUIC](https://github.com/MetaCoq/metacoq/tree/master/pcuic/theories) PCUIC, the Polymorphic Cumulative Calculus of Inductive Constructions is a cleaned up version of the term language of Coq and its associated @@ -82,21 +92,36 @@ calculus has proofs of standard metatheoretical results: - Confluence of reduction using a notion of parallel reduction -- Context conversion and validity of typing. +- Context cumulativity / conversion and validity of typing. - Subject Reduction (case/cofix reduction excluded) - Principality: every typeable term has a smallest type. +- Bidirectional presentation: an equivalent presentation of the system + that enforces directionality of the typing rules. Strengthening follows + from this presentation. + - Elimination restrictions: the elimination restrictions ensure that singleton elimination (from Prop to Type) is only allowed on singleton inductives in Prop. -### [Safe Checker](https://github.com/MetaCoq/metacoq/tree/coq-8.13/safechecker) +- Canonicity: The weak head normal form of a term of inductive type is a constructor application. + +- Consistency under the assumption of strong normalization + +- Weak call-by-value standardization: Normal forms of terms of first-order inductive type +can be found via weak call-by-value evaluation. + +See the PCUIC [README](https://github.com/MetaCoq/metacoq/tree/master/pcuic/theories/README.md) for +a detailed view of the development. + +### [Safe Checker](https://github.com/MetaCoq/metacoq/tree/master/safechecker/theories) Implementation of a fuel-free and verified reduction machine, conversion checker and type checker for PCUIC. This relies on a postulate of strong normalization of the reduction relation of PCUIC on well-typed terms. +The checker is shown to be correct and complete w.r.t. the PCUIC specification. The extracted safe checker is available in Coq through a new vernacular command: MetaCoq SafeCheck @@ -108,44 +133,74 @@ type-checker, one can use: MetaCoq CoqCheck +This also includes a verified, efficient re-typing procedure (useful in tactics) in +`MetaCoq.SafeChecker.PCUICSafeRetyping`. + +See the SafeChecker [README](https://github.com/MetaCoq/metacoq/tree/master/safechecker/theories/README.md) for +a detailed view of the development. -### [Erasure](https://github.com/MetaCoq/metacoq/tree/coq-8.13/erasure) +### [Erasure](https://github.com/MetaCoq/metacoq/tree/master/erasure/theories) An erasure procedure to untyped lambda-calculus accomplishing the -same as the Extraction plugin of Coq. The extracted safe erasure is -available in Coq through a new vernacular command: +same as the type and proof erasure phase of the Extraction plugin of Coq. +The extracted safe erasure is available in Coq through a new vernacular command: MetaCoq Erase After importing `MetaCoq.Erasure.Loader`. +The erasure pipeline includes verified optimizations to remove lets in constructors, +remove cases on propositional terms, switch to an unguarded fixpoint reduction rule and +transform the higher-order constructor applications to first-order blocks for easier +translation to usual programming languages. See the erasure +[README](https://github.com/MetaCoq/metacoq/tree/master/erasure/theories/README.md) for +a detailed view of the development. -### [Translations](https://github.com/MetaCoq/metacoq/tree/coq-8.13/translations) +### [Translations](https://github.com/MetaCoq/metacoq/tree/master/translations) Examples of translations built on top of this: -- a parametricity plugin in [translations/param_original.v](https://github.com/MetaCoq/metacoq/tree/coq-8.13/translations/param_original.v) +- a parametricity plugin in [translations/param_original.v](https://github.com/MetaCoq/metacoq/tree/master/translations/param_original.v) -- a plugin to negate funext in [translations/times_bool_fun.v](https://github.com/MetaCoq/metacoq/tree/coq-8.13/translations/times_bool_fun.v) +- a plugin to negate functional extensionality in [translations/times_bool_fun.v](https://github.com/MetaCoq/metacoq/tree/master/translations/times_bool_fun.v) ### Examples - An example Coq plugin built on the Template Monad, which can be used to - add a constructor to any inductive type is in [examples/add_constructor.v](https://github.com/MetaCoq/metacoq/tree/coq-8.13/examples/add_constructor.v) + add a constructor to any inductive type is in [examples/add_constructor.v](https://github.com/MetaCoq/metacoq/tree/master/examples/add_constructor.v) -- The test-suite files [test-suite/erasure_test.v](https://github.com/MetaCoq/metacoq/tree/coq-8.13/test-suite/erasure_test.v) - and [test-suite/safechecker_test.v](https://github.com/MetaCoq/metacoq/tree/coq-8.13/test-suite/safechecker_test.v) show example - uses (and current limitations of) the verified checker and erasure. +- An example *extracted* Coq plugin built on the extractable Template Monad, which can be used to + derive lenses associated to a record type is in [test-suite/plugin-demo](https://github.com/MetaCoq/metacoq/tree/master/test-suite/plugin-demo). The plugin runs in OCaml and is a template for writing extracted plugins. +- An example ``constructor`` tactic written using the Template Monad is in [examples/constructor_tac.v](https://github.com/MetaCoq/metacoq/tree/master/examples/constructor_tac.v), + and a more elaborate verified tautology checker is in [examples/tauto.v](https://github.com/MetaCoq/metacoq/tree/master/examples/tauto.v). +- The test-suite files [test-suite/erasure_test.v](https://github.com/MetaCoq/metacoq/tree/master/test-suite/erasure_test.v) + and [test-suite/safechecker_test.v](https://github.com/MetaCoq/metacoq/tree/master/test-suite/safechecker_test.v) show example + uses (and current limitations of) the extracted verified checker and erasure. + +- The [test-suite/self_erasure.v](https://github.com/MetaCoq/metacoq/tree/master/test-suite/self_erasure.v) file checks that erasure + works on the verified typechecking and erasure programs themselves. + +- The test-suite file [test-suite/erasure_live_test.v](https://github.com/MetaCoq/metacoq/tree/master/test-suite/erasure_live_test.v) + shows uses of the verified erasure running *inside* Coq. ## Papers +- ["The Curious Case of Case"](https://sozeau.gitlabpages.inria.fr/www/research/publications/The_Curious_Case_of_Case-WITS22-220122.pdf) Matthieu Sozeau, Meven Lennon-Bertrand and Yannick Forster. WITS 2022 presentation, Philadelphia. + This presents the challenges around the representation of cases in Coq and PCUIC. + +- ["Bidirectional Typing for the Calculus of Inductive Constructions"](https://www.meven.ac/category/phd-thesis.html) Meven Lennon-Bertrand, PhD thesis, June 2022. + Part 2 describes in detail the bidirectional variant of typing and its use to verify correctness and completeness of the type checker. + - ["Coq Coq Correct! Verification of Type Checking and Erasure for Coq, in Coq"](https://metacoq.github.io/coqcoqcorrect) Matthieu Sozeau, Simon Boulier, Yannick Forster, Nicolas Tabareau and Théo Winterhalter. POPL 2020, New Orleans. +- ["Formalisation and meta-theory of type theory"](https://theowinterhalter.github.io/#phd) Théo Winterhalter, PhD thesis, September 2020. + Part 3 describes in detail the verified reduction, conversion and type checker. + - ["Coq Coq Codet! Towards a Verified Toolchain for Coq in MetaCoq"](http://www.irif.fr/~sozeau/research/publications/Coq_Coq_Codet-CoqWS19.pdf) Matthieu Sozeau, Simon Boulier, Yannick Forster, Nicolas Tabareau and @@ -173,8 +228,6 @@ Examples of translations built on top of this: - The system was presented at [Coq'PL 2018](https://popl18.sigplan.org/event/coqpl-2018-typed-template-coq) - - ## Team & Credits

@@ -194,8 +247,17 @@ alt="Cyril Cohen" width="150px"/> src="https://github.com/MetaCoq/metacoq.github.io/raw/master/assets/yannick-forster.jpg" alt="Yannick Forster" width="150px"/>
+ +
+alt="Gregory Malecha" width="150px"/> +
Matthieu Sozeau @@ -205,6 +267,8 @@ alt="Nicolas Tabareau" width="150px"/> Théo Winterhalter +
+ MetaCoq is developed by (left to right) Abhishek Anand, @@ -212,7 +276,10 @@ MetaCoq is developed by (left to right) Simon Boulier, Cyril Cohen, Yannick Forster, +Meven Lennon-Bertrand, +Kenji Maillard, Gregory Malecha, +Jakob Botsch Nielsen, Matthieu Sozeau, Nicolas Tabareau and Théo Winterhalter. @@ -224,10 +291,12 @@ Copyright (c) 2014-2022 Gregory Malecha Copyright (c) 2015-2022 Abhishek Anand, Matthieu Sozeau Copyright (c) 2017-2022 Simon Boulier, Nicolas Tabareau, Cyril Cohen Copyright (c) 2018-2022 Danil Annenkov, Yannick Forster, Théo Winterhalter +Copyright (c) 2020-2022 Jakob Botsch Nielsen, Meven Lennon-Bertrand +Copyright (c) 2022 Kenji Maillard ``` This software is distributed under the terms of the MIT license. -See [LICENSE](https://github.com/MetaCoq/metacoq/tree/coq-8.13/LICENSE) for details. +See [LICENSE](https://github.com/MetaCoq/metacoq/tree/master/LICENSE) for details. diff --git a/RELEASING.md b/RELEASING.md index 91e4c35e3..4d2613a6d 100644 --- a/RELEASING.md +++ b/RELEASING.md @@ -1 +1,2 @@ - Change the "version:" fields in opam files. + diff --git a/checktodos.sh b/checktodos.sh new file mode 100755 index 000000000..f4eef771e --- /dev/null +++ b/checktodos.sh @@ -0,0 +1,21 @@ +#!/bin/bash + +if [[ $(git grep -c todo | grep theories) = template-coq/theories/utils/MCUtils.v:3 ]] +then + echo "No todos found" + if [[ $(git grep -c Admitted | grep theories) = "" ]] + then + echo "No Admitted results found" + exit 0 + else + echo "Found Admitted results:" + git grep -c Admitted | grep theories + exit 1 + fi +else + echo "Found todos:" + git grep -c todo | grep theories | grep -v "template-coq/theories/utils/MCUtils.v:3" + exit 1 +fi +endef + diff --git a/coq-metacoq-erasure.opam b/coq-metacoq-erasure.opam index 88a9ead2e..1744dbe46 100644 --- a/coq-metacoq-erasure.opam +++ b/coq-metacoq-erasure.opam @@ -1,22 +1,26 @@ opam-version: "2.0" -version: "8.14.dev" +version: "dev" maintainer: "matthieu.sozeau@inria.fr" homepage: "https://metacoq.github.io/metacoq" -dev-repo: "git+https://github.com/MetaCoq/metacoq.git#coq-8.11" +dev-repo: "git+https://github.com/MetaCoq/metacoq.git#coq-8.16" bug-reports: "https://github.com/MetaCoq/metacoq/issues" authors: ["Abhishek Anand " + "Danil Annenkov " "Simon Boulier " "Cyril Cohen " "Yannick Forster " "Fabian Kunze " + "Meven Lennon-Bertrand " + "Kenji Maillard " "Gregory Malecha " + "Jakob Botsch Nielsen " "Matthieu Sozeau " "Nicolas Tabareau " "Théo Winterhalter " ] license: "MIT" build: [ - ["sh" "./configure.sh"] + ["bash" "./configure.sh"] [make "-j" "%{jobs}%" "-C" "erasure"] ] install: [ diff --git a/coq-metacoq-pcuic.opam b/coq-metacoq-pcuic.opam index fd4df7087..7095a2542 100644 --- a/coq-metacoq-pcuic.opam +++ b/coq-metacoq-pcuic.opam @@ -1,22 +1,26 @@ opam-version: "2.0" -version: "8.14.dev" +version: "dev" maintainer: "matthieu.sozeau@inria.fr" homepage: "https://metacoq.github.io/metacoq" -dev-repo: "git+https://github.com/MetaCoq/metacoq.git#coq-8.11" +dev-repo: "git+https://github.com/MetaCoq/metacoq.git#coq-8.16" bug-reports: "https://github.com/MetaCoq/metacoq/issues" authors: ["Abhishek Anand " + "Danil Annenkov " "Simon Boulier " "Cyril Cohen " "Yannick Forster " "Fabian Kunze " + "Meven Lennon-Bertrand " + "Kenji Maillard " "Gregory Malecha " + "Jakob Botsch Nielsen " "Matthieu Sozeau " "Nicolas Tabareau " "Théo Winterhalter " ] license: "MIT" build: [ - ["sh" "./configure.sh"] + ["bash" "./configure.sh"] [make "-j" "%{jobs}%" "-C" "pcuic"] ] install: [ diff --git a/coq-metacoq-safechecker.opam b/coq-metacoq-safechecker.opam index 5105bdc62..488afa79f 100644 --- a/coq-metacoq-safechecker.opam +++ b/coq-metacoq-safechecker.opam @@ -1,22 +1,26 @@ opam-version: "2.0" -version: "8.14.dev" +version: "dev" maintainer: "matthieu.sozeau@inria.fr" homepage: "https://metacoq.github.io/metacoq" -dev-repo: "git+https://github.com/MetaCoq/metacoq.git#coq-8.11" +dev-repo: "git+https://github.com/MetaCoq/metacoq.git#coq-8.16" bug-reports: "https://github.com/MetaCoq/metacoq/issues" authors: ["Abhishek Anand " + "Danil Annenkov " "Simon Boulier " "Cyril Cohen " "Yannick Forster " "Fabian Kunze " + "Meven Lennon-Bertrand " + "Kenji Maillard " "Gregory Malecha " + "Jakob Botsch Nielsen " "Matthieu Sozeau " "Nicolas Tabareau " "Théo Winterhalter " ] license: "MIT" build: [ - ["sh" "./configure.sh"] + ["bash" "./configure.sh"] [make "-j" "%{jobs}%" "-C" "safechecker"] ] install: [ diff --git a/coq-metacoq-template.opam b/coq-metacoq-template.opam index bf310767b..027720d03 100644 --- a/coq-metacoq-template.opam +++ b/coq-metacoq-template.opam @@ -1,15 +1,19 @@ opam-version: "2.0" -version: "8.14.dev" +version: "dev" maintainer: "matthieu.sozeau@inria.fr" homepage: "https://metacoq.github.io/metacoq" -dev-repo: "git+https://github.com/MetaCoq/metacoq.git#master" +dev-repo: "git+https://github.com/MetaCoq/metacoq.git#coq-8.16" bug-reports: "https://github.com/MetaCoq/metacoq/issues" authors: ["Abhishek Anand " + "Danil Annenkov " "Simon Boulier " "Cyril Cohen " "Yannick Forster " "Fabian Kunze " + "Meven Lennon-Bertrand " + "Kenji Maillard " "Gregory Malecha " + "Jakob Botsch Nielsen " "Matthieu Sozeau " "Nicolas Tabareau " "Théo Winterhalter " @@ -24,7 +28,6 @@ install: [ ] depends: [ "stdlib-shims" - "ocaml" {>= "4.07.1"} "coq" { = "dev" } "coq-equations" { = "dev" } ] diff --git a/coq-metacoq-translations.opam b/coq-metacoq-translations.opam index 3fcbaa469..36e6f80f9 100644 --- a/coq-metacoq-translations.opam +++ b/coq-metacoq-translations.opam @@ -1,18 +1,26 @@ opam-version: "2.0" -version: "8.14.dev" +version: "dev" maintainer: "matthieu.sozeau@inria.fr" homepage: "https://metacoq.github.io/metacoq" -dev-repo: "git+https://github.com/MetaCoq/metacoq.git#coq-8.11" +dev-repo: "git+https://github.com/MetaCoq/metacoq.git#coq-8.16" bug-reports: "https://github.com/MetaCoq/metacoq/issues" -authors: ["Simon Boulier " +authors: ["Abhishek Anand " + "Danil Annenkov " + "Simon Boulier " "Cyril Cohen " + "Yannick Forster " + "Fabian Kunze " + "Meven Lennon-Bertrand " + "Kenji Maillard " + "Gregory Malecha " + "Jakob Botsch Nielsen " "Matthieu Sozeau " "Nicolas Tabareau " "Théo Winterhalter " ] license: "MIT" build: [ - ["sh" "./configure.sh"] + ["bash" "./configure.sh"] [make "-j" "%{jobs}%" "-C" "translations"] ] install: [ diff --git a/coq-metacoq.opam b/coq-metacoq.opam index 8df96a6af..cf0568455 100644 --- a/coq-metacoq.opam +++ b/coq-metacoq.opam @@ -1,15 +1,19 @@ opam-version: "2.0" -version: "8.14.dev" +version: "dev" maintainer: "matthieu.sozeau@inria.fr" homepage: "https://metacoq.github.io/metacoq" -dev-repo: "git+https://github.com/MetaCoq/metacoq.git#coq-8.11" +dev-repo: "git+https://github.com/MetaCoq/metacoq.git#coq-8.16" bug-reports: "https://github.com/MetaCoq/metacoq/issues" authors: ["Abhishek Anand " + "Danil Annenkov " "Simon Boulier " "Cyril Cohen " "Yannick Forster " "Fabian Kunze " + "Meven Lennon-Bertrand " + "Kenji Maillard " "Gregory Malecha " + "Jakob Botsch Nielsen " "Matthieu Sozeau " "Nicolas Tabareau " "Théo Winterhalter " @@ -23,7 +27,7 @@ depends: [ "coq-metacoq-translations" {= version} ] build: [ - ["sh" "./configure.sh" ] {with-test} + ["bash" "./configure.sh" ] {with-test} [make "-C" "examples" ] {with-test} [make "-C" "test-suite" ] {with-test} ] diff --git a/default.nix b/default.nix new file mode 100644 index 000000000..6fda2e8b2 --- /dev/null +++ b/default.nix @@ -0,0 +1,13 @@ +{ config ? {}, withEmacs ? false, print-env ? false, do-nothing ? false, + update-nixpkgs ? false, ci-matrix ? false, + override ? {}, ocaml-override ? {}, global-override ? {}, + bundle ? null, job ? null, inNixShell ? null, src ? ./., +}@args: +let auto = fetchGit { + url = "https://github.com/coq-community/coq-nix-toolbox.git"; + allRefs = true ; + # ref = "master"; + rev = import .nix/coq-nix-toolbox.nix; +}; +in +import auto ({inherit src;} // args) diff --git a/dependency-graph/depgraph-2022-07-01.dot b/dependency-graph/depgraph-2022-07-01.dot new file mode 100644 index 000000000..29de49597 --- /dev/null +++ b/dependency-graph/depgraph-2022-07-01.dot @@ -0,0 +1,540 @@ +digraph dependencies { +node[style=filled] +"safechecker/Extraction"[label="Extraction", color=paleturquoise1] +"safechecker/PCUICConsistency"[label="PCUICConsistency", color=paleturquoise1] +"safechecker/PCUICRetypingEnvIrrelevance"[label="PCUICRetypingEnvIrrelevance", color=paleturquoise1] +"safechecker/PCUICSafeRetyping"[label="PCUICSafeRetyping", color=paleturquoise1] +"safechecker/SafeTemplateChecker"[label="SafeTemplateChecker", color=paleturquoise1] +"safechecker/PCUICWfEnvImpl"[label="PCUICWfEnvImpl", color=paleturquoise1] +"safechecker/PCUICSafeChecker"[label="PCUICSafeChecker", color=paleturquoise1] +"safechecker/PCUICTypeChecker"[label="PCUICTypeChecker", color=paleturquoise1] +"safechecker/PCUICWfReduction"[label="PCUICWfReduction", color=paleturquoise1] +"safechecker/PCUICSafeConversion"[label="PCUICSafeConversion", color=paleturquoise1] +"safechecker/PCUICSafeReduce"[label="PCUICSafeReduce", color=paleturquoise1] +"safechecker/PCUICWfEnv"[label="PCUICWfEnv", color=paleturquoise1] +"safechecker/PCUICErrors"[label="PCUICErrors", color=paleturquoise1] +"safechecker/PCUICEqualityDec"[label="PCUICEqualityDec", color=paleturquoise1] +"pcuic/Bidirectional/BDToPCUIC" -> "pcuic/Bidirectional/BDFromPCUIC" +"pcuic/Bidirectional/BDTyping" -> "pcuic/Bidirectional/BDToPCUIC" +"pcuic/PCUICSR" -> "pcuic/Bidirectional/BDToPCUIC" +"pcuic/PCUICCumulativity" -> "pcuic/Bidirectional/BDTyping" +"pcuic/PCUICTyping" -> "pcuic/Bidirectional/BDTyping" +"pcuic/Bidirectional/BDFromPCUIC" -> "pcuic/Bidirectional/BDUnique" +"pcuic/PCUICGlobalEnv" -> "pcuic/Conversion/PCUICClosedConv" +"pcuic/PCUICReduction" -> "pcuic/Conversion/PCUICClosedConv" +"pcuic/PCUICWeakeningEnv" -> "pcuic/Conversion/PCUICClosedConv" +"pcuic/Conversion/PCUICUnivSubstitutionConv" -> "pcuic/Conversion/PCUICInstConv" +"pcuic/Typing/PCUICWeakeningTyp" -> "pcuic/Conversion/PCUICInstConv" +"pcuic/Conversion/PCUICRenameConv" -> "pcuic/Conversion/PCUICOnFreeVarsConv" +"pcuic/Syntax/PCUICViews" -> "pcuic/Conversion/PCUICRenameConv" +"pcuic/Typing/PCUICClosedTyp" -> "pcuic/Conversion/PCUICRenameConv" +"pcuic/PCUICCumulativity" -> "pcuic/Conversion/PCUICUnivSubstitutionConv" +"pcuic/PCUICGuardCondition" -> "pcuic/Conversion/PCUICUnivSubstitutionConv" +"pcuic/PCUICWeakeningEnv" -> "pcuic/Conversion/PCUICUnivSubstitutionConv" +"pcuic/Conversion/PCUICRenameConv" -> "pcuic/Conversion/PCUICWeakeningConv" +"pcuic/PCUICCumulativity" -> "pcuic/Conversion/PCUICWeakeningEnvConv" +"pcuic/PCUICCumulativitySpec" -> "pcuic/Conversion/PCUICWeakeningEnvConv" +"pcuic/PCUICWeakeningEnv" -> "pcuic/Conversion/PCUICWeakeningEnvConv" +"pcuic/PCUICInductiveInversion" -> "pcuic/PCUICAlpha" +"pcuic/PCUICContexts" -> "pcuic/PCUICArities" +"pcuic/PCUICInversion" -> "pcuic/PCUICArities" +"pcuic/PCUICWfUniverses" -> "pcuic/PCUICArities" +"pcuic/utils/PCUICPrimitive" -> "pcuic/PCUICAst" +"pcuic/PCUICReduction" -> "pcuic/PCUICCSubst" +"pcuic/PCUICTyping" -> "pcuic/PCUICCSubst" +"pcuic/PCUICElimination" -> "pcuic/PCUICCanonicity" +"pcuic/PCUICWcbvEval" -> "pcuic/PCUICCanonicity" +"pcuic/PCUICEquality" -> "pcuic/PCUICCasesContexts" +"pcuic/PCUICSigmaCalculus" -> "pcuic/PCUICCasesContexts" +"pcuic/PCUICParallelReductionConfluence" -> "pcuic/PCUICConfluence" +"pcuic/PCUICRedTypeIrrelevance" -> "pcuic/PCUICConfluence" +"pcuic/PCUICWellScopedCumulativity" -> "pcuic/PCUICContextConversion" +"pcuic/PCUICSubstitution" -> "pcuic/PCUICContextReduction" +"pcuic/Syntax/PCUICLiftSubst" -> "pcuic/PCUICContextSubst" +"pcuic/PCUICGeneration" -> "pcuic/PCUICContexts" +"pcuic/PCUICSubstitution" -> "pcuic/PCUICContexts" +"pcuic/Typing/PCUICUnivSubstitutionTyp" -> "pcuic/PCUICContexts" +"pcuic/PCUICNormal" -> "pcuic/PCUICConvCumInversion" +"pcuic/PCUICContextConversion" -> "pcuic/PCUICConversion" +"pcuic/PCUICSafeLemmata" -> "pcuic/PCUICCumulProp" +"pcuic/PCUICReduction" -> "pcuic/PCUICCumulativity" +"pcuic/Syntax/PCUICOnFreeVars" -> "pcuic/PCUICCumulativitySpec" +"pcuic/utils/PCUICOnOne" -> "pcuic/PCUICCumulativitySpec" +"pcuic/PCUICCumulProp" -> "pcuic/PCUICElimination" +"pcuic/Syntax/PCUICLiftSubst" -> "pcuic/PCUICEquality" +"pcuic/Syntax/PCUICReflect" -> "pcuic/PCUICEquality" +"pcuic/PCUICTyping" -> "pcuic/PCUICGeneration" +"pcuic/PCUICTyping" -> "pcuic/PCUICGlobalEnv" +"pcuic/PCUICReduction" -> "pcuic/PCUICGuardCondition" +"pcuic/Syntax/PCUICInstDef" -> "pcuic/PCUICGuardCondition" +"pcuic/Syntax/PCUICNamelessDef" -> "pcuic/PCUICGuardCondition" +"pcuic/PCUICValidity" -> "pcuic/PCUICInductiveInversion" +"pcuic/PCUICSpine" -> "pcuic/PCUICInductives" +"pcuic/PCUICConversion" -> "pcuic/PCUICInversion" +"pcuic/PCUICSR" -> "pcuic/PCUICNormal" +"template-coq/UnivSubst" -> "pcuic/PCUICNormal" +"pcuic/PCUICSubstitution" -> "pcuic/PCUICParallelReduction" +"pcuic/Syntax/PCUICDepth" -> "pcuic/PCUICParallelReduction" +"pcuic/PCUICParallelReduction" -> "pcuic/PCUICParallelReductionConfluence" +"pcuic/PCUICCumulProp" -> "pcuic/PCUICPrincipality" +"pcuic/PCUICGlobalEnv" -> "pcuic/PCUICProgram" +"template-coq/EnvMap" -> "pcuic/PCUICProgram" +"pcuic/PCUICContextReduction" -> "pcuic/PCUICRedTypeIrrelevance" +"pcuic/Syntax/PCUICClosed" -> "pcuic/PCUICReduction" +"pcuic/Syntax/PCUICPosition" -> "pcuic/PCUICReduction" +"pcuic/Syntax/PCUICTactics" -> "pcuic/PCUICReduction" +"pcuic/utils/PCUICOnOne" -> "pcuic/PCUICReduction" +"pcuic/PCUICSafeLemmata" -> "pcuic/PCUICSN" +"pcuic/PCUICAlpha" -> "pcuic/PCUICSR" +"pcuic/PCUICNormal" -> "pcuic/PCUICSafeLemmata" +"pcuic/Syntax/PCUICLiftSubst" -> "pcuic/PCUICSigmaCalculus" +"pcuic/PCUICArities" -> "pcuic/PCUICSpine" +"pcuic/PCUICCasesContexts" -> "pcuic/PCUICSpine" +"pcuic/Typing/PCUICContextConversionTyp" -> "pcuic/PCUICSpine" +"pcuic/Typing/PCUICInstTyp" -> "pcuic/PCUICSubstitution" +"pcuic/PCUICCumulativitySpec" -> "pcuic/PCUICTyping" +"pcuic/Syntax/PCUICPosition" -> "pcuic/PCUICTyping" +"pcuic/utils/PCUICUtils" -> "pcuic/PCUICTyping" +"pcuic/PCUICInductives" -> "pcuic/PCUICValidity" +"pcuic/PCUICCSubst" -> "pcuic/PCUICWcbvEval" +"pcuic/Typing/PCUICClosedTyp" -> "pcuic/PCUICWcbvEval" +"pcuic/utils/PCUICAstUtils" -> "pcuic/PCUICWeakeningEnv" +"template-coq/utils/LibHypsNaming" -> "pcuic/PCUICWeakeningEnv" +"pcuic/PCUICConfluence" -> "pcuic/PCUICWellScopedCumulativity" +"pcuic/PCUICGeneration" -> "pcuic/PCUICWfUniverses" +"pcuic/PCUICSubstitution" -> "pcuic/PCUICWfUniverses" +"pcuic/utils/PCUICAstUtils" -> "pcuic/Syntax/PCUICCases" +"pcuic/PCUICSigmaCalculus" -> "pcuic/Syntax/PCUICClosed" +"pcuic/Syntax/PCUICUnivSubst" -> "pcuic/Syntax/PCUICClosed" +"pcuic/Syntax/PCUICInduction" -> "pcuic/Syntax/PCUICDepth" +"pcuic/Syntax/PCUICCases" -> "pcuic/Syntax/PCUICInduction" +"template-coq/utils/LibHypsNaming" -> "pcuic/Syntax/PCUICInduction" +"pcuic/Syntax/PCUICRenameDef" -> "pcuic/Syntax/PCUICInstDef" +"pcuic/Syntax/PCUICInduction" -> "pcuic/Syntax/PCUICLiftSubst" +"pcuic/PCUICTyping" -> "pcuic/Syntax/PCUICNamelessDef" +"pcuic/PCUICEquality" -> "pcuic/Syntax/PCUICOnFreeVars" +"pcuic/Syntax/PCUICClosed" -> "pcuic/Syntax/PCUICOnFreeVars" +"template-coq/utils/MCPred" -> "pcuic/Syntax/PCUICOnFreeVars" +"pcuic/PCUICEquality" -> "pcuic/Syntax/PCUICPosition" +"pcuic/Syntax/PCUICInduction" -> "pcuic/Syntax/PCUICReflect" +"pcuic/PCUICTyping" -> "pcuic/Syntax/PCUICRenameDef" +"pcuic/PCUICSigmaCalculus" -> "pcuic/Syntax/PCUICTactics" +"pcuic/Syntax/PCUICInduction" -> "pcuic/Syntax/PCUICUnivSubst" +"pcuic/Syntax/PCUICReflect" -> "pcuic/Syntax/PCUICViews" +"pcuic/utils/PCUICOnOne" -> "pcuic/Syntax/PCUICViews" +"pcuic/PCUICProgram" -> "pcuic/TemplateToPCUIC" +"template-coq/TemplateProgram" -> "pcuic/TemplateToPCUIC" +"pcuic/Conversion/PCUICClosedConv" -> "pcuic/Typing/PCUICClosedTyp" +"pcuic/Typing/PCUICWeakeningEnvTyp" -> "pcuic/Typing/PCUICClosedTyp" +"pcuic/PCUICConversion" -> "pcuic/Typing/PCUICContextConversionTyp" +"pcuic/Conversion/PCUICInstConv" -> "pcuic/Typing/PCUICInstTyp" +"pcuic/Conversion/PCUICOnFreeVarsConv" -> "pcuic/Typing/PCUICRenameTyp" +"pcuic/Conversion/PCUICUnivSubstitutionConv" -> "pcuic/Typing/PCUICUnivSubstitutionTyp" +"pcuic/Typing/PCUICWeakeningEnvTyp" -> "pcuic/Typing/PCUICUnivSubstitutionTyp" +"pcuic/Conversion/PCUICWeakeningEnvConv" -> "pcuic/Typing/PCUICWeakeningEnvTyp" +"pcuic/PCUICContextSubst" -> "pcuic/Typing/PCUICWeakeningEnvTyp" +"pcuic/PCUICGlobalEnv" -> "pcuic/Typing/PCUICWeakeningEnvTyp" +"pcuic/PCUICGuardCondition" -> "pcuic/Typing/PCUICWeakeningEnvTyp" +"pcuic/Conversion/PCUICWeakeningConv" -> "pcuic/Typing/PCUICWeakeningTyp" +"pcuic/Typing/PCUICRenameTyp" -> "pcuic/Typing/PCUICWeakeningTyp" +"pcuic/utils/PCUICSize" -> "pcuic/utils/PCUICAstUtils" +"template-coq/common/uGraph" -> "pcuic/utils/PCUICAstUtils" +"pcuic/PCUICAst" -> "pcuic/utils/PCUICOnOne" +"pcuic/utils/PCUICAstUtils" -> "pcuic/utils/PCUICPretty" +"template-coq/EnvironmentTyping" -> "pcuic/utils/PCUICPrimitive" +"template-coq/Reflect" -> "pcuic/utils/PCUICPrimitive" +"pcuic/PCUICAst" -> "pcuic/utils/PCUICSize" +"template-coq/config" -> "pcuic/utils/PCUICUtils" +"template-coq/utils" -> "pcuic/utils/PCUICUtils" +"template-coq/EnvironmentTyping" -> "template-coq/Ast" +"template-coq/Ast" -> "template-coq/AstUtils" +"template-coq/Kernames" -> "template-coq/BasicAst" +"template-coq/Reflect" -> "template-coq/EnvMap" +"template-coq/common/uGraph" -> "template-coq/EnvMap" +"template-coq/utils/canonicaltries/CanonicalTries" -> "template-coq/EnvMap" +"template-coq/Universes" -> "template-coq/Environment" +"template-coq/Environment" -> "template-coq/EnvironmentTyping" +"template-coq/Typing" -> "template-coq/EtaExpand" +"template-coq/common/uGraph" -> "template-coq/EtaExpand" +"template-coq/AstUtils" -> "template-coq/Induction" +"template-coq/utils" -> "template-coq/Kernames" +"template-coq/WfAst" -> "template-coq/LiftSubst" +"template-coq/Universes" -> "template-coq/Reflect" +"template-coq/Induction" -> "template-coq/ReflectAst" +"template-coq/Reflect" -> "template-coq/ReflectAst" +"template-coq/EtaExpand" -> "template-coq/TemplateProgram" +"template-coq/Transform" -> "template-coq/TemplateProgram" +"template-coq/WcbvEval" -> "template-coq/TemplateProgram" +"template-coq/Induction" -> "template-coq/TermEquality" +"template-coq/Reflect" -> "template-coq/TermEquality" +"template-coq/utils" -> "template-coq/Transform" +"template-coq/LiftSubst" -> "template-coq/Typing" +"template-coq/ReflectAst" -> "template-coq/Typing" +"template-coq/TermEquality" -> "template-coq/Typing" +"template-coq/Typing" -> "template-coq/TypingWf" +"template-coq/Induction" -> "template-coq/UnivSubst" +"template-coq/BasicAst" -> "template-coq/Universes" +"template-coq/config" -> "template-coq/Universes" +"template-coq/TypingWf" -> "template-coq/WcbvEval" +"template-coq/UnivSubst" -> "template-coq/WfAst" +"template-coq/Universes" -> "template-coq/common/uGraph" +"template-coq/utils/wGraph" -> "template-coq/common/uGraph" +"template-coq/utils/All_Forall" -> "template-coq/monad_utils" +"template-coq/monad_utils" -> "template-coq/utils" +"template-coq/utils/MCUtils" -> "template-coq/utils" +"template-coq/utils/MCOption" -> "template-coq/utils/All_Forall" +"template-coq/utils/MCSquash" -> "template-coq/utils/All_Forall" +"template-coq/utils/ByteCompare" -> "template-coq/utils/ByteCompareSpec" +"template-coq/utils/MCCompare" -> "template-coq/utils/ByteCompareSpec" +"template-coq/utils/ReflectEq" -> "template-coq/utils/ByteCompareSpec" +"template-coq/utils/MCPrelude" -> "template-coq/utils/MCList" +"template-coq/utils/MCRelations" -> "template-coq/utils/MCList" +"template-coq/utils/ReflectEq" -> "template-coq/utils/MCList" +"template-coq/utils/MCList" -> "template-coq/utils/MCOption" +"template-coq/utils/MCProd" -> "template-coq/utils/MCOption" +"template-coq/utils/MCReflect" -> "template-coq/utils/MCOption" +"template-coq/utils/MCOption" -> "template-coq/utils/MCPred" +"template-coq/utils/MCPrelude" -> "template-coq/utils/MCReflect" +"template-coq/utils/bytestring" -> "template-coq/utils/MCString" +"template-coq/utils/All_Forall" -> "template-coq/utils/MCUtils" +"template-coq/utils/MCArith" -> "template-coq/utils/MCUtils" +"template-coq/utils/MCEquality" -> "template-coq/utils/MCUtils" +"template-coq/utils/MCString" -> "template-coq/utils/MCUtils" +"template-coq/utils/ByteCompareSpec" -> "template-coq/utils/bytestring" +"template-coq/utils/canonicaltries/String2pos" -> "template-coq/utils/canonicaltries/CanonicalTries" +"template-coq/utils/MCUtils" -> "template-coq/utils/wGraph" +"template-coq/utils/MC_ExtrOCamlZPosInt" -> "safechecker/Extraction" +"safechecker/SafeTemplateChecker" -> "safechecker/Extraction" +"safechecker/PCUICSafeReduce" -> "safechecker/PCUICConsistency" +"safechecker/PCUICWfEnvImpl" -> "safechecker/PCUICConsistency" +"pcuic/PCUICWfUniverses" -> "safechecker/PCUICEqualityDec" +"pcuic/utils/PCUICPretty" -> "safechecker/PCUICErrors" +"safechecker/PCUICSafeRetyping" -> "safechecker/PCUICRetypingEnvIrrelevance" +"safechecker/PCUICTypeChecker" -> "safechecker/PCUICSafeChecker" +"pcuic/PCUICConvCumInversion" -> "safechecker/PCUICSafeConversion" +"pcuic/PCUICPrincipality" -> "safechecker/PCUICSafeConversion" +"safechecker/PCUICEqualityDec" -> "safechecker/PCUICSafeConversion" +"safechecker/PCUICSafeReduce" -> "safechecker/PCUICSafeConversion" +"pcuic/PCUICCanonicity" -> "safechecker/PCUICSafeReduce" +"safechecker/PCUICErrors" -> "safechecker/PCUICSafeReduce" +"safechecker/PCUICWfReduction" -> "safechecker/PCUICSafeReduce" +"pcuic/Bidirectional/BDUnique" -> "safechecker/PCUICSafeRetyping" +"pcuic/PCUICConvCumInversion" -> "safechecker/PCUICSafeRetyping" +"safechecker/PCUICSafeReduce" -> "safechecker/PCUICSafeRetyping" +"pcuic/Bidirectional/BDUnique" -> "safechecker/PCUICTypeChecker" +"safechecker/PCUICSafeConversion" -> "safechecker/PCUICTypeChecker" +"pcuic/PCUICSafeLemmata" -> "safechecker/PCUICWfEnv" +"template-coq/EnvMap" -> "safechecker/PCUICWfEnv" +"safechecker/PCUICEqualityDec" -> "safechecker/PCUICWfEnvImpl" +"safechecker/PCUICWfEnv" -> "safechecker/PCUICWfEnvImpl" +"pcuic/PCUICSN" -> "safechecker/PCUICWfReduction" +"pcuic/utils/PCUICPretty" -> "safechecker/PCUICWfReduction" +"safechecker/PCUICWfEnv" -> "safechecker/PCUICWfReduction" +"pcuic/TemplateToPCUIC" -> "safechecker/SafeTemplateChecker" +"safechecker/PCUICSafeChecker" -> "safechecker/SafeTemplateChecker" +"safechecker/PCUICWfEnvImpl" -> "safechecker/SafeTemplateChecker" +"template-coq/Extraction"[label="Extraction", color=aquamarine] +"template-coq/Constants"[label="Constants", color=aquamarine] +"template-coq/monad_utils"[label="monad_utils", color=aquamarine] +"template-coq/TemplateMonad/Extractable"[label="Extractable", color=aquamarine] +"template-coq/TemplateMonad/Core"[label="Core", color=aquamarine] +"template-coq/TemplateMonad/Common"[label="Common", color=aquamarine] +"template-coq/TemplateMonad"[label="TemplateMonad", color=aquamarine] +"template-coq/TemplateProgram"[label="TemplateProgram", color=aquamarine] +"template-coq/EtaExpand"[label="EtaExpand", color=aquamarine] +"template-coq/Checker"[label="Checker", color=aquamarine] +"template-coq/WcbvEval"[label="WcbvEval", color=aquamarine] +"template-coq/Normal"[label="Normal", color=aquamarine] +"template-coq/TypingWf"[label="TypingWf", color=aquamarine] +"template-coq/Reduction"[label="Reduction", color=aquamarine] +"template-coq/Typing"[label="Typing", color=aquamarine] +"template-coq/TermEquality"[label="TermEquality", color=aquamarine] +"template-coq/Pretty"[label="Pretty", color=aquamarine] +"template-coq/UnivSubst"[label="UnivSubst", color=aquamarine] +"template-coq/LiftSubst"[label="LiftSubst", color=aquamarine] +"template-coq/WfAst"[label="WfAst", color=aquamarine] +"template-coq/EnvironmentTyping"[label="EnvironmentTyping", color=aquamarine] +"template-coq/Induction"[label="Induction", color=aquamarine] +"template-coq/EnvMap"[label="EnvMap", color=aquamarine] +"template-coq/ReflectAst"[label="ReflectAst", color=aquamarine] +"template-coq/Reflect"[label="Reflect", color=aquamarine] +"template-coq/AstUtils"[label="AstUtils", color=aquamarine] +"template-coq/Ast"[label="Ast", color=aquamarine] +"template-coq/Environment"[label="Environment", color=aquamarine] +"template-coq/BasicAst"[label="BasicAst", color=aquamarine] +"template-coq/Universes"[label="Universes", color=aquamarine] +"template-coq/Kernames"[label="Kernames", color=aquamarine] +"template-coq/config"[label="config", color=aquamarine] +"template-coq/utils"[label="utils", color=aquamarine] +"template-coq/Transform"[label="Transform", color=aquamarine] +"template-coq/common/uGraph"[label="uGraph", color=aquamarine] +"template-coq/utils/ReflectEq"[label="ReflectEq", color=aquamarine] +"template-coq/utils/MC_ExtrOCamlZPosInt"[label="MC_ExtrOCamlZPosInt", color=aquamarine] +"template-coq/utils/MCUtils"[label="MCUtils", color=aquamarine] +"template-coq/utils/wGraph"[label="wGraph", color=aquamarine] +"template-coq/utils/MCString"[label="MCString", color=aquamarine] +"template-coq/utils/MCSquash"[label="MCSquash", color=aquamarine] +"template-coq/utils/MCRelations"[label="MCRelations", color=aquamarine] +"template-coq/utils/MCPred"[label="MCPred", color=aquamarine] +"template-coq/utils/MCProd"[label="MCProd", color=aquamarine] +"template-coq/utils/MCOption"[label="MCOption", color=aquamarine] +"template-coq/utils/MCList"[label="MCList", color=aquamarine] +"template-coq/utils/LibHypsNaming"[label="LibHypsNaming", color=aquamarine] +"template-coq/utils/MCEquality"[label="MCEquality", color=aquamarine] +"template-coq/utils/MCCompare"[label="MCCompare", color=aquamarine] +"template-coq/utils/MCArith"[label="MCArith", color=aquamarine] +"template-coq/utils/All_Forall"[label="All_Forall", color=aquamarine] +"template-coq/utils/MCReflect"[label="MCReflect", color=aquamarine] +"template-coq/utils/MCPrelude"[label="MCPrelude", color=aquamarine] +"template-coq/utils/bytestring"[label="bytestring", color=aquamarine] +"template-coq/utils/ByteCompareSpec"[label="ByteCompareSpec", color=aquamarine] +"template-coq/utils/ByteCompare"[label="ByteCompare", color=aquamarine] +"template-coq/utils/canonicaltries/CanonicalTries"[label="CanonicalTries", color=aquamarine] +"template-coq/utils/canonicaltries/String2pos"[label="String2pos", color=aquamarine] +"template-coq/Typing" -> "template-coq/Checker" +"template-coq/common/uGraph" -> "template-coq/Checker" +"template-coq/TemplateMonad" -> "template-coq/Constants" +"template-coq/TemplateMonad/Extractable" -> "template-coq/Constants" +"template-coq/common/uGraph" -> "template-coq/Constants" +"template-coq/Pretty" -> "template-coq/Extraction" +"template-coq/TemplateMonad/Extractable" -> "template-coq/Extraction" +"template-coq/TemplateProgram" -> "template-coq/Extraction" +"template-coq/utils/MC_ExtrOCamlZPosInt" -> "template-coq/Extraction" +"template-coq/Typing" -> "template-coq/Normal" +"template-coq/LiftSubst" -> "template-coq/Pretty" +"template-coq/Typing" -> "template-coq/Reduction" +"template-coq/TemplateMonad/Core" -> "template-coq/TemplateMonad" +"template-coq/Ast" -> "template-coq/TemplateMonad/Common" +"template-coq/AstUtils" -> "template-coq/TemplateMonad/Core" +"template-coq/TemplateMonad/Common" -> "template-coq/TemplateMonad/Core" +"template-coq/AstUtils" -> "template-coq/TemplateMonad/Extractable" +"template-coq/TemplateMonad/Common" -> "template-coq/TemplateMonad/Extractable" +"erasure/Erasure"[label="Erasure", color=tan] +"erasure/EConstructorsAsBlocks"[label="EConstructorsAsBlocks", color=tan] +"erasure/ETransform"[label="ETransform", color=tan] +"erasure/EInlineProjections"[label="EInlineProjections", color=tan] +"erasure/ERemoveParams"[label="ERemoveParams", color=tan] +"erasure/EProgram"[label="EProgram", color=tan] +"erasure/EEtaExpanded"[label="EEtaExpanded", color=tan] +"erasure/EEtaExpandedFix"[label="EEtaExpandedFix", color=tan] +"erasure/EOptimizePropDiscr"[label="EOptimizePropDiscr", color=tan] +"erasure/EExtends"[label="EExtends", color=tan] +"erasure/ErasureFunction"[label="ErasureFunction", color=tan] +"erasure/ErasureCorrectness"[label="ErasureCorrectness", color=tan] +"erasure/ErasureProperties"[label="ErasureProperties", color=tan] +"erasure/EArities"[label="EArities", color=tan] +"erasure/ESubstitution"[label="ESubstitution", color=tan] +"erasure/Prelim"[label="Prelim", color=tan] +"erasure/Extraction"[label="Extraction", color=tan] +"erasure/EDeps"[label="EDeps", color=tan] +"erasure/Extract"[label="Extract", color=tan] +"erasure/EWcbvEvalEtaInd"[label="EWcbvEvalEtaInd", color=tan] +"erasure/EWcbvEvalInd"[label="EWcbvEvalInd", color=tan] +"erasure/EEnvMap"[label="EEnvMap", color=tan] +"erasure/EWellformed"[label="EWellformed", color=tan] +"erasure/EGlobalEnv"[label="EGlobalEnv", color=tan] +"erasure/EWcbvEval"[label="EWcbvEval", color=tan] +"erasure/ECSubst"[label="ECSubst", color=tan] +"erasure/EPretty"[label="EPretty", color=tan] +"erasure/ESpineView"[label="ESpineView", color=tan] +"erasure/EReflect"[label="EReflect", color=tan] +"erasure/ELiftSubst"[label="ELiftSubst", color=tan] +"erasure/EInduction"[label="EInduction", color=tan] +"erasure/EAstUtils"[label="EAstUtils", color=tan] +"erasure/EAst"[label="EAst", color=tan] +"pcuic/PCUICInductiveInversion" -> "pcuic/PCUICEtaExpand" +"pcuic/TemplateToPCUIC" -> "pcuic/PCUICEtaExpand" +"pcuic/PCUICProgram" -> "pcuic/PCUICExpandLets" +"pcuic/PCUICCanonicity" -> "pcuic/PCUICExpandLetsCorrectness" +"pcuic/PCUICEtaExpand" -> "pcuic/PCUICExpandLetsCorrectness" +"pcuic/PCUICExpandLets" -> "pcuic/PCUICExpandLetsCorrectness" +"pcuic/PCUICCanonicity" -> "pcuic/PCUICFirstorder" +"pcuic/PCUICPrincipality" -> "pcuic/PCUICFirstorder" +"pcuic/PCUICSN" -> "pcuic/PCUICFirstorder" +"pcuic/PCUICFirstorder" -> "pcuic/PCUICProgress" +"pcuic/PCUICExpandLetsCorrectness" -> "pcuic/PCUICTransform" +"pcuic/TemplateToPCUICExpanded" -> "pcuic/PCUICTransform" +"pcuic/TemplateToPCUICWcbvEval" -> "pcuic/PCUICTransform" +"pcuic/PCUICInductiveInversion" -> "pcuic/TemplateToPCUICCorrectness" +"pcuic/TemplateToPCUIC" -> "pcuic/TemplateToPCUICCorrectness" +"pcuic/PCUICEtaExpand" -> "pcuic/TemplateToPCUICExpanded" +"pcuic/TemplateToPCUICCorrectness" -> "pcuic/TemplateToPCUICExpanded" +"pcuic/PCUICCanonicity" -> "pcuic/TemplateToPCUICWcbvEval" +"pcuic/TemplateToPCUICCorrectness" -> "pcuic/TemplateToPCUICWcbvEval" +"pcuic/PCUICCanonicity" -> "erasure/EArities" +"pcuic/PCUICPrincipality" -> "erasure/EArities" +"erasure/Extract" -> "erasure/EArities" +"template-coq/Universes" -> "erasure/EAst" +"erasure/EAst" -> "erasure/EAstUtils" +"erasure/ELiftSubst" -> "erasure/ECSubst" +"erasure/EGenericMapEnv" -> "erasure/EConstructorsAsBlocks" +"erasure/EExtends" -> "erasure/EDeps" +"erasure/ESubstitution" -> "erasure/EDeps" +"template-coq/EnvMap" -> "erasure/EEnvMap" +"erasure/EGlobalEnv" -> "erasure/EEnvMap" +"erasure/EEtaExpandedFix" -> "erasure/EEtaExpanded" +"erasure/EExtends" -> "erasure/EEtaExpandedFix" +"erasure/EProgram" -> "erasure/EEtaExpandedFix" +"erasure/ESpineView" -> "erasure/EEtaExpandedFix" +"erasure/EWcbvEvalInd" -> "erasure/EEtaExpandedFix" +"erasure/EWellformed" -> "erasure/EExtends" +"erasure/EArities" -> "erasure/EGenericMapEnv" +"erasure/EWcbvEvalEtaInd" -> "erasure/EGenericMapEnv" +"erasure/ECSubst" -> "erasure/EGlobalEnv" +"erasure/EReflect" -> "erasure/EGlobalEnv" +"pcuic/utils/PCUICSize" -> "erasure/EInduction" +"erasure/EAstUtils" -> "erasure/EInduction" +"erasure/EArities" -> "erasure/EInlineProjections" +"erasure/EEtaExpanded" -> "erasure/EInlineProjections" +"erasure/EInduction" -> "erasure/ELiftSubst" +"safechecker/PCUICWfEnvImpl" -> "erasure/EOptimizePropDiscr" +"erasure/EDeps" -> "erasure/EOptimizePropDiscr" +"erasure/EEtaExpanded" -> "erasure/EOptimizePropDiscr" +"erasure/EGlobalEnv" -> "erasure/EPretty" +"pcuic/PCUICProgram" -> "erasure/EProgram" +"template-coq/Transform" -> "erasure/EProgram" +"erasure/EEnvMap" -> "erasure/EProgram" +"erasure/EPretty" -> "erasure/EProgram" +"erasure/EWcbvEval" -> "erasure/EProgram" +"erasure/EInduction" -> "erasure/EReflect" +"erasure/EArities" -> "erasure/ERemoveParams" +"erasure/EWcbvEvalEtaInd" -> "erasure/ERemoveParams" +"erasure/EReflect" -> "erasure/ESpineView" +"erasure/Prelim" -> "erasure/ESubstitution" +"pcuic/PCUICTransform" -> "erasure/ETransform" +"template-coq/Pretty" -> "erasure/ETransform" +"erasure/EConstructorsAsBlocks" -> "erasure/ETransform" +"erasure/EInlineProjections" -> "erasure/ETransform" +"erasure/EOptimizePropDiscr" -> "erasure/ETransform" +"erasure/ERemoveParams" -> "erasure/ETransform" +"erasure/ErasureFunction" -> "erasure/ETransform" +"pcuic/PCUICWcbvEval" -> "erasure/EWcbvEval" +"erasure/EWellformed" -> "erasure/EWcbvEval" +"erasure/EEtaExpanded" -> "erasure/EWcbvEvalEtaInd" +"template-coq/EnvMap" -> "erasure/EWcbvEvalInd" +"erasure/EWcbvEval" -> "erasure/EWcbvEvalInd" +"pcuic/Syntax/PCUICTactics" -> "erasure/EWellformed" +"erasure/EGlobalEnv" -> "erasure/EWellformed" +"erasure/ETransform" -> "erasure/Erasure" +"pcuic/PCUICEtaExpand" -> "erasure/ErasureCorrectness" +"erasure/EEtaExpandedFix" -> "erasure/ErasureCorrectness" +"erasure/ErasureProperties" -> "erasure/ErasureCorrectness" +"pcuic/PCUICProgress" -> "erasure/ErasureFunction" +"safechecker/PCUICRetypingEnvIrrelevance" -> "erasure/ErasureFunction" +"erasure/ErasureCorrectness" -> "erasure/ErasureFunction" +"erasure/EDeps" -> "erasure/ErasureProperties" +"pcuic/PCUICElimination" -> "erasure/Extract" +"pcuic/PCUICWcbvEval" -> "erasure/Extract" +"erasure/EGlobalEnv" -> "erasure/Extract" +"erasure/Erasure" -> "erasure/Extraction" +"safechecker/PCUICErrors" -> "erasure/Prelim" +"erasure/EArities" -> "erasure/Prelim" +"erasure/EWcbvEval" -> "erasure/Prelim" +"pcuic/PCUICWeakeningEnv"[label="PCUICWeakeningEnv", color=lemonchiffon1] +"pcuic/Bidirectional/BDStrengthening"[label="BDStrengthening", color=lemonchiffon1] +"pcuic/Bidirectional/BDUnique"[label="BDUnique", color=lemonchiffon1] +"pcuic/Bidirectional/BDFromPCUIC"[label="BDFromPCUIC", color=lemonchiffon1] +"pcuic/Bidirectional/BDToPCUIC"[label="BDToPCUIC", color=lemonchiffon1] +"pcuic/Bidirectional/BDTyping"[label="BDTyping", color=lemonchiffon1] +"pcuic/PCUICTransform"[label="PCUICTransform", color=lemonchiffon1] +"pcuic/PCUICExpandLetsCorrectness"[label="PCUICExpandLetsCorrectness", color=lemonchiffon1] +"pcuic/PCUICExpandLets"[label="PCUICExpandLets", color=lemonchiffon1] +"pcuic/PCUICToTemplateCorrectness"[label="PCUICToTemplateCorrectness", color=lemonchiffon1] +"pcuic/PCUICToTemplate"[label="PCUICToTemplate", color=lemonchiffon1] +"pcuic/TemplateToPCUICExpanded"[label="TemplateToPCUICExpanded", color=lemonchiffon1] +"pcuic/TemplateToPCUICWcbvEval"[label="TemplateToPCUICWcbvEval", color=lemonchiffon1] +"pcuic/TemplateToPCUICCorrectness"[label="TemplateToPCUICCorrectness", color=lemonchiffon1] +"pcuic/TemplateToPCUIC"[label="TemplateToPCUIC", color=lemonchiffon1] +"pcuic/PCUICProgram"[label="PCUICProgram", color=lemonchiffon1] +"pcuic/PCUICEtaExpand"[label="PCUICEtaExpand", color=lemonchiffon1] +"pcuic/PCUICSafeLemmata"[label="PCUICSafeLemmata", color=lemonchiffon1] +"pcuic/PCUICProgress"[label="PCUICProgress", color=lemonchiffon1] +"pcuic/PCUICFirstorder"[label="PCUICFirstorder", color=lemonchiffon1] +"pcuic/PCUICSigmaCalculus"[label="PCUICSigmaCalculus", color=lemonchiffon1] +"pcuic/PCUICPrincipality"[label="PCUICPrincipality", color=lemonchiffon1] +"pcuic/PCUICSN"[label="PCUICSN", color=lemonchiffon1] +"pcuic/PCUICElimination"[label="PCUICElimination", color=lemonchiffon1] +"pcuic/PCUICCumulProp"[label="PCUICCumulProp", color=lemonchiffon1] +"pcuic/PCUICWcbvEval"[label="PCUICWcbvEval", color=lemonchiffon1] +"pcuic/PCUICCSubst"[label="PCUICCSubst", color=lemonchiffon1] +"pcuic/PCUICCanonicity"[label="PCUICCanonicity", color=lemonchiffon1] +"pcuic/PCUICSR"[label="PCUICSR", color=lemonchiffon1] +"pcuic/PCUICInductiveInversion"[label="PCUICInductiveInversion", color=lemonchiffon1] +"pcuic/PCUICValidity"[label="PCUICValidity", color=lemonchiffon1] +"pcuic/PCUICInductives"[label="PCUICInductives", color=lemonchiffon1] +"pcuic/PCUICSpine"[label="PCUICSpine", color=lemonchiffon1] +"pcuic/PCUICWfUniverses"[label="PCUICWfUniverses", color=lemonchiffon1] +"pcuic/PCUICArities"[label="PCUICArities", color=lemonchiffon1] +"pcuic/PCUICContexts"[label="PCUICContexts", color=lemonchiffon1] +"pcuic/PCUICAlpha"[label="PCUICAlpha", color=lemonchiffon1] +"pcuic/PCUICGeneration"[label="PCUICGeneration", color=lemonchiffon1] +"pcuic/PCUICRedTypeIrrelevance"[label="PCUICRedTypeIrrelevance", color=lemonchiffon1] +"pcuic/PCUICConvCumInversion"[label="PCUICConvCumInversion", color=lemonchiffon1] +"pcuic/PCUICConversion"[label="PCUICConversion", color=lemonchiffon1] +"pcuic/PCUICContextConversion"[label="PCUICContextConversion", color=lemonchiffon1] +"pcuic/PCUICWellScopedCumulativity"[label="PCUICWellScopedCumulativity", color=lemonchiffon1] +"pcuic/PCUICConfluence"[label="PCUICConfluence", color=lemonchiffon1] +"pcuic/PCUICParallelReductionConfluence"[label="PCUICParallelReductionConfluence", color=lemonchiffon1] +"pcuic/PCUICParallelReduction"[label="PCUICParallelReduction", color=lemonchiffon1] +"pcuic/PCUICCumulativitySpec"[label="PCUICCumulativitySpec", color=lemonchiffon1] +"pcuic/PCUICCumulativity"[label="PCUICCumulativity", color=lemonchiffon1] +"pcuic/PCUICContextReduction"[label="PCUICContextReduction", color=lemonchiffon1] +"pcuic/PCUICSubstitution"[label="PCUICSubstitution", color=lemonchiffon1] +"pcuic/PCUICEquality"[label="PCUICEquality", color=lemonchiffon1] +"pcuic/PCUICNormal"[label="PCUICNormal", color=lemonchiffon1] +"pcuic/PCUICInversion"[label="PCUICInversion", color=lemonchiffon1] +"pcuic/PCUICGlobalEnv"[label="PCUICGlobalEnv", color=lemonchiffon1] +"pcuic/PCUICGuardCondition"[label="PCUICGuardCondition", color=lemonchiffon1] +"pcuic/PCUICTyping"[label="PCUICTyping", color=lemonchiffon1] +"pcuic/PCUICReduction"[label="PCUICReduction", color=lemonchiffon1] +"pcuic/PCUICCasesContexts"[label="PCUICCasesContexts", color=lemonchiffon1] +"pcuic/PCUICContextSubst"[label="PCUICContextSubst", color=lemonchiffon1] +"pcuic/Typing/PCUICContextConversionTyp"[label="PCUICContextConversionTyp", color=lemonchiffon1] +"pcuic/Typing/PCUICClosedTyp"[label="PCUICClosedTyp", color=lemonchiffon1] +"pcuic/Typing/PCUICUnivSubstitutionTyp"[label="PCUICUnivSubstitutionTyp", color=lemonchiffon1] +"pcuic/Typing/PCUICWeakeningTyp"[label="PCUICWeakeningTyp", color=lemonchiffon1] +"pcuic/Typing/PCUICWeakeningEnvTyp"[label="PCUICWeakeningEnvTyp", color=lemonchiffon1] +"pcuic/Typing/PCUICInstTyp"[label="PCUICInstTyp", color=lemonchiffon1] +"pcuic/Typing/PCUICRenameTyp"[label="PCUICRenameTyp", color=lemonchiffon1] +"pcuic/Typing/PCUICNamelessTyp"[label="PCUICNamelessTyp", color=lemonchiffon1] +"pcuic/Conversion/PCUICOnFreeVarsConv"[label="PCUICOnFreeVarsConv", color=lemonchiffon1] +"pcuic/Conversion/PCUICClosedConv"[label="PCUICClosedConv", color=lemonchiffon1] +"pcuic/Conversion/PCUICWeakeningConv"[label="PCUICWeakeningConv", color=lemonchiffon1] +"pcuic/Conversion/PCUICUnivSubstitutionConv"[label="PCUICUnivSubstitutionConv", color=lemonchiffon1] +"pcuic/Conversion/PCUICWeakeningEnvConv"[label="PCUICWeakeningEnvConv", color=lemonchiffon1] +"pcuic/Conversion/PCUICInstConv"[label="PCUICInstConv", color=lemonchiffon1] +"pcuic/Conversion/PCUICRenameConv"[label="PCUICRenameConv", color=lemonchiffon1] +"pcuic/Conversion/PCUICNamelessConv"[label="PCUICNamelessConv", color=lemonchiffon1] +"pcuic/Syntax/PCUICViews"[label="PCUICViews", color=lemonchiffon1] +"pcuic/Syntax/PCUICClosed"[label="PCUICClosed", color=lemonchiffon1] +"pcuic/Syntax/PCUICUnivSubst"[label="PCUICUnivSubst", color=lemonchiffon1] +"pcuic/Syntax/PCUICTactics"[label="PCUICTactics", color=lemonchiffon1] +"pcuic/Syntax/PCUICLiftSubst"[label="PCUICLiftSubst", color=lemonchiffon1] +"pcuic/Syntax/PCUICInstDef"[label="PCUICInstDef", color=lemonchiffon1] +"pcuic/Syntax/PCUICRenameDef"[label="PCUICRenameDef", color=lemonchiffon1] +"pcuic/Syntax/PCUICOnFreeVars"[label="PCUICOnFreeVars", color=lemonchiffon1] +"pcuic/Syntax/PCUICNamelessDef"[label="PCUICNamelessDef", color=lemonchiffon1] +"pcuic/Syntax/PCUICReflect"[label="PCUICReflect", color=lemonchiffon1] +"pcuic/Syntax/PCUICPosition"[label="PCUICPosition", color=lemonchiffon1] +"pcuic/Syntax/PCUICDepth"[label="PCUICDepth", color=lemonchiffon1] +"pcuic/Syntax/PCUICInduction"[label="PCUICInduction", color=lemonchiffon1] +"pcuic/Syntax/PCUICCases"[label="PCUICCases", color=lemonchiffon1] +"pcuic/utils/PCUICPretty"[label="PCUICPretty", color=lemonchiffon1] +"pcuic/utils/PCUICSize"[label="PCUICSize", color=lemonchiffon1] +"pcuic/utils/PCUICUtils"[label="PCUICUtils", color=lemonchiffon1] +"pcuic/utils/PCUICAstUtils"[label="PCUICAstUtils", color=lemonchiffon1] +"pcuic/utils/PCUICPrimitive"[label="PCUICPrimitive", color=lemonchiffon1] +"pcuic/utils/PCUICOnOne"[label="PCUICOnOne", color=lemonchiffon1] +"pcuic/PCUICAst"[label="PCUICAst", color=lemonchiffon1] +"pcuic/Bidirectional/BDFromPCUIC" -> "pcuic/Bidirectional/BDStrengthening" +"pcuic/Conversion/PCUICUnivSubstitutionConv" -> "pcuic/Conversion/PCUICNamelessConv" +"pcuic/Typing/PCUICClosedTyp" -> "pcuic/Conversion/PCUICNamelessConv" +"template-coq/AstUtils" -> "pcuic/PCUICToTemplate" +"pcuic/Syntax/PCUICCases" -> "pcuic/PCUICToTemplate" +"template-coq/Reduction" -> "pcuic/PCUICToTemplateCorrectness" +"template-coq/TypingWf" -> "pcuic/PCUICToTemplateCorrectness" +"pcuic/PCUICSafeLemmata" -> "pcuic/PCUICToTemplateCorrectness" +"pcuic/PCUICToTemplate" -> "pcuic/PCUICToTemplateCorrectness" +"pcuic/Conversion/PCUICNamelessConv" -> "pcuic/Typing/PCUICNamelessTyp" +"pcuic/PCUICConversion" -> "pcuic/Typing/PCUICNamelessTyp" +} diff --git a/dependency-graph/depgraph-2022-07-01.png b/dependency-graph/depgraph-2022-07-01.png new file mode 100644 index 000000000..fb92b6583 Binary files /dev/null and b/dependency-graph/depgraph-2022-07-01.png differ diff --git a/dependency-graph/depgraph-2022-07-01.svg b/dependency-graph/depgraph-2022-07-01.svg new file mode 100644 index 000000000..0a1e46c4e --- /dev/null +++ b/dependency-graph/depgraph-2022-07-01.svg @@ -0,0 +1,3241 @@ + + + + + + +dependencies + + + +safechecker/Extraction + +Extraction + + + +safechecker/PCUICConsistency + +PCUICConsistency + + + +safechecker/PCUICRetypingEnvIrrelevance + +PCUICRetypingEnvIrrelevance + + + +erasure/ErasureFunction + +ErasureFunction + + + +safechecker/PCUICRetypingEnvIrrelevance->erasure/ErasureFunction + + + + + +safechecker/PCUICSafeRetyping + +PCUICSafeRetyping + + + +safechecker/PCUICSafeRetyping->safechecker/PCUICRetypingEnvIrrelevance + + + + + +safechecker/SafeTemplateChecker + +SafeTemplateChecker + + + +safechecker/SafeTemplateChecker->safechecker/Extraction + + + + + +safechecker/PCUICWfEnvImpl + +PCUICWfEnvImpl + + + +safechecker/PCUICWfEnvImpl->safechecker/PCUICConsistency + + + + + +safechecker/PCUICWfEnvImpl->safechecker/SafeTemplateChecker + + + + + +erasure/EOptimizePropDiscr + +EOptimizePropDiscr + + + +safechecker/PCUICWfEnvImpl->erasure/EOptimizePropDiscr + + + + + +safechecker/PCUICSafeChecker + +PCUICSafeChecker + + + +safechecker/PCUICSafeChecker->safechecker/SafeTemplateChecker + + + + + +safechecker/PCUICTypeChecker + +PCUICTypeChecker + + + +safechecker/PCUICTypeChecker->safechecker/PCUICSafeChecker + + + + + +safechecker/PCUICWfReduction + +PCUICWfReduction + + + +safechecker/PCUICSafeReduce + +PCUICSafeReduce + + + +safechecker/PCUICWfReduction->safechecker/PCUICSafeReduce + + + + + +safechecker/PCUICSafeConversion + +PCUICSafeConversion + + + +safechecker/PCUICSafeConversion->safechecker/PCUICTypeChecker + + + + + +safechecker/PCUICSafeReduce->safechecker/PCUICConsistency + + + + + +safechecker/PCUICSafeReduce->safechecker/PCUICSafeRetyping + + + + + +safechecker/PCUICSafeReduce->safechecker/PCUICSafeConversion + + + + + +safechecker/PCUICWfEnv + +PCUICWfEnv + + + +safechecker/PCUICWfEnv->safechecker/PCUICWfEnvImpl + + + + + +safechecker/PCUICWfEnv->safechecker/PCUICWfReduction + + + + + +safechecker/PCUICErrors + +PCUICErrors + + + +safechecker/PCUICErrors->safechecker/PCUICSafeReduce + + + + + +erasure/Prelim + +Prelim + + + +safechecker/PCUICErrors->erasure/Prelim + + + + + +safechecker/PCUICEqualityDec + +PCUICEqualityDec + + + +safechecker/PCUICEqualityDec->safechecker/PCUICWfEnvImpl + + + + + +safechecker/PCUICEqualityDec->safechecker/PCUICSafeConversion + + + + + +pcuic/Bidirectional/BDToPCUIC + +BDToPCUIC + + + +pcuic/Bidirectional/BDFromPCUIC + +BDFromPCUIC + + + +pcuic/Bidirectional/BDToPCUIC->pcuic/Bidirectional/BDFromPCUIC + + + + + +pcuic/Bidirectional/BDUnique + +BDUnique + + + +pcuic/Bidirectional/BDFromPCUIC->pcuic/Bidirectional/BDUnique + + + + + +pcuic/Bidirectional/BDStrengthening + +BDStrengthening + + + +pcuic/Bidirectional/BDFromPCUIC->pcuic/Bidirectional/BDStrengthening + + + + + +pcuic/Bidirectional/BDTyping + +BDTyping + + + +pcuic/Bidirectional/BDTyping->pcuic/Bidirectional/BDToPCUIC + + + + + +pcuic/PCUICSR + +PCUICSR + + + +pcuic/PCUICSR->pcuic/Bidirectional/BDToPCUIC + + + + + +pcuic/PCUICNormal + +PCUICNormal + + + +pcuic/PCUICSR->pcuic/PCUICNormal + + + + + +pcuic/PCUICCumulativity + +PCUICCumulativity + + + +pcuic/PCUICCumulativity->pcuic/Bidirectional/BDTyping + + + + + +pcuic/Conversion/PCUICUnivSubstitutionConv + +PCUICUnivSubstitutionConv + + + +pcuic/PCUICCumulativity->pcuic/Conversion/PCUICUnivSubstitutionConv + + + + + +pcuic/Conversion/PCUICWeakeningEnvConv + +PCUICWeakeningEnvConv + + + +pcuic/PCUICCumulativity->pcuic/Conversion/PCUICWeakeningEnvConv + + + + + +pcuic/PCUICTyping + +PCUICTyping + + + +pcuic/PCUICTyping->pcuic/Bidirectional/BDTyping + + + + + +pcuic/PCUICGlobalEnv + +PCUICGlobalEnv + + + +pcuic/PCUICTyping->pcuic/PCUICGlobalEnv + + + + + +pcuic/PCUICCSubst + +PCUICCSubst + + + +pcuic/PCUICTyping->pcuic/PCUICCSubst + + + + + +pcuic/PCUICGeneration + +PCUICGeneration + + + +pcuic/PCUICTyping->pcuic/PCUICGeneration + + + + + +pcuic/Syntax/PCUICNamelessDef + +PCUICNamelessDef + + + +pcuic/PCUICTyping->pcuic/Syntax/PCUICNamelessDef + + + + + +pcuic/Syntax/PCUICRenameDef + +PCUICRenameDef + + + +pcuic/PCUICTyping->pcuic/Syntax/PCUICRenameDef + + + + + +pcuic/Bidirectional/BDUnique->safechecker/PCUICSafeRetyping + + + + + +pcuic/Bidirectional/BDUnique->safechecker/PCUICTypeChecker + + + + + +pcuic/Conversion/PCUICClosedConv + +PCUICClosedConv + + + +pcuic/PCUICGlobalEnv->pcuic/Conversion/PCUICClosedConv + + + + + +pcuic/PCUICProgram + +PCUICProgram + + + +pcuic/PCUICGlobalEnv->pcuic/PCUICProgram + + + + + +pcuic/Typing/PCUICWeakeningEnvTyp + +PCUICWeakeningEnvTyp + + + +pcuic/PCUICGlobalEnv->pcuic/Typing/PCUICWeakeningEnvTyp + + + + + +pcuic/Typing/PCUICClosedTyp + +PCUICClosedTyp + + + +pcuic/Conversion/PCUICClosedConv->pcuic/Typing/PCUICClosedTyp + + + + + +pcuic/PCUICReduction + +PCUICReduction + + + +pcuic/PCUICReduction->pcuic/PCUICCumulativity + + + + + +pcuic/PCUICReduction->pcuic/Conversion/PCUICClosedConv + + + + + +pcuic/PCUICGuardCondition + +PCUICGuardCondition + + + +pcuic/PCUICReduction->pcuic/PCUICGuardCondition + + + + + +pcuic/PCUICReduction->pcuic/PCUICCSubst + + + + + +pcuic/PCUICWeakeningEnv + +PCUICWeakeningEnv + + + +pcuic/PCUICWeakeningEnv->pcuic/Conversion/PCUICClosedConv + + + + + +pcuic/PCUICWeakeningEnv->pcuic/Conversion/PCUICUnivSubstitutionConv + + + + + +pcuic/PCUICWeakeningEnv->pcuic/Conversion/PCUICWeakeningEnvConv + + + + + +pcuic/Conversion/PCUICInstConv + +PCUICInstConv + + + +pcuic/Conversion/PCUICUnivSubstitutionConv->pcuic/Conversion/PCUICInstConv + + + + + +pcuic/Typing/PCUICUnivSubstitutionTyp + +PCUICUnivSubstitutionTyp + + + +pcuic/Conversion/PCUICUnivSubstitutionConv->pcuic/Typing/PCUICUnivSubstitutionTyp + + + + + +pcuic/Conversion/PCUICNamelessConv + +PCUICNamelessConv + + + +pcuic/Conversion/PCUICUnivSubstitutionConv->pcuic/Conversion/PCUICNamelessConv + + + + + +pcuic/Typing/PCUICInstTyp + +PCUICInstTyp + + + +pcuic/Conversion/PCUICInstConv->pcuic/Typing/PCUICInstTyp + + + + + +pcuic/Typing/PCUICWeakeningTyp + +PCUICWeakeningTyp + + + +pcuic/Typing/PCUICWeakeningTyp->pcuic/Conversion/PCUICInstConv + + + + + +pcuic/Conversion/PCUICRenameConv + +PCUICRenameConv + + + +pcuic/Conversion/PCUICOnFreeVarsConv + +PCUICOnFreeVarsConv + + + +pcuic/Conversion/PCUICRenameConv->pcuic/Conversion/PCUICOnFreeVarsConv + + + + + +pcuic/Conversion/PCUICWeakeningConv + +PCUICWeakeningConv + + + +pcuic/Conversion/PCUICRenameConv->pcuic/Conversion/PCUICWeakeningConv + + + + + +pcuic/Typing/PCUICRenameTyp + +PCUICRenameTyp + + + +pcuic/Conversion/PCUICOnFreeVarsConv->pcuic/Typing/PCUICRenameTyp + + + + + +pcuic/Syntax/PCUICViews + +PCUICViews + + + +pcuic/Syntax/PCUICViews->pcuic/Conversion/PCUICRenameConv + + + + + +pcuic/Typing/PCUICClosedTyp->pcuic/Conversion/PCUICRenameConv + + + + + +pcuic/PCUICWcbvEval + +PCUICWcbvEval + + + +pcuic/Typing/PCUICClosedTyp->pcuic/PCUICWcbvEval + + + + + +pcuic/Typing/PCUICClosedTyp->pcuic/Conversion/PCUICNamelessConv + + + + + +pcuic/PCUICGuardCondition->pcuic/Conversion/PCUICUnivSubstitutionConv + + + + + +pcuic/PCUICGuardCondition->pcuic/Typing/PCUICWeakeningEnvTyp + + + + + +pcuic/Conversion/PCUICWeakeningConv->pcuic/Typing/PCUICWeakeningTyp + + + + + +pcuic/Conversion/PCUICWeakeningEnvConv->pcuic/Typing/PCUICWeakeningEnvTyp + + + + + +pcuic/PCUICCumulativitySpec + +PCUICCumulativitySpec + + + +pcuic/PCUICCumulativitySpec->pcuic/PCUICTyping + + + + + +pcuic/PCUICCumulativitySpec->pcuic/Conversion/PCUICWeakeningEnvConv + + + + + +pcuic/PCUICInductiveInversion + +PCUICInductiveInversion + + + +pcuic/PCUICAlpha + +PCUICAlpha + + + +pcuic/PCUICInductiveInversion->pcuic/PCUICAlpha + + + + + +pcuic/PCUICEtaExpand + +PCUICEtaExpand + + + +pcuic/PCUICInductiveInversion->pcuic/PCUICEtaExpand + + + + + +pcuic/TemplateToPCUICCorrectness + +TemplateToPCUICCorrectness + + + +pcuic/PCUICInductiveInversion->pcuic/TemplateToPCUICCorrectness + + + + + +pcuic/PCUICAlpha->pcuic/PCUICSR + + + + + +pcuic/PCUICContexts + +PCUICContexts + + + +pcuic/PCUICArities + +PCUICArities + + + +pcuic/PCUICContexts->pcuic/PCUICArities + + + + + +pcuic/PCUICSpine + +PCUICSpine + + + +pcuic/PCUICArities->pcuic/PCUICSpine + + + + + +pcuic/PCUICInversion + +PCUICInversion + + + +pcuic/PCUICInversion->pcuic/PCUICArities + + + + + +pcuic/PCUICWfUniverses + +PCUICWfUniverses + + + +pcuic/PCUICWfUniverses->safechecker/PCUICEqualityDec + + + + + +pcuic/PCUICWfUniverses->pcuic/PCUICArities + + + + + +pcuic/utils/PCUICPrimitive + +PCUICPrimitive + + + +pcuic/PCUICAst + +PCUICAst + + + +pcuic/utils/PCUICPrimitive->pcuic/PCUICAst + + + + + +pcuic/utils/PCUICOnOne + +PCUICOnOne + + + +pcuic/PCUICAst->pcuic/utils/PCUICOnOne + + + + + +pcuic/utils/PCUICSize + +PCUICSize + + + +pcuic/PCUICAst->pcuic/utils/PCUICSize + + + + + +pcuic/PCUICCSubst->pcuic/PCUICWcbvEval + + + + + +pcuic/PCUICElimination + +PCUICElimination + + + +pcuic/PCUICCanonicity + +PCUICCanonicity + + + +pcuic/PCUICElimination->pcuic/PCUICCanonicity + + + + + +erasure/Extract + +Extract + + + +pcuic/PCUICElimination->erasure/Extract + + + + + +pcuic/PCUICCanonicity->safechecker/PCUICSafeReduce + + + + + +erasure/EArities + +EArities + + + +pcuic/PCUICCanonicity->erasure/EArities + + + + + +pcuic/PCUICExpandLetsCorrectness + +PCUICExpandLetsCorrectness + + + +pcuic/PCUICCanonicity->pcuic/PCUICExpandLetsCorrectness + + + + + +pcuic/PCUICFirstorder + +PCUICFirstorder + + + +pcuic/PCUICCanonicity->pcuic/PCUICFirstorder + + + + + +pcuic/TemplateToPCUICWcbvEval + +TemplateToPCUICWcbvEval + + + +pcuic/PCUICCanonicity->pcuic/TemplateToPCUICWcbvEval + + + + + +pcuic/PCUICWcbvEval->pcuic/PCUICCanonicity + + + + + +pcuic/PCUICWcbvEval->erasure/Extract + + + + + +erasure/EWcbvEval + +EWcbvEval + + + +pcuic/PCUICWcbvEval->erasure/EWcbvEval + + + + + +pcuic/PCUICEquality + +PCUICEquality + + + +pcuic/PCUICCasesContexts + +PCUICCasesContexts + + + +pcuic/PCUICEquality->pcuic/PCUICCasesContexts + + + + + +pcuic/Syntax/PCUICOnFreeVars + +PCUICOnFreeVars + + + +pcuic/PCUICEquality->pcuic/Syntax/PCUICOnFreeVars + + + + + +pcuic/Syntax/PCUICPosition + +PCUICPosition + + + +pcuic/PCUICEquality->pcuic/Syntax/PCUICPosition + + + + + +pcuic/PCUICCasesContexts->pcuic/PCUICSpine + + + + + +pcuic/PCUICSigmaCalculus + +PCUICSigmaCalculus + + + +pcuic/PCUICSigmaCalculus->pcuic/PCUICCasesContexts + + + + + +pcuic/Syntax/PCUICClosed + +PCUICClosed + + + +pcuic/PCUICSigmaCalculus->pcuic/Syntax/PCUICClosed + + + + + +pcuic/Syntax/PCUICTactics + +PCUICTactics + + + +pcuic/PCUICSigmaCalculus->pcuic/Syntax/PCUICTactics + + + + + +pcuic/PCUICParallelReductionConfluence + +PCUICParallelReductionConfluence + + + +pcuic/PCUICConfluence + +PCUICConfluence + + + +pcuic/PCUICParallelReductionConfluence->pcuic/PCUICConfluence + + + + + +pcuic/PCUICWellScopedCumulativity + +PCUICWellScopedCumulativity + + + +pcuic/PCUICConfluence->pcuic/PCUICWellScopedCumulativity + + + + + +pcuic/PCUICRedTypeIrrelevance + +PCUICRedTypeIrrelevance + + + +pcuic/PCUICRedTypeIrrelevance->pcuic/PCUICConfluence + + + + + +pcuic/PCUICContextConversion + +PCUICContextConversion + + + +pcuic/PCUICWellScopedCumulativity->pcuic/PCUICContextConversion + + + + + +pcuic/PCUICConversion + +PCUICConversion + + + +pcuic/PCUICContextConversion->pcuic/PCUICConversion + + + + + +pcuic/PCUICSubstitution + +PCUICSubstitution + + + +pcuic/PCUICSubstitution->pcuic/PCUICContexts + + + + + +pcuic/PCUICSubstitution->pcuic/PCUICWfUniverses + + + + + +pcuic/PCUICContextReduction + +PCUICContextReduction + + + +pcuic/PCUICSubstitution->pcuic/PCUICContextReduction + + + + + +pcuic/PCUICParallelReduction + +PCUICParallelReduction + + + +pcuic/PCUICSubstitution->pcuic/PCUICParallelReduction + + + + + +pcuic/PCUICContextReduction->pcuic/PCUICRedTypeIrrelevance + + + + + +pcuic/Syntax/PCUICLiftSubst + +PCUICLiftSubst + + + +pcuic/Syntax/PCUICLiftSubst->pcuic/PCUICEquality + + + + + +pcuic/Syntax/PCUICLiftSubst->pcuic/PCUICSigmaCalculus + + + + + +pcuic/PCUICContextSubst + +PCUICContextSubst + + + +pcuic/Syntax/PCUICLiftSubst->pcuic/PCUICContextSubst + + + + + +pcuic/PCUICContextSubst->pcuic/Typing/PCUICWeakeningEnvTyp + + + + + +pcuic/PCUICGeneration->pcuic/PCUICContexts + + + + + +pcuic/PCUICGeneration->pcuic/PCUICWfUniverses + + + + + +pcuic/Typing/PCUICUnivSubstitutionTyp->pcuic/PCUICContexts + + + + + +pcuic/PCUICConvCumInversion + +PCUICConvCumInversion + + + +pcuic/PCUICNormal->pcuic/PCUICConvCumInversion + + + + + +pcuic/PCUICSafeLemmata + +PCUICSafeLemmata + + + +pcuic/PCUICNormal->pcuic/PCUICSafeLemmata + + + + + +pcuic/PCUICConvCumInversion->safechecker/PCUICSafeRetyping + + + + + +pcuic/PCUICConvCumInversion->safechecker/PCUICSafeConversion + + + + + +pcuic/PCUICConversion->pcuic/PCUICInversion + + + + + +pcuic/Typing/PCUICContextConversionTyp + +PCUICContextConversionTyp + + + +pcuic/PCUICConversion->pcuic/Typing/PCUICContextConversionTyp + + + + + +pcuic/Typing/PCUICNamelessTyp + +PCUICNamelessTyp + + + +pcuic/PCUICConversion->pcuic/Typing/PCUICNamelessTyp + + + + + +pcuic/PCUICSafeLemmata->safechecker/PCUICWfEnv + + + + + +pcuic/PCUICCumulProp + +PCUICCumulProp + + + +pcuic/PCUICSafeLemmata->pcuic/PCUICCumulProp + + + + + +pcuic/PCUICSN + +PCUICSN + + + +pcuic/PCUICSafeLemmata->pcuic/PCUICSN + + + + + +pcuic/PCUICToTemplateCorrectness + +PCUICToTemplateCorrectness + + + +pcuic/PCUICSafeLemmata->pcuic/PCUICToTemplateCorrectness + + + + + +pcuic/PCUICCumulProp->pcuic/PCUICElimination + + + + + +pcuic/PCUICPrincipality + +PCUICPrincipality + + + +pcuic/PCUICCumulProp->pcuic/PCUICPrincipality + + + + + +pcuic/Syntax/PCUICOnFreeVars->pcuic/PCUICCumulativitySpec + + + + + +pcuic/utils/PCUICOnOne->pcuic/PCUICReduction + + + + + +pcuic/utils/PCUICOnOne->pcuic/Syntax/PCUICViews + + + + + +pcuic/utils/PCUICOnOne->pcuic/PCUICCumulativitySpec + + + + + +pcuic/Syntax/PCUICReflect + +PCUICReflect + + + +pcuic/Syntax/PCUICReflect->pcuic/Syntax/PCUICViews + + + + + +pcuic/Syntax/PCUICReflect->pcuic/PCUICEquality + + + + + +pcuic/Syntax/PCUICInstDef + +PCUICInstDef + + + +pcuic/Syntax/PCUICInstDef->pcuic/PCUICGuardCondition + + + + + +pcuic/Syntax/PCUICNamelessDef->pcuic/PCUICGuardCondition + + + + + +pcuic/PCUICValidity + +PCUICValidity + + + +pcuic/PCUICValidity->pcuic/PCUICInductiveInversion + + + + + +pcuic/PCUICInductives + +PCUICInductives + + + +pcuic/PCUICSpine->pcuic/PCUICInductives + + + + + +pcuic/PCUICInductives->pcuic/PCUICValidity + + + + + +template-coq/UnivSubst + +UnivSubst + + + +template-coq/UnivSubst->pcuic/PCUICNormal + + + + + +template-coq/WfAst + +WfAst + + + +template-coq/UnivSubst->template-coq/WfAst + + + + + +pcuic/PCUICParallelReduction->pcuic/PCUICParallelReductionConfluence + + + + + +pcuic/Syntax/PCUICDepth + +PCUICDepth + + + +pcuic/Syntax/PCUICDepth->pcuic/PCUICParallelReduction + + + + + +pcuic/PCUICPrincipality->safechecker/PCUICSafeConversion + + + + + +pcuic/PCUICPrincipality->erasure/EArities + + + + + +pcuic/PCUICPrincipality->pcuic/PCUICFirstorder + + + + + +pcuic/TemplateToPCUIC + +TemplateToPCUIC + + + +pcuic/PCUICProgram->pcuic/TemplateToPCUIC + + + + + +erasure/EProgram + +EProgram + + + +pcuic/PCUICProgram->erasure/EProgram + + + + + +pcuic/PCUICExpandLets + +PCUICExpandLets + + + +pcuic/PCUICProgram->pcuic/PCUICExpandLets + + + + + +template-coq/EnvMap + +EnvMap + + + +template-coq/EnvMap->safechecker/PCUICWfEnv + + + + + +template-coq/EnvMap->pcuic/PCUICProgram + + + + + +erasure/EWcbvEvalInd + +EWcbvEvalInd + + + +template-coq/EnvMap->erasure/EWcbvEvalInd + + + + + +erasure/EEnvMap + +EEnvMap + + + +template-coq/EnvMap->erasure/EEnvMap + + + + + +pcuic/Syntax/PCUICClosed->pcuic/PCUICReduction + + + + + +pcuic/Syntax/PCUICClosed->pcuic/Syntax/PCUICOnFreeVars + + + + + +pcuic/Syntax/PCUICPosition->pcuic/PCUICTyping + + + + + +pcuic/Syntax/PCUICPosition->pcuic/PCUICReduction + + + + + +pcuic/Syntax/PCUICTactics->pcuic/PCUICReduction + + + + + +erasure/EWellformed + +EWellformed + + + +pcuic/Syntax/PCUICTactics->erasure/EWellformed + + + + + +pcuic/PCUICSN->safechecker/PCUICWfReduction + + + + + +pcuic/PCUICSN->pcuic/PCUICFirstorder + + + + + +pcuic/Typing/PCUICContextConversionTyp->pcuic/PCUICSpine + + + + + +pcuic/Typing/PCUICInstTyp->pcuic/PCUICSubstitution + + + + + +pcuic/utils/PCUICUtils + +PCUICUtils + + + +pcuic/utils/PCUICUtils->pcuic/PCUICTyping + + + + + +pcuic/utils/PCUICAstUtils + +PCUICAstUtils + + + +pcuic/utils/PCUICAstUtils->pcuic/PCUICWeakeningEnv + + + + + +pcuic/Syntax/PCUICCases + +PCUICCases + + + +pcuic/utils/PCUICAstUtils->pcuic/Syntax/PCUICCases + + + + + +pcuic/utils/PCUICPretty + +PCUICPretty + + + +pcuic/utils/PCUICAstUtils->pcuic/utils/PCUICPretty + + + + + +template-coq/utils/LibHypsNaming + +LibHypsNaming + + + +template-coq/utils/LibHypsNaming->pcuic/PCUICWeakeningEnv + + + + + +pcuic/Syntax/PCUICInduction + +PCUICInduction + + + +template-coq/utils/LibHypsNaming->pcuic/Syntax/PCUICInduction + + + + + +pcuic/Syntax/PCUICCases->pcuic/Syntax/PCUICInduction + + + + + +pcuic/PCUICToTemplate + +PCUICToTemplate + + + +pcuic/Syntax/PCUICCases->pcuic/PCUICToTemplate + + + + + +pcuic/Syntax/PCUICUnivSubst + +PCUICUnivSubst + + + +pcuic/Syntax/PCUICUnivSubst->pcuic/Syntax/PCUICClosed + + + + + +pcuic/Syntax/PCUICInduction->pcuic/Syntax/PCUICLiftSubst + + + + + +pcuic/Syntax/PCUICInduction->pcuic/Syntax/PCUICReflect + + + + + +pcuic/Syntax/PCUICInduction->pcuic/Syntax/PCUICDepth + + + + + +pcuic/Syntax/PCUICInduction->pcuic/Syntax/PCUICUnivSubst + + + + + +pcuic/Syntax/PCUICRenameDef->pcuic/Syntax/PCUICInstDef + + + + + +template-coq/utils/MCPred + +MCPred + + + +template-coq/utils/MCPred->pcuic/Syntax/PCUICOnFreeVars + + + + + +pcuic/TemplateToPCUIC->safechecker/SafeTemplateChecker + + + + + +pcuic/TemplateToPCUIC->pcuic/PCUICEtaExpand + + + + + +pcuic/TemplateToPCUIC->pcuic/TemplateToPCUICCorrectness + + + + + +template-coq/TemplateProgram + +TemplateProgram + + + +template-coq/TemplateProgram->pcuic/TemplateToPCUIC + + + + + +template-coq/Extraction + +Extraction + + + +template-coq/TemplateProgram->template-coq/Extraction + + + + + +pcuic/Typing/PCUICWeakeningEnvTyp->pcuic/Typing/PCUICClosedTyp + + + + + +pcuic/Typing/PCUICWeakeningEnvTyp->pcuic/Typing/PCUICUnivSubstitutionTyp + + + + + +pcuic/Typing/PCUICRenameTyp->pcuic/Typing/PCUICWeakeningTyp + + + + + +pcuic/utils/PCUICSize->pcuic/utils/PCUICAstUtils + + + + + +erasure/EInduction + +EInduction + + + +pcuic/utils/PCUICSize->erasure/EInduction + + + + + +template-coq/common/uGraph + +uGraph + + + +template-coq/common/uGraph->template-coq/EnvMap + + + + + +template-coq/common/uGraph->pcuic/utils/PCUICAstUtils + + + + + +template-coq/EtaExpand + +EtaExpand + + + +template-coq/common/uGraph->template-coq/EtaExpand + + + + + +template-coq/Constants + +Constants + + + +template-coq/common/uGraph->template-coq/Constants + + + + + +template-coq/Checker + +Checker + + + +template-coq/common/uGraph->template-coq/Checker + + + + + +pcuic/utils/PCUICPretty->safechecker/PCUICWfReduction + + + + + +pcuic/utils/PCUICPretty->safechecker/PCUICErrors + + + + + +template-coq/EnvironmentTyping + +EnvironmentTyping + + + +template-coq/EnvironmentTyping->pcuic/utils/PCUICPrimitive + + + + + +template-coq/Ast + +Ast + + + +template-coq/EnvironmentTyping->template-coq/Ast + + + + + +template-coq/Reflect + +Reflect + + + +template-coq/Reflect->pcuic/utils/PCUICPrimitive + + + + + +template-coq/Reflect->template-coq/EnvMap + + + + + +template-coq/ReflectAst + +ReflectAst + + + +template-coq/Reflect->template-coq/ReflectAst + + + + + +template-coq/TermEquality + +TermEquality + + + +template-coq/Reflect->template-coq/TermEquality + + + + + +template-coq/config + +config + + + +template-coq/config->pcuic/utils/PCUICUtils + + + + + +template-coq/Universes + +Universes + + + +template-coq/config->template-coq/Universes + + + + + +template-coq/utils + +utils + + + +template-coq/utils->pcuic/utils/PCUICUtils + + + + + +template-coq/Kernames + +Kernames + + + +template-coq/utils->template-coq/Kernames + + + + + +template-coq/Transform + +Transform + + + +template-coq/utils->template-coq/Transform + + + + + +template-coq/AstUtils + +AstUtils + + + +template-coq/Ast->template-coq/AstUtils + + + + + +template-coq/TemplateMonad/Common + +Common + + + +template-coq/Ast->template-coq/TemplateMonad/Common + + + + + +template-coq/Induction + +Induction + + + +template-coq/AstUtils->template-coq/Induction + + + + + +template-coq/TemplateMonad/Extractable + +Extractable + + + +template-coq/AstUtils->template-coq/TemplateMonad/Extractable + + + + + +template-coq/TemplateMonad/Core + +Core + + + +template-coq/AstUtils->template-coq/TemplateMonad/Core + + + + + +template-coq/AstUtils->pcuic/PCUICToTemplate + + + + + +template-coq/BasicAst + +BasicAst + + + +template-coq/Kernames->template-coq/BasicAst + + + + + +template-coq/BasicAst->template-coq/Universes + + + + + +template-coq/utils/canonicaltries/CanonicalTries + +CanonicalTries + + + +template-coq/utils/canonicaltries/CanonicalTries->template-coq/EnvMap + + + + + +template-coq/Universes->template-coq/common/uGraph + + + + + +template-coq/Universes->template-coq/Reflect + + + + + +template-coq/Environment + +Environment + + + +template-coq/Universes->template-coq/Environment + + + + + +erasure/EAst + +EAst + + + +template-coq/Universes->erasure/EAst + + + + + +template-coq/Environment->template-coq/EnvironmentTyping + + + + + +template-coq/Typing + +Typing + + + +template-coq/Typing->template-coq/EtaExpand + + + + + +template-coq/TypingWf + +TypingWf + + + +template-coq/Typing->template-coq/TypingWf + + + + + +template-coq/Typing->template-coq/Checker + + + + + +template-coq/Normal + +Normal + + + +template-coq/Typing->template-coq/Normal + + + + + +template-coq/Reduction + +Reduction + + + +template-coq/Typing->template-coq/Reduction + + + + + +template-coq/EtaExpand->template-coq/TemplateProgram + + + + + +template-coq/Induction->template-coq/UnivSubst + + + + + +template-coq/Induction->template-coq/ReflectAst + + + + + +template-coq/Induction->template-coq/TermEquality + + + + + +template-coq/LiftSubst + +LiftSubst + + + +template-coq/WfAst->template-coq/LiftSubst + + + + + +template-coq/LiftSubst->template-coq/Typing + + + + + +template-coq/Pretty + +Pretty + + + +template-coq/LiftSubst->template-coq/Pretty + + + + + +template-coq/ReflectAst->template-coq/Typing + + + + + +template-coq/Transform->template-coq/TemplateProgram + + + + + +template-coq/Transform->erasure/EProgram + + + + + +template-coq/WcbvEval + +WcbvEval + + + +template-coq/WcbvEval->template-coq/TemplateProgram + + + + + +template-coq/TermEquality->template-coq/Typing + + + + + +template-coq/TypingWf->template-coq/WcbvEval + + + + + +template-coq/TypingWf->pcuic/PCUICToTemplateCorrectness + + + + + +template-coq/utils/wGraph + +wGraph + + + +template-coq/utils/wGraph->template-coq/common/uGraph + + + + + +template-coq/utils/All_Forall + +All_Forall + + + +template-coq/monad_utils + +monad_utils + + + +template-coq/utils/All_Forall->template-coq/monad_utils + + + + + +template-coq/utils/MCUtils + +MCUtils + + + +template-coq/utils/All_Forall->template-coq/utils/MCUtils + + + + + +template-coq/monad_utils->template-coq/utils + + + + + +template-coq/utils/MCUtils->template-coq/utils + + + + + +template-coq/utils/MCUtils->template-coq/utils/wGraph + + + + + +template-coq/utils/MCOption + +MCOption + + + +template-coq/utils/MCOption->template-coq/utils/MCPred + + + + + +template-coq/utils/MCOption->template-coq/utils/All_Forall + + + + + +template-coq/utils/MCSquash + +MCSquash + + + +template-coq/utils/MCSquash->template-coq/utils/All_Forall + + + + + +template-coq/utils/ByteCompare + +ByteCompare + + + +template-coq/utils/ByteCompareSpec + +ByteCompareSpec + + + +template-coq/utils/ByteCompare->template-coq/utils/ByteCompareSpec + + + + + +template-coq/utils/bytestring + +bytestring + + + +template-coq/utils/ByteCompareSpec->template-coq/utils/bytestring + + + + + +template-coq/utils/MCCompare + +MCCompare + + + +template-coq/utils/MCCompare->template-coq/utils/ByteCompareSpec + + + + + +template-coq/utils/ReflectEq + +ReflectEq + + + +template-coq/utils/ReflectEq->template-coq/utils/ByteCompareSpec + + + + + +template-coq/utils/MCList + +MCList + + + +template-coq/utils/ReflectEq->template-coq/utils/MCList + + + + + +template-coq/utils/MCPrelude + +MCPrelude + + + +template-coq/utils/MCPrelude->template-coq/utils/MCList + + + + + +template-coq/utils/MCReflect + +MCReflect + + + +template-coq/utils/MCPrelude->template-coq/utils/MCReflect + + + + + +template-coq/utils/MCList->template-coq/utils/MCOption + + + + + +template-coq/utils/MCRelations + +MCRelations + + + +template-coq/utils/MCRelations->template-coq/utils/MCList + + + + + +template-coq/utils/MCProd + +MCProd + + + +template-coq/utils/MCProd->template-coq/utils/MCOption + + + + + +template-coq/utils/MCReflect->template-coq/utils/MCOption + + + + + +template-coq/utils/MCString + +MCString + + + +template-coq/utils/bytestring->template-coq/utils/MCString + + + + + +template-coq/utils/MCString->template-coq/utils/MCUtils + + + + + +template-coq/utils/MCArith + +MCArith + + + +template-coq/utils/MCArith->template-coq/utils/MCUtils + + + + + +template-coq/utils/MCEquality + +MCEquality + + + +template-coq/utils/MCEquality->template-coq/utils/MCUtils + + + + + +template-coq/utils/canonicaltries/String2pos + +String2pos + + + +template-coq/utils/canonicaltries/String2pos->template-coq/utils/canonicaltries/CanonicalTries + + + + + +template-coq/utils/MC_ExtrOCamlZPosInt + +MC_ExtrOCamlZPosInt + + + +template-coq/utils/MC_ExtrOCamlZPosInt->safechecker/Extraction + + + + + +template-coq/utils/MC_ExtrOCamlZPosInt->template-coq/Extraction + + + + + +template-coq/TemplateMonad/Extractable->template-coq/Extraction + + + + + +template-coq/TemplateMonad/Extractable->template-coq/Constants + + + + + +template-coq/TemplateMonad + +TemplateMonad + + + +template-coq/TemplateMonad/Core->template-coq/TemplateMonad + + + + + +template-coq/TemplateMonad/Common->template-coq/TemplateMonad/Extractable + + + + + +template-coq/TemplateMonad/Common->template-coq/TemplateMonad/Core + + + + + +template-coq/TemplateMonad->template-coq/Constants + + + + + +template-coq/Reduction->pcuic/PCUICToTemplateCorrectness + + + + + +template-coq/Pretty->template-coq/Extraction + + + + + +erasure/ETransform + +ETransform + + + +template-coq/Pretty->erasure/ETransform + + + + + +erasure/Erasure + +Erasure + + + +erasure/Extraction + +Extraction + + + +erasure/Erasure->erasure/Extraction + + + + + +erasure/EConstructorsAsBlocks + +EConstructorsAsBlocks + + + +erasure/EConstructorsAsBlocks->erasure/ETransform + + + + + +erasure/ETransform->erasure/Erasure + + + + + +erasure/EInlineProjections + +EInlineProjections + + + +erasure/EInlineProjections->erasure/ETransform + + + + + +erasure/ERemoveParams + +ERemoveParams + + + +erasure/ERemoveParams->erasure/ETransform + + + + + +erasure/EEtaExpandedFix + +EEtaExpandedFix + + + +erasure/EProgram->erasure/EEtaExpandedFix + + + + + +erasure/EEtaExpanded + +EEtaExpanded + + + +erasure/EEtaExpanded->erasure/EInlineProjections + + + + + +erasure/EEtaExpanded->erasure/EOptimizePropDiscr + + + + + +erasure/EWcbvEvalEtaInd + +EWcbvEvalEtaInd + + + +erasure/EEtaExpanded->erasure/EWcbvEvalEtaInd + + + + + +erasure/EEtaExpandedFix->erasure/EEtaExpanded + + + + + +erasure/ErasureCorrectness + +ErasureCorrectness + + + +erasure/EEtaExpandedFix->erasure/ErasureCorrectness + + + + + +erasure/EOptimizePropDiscr->erasure/ETransform + + + + + +erasure/EExtends + +EExtends + + + +erasure/EExtends->erasure/EEtaExpandedFix + + + + + +erasure/EDeps + +EDeps + + + +erasure/EExtends->erasure/EDeps + + + + + +erasure/ErasureFunction->erasure/ETransform + + + + + +erasure/ErasureCorrectness->erasure/ErasureFunction + + + + + +erasure/ErasureProperties + +ErasureProperties + + + +erasure/ErasureProperties->erasure/ErasureCorrectness + + + + + +erasure/EArities->erasure/EInlineProjections + + + + + +erasure/EArities->erasure/ERemoveParams + + + + + +erasure/EArities->erasure/Prelim + + + + + +erasure/EGenericMapEnv + +erasure/EGenericMapEnv + + + +erasure/EArities->erasure/EGenericMapEnv + + + + + +erasure/ESubstitution + +ESubstitution + + + +erasure/ESubstitution->erasure/EDeps + + + + + +erasure/Prelim->erasure/ESubstitution + + + + + +erasure/EDeps->erasure/EOptimizePropDiscr + + + + + +erasure/EDeps->erasure/ErasureProperties + + + + + +erasure/Extract->erasure/EArities + + + + + +erasure/EWcbvEvalEtaInd->erasure/ERemoveParams + + + + + +erasure/EWcbvEvalEtaInd->erasure/EGenericMapEnv + + + + + +erasure/EWcbvEvalInd->erasure/EEtaExpandedFix + + + + + +erasure/EEnvMap->erasure/EProgram + + + + + +erasure/EWellformed->erasure/EExtends + + + + + +erasure/EWellformed->erasure/EWcbvEval + + + + + +erasure/EGlobalEnv + +EGlobalEnv + + + +erasure/EGlobalEnv->erasure/Extract + + + + + +erasure/EGlobalEnv->erasure/EEnvMap + + + + + +erasure/EGlobalEnv->erasure/EWellformed + + + + + +erasure/EPretty + +EPretty + + + +erasure/EGlobalEnv->erasure/EPretty + + + + + +erasure/EWcbvEval->erasure/EProgram + + + + + +erasure/EWcbvEval->erasure/Prelim + + + + + +erasure/EWcbvEval->erasure/EWcbvEvalInd + + + + + +erasure/ECSubst + +ECSubst + + + +erasure/ECSubst->erasure/EGlobalEnv + + + + + +erasure/EPretty->erasure/EProgram + + + + + +erasure/ESpineView + +ESpineView + + + +erasure/ESpineView->erasure/EEtaExpandedFix + + + + + +erasure/EReflect + +EReflect + + + +erasure/EReflect->erasure/EGlobalEnv + + + + + +erasure/EReflect->erasure/ESpineView + + + + + +erasure/ELiftSubst + +ELiftSubst + + + +erasure/ELiftSubst->erasure/ECSubst + + + + + +erasure/EInduction->erasure/EReflect + + + + + +erasure/EInduction->erasure/ELiftSubst + + + + + +erasure/EAstUtils + +EAstUtils + + + +erasure/EAstUtils->erasure/EInduction + + + + + +erasure/EAst->erasure/EAstUtils + + + + + +pcuic/PCUICEtaExpand->erasure/ErasureCorrectness + + + + + +pcuic/PCUICEtaExpand->pcuic/PCUICExpandLetsCorrectness + + + + + +pcuic/TemplateToPCUICExpanded + +TemplateToPCUICExpanded + + + +pcuic/PCUICEtaExpand->pcuic/TemplateToPCUICExpanded + + + + + +pcuic/PCUICExpandLets->pcuic/PCUICExpandLetsCorrectness + + + + + +pcuic/PCUICTransform + +PCUICTransform + + + +pcuic/PCUICExpandLetsCorrectness->pcuic/PCUICTransform + + + + + +pcuic/PCUICProgress + +PCUICProgress + + + +pcuic/PCUICFirstorder->pcuic/PCUICProgress + + + + + +pcuic/PCUICProgress->erasure/ErasureFunction + + + + + +pcuic/PCUICTransform->erasure/ETransform + + + + + +pcuic/TemplateToPCUICExpanded->pcuic/PCUICTransform + + + + + +pcuic/TemplateToPCUICWcbvEval->pcuic/PCUICTransform + + + + + +pcuic/TemplateToPCUICCorrectness->pcuic/TemplateToPCUICExpanded + + + + + +pcuic/TemplateToPCUICCorrectness->pcuic/TemplateToPCUICWcbvEval + + + + + +erasure/EGenericMapEnv->erasure/EConstructorsAsBlocks + + + + + +pcuic/PCUICToTemplate->pcuic/PCUICToTemplateCorrectness + + + + + +pcuic/Conversion/PCUICNamelessConv->pcuic/Typing/PCUICNamelessTyp + + + + + diff --git a/dependency-graph/generate-depgraph.sh b/dependency-graph/generate-depgraph.sh index e8e61731d..66b2addba 100755 --- a/dependency-graph/generate-depgraph.sh +++ b/dependency-graph/generate-depgraph.sh @@ -21,7 +21,6 @@ dot_file=$filename.dot # Associative arrays of the folders together with a color declare -A folders folders[template-coq]=aquamarine -folders[checker]=seagreen3 folders[pcuic]=lemonchiffon1 folders[safechecker]=paleturquoise1 folders[erasure]=tan @@ -33,6 +32,7 @@ for folder in "${!folders[@]}" do cd ../$folder echo `pwd` + # WARNING: coqdep <= 8.11 only supports -dumpgraph coqdep -f _CoqProject -dumpgraph ../dependency-graph/$folder.dot > /dev/null cd ../dependency-graph # remove the first and last lines diff --git a/erasure/_CoqProject.in b/erasure/_CoqProject.in index 617a15e08..1eb4c6557 100644 --- a/erasure/_CoqProject.in +++ b/erasure/_CoqProject.in @@ -10,15 +10,14 @@ theories/EPretty.v theories/ECSubst.v theories/EWcbvEval.v # theories/EWtAst.v -theories/EWndEval.v theories/EGlobalEnv.v +theories/EGenericMapEnv.v theories/EWellformed.v theories/EEnvMap.v theories/EWcbvEvalInd.v theories/EWcbvEvalEtaInd.v theories/Extract.v theories/EDeps.v -theories/EAll.v theories/Extraction.v theories/Prelim.v theories/ESubstitution.v @@ -34,4 +33,6 @@ theories/EProgram.v theories/ERemoveParams.v theories/EInlineProjections.v theories/ETransform.v +theories/EConstructorsAsBlocks.v +theories/EWcbvEvalCstrsAsBlocksInd.v theories/Erasure.v diff --git a/erasure/_PluginProject.in b/erasure/_PluginProject.in index 9d0296061..e7a89e742 100644 --- a/erasure/_PluginProject.in +++ b/erasure/_PluginProject.in @@ -11,14 +11,12 @@ src/META.coq-metacoq-erasure # src/canonicalTries.ml src/ssrbool.ml src/ssrbool.mli -# src/ssreflect.ml -# src/ssreflect.mli src/uGraph0.ml src/uGraph0.mli src/wGraph.ml src/wGraph.mli -src/envMap.mli -src/envMap.ml +src/etaExpand.mli +src/etaExpand.ml # src/reflect.mli # src/reflect.ml @@ -28,8 +26,8 @@ src/envMap.ml # src/wcbvEval.mli # src/wcbvEval.ml # From PCUIC -# src/pCUICPrimitive.mli -# src/pCUICPrimitive.ml +src/pCUICPrimitive.mli +src/pCUICPrimitive.ml src/pCUICAst.ml src/pCUICAst.mli src/pCUICCases.mli @@ -140,6 +138,8 @@ src/eProgram.ml # src/eEtaExpandedFix.ml src/eInlineProjections.mli src/eInlineProjections.ml +src/eConstructorsAsBlocks.mli +src/eConstructorsAsBlocks.ml src/eTransform.mli src/eTransform.ml src/erasure.mli diff --git a/erasure/src/g_metacoq_erasure.mlg b/erasure/src/g_metacoq_erasure.mlg index 3cdbf6df7..a0a175ff7 100644 --- a/erasure/src/g_metacoq_erasure.mlg +++ b/erasure/src/g_metacoq_erasure.mlg @@ -28,10 +28,9 @@ let pr_char_list l = let check ~bypass ~fast env evm c = debug (fun () -> str"Quoting"); let term = time (str"Quoting") (Ast_quoter.quote_term_rec ~bypass env evm) (EConstr.to_constr evm c) in - let checker_flags = Config0.extraction_checker_flags in let erase = time (str"Erasure") - (if fast then Erasure.erase_fast_and_print_template_program checker_flags - else Erasure.erase_and_print_template_program checker_flags) + (if fast then Erasure.erase_fast_and_print_template_program + else Erasure.erase_and_print_template_program) term in Feedback.msg_info (pr_char_list erase) diff --git a/erasure/src/metacoq_erasure_plugin.mlpack b/erasure/src/metacoq_erasure_plugin.mlpack index 316318fbc..662a2d49a 100644 --- a/erasure/src/metacoq_erasure_plugin.mlpack +++ b/erasure/src/metacoq_erasure_plugin.mlpack @@ -6,13 +6,14 @@ Utils WGraph UGraph0 -EnvMap +EtaExpand WcbvEval Classes0 Logic1 Relation Relation_Properties +PCUICPrimitive PCUICAst PCUICCases PCUICAstUtils @@ -55,6 +56,7 @@ ERemoveParams ErasureFunction EOptimizePropDiscr EInlineProjections +EConstructorsAsBlocks EProgram ETransform Erasure diff --git a/erasure/theories/EAll.v b/erasure/theories/EAll.v deleted file mode 100644 index 06e48834b..000000000 --- a/erasure/theories/EAll.v +++ /dev/null @@ -1,3 +0,0 @@ -(* Distributed under the terms of the MIT license. *) -From MetaCoq.Erasure Require Export EAst EInduction ELiftSubst EGlobalEnv EWcbvEval - EWndEval Extract. diff --git a/erasure/theories/EArities.v b/erasure/theories/EArities.v index b7dbf552b..f687356d5 100644 --- a/erasure/theories/EArities.v +++ b/erasure/theories/EArities.v @@ -22,7 +22,7 @@ Local Existing Instance extraction_checker_flags. Implicit Types (cf : checker_flags) (Σ : global_env_ext). -(* todo move *) +(* TODO move *) #[global] Existing Instance extends_refl. Lemma isErasable_Proof Σ Γ t : diff --git a/erasure/theories/EAst.v b/erasure/theories/EAst.v index b0c8bbd72..6e467d144 100644 --- a/erasure/theories/EAst.v +++ b/erasure/theories/EAst.v @@ -1,5 +1,6 @@ (* Distributed under the terms of the MIT license. *) From MetaCoq.Template Require Import utils BasicAst Universes. +From MetaCoq.PCUIC Require Import PCUICPrimitive. (** * Extracted terms These are the terms produced by extraction: compared to kernel terms, @@ -33,13 +34,13 @@ Inductive term : Set := | tLetIn : name -> term (* the term *) -> term -> term | tApp : term -> term -> term | tConst : kername -> term -| tConstruct : inductive -> nat -> term +| tConstruct : inductive -> nat -> list term -> term | tCase : (inductive * nat) (* # of parameters *) -> term (* discriminee *) -> list (list name * term) (* branches *) -> term | tProj : projection -> term -> term | tFix : mfixpoint term -> nat -> term -| tCoFix : mfixpoint term -> nat -> term. -(* | tPrim : prim_val term -> term. *) +| tCoFix : mfixpoint term -> nat -> term +| tPrim : prim_val term -> term. Derive NoConfusion for term. @@ -105,11 +106,6 @@ Inductive constant_entry := [x1:X1;...;xn:Xn]. *) -Inductive recursivity_kind := - | Finite (* = inductive *) - | CoFinite (* = coinductive *) - | BiFinite (* = non-recursive, like in "Record" definitions *). - Inductive local_entry : Set := | LocalDef : term -> local_entry (* local let binding *) | LocalAssum : term -> local_entry. @@ -198,6 +194,7 @@ Derive NoConfusion for one_inductive_body. (** See [mutual_inductive_body] from [declarations.ml]. *) Record mutual_inductive_body := { + ind_finite : recursivity_kind; ind_npars : nat; ind_bodies : list one_inductive_body }. Derive NoConfusion for mutual_inductive_body. diff --git a/erasure/theories/EAstUtils.v b/erasure/theories/EAstUtils.v index 6db80c98d..3631386cd 100644 --- a/erasure/theories/EAstUtils.v +++ b/erasure/theories/EAstUtils.v @@ -283,10 +283,17 @@ Definition isCoFix t := Definition isConstruct t := match t with - | tConstruct _ _ => true + | tConstruct _ _ _ => true | _ => false end. +Definition isPrim t := + match t with + | tPrim _ => true + | _ => false + end. + + Definition isBox t := match t with | tBox => true @@ -301,11 +308,14 @@ Definition is_box c := Definition isFixApp t := isFix (head t). Definition isConstructApp t := isConstruct (head t). +Definition isPrimApp t := isPrim (head t). Lemma isFixApp_mkApps f l : isFixApp (mkApps f l) = isFixApp f. Proof. rewrite /isFixApp head_mkApps //. Qed. Lemma isConstructApp_mkApps f l : isConstructApp (mkApps f l) = isConstructApp f. Proof. rewrite /isConstructApp head_mkApps //. Qed. +Lemma isPrimApp_mkApps f l : isPrimApp (mkApps f l) = isPrimApp f. +Proof. rewrite /isPrimApp head_mkApps //. Qed. Lemma is_box_mkApps f a : is_box (mkApps f a) = is_box f. Proof. @@ -323,11 +333,15 @@ Lemma nisFix_mkApps f args : ~~ isFix f -> ~~ isFix (mkApps f args). Proof. destruct args using rev_case => //. rewrite mkApps_app /= //. Qed. Lemma nisBox_mkApps f args : ~~ isBox f -> ~~ isBox (mkApps f args). Proof. destruct args using rev_case => //. rewrite mkApps_app /= //. Qed. +Lemma nisPrim_mkApps f args : ~~ isPrim f -> ~~ isPrim (mkApps f args). +Proof. destruct args using rev_case => //. rewrite mkApps_app /= //. Qed. Definition string_of_def {A : Set} (f : A -> string) (def : def A) := "(" ^ string_of_name (dname def) ^ "," ^ f (dbody def) ^ "," ^ string_of_nat (rarg def) ^ ")". +Definition maybe_string_of_list {A} f (l : list A) := match l with [] => "" | _ => string_of_list f l end. + Fixpoint string_of_term (t : term) : string := match t with | tBox => "∎" @@ -338,7 +352,7 @@ Fixpoint string_of_term (t : term) : string := | tLetIn na b t => "LetIn(" ^ string_of_name na ^ "," ^ string_of_term b ^ "," ^ string_of_term t ^ ")" | tApp f l => "App(" ^ string_of_term f ^ "," ^ string_of_term l ^ ")" | tConst c => "Const(" ^ string_of_kername c ^ ")" - | tConstruct i n => "Construct(" ^ string_of_inductive i ^ "," ^ string_of_nat n ^ ")" + | tConstruct i n args => "Construct(" ^ string_of_inductive i ^ "," ^ string_of_nat n ^ maybe_string_of_list string_of_term args ^ ")" | tCase (ind, i) t brs => "Case(" ^ string_of_inductive ind ^ "," ^ string_of_nat i ^ "," ^ string_of_term t ^ "," ^ string_of_list (fun b => string_of_term (snd b)) brs ^ ")" @@ -347,15 +361,17 @@ Fixpoint string_of_term (t : term) : string := ^ string_of_term c ^ ")" | tFix l n => "Fix(" ^ (string_of_list (string_of_def string_of_term) l) ^ "," ^ string_of_nat n ^ ")" | tCoFix l n => "CoFix(" ^ (string_of_list (string_of_def string_of_term) l) ^ "," ^ string_of_nat n ^ ")" - (* | tPrim p => "Prim(" ^ PCUICPrimitive.string_of_prim string_of_term p ^ ")" *) + | tPrim p => "Prim(" ^ PCUICPrimitive.string_of_prim string_of_term p ^ ")" end. (** Compute all the global environment dependencies of the term *) Fixpoint term_global_deps (t : EAst.term) := match t with - | EAst.tConst kn - | EAst.tConstruct {| inductive_mind := kn |} _ => KernameSet.singleton kn + | EAst.tConst kn => KernameSet.singleton kn + | EAst.tConstruct {| inductive_mind := kn |} _ args => + List.fold_left (fun acc x => KernameSet.union (term_global_deps x) acc) args + (KernameSet.singleton kn) | EAst.tLambda _ x => term_global_deps x | EAst.tApp x y | EAst.tLetIn _ x y => KernameSet.union (term_global_deps x) (term_global_deps y) diff --git a/erasure/theories/ECSubst.v b/erasure/theories/ECSubst.v index 7edceca5d..65a0695d3 100644 --- a/erasure/theories/ECSubst.v +++ b/erasure/theories/ECSubst.v @@ -36,6 +36,7 @@ Fixpoint csubst t k u := let k' := List.length mfix + k in let mfix' := List.map (map_def (csubst t k')) mfix in tCoFix mfix' idx + | tConstruct ind n args => tConstruct ind n (map (csubst t k) args) | x => x end. @@ -57,7 +58,7 @@ Proof. destruct (nth_error_spec [t] (n - k) ). simpl in l0; lia. now rewrite Nat.sub_1_r. - + now destruct (Nat.leb_spec k n); try lia. + + now destruct (Nat.leb_spec k n); try lia. Qed. Lemma substl_subst s u : forallb (closedn 0) s -> diff --git a/erasure/theories/ECoFixToFix.v b/erasure/theories/ECoFixToFix.v deleted file mode 100644 index 401644e9b..000000000 --- a/erasure/theories/ECoFixToFix.v +++ /dev/null @@ -1,23 +0,0 @@ -(* Distributed under the terms of the MIT license. *) -From Coq Require Import Program. -From MetaCoq.Template Require Import config utils. -From MetaCoq.PCUIC Require PCUICWcbvEval. -From MetaCoq.Erasure Require Import EAst EAstUtils ELiftSubst ECSubst EReflect EGlobalEnv. - -From Equations Require Import Equations. -Require Import ssreflect ssrbool. - -(** * Weak-head call-by-value evaluation strategy. - - The [wcbveval] inductive relation specifies weak cbv evaluation. It - is shown to be a subrelation of the 1-step reduction relation from - which conversion is defined. Hence two terms that reduce to the same - wcbv head normal form are convertible. - - This reduction strategy is supposed to mimick at the Coq level the - reduction strategy of ML programming languages. It is used to state - the extraction conjecture that can be applied to Coq terms to produce - (untyped) terms where all proofs are erased to a dummy value. *) - - -Local Ltac inv H := inversion H; subst. diff --git a/erasure/theories/EConstructorsAsBlocks.v b/erasure/theories/EConstructorsAsBlocks.v new file mode 100644 index 000000000..d77c23bea --- /dev/null +++ b/erasure/theories/EConstructorsAsBlocks.v @@ -0,0 +1,1173 @@ +(* Distributed under the terms of the MIT license. *) +From Coq Require Import Utf8 Program. +From MetaCoq.Template Require Import config utils Kernames BasicAst EnvMap. +From MetaCoq.Erasure Require Import EAst EAstUtils EInduction EArities + ELiftSubst ESpineView EGlobalEnv EWellformed EEnvMap + EWcbvEval EEtaExpanded ECSubst EWcbvEvalEtaInd EProgram. + +Local Open Scope string_scope. +Set Asymmetric Patterns. +Import MCMonadNotation. + +From Equations Require Import Equations. +Set Equations Transparent. +Local Set Keyed Unification. +From Coq Require Import ssreflect ssrbool. + +(** We assume [Prop size x < size y) := + | e with TermSpineView.view e := { + | tRel i => EAst.tRel i + | tEvar ev args => EAst.tEvar ev (map_InP args (fun x H => transform_blocks x)) + | tLambda na M => EAst.tLambda na (transform_blocks M) + | tApp u v napp nnil with construct_viewc u := + { | view_construct ind i block_args with GlobalContextMap.lookup_constructor_pars_args Σ ind i := { + | Some (npars, nargs) => + let args := map_InP v (fun x H => transform_blocks x) in + let '(args, rest) := MCList.chop nargs args in + EAst.mkApps (EAst.tConstruct ind i args) rest + | None => + let args := map_InP v (fun x H => transform_blocks x) in + EAst.tConstruct ind i args } + | view_other _ _ => mkApps (transform_blocks u) (map_InP v (fun x H => transform_blocks x)) } + + | tLetIn na b b' => EAst.tLetIn na (transform_blocks b) (transform_blocks b') + | tCase ind c brs => + let brs' := map_InP brs (fun x H => (x.1, transform_blocks x.2)) in + EAst.tCase (ind.1, 0) (transform_blocks c) brs' + | tProj p c => EAst.tProj {| proj_ind := p.(proj_ind); proj_npars := 0; proj_arg := p.(proj_arg) |} (transform_blocks c) + | tFix mfix idx => + let mfix' := map_InP mfix (fun d H => {| dname := dname d; dbody := transform_blocks d.(dbody); rarg := d.(rarg) |}) in + EAst.tFix mfix' idx + | tCoFix mfix idx => + let mfix' := map_InP mfix (fun d H => {| dname := dname d; dbody := transform_blocks d.(dbody); rarg := d.(rarg) |}) in + EAst.tCoFix mfix' idx + | tBox => EAst.tBox + | tVar n => EAst.tVar n + | tConst n => EAst.tConst n + | tConstruct ind i block_args => EAst.tConstruct ind i [] + | tPrim p => EAst.tPrim p }. + Proof. + all:try lia. + all:try apply (In_size); tea. + all:try lia. + - now apply (In_size id size). + - change (fun x => size (id x)) with size in H. + eapply (In_size id size) in H. unfold id in H. + change (fun x => size x) with size in H. + rewrite size_mkApps. cbn. lia. + - change (fun x => size (id x)) with size in H. + eapply (In_size id size) in H. unfold id in H. + change (fun x => size x) with size in H. + rewrite size_mkApps. cbn. lia. + - now eapply size_mkApps_f. + - change (fun x => size (id x)) with size in H. + eapply (In_size id size) in H. unfold id in H. + change (fun x => size x) with size in H. + pose proof (size_mkApps_l napp nnil). lia. + - eapply (In_size snd size) in H. cbn in *. lia. + Qed. + + End Def. + + Hint Rewrite @map_InP_spec : transform_blocks. + + Arguments eqb : simpl never. + + Opaque transform_blocks_unfold_clause_1. + Opaque transform_blocks. + Opaque isEtaExp. + Opaque isEtaExp_unfold_clause_1. + + + Lemma chop_firstn_skipn {A} n (l : list A) : chop n l = (firstn n l, skipn n l). + Proof using Type. + induction n in l |- *; destruct l; simpl; auto. + now rewrite IHn skipn_S. + Qed. + + Lemma chop_eq {A} n (l : list A) l1 l2 : chop n l = (l1, l2) -> l = l1 ++ l2. + Proof. + rewrite chop_firstn_skipn. intros [= <- <-]. + now rewrite firstn_skipn. + Qed. + + Lemma closed_transform_blocks t k : closedn k t -> closedn k (transform_blocks t). + Proof using Type. + funelim (transform_blocks t); simp transform_blocks; rewrite <-?transform_blocks_equation_1; toAll; simpl; + intros; try easy; + rewrite -> ?map_map_compose, ?compose_on_snd, ?compose_map_def, ?map_length; + unfold test_def in *; + simpl closed in *; + try solve [simpl; subst; simpl closed; f_equal; auto; rtoProp; solve_all; solve_all]; try easy. + - rewrite !closedn_mkApps in H1 *. + rtoProp; intuition auto. solve_all. + - destruct (chop nargs v) eqn:E. + erewrite chop_map; eauto. + eapply chop_eq in E as ->. + rewrite !closedn_mkApps in H0 *. + rtoProp; intuition auto; cbn; solve_all; eapply All_app in H1; + repeat solve_all. + - rewrite !closedn_mkApps /= in H0 *. rtoProp. + repeat solve_all. + Qed. + + Hint Rewrite @forallb_InP_spec : isEtaExp. + Transparent isEtaExp_unfold_clause_1. + + Transparent transform_blocks_unfold_clause_1. + + Local Lemma transform_blocks_mkApps f v : + ~~ isApp f -> + transform_blocks (mkApps f v) = match construct_viewc f with + | view_construct ind i block_args => + match lookup_constructor_pars_args Σ ind i with + | Some (npars, nargs) => + let args := map transform_blocks v in + let '(args, rest) := MCList.chop nargs args in + EAst.mkApps (EAst.tConstruct ind i args) rest + | None => + let args := map transform_blocks v in + EAst.tConstruct ind i args + end + | view_other _ _ => mkApps (transform_blocks f) (map transform_blocks v) + end. + Proof using Type. + intros napp; simp transform_blocks. + destruct (construct_viewc f) eqn:vc. + - destruct lookup_constructor_pars_args as [[]|] eqn:heq. + destruct v eqn:hargs. cbn. + * destruct n1 => //. + * set (v' := TermSpineView.view _). + destruct (TermSpineView.view_mkApps v') as [hf [vn eq]] => //. + rewrite eq /=. + rewrite GlobalContextMap.lookup_constructor_pars_args_spec. + rewrite heq /=. now simp transform_blocks. + * destruct v eqn:hargs => //. + set (v' := TermSpineView.view _). + destruct (TermSpineView.view_mkApps v') as [hf [vn eq]] => //. + rewrite eq /=. rewrite GlobalContextMap.lookup_constructor_pars_args_spec heq /=. + now simp transform_blocks. + - destruct v eqn:hargs => //. + simp transform_blocks. + set (v' := TermSpineView.view _). + destruct (TermSpineView.view_mkApps v') as [hf [vn eq]] => //. + rewrite eq /= vc /=. now simp transform_blocks. + Qed. + + Lemma transform_blocks_decompose f : + transform_blocks f = + let (fn, args) := decompose_app f in + match construct_viewc fn with + | view_construct kn c _ => + match lookup_constructor_pars_args Σ kn c with + | Some (npars, nargs) => + let args := map (transform_blocks) args in + let '(args, rest) := MCList.chop nargs args in + mkApps (tConstruct kn c args) rest + | None => + let args := map transform_blocks args in + tConstruct kn c args + end + | view_other fn nconstr => + mkApps (transform_blocks fn) (map transform_blocks args) + end. + Proof. + destruct (decompose_app f) eqn:da. + rewrite (decompose_app_inv da). rewrite transform_blocks_mkApps. + now eapply decompose_app_notApp. + destruct construct_viewc; try reflexivity. + Qed. + + Lemma transform_blocks_mkApps_eta (P : term -> Prop) fn args : + (* wf_glob Σ -> + *)~~ EAst.isApp fn -> + isEtaExp Σ (mkApps fn args) -> + (match construct_viewc fn with + | view_construct kn c block_args => + forall pars nargs, + lookup_constructor_pars_args Σ kn c = Some (pars, nargs) -> + let cargs := map transform_blocks args in + let '(cargs, rest) := MCList.chop nargs cargs in + P (mkApps (tConstruct kn c cargs) rest) + | view_other fn nconstr => + P (mkApps (transform_blocks fn) (map transform_blocks args)) + end) -> + P (transform_blocks (mkApps fn args)). + Proof. + intros napp. + move/isEtaExp_mkApps. + rewrite decompose_app_mkApps //. + destruct construct_viewc eqn:vc. + + rewrite /isEtaExp_app. + destruct lookup_constructor_pars_args as [[]|] eqn:hl. + rewrite transform_blocks_decompose decompose_app_mkApps // /= hl. + move=> /andP[] /andP[] /Nat.leb_le hargs etaargs bargs. + destruct block_args; invs bargs. + move/(_ _ _ eq_refl). + destruct chop eqn:eqch => //. + move => /andP[] => //. + + intros ht. rewrite transform_blocks_mkApps // vc //. + Qed. + + Lemma transform_blocks_mkApps_eta_fn f args : isEtaExp Σ f -> + transform_blocks (mkApps f args) = mkApps (transform_blocks f) (map (transform_blocks) args). + Proof. + intros ef. + destruct (decompose_app f) eqn:df. + rewrite (decompose_app_inv df) in ef |- *. + rewrite -mkApps_app. + move/isEtaExp_mkApps: ef. + pose proof (decompose_app_notApp _ _ _ df). + rewrite decompose_app_mkApps /= //. + rewrite transform_blocks_decompose. + rewrite decompose_app_mkApps /= //. + destruct (construct_viewc t) eqn:vc. + + move=> /andP[] etanl etal. + destruct lookup_constructor_pars_args as [[pars args']|] eqn:hl => //. + cbn. + rewrite chop_firstn_skipn. + rewrite transform_blocks_decompose. + rewrite decompose_app_mkApps // /= hl. + rewrite chop_firstn_skipn. + rewrite - mkApps_app. + move: etanl. rewrite /isEtaExp_app hl. + move => /andP[] /Nat.leb_le => hl' hall. + rewrite firstn_map. + rewrite firstn_app. + assert (args' - #|l| = 0) as -> by lia. + rewrite firstn_O // app_nil_r. f_equal. f_equal. + rewrite firstn_map //. rewrite map_app skipn_map. + rewrite skipn_app. len. + assert (args' - #|l| = 0) as -> by lia. + now rewrite skipn_0 -skipn_map. + move: etanl. rewrite /isEtaExp_app hl //. + + move => /andP[] etat etal. + rewrite (transform_blocks_decompose (mkApps t l)). + rewrite decompose_app_mkApps //. + rewrite vc. rewrite -mkApps_app. f_equal. + now rewrite map_app. + Qed. + + Lemma transform_blocks_csubst a k b : + closed a -> + isEtaExp Σ a -> + isEtaExp Σ b -> + transform_blocks (ECSubst.csubst a k b) = ECSubst.csubst (transform_blocks a) k (transform_blocks b). + Proof using Type. + intros cla etaa. move b at bottom. + funelim (transform_blocks b); cbn; simp transform_blocks isEtaExp; rewrite -?isEtaExp_equation_1 -?transform_blocks_equation_1; toAll; simpl; + intros; try easy; + rewrite -> ?map_map_compose, ?compose_on_snd, ?compose_map_def, ?map_length; + unfold test_def in *; + simpl closed in *; try solve [simpl subst; simpl closed; f_equal; auto; rtoProp; solve_all]; try easy. + + - destruct Nat.compare => //. + - f_equal. solve_all. move/andP: b => [] _ he. solve_all. + - rewrite csubst_mkApps. + rtoProp. solve_all. + assert ( + mkApps (transform_blocks u) (map transform_blocks v) = + transform_blocks (mkApps u v) + ) as ->. { rewrite transform_blocks_mkApps. eauto. now rewrite Heq. } + eapply (transform_blocks_mkApps_eta (fun x => transform_blocks (mkApps (csubst a k u) (map (csubst a k) v)) = + csubst (transform_blocks a) k x)); eauto. + rewrite Heq. + rewrite csubst_mkApps. + rewrite isEtaExp_mkApps_napp in H1 => //. rewrite Heq in H1. + rtoProp. rename H1 into etau. rename H2 into etav. + rewrite - H //. + rewrite transform_blocks_mkApps_eta_fn. + now eapply etaExp_csubst. + f_equal. + rewrite !map_map_compose. solve_all. + - assert (H1 := etaExp_csubst _ _ k _ etaa H0). + rewrite !csubst_mkApps /= in H1 *. + assert (map (csubst a k) v <> []). + { destruct v; cbn; congruence. } + rewrite transform_blocks_mkApps //. + rewrite isEtaExp_Constructor // in H1. + move: H1 => /andP[] /andP[]. rewrite map_length. move=> etaapp etav bargs. + destruct block_args; invs bargs. + cbn -[lookup_constructor_pars_args]. + rewrite GlobalContextMap.lookup_constructor_pars_args_spec in Heq. + unfold isEtaExp_app in etaapp. + rewrite Heq in etaapp |- *. + destruct (chop nargs v) eqn:heqc. + rewrite map_map_compose. + erewrite !chop_map; eauto. + rewrite csubst_mkApps. cbn. + eapply chop_eq in heqc as ->. + cbn. + rewrite isEtaExp_Constructor in H0. + move: H0 => /andP[] /andP[] He1 He2 He3. + cbn. f_equal. f_equal. + all: rewrite !map_map_compose; solve_all; eapply All_app in He2. + all: repeat solve_all. + - assert (H1 := etaExp_csubst _ _ k _ etaa H0). + rewrite !csubst_mkApps /= in H1 *. + assert (map (csubst a k) v <> []). + { destruct v; cbn; congruence. } + rewrite GlobalContextMap.lookup_constructor_pars_args_spec in Heq. + rewrite transform_blocks_mkApps //. + rewrite isEtaExp_Constructor // in H1. + move/andP : H1 => [] /andP[]. rewrite map_length. move=> etaapp etav bargs. + cbn -[lookup_inductive_pars]. + unfold isEtaExp_app in etaapp. + destruct lookup_constructor_pars_args as [[pars args]|] eqn:eqpars => //. + Qed. + + Lemma transform_blocks_substl s t : + forallb (closedn 0) s -> + forallb (isEtaExp Σ) s -> + isEtaExp Σ t -> + transform_blocks (substl s t) = substl (map transform_blocks s) (transform_blocks t). + Proof using Type. + induction s in t |- *; simpl; auto. + move=> /andP[] cla cls /andP[] etaa etas etat. + rewrite IHs //. now eapply etaExp_csubst. f_equal. + now rewrite transform_blocks_csubst. + Qed. + + Lemma transform_blocks_iota_red pars args br : + forallb (closedn 0) args -> + forallb (isEtaExp Σ) args -> + isEtaExp Σ br.2 -> + transform_blocks (EGlobalEnv.iota_red pars args br) = EGlobalEnv.iota_red pars (map transform_blocks args) (on_snd transform_blocks br). + Proof using Type. + intros cl etaargs etabr. + unfold EGlobalEnv.iota_red. + rewrite transform_blocks_substl //. + rewrite forallb_rev forallb_skipn //. + rewrite forallb_rev forallb_skipn //. + now rewrite map_rev map_skipn. + Qed. + + Lemma transform_blocks_fix_subst mfix : EGlobalEnv.fix_subst (map (map_def transform_blocks) mfix) = map transform_blocks (EGlobalEnv.fix_subst mfix). + Proof using Type. + unfold EGlobalEnv.fix_subst. + rewrite map_length. + generalize #|mfix|. + induction n; simpl; auto. + f_equal; auto. now simp transform_blocks. + Qed. + + Lemma transform_blocks_cofix_subst mfix : EGlobalEnv.cofix_subst (map (map_def transform_blocks) mfix) = map transform_blocks (EGlobalEnv.cofix_subst mfix). + Proof using Type. + unfold EGlobalEnv.cofix_subst. + rewrite map_length. + generalize #|mfix|. + induction n; simpl; auto. + f_equal; auto. now simp transform_blocks. + Qed. + + Lemma transform_blocks_cunfold_fix mfix idx n f : + forallb (closedn 0) (fix_subst mfix) -> + forallb (fun d => isLambda (dbody d) && isEtaExp Σ (dbody d)) mfix -> + cunfold_fix mfix idx = Some (n, f) -> + cunfold_fix (map (map_def transform_blocks) mfix) idx = Some (n, transform_blocks f). + Proof using Type. + intros hfix heta. + unfold cunfold_fix. + rewrite nth_error_map. + destruct nth_error eqn:heq. + intros [= <- <-] => /=. f_equal. f_equal. + rewrite transform_blocks_substl //. + now apply isEtaExp_fix_subst. + solve_all. eapply nth_error_all in heta; tea. cbn in heta. + rtoProp; intuition auto. + f_equal. f_equal. apply transform_blocks_fix_subst. + discriminate. + Qed. + + + Lemma transform_blocks_cunfold_cofix mfix idx n f : + forallb (closedn 0) (cofix_subst mfix) -> + forallb (isEtaExp Σ ∘ dbody) mfix -> + cunfold_cofix mfix idx = Some (n, f) -> + cunfold_cofix (map (map_def transform_blocks) mfix) idx = Some (n, transform_blocks f). + Proof using Type. + intros hcofix heta. + unfold cunfold_cofix. + rewrite nth_error_map. + destruct nth_error eqn:heq. + intros [= <- <-] => /=. f_equal. + rewrite transform_blocks_substl //. + now apply isEtaExp_cofix_subst. + solve_all. now eapply nth_error_all in heta; tea. + f_equal. f_equal. apply transform_blocks_cofix_subst. + discriminate. + Qed. + + Lemma transform_blocks_nth {n l d} : + transform_blocks (nth n l d) = nth n (map transform_blocks l) (transform_blocks d). + Proof using Type. + induction l in n |- *; destruct n; simpl; auto. + Qed. + + Definition switch_constructor_as_block fl : WcbvFlags := + EWcbvEval.Build_WcbvFlags fl.(@with_prop_case) fl.(@with_guarded_fix) true. + +End transform_blocks. + +Definition transform_blocks_constant_decl Σ cb := + {| cst_body := option_map (transform_blocks Σ) cb.(cst_body) |}. + +Definition transform_blocks_decl Σ d := + match d with + | ConstantDecl cb => ConstantDecl (transform_blocks_constant_decl Σ cb) + | InductiveDecl idecl => d + end. + +Definition transform_blocks_env Σ := + map (on_snd (transform_blocks_decl Σ)) Σ.(GlobalContextMap.global_decls). + +Definition transform_blocks_program (p : eprogram_env) := + (transform_blocks_env p.1, transform_blocks p.1 p.2). + +Definition switch_cstr_as_blocks (fl : EEnvFlags) := + {| has_axioms := has_axioms; + has_cstr_params := has_cstr_params; + term_switches := term_switches; + cstr_as_blocks := true |}. + +Definition block_wcbv_flags := + {| with_prop_case := false ; with_guarded_fix := false ; with_constructor_as_block := true |}. + +Local Hint Resolve wellformed_closed : core. + +Lemma wellformed_lookup_inductive_pars {efl : EEnvFlags} Σ kn mdecl : + has_cstr_params = false -> + wf_glob Σ -> + lookup_minductive Σ kn = Some mdecl -> mdecl.(ind_npars) = 0. +Proof. + intros hasp. + induction 1; cbn => //. + case: eqb_spec => [|]. + - intros ->. destruct d => //. intros [= <-]. + cbn in H0. unfold wf_minductive in H0. + rtoProp. cbn in H0. rewrite hasp in H0; now eapply eqb_eq in H0. + - intros _. eapply IHwf_glob. +Qed. + +Lemma wellformed_lookup_constructor_pars {efl : EEnvFlags} {Σ kn c mdecl idecl cdecl} : + has_cstr_params = false -> + wf_glob Σ -> + lookup_constructor Σ kn c = Some (mdecl, idecl, cdecl) -> mdecl.(ind_npars) = 0. +Proof. + intros hasp wf. cbn -[lookup_minductive]. + destruct lookup_minductive eqn:hl => //. + do 2 destruct nth_error => //. + eapply wellformed_lookup_inductive_pars in hl => //. congruence. +Qed. + +Lemma lookup_constructor_pars_args_spec {efl : EEnvFlags} {Σ ind n mdecl idecl cdecl} : + wf_glob Σ -> + lookup_constructor Σ ind n = Some (mdecl, idecl, cdecl) -> + lookup_constructor_pars_args Σ ind n = Some (mdecl.(ind_npars), cdecl.(cstr_nargs)). +Proof. + cbn -[lookup_constructor] => wfΣ. + destruct lookup_constructor as [[[mdecl' idecl'] [pars args]]|] eqn:hl => //. + intros [= -> -> <-]. cbn. f_equal. +Qed. + +Lemma wellformed_lookup_constructor_pars_args {efl : EEnvFlags} {Σ ind k n block_args} : + wf_glob Σ -> + has_cstr_params = false -> + wellformed Σ k (EAst.tConstruct ind n block_args) -> + ∑ args, lookup_constructor_pars_args Σ ind n = Some (0, args). +Proof. + intros wfΣ hasp wf. cbn -[lookup_constructor] in wf. + destruct lookup_constructor as [[[mdecl idecl] cdecl]|] eqn:hl => //. + exists cdecl.(cstr_nargs). + pose proof (wellformed_lookup_constructor_pars hasp wfΣ hl). + eapply lookup_constructor_pars_args_spec in hl => //. congruence. + destruct has_tConstruct => //. +Qed. + +Lemma constructor_isprop_pars_decl_params {efl : EEnvFlags} {Σ ind c b pars cdecl} : + has_cstr_params = false -> wf_glob Σ -> + constructor_isprop_pars_decl Σ ind c = Some (b, pars, cdecl) -> pars = 0. +Proof. + intros hasp hwf. + rewrite /constructor_isprop_pars_decl /lookup_constructor /lookup_inductive. + destruct lookup_minductive as [mdecl|] eqn:hl => /= //. + do 2 destruct nth_error => //. + eapply wellformed_lookup_inductive_pars in hl => //. congruence. +Qed. + +Lemma skipn_ge m {A} (l : list A) : + m >= length l -> skipn m l = []. +Proof. + induction l in m |- *. + - destruct m; reflexivity. + - cbn. destruct m; try lia. intros H. + eapply IHl. lia. +Qed. + +Lemma chop_all {A} (l : list A) m : + m >= length l -> chop m l = (l, nil). +Proof. + intros Hl. rewrite chop_firstn_skipn. + rewrite firstn_ge; try lia. rewrite skipn_ge; try lia. + eauto. +Qed. + +Lemma transform_blocks_tApp (efl : EEnvFlags) {Σ : GlobalContextMap.t} t a (P : term -> Set) k : + has_cstr_params = false -> + wf_glob Σ -> + wellformed Σ k (tApp t a) -> + (let (fn, args) := decompose_app (tApp t a) in + match construct_viewc fn with + | view_construct kn c block_args => + match GlobalContextMap.lookup_constructor_pars_args Σ kn c with + | Some (0, nargs) => + let cargs := map (transform_blocks Σ) args in + let '(cargs, rest) := MCList.chop nargs cargs in + (args <> [] /\ t = mkApps (tConstruct kn c block_args) (remove_last args) /\ a = last args a) -> + P (mkApps (tConstruct kn c cargs) rest) + | _ => True + end + | view_other fn nconstr => + P (tApp (transform_blocks Σ t) (transform_blocks Σ a)) + end) -> + P (transform_blocks Σ (tApp t a)). +Proof. + intros haspars wfΣ wf. + rewrite (transform_blocks_decompose _ (tApp t a)). + destruct decompose_app eqn:da. + pose proof (decompose_app_notApp _ _ _ da). + pose proof (EInduction.decompose_app_app _ _ _ _ da). + destruct construct_viewc eqn:vc. + + eapply EEtaExpandedFix.decompose_app_tApp_split in da as [Ha Ht]. + cbn in wf. + move: wf => /andP[]. move/andP=> [haapp]. rewrite Ha wellformed_mkApps // => /andP[] wfc wfl wft. + rewrite GlobalContextMap.lookup_constructor_pars_args_spec. + destruct (wellformed_lookup_constructor_pars_args wfΣ haspars wfc). + rewrite e. cbn. + destruct chop eqn:eqch => //. + intros. apply H1. intuition auto. + + pose proof (decompose_app_notApp _ _ _ da). + pose proof (EInduction.decompose_app_app _ _ _ _ da). + eapply EEtaExpandedFix.decompose_app_tApp_split in da as [Ha Ht]. + rewrite Ha Ht. + rewrite transform_blocks_mkApps // vc. + rewrite {3} (remove_last_last l a) => //. + now rewrite map_app mkApps_app. +Qed. + +Lemma eval_mkApps_Construct_inv {fl : WcbvFlags} Σ kn c args e block_args mdecl idecl cdecl : + with_constructor_as_block = false -> + lookup_constructor Σ kn c = Some (mdecl, idecl, cdecl) -> + eval Σ (mkApps (tConstruct kn c block_args) args) e -> + ∑ args', (e = mkApps (tConstruct kn c []) args') × All2 (eval Σ) args args' × block_args = [] × #|args| <= cstr_arity mdecl cdecl. +Proof. + intros hblock hlook. + revert e; induction args using rev_ind; intros e. + - intros ev. depelim ev. congruence. exists []=> //. invs i. destruct block_args; invs H0 => //. cbn. repeat split. econstructor. lia. + - intros ev. rewrite mkApps_app /= in ev. + depelim ev; try solve_discr. + destruct (IHargs _ ev1) as [? []]. solve_discr. + all:try specialize (IHargs _ ev1) as [? []]; try solve_discr; try noconf H. + * destruct p as (? & ? & ?). exists (x0 ++ [a']). split => //. + rewrite mkApps_app /= //. split => //. eapply All2_app; eauto. + split => //. eapply All2_length in a. len. rewrite e1 in hlook; invs hlook. lia. + * destruct p as (? & ? & ?). subst f'. + cbn in i. + rewrite isConstructApp_mkApps in i. cbn in i. + rewrite orb_true_r in i. cbn in i. congruence. + * now cbn in i. +Qed. + +Lemma transform_blocks_isConstructApp {efl : EEnvFlags} {Σ : GlobalContextMap.t} t : + has_cstr_params = false -> + wf_glob Σ -> wellformed Σ 0 t -> + isConstructApp (transform_blocks Σ t) = isConstructApp t. +Proof. + intros haspars Hwf Hwf'. + induction t; try now cbn; eauto. + eapply transform_blocks_tApp; eauto. + destruct decompose_app. + destruct construct_viewc. + - rewrite GlobalContextMap.lookup_constructor_pars_args_spec. + destruct lookup_constructor_pars_args as [ [[]] | ]; eauto. + cbn. destruct chop. intros (? & ? & ?). subst. + rewrite -[tApp _ _](mkApps_app _ _ [t2]). + rewrite !isConstructApp_mkApps. cbn. reflexivity. + - change (tApp t1 t2) with (mkApps t1 [t2]). + change (tApp (transform_blocks Σ t1) (transform_blocks Σ t2)) with + (mkApps (transform_blocks Σ t1) [transform_blocks Σ t2]). + rewrite !isConstructApp_mkApps. + eapply IHt1. cbn in Hwf'. rtoProp. intuition. +Qed. + +Lemma transform_blocks_isPrimApp {efl : EEnvFlags} {Σ : GlobalContextMap.t} t : + has_cstr_params = false -> + wf_glob Σ -> wellformed Σ 0 t -> + isPrimApp (transform_blocks Σ t) = isPrimApp t. +Proof. + intros haspars Hwf Hwf'. + induction t; try now cbn; eauto. + eapply transform_blocks_tApp; eauto. + destruct decompose_app. + destruct construct_viewc. + - rewrite GlobalContextMap.lookup_constructor_pars_args_spec. + destruct lookup_constructor_pars_args as [ [[]] | ]; eauto. + cbn. destruct chop. intros (? & ? & ?). subst. + rewrite -[tApp _ _](mkApps_app _ _ [t2]). + rewrite !isPrimApp_mkApps. cbn. reflexivity. + - change (tApp t1 t2) with (mkApps t1 [t2]). + change (tApp (transform_blocks Σ t1) (transform_blocks Σ t2)) with + (mkApps (transform_blocks Σ t1) [transform_blocks Σ t2]). + rewrite !isPrimApp_mkApps. + eapply IHt1. cbn in Hwf'. rtoProp. intuition. +Qed. + +Lemma lookup_env_transform_blocks {Σ : GlobalContextMap.t} kn : + lookup_env (transform_blocks_env Σ) kn = + option_map (transform_blocks_decl Σ) (lookup_env Σ kn). +Proof. + unfold transform_blocks_env. + destruct Σ as [Σ ? ? ?]; cbn. + induction Σ at 2 4; simpl; auto. + case: eqb_spec => //. +Qed. + +Lemma transform_blocks_declared_constant {Σ : GlobalContextMap.t} c decl : + declared_constant Σ c decl -> + declared_constant (transform_blocks_env Σ) c (transform_blocks_constant_decl Σ decl). +Proof. + intros H. red in H; red. + rewrite lookup_env_transform_blocks H //. +Qed. + +Lemma lookup_constructor_transform_blocks Σ ind c : + lookup_constructor (transform_blocks_env Σ) ind c = + lookup_constructor Σ ind c. +Proof. + unfold lookup_constructor, lookup_inductive, lookup_minductive in *. + rewrite lookup_env_transform_blocks. + destruct lookup_env as [ [] | ]; cbn; congruence. +Qed. + +Lemma isLambda_transform_blocks Σ c : isLambda c -> isLambda (transform_blocks Σ c). +Proof. destruct c => //. Qed. + +Lemma transform_wellformed' {efl : EEnvFlags} {Σ : GlobalContextMap.t} n t : + has_cstr_params = false -> + cstr_as_blocks = false -> + has_tApp -> + wf_glob Σ -> + @wellformed efl Σ n t -> + isEtaExp Σ t -> + @wellformed (switch_cstr_as_blocks efl) Σ n (transform_blocks Σ t). +Proof. + intros hasp cstrbl hasa. + revert n. funelim (transform_blocks Σ t); simp_eta; cbn -[transform_blocks + lookup_inductive lookup_constructor lookup_constructor_pars_args + GlobalContextMap.lookup_constructor_pars_args isEtaExp]; intros m Hwf Hw; rtoProp; try split; eauto. + all: rewrite ?map_InP_spec; toAll; eauto; try now solve_all. + - rewrite cstrbl in H0. destruct H2. unfold isEtaExp_app in H2. unfold lookup_constructor_pars_args in *. + destruct (lookup_constructor Σ) as [[[]] | ]; try congruence; cbn - [transform_blocks]. + 2: eauto. split; auto. cbn in H2. eapply Nat.leb_le in H2. + apply/eqb_spec. lia. + - destruct H5. solve_all. solve_all. + - unfold wf_fix in *. rtoProp. solve_all. solve_all. now eapply isLambda_transform_blocks. + - unfold wf_fix in *. rtoProp. solve_all. + len. solve_all. len. destruct x. + cbn -[transform_blocks isEtaExp] in *. rtoProp. eauto. + - unfold wf_fix in *. len. solve_all. rtoProp; intuition auto. + solve_all. + - rewrite !wellformed_mkApps in Hw |- * => //. rtoProp. intros. + eapply isEtaExp_mkApps in H3. rewrite decompose_app_mkApps in H3; eauto. + destruct construct_viewc; eauto. cbn in d. eauto. + rtoProp. eauto. repeat solve_all. + - Opaque isEtaExp. destruct chop eqn:Ec. rewrite !wellformed_mkApps in Hw |- * => //. rtoProp. + rewrite GlobalContextMap.lookup_constructor_pars_args_spec in Heq. + cbn -[lookup_constructor transform_blocks ] in *. intros. rtoProp. + rewrite isEtaExp_Constructor in H2. + rtoProp. unfold isEtaExp_app in *. unfold lookup_constructor_pars_args in H2. + repeat split; eauto; + rewrite ?lookup_constructor_transform_blocks; eauto. + * destruct lookup_constructor as [ [[]] | ] eqn:E; cbn -[transform_blocks] in *; eauto. + invs Heq. rewrite chop_firstn_skipn in Ec. invs Ec. + rewrite firstn_length. len. eapply Nat.leb_le in H2. + apply/eqb_spec. + assert (ind_npars m0 = 0). + { destruct lookup_env as [ [] | ] eqn:E'; try congruence. + eapply lookup_env_wellformed in E'; eauto. + cbn in E'. red in E'. unfold wf_minductive in E'. + rewrite andb_true_iff in E'. + cbn in E'. destruct E'. + rewrite hasp in H7. eapply Nat.eqb_eq in H7. + destruct nth_error; invs E. + now destruct nth_error; invs H10. } + lia. + * rewrite chop_firstn_skipn in Ec. invs Ec. + solve_all. eapply All_firstn. solve_all. + * rewrite chop_firstn_skipn in Ec. invs Ec. + solve_all. eapply All_skipn. solve_all. + - rewrite wellformed_mkApps in Hw; eauto. rtoProp. cbn in *. rtoProp. + cbn in *. destruct lookup_env as [[] | ]; cbn in *; eauto; try congruence. + - rewrite isEtaExp_Constructor in H0. rtoProp. + rewrite GlobalContextMap.lookup_constructor_pars_args_spec in Heq; unfold lookup_constructor_pars_args in *. + destruct lookup_constructor as [ [[]] | ]; cbn in Heq; try congruence. + cbn. split; eauto. rewrite wellformed_mkApps in Hw; eauto. rtoProp. solve_all. +Qed. + +Lemma transform_wellformed_decl' {efl : EEnvFlags} {Σ : GlobalContextMap.t} d : + has_cstr_params = false -> + cstr_as_blocks = false -> + has_tApp -> + wf_glob Σ -> + @wf_global_decl efl Σ d -> + isEtaExp_decl Σ d -> + @wf_global_decl (switch_cstr_as_blocks efl) Σ (transform_blocks_decl Σ d). +Proof. + intros wf wfd etad. + destruct d => //=. cbn. + destruct c as [[]] => //=. + eapply transform_wellformed'; tea. +Qed. + +From MetaCoq.Erasure Require Import EGenericMapEnv. + +Lemma transform_blocks_extends {efl : EEnvFlags} : + has_tApp -> + ∀ (Σ : GlobalContextMap.t) (t : term) (n : nat), + wellformed Σ n t + → ∀ Σ' : GlobalContextMap.t, + extends Σ Σ' + → wf_glob Σ' → transform_blocks Σ t = transform_blocks Σ' t. +Proof. + intros hasapp Σ t. + Opaque transform_blocks. + funelim (transform_blocks Σ t); cbn -[lookup_constant lookup_inductive + lookup_projection]; intros => //; simp transform_blocks; rewrite -?transform_blocks_equation_1. + all: try rewrite !map_InP_spec. + all: try toAll. + all: try f_equal. + all: rtoProp; solve_all. + - f_equal. eauto. solve_all. + - unfold wf_fix in *. rtoProp. f_equal. solve_all. + - unfold wf_fix in *. rtoProp. f_equal. solve_all. + - f_equal. eauto. rewrite wellformed_mkApps in H1 => //. rtoProp. + rewrite transform_blocks_mkApps; eauto. destruct construct_viewc; cbn in d; eauto. + f_equal. eapply H; eauto. solve_all. + - destruct chop eqn:E. + rewrite GlobalContextMap.lookup_constructor_pars_args_spec in Heq. + rewrite wellformed_mkApps in H0 => //. rewrite transform_blocks_mkApps => //. + rtoProp. cbn [construct_viewc]. unfold lookup_constructor_pars_args in *. + destruct (lookup_constructor Σ) as [ [[]] | ] eqn:E'; invs Heq. + erewrite extends_lookup_constructor; eauto. cbn. + destruct (chop (cstr_nargs c) (map (transform_blocks Σ') v) ) eqn:Ec. + rewrite !chop_firstn_skipn in E, Ec. invs E. invs Ec. + f_equal. f_equal. f_equal. solve_all. f_equal. solve_all. + - rewrite wellformed_mkApps in H0 => //. + rewrite GlobalContextMap.lookup_constructor_pars_args_spec in Heq. + cbn -[lookup_constructor] in H0. rtoProp. + unfold lookup_constructor_pars_args in Heq. + destruct lookup_constructor as [ [[]] | ]; cbn in *; try congruence. +Qed. + + +Lemma transform_blocks_decl_extends {efl : EEnvFlags} : + has_tApp -> + ∀ (Σ : GlobalContextMap.t) t, + wf_global_decl Σ t + → ∀ Σ' : GlobalContextMap.t, + extends Σ Σ' + → wf_glob Σ' → transform_blocks_decl Σ t = transform_blocks_decl Σ' t. +Proof. + intros. + destruct t => //=. f_equal. + destruct c as [[]] => //=. + unfold transform_blocks_constant_decl. cbn. + do 2 f_equal. + eapply transform_blocks_extends; tea. + eapply H0. +Qed. + +Lemma transform_wellformed {efl : EEnvFlags} {Σ : GlobalContextMap.t} n t : + has_cstr_params = false -> + cstr_as_blocks = false -> + has_tApp -> + wf_glob Σ -> + @wellformed efl Σ n t -> + isEtaExp Σ t -> + @wellformed (switch_cstr_as_blocks efl) (transform_blocks_env Σ) n (transform_blocks Σ t). +Proof. + intros. eapply gen_transform_wellformed_irrel; eauto. + eapply transform_wellformed'; eauto. +Qed. + +(*Lemma optimize_wellformed_decl_irrel {efl : EEnvFlags} {Σ : GlobalContextMap.t} d : + wf_glob Σ -> + wf_global_decl (efl := env_flags) Σ d -> + wf_global_decl (efl := env_flags_blocks) (transform_blocks_env Σ) d. +Proof. + intros wf; destruct d => /= //. + destruct (cst_body c) => /= //. + intros wf'. eapply transform_wellformed. +Qed. *) + +Lemma optimize_decl_wf {efl : EEnvFlags} {Σ : GlobalContextMap.t} : + has_cstr_params = false -> + cstr_as_blocks = false -> + has_tApp -> + wf_glob (efl := efl) Σ -> + forall d, + wf_global_decl (efl := efl) Σ d -> + isEtaExp_decl Σ d -> + wf_global_decl (efl := switch_cstr_as_blocks efl) (transform_blocks_env Σ) (transform_blocks_decl Σ d). +Proof. + intros hasp cstrbl hasapp wf d. + destruct d => /= //. + rewrite /isEtaExp_constant_decl. + destruct (cst_body c) => /= //. + intros hwf etat. eapply transform_wellformed => //. +Qed. + +Lemma fresh_global_optimize_env {Σ : GlobalContextMap.t} kn : + fresh_global kn Σ -> + fresh_global kn (transform_blocks_env Σ). +Proof. + destruct Σ as [Σ map repr wf]; cbn in *. + induction 1; cbn; constructor; auto. + now eapply Forall_map; cbn. +Qed. + +Lemma fresh_global_map_on_snd Σ f kn : + fresh_global kn Σ -> + fresh_global kn (map (on_snd f) Σ). +Proof. + induction 1; cbn; constructor; auto. +Qed. + +Lemma transform_wf_global {efl : EEnvFlags} {Σ : GlobalContextMap.t} : + has_cstr_params = false -> + cstr_as_blocks = false -> + has_tApp -> + EEtaExpanded.isEtaExp_env Σ -> + wf_glob (efl := efl) Σ -> wf_glob (efl := switch_cstr_as_blocks efl) (transform_blocks_env Σ). +Proof. + intros hasp cstrbl hasapp etag wfg. + destruct Σ as [Σ map repr wf]; cbn in *. + revert etag wfg. + assert (extends Σ Σ). now exists []. + revert H. + revert repr wf. generalize Σ at 1 2 4 6 7. + induction Σ; cbn; constructor; auto. + - eapply IHΣ; rtoProp; intuition auto. destruct H. subst Σ0. exists (x ++ [a]). now rewrite -app_assoc. + - set (Σm := {| GlobalContextMap.global_decls := _ |}). + clear IHΣ. + epose proof (EExtends.extends_wf_glob _ H wfg); tea. + depelim H0. + set (Σm' := GlobalContextMap.make Σ (wf_glob_fresh _ H0)). + pose proof (transform_blocks_decl_extends hasapp Σm' _ H1 Σm). + forward H3. cbn. destruct H. subst Σ0. exists (x ++ [(kn, d)]). now rewrite -app_assoc. + specialize (H3 wfg). rewrite -H3. + move/andP: etag => [etad etag]. + unshelve epose proof (@transform_wellformed_decl' _ Σm' d _ _ _ H0 H1 etad); tea. + cbn in H4. unfold Σm. + eapply gen_transform_wellformed_decl_irrel; trea. + - eapply fresh_global_map_on_snd. + eapply EExtends.extends_wf_glob in wfg; tea. now depelim wfg. +Qed. + +Transparent transform_blocks. + +Lemma fst_decompose_app_rec t l : fst (decompose_app_rec t l) = fst (decompose_app t). +Proof. + induction t in l |- *; simpl; auto. rewrite IHt1. + unfold decompose_app. simpl. now rewrite (IHt1 [t2]). +Qed. + +Lemma head_tapp t1 t2 : head (tApp t1 t2) = head t1. +Proof. rewrite /head /decompose_app /= fst_decompose_app_rec //. Qed. +Lemma tApp_mkApps f a : tApp f a = mkApps f [a]. +Proof. reflexivity. Qed. + +Lemma transform_blocks_eval {efl : EEnvFlags} (fl := EWcbvEval.target_wcbv_flags) : + cstr_as_blocks = false -> + has_cstr_params = false -> + has_tApp -> + forall (Σ : GlobalContextMap.t), isEtaExp_env Σ -> @wf_glob efl Σ -> + forall t t', + @wellformed efl Σ 0 t -> + isEtaExp Σ t -> + EWcbvEval.eval Σ t t' -> + @EWcbvEval.eval block_wcbv_flags (transform_blocks_env Σ) (transform_blocks Σ t) (transform_blocks Σ t'). +Proof. + intros cstrbl haspars hasapp Σ etaΣ wfΣ. + eapply + (EWcbvEvalEtaInd.eval_preserve_mkApps_ind fl eq_refl (efl := efl) Σ _ + (wellformed Σ) (Qpres := Qpreserves_wellformed efl _ cstrbl wfΣ)) => //; eauto. + { intros. eapply EWcbvEval.eval_wellformed => //; tea. } + all:intros *. + - intros; repeat match goal with [H : MCProd.and5 _ _ _ _ _ |- _] => destruct H end. + eapply transform_blocks_tApp; eauto. { cbn. rtoProp; eauto. } + destruct decompose_app as [fn args] eqn:heq. + destruct construct_viewc eqn:heqv. + + rewrite GlobalContextMap.lookup_constructor_pars_args_spec; + destruct lookup_constructor_pars_args as [[[] args']|] => // /=. + destruct chop eqn:eqch. + intros [Hl [ha ht]]. rewrite ha in H. + destruct with_constructor_as_block eqn:E. + * eapply eval_mkApps_Construct_block_inv in H as (args'' & Ha1 & Ha2 & Ha3); eauto. congruence. + * rewrite ha in i3. rewrite wellformed_mkApps in i3; eauto. rtoProp. cbn [wellformed] in H0. + rtoProp. destruct lookup_constructor as [ [[]] | ] eqn:hel; cbn in H4; try congruence. + eapply eval_mkApps_Construct_inv in H as (args'' & Ha1 & Ha2 & -> & ?); eauto. + solve_discr. + + econstructor; tea. + - intros; repeat match goal with [H : MCProd.and5 _ _ _ _ _ |- _] => destruct H end. + eapply transform_blocks_tApp; eauto. cbn. rtoProp; eauto. + destruct decompose_app as [fn args] eqn:heq. + destruct construct_viewc eqn:heqv. + + rewrite GlobalContextMap.lookup_constructor_pars_args_spec; + destruct lookup_constructor_pars_args as [[] |] => // /=. + destruct n0; eauto. + destruct chop eqn:eqch. + intros [Hl [ha ht]]. rewrite ha in H. + destruct with_constructor_as_block eqn:E. + * eapply eval_mkApps_Construct_block_inv in H as (args'' & Ha1 & Ha2 & Ha3); eauto. congruence. + * rewrite ha in i7. rewrite wellformed_mkApps in i7; eauto. rtoProp. cbn [wellformed] in H0. + rtoProp. destruct lookup_constructor as [ [[]] | ] eqn:hel; cbn in H5; try congruence. + eapply eval_mkApps_Construct_inv in H as (args'' & Ha1 & Ha2 & -> & ?); eauto. + solve_discr. + + econstructor. + * revert e1. set (x := transform_blocks Σ f0). + simp transform_blocks. + * eauto. + * rewrite transform_blocks_csubst in e; eauto. + 1: now simp_eta in i10. + now rewrite - transform_blocks_equation_1. + - intros; repeat match goal with [H : MCProd.and5 _ _ _ _ _ |- _] => destruct H end. + simp transform_blocks. rewrite -!transform_blocks_equation_1. + econstructor; eauto. + rewrite -transform_blocks_csubst; eauto. + - intros; repeat match goal with [H : MCProd.and5 _ _ _ _ _ |- _] => destruct H end. + simp transform_blocks. rewrite -!transform_blocks_equation_1. + cbn [plus]. + rewrite transform_blocks_mkApps in e0 => //. + assert (pars = 0) as -> by now (eapply constructor_isprop_pars_decl_params; eauto). + cbn [construct_viewc] in e0. + pose proof (Hcon := H2). + rewrite /constructor_isprop_pars_decl in H2. + destruct lookup_constructor as [[[]] | ] eqn:eqc; cbn in H2; invs H2. + rewrite -> lookup_constructor_pars_args_cstr_arity with (1 := eqc) in e0. + erewrite chop_all in e0. 2:len. + eapply eval_iota_block => //. + + cbn [fst]. eapply e0. + + unfold constructor_isprop_pars_decl. + rewrite lookup_constructor_transform_blocks. cbn [fst]. + rewrite eqc //= H8 //. + + now rewrite map_InP_spec nth_error_map H3; eauto. + + len. + + rewrite H9. len. + + rewrite wellformed_mkApps in i4 => //. + rewrite isEtaExp_Constructor in i6 => //. rtoProp. + rewrite -transform_blocks_iota_red. + * solve_all. + * solve_all. + * eapply forallb_nth_error in H. rewrite -> H3 in H => //. + * now rewrite H9. + - intros; repeat match goal with [H : MCProd.and5 _ _ _ _ _ |- _] => destruct H end. + eapply transform_blocks_tApp; eauto. eauto; cbn; rtoProp; eauto. + destruct decompose_app as [ f args] eqn:heq. + destruct construct_viewc eqn:heqv. + + rewrite GlobalContextMap.lookup_constructor_pars_args_spec; + destruct lookup_constructor_pars_args as [[] |] => // /=. + destruct n0; eauto. + destruct chop eqn:eqch. + intros [Hl [ha ht]]. rewrite ha in H0. + destruct with_constructor_as_block eqn:E. + * eapply eval_mkApps_Construct_block_inv in H0 as (args'' & Ha1 & Ha2 & Ha3); eauto. congruence. + * rewrite ha in i7. rewrite wellformed_mkApps in i7; eauto. rtoProp. cbn [wellformed] in H1. + rtoProp. destruct lookup_constructor as [ [[]] | ] eqn:hel; cbn in H9; try congruence. + eapply eval_mkApps_Construct_inv in H0 as (args'' & Ha1 & Ha2 & -> & ?); eauto. + solve_discr. + + eapply eval_fix'. + * eauto. + * revert e1. set (x := transform_blocks Σ f5). + simp transform_blocks. + * rewrite map_InP_spec. + cbn in i8. unfold wf_fix in i8. rtoProp. + erewrite <- transform_blocks_cunfold_fix => //. + all: eauto. + eapply closed_fix_subst. solve_all. destruct x; cbn in H5 |- *. eauto. + simp_eta in i10. + * eauto. + * revert e. + eapply transform_blocks_tApp => //. + -- cbn. rtoProp. split; eauto. split; eauto. eapply wellformed_cunfold_fix; eauto. + -- destruct (decompose_app (tApp fn av)) eqn:E; eauto. + destruct (construct_viewc t0) eqn:E1; eauto. + rewrite GlobalContextMap.lookup_constructor_pars_args_spec; + destruct (lookup_constructor_pars_args Σ ind n) as [ [[ ]] | ] eqn:E2; eauto. + cbn zeta. destruct chop eqn:E3. intros (? & ? & ?). + subst. rewrite -> H7 in *. intros He. + eapply eval_mkApps_Construct_block_inv in He as (? & ? & ? & ?); eauto. subst. + rewrite -[tApp _ _](mkApps_app _ _ [last l av]) in i1. + rewrite H7 - remove_last_last in i1 => //. + rewrite isEtaExp_Constructor in i1. rtoProp. + rewrite isEtaExp_Constructor in H3. rtoProp. + unfold isEtaExp_app in *. + rewrite E2 in H3, H5. + eapply leb_complete in H3, H5. + exfalso. + enough (n0 >= #|l|). + { destruct l; try congruence. rewrite remove_last_length in H3. cbn in H5, H3, H13. lia. } + destruct (chop n0 l) eqn:Ec. + erewrite chop_map in E3 => //. 2: eauto. + inversion E3. subst. destruct l2; invs H15. + rewrite chop_firstn_skipn in Ec. invs Ec. + eapply PCUICSR.skipn_nil_length in H15. lia. + - simp transform_blocks. rewrite -!transform_blocks_equation_1. + rewrite transform_blocks_mkApps //=. + simp transform_blocks. rewrite -!transform_blocks_equation_1. + rewrite !map_InP_spec. cbn [plus]. + intros. + destruct H3 as [ev wf eta etad]. + destruct H6. + move: eta; rewrite wellformed_mkApps //. + move => /andP[] wfcof wfargs. + eapply eval_cofix_case; tea. + erewrite transform_blocks_cunfold_cofix; trea. + eapply closed_cofix_subst. now eapply wellformed_closed in wfcof. + rewrite isEtaExp_mkApps_napp //= in i. move/andP: i => [] etacof etaargs. now simp_eta in etacof. + now rewrite transform_blocks_mkApps_eta_fn in e. + - intros; repeat match goal with [H : MCProd.and5 _ _ _ _ _ |- _] => destruct H end. + rewrite transform_blocks_mkApps //= in e0. + simp transform_blocks in e0. rewrite -!transform_blocks_equation_1 map_InP_spec in e0. simpl in e0. + simp transform_blocks. rewrite -!transform_blocks_equation_1. + move: i; rewrite /= wellformed_mkApps //. move/and3P => [] hasp wffn wfargs. + move: i4; rewrite /= wellformed_mkApps //. move/andP => [] wfcof _. + move: i6 => /=; simp_eta. rewrite isEtaExp_mkApps_napp //=. move=> /andP[] etacof etaargs. + econstructor; tea. + erewrite transform_blocks_cunfold_cofix; trea. + eapply closed_cofix_subst. now eapply wellformed_closed in wfcof. + now simp_eta in etacof. + simp transform_blocks in e. rewrite -!transform_blocks_equation_1 in e. + now rewrite transform_blocks_mkApps_eta_fn in e. + - intros; repeat match goal with [H : MCProd.and5 _ _ _ _ _ |- _] => destruct H end. + econstructor. + eapply transform_blocks_declared_constant; eauto. + destruct decl. cbn in *. now rewrite H0. + eauto. + - intros; repeat match goal with [H : MCProd.and5 _ _ _ _ _ |- _] => destruct H end. + rewrite transform_blocks_mkApps //= in e0. + simp transform_blocks in e0; rewrite -!transform_blocks_equation_1 in e0. + simp transform_blocks; rewrite -!transform_blocks_equation_1. + move: i4; rewrite wellformed_mkApps // => /andP[] /= /andP[] /andP[] hasc hl; + rewrite cstrbl => _ wfargs. + destruct lookup_constructor as [[[mdecl idecl] cdecl']|] eqn:hc => //. + rewrite (constructor_isprop_pars_decl_constructor hc) in H2. noconf H2. + rewrite (lookup_constructor_pars_args_cstr_arity _ _ _ _ _ _ hc) in e0. + assert (ind_npars mdecl = 0). + { eapply wellformed_lookup_constructor_pars; tea. } + rewrite chop_all in e0. len. + simpl in e0. + eapply eval_proj_block => //; tea. cbn. + + unfold constructor_isprop_pars_decl. + rewrite lookup_constructor_transform_blocks. cbn [fst]. + rewrite hc //= H1 H6. reflexivity. + + len. + + rewrite nth_error_map /=. rewrite H6 in H2; rewrite -H2 in H4; rewrite H4; eauto. + - intros; repeat match goal with [H : MCProd.and5 _ _ _ _ _ |- _] => destruct H end. + eapply transform_blocks_tApp; eauto. cbn; rtoProp; eauto. + destruct decompose_app as [f args] eqn:heq. + destruct construct_viewc eqn:heqv. + + rewrite GlobalContextMap.lookup_constructor_pars_args_spec; + destruct lookup_constructor_pars_args as [[npars args']|] eqn:hl => // /=. + destruct npars; eauto. + destruct chop eqn:eqch. + intros [Hl [ha ht]]. pose proof ev as Hev. rewrite ha in Hev. + destruct with_constructor_as_block eqn:E. + * eapply eval_mkApps_Construct_block_inv in Hev as (args'' & Ha1 & Ha2 & Ha3); eauto. subst. + destruct args as [ | []]; cbn in *; congruence. + * rewrite ha in i3. rewrite wellformed_mkApps in i3; eauto. rtoProp. cbn [wellformed] in H. + rtoProp. destruct lookup_constructor as [ [[]] | ] eqn:hel; cbn in H6; try congruence. + eapply eval_mkApps_Construct_inv in Hev as (args'' & Ha1 & Ha2 & -> & ?); eauto. subst. + rewrite isConstructApp_mkApps in H1. rewrite orb_true_r in H1 => //. + + eapply transform_blocks_tApp; eauto. cbn; rtoProp; eauto. + destruct (decompose_app (tApp f' a')). destruct (construct_viewc t0). + * rewrite GlobalContextMap.lookup_constructor_pars_args_spec; + destruct lookup_constructor_pars_args as [ [[]] | ] eqn:hpa; eauto. + cbn [plus]. destruct chop eqn:heqch. + intros [hl [ht ha]]. rewrite ht in H1. rewrite isConstructApp_mkApps isPrimApp_mkApps orb_true_r in H1 => //. + * eapply eval_app_cong; eauto. + revert H1. + destruct f'; try now cbn; tauto. + intros H. cbn in H. + rewrite transform_blocks_isConstructApp; eauto. + rewrite transform_blocks_isPrimApp; eauto. + rewrite negb_or in H. move/andP: H => [] ncstr nprim. + destruct (isConstructApp (tApp f'1 f'2)) eqn:heq'. + -- cbn in ncstr. congruence. + -- eapply transform_blocks_tApp; eauto. clear -nprim. + destruct decompose_app. + destruct construct_viewc; try now cbn; eauto. + rewrite GlobalContextMap.lookup_constructor_pars_args_spec; + destruct lookup_constructor_pars_args as [[[]] | ]; eauto. + cbn. destruct chop. cbn. intros. + rewrite !orb_false_r. + destruct l1 using rev_case; cbn; eauto. + rewrite mkApps_app; cbn; eauto. + - intros; repeat match goal with [H : MCProd.and5 _ _ _ _ _ |- _] => destruct H end. + simp transform_blocks. rewrite -!transform_blocks_equation_1. + rewrite !transform_blocks_mkApps => //. + cbn [construct_viewc]. + erewrite lookup_constructor_pars_args_cstr_arity; eauto. + destruct (chop (cstr_nargs cdecl) args) eqn:E1. + destruct (chop (cstr_nargs cdecl) args') eqn:E2. + erewrite !chop_map; eauto. + specialize H as Heq. + unfold lookup_constructor, lookup_inductive, lookup_minductive in Heq. + destruct lookup_env eqn:E; try now inv Heq. + eapply lookup_env_wellformed in E; eauto. + destruct g; cbn in Heq; try now inv Heq. + cbn in E. + destruct nth_error; try now inv Heq. + destruct nth_error; invs Heq. + rewrite /wf_minductive in E. rtoProp. + rewrite haspars /= in H4. + cbn in H4. eapply eqb_eq in H4. + unfold cstr_arity in H0. + rewrite -> H4 in *. cbn in H0. + revert E1 E2. + rewrite <- H0. + rewrite !chop_firstn_skipn !firstn_all. intros [= <- <-] [= <- <-]. + eapply All2_length in X0 as Hlen. + cbn. + rewrite !skipn_all Hlen skipn_all firstn_all. cbn. + eapply eval_construct_block; tea. eauto. + now rewrite lookup_constructor_transform_blocks. + unfold cstr_arity. cbn. rewrite H4; len. + solve_all. clear -X0. eapply All2_All2_Set. solve_all. + apply H. + - intros. destruct t; try solve [constructor; cbn in H, H0 |- *; try congruence]. + cbn -[lookup_constructor] in H |- *. destruct l => //. + destruct lookup_constructor eqn:hl => //. + destruct p as [[mdecl idecl] cdecl]. + eapply eval_construct_block => //. + now rewrite lookup_constructor_transform_blocks hl. + simp_eta in H1. cbn in H1. unfold isEtaExp_app in H1. + rewrite (lookup_constructor_pars_args_spec wfΣ hl) andb_true_r in H1. + apply Nat.leb_le in H1; cbn; unfold cstr_arity. lia. +Qed. diff --git a/erasure/theories/EDeps.v b/erasure/theories/EDeps.v index 1b72d5c12..0659d471d 100644 --- a/erasure/theories/EDeps.v +++ b/erasure/theories/EDeps.v @@ -57,6 +57,8 @@ Proof. now constructor. - depelim er. now constructor. + - depelim er. + econstructor; eauto. - depelim er. econstructor; eauto. induction X; [easy|]. @@ -105,6 +107,8 @@ Proof. now constructor. - depelim er. now constructor. + - depelim er. + econstructor; eauto. - depelim er. econstructor; eauto. induction X; [easy|]. @@ -160,6 +164,8 @@ Proof. now constructor. - depelim er. now constructor. + - depelim er. + cbn. econstructor; eauto. - depelim er. econstructor; [easy|easy|easy|easy|easy|]. induction X; [easy|]. @@ -253,7 +259,7 @@ Qed. Notation "Σ ⊢ s ▷ t" := (eval Σ s t) (at level 50, s, t at next level) : type_scope. -Lemma erases_deps_eval {wfl:WcbvFlags} Σ t v Σ' : +Lemma erases_deps_eval {wfl:WcbvFlags} {hcon : with_constructor_as_block = false} Σ t v Σ' : Σ' ⊢ t ▷ v -> erases_deps Σ Σ' t -> erases_deps Σ Σ' v. @@ -275,8 +281,9 @@ Proof. + intuition auto. apply erases_deps_mkApps_inv in H4. now apply Forall_rev, Forall_skipn. - + eapply nth_error_forall in e0; [|now eauto]. + + eapply nth_error_forall in e2; [|now eauto]. assumption. + - congruence. - depelim er. subst brs; cbn in *. depelim H3. @@ -326,10 +333,12 @@ Proof. intuition auto. apply erases_deps_mkApps_inv in H3 as (? & ?). apply IHev2. - now eapply nth_error_forall in e1. + now eapply nth_error_forall in e3. + - congruence. - constructor. - depelim er. now constructor. + - congruence. - depelim er. now constructor. - easy. Qed. @@ -367,7 +376,7 @@ Lemma erases_deps_forall_ind Σ Σ' declared_constructor Σ' (ind, c) mdecl' idecl' cdecl' -> erases_one_inductive_body idecl idecl' -> erases_mutual_inductive_body mdecl mdecl' -> - P (Extract.E.tConstruct ind c)) + P (Extract.E.tConstruct ind c [])) (Hcase : forall (p : inductive × nat) mdecl idecl mdecl' idecl' (discr : Extract.E.term) (brs : list (list name × Extract.E.term)), PCUICAst.declared_inductive Σ (fst p) mdecl idecl -> EGlobalEnv.declared_inductive Σ' (fst p) mdecl' idecl' -> @@ -391,7 +400,8 @@ Lemma erases_deps_forall_ind Σ Σ' (Hcofix : forall (defs : list (Extract.E.def Extract.E.term)) (i : nat), Forall (fun d : Extract.E.def Extract.E.term => erases_deps Σ Σ' (Extract.E.dbody d)) defs -> Forall (fun d => P (E.dbody d)) defs -> - P (Extract.E.tCoFix defs i)) : + P (Extract.E.tCoFix defs i)) + (Hprim : forall p, P (Extract.E.tPrim p)): forall t, erases_deps Σ Σ' t -> P t. Proof. fix f 2. @@ -454,7 +464,7 @@ Qed. *) Lemma erases_deps_cons Σ Σ' kn decl decl' t : on_global_univs Σ.(universes) -> - on_global_decls cumulSpec0 (lift_typing typing) Σ.(universes) ((kn, decl) :: Σ.(declarations)) -> + on_global_decls cumulSpec0 (lift_typing typing) Σ.(universes) Σ.(retroknowledge) ((kn, decl) :: Σ.(declarations)) -> erases_deps Σ Σ' t -> erases_deps (add_global_decl Σ (kn, decl)) ((kn, decl') :: Σ') t. Proof. @@ -672,7 +682,7 @@ Lemma erases_global_all_deps Σ Σ' : globals_erased_with_deps Σ Σ'. Proof. intros wf erg. - set (Σg := Σ). destruct Σ as [univs Σ]; cbn in *. + set (Σg := Σ). destruct Σ as [univs Σ retro]; cbn in *. induction Σ as [|(kn, decl) Σ IH] in Σ', Σg, wf, erg |- *; cbn in *. - depelim erg. split; [intros ? ? decl; discriminate decl|]. @@ -710,7 +720,7 @@ Proof. now split; cbn; eauto. depelim wf. depelim o0. do 2 red in o2. now rewrite E in o2. apply IH; eauto. depelim wf. now depelim o0. - + set (Σu := {| universes := univs; declarations := Σ |}). + + set (Σu := {| universes := univs; declarations := Σ; retroknowledge := retro |}). assert (wfΣu : PCUICTyping.wf Σu). { depelim wf. now depelim o0. } assert (exists decl' Σ'', Σ' = (kn, decl') :: Σ'' /\ erases_global Σu Σ'') diff --git a/erasure/theories/EEnvMap.v b/erasure/theories/EEnvMap.v index 6ce87c314..89872d71b 100644 --- a/erasure/theories/EEnvMap.v +++ b/erasure/theories/EEnvMap.v @@ -1,6 +1,6 @@ From Coq Require Import ssreflect ssrbool. From Equations Require Import Equations. -From MetaCoq.Template Require Import utils Kernames EnvMap. +From MetaCoq.Template Require Import utils Kernames EnvMap BasicAst. From MetaCoq.Erasure Require Import EAst EGlobalEnv EAstUtils EGlobalEnv EAstUtils. Import MCMonadNotation. @@ -79,6 +79,16 @@ Module GlobalContextMap. now rewrite lookup_minductive_spec. Qed. + Definition lookup_inductive_kind Σ kn : option recursivity_kind := + mdecl <- lookup_minductive Σ kn ;; + ret mdecl.(ind_finite). + + Lemma lookup_inductive_kind_spec Σ kn : lookup_inductive_kind Σ kn = EGlobalEnv.lookup_inductive_kind Σ kn. + Proof. + rewrite /lookup_inductive_kind /EGlobalEnv.lookup_inductive_kind. + now rewrite lookup_minductive_spec. + Qed. + Definition inductive_isprop_and_pars Σ (ind : inductive) := '(mdecl, idecl) <- lookup_inductive Σ ind ;; ret (ind_propositional idecl, ind_npars mdecl). @@ -101,6 +111,17 @@ Module GlobalContextMap. rewrite lookup_constructor_spec //. Qed. + Definition lookup_constructor_pars_args Σ (ind : inductive) (c : nat) := + '(mdecl, idecl, cdecl) <- lookup_constructor Σ ind c ;; + ret (ind_npars mdecl, cstr_nargs cdecl). + + Lemma lookup_constructor_pars_args_spec Σ kn : + lookup_constructor_pars_args Σ kn = EGlobalEnv.lookup_constructor_pars_args Σ kn. + Proof. + rewrite /lookup_constructor_pars_args /EGlobalEnv.lookup_constructor_pars_args. + rewrite lookup_constructor_spec //. + Qed. + Program Definition make (g : global_declarations) (Hg : EnvMap.fresh_globals g): t := {| global_decls := g; map := EnvMap.of_global_env g |}. diff --git a/erasure/theories/EEtaExpanded.v b/erasure/theories/EEtaExpanded.v index 476c82b7d..78e399a4c 100644 --- a/erasure/theories/EEtaExpanded.v +++ b/erasure/theories/EEtaExpanded.v @@ -26,15 +26,15 @@ Hint Constructors eval : core. Import MCList (map_InP, map_InP_elim, map_InP_spec). Equations discr_construct (t : term) : Prop := -discr_construct (tConstruct ind n) := False ; +discr_construct (tConstruct ind n block_args) := False ; discr_construct _ := True. Inductive construct_view : term -> Type := -| view_construct : forall ind n, construct_view (tConstruct ind n) +| view_construct : forall ind n block_args, construct_view (tConstruct ind n block_args) | view_other : forall t, discr_construct t -> construct_view t. Equations construct_viewc t : construct_view t := -construct_viewc (tConstruct ind n) := view_construct ind n ; +construct_viewc (tConstruct ind n block_args) := view_construct ind n block_args ; construct_viewc t := view_other t I. Ltac toAll := @@ -55,6 +55,8 @@ Section isEtaExp. Import TermSpineView. + Definition is_nil {A} (l : list A) := match l with [] => true | _ => false end. + Equations? isEtaExp (e : EAst.term) : bool by wf e (fun x y : EAst.term => size x < size y) := | e with TermSpineView.view e := { @@ -62,7 +64,7 @@ Section isEtaExp. | tEvar ev args => forallb_InP args (fun x H => isEtaExp x) | tLambda na M => isEtaExp M | tApp u v napp nnil with construct_viewc u := - { | view_construct ind i => isEtaExp_app ind i (List.length v) && forallb_InP v (fun x H => isEtaExp x) + { | view_construct ind i block_args => isEtaExp_app ind i (List.length v) && forallb_InP v (fun x H => isEtaExp x) && is_nil block_args | view_other _ _ => isEtaExp u && forallb_InP v (fun x H => isEtaExp x) } | tLetIn na b b' => isEtaExp b && isEtaExp b' | tCase ind c brs => isEtaExp c && forallb_InP brs (fun x H => isEtaExp x.2) @@ -72,15 +74,17 @@ Section isEtaExp. | tBox => true | tVar _ => true | tConst _ => true - | tConstruct ind i => isEtaExp_app ind i 0 }. + | tPrim _ => true + | tConstruct ind i block_args => isEtaExp_app ind i 0 && is_nil block_args }. Proof. all:try lia. all:try apply (In_size); tea. all:try lia. - now apply (In_size id size). - rewrite size_mkApps. - change (fun x => size (id x)) with size in H. cbn. - now apply (In_size id size). + eapply (In_size id size) in H. + change (fun x => size (id x)) with size in H. unfold id in *; cbn. + lia. - now eapply size_mkApps_f. - change (fun x => size (id x)) with size in H. eapply (In_size id size) in H. unfold id in H. @@ -102,7 +106,7 @@ Section isEtaExp. Lemma isEtaExp_mkApps_nonnil f v : ~~ isApp f -> v <> [] -> isEtaExp (mkApps f v) = match construct_viewc f with - | view_construct ind i => isEtaExp_app Σ ind i #|v| && forallb isEtaExp v + | view_construct ind i block_args => isEtaExp_app Σ ind i #|v| && forallb isEtaExp v && is_nil block_args | view_other t discr => isEtaExp f && forallb isEtaExp v end. Proof using Type. @@ -114,7 +118,7 @@ Section isEtaExp. Lemma isEtaExp_mkApps_napp f v : ~~ isApp f -> isEtaExp (mkApps f v) = match construct_viewc f with - | view_construct ind i => isEtaExp_app Σ ind i #|v| && forallb isEtaExp v + | view_construct ind i block_args => isEtaExp_app Σ ind i #|v| && forallb isEtaExp v && is_nil block_args | view_other t discr => isEtaExp f && forallb isEtaExp v end. Proof using Type. @@ -124,8 +128,8 @@ Section isEtaExp. - rewrite isEtaExp_mkApps_nonnil //. Qed. - Lemma isEtaExp_Constructor ind i v : - isEtaExp (mkApps (EAst.tConstruct ind i) v) = isEtaExp_app Σ ind i #|v| && forallb isEtaExp v. + Lemma isEtaExp_Constructor ind i v block_args : + isEtaExp (mkApps (EAst.tConstruct ind i block_args) v) = isEtaExp_app Σ ind i #|v| && forallb isEtaExp v && is_nil block_args. Proof using Type. rewrite isEtaExp_mkApps_napp //. Qed. @@ -134,7 +138,7 @@ Section isEtaExp. Lemma isEtaExp_mkApps f u : isEtaExp (mkApps f u) -> let (hd, args) := decompose_app (mkApps f u) in match construct_viewc hd with - | view_construct kn c => isEtaExp_app Σ kn c #|args| && forallb isEtaExp args + | view_construct kn c block_args => isEtaExp_app Σ kn c #|args| && forallb isEtaExp args && is_nil block_args | view_other u discr => isEtaExp hd && forallb isEtaExp args end. Proof using Type. @@ -143,7 +147,7 @@ Section isEtaExp. pose proof (decompose_app_notApp _ _ _ da). destruct l. cbn -[isEtaExp]. intros eq; rewrite eq. - destruct (construct_viewc t) => //. simp isEtaExp in eq; now rewrite eq. + destruct (construct_viewc t) => //. simp isEtaExp in eq. rtoProp. solve_all. assert (t0 :: l <> []) by congruence. revert da H0. generalize (t0 :: l). clear t0 l; intros l. intros da nnil. @@ -179,9 +183,9 @@ Section isEtaExp. Lemma isEtaExp_tApp {f u} : isEtaExp (EAst.tApp f u) -> let (hd, args) := decompose_app (EAst.tApp f u) in match construct_viewc hd with - | view_construct kn c => + | view_construct kn c block_args => args <> [] /\ f = mkApps hd (remove_last args) /\ u = last args u /\ - isEtaExp_app Σ kn c #|args| && forallb isEtaExp args + isEtaExp_app Σ kn c #|args| && forallb isEtaExp args && is_nil block_args | view_other _ discr => [&& isEtaExp hd, forallb isEtaExp args, isEtaExp f & isEtaExp u] end. @@ -232,17 +236,19 @@ Section WeakEtaExp. pose proof (decompose_app_notApp _ _ _ da). destruct l0. simp_eta. - rewrite isEtaExp_mkApps_napp //. - destruct construct_viewc. cbn. len. - rtoProp; repeat solve_all. cbn in et. simp isEtaExp in et. + destruct construct_viewc. cbn. len. + rtoProp; repeat solve_all. cbn in et. rtoProp. rename H0 into et. simp isEtaExp in et. eapply isEtaExp_app_mon; tea; lia. - eapply All_app_inv; eauto. rewrite et forallb_app /=. + eapply All_app_inv; eauto. + cbn in et. rtoProp. rename H0 into et. simp isEtaExp in et. + rewrite et forallb_app /=. rtoProp; repeat solve_all. - rewrite isEtaExp_mkApps_napp in et => //. destruct construct_viewc. rewrite -mkApps_app. rewrite isEtaExp_Constructor. - cbn. cbn. rtoProp; solve_all. - eapply isEtaExp_app_mon; tea. cbn. len. now depelim H1. - depelim H1. solve_all. eapply All_app_inv => //. + rtoProp; solve_all. + eapply isEtaExp_app_mon; tea. cbn. len. solve_all. depelim H2. + solve_all. eapply All_app_inv => //. econstructor; eauto. eapply All_app_inv => //. eauto. rewrite -mkApps_app. rewrite isEtaExp_mkApps_napp //. destruct (construct_viewc t0) => //. @@ -260,6 +266,7 @@ Section WeakEtaExp. - intros. simp isEtaExp ; cbn. destruct Nat.compare => //. simp_eta in etaa. - move/andP: H1 => [] etab etab'. apply/andP. split; eauto. + - rtoProp. intuition eauto. now destruct block_args. - rtoProp. intuition eauto. solve_all. - move/andP: b => [] etaexp h. @@ -270,6 +277,7 @@ Section WeakEtaExp. rewrite csubst_mkApps /=. rewrite isEtaExp_Constructor. solve_all. rewrite map_length. rtoProp; solve_all. solve_all. + now destruct block_args. - rewrite csubst_mkApps /=. move/andP: H1 => [] eu ev. specialize (H _ k etaa eu). @@ -460,7 +468,8 @@ Inductive expanded : term -> Prop := declared_constructor Σ (ind, idx) mind idecl cdecl -> #|args| >= cstr_arity mind cdecl -> Forall expanded args -> - expanded (mkApps (tConstruct ind idx) args) + expanded (mkApps (tConstruct ind idx []) args) +| expanded_tPrim p : expanded (tPrim p) | expanded_tBox : expanded tBox. End expanded. @@ -498,19 +507,20 @@ forall (Σ : global_declarations) (P : term -> Prop), (idecl : one_inductive_body) cdecl (args : list term), declared_constructor Σ (ind, idx) mind idecl cdecl -> - #|args| >= cstr_arity mind cdecl -> Forall (expanded Σ) args -> Forall P args -> P (mkApps (tConstruct ind idx) args)) -> + #|args| >= cstr_arity mind cdecl -> Forall (expanded Σ) args -> Forall P args -> P (mkApps (tConstruct ind idx []) args)) -> +(forall p, P (tPrim p)) -> (P tBox) -> forall t : term, expanded Σ t -> P t. Proof. - intros. revert t H12. + intros. revert t H13. fix f 2. intros t Hexp. destruct Hexp; eauto. - - eapply H1; eauto. induction H12; econstructor; cbn in *; eauto. - - eapply H4; eauto. clear H13. induction H14; econstructor; cbn in *; eauto. - - eapply H6; eauto. induction H12; econstructor; cbn in *; eauto. - - eapply H8; eauto. induction H12; econstructor; cbn in *; intuition eauto. - - eapply H9; eauto. induction H12; econstructor; cbn in *; eauto. - - eapply H10; eauto. clear - H14 f. induction H14; econstructor; cbn in *; eauto. + - eapply H1; eauto. induction H13; econstructor; cbn in *; eauto. + - eapply H4; eauto. clear H14. induction H15; econstructor; cbn in *; eauto. + - eapply H6; eauto. induction H13; econstructor; cbn in *; eauto. + - eapply H8; eauto. induction H13; econstructor; cbn in *; intuition eauto. + - eapply H9; eauto. induction H13; econstructor; cbn in *; eauto. + - eapply H10; eauto. clear - H15 f. induction H15; econstructor; cbn in *; eauto. Qed. Local Hint Constructors expanded : core. @@ -571,7 +581,8 @@ Proof. - rewrite forallb_InP_spec in H0. eapply forallb_Forall in H0. eapply In_All in H. econstructor. solve_all. - eapply andb_true_iff in H1 as []; eauto. - - eapply isEtaExp_app_expanded in H as (? & ? & ? & ? & ?). + - rtoProp. eapply isEtaExp_app_expanded in H as (? & ? & ? & ? & ?). + destruct block_args; inv H0. eapply expanded_tConstruct_app with (args := []); eauto. - eapply andb_true_iff in H1 as []. destruct ind. econstructor; eauto. rewrite forallb_InP_spec in H2. eapply forallb_Forall in H2. @@ -582,9 +593,10 @@ Proof. intuition auto. - econstructor. rewrite forallb_InP_spec in H0. eapply forallb_Forall in H0. eapply In_All in H. solve_all. - - eapply andb_true_iff in H0 as []. eapply In_All in H. - rewrite forallb_InP_spec in H1. eapply forallb_Forall in H1. + - rtoProp. eapply In_All in H. + rewrite forallb_InP_spec in H2. eapply forallb_Forall in H2. eapply isEtaExp_app_expanded in H0 as (? & ? & ? & ? & ?). + destruct block_args; inv H1. eapply expanded_tConstruct_app; eauto. solve_all. - eapply andb_true_iff in H1 as []. rewrite forallb_InP_spec in H2. eapply forallb_Forall in H2. econstructor. @@ -604,8 +616,8 @@ Proof. eauto). - eapply isEtaExp_mkApps_intro; eauto. solve_all. - solve_all. now rewrite b H. - - rewrite isEtaExp_Constructor. eapply andb_true_iff. - split. 2: eapply forallb_Forall. + - rewrite isEtaExp_Constructor. rtoProp; repeat split. + 2: eapply forallb_Forall. 2: solve_all. eapply expanded_isEtaExp_app_; eauto. Qed. @@ -669,8 +681,8 @@ Proof. eapply In_All in H0; solve_all. - eapply In_All in H. simp_eta; rtoProp; intuition auto. solve_all. - eapply In_All in H. simp_eta; rtoProp; intuition auto. - rewrite EEtaExpanded.isEtaExp_Constructor. apply/andP; split. exact H1. - solve_all. + rewrite EEtaExpanded.isEtaExp_Constructor. rtoProp; repeat split. eauto. + solve_all. destruct block_args; cbn in *; eauto. - eapply In_All in H, H0. simp_eta. move => /andP[] /andP[] etafix etamfix etav. eapply EEtaExpanded.isEtaExp_mkApps_intro. simp_eta. diff --git a/erasure/theories/EEtaExpandedFix.v b/erasure/theories/EEtaExpandedFix.v index db86e7e7e..5975d992e 100644 --- a/erasure/theories/EEtaExpandedFix.v +++ b/erasure/theories/EEtaExpandedFix.v @@ -58,7 +58,8 @@ Inductive expanded (Γ : list nat): term -> Prop := declared_constructor Σ (ind, idx) mind idecl cdecl -> #|args| >= ind_npars mind + cdecl.(cstr_nargs) -> Forall (expanded Γ) args -> - expanded Γ (mkApps (tConstruct ind idx) args) + expanded Γ (mkApps (tConstruct ind idx []) args) +| expanded_tPrim p : expanded Γ (tPrim p) | expanded_tBox : expanded Γ tBox. End expanded. @@ -135,11 +136,12 @@ Lemma expanded_ind : → #|args| ≥ ind_npars mind + cdecl.(cstr_nargs) → Forall (expanded Σ Γ) args → Forall (P Γ) args - → P Γ (mkApps (tConstruct ind idx) args)) + → P Γ (mkApps (tConstruct ind idx []) args)) + → (∀ Γ p, P Γ (tPrim p)) → (∀ Γ : list nat, P Γ tBox) → ∀ (Γ : list nat) (t : term), expanded Σ Γ t → P Γ t. Proof. - intros Σ P HRel_app HVar HEvar HLamdba HLetIn HmkApps HConst HCase HProj HFix HCoFix HConstruct HBox. + intros Σ P HRel_app HVar HEvar HLamdba HLetIn HmkApps HConst HCase HProj HFix HCoFix HConstruct HPrim HBox. fix f 3. intros Γ t Hexp. destruct Hexp; eauto. - eapply HRel_app; eauto. clear - f H0. induction H0; econstructor; eauto. @@ -225,19 +227,19 @@ Proof. Qed. Equations discr_expanded_head (t : term) : Prop := - discr_expanded_head (tConstruct ind n) := False ; + discr_expanded_head (tConstruct ind n block_args) := False ; discr_expanded_head (tFix mfix idx) := False ; discr_expanded_head (tRel n) := False ; discr_expanded_head _ := True. Inductive expanded_head_view : term -> Type := -| expanded_head_construct : forall ind n, expanded_head_view (tConstruct ind n) +| expanded_head_construct : forall ind n block_args, expanded_head_view (tConstruct ind n block_args) | expanded_head_fix : forall mfix idx, expanded_head_view (tFix mfix idx) | expanded_head_rel : forall n, expanded_head_view (tRel n) | expanded_head_other : forall t, discr_expanded_head t -> expanded_head_view t. Equations expanded_head_viewc t : expanded_head_view t := - expanded_head_viewc (tConstruct ind n) := expanded_head_construct ind n ; + expanded_head_viewc (tConstruct ind n block_args) := expanded_head_construct ind n block_args; expanded_head_viewc (tFix mfix idx) := expanded_head_fix mfix idx ; expanded_head_viewc (tRel n) := expanded_head_rel n ; expanded_head_viewc t := expanded_head_other t I. @@ -266,6 +268,8 @@ Section isEtaExp. Import TermSpineView. + Definition is_nil {A} (l : list A) := match l with nil => true | _ => false end. + Equations? isEtaExp (Γ : list nat) (e : EAst.term) : bool by wf e (fun x y : EAst.term => size x < size y) := isEtaExp Γ e with TermSpineView.view e := { @@ -273,7 +277,7 @@ Section isEtaExp. | tEvar ev args => forallb_InP args (fun x H => isEtaExp Γ x) | tLambda na M => isEtaExp (0 :: Γ) M | tApp u v napp nnil with expanded_head_viewc u := - { | expanded_head_construct ind i => isEtaExp_app ind i (List.length v) && forallb_InP v (fun x H => isEtaExp Γ x) + { | expanded_head_construct ind i block_args => isEtaExp_app ind i (List.length v) && forallb_InP v (fun x H => isEtaExp Γ x) && is_nil block_args | expanded_head_fix mfix idx => isEtaExp_fixapp mfix idx (List.length v) && forallb_InP mfix (fun x H => isLambda x.(dbody) && isEtaExp (rev_map (S ∘ rarg) mfix ++ Γ) x.(dbody)) && forallb_InP v (fun x H => isEtaExp Γ x) @@ -287,14 +291,16 @@ Section isEtaExp. | tBox => true | tVar _ => true | tConst _ => true - | tConstruct ind i => isEtaExp_app ind i 0 }. + | tPrim _ => true + | tConstruct ind i block_args => isEtaExp_app ind i 0 && is_nil block_args }. Proof using Σ. all:try lia. all:try apply (In_size); tea. all:try lia. - now apply (In_size id size). - - rewrite size_mkApps. - now apply (In_size id size). + - rewrite size_mkApps. cbn. + apply (In_size id size) in H. + unfold id in H. change (fun x => size x) with size in H. lia. - rewrite size_mkApps. apply (In_size id (fun d => size d.(dbody))) in H. unfold id in H. change (fun x => size x) with size in H. cbn. lia. @@ -325,7 +331,7 @@ Section isEtaExp. Lemma isEtaExp_mkApps_nonnil Γ f v : ~~ isApp f -> v <> [] -> isEtaExp Γ (mkApps f v) = match expanded_head_viewc f with - | expanded_head_construct ind i => isEtaExp_app ind i #|v| && forallb (isEtaExp Γ) v + | expanded_head_construct ind i block_args => isEtaExp_app ind i #|v| && forallb (isEtaExp Γ) v && is_nil block_args | expanded_head_fix mfix idx => isEtaExp_fixapp mfix idx #|v| && forallb (fun x => isLambda x.(dbody) && isEtaExp (rev_map (S ∘ rarg) mfix ++ Γ) x.(dbody)) mfix && forallb (isEtaExp Γ) v | expanded_head_rel n => option_default (fun m => m <=? List.length v) (nth_error Γ n) false && forallb (fun x => isEtaExp Γ x) v @@ -345,7 +351,7 @@ Section isEtaExp. Lemma isEtaExp_mkApps Γ f v : ~~ isApp f -> isEtaExp Γ (mkApps f v) = match expanded_head_viewc f with - | expanded_head_construct ind i => isEtaExp_app ind i #|v| && forallb (isEtaExp Γ) v + | expanded_head_construct ind i block_args => isEtaExp_app ind i #|v| && forallb (isEtaExp Γ) v && is_nil block_args | expanded_head_fix mfix idx => isEtaExp_fixapp mfix idx #|v| && forallb (fun x => isLambda x.(dbody) && isEtaExp (rev_map (S ∘ rarg) mfix ++ Γ) x.(dbody)) mfix && forallb (isEtaExp Γ) v @@ -362,8 +368,8 @@ Section isEtaExp. - rewrite isEtaExp_mkApps_nonnil //. Qed. - Lemma isEtaExp_Constructor Γ ind i v : - isEtaExp Γ (mkApps (EAst.tConstruct ind i) v) = isEtaExp_app ind i #|v| && forallb (isEtaExp Γ) v. + Lemma isEtaExp_Constructor Γ ind i block_args v : + isEtaExp Γ (mkApps (EAst.tConstruct ind i block_args) v) = isEtaExp_app ind i #|v| && forallb (isEtaExp Γ) v && is_nil block_args. Proof. now rewrite isEtaExp_mkApps. Qed. @@ -380,7 +386,7 @@ Section isEtaExp. - rewrite isEtaExp_mkApps //. destruct expanded_head_viewc. + cbn. len. - rtoProp; repeat solve_all. cbn in et. simp isEtaExp in et. + rtoProp; repeat solve_all; cbn in et; rtoProp; eauto. rename H0 into et. simp isEtaExp in et. eapply isEtaExp_app_mon; tea; lia. eapply All_app_inv; eauto. + cbn in *; congruence. @@ -393,9 +399,9 @@ Section isEtaExp. - rewrite isEtaExp_mkApps in et => //. destruct expanded_head_viewc. + rewrite -mkApps_app. rewrite isEtaExp_Constructor. - cbn. cbn. rtoProp; solve_all. - eapply isEtaExp_app_mon; tea. cbn. len. now depelim H1. - depelim H1. solve_all. eapply All_app_inv => //. + rtoProp; solve_all. + eapply isEtaExp_app_mon; tea. cbn. len. solve_all. depelim H2. + eapply All_app_inv => //. econstructor; eauto. eapply All_app_inv => //. eauto. + rewrite -mkApps_app. rewrite isEtaExp_mkApps //. simp expanded_head_viewc. rewrite /isEtaExp_fixapp in et |- *. @@ -439,8 +445,10 @@ Section isEtaExp. rewrite ?closedn_mkApps; rtoProp; (try toAll); repeat solve_all. - destruct nth_error eqn:Hn; cbn in H; try easy. eapply nth_error_Some_length in Hn. now eapply Nat.ltb_lt. + - destruct block_args; cbn in *; eauto. - eapply a in b. 2: f_equal. revert b. now len. - eapply a in b. 2: f_equal. revert b. now len. + - cbn. destruct block_args; cbn in *; eauto. - cbn. solve_all. rtoProp; intuition auto. eapply a in H0. 2: reflexivity. revert H0. now len. - destruct nth_error eqn:Hn; cbn in H1; try easy. eapply nth_error_Some_length in Hn. now eapply Nat.ltb_lt. @@ -467,6 +475,7 @@ Section isEtaExp. - move/andP: H2 => [] etab etab'. simp_eta. apply/andP. split; eauto. eapply H0 with (Γ := 0 :: Γ0); cbn; eauto. + - rtoProp. intuition eauto. destruct block_args; cbn in *; eauto. - rtoProp. intuition eauto. solve_all. rewrite app_assoc. eapply a0; cbn; eauto. now len. cbn. now rewrite app_assoc. @@ -474,7 +483,7 @@ Section isEtaExp. - fold csubst. move/andP: H1 => [] etaexp h. rewrite csubst_mkApps /=. rewrite isEtaExp_Constructor. solve_all. - rewrite map_length. rtoProp; solve_all. solve_all. + rewrite map_length. rtoProp; solve_all. solve_all. destruct block_args; cbn in *; eauto. - rewrite csubst_mkApps /=. move/andP : H2 => [] /andP [] eu ef ev. rewrite isEtaExp_mkApps //. @@ -505,7 +514,7 @@ Section isEtaExp. Qed. Lemma etaExp_csubst a b n : - isEtaExp []a -> isEtaExp [n] b -> isEtaExp [] (ECSubst.csubst a 0 b). + isEtaExp []a -> isEtaExp [n] b -> isEtaExp [] (ECSubst.csubst a 0 b). Proof. intros. eapply etaExp_csubst' with (Γ := []); eauto. @@ -536,6 +545,7 @@ Section isEtaExp. apply/andP. split; eauto. eapply H; eauto. solve_all. eapply H0 with (Γ := 0 :: Γ0); eauto. solve_all. + - rtoProp. intuition eauto. destruct block_args; eauto. - rtoProp. intuition eauto. solve_all. rewrite app_assoc. eapply a; cbn-[isEtaExp]; eauto. now len. cbn. now rewrite app_assoc. @@ -553,7 +563,7 @@ Section isEtaExp. eapply All_impl; tea; cbv beta. intros x Hx. eapply Hx; eauto. - solve_all. apply Hx. + solve_all. apply Hx. now destruct block_args. - solve_all. rewrite csubst_mkApps /=. move/andP : H2 => [] /andP [] eu ef ev. rewrite isEtaExp_mkApps //. @@ -731,7 +741,7 @@ Section isEtaExp. Lemma isEtaExp_tApp Γ f u : isEtaExp Γ (mkApps f u) -> let (hd, v) := decompose_app (mkApps f u) in match expanded_head_viewc hd with - | expanded_head_construct ind i => isEtaExp_app ind i #|v| && forallb (isEtaExp Γ) v + | expanded_head_construct ind i block_args => isEtaExp_app ind i #|v| && forallb (isEtaExp Γ) v && is_nil block_args | expanded_head_fix mfix idx => isEtaExp_fixapp mfix idx #|v| && forallb (fun x => isLambda x.(dbody) && isEtaExp (rev_map (S ∘ rarg) mfix ++ Γ) x.(dbody)) mfix && forallb (isEtaExp Γ) v | expanded_head_rel n => (option_default (fun m => m <=? List.length v) (nth_error Γ n) false) && forallb (fun x => isEtaExp Γ x) v @@ -789,16 +799,18 @@ Proof. - eapply expanded_tRel_app with (args := []). destruct (nth_error); invs H. f_equal. eapply Nat.eqb_eq in H1; eauto. cbn. lia. econstructor. - rewrite forallb_InP_spec in H0. eapply forallb_Forall in H0. eapply In_All in H. econstructor. solve_all. - eapply andb_true_iff in H1 as []; eauto. - - eapply isEtaExp_app_expanded in H as (? & ? & ? & ? & ?). + - rtoProp. eapply isEtaExp_app_expanded in H as (? & ? & ? & ? & ?). + destruct block_args; cbn in *; eauto. eapply expanded_tConstruct_app with (args := []); eauto. - eapply andb_true_iff in H1 as []. destruct ind. econstructor; eauto. rewrite forallb_InP_spec in H2. eapply forallb_Forall in H2. eapply In_All in H0. solve_all. - econstructor. rewrite forallb_InP_spec in H0. eapply forallb_Forall in H0. eapply In_All in H. solve_all. - - eapply andb_true_iff in H0 as []. eapply In_All in H. - rewrite forallb_InP_spec in H1. eapply forallb_Forall in H1. + - rtoProp. eapply In_All in H. + rewrite forallb_InP_spec in H2. eapply forallb_Forall in H2. eapply isEtaExp_app_expanded in H0 as (? & ? & ? & ? & ?). + destruct block_args; cbn in *; eauto. eapply expanded_tConstruct_app; eauto. solve_all. - rtoProp. rewrite forallb_InP_spec in H2. rewrite forallb_InP_spec in H3. eapply In_All in H. eapply In_All in H0. unfold isEtaExp_fixapp in H1. destruct nth_error eqn:E; try congruence. @@ -831,9 +843,9 @@ Proof. + unfold isEtaExp_fixapp. rewrite H4. eapply Nat.ltb_lt. lia. + solve_all; rtoProp; intuition auto. + solve_all. - - rewrite isEtaExp_Constructor. eapply andb_true_iff. - split. 2: eapply forallb_Forall. - 2: solve_all. eapply expanded_isEtaExp_app_; eauto. + - rewrite isEtaExp_Constructor. rtoProp. repeat split. + 2: eapply forallb_Forall; solve_all. + eapply expanded_isEtaExp_app_; eauto. Qed. Definition isEtaExp_constant_decl Σ cb := @@ -872,9 +884,9 @@ Arguments isEtaExp : simpl never. Lemma isEtaExp_tApp' {Σ} {Γ} {f u} : isEtaExp Σ Γ (tApp f u) -> let (hd, args) := decompose_app (tApp f u) in match expanded_head_viewc hd with - | expanded_head_construct kn c => + | expanded_head_construct kn c block_args => args <> [] /\ f = mkApps hd (remove_last args) /\ u = last args u /\ - isEtaExp_app Σ kn c #|args| && forallb (isEtaExp Σ Γ) args + isEtaExp_app Σ kn c #|args| && forallb (isEtaExp Σ Γ) args && is_nil block_args | expanded_head_fix mfix idx => args <> [] /\ f = mkApps hd (remove_last args) /\ u = last args u /\ isEtaExp_fixapp mfix idx #|args| && forallb (fun d => isLambda d.(dbody) && isEtaExp Σ (rev_map (fun d => 1 + d.(rarg)) mfix ++ Γ) d.(dbody)) mfix && forallb (isEtaExp Σ Γ) args @@ -1009,22 +1021,22 @@ Qed. Arguments lookup_inductive_pars_constructor_pars_args {Σ ind n pars args}. -Lemma eval_etaexp {fl : WcbvFlags} {efl : EEnvFlags} {Σ a a'} : +Lemma eval_etaexp {fl : WcbvFlags} {efl : EEnvFlags} {wcon : with_constructor_as_block = false} {Σ a a'} : isEtaExp_env Σ -> wf_glob Σ -> eval Σ a a' -> isEtaExp Σ [] a -> isEtaExp Σ [] a'. Proof. intros etaΣ wfΣ. - induction 1 as [ | ? ? ? ? ? ? ? ? IHs | | | | ? ? ? ? ? ? ? ? ? ? ? IHs | ? ? ? ? ? ? ? ? ? ? ? IHs - | ? ? ? ? ? ? ? ? ? ? IHs | | | | | | | | ] using eval_mkApps_rect. + induction 1 as [ | ? ? ? ? ? ? ? ? IHs | | | | | ? ? ? ? ? ? ? ? ? ? ? IHs | ? ? ? ? ? ? ? ? ? ? ? IHs + | ? ? ? ? ? ? ? ? ? ? IHs | | | | | | | | | | ] using eval_mkApps_rect; try now congruence. all:try simp isEtaExp; rewrite -!isEtaExp_equation_1 => //. 6:{ move/isEtaExp_tApp'. destruct decompose_app eqn:da. destruct expanded_head_viewc eqn:vc. - * move => [hl [hf [ha /andP[] ise etal]]]. + * move => [hl [hf [ha /andP[] /andP[] ise etal bargs]]]. destruct block_args; cbn in *; eauto. pose proof (H' := H). - rewrite hf in H'. eapply eval_mkApps_Construct_inv in H' as [? []]. exfalso. solve_discr. + rewrite hf in H'. eapply eval_mkApps_Construct_inv in H' as [? []]. exfalso. solve_discr. auto. * move => [hl [hf [ha /andP[] /andP[] etal etab]]] isel. pose proof (mkApps_app (EAst.tFix mfix idx) argsv [av]). cbn in H3. rewrite <- H3. clear H3. @@ -1065,8 +1077,8 @@ Proof. move/isEtaExp_tApp'. destruct decompose_app eqn:da. destruct expanded_head_viewc eqn:vc. - * move => [hl [hf [ha /andP[] ise etal]]]. clear IHs. - rewrite hf in H. eapply eval_mkApps_Construct_inv in H as [? []]. exfalso. solve_discr. + * move => [hl [hf [ha /andP[] /andP[] ise etal bargs]]]. clear IHs. destruct block_args; inv bargs. + rewrite hf in H. eapply eval_mkApps_Construct_inv in H as [? []]. exfalso. solve_discr. auto. * move => [hl [hf [ha /andP[] /andP[] etal etab]]] isel. subst. eapply IHeval3. @@ -1115,11 +1127,11 @@ Proof. 11:{ move/isEtaExp_tApp'. destruct decompose_app eqn:da. destruct expanded_head_viewc. - * move=> [] hl [] hf [] ha /andP[] hl' etal. + * move=> [] hl [] hf [] ha /andP[] /andP[] hl' etal bargs. destruct block_args; inv bargs. move: H H0. rewrite hf => H H0. - destruct (eval_construct_size H) as [args' []]. subst f'. - rewrite isConstructApp_mkApps /= in H1. - rewrite !negb_or in H1. rtoProp; intuition auto. now cbn in H3. + destruct (eval_construct_size wcon H) as [args' []]. subst f'. + rewrite isConstructApp_mkApps /= in i. + rewrite !negb_or in i. rtoProp; intuition auto. now cbn in H3. * move => [hl [hf [ha /andP[] /andP[] etal etab]]] isel. subst. @@ -1128,7 +1140,7 @@ Proof. { specialize eval_mkApps_tFix_inv_size with (Heval := H); intros [(args' & ? & Heq) | (? & ? & ? & ? & ?)]; eauto. - -- subst. rewrite isFixApp_mkApps in H1 => //. destruct EAst.isLambda; easy. + -- subst. rewrite isFixApp_mkApps in i => //. destruct EAst.isLambda; easy. -- eapply (isEtaExp_mkApps_intro _ _ f' [a']); eauto. eapply IHeval1. rewrite isEtaExp_mkApps => //. cbn [expanded_head_viewc]. rtoProp. @@ -1136,7 +1148,7 @@ Proof. 2: eapply All_firstn; eauto. unfold isEtaExp_fixapp, cunfold_fix in *. destruct nth_error; try easy. - invs H5. eapply Nat.ltb_lt. lia. + invs H4. eapply Nat.ltb_lt. lia. } { @@ -1146,7 +1158,7 @@ Proof. unshelve eapply H0. 2: eauto. lia. eapply (isEtaExp_mkApps_intro). eapply (isEtaExp_mkApps_intro _ _ fn [a_']); eauto. 2: econstructor; [ | econstructor]. - ++ eapply isEtaExp_cunfold_fix. 2: eauto. solve_all. now rewrite app_nil_r in H5. + ++ eapply isEtaExp_cunfold_fix. 2: eauto. solve_all. now rewrite app_nil_r in H4. ++ solve_all. eapply All_firstn in isel. unfold remove_last in Heq. eapply All_Forall in isel. setoid_rewrite Heq in isel. invs isel. eauto. ++ eapply forallb_Forall in isel. eapply Forall_firstn in isel. unfold remove_last in Heq. @@ -1154,7 +1166,7 @@ Proof. destruct b0. unshelve eapply H0. 2: eauto. lia. eauto. } * intros (? & ? & ? & ?). rtoProp. solve_all. - rewrite nth_error_nil in H6. easy. + rewrite nth_error_nil in H5. easy. * move/and4P => [] etat etal etaf etaa. eapply (isEtaExp_mkApps_intro _ _ f' [a']); eauto. } @@ -1162,64 +1174,65 @@ Proof. move/isEtaExp_tApp'. destruct decompose_app eqn:da. destruct expanded_head_viewc. - * move=> [] hl [] hf [] ha /andP[] hl' etal. + * move=> [] hl [] hf [] ha /andP[] /andP[] hl' etal bargs. destruct block_args; inv bargs. rewrite -[EAst.tApp _ _](mkApps_app _ _ [a']). - rewrite isEtaExp_Constructor. - move: H0 H1. rewrite hf. intros H0 H1. - destruct (eval_mkApps_Construct_size H0) as [args'' [evc []]]. - eapply mkApps_eq_inj in e as [] => //. subst args''. noconf H3. + rewrite isEtaExp_Constructor. cbn. rewrite andb_true_r. + revert H H0. rewrite hf. intros H H0. + destruct (eval_mkApps_Construct_size wcon H) as [args'' [evc []]]. + eapply mkApps_eq_inj in e1 as [] => //. subst args''. noconf H2. apply/andP; split => //. - + len. - rewrite (remove_last_last l a) // in hl'. + + len. + rewrite (remove_last_last l0 a) // in hl'. rewrite app_length in hl'. cbn in hl'. now rewrite -(All2_length a0). + solve_all. - rewrite (remove_last_last l a) // in etal. + rewrite (remove_last_last l0 a) // in etal. eapply All_app in etal as [etal etaa]. depelim etaa. clear etaa. rewrite -ha in i. eapply All_app_inv; try constructor; eauto. - clear -H1 a0 etal. solve_all. - destruct b as [ev Hev]. eapply (H1 _ _ ev) => //. lia. + solve_all. + destruct b as [ev Hev]. eapply (H0 _ _ ev) => //. lia. * move => [hl [hf [ha /andP[] /andP[] etal etab]]] isel. subst. assert (isEtaExp Σ [] a). { rewrite ha. eapply Forall_last; solve_all. } destruct with_guarded_fix eqn:guarded. - { specialize eval_mkApps_tFix_inv_size with (Heval := H0); intros [(args' & ? & Heq) | (? & ? & ? & ? & ?)]; eauto. + { specialize eval_mkApps_tFix_inv_size with (Heval := H); intros [(args' & ? & Heq) | (? & ? & ? & ? & ?)]; eauto. -- subst. solve_discr. + -- eapply (isEtaExp_mkApps_intro _ _ _ [a']); eauto. eapply IHeval1. rewrite isEtaExp_mkApps => //. cbn [expanded_head_viewc]. rtoProp. repeat split; solve_all. 2: eapply All_firstn; eauto. unfold isEtaExp_fixapp, cunfold_fix in *. - destruct nth_error; try easy. noconf H6. + destruct nth_error; try easy. noconf H4. eapply Nat.ltb_lt. lia. } { - specialize eval_mkApps_tFix_inv_size_unguarded with (Heval := H0); intros Hinv; destruct Hinv as [[Heq Hv] | (a_ & a_' & args' & argsv & Heq & Hall & n & fn & Hunf & Haa' & Hev & Hev' & Hsz)]; eauto. + specialize eval_mkApps_tFix_inv_size_unguarded with (Heval := H); intros Hinv; destruct Hinv as [[Heq Hv] | (a_ & a_' & args' & argsv & Heq & Hall & n & fn & Hunf & Haa' & Hev & Hev' & Hsz)]; eauto. -- cbn in *. solve_discr. -- eapply (isEtaExp_mkApps_intro _ _ _ [a']); eauto. - unshelve eapply H1. 2: eauto. lia. + unshelve eapply H0. 2: eauto. lia. eapply (isEtaExp_mkApps_intro). eapply (isEtaExp_mkApps_intro _ _ fn [a_']); eauto. 2: econstructor; [ | econstructor]. - ++ eapply isEtaExp_cunfold_fix. 2: eauto. solve_all. now rewrite app_nil_r in H6. + ++ eapply isEtaExp_cunfold_fix. 2: eauto. solve_all. now rewrite app_nil_r in H4. ++ solve_all. eapply All_firstn in isel. unfold remove_last in Heq. eapply All_Forall in isel. setoid_rewrite Heq in isel. invs isel. eauto. ++ eapply forallb_Forall in isel. eapply Forall_firstn in isel. unfold remove_last in Heq. setoid_rewrite Heq in isel. eapply Forall_All in isel. invs isel. solve_all. subst; eauto. - destruct b0. unshelve eapply H1. 2: eauto. lia. eauto. + destruct b0. unshelve eapply H0. 2: eauto. lia. eauto. } - * intros (? & ? & ? & ?). rtoProp. solve_all. rewrite nth_error_nil in H7. easy. - * move/and4P => [] etat etal etaf etaa. + * intros (? & ? & ? & ?). rtoProp. solve_all. rewrite nth_error_nil in H5. easy. + * move/and4P => [] etat etal etaf etaa. eapply (isEtaExp_mkApps_intro _ _ _ [a']); eauto. } 1:{ move/isEtaExp_tApp'. destruct decompose_app eqn:da. destruct expanded_head_viewc. - * clear IHs. move=> [] hl [] hf [] ha /andP[] hl' etal. + * clear IHs. move=> [] hl [] hf [] ha /andP[] /andP[] hl' etal bargs. destruct block_args; inv bargs. move: H H0. rewrite hf => H H0. - eapply eval_mkApps_Construct_inv in H as [? []];solve_discr. + eapply (eval_mkApps_Construct_inv _ _ _ _ _ wcon) in H as [? []];solve_discr. * solve_all. rtoProp. solve_all. subst. destruct with_guarded_fix eqn:guarded. @@ -1266,10 +1279,10 @@ Proof. eapply IHeval2. rewrite /iota_red. eapply isEtaExp_substl with (Γ := repeat 0 #|br.1|); eauto. { len. } - rewrite isEtaExp_Constructor // in H5. solve_all. - eapply All_skipn. move/andP: H5 => []. repeat solve_all. - eapply forallb_nth_error in H7; tea. - now erewrite H1 in H7. + rewrite isEtaExp_Constructor // in H1. solve_all. + eapply All_skipn. move/andP: H1 => []. repeat solve_all. rtoProp. solve_all. + eapply forallb_nth_error in H3; tea. + now erewrite e2 in H3. - rtoProp; intuition auto. eapply IHeval2. eapply isEtaExp_substl. shelve. now apply forallb_repeat. @@ -1279,9 +1292,9 @@ Proof. - move/isEtaExp_tApp'. destruct decompose_app eqn:da. destruct expanded_head_viewc. - * clear IHs. move=> [] hl [] hf [] ha /andP[] hl' etal. + * clear IHs. move=> [] hl [] hf [] ha /andP[] /andP[] hl' etal bargs. destruct block_args; inv bargs. move: H H0. rewrite hf => H H0. - clear H0; eapply eval_mkApps_Construct_inv in H as [? []]; solve_discr. + clear H0; eapply (eval_mkApps_Construct_inv _ _ _ _ _ wcon) in H as [? []]; solve_discr. * solve_all. rtoProp. solve_all. subst. specialize eval_mkApps_tFix_inv_size_unguarded with (Heval := H); intros Hinv; destruct Hinv as [[Heq Heq'] | (a_ & a_' & args' & argsv & Heq & Hall & n & fn_ & Hunf & Hav & Hsza & Hev & Hsz)]; eauto; try congruence. @@ -1328,9 +1341,9 @@ Proof. eapply IHeval2. specialize (IHeval1 hd). move: IHeval1. rewrite isEtaExp_Constructor. - destruct args => //. now rewrite nth_error_nil in H2. - move=> /andP[] _ hargs. - eapply nth_error_forallb in H2; tea. + destruct args => //. now rewrite nth_error_nil in e3. + intros. rtoProp. + eapply nth_error_forallb in e3; tea. Qed. Lemma isEtaExp_fixapp_mon {mfix idx n n'} : n <= n' -> isEtaExp_fixapp mfix idx n -> isEtaExp_fixapp mfix idx n'. @@ -1382,7 +1395,7 @@ Proof. destruct s. * destruct p; solve_discr. noconf H3. right. len. - move: e; unfold isEtaExp_fixapp. + move: e1; unfold isEtaExp_fixapp. unfold EGlobalEnv.cunfold_fix. destruct nth_error eqn:hnth => //. intros [=]. rewrite H3. rewrite -(All2_length a0). eapply Nat.ltb_lt; lia. * right. len. eapply isEtaExp_fixapp_mon; tea. lia. @@ -1394,7 +1407,7 @@ Proof. destruct s. * destruct p; solve_discr. noconf H2. left. split. - unfold isStuckFix'; rewrite e. len. eapply Nat.leb_le. lia. + unfold isStuckFix'; rewrite e1. len. eapply Nat.leb_le. lia. now rewrite -[tApp _ _](mkApps_app _ _ [av]). * right. len. eapply isEtaExp_fixapp_mon; tea. lia. + eapply mkApps_eq in H1 as [? []] => //; subst. @@ -1466,18 +1479,18 @@ Lemma neval_to_stuck_fix {efl : EEnvFlags} {Σ mfix idx t} : isEtaExp Σ [] t -> @eval opt_wcbv_flags Σ t (tFix mfix idx) -> False. Proof. intros etaΣ wfΣ he hev. - pose proof (eval_etaexp etaΣ wfΣ hev he). + unshelve epose proof (eval_etaexp etaΣ wfΣ hev he). eauto. now apply isEtaExp_tFix in H. Qed. -Lemma neval_to_stuck_fix_app {efl : EEnvFlags} {fl Σ mfix idx t args} : +Lemma neval_to_stuck_fix_app {efl : EEnvFlags} {fl} {wcon : with_constructor_as_block = false} {Σ mfix idx t args} : with_guarded_fix -> isEtaExp_env Σ -> wf_glob Σ -> isEtaExp Σ [] t -> @eval fl Σ t (mkApps (tFix mfix idx) args) -> False. Proof. intros wguard etaΣ wfΣ he hev. - pose proof (eval_etaexp etaΣ wfΣ hev he). + unshelve epose proof (eval_etaexp etaΣ wfΣ hev he); eauto. move: H. move/isEtaExp_tApp. rewrite decompose_app_mkApps // /= // app_nil_r //. @@ -1492,13 +1505,14 @@ Qed. Lemma isEtaExp_tApp_eval {fl} {Σ} {f u v} : with_guarded_fix -> + with_constructor_as_block = false -> @eval fl Σ f v -> isEtaExp Σ [] (tApp f u) -> - (forall kn c args, v <> mkApps (tConstruct kn c) args) -> + (forall kn c args block_args, v <> mkApps (tConstruct kn c block_args) args) -> (forall mfix idx args, v <> mkApps (tFix mfix idx) args) -> let (hd, args) := decompose_app (tApp f u) in match expanded_head_viewc hd with - | expanded_head_construct kn c => False + | expanded_head_construct kn c _ => False | expanded_head_fix mfix idx => args <> [] /\ f = mkApps hd (remove_last args) /\ u = last args u /\ [&& isEtaExp_fixapp mfix idx #|remove_last args|, @@ -1509,14 +1523,14 @@ Lemma isEtaExp_tApp_eval {fl} {Σ} {f u v} : [&& isEtaExp Σ [] hd, forallb (isEtaExp Σ []) args, isEtaExp Σ [] f & isEtaExp Σ [] u] end. Proof. - intros wguard ev eta; revert eta ev. + intros wguard wcon ev eta; revert eta ev. move/isEtaExp_tApp'. cbn -[decompose_app]. destruct decompose_app eqn:da. destruct expanded_head_viewc eqn:cv => //. - * move=> [] hl [] ha [] ht /andP[] etaap etal. + * move=> [] hl [] ha [] ht /andP[] /andP[] etaap etal bargs. destruct block_args; inv bargs. rewrite ha. intros h. eapply eval_mkApps_Construct_inv in h as [? []]. subst v. - intros Hc _. specialize (Hc ind n x). now apply Hc. + intros Hc _. specialize (Hc ind n x). now eapply Hc. auto. * move=> [] hl [] ha [] ht /andP[] /andP[] etafix etab etal. rewrite ha. intros H; eapply eval_stuck_fix_eq in H as [args' [Hargs' [[]|]]]. subst v. @@ -1560,7 +1574,7 @@ Proof. - pose proof (eval_trans' H H0_0). subst a'. econstructor; tea. - pose proof (eval_trans' H H0_0). subst av. eapply eval_fix; tea. - pose proof (eval_trans' H H0_0). subst av. eapply eval_fix_value; tea. - - eapply value_final in X. pose proof (eval_trans' X H0_). subst f. + - eapply value_final in X. pose proof (eval_trans' X H0_). subst f7. pose proof (eval_trans' H H0_0). subst av. eapply eval_fix'; tea. - eapply eval_construct; tea. @@ -1609,12 +1623,12 @@ Proof. eapply eval_app_cong_tApp'. now eapply eval_to_value in evf''. exact e0. exact evres. Qed. -Lemma All_eval_etaexp {fl : WcbvFlags} {efl : EEnvFlags} Σ l l' : +Lemma All_eval_etaexp {fl : WcbvFlags} {wcon : with_constructor_as_block = false } {efl : EEnvFlags} Σ l l' : isEtaExp_env Σ -> wf_glob Σ -> All2 (eval Σ) l l' -> forallb (isEtaExp Σ []) l -> forallb (isEtaExp Σ []) l'. Proof. - intros; solve_all. now eapply eval_etaexp. + intros; solve_all. eapply eval_etaexp; eauto. Unshelve. eauto. Qed. Lemma isFix_mkApps f args : ~~ isFix f -> ~~ isFix (mkApps f args). @@ -1633,7 +1647,7 @@ Proof. intros h. now apply isFix_mkApps. Qed. -Lemma eval_opt_to_target {fl: WcbvFlags} {efl : EEnvFlags} Σ t v : +Lemma eval_opt_to_target {fl: WcbvFlags} {wcon : with_constructor_as_block = false} {efl : EEnvFlags} Σ t v : with_guarded_fix -> isEtaExp_env Σ -> wf_glob Σ -> @@ -1644,7 +1658,7 @@ Proof. intros wguard etaΣ wfΣ. intros H. induction H using eval_mkApps_rect. - - move/(isEtaExp_tApp_eval wguard H) => IH. + - move/(isEtaExp_tApp_eval wguard wcon H) => IH. forward IH by (intros; intro; solve_discr). forward IH by (intros; intro; solve_discr). destruct (decompose_app (tApp a t)) eqn:da. @@ -1662,7 +1676,7 @@ Proof. forward IHeval2 => //. econstructor; eauto. - clear H0. - move/(isEtaExp_tApp_eval wguard H) => IH. + move/(isEtaExp_tApp_eval wguard wcon H) => IH. forward IH by (intros; intro; solve_discr). forward IH by (intros; intro; solve_discr). destruct (decompose_app (tApp f0 a)) eqn:da. @@ -1690,14 +1704,15 @@ Proof. eapply eval_etaexp in IHeval1; tea. - simp_eta. move=> /andP[] etad etabrs. forward IHeval1 => //. - move: (eval_etaexp etaΣ wfΣ IHeval1 etad). - rewrite isEtaExp_Constructor => /andP[] etac etaargs. + unshelve epose proof (eval_etaexp etaΣ wfΣ IHeval1 etad). eauto. + revert H1. + rewrite isEtaExp_Constructor => /andP[] /andP[] etac etaargs bargs. forward_keep IHeval2 => //. eapply isEtaExp_iota_red'; eauto. - eapply forallb_nth_error in etabrs; tea. erewrite H1 in etabrs. - cbn in etabrs. now rewrite -H3 app_nil_r skipn_length in etabrs. + eapply forallb_nth_error in etabrs; tea. erewrite e2 in etabrs. + cbn in etabrs. now rewrite -e4 app_nil_r skipn_length in etabrs. econstructor; tea. - + - congruence. - simp_eta. move=> /andP[] etad etabrs. forward IHeval1 => //. eapply eval_iota_sing => //. tea. @@ -1711,9 +1726,9 @@ Proof. move/isEtaExp_tApp'. destruct decompose_app eqn:da. destruct expanded_head_viewc. - * move=> [] hl [] hf [] ha heta. + * move=> [] hl [] hf [] ha /andP[]/ andP[] heta heta2 bargs. destruct block_args; inv bargs. clear H0. - rewrite hf in H. eapply eval_mkApps_Construct_inv in H as [? []]; solve_discr. + rewrite hf in H. eapply eval_mkApps_Construct_inv in H as [? []]; try solve_discr. auto. * move => [hl [hf [ha /andP[] /andP[] etal etab]]] isel. set (H' := H); assert (eval_depth H' = eval_depth H) by reflexivity. clearbody H'. move: H' H4. rewrite {1 2}hf. intros H'. @@ -1770,8 +1785,8 @@ Proof. move/isEtaExp_tApp'. destruct decompose_app eqn:da. destruct expanded_head_viewc. - * move=> [] hl [] hf [] ha heta. - rewrite hf in H. eapply eval_mkApps_Construct_inv in H as [? []]; solve_discr. + * move=> [] hl [] hf [] ha /andP[]/ andP[] heta heta2 bargs. destruct block_args; inv bargs. + rewrite hf in H. eapply eval_mkApps_Construct_inv in H as [? []]; try solve_discr. eauto. * move => [hl [hf [ha /andP[] /andP[] etal etab]]] isel. rewrite hf in H. elimtype False. @@ -1821,10 +1836,11 @@ Proof. forward IHeval1 by tas. forward IHeval2. { eapply eval_etaexp in H; tea. - move: H; rewrite isEtaExp_mkApps // /= => /andP[] etaapp etaargs. + move: H; rewrite isEtaExp_mkApps // /= => /andP[] /andP[] etaapp etaargs bargs. eapply forallb_nth_error in etaargs; tea. - now erewrite H2 in etaargs. } + now erewrite e3 in etaargs. } eapply eval_proj; tea. + - congruence. - simp_eta => etad. forward IHeval by tas. eapply eval_proj_prop ; tea. @@ -1832,37 +1848,37 @@ Proof. destruct decompose_app eqn:da. rewrite (decompose_app_inv da). destruct expanded_head_viewc. - * move=> [] hl [] hf [] ha /andP[] heta etal. - set (H' := H0) ; assert (eval_depth H' = eval_depth H0) by reflexivity. - clearbody H'. move: H' H4. rewrite {1 2}hf. intros H'. - destruct (eval_mkApps_Construct_size H') as [args'' [evc [evcs hargs heq]]]. - eapply mkApps_eq_inj in heq as [] => //. noconf H4. noconf H5. + * move=> [] hl [] hf [] ha /andP[] /andP[] heta etal bargs. destruct block_args; inv bargs. + set (H' := H) ; assert (eval_depth H' = eval_depth H) by reflexivity. + clearbody H'. move: H' H2. rewrite {1 2}hf. intros H'. + destruct (eval_mkApps_Construct_size wcon H') as [args'' [evc [evcs hargs heq]]]. + eapply mkApps_eq_inj in heq as [] => //. noconf H2. noconf H3. intros hevd. - rewrite (remove_last_last l a hl). + rewrite (remove_last_last l0 a hl). rewrite -[tApp _ _](mkApps_app _ _ [a']). eapply eval_mkApps_Construct; tea. - { now constructor. } + { constructor. cbn [atom]; rewrite e e0 //. } { len. rewrite (All2_length hargs). lia. } eapply All2_app. eapply forallb_remove_last, forallb_All in etal. eapply All2_All_mix_left in hargs; tea. eapply All2_impl; tea. cbn; intros ? ? []. - destruct s as [evxy hevxy]. unshelve eapply H1; tea. lia. + destruct s as [evxy hevxy]. unshelve eapply H0; tea. lia. constructor; [|constructor]. rewrite -ha. eapply IHeval2. rewrite ha. now eapply forallb_last. * move => [hl [hf [ha /andP[] /andP[] etal etab]]] isel. forward IHeval2. { rewrite ha. now eapply forallb_last. } - rewrite (remove_last_last l a hl) /=. + rewrite (remove_last_last l0 a hl) /=. rewrite mkApps_app. eapply eval_construct; tea. - pose proof H0 as Hfix. + pose proof H as Hfix. rewrite hf in Hfix. eapply eval_stuck_fix_eq in Hfix as [args' [hargs [[hstuck ?]|]]]; auto. { solve_discr. } - { cbn in H2. + { cbn in H1. rewrite hf in IHeval1. eapply IHeval1. rewrite isEtaExp_mkApps // /= i /= etab /=. move: isel. - now rewrite {1}(remove_last_last l a hl) /= forallb_app => /andP[]. } + now rewrite {1}(remove_last_last l0 a hl) /= forallb_app => /andP[]. } { now rewrite -ha. } * move=> [] hl [] ha [] ht /andP[] hnth. now rewrite nth_error_nil /= in hnth. @@ -1871,21 +1887,22 @@ Proof. forward IHeval2 by tas. rewrite -(decompose_app_inv da). eapply eval_construct; tea. + - congruence. - move/isEtaExp_tApp'. destruct decompose_app eqn:da. rewrite (decompose_app_inv da). destruct expanded_head_viewc. - * move=> [] hl [] hf [] ha /andP[] heta etal. + * move=> [] hl [] hf [] ha /andP[] /andP[] heta etal bargs. destruct block_args; inv bargs. set (H' := H) ; assert (eval_depth H' = eval_depth H) by reflexivity. - clearbody H'. move: H' H3. rewrite {1 2}hf. intros H'. - destruct (eval_mkApps_Construct_size H') as [args'' [evc [evcs hargs heq]]]. + clearbody H'. move: H' H2. rewrite {1 2}hf. intros H'. + destruct (eval_mkApps_Construct_size wcon H') as [args'' [evc [evcs hargs heq]]]. subst f'. - rewrite isConstructApp_mkApps /isConstructApp /= in H1. - now rewrite !negb_or /= !andb_false_r in H1. + rewrite isConstructApp_mkApps /isConstructApp /= in i. + now rewrite !negb_or /= !andb_false_r in i. * move => [hl [hf [ha /andP[] /andP[] etal etab]]] isel. forward IHeval2. { rewrite ha. now eapply forallb_last. } rewrite (remove_last_last l a hl) /=. - rewrite mkApps_app. rewrite wguard in H1. + rewrite mkApps_app. rewrite wguard in i. move: H H0. rewrite hf. intros H IH. eapply eval_app_cong; tea. @@ -1893,12 +1910,12 @@ Proof. unshelve eapply IH. exact H. lia. pose proof H as Hfix. eapply eval_stuck_fix_eq in Hfix as [args' [hargs [[hstuck ?]|]]]; auto. - { subst f'. rewrite isFixApp_mkApps in H1. - now rewrite !negb_or /= !andb_false_r in H1. } - { rewrite isEtaExp_mkApps // /= i /= etab /=. + { subst f'. rewrite isFixApp_mkApps in i. + now rewrite !negb_or /= !andb_false_r in i. } + { rewrite isEtaExp_mkApps // /= i0 /= etab /=. move: isel. now rewrite {1}(remove_last_last l a hl) /= forallb_app => /andP[]. } - cbn. move: H1. rewrite !negb_or; rtoProp; intuition auto. + cbn. move: i. rewrite !negb_or; rtoProp; intuition auto. now eapply nisFixApp_nisFix. * move=> [] hl [] ha [] ht /andP[] hnth. now rewrite nth_error_nil /= in hnth. @@ -1907,10 +1924,11 @@ Proof. forward IHeval2 by tas. rewrite -(decompose_app_inv da). eapply eval_app_cong; tea. - cbn. rewrite wguard in H1. - cbn. move: H1. rewrite !negb_or; rtoProp; intuition auto. + cbn. rewrite wguard in i. + cbn. move: i. rewrite !negb_or; rtoProp; intuition auto. now eapply nisFixApp_nisFix. - intros hexp. now eapply eval_atom. + Unshelve. all: eauto. Qed. Lemma expanded_global_env_isEtaExp_env {Σ} : expanded_global_env Σ -> isEtaExp_env Σ. diff --git a/erasure/theories/EGenericMapEnv.v b/erasure/theories/EGenericMapEnv.v new file mode 100644 index 000000000..1f1df5bc2 --- /dev/null +++ b/erasure/theories/EGenericMapEnv.v @@ -0,0 +1,339 @@ +(* Distributed under the terms of the MIT license. *) +From Coq Require Import Utf8 Program. +From MetaCoq.Template Require Import config utils Kernames BasicAst EnvMap. +From MetaCoq.Erasure Require Import EAst EAstUtils EInduction EArities + ELiftSubst ESpineView EGlobalEnv EWellformed EEnvMap + EWcbvEval EEtaExpanded ECSubst EWcbvEvalEtaInd EProgram. + +Local Open Scope string_scope. +Set Asymmetric Patterns. +Import MCMonadNotation. + +From Equations Require Import Equations. +Set Equations Transparent. +Local Set Keyed Unification. +Require Import ssreflect ssrbool. + +Section sec. + +Variable gen_transform : global_context -> term -> term. + +Definition gen_transform_constant_decl Σ cb := + {| cst_body := option_map (gen_transform Σ) cb.(cst_body) |}. + +Definition gen_transform_decl Σ d := + match d with + | ConstantDecl cb => ConstantDecl (gen_transform_constant_decl Σ cb) + | InductiveDecl idecl => d + end. + +Definition gen_transform_env Σ := + map (on_snd (gen_transform_decl Σ)) Σ. + +Program Fixpoint gen_transform_env' Σ : global_context := +match Σ with +| [] => [] +| hd :: tl => on_snd (gen_transform_decl tl) hd :: gen_transform_env' tl +end. + +Import EGlobalEnv EExtends. + +Lemma extends_lookup_projection {efl : EEnvFlags} {Σ Σ' p} : extends Σ Σ' -> wf_glob Σ' -> +isSome (lookup_projection Σ p) -> +lookup_projection Σ p = lookup_projection Σ' p. +Proof. +intros ext wf; cbn -[lookup_projection]. +unfold lookup_projection. +destruct lookup_constructor as [[[mdecl idecl] cdecl]|] eqn:hl => //. +simpl. +rewrite (extends_lookup_constructor wf ext _ _ _ hl) //. +Qed. + +Variable efl' : EEnvFlags. +Variable efl : EEnvFlags. + +Hypothesis wellformed_gen_transform_extends : forall {Σ : global_context} t, +forall n, EWellformed.wellformed Σ n t -> +forall {Σ' : global_context}, extends Σ Σ' -> wf_glob Σ' -> +gen_transform Σ t = gen_transform Σ' t. + +Lemma wellformed_gen_transform_decl_extends {Σ : global_context} t : +wf_global_decl Σ t -> +forall {Σ' : global_context}, extends Σ Σ' -> wf_glob Σ' -> +gen_transform_decl Σ t = gen_transform_decl Σ' t. +Proof. +destruct t => /= //. +intros wf Σ' ext wf'. f_equal. unfold gen_transform_constant_decl. f_equal. +destruct (cst_body c) => /= //. f_equal. +now eapply wellformed_gen_transform_extends. +Qed. + +Lemma lookup_env_gen_transform_env_Some {Σ : global_context} kn d : +wf_glob Σ -> +lookup_env Σ kn = Some d -> +∑ Σ' : global_context, + [× extends Σ' Σ, wf_global_decl Σ' d & + lookup_env (gen_transform_env Σ) kn = Some (gen_transform_decl Σ' d)]. +Proof. +induction Σ in |- *; simpl; auto => //. +intros wfg. +case: eqb_specT => //. +- intros ->. cbn. intros [= <-]. exists Σ. split. + now eexists [_]. + cbn. now depelim wfg. + f_equal. symmetry. eapply wellformed_gen_transform_decl_extends. cbn. now depelim wfg. + cbn. now exists [a]. now cbn. +- intros _. + cbn in IHΣ. forward IHΣ. now depelim wfg. + intros hl. specialize (IHΣ hl) as [Σ'' [ext wfgd hl']]. + exists Σ''. split => //. + * destruct ext as [? ->]. + now exists (a :: x). + * rewrite -hl'. f_equal. + clear -wfg wellformed_gen_transform_extends. + eapply map_ext_in => kn hin. unfold on_snd. f_equal. + symmetry. eapply wellformed_gen_transform_decl_extends => //. cbn. + eapply lookup_env_In in hin. 2:now depelim wfg. + depelim wfg. eapply lookup_env_wellformed; tea. + cbn. now exists [a]. +Qed. + +Lemma lookup_env_map_snd Σ f kn : lookup_env (List.map (on_snd f) Σ) kn = option_map f (lookup_env Σ kn). +Proof. +induction Σ; cbn; auto. +case: eqb_spec => //. +Qed. + +Lemma lookup_env_gen_transform_env_None {Σ : global_context} kn : +lookup_env Σ kn = None -> +lookup_env (gen_transform_env Σ) kn = None. +Proof. +cbn. intros hl. rewrite lookup_env_map_snd hl //. +Qed. + +Lemma lookup_env_gen_transform {Σ : global_context} kn : +wf_glob Σ -> +lookup_env (gen_transform_env Σ) kn = option_map (gen_transform_decl Σ) (lookup_env Σ kn). +Proof. +intros wf. +destruct (lookup_env Σ kn) eqn:hl. +- eapply lookup_env_gen_transform_env_Some in hl as [Σ' [ext wf' hl']] => /=. + rewrite hl'. f_equal. + eapply wellformed_gen_transform_decl_extends; eauto. auto. + +- cbn. now eapply lookup_env_gen_transform_env_None in hl. +Qed. + + +Lemma is_propositional_gen_transform {Σ : global_context} ind : + wf_glob Σ -> + inductive_isprop_and_pars Σ ind = inductive_isprop_and_pars (gen_transform_env Σ) ind. +Proof. + rewrite /inductive_isprop_and_pars => wf. + rewrite /lookup_inductive /lookup_minductive. + rewrite (lookup_env_gen_transform (inductive_mind ind) wf). + rewrite /GlobalContextMap.inductive_isprop_and_pars /GlobalContextMap.lookup_inductive + /GlobalContextMap.lookup_minductive. + destruct lookup_env as [[decl|]|] => //. +Qed. + +Lemma is_propositional_cstr_gen_transform {Σ : global_context} ind c : + wf_glob Σ -> + constructor_isprop_pars_decl Σ ind c = constructor_isprop_pars_decl (gen_transform_env Σ) ind c. +Proof. + rewrite /constructor_isprop_pars_decl => wf. + rewrite /lookup_constructor /lookup_inductive /lookup_minductive. + rewrite (lookup_env_gen_transform (inductive_mind ind) wf). + rewrite /GlobalContextMap.inductive_isprop_and_pars /GlobalContextMap.lookup_inductive + /GlobalContextMap.lookup_minductive. + destruct lookup_env as [[decl|]|] => //. +Qed. + +Lemma isFix_mkApps t l : isFix (mkApps t l) = isFix t && match l with [] => true | _ => false end. +Proof. + induction l using rev_ind; cbn. + - now rewrite andb_true_r. + - rewrite mkApps_app /=. now destruct l => /= //; rewrite andb_false_r. +Qed. + +Lemma lookup_constructor_gen_transform {Σ : global_context} {ind c} : + wf_glob Σ -> + lookup_constructor Σ ind c = lookup_constructor (gen_transform_env Σ) ind c. +Proof. + intros wfΣ. rewrite /lookup_constructor /lookup_inductive /lookup_minductive. + rewrite lookup_env_gen_transform // /=. destruct lookup_env => // /=. + destruct g => //. +Qed. + +Lemma lookup_projection_gen_transform {Σ : global_context} {p} : + wf_glob Σ -> + lookup_projection Σ p = lookup_projection (gen_transform_env Σ) p. +Proof. + intros wfΣ. rewrite /lookup_projection. + rewrite -lookup_constructor_gen_transform //. +Qed. + +Lemma constructor_isprop_pars_decl_inductive {Σ ind c} {prop pars cdecl} : + constructor_isprop_pars_decl Σ ind c = Some (prop, pars, cdecl) -> + inductive_isprop_and_pars Σ ind = Some (prop, pars). +Proof. + rewrite /constructor_isprop_pars_decl /inductive_isprop_and_pars /lookup_constructor. + destruct lookup_inductive as [[mdecl idecl]|]=> /= //. + destruct nth_error => //. congruence. +Qed. + +Lemma constructor_isprop_pars_decl_constructor {Σ ind c} {mdecl idecl cdecl} : + lookup_constructor Σ ind c = Some (mdecl, idecl, cdecl) -> + constructor_isprop_pars_decl Σ ind c = Some (ind_propositional idecl, ind_npars mdecl, cdecl). +Proof. + rewrite /constructor_isprop_pars_decl. intros -> => /= //. +Qed. + +Lemma wf_mkApps (ha : has_tApp) Σ k f args : reflect (wellformed Σ k f /\ forallb (wellformed Σ k) args) (wellformed Σ k (mkApps f args)). +Proof. + rewrite wellformed_mkApps //. eapply andP. +Qed. + +Lemma gen_transform_env_extends' {Σ Σ' : global_context} : + extends Σ Σ' -> + wf_glob Σ' -> + List.map (on_snd (gen_transform_decl Σ)) Σ = + List.map (on_snd (gen_transform_decl Σ')) Σ. +Proof. + intros ext. + move=> wfΣ. + assert (Hext : extends Σ Σ); auto. now exists []. + assert (Hwfg : wf_glob Σ). + { eapply extends_wf_glob. exact ext. tea. } + revert Hext Hwfg. + generalize Σ at 1 3 5 6. intros Σ''. + induction Σ'' => //. cbn. + intros hin wfg. depelim wfg. + f_equal. + 2:{ eapply IHΣ'' => //. destruct hin. exists (x ++ [(kn, d)]). rewrite -app_assoc /= //. } + unfold on_snd. cbn. f_equal. + eapply wellformed_gen_transform_decl_extends => //. cbn. + eapply extends_wf_global_decl. 3:tea. + eapply extends_wf_glob; tea. + destruct hin. exists (x ++ [(kn, d)]). rewrite -app_assoc /= //. +Qed. + +Lemma gen_transform_env_eq (Σ : global_context) : wf_glob Σ -> gen_transform_env Σ = gen_transform_env' Σ. +Proof. + intros wf. + unfold gen_transform_env. + induction Σ => //. + cbn. f_equal. + destruct a as [kn d]; unfold on_snd; cbn. f_equal. symmetry. + eapply wellformed_gen_transform_decl_extends => //. cbn. now depelim wf. cbn. now exists [(kn, d)]. cbn. + erewrite <- IHΣ. + 2:now depelim wf. + symmetry. eapply gen_transform_env_extends'; eauto. + cbn. now exists [a]. +Qed. + +Variable Pre : global_context -> term -> Prop. + +Hypothesis gen_transform_wellformed : forall {Σ : global_context} n t, + has_tBox -> has_tRel -> Pre Σ t -> + @wf_glob efl Σ -> @EWellformed.wellformed efl Σ n t -> + EWellformed.wellformed (efl := efl') Σ n (gen_transform Σ t). + +Import EWellformed. + +Lemma gen_transform_wellformed_irrel {Σ : global_context} t : + wf_glob Σ -> + forall n, wellformed (efl := efl') Σ n t -> + wellformed (efl := efl') (gen_transform_env Σ) n t. +Proof. + intros wfΣ. induction t using EInduction.term_forall_list_ind; cbn => //. + all:try solve [intros; unfold wf_fix_gen in *; rtoProp; intuition eauto; solve_all]. + - rewrite lookup_env_gen_transform //. + destruct lookup_env eqn:hl => // /=. + destruct g eqn:hg => /= //. destruct (cst_body c); cbn; eauto. + - rewrite lookup_env_gen_transform //. + destruct lookup_env eqn:hl => // /=; intros; rtoProp; eauto. + destruct g eqn:hg => /= //; intros; rtoProp; eauto. + repeat split; eauto. destruct cstr_as_blocks; rtoProp; repeat split; eauto. solve_all. + - rewrite lookup_env_gen_transform //. + destruct lookup_env eqn:hl => // /=. + destruct g eqn:hg => /= //. subst g. + destruct nth_error => /= //. + intros; rtoProp; intuition auto; solve_all. + - rewrite lookup_env_gen_transform //. + destruct lookup_env eqn:hl => // /=; intros; rtoProp; repeat split; eauto. + destruct g eqn:hg => /= //. +Qed. + +Lemma gen_transform_wellformed_decl_irrel {Σ : global_context} d : + wf_glob Σ -> + wf_global_decl (efl:= efl') Σ d -> + wf_global_decl (efl := efl') (gen_transform_env Σ) d. +Proof. + intros wf; destruct d => /= //. + destruct (cst_body c) => /= //. + now eapply gen_transform_wellformed_irrel. +Qed. + +Hypothesis axioms_efl : forall _ : is_true (@has_axioms efl), is_true (@has_axioms efl'). +Hypothesis cstrs_efl : forall _ : is_true (@has_cstr_params efl), is_true (@has_cstr_params efl'). + +Definition Pre_decl Σ d := match d with ConstantDecl cb => match cb.(cst_body) with Some b => Pre Σ b | _ => True end | _ => True end. + +Lemma gen_transform_decl_wf {Σ : global_context} : + has_tBox -> has_tRel -> wf_glob Σ -> + forall d, wf_global_decl Σ d -> Pre_decl Σ d -> + wf_global_decl (efl := efl') (gen_transform_env Σ) (gen_transform_decl Σ d). +Proof. + intros hasb hasr wf d. + intros hd. intros pre. + eapply gen_transform_wellformed_decl_irrel; tea; eauto. + move: hd. + destruct d => /= //. cbn in pre. + destruct (cst_body c) => /= //. + intros hwf. eapply gen_transform_wellformed => //. auto. + destruct efl => //; eauto. destruct m => //. cbn. unfold wf_minductive. + cbn. move/andP => [] hp //. rtoProp. solve_all. + eapply orb_true_iff. eapply orb_true_iff in hp as []; eauto. + left. eapply cstrs_efl. now rewrite H. +Qed. + +Lemma fresh_global_gen_transform_env {Σ : global_context} kn : + fresh_global kn Σ -> + fresh_global kn (gen_transform_env Σ). +Proof. + induction 1; cbn; constructor; auto. + now eapply Forall_map; cbn. +Qed. + +Fixpoint Pre_glob Σ := + match Σ with + | nil => True + | (kn, d) :: Σ => Pre_decl Σ d /\ Pre_glob Σ + end. + +Lemma gen_transform_env_wf {Σ : global_context} : + has_tBox -> has_tRel -> Pre_glob Σ -> + wf_glob Σ -> wf_glob (efl := efl') (gen_transform_env Σ). +Proof. + intros hasb hasrel pre. + intros wfg. rewrite gen_transform_env_eq //. + induction wfg; cbn; constructor; invs pre; auto. + - rewrite /= -(gen_transform_env_eq Σ) => //. eauto. + eapply gen_transform_decl_wf => //. + - rewrite /= -(gen_transform_env_eq Σ) //. + now eapply fresh_global_gen_transform_env. +Qed. + +(* Definition gen_transform_program (p : eprogram_env) := + (gen_transform_env p.1, gen_transform p.1 p.2). + +Definition gen_transform_program_wf (p : eprogram_env) {hastbox : has_tBox} {hastrel : has_tRel} : + wf_eprogram_env efl p -> wf_eprogram (efl') (gen_transform_program p). +Proof. + intros []; split. + now eapply gen_transform_env_wf. + cbn. eapply gen_transform_wellformed_irrel => //. now eapply gen_transform_wellformed. +Qed. *) + +End sec. \ No newline at end of file diff --git a/erasure/theories/EGlobalEnv.v b/erasure/theories/EGlobalEnv.v index 3448f7540..7294462e2 100644 --- a/erasure/theories/EGlobalEnv.v +++ b/erasure/theories/EGlobalEnv.v @@ -73,6 +73,10 @@ Section Lookups. mdecl <- lookup_minductive kn ;; ret mdecl.(ind_npars). + Definition lookup_inductive_kind kn : option recursivity_kind := + mdecl <- lookup_minductive kn ;; + ret mdecl.(ind_finite). + Definition lookup_constructor kn c : option (mutual_inductive_body * one_inductive_body * constructor_body) := '(mdecl, idecl) <- lookup_inductive kn ;; cdecl <- nth_error idecl.(ind_ctors) c ;; @@ -247,7 +251,7 @@ Definition is_constructor_app_or_box t := | a => let (f, a) := decompose_app a in match f with - | tConstruct _ _ => true + | tConstruct _ _ _ => true | _ => false end end. diff --git a/erasure/theories/EInduction.v b/erasure/theories/EInduction.v index 61a591530..3b28ad983 100644 --- a/erasure/theories/EInduction.v +++ b/erasure/theories/EInduction.v @@ -25,14 +25,15 @@ Lemma term_forall_list_ind : P t -> forall t0 : term, P t0 -> P (tLetIn n t t0)) -> (forall t u : term, P t -> P u -> P (tApp t u)) -> (forall s, P (tConst s)) -> - (forall (i : inductive) (n : nat), P (tConstruct i n)) -> + (forall (i : inductive) (n : nat) (args : list term), + All P args -> P (tConstruct i n args)) -> (forall (p : inductive * nat) (t : term), P t -> forall l : list (list name * term), All (fun x => P x.2) l -> P (tCase p t l)) -> (forall (s : projection) (t : term), P t -> P (tProj s t)) -> (forall (m : mfixpoint term) (n : nat), All (fun x => P (dbody x)) m -> P (tFix m n)) -> (forall (m : mfixpoint term) (n : nat), All (fun x => P (dbody x)) m -> P (tCoFix m n)) -> - (* (forall p, P (tPrim p)) -> *) + (forall p, P (tPrim p)) -> forall t : term, P t. Proof. intros until t. revert t. @@ -50,6 +51,11 @@ Proof. destruct l; constructor; [|apply auxl']. apply auxt. + revert l. + fix auxl' 1. + destruct l; constructor; [|apply auxl']. + apply auxt. + revert m. fix auxm 1. destruct m; constructor; [|apply auxm]. @@ -93,6 +99,7 @@ Fixpoint size t : nat := | tProj p c => S (size c) | tFix mfix idx => S (list_size (fun x => size (dbody x)) mfix) | tCoFix mfix idx => S (list_size (fun x => size (dbody x)) mfix) + | tConstruct _ _ ignore_args => S (list_size size ignore_args) | _ => 1 end. @@ -168,7 +175,7 @@ Qed. Lemma size_mkApps_l {f l} (Hf : ~~ isApp f) (Hl : l <> []) : list_size size l < size (mkApps f l). Proof. rewrite size_mkApps. - destruct f => /= //; lia. + destruct f => /= //; try lia. Qed. (** Custom induction principle on syntax, dealing with the various lists appearing in terms. *) @@ -202,13 +209,14 @@ Section MkApps_rec. (papp : forall t u, ~~ isApp t -> u <> nil -> P t -> All P u -> P (mkApps t u)) (pconst : forall s, P (tConst s)) - (pconstruct : forall (i : inductive) (n : nat), P (tConstruct i n)) + (pconstruct : forall (i : inductive) (n : nat) args, All P args -> P (tConstruct i n args)) (pcase : forall (p : inductive * nat) (t : term), P t -> forall l : list (list name * term), All (fun x => P x.2) l -> P (tCase p t l)) (pproj : forall (s : projection) (t : term), P t -> P (tProj s t)) (pfix : forall (m : mfixpoint term) (n : nat), All (fun x => P (dbody x)) m -> P (tFix m n)) - (pcofix : forall (m : mfixpoint term) (n : nat), All (fun x => P (dbody x)) m -> P (tCoFix m n)). + (pcofix : forall (m : mfixpoint term) (n : nat), All (fun x => P (dbody x)) m -> P (tCoFix m n)) + (pprim : forall p, P (tPrim p)). Definition inspect {A} (x : A) : { y : A | x = y } := exist _ x eq_refl. @@ -229,11 +237,12 @@ Section MkApps_rec. let pl := All_rec P id l (fun x H => rec x) in rew _ in papp t l napp nonnil pt pl } | tConst k => pconst k - | tConstruct i n => pconstruct i n + | tConstruct i n args => pconstruct i n _ (All_rec P id args (fun x H => rec x)) | tCase ina c brs => pcase ina c (rec c) brs (All_rec P (fun x => x.2) brs (fun x H => rec x)) | tProj p c => pproj p c (rec c) | tFix mfix idx => pfix mfix idx (All_rec P dbody mfix (fun x H => rec x)) - | tCoFix mfix idx => pcofix mfix idx (All_rec P dbody mfix (fun x H => rec x)). + | tCoFix mfix idx => pcofix mfix idx (All_rec P dbody mfix (fun x H => rec x)) + | tPrim p => pprim p. Proof. all:unfold MR; cbn; auto with arith. 4:lia. - clear -napp nonnil da rec. @@ -260,11 +269,12 @@ Section MkApps_rec. (plet : forall (n : name) (t : term), forall t0 : term, P (tLetIn n t t0)) (papp : forall t u, ~~ isApp t -> u <> nil -> P (mkApps t u)) (pconst : forall s, P (tConst s)) - (pconstruct : forall (i : inductive) (n : nat), P (tConstruct i n)) + (pconstruct : forall (i : inductive) (n : nat) args, P (tConstruct i n args)) (pcase : forall (p : inductive * nat) (t : term) (l : list (list name * term)), P (tCase p t l)) (pproj : forall (s : projection) (t : term), P (tProj s t)) (pfix : forall (m : mfixpoint term) (n : nat), P (tFix m n)) - (pcofix : forall (m : mfixpoint term) (n : nat), P (tCoFix m n)). + (pcofix : forall (m : mfixpoint term) (n : nat), P (tCoFix m n)) + (pprim : forall p, P (tPrim p)). Import EqNotations. @@ -281,11 +291,12 @@ Section MkApps_rec. let nonnil := decompose_app_app _ _ _ _ da in rew [P] (eq_sym (decompose_app_inv da)) in papp t l napp nonnil } | tConst k => pconst k - | tConstruct i n => pconstruct i n + | tConstruct i n args => pconstruct i n args | tCase ina c brs => pcase ina c brs | tProj p c => pproj p c | tFix mfix idx => pfix mfix idx - | tCoFix mfix idx => pcofix mfix idx. + | tCoFix mfix idx => pcofix mfix idx + | tPrim p => pprim p. End MkApps_case. diff --git a/erasure/theories/EInlineProjections.v b/erasure/theories/EInlineProjections.v index 3f99c9e9c..795ff789a 100644 --- a/erasure/theories/EInlineProjections.v +++ b/erasure/theories/EInlineProjections.v @@ -23,8 +23,15 @@ Ltac introdep := let H := fresh in intros H; depelim H. Hint Constructors eval : core. (** Allow everything in terms *) -Local Existing Instance all_env_flags. +Definition switch_no_params (efl : EEnvFlags) := + {| has_axioms := has_axioms; + has_cstr_params := false; + term_switches := term_switches ; + cstr_as_blocks := false + |}. +Definition flags_after_projs := (switch_no_params all_env_flags). +Local Existing Instance flags_after_projs. Arguments lookup_projection : simpl never. Arguments GlobalContextMap.lookup_projection : simpl never. @@ -90,8 +97,8 @@ Section optimize. | tBox => t | tVar _ => t | tConst _ => t - | tConstruct _ _ => t - (* | tPrim _ => t *) + | tConstruct ind n args => tConstruct ind n (map optimize args) + | tPrim _ => t end. Lemma optimize_mkApps f l : optimize (mkApps f l) = mkApps (optimize f) (map optimize l). @@ -105,7 +112,11 @@ Section optimize. (* move to globalenv *) - + Lemma isLambda_optimize t : isLambda t -> isLambda (optimize t). + Proof. destruct t => //. Qed. + Lemma isBox_optimize t : isBox t -> isBox (optimize t). + Proof. destruct t => //. Qed. + Lemma wf_optimize t k : wf_glob Σ -> wellformed Σ k t -> wellformed Σ k (optimize t). @@ -116,6 +127,7 @@ Section optimize. rewrite -> ?map_map_compose, ?compose_on_snd, ?compose_map_def, ?map_length; unfold wf_fix_gen, test_def in *; simpl closed in *; try solve [simpl subst; simpl closed; f_equal; auto; rtoProp; solve_all]; try easy. + - rtoProp. split; eauto. destruct args; eauto. - move/andP: H => [] /andP[] -> clt cll /=. rewrite IHt //=. solve_all. - rewrite GlobalContextMap.lookup_projection_spec. @@ -127,6 +139,7 @@ Section optimize. rewrite IHt //=; len. apply Nat.ltb_lt. lia. - len. rtoProp; solve_all. rewrite forallb_map; solve_all. + now eapply isLambda_optimize. solve_all. - len. rtoProp; solve_all. rewrite forallb_map; solve_all. Qed. @@ -142,6 +155,7 @@ Section optimize. unfold wf_fix, test_def in *; simpl closed in *; try solve [simpl subst; simpl closed; f_equal; auto; rtoProp; solve_all]; try easy. - destruct (k ?= n0)%nat; auto. + - f_equal. rtoProp. now destruct args; inv H0. - move/andP: wft => [] /andP[] hi hb hl. rewrite IHb. f_equal. unfold on_snd; solve_all. repeat toAll. f_equal. solve_all. unfold on_snd; cbn. f_equal. rewrite a0 //. now rewrite -Nat.add_assoc. @@ -152,7 +166,7 @@ Section optimize. have arglen := wellformed_projection_args wfΣ hl. case: Nat.compare_spec. lia. lia. auto. - - f_equal. move/andP: wft => [hidx hb]. + - f_equal. move/andP: wft => [hlam /andP[] hidx hb]. solve_all. unfold map_def. f_equal. eapply a0. now rewrite -Nat.add_assoc. - f_equal. move/andP: wft => [hidx hb]. @@ -213,7 +227,7 @@ Section optimize. intros wfΣ hfix. unfold cunfold_fix. rewrite nth_error_map. - cbn in hfix. move/andP: hfix => [] hidx hfix. + cbn in hfix. move/andP: hfix => [] hlam /andP[] hidx hfix. destruct nth_error eqn:hnth => //. intros [= <- <-] => /=. f_equal. rewrite optimize_substl //. eapply wellformed_fix_subst => //. @@ -284,7 +298,8 @@ Lemma wellformed_optimize_extends {wfl: EEnvFlags} {Σ : GlobalContextMap.t} t : Proof. induction t using EInduction.term_forall_list_ind; cbn -[lookup_constant lookup_inductive GlobalContextMap.lookup_projection]; intros => //. - all:unfold wf_fix_gen in *; rtoProp; intuition auto. + all:unfold wf_fix_gen in *; rtoProp; intuition auto. + 5:{ destruct cstr_as_blocks; rtoProp. f_equal; eauto; solve_all. destruct args; cbn in *; eauto. } all:f_equal; eauto; solve_all. - rewrite !GlobalContextMap.lookup_projection_spec. rewrite -(extends_lookup_projection H0 H1 H3). @@ -364,7 +379,7 @@ Proof. rewrite hl'. f_equal. eapply wellformed_optimize_decl_extends; eauto. auto. - - cbn. now eapply lookup_env_optimize_env_None in hl. + - cbn. now eapply lookup_env_optimize_env_None in hl. Qed. Lemma is_propositional_optimize {efl : EEnvFlags} {Σ : GlobalContextMap.t} ind : @@ -406,7 +421,7 @@ Proof. now rewrite List.rev_length hskip Nat.add_0_r. Qed. -Definition disable_prop_cases fl := {| with_prop_case := false; with_guarded_fix := fl.(@with_guarded_fix) |}. +Definition disable_prop_cases fl := {| with_prop_case := false; with_guarded_fix := fl.(@with_guarded_fix) ; with_constructor_as_block := false |}. Lemma isFix_mkApps t l : isFix (mkApps t l) = isFix t && match l with [] => true | _ => false end. Proof. @@ -472,7 +487,8 @@ Proof. * intros hnth. now apply IHs. Qed. -Lemma optimize_correct (efl := all_env_flags) {fl} {Σ : GlobalContextMap.t} t v : + +Lemma optimize_correct {fl} {wcon : with_constructor_as_block = false} { Σ : GlobalContextMap.t} t v : wf_glob Σ -> @eval fl Σ t v -> wellformed Σ 0 t -> @@ -486,7 +502,7 @@ Proof. eapply eval_wellformed in ev2; tea => //. eapply eval_wellformed in ev1; tea => //. econstructor; eauto. - rewrite -(optimize_csubst _ 1) //. + rewrite -(optimize_csubst _ 1) //. apply IHev3. eapply wellformed_csubst => //. - move/andP => [] clb0 clb1. @@ -501,21 +517,23 @@ Proof. eapply nth_error_forallb in wfbrs; tea. rewrite Nat.add_0_r in wfbrs. forward IHev2. eapply wellformed_iota_red; tea => //. - rewrite optimize_iota_red in IHev2 => //. now rewrite e2. + rewrite optimize_iota_red in IHev2 => //. now rewrite e4. econstructor; eauto. rewrite -is_propositional_cstr_optimize //. tea. - rewrite nth_error_map e0 //. len. len. - + rewrite nth_error_map e2 //. len. len. + + - congruence. + - move/andP => [] /andP[] hl wfd wfbrs. forward IHev2. eapply wellformed_substl; tea => //. rewrite forallb_repeat //. len. - rewrite e0 /= Nat.add_0_r in wfbrs. now move/andP: wfbrs. + rewrite e1 /= Nat.add_0_r in wfbrs. now move/andP: wfbrs. rewrite optimize_substl in IHev2 => //. rewrite forallb_repeat //. len. - rewrite e0 /= Nat.add_0_r in wfbrs. now move/andP: wfbrs. + rewrite e1 /= Nat.add_0_r in wfbrs. now move/andP: wfbrs. eapply eval_iota_sing => //; eauto. rewrite -is_propositional_optimize //. - rewrite e0 //. simpl. + rewrite e1 //. simpl. rewrite map_repeat in IHev2 => //. - move/andP => [] clf cla. rewrite optimize_mkApps in IHev1. @@ -587,7 +605,7 @@ Proof. move/wf_mkApps: ev1 => [] wfc wfargs. destruct lookup_projection as [[[[mdecl idecl] cdecl'] pdecl]|] eqn:hl' => //. pose proof (lookup_projection_lookup_constructor hl'). - rewrite (constructor_isprop_pars_decl_constructor H) in e. noconf e. + rewrite (constructor_isprop_pars_decl_constructor H) in e1. noconf e1. forward IHev1 by auto. forward IHev2. eapply nth_error_forallb in wfargs; tea. rewrite optimize_mkApps /= in IHev1. @@ -604,18 +622,20 @@ Proof. rewrite nth_error_rev. len. rewrite skipn_length. lia. rewrite List.rev_involutive. len. rewrite skipn_length. rewrite nth_error_skipn nth_error_map. - rewrite e0 -H1. + rewrite e2 -H1. assert((ind_npars mdecl + cstr_nargs cdecl - ind_npars mdecl) = cstr_nargs cdecl) by lia. rewrite H3. - eapply (f_equal (option_map (optimize Σ))) in e1. - cbn in e1. rewrite -e1. f_equal. f_equal. lia. + eapply (f_equal (option_map (optimize Σ))) in e3. + cbn in e3. rewrite -e3. f_equal. f_equal. lia. + + - congruence. - move=> /andP[] iss cld. rewrite GlobalContextMap.lookup_projection_spec. destruct lookup_projection as [[[[mdecl idecl] cdecl'] pdecl]|] eqn:hl' => //. pose proof (lookup_projection_lookup_constructor hl'). simpl in H. - move: e. rewrite /inductive_isprop_and_pars. + move: e0. rewrite /inductive_isprop_and_pars. rewrite (lookup_constructor_lookup_inductive H) /=. intros [= eq <-]. eapply eval_iota_sing => //; eauto. @@ -629,11 +649,13 @@ Proof. - move/andP=> [] clf cla. rewrite optimize_mkApps. eapply eval_construct; tea. - rewrite -lookup_constructor_optimize //. exact e. + rewrite -lookup_constructor_optimize //. exact e0. rewrite optimize_mkApps in IHev1. now eapply IHev1. now len. now eapply IHev2. + - congruence. + - move/andP => [] clf cla. specialize (IHev1 clf). specialize (IHev2 cla). eapply eval_app_cong; eauto. @@ -643,28 +665,27 @@ Proof. * destruct with_guarded_fix. + move: i. rewrite !negb_or. - rewrite optimize_mkApps !isFixApp_mkApps !isConstructApp_mkApps. + rewrite optimize_mkApps !isFixApp_mkApps !isConstructApp_mkApps !isPrimApp_mkApps. destruct args using rev_case => // /=. rewrite map_app !mkApps_app /= //. rewrite !andb_true_r. rtoProp; intuition auto. destruct v => /= //. destruct v => /= //. + destruct v => /= //. + move: i. rewrite !negb_or. - rewrite optimize_mkApps !isConstructApp_mkApps. + rewrite optimize_mkApps !isConstructApp_mkApps !isPrimApp_mkApps. destruct args using rev_case => // /=. rewrite map_app !mkApps_app /= //. destruct v => /= //. - destruct t => //. all:constructor; eauto. + cbn [atom optimize] in i |- *. + rewrite -lookup_constructor_optimize //. + destruct l; cbn in *; eauto. Qed. From MetaCoq.Erasure Require Import EEtaExpanded. -Lemma isLambda_optimize Σ t : isLambda t -> isLambda (optimize Σ t). -Proof. destruct t => //. Qed. -Lemma isBox_optimize Σ t : isBox t -> isBox (optimize Σ t). -Proof. destruct t => //. Qed. - Lemma optimize_expanded {Σ : GlobalContextMap.t} t : expanded Σ t -> expanded Σ (optimize Σ t). Proof. induction 1 using expanded_ind. @@ -779,12 +800,14 @@ Definition disable_projections_term_flags (et : ETermFlags) := ; has_tProj := false ; has_tFix := has_tFix ; has_tCoFix := has_tCoFix + ; has_tPrim := has_tPrim |}. Definition disable_projections_env_flag (efl : EEnvFlags) := - {| has_axioms := true; + {| has_axioms := efl.(@has_axioms); term_switches := disable_projections_term_flags term_switches; - has_cstr_params := true |}. + has_cstr_params := efl.(@has_cstr_params) ; + cstr_as_blocks := efl.(@cstr_as_blocks) |}. Lemma optimize_wellformed {efl : EEnvFlags} {Σ : GlobalContextMap.t} n t : has_tBox -> has_tRel -> @@ -794,8 +817,10 @@ Proof. intros hbox hrel wfΣ. induction t in n |- * using EInduction.term_forall_list_ind => //. all:try solve [cbn; rtoProp; intuition auto; solve_all]. - - simpl. destruct lookup_constant => //. - move/andP => [] hasc _ => //. now rewrite hasc. + - cbn -[lookup_constructor_pars_args]. intros. rtoProp. repeat split; eauto. + destruct cstr_as_blocks; rtoProp; eauto. + destruct lookup_constructor_pars_args as [ [] | ]; eauto. split; len. solve_all. split; eauto. + solve_all. now destruct args; invs H0. - cbn. move/andP => [] /andP[] hast hl wft. rewrite GlobalContextMap.lookup_projection_spec. destruct lookup_projection as [[[[mdecl idecl] cdecl] pdecl]|] eqn:hl'; auto => //. @@ -804,7 +829,7 @@ Proof. rewrite hrel IHt //= andb_true_r. have hargs' := wellformed_projection_args wfΣ hl'. apply Nat.ltb_lt. len. - - cbn. unfold wf_fix; rtoProp; intuition auto; solve_all. now len. + - cbn. unfold wf_fix; rtoProp; intuition auto; solve_all. now eapply isLambda_optimize. now len. unfold test_def in *. len. eauto. - cbn. unfold wf_fix; rtoProp; intuition auto; solve_all. now len. unfold test_def in *. len. eauto. @@ -822,9 +847,13 @@ Proof. - rewrite lookup_env_optimize //. destruct lookup_env eqn:hl => // /=. destruct g eqn:hg => /= //. + repeat (rtoProp; intuition auto). + destruct has_axioms => //. cbn in *. + destruct (cst_body c) => //. - rewrite lookup_env_optimize //. - destruct lookup_env eqn:hl => // /=. - destruct g eqn:hg => /= //. + destruct lookup_env eqn:hl => // /=; intros; rtoProp; eauto. + destruct g eqn:hg => /= //; intros; rtoProp; eauto. + repeat split; eauto. destruct cstr_as_blocks; rtoProp; repeat split; eauto. solve_all. - rewrite lookup_env_optimize //. destruct lookup_env eqn:hl => // /=. destruct g eqn:hg => /= //. subst g. @@ -853,9 +882,7 @@ Proof. move: hd. destruct d => /= //. destruct (cst_body c) => /= //. - intros hwf. eapply optimize_wellformed => //. auto. - destruct efl => //. destruct m => //. cbn. unfold wf_minductive. - cbn. move/andP => [] hp //. + intros hwf. eapply optimize_wellformed => //. Qed. Lemma fresh_global_optimize_env {Σ : GlobalContextMap.t} kn : diff --git a/erasure/theories/ELiftSubst.v b/erasure/theories/ELiftSubst.v index 91f9b59ad..bb4f9feea 100644 --- a/erasure/theories/ELiftSubst.v +++ b/erasure/theories/ELiftSubst.v @@ -34,8 +34,8 @@ Fixpoint lift n k t : term := | tBox => t | tVar _ => t | tConst _ => t - | tConstruct _ _ => t - (* | tPrim _ => t *) + | tConstruct ind i args => tConstruct ind i (map (lift n k) args) + | tPrim _ => t end. Notation lift0 n := (lift n 0). @@ -69,6 +69,7 @@ Fixpoint subst s k u := let k' := List.length mfix + k in let mfix' := List.map (map_def (subst s k')) mfix in tCoFix mfix' idx + | tConstruct ind i args => tConstruct ind i (map (subst s k) args) | x => x end. @@ -95,6 +96,7 @@ Fixpoint closedn k (t : term) : bool := | tCoFix mfix idx => let k' := List.length mfix + k in List.forallb (test_def (closedn k')) mfix + | tConstruct ind i args => forallb (closedn k) args | _ => true end. @@ -106,7 +108,7 @@ Require Import PeanoNat. Import Nat. Lemma lift_rel_ge : - forall k n p, p <= n -> lift k p (tRel n) = tRel (k + n). + forall k n p, p <= n -> lift k p (tRel n) = tRel (k + n). Proof. intros; simpl in |- *. now elim (leb_spec p n). @@ -450,8 +452,8 @@ Proof. revert H. elim (Nat.ltb_spec n0 k); intros; try easy. - cbn. f_equal; auto. rtoProp; solve_all. - rtoProp; solve_all. - destruct x; f_equal; cbn in *. now apply a0. + rtoProp; solve_all. + destruct x; f_equal; cbn in *. eauto. Qed. Lemma closed_upwards {k t} k' : closedn k t -> k' >= k -> closedn k' t. @@ -604,6 +606,7 @@ Proof. - specialize (IHt2 (S k')). rewrite <- Nat.add_succ_comm in IHt2. rewrite IHt1 // IHt2 //. + - eapply All_forallb_eq_forallb; eauto. - rewrite IHt //. f_equal. eapply All_forallb_eq_forallb; tea. cbn. intros. specialize (H (#|x.1| + k')). diff --git a/erasure/theories/EOptimizePropDiscr.v b/erasure/theories/EOptimizePropDiscr.v index 64a4ef6f7..db714fe13 100644 --- a/erasure/theories/EOptimizePropDiscr.v +++ b/erasure/theories/EOptimizePropDiscr.v @@ -61,8 +61,8 @@ Section optimize. | tBox => t | tVar _ => t | tConst _ => t - | tConstruct _ _ => t - (* | tPrim _ => t *) + | tConstruct ind i args => tConstruct ind i (map optimize args) + | tPrim _ => t end. Lemma optimize_mkApps f l : optimize (mkApps f l) = mkApps (optimize f) (map optimize l). @@ -366,7 +366,8 @@ Proof. lookup_projection GlobalContextMap.inductive_isprop_and_pars]; intros => //. all:unfold wf_fix_gen in *; rtoProp; intuition auto. - all:f_equal; eauto; solve_all. + all:try now f_equal; eauto; solve_all. + - destruct cstr_as_blocks; rtoProp; eauto. f_equal. solve_all. destruct args; inv H2. reflexivity. - rewrite !GlobalContextMap.inductive_isprop_and_pars_spec. assert (map (on_snd (optimize Σ)) l = map (on_snd (optimize Σ')) l) as -> by solve_all. rewrite (extends_inductive_isprop_and_pars H0 H1 H2). @@ -522,7 +523,7 @@ Proof. destruct nth_error => //. congruence. Qed. -Lemma optimize_correct {efl : EEnvFlags} {fl} {Σ : GlobalContextMap.t} t v : +Lemma optimize_correct {efl : EEnvFlags} {fl}{wcon : with_constructor_as_block = false} {Σ : GlobalContextMap.t} t v : wf_glob Σ -> closed_env Σ -> @Ee.eval fl Σ t v -> @@ -550,19 +551,21 @@ Proof. rewrite optimize_iota_red in IHev2. eapply eval_closed in ev1 => //. rewrite GlobalContextMap.inductive_isprop_and_pars_spec. - rewrite (constructor_isprop_pars_decl_inductive e). - eapply eval_iota; eauto. tea. + rewrite (constructor_isprop_pars_decl_inductive e1). + eapply eval_iota; eauto. now rewrite -is_propositional_cstr_optimize. - rewrite nth_error_map e0 //. now len. cbn. - rewrite -e2. rewrite !skipn_length map_length //. + rewrite nth_error_map e2 //. now len. cbn. + rewrite -e4. rewrite !skipn_length map_length //. eapply IHev2. eapply closed_iota_red => //; tea. eapply nth_error_forallb in clbrs; tea. cbn in clbrs. now rewrite Nat.add_0_r in clbrs. + - congruence. + - move/andP => [] cld clbrs. rewrite GlobalContextMap.inductive_isprop_and_pars_spec. - rewrite e e0 /=. + rewrite e0 e1 /=. subst brs. cbn in clbrs. rewrite Nat.add_0_r andb_true_r in clbrs. rewrite optimize_substl in IHev2. eapply All_forallb, All_repeat => //. @@ -657,26 +660,30 @@ Proof. eapply eval_closed in ev1; tea. move: ev1; rewrite closedn_mkApps /= => clargs. rewrite GlobalContextMap.inductive_isprop_and_pars_spec. - rewrite (constructor_isprop_pars_decl_inductive e). + rewrite (constructor_isprop_pars_decl_inductive e1). rewrite optimize_mkApps in IHev1. specialize (IHev1 cld). eapply Ee.eval_proj; tea. now rewrite -is_propositional_cstr_optimize. - now len. rewrite nth_error_map e1 //. + now len. rewrite nth_error_map e3 //. eapply IHev2. - eapply nth_error_forallb in e1; tea. + eapply nth_error_forallb in e3; tea. + + - congruence. - rewrite GlobalContextMap.inductive_isprop_and_pars_spec. - now rewrite e. + now rewrite e0. - move/andP=> [] clf cla. rewrite optimize_mkApps. eapply eval_construct; tea. - rewrite -lookup_constructor_optimize //. exact e. + rewrite -lookup_constructor_optimize //. exact e0. rewrite optimize_mkApps in IHev1. now eapply IHev1. now len. now eapply IHev2. + - congruence. + - move/andP => [] clf cla. specialize (IHev1 clf). specialize (IHev2 cla). eapply Ee.eval_app_cong; eauto. @@ -686,34 +693,23 @@ Proof. * destruct with_guarded_fix. + move: i. rewrite !negb_or. - rewrite optimize_mkApps !isFixApp_mkApps !isConstructApp_mkApps. + rewrite optimize_mkApps !isFixApp_mkApps !isConstructApp_mkApps !isPrimApp_mkApps. destruct args using rev_case => // /=. rewrite map_app !mkApps_app /= //. rewrite !andb_true_r. rtoProp; intuition auto. destruct v => /= //. destruct v => /= //. + destruct v => /= //. + move: i. rewrite !negb_or. - rewrite optimize_mkApps !isConstructApp_mkApps. + rewrite optimize_mkApps !isConstructApp_mkApps !isPrimApp_mkApps. destruct args using rev_case => // /=. rewrite map_app !mkApps_app /= //. destruct v => /= //. - destruct t => //. - all:constructor; eauto. + all:constructor; eauto. cbn [atom optimize] in i |- *. + rewrite -lookup_constructor_optimize //. destruct l => //. Qed. -(* -Lemma optimize_extends Σ Σ' : - wf_glob Σ' -> - extends Σ Σ' -> - forall t b, optimize Σ t = b -> optimize Σ' t = b. -Proof. - intros wf ext. - induction t using EInduction.term_forall_list_ind; cbn => //. - all:try solve [f_equal; solve_all]. - destruct inductive_isp - rewrite (extends_is_propositional wf ext). - *) - From MetaCoq.Erasure Require Import EEtaExpanded. Lemma isLambda_optimize Σ t : isLambda t -> isLambda (optimize Σ t). @@ -841,6 +837,8 @@ Proof. intros wfΣ hbox hrel. induction t in n |- * using EInduction.term_forall_list_ind => //. all:try solve [cbn; rtoProp; intuition auto; solve_all]. + - cbn -[lookup_constructor]. intros. destruct cstr_as_blocks; rtoProp; repeat split; eauto. 2:solve_all. + 2: now destruct args; inv H0. len. eauto. - cbn -[GlobalContextMap.inductive_isprop_and_pars lookup_inductive]. move/and3P => [] hasc /andP[]hs ht hbrs. destruct GlobalContextMap.inductive_isprop_and_pars as [[[|] _]|] => /= //. destruct l as [|[br n'] [|l']] eqn:eql; simpl. @@ -859,7 +857,7 @@ Proof. - cbn -[GlobalContextMap.inductive_isprop_and_pars lookup_inductive]. move/andP => [] /andP[]hasc hs ht. destruct GlobalContextMap.inductive_isprop_and_pars as [[[|] _]|] => /= //. all:rewrite hasc hs /=; eauto. - - cbn. unfold wf_fix; rtoProp; intuition auto; solve_all. now len. + - cbn. unfold wf_fix; rtoProp; intuition auto; solve_all. now eapply isLambda_optimize. now len. unfold test_def in *. len. eauto. - cbn. unfold wf_fix; rtoProp; intuition auto; solve_all. now len. unfold test_def in *. len. eauto. @@ -878,8 +876,9 @@ Proof. destruct g eqn:hg => /= //. subst g. destruct (cst_body c) => //. - rewrite lookup_env_optimize //. - destruct lookup_env eqn:hl => // /=. - destruct g eqn:hg => /= //. + destruct lookup_env eqn:hl => // /=; intros; rtoProp; eauto. + destruct g eqn:hg => /= //; intros; rtoProp; eauto. + repeat split; eauto. destruct cstr_as_blocks; rtoProp; repeat split; len; eauto. 1: solve_all. - rewrite lookup_env_optimize //. destruct lookup_env eqn:hl => // /=. destruct g eqn:hg => /= //. subst g. diff --git a/erasure/theories/EPretty.v b/erasure/theories/EPretty.v index 4322008aa..049ba801b 100644 --- a/erasure/theories/EPretty.v +++ b/erasure/theories/EPretty.v @@ -84,6 +84,12 @@ Module PrintTermTree. let ctx' := List.map (fun d => {| decl_name := dname d; decl_body := None |}) defs in print_list (print_def (print_term (ctx' ++ Γ)%list true false)) (nl ^ " with ") defs. + Definition print_prim {term} (soft : term -> Tree.t) (p : @prim_val EAst.term) : Tree.t := + match p.π2 return Tree.t with + | primIntModel f => "(int: " ^ Primitive.string_of_prim_int f ^ ")" + | primFloatModel f => "(float: " ^ Primitive.string_of_float f ^ ")" + (* | primArrayModel a => "(array:" ^ ")" *) + end. Fixpoint print_term (Γ : context) (top : bool) (inapp : bool) (t : term) {struct t} : Tree.t := match t with @@ -111,11 +117,15 @@ Module PrintTermTree. | tApp f l => parens (top || inapp) (print_term Γ false true f ^ " " ^ print_term Γ false false l) | tConst c => string_of_kername c - | tConstruct (mkInd i k as ind) l => + | tConstruct (mkInd i k as ind) l args => match lookup_ind_decl Σ i k with | Some oib => match nth_error oib.(ind_ctors) l with - | Some cstr => cstr.(cstr_name) + | Some cstr => + match args with + | [] => cstr.(cstr_name) + | args => parens (top || inapp) (cstr.(cstr_name) ^ "[" ^ print_list (print_term Γ false false) " " args ^ "]") + end | None => "UnboundConstruct(" ^ string_of_inductive ind ^ "," ^ string_of_nat l ^ ")" end @@ -159,8 +169,7 @@ Module PrintTermTree. | tCoFix l n => parens top ("let cofix " ^ print_defs print_term Γ l ^ nl ^ " in " ^ List.nth_default (string_of_nat n) (map (string_of_name ∘ dname) l) n) - (* | tPrim p => *) - (* parens top (string_of_prim (print_term Γ false false) p) *) + | tPrim p => parens top (print_prim (print_term Γ false false) p) end. End print_term. @@ -192,10 +201,18 @@ Module PrintTermTree. | _ => nl ^ "projections: " ^ print_list (fun x => x.(proj_name)) ", " body.(ind_projs) end in - "Inductive " ^ body.(ind_name) ^ "(" ^ params ^ "," ^ prop ^ ", elimination " ^ kelim ^ ") := " ^ nl ^ ctors ^ projs. + body.(ind_name) ^ "(" ^ params ^ "," ^ prop ^ ", elimination " ^ kelim ^ ") := " ^ nl ^ ctors ^ projs. + + Definition print_recursivity_kind k := + match k with + | Finite => "Inductive" + | CoFinite => "CoInductive" + | BiFinite => "Variant" + end. Definition print_inductive_body decl := - print_list (print_one_inductive_body decl.(ind_npars)) nl decl.(ind_bodies). + print_recursivity_kind decl.(ind_finite) ^ " " ^ + print_list (print_one_inductive_body decl.(ind_npars)) (nl ^ " with ") decl.(ind_bodies). Definition print_decl Σ '(kn, d) := match d with diff --git a/erasure/theories/EProgram.v b/erasure/theories/EProgram.v index 77ebef9c6..57b37ea83 100644 --- a/erasure/theories/EProgram.v +++ b/erasure/theories/EProgram.v @@ -4,7 +4,7 @@ From Equations Require Import Equations. From MetaCoq.Template Require Import Transform bytestring config utils BasicAst. From MetaCoq.PCUIC Require PCUICAst PCUICAstUtils PCUICProgram. (* From MetaCoq.SafeChecker Require Import PCUICErrors PCUICWfEnvImpl. *) -From MetaCoq.Erasure Require EAstUtils EPretty EWellformed EEnvMap EWcbvEval. +From MetaCoq.Erasure Require EAstUtils EWellformed EEnvMap EWcbvEval. Import bytestring. Local Open Scope bs. diff --git a/erasure/theories/EReflect.v b/erasure/theories/EReflect.v index 99dc459ef..a0721b9af 100644 --- a/erasure/theories/EReflect.v +++ b/erasure/theories/EReflect.v @@ -27,6 +27,7 @@ Local Ltac term_dec_tac term_dec := | x : inductive * nat, y : inductive * nat |- _ => fcase (eq_dec x y) | x : projection, y : projection |- _ => fcase (eq_dec x y) + | x : recursivity_kind, y : recursivity_kind |- _ => fcase (eq_dec x y) end. Ltac nodec := @@ -59,6 +60,15 @@ Proof. - destruct (IHx1 t1) ; nodec. destruct (IHx2 t2) ; nodec. subst. left. reflexivity. + - revert l. induction X ; intro l0. + + destruct l0. + * left. reflexivity. + * right. discriminate. + + destruct l0. + * right. discriminate. + * destruct (IHX l0) ; nodec. + destruct (p t) ; nodec. + inversion e. subst; left; reflexivity. - destruct (IHx t) ; nodec. subst. revert l0. clear IHx. induction X ; intro l0. @@ -101,6 +111,8 @@ Proof. subst. inversion e0. subst. destruct (eq_dec rarg rarg0) ; nodec. subst. left. reflexivity. + - destruct (eq_dec p p0); nodec. + left; subst. reflexivity. Defined. #[global] @@ -160,9 +172,9 @@ Proof. Defined. Definition eqb_mutual_inductive_body (x y : mutual_inductive_body) := - let (n, b) := x in - let (n', b') := y in - eqb n n' && eqb b b'. + let (f, n, b) := x in + let (f', n', b') := y in + eqb f f' && eqb n n' && eqb b b'. #[global, program] Instance reflect_mutual_inductive_body : ReflectEq mutual_inductive_body := diff --git a/erasure/theories/ERemoveParams.v b/erasure/theories/ERemoveParams.v index d306c5f2e..21a8efb37 100644 --- a/erasure/theories/ERemoveParams.v +++ b/erasure/theories/ERemoveParams.v @@ -36,10 +36,10 @@ Section strip. | tEvar ev args => EAst.tEvar ev (map_InP args (fun x H => strip x)) | tLambda na M => EAst.tLambda na (strip M) | tApp u v napp nnil with construct_viewc u := { - | view_construct kn c with GlobalContextMap.lookup_inductive_pars Σ (inductive_mind kn) := { + | view_construct kn c block_args with GlobalContextMap.lookup_inductive_pars Σ (inductive_mind kn) := { | Some npars := - mkApps (EAst.tConstruct kn c) (List.skipn npars (map_InP v (fun x H => strip x))) - | None => mkApps (EAst.tConstruct kn c) (map_InP v (fun x H => strip x)) } + mkApps (EAst.tConstruct kn c block_args) (List.skipn npars (map_InP v (fun x H => strip x))) + | None => mkApps (EAst.tConstruct kn c block_args) (map_InP v (fun x H => strip x)) } | view_other u nconstr => mkApps (strip u) (map_InP v (fun x H => strip x)) } @@ -57,15 +57,16 @@ Section strip. | tBox => EAst.tBox | tVar n => EAst.tVar n | tConst n => EAst.tConst n - | tConstruct ind i => EAst.tConstruct ind i }. + | tConstruct ind i block_args => EAst.tConstruct ind i block_args + | tPrim p => EAst.tPrim p }. Proof. all:try lia. all:try apply (In_size); tea. - now eapply (In_size id size). - rewrite size_mkApps. - now eapply (In_size id size) in H. + eapply (In_size id size) in H. change (fun x => size (id x)) with size in H. unfold id in H. cbn. lia. - rewrite size_mkApps. - now eapply (In_size id size) in H. + eapply (In_size id size) in H. change (fun x => size (id x)) with size in H. unfold id in H. cbn. lia. - now eapply size_mkApps_f. - pose proof (size_mkApps_l napp nnil). eapply (In_size id size) in H. change (fun x => size (id x)) with size in H. unfold id in H. lia. @@ -108,9 +109,9 @@ Section strip. - rewrite !closedn_mkApps in H1 *. rtoProp; intuition auto. solve_all. - - rewrite !closedn_mkApps /= in H0 *. - rewrite forallb_skipn; solve_all. - - rewrite !closedn_mkApps /= in H0 *; solve_all. + - rewrite !closedn_mkApps /= in H0 *. rtoProp. + rewrite forallb_skipn; solve_all. solve_all. + - rewrite !closedn_mkApps /= in H0 *. rtoProp. repeat solve_all. Qed. Hint Rewrite @forallb_InP_spec : isEtaExp. @@ -119,10 +120,10 @@ Section strip. Local Lemma strip_mkApps_nonnil f v : ~~ isApp f -> v <> [] -> strip (mkApps f v) = match construct_viewc f with - | view_construct kn c => + | view_construct kn c block_args => match lookup_inductive_pars Σ (inductive_mind kn) with - | Some npars => mkApps (EAst.tConstruct kn c) (List.skipn npars (map strip v)) - | None => mkApps (EAst.tConstruct kn c) (map strip v) + | Some npars => mkApps (EAst.tConstruct kn c block_args) (List.skipn npars (map strip v)) + | None => mkApps (EAst.tConstruct kn c block_args) (map strip v) end | view_other u nconstr => mkApps (strip f) (map strip v) end. @@ -139,10 +140,10 @@ Section strip. Lemma strip_mkApps f v : ~~ isApp f -> strip (mkApps f v) = match construct_viewc f with - | view_construct kn c => + | view_construct kn c block_args => match lookup_inductive_pars Σ (inductive_mind kn) with - | Some npars => mkApps (EAst.tConstruct kn c) (List.skipn npars (map strip v)) - | None => mkApps (EAst.tConstruct kn c) (map strip v) + | Some npars => mkApps (EAst.tConstruct kn c block_args) (List.skipn npars (map strip v)) + | None => mkApps (EAst.tConstruct kn c block_args) (map strip v) end | view_other u nconstr => mkApps (strip f) (map strip v) end. @@ -178,7 +179,8 @@ Section strip. simpl closed in *; try solve [simpl subst; simpl closed; f_equal; auto; rtoProp; solve_all]; try easy. - destruct Nat.compare => //. - - f_equal. solve_all. move/andP: b => [] _ he. solve_all. + - f_equal. rtoProp. solve_all. destruct block_args; inv H0. eauto. + - f_equal. solve_all. move/andP: b => [] _ he. solve_all. - specialize (H a etaa cla k). rewrite !csubst_mkApps in H1 *. rewrite isEtaExp_mkApps_napp // in H1. @@ -209,7 +211,7 @@ Section strip. rewrite (lookup_inductive_pars_constructor_pars_args eqpars). rewrite -mkApps_app /= !skipn_map. f_equal. rewrite skipn_app map_app. f_equal. - assert (pars - #|l| = 0). eapply Nat.leb_le in ise; lia. + assert (pars - #|l| = 0). rtoProp. rename H2 into ise. eapply Nat.leb_le in ise; lia. rewrite H2 skipn_0. rewrite !map_map_compose. clear -etaa cla ev H0. solve_all. } @@ -226,7 +228,7 @@ Section strip. rewrite /isEtaExp_app in H2. destruct lookup_constructor_pars_args as [[pars args]|] eqn:eqpars => // /=. rewrite (lookup_inductive_pars_constructor_pars_args eqpars). - assert (pars = 0). eapply Nat.leb_le in H2. lia. + assert (pars = 0). rtoProp. eapply Nat.leb_le in H2. lia. subst pars. rewrite skipn_0. simp strip; rewrite -strip_equation_1. { f_equal. rewrite !map_map_compose. clear -etaa cla ev H0. solve_all. } } @@ -241,11 +243,11 @@ Section strip. unfold isEtaExp_app in etaapp. rewrite GlobalContextMap.lookup_inductive_pars_spec in Heq. rewrite Heq in etaapp *. - f_equal. rewrite map_skipn. f_equal. + f_equal. + now destruct block_args; inv etav. + rewrite map_skipn. f_equal. rewrite !map_map_compose. - rewrite isEtaExp_Constructor // in H0. - move/andP: H0 => [] etaapp' ev. - clear -etaa cla ev H. solve_all. + rewrite isEtaExp_Constructor // in H0. rtoProp. solve_all. - pose proof (etaExp_csubst _ _ k _ etaa H0). rewrite !csubst_mkApps /= in H1 *. assert (map (csubst a k) v <> []). @@ -360,7 +362,7 @@ Definition strip_constant_decl Σ cb := {| cst_body := option_map (strip Σ) cb.(cst_body) |}. Definition strip_inductive_decl idecl := - {| ind_npars := 0; ind_bodies := idecl.(ind_bodies) |}. + {| ind_finite := idecl.(ind_finite); ind_npars := 0; ind_bodies := idecl.(ind_bodies) |}. Definition strip_decl Σ d := match d with @@ -434,9 +436,9 @@ Arguments isEtaExp : simpl never. Lemma isEtaExp_mkApps {Σ} {f u} : isEtaExp Σ (tApp f u) -> let (hd, args) := decompose_app (tApp f u) in match construct_viewc hd with - | view_construct kn c => + | view_construct kn c block_args => args <> [] /\ f = mkApps hd (remove_last args) /\ u = last args u /\ - isEtaExp_app Σ kn c #|args| && forallb (isEtaExp Σ) args + isEtaExp_app Σ kn c #|args| && forallb (isEtaExp Σ) args && is_nil block_args | view_other _ discr => [&& isEtaExp Σ hd, forallb (isEtaExp Σ) args, isEtaExp Σ f & isEtaExp Σ u] end. @@ -497,7 +499,7 @@ Proof. rewrite isEtaExp_mkApps_napp // in etaf. simp construct_viewc in etaf. move/andP: etaf => []. rewrite /isEtaExp_app hl. - move/Nat.leb_le. lia. } + move => /andP[] /Nat.leb_le. lia. } { move/and4P=> [] iset isel _ _. rewrite (decompose_app_inv da). pose proof (decompose_app_notApp _ _ _ da). rewrite strip_mkApps //. @@ -532,9 +534,9 @@ Module Fast. | app, tCoFix mfix idx => let mfix' := strip_defs mfix in mkApps (EAst.tCoFix mfix' idx) app - | app, tConstruct kn c with GlobalContextMap.lookup_inductive_pars Σ (inductive_mind kn) := { - | Some npars => mkApps (EAst.tConstruct kn c) (List.skipn npars app) - | None => mkApps (EAst.tConstruct kn c) app } + | app, tConstruct kn c block_args with GlobalContextMap.lookup_inductive_pars Σ (inductive_mind kn) := { + | Some npars => mkApps (EAst.tConstruct kn c block_args) (List.skipn npars app) + | None => mkApps (EAst.tConstruct kn c block_args) app } | app, x => mkApps x app } where strip_args (t : list term) : list term := @@ -598,7 +600,7 @@ Module Fast. {| cst_body := option_map (strip' Σ) cb.(cst_body) |}. Definition strip_inductive_decl idecl := - {| ind_npars := 0; ind_bodies := idecl.(ind_bodies) |}. + {| ind_finite := idecl.(ind_finite); ind_npars := 0; ind_bodies := idecl.(ind_bodies) |}. Definition strip_decl Σ d := match d with @@ -647,22 +649,22 @@ Proof. rewrite mkApps_app /= //. Qed. -Lemma isLambda_mkApps_Construct ind n l : - ~~ EAst.isLambda (EAst.mkApps (EAst.tConstruct ind n) l). +Lemma isLambda_mkApps_Construct ind n block_args l : + ~~ EAst.isLambda (EAst.mkApps (EAst.tConstruct ind n block_args) l). Proof. induction l using rev_ind; cbn; try congruence. rewrite mkApps_app /= //. Qed. -Lemma isBox_mkApps_Construct ind n l : - ~~ isBox (EAst.mkApps (EAst.tConstruct ind n) l). +Lemma isBox_mkApps_Construct ind n block_args l : + ~~ isBox (EAst.mkApps (EAst.tConstruct ind n block_args) l). Proof. induction l using rev_ind; cbn; try congruence. rewrite mkApps_app /= //. Qed. -Lemma isFix_mkApps_Construct ind n l : - ~~ isFix (EAst.mkApps (EAst.tConstruct ind n) l). +Lemma isFix_mkApps_Construct ind n block_args l : + ~~ isFix (EAst.mkApps (EAst.tConstruct ind n block_args) l). Proof. induction l using rev_ind; cbn; try congruence. rewrite mkApps_app /= //. @@ -674,7 +676,7 @@ Proof. funelim (strip Σ f); cbn -[strip]; (try simp_strip) => //. rewrite (negbTE (isLambda_mkApps' _ _ _)) //. rewrite (negbTE (isLambda_mkApps' _ _ _)) //; try apply map_nil => //. - all:rewrite !(negbTE (isLambda_mkApps_Construct _ _ _)) //. + all:rewrite !(negbTE (isLambda_mkApps_Construct _ _ _ _)) //. Qed. Lemma strip_isBox Σ f : @@ -684,7 +686,7 @@ Proof. all:rewrite map_InP_spec. rewrite (negbTE (isBox_mkApps' _ _ _)) //. rewrite (negbTE (isBox_mkApps' _ _ _)) //; try apply map_nil => //. - all:rewrite !(negbTE (isBox_mkApps_Construct _ _ _)) //. + all:rewrite !(negbTE (isBox_mkApps_Construct _ _ _ _)) //. Qed. Lemma isApp_mkApps u v : v <> nil -> isApp (mkApps u v). @@ -709,7 +711,7 @@ Proof. all:rewrite map_InP_spec. rewrite (negbTE (isFix_mkApps' _ _ _)) //. rewrite (negbTE (isFix_mkApps' _ _ _)) //; try apply map_nil => //. - all:rewrite !(negbTE (isFix_mkApps_Construct _ _ _)) //. + all:rewrite !(negbTE (isFix_mkApps_Construct _ _ _ _)) //. Qed. Lemma strip_isFixApp Σ f : @@ -728,6 +730,14 @@ Proof. all:rewrite isConstructApp_mkApps isConstructApp_mkApps //. Qed. +Lemma strip_isPrimApp Σ f : + isPrimApp f = isPrimApp (strip Σ f). +Proof. + funelim (strip Σ f); cbn -[strip] => //. + all:rewrite map_InP_spec. + all:rewrite !isPrimApp_mkApps //. +Qed. + Lemma lookup_inductive_pars_is_prop_and_pars {Σ ind b pars} : inductive_isprop_and_pars Σ ind = Some (b, pars) -> lookup_inductive_pars Σ (inductive_mind ind) = Some pars. @@ -777,21 +787,22 @@ Proof. destruct construct_viewc eqn:vc. + move=> /andP[] hl0 etal0. rewrite -mkApps_app. - rewrite (strip_mkApps Σ (tConstruct ind n)) // /=. + rewrite (strip_mkApps Σ (tConstruct ind n block_args)) // /=. rewrite strip_mkApps // /=. unfold isEtaExp_app in hl0. destruct lookup_constructor_pars_args as [[pars args']|] eqn:hl => //. - eapply Nat.leb_le in hl0. + rtoProp. + eapply Nat.leb_le in H. rewrite (lookup_inductive_pars_constructor_pars_args hl). rewrite -mkApps_app. f_equal. rewrite map_app. rewrite skipn_app. len. assert (pars - #|l| = 0) by lia. - now rewrite H skipn_0. + now rewrite H1 skipn_0. + move=> /andP[] etat0 etal0. rewrite -mkApps_app !strip_mkApps; try now eapply decompose_app_notApp. rewrite vc. rewrite -mkApps_app !map_app //. Qed. -#[export] Instance Qpreserves_closedn (efl := all_env_flags) Σ : closed_env Σ -> + #[export] Instance Qpreserves_closedn (efl := all_env_flags) Σ : closed_env Σ -> Qpreserves (fun n x => closedn n x) Σ. Proof. intros clΣ. @@ -810,29 +821,29 @@ Proof. - red. move=> hasapp n t args. rewrite closedn_mkApps. split; intros; rtoProp; intuition auto; solve_all. - red. move=> hascase n ci discr brs. simpl. - split; intros; rtoProp; intuition auto; solve_all. + intros; rtoProp; intuition auto; solve_all. - red. move=> hasproj n p discr. simpl. - split; intros; rtoProp; intuition auto; solve_all. + intros; rtoProp; intuition auto; solve_all. - red. move=> t args clt cll. eapply closed_substl. solve_all. now rewrite Nat.add_0_r. - red. move=> n mfix idx. cbn. - split; intros; rtoProp; intuition auto; solve_all. + intros; rtoProp; intuition auto; solve_all. - red. move=> n mfix idx. cbn. - split; intros; rtoProp; intuition auto; solve_all. + intros; rtoProp; intuition auto; solve_all. Qed. -Lemma strip_eval (efl := all_env_flags) {wfl:WcbvFlags} {Σ : GlobalContextMap.t} t v : - closed_env Σ -> +Lemma strip_eval (efl := all_env_flags) {wfl:WcbvFlags} {wcon : with_constructor_as_block = false} {Σ : GlobalContextMap.t} t v : isEtaExp_env Σ -> + closed_env Σ -> wf_glob Σ -> - eval Σ t v -> - closed t -> + closedn 0 t -> isEtaExp Σ t -> + eval Σ t v -> eval (strip_env Σ) (strip Σ t) (strip Σ v). Proof. - intros clΣ etaΣ wfΣ ev clt etat. - revert t v clt etat ev. - apply (eval_preserve_mkApps_ind wfl Σ (fun x y => eval (strip_env Σ) (strip Σ x) (strip Σ y)) + intros etaΣ clΣ wfΣ. + revert t v. + unshelve eapply (eval_preserve_mkApps_ind wfl wcon Σ (fun x y => eval (strip_env Σ) (strip Σ x) (strip Σ y)) (fun n x => closedn n x) (Qpres := Qpreserves_closedn Σ clΣ)) => //. { intros. eapply eval_closed; tea. } all:intros; simpl in *. @@ -864,7 +875,7 @@ Proof. * cbn -[strip]. have etaargs : forallb (isEtaExp Σ) args. { rewrite isEtaExp_Constructor in i6. - now move/andP: i6 => []. } + now move/andP: i6 => [] /andP[]. } rewrite strip_iota_red // in e. rewrite closedn_mkApps in i4. now move/andP: i4. cbn. now eapply nth_error_forallb in H; tea. @@ -958,14 +969,14 @@ Proof. - rewrite !strip_tApp //. eapply eval_app_cong; tea. move: H1. eapply contraNN. - rewrite -strip_isLambda -strip_isConstructApp -strip_isFixApp -strip_isBox //. + rewrite -strip_isLambda -strip_isConstructApp -strip_isFixApp -strip_isBox -strip_isPrimApp //. rewrite -strip_isFix //. - rewrite !strip_mkApps // /=. rewrite (lookup_constructor_lookup_inductive_pars H). eapply eval_mkApps_Construct; tea. + rewrite lookup_constructor_strip H //. - + now constructor. + + constructor. cbn [atom]. rewrite wcon lookup_constructor_strip H //. + rewrite /cstr_arity /=. move: H0; rewrite /cstr_arity /=. rewrite skipn_length map_length => ->. lia. @@ -974,7 +985,10 @@ Proof. intros x y []; auto. - destruct t => //. - all:constructor; eauto. + all:constructor; eauto. simp strip. + cbn [atom strip] in H |- *. + rewrite lookup_constructor_strip. + destruct lookup_constructor eqn:hl => //. destruct p as [[] ?] => //. Qed. From MetaCoq.Erasure Require Import EEtaExpanded. @@ -1027,6 +1041,7 @@ Proof. destruct EAst.ind_ctors => //. destruct nth_error => //. - unfold wf_fix_gen in *. rewrite map_length. rtoProp; intuition auto. toAll; solve_all. + now rewrite -strip_isLambda. toAll; solve_all. - unfold wf_fix in *. rewrite map_length; rtoProp; intuition auto. toAll; solve_all. - move:H1; rewrite !wellformed_mkApps //. rtoProp; intuition auto. toAll; solve_all. @@ -1045,18 +1060,20 @@ Proof. Qed. Lemma strip_wellformed_irrel {efl : EEnvFlags} {Σ : GlobalContextMap.t} t : + cstr_as_blocks = false -> wf_glob Σ -> forall n, wellformed Σ n t -> wellformed (strip_env Σ) n t. Proof. - intros wfΣ. induction t using EInduction.term_forall_list_ind; cbn => //. + intros hcstrs wfΣ. induction t using EInduction.term_forall_list_ind; cbn => //. all:try solve [intros; unfold wf_fix in *; rtoProp; intuition eauto; solve_all]. - rewrite lookup_env_strip //. destruct lookup_env eqn:hl => // /=. destruct g eqn:hg => /= //. subst g. destruct (cst_body c) => //. - rewrite lookup_env_strip //. - destruct lookup_env eqn:hl => // /=. - destruct g eqn:hg => /= //. + destruct lookup_env eqn:hl => // /=; intros; rtoProp; eauto. + destruct g eqn:hg => /= //; intros; rtoProp; eauto. + destruct cstr_as_blocks => //; repeat split; eauto. destruct nth_error => /= //. destruct nth_error => /= //. - rewrite lookup_env_strip //. @@ -1075,10 +1092,11 @@ Proof. Qed. Lemma strip_wellformed_decl_irrel {efl : EEnvFlags} {Σ : GlobalContextMap.t} d : + cstr_as_blocks = false -> wf_glob Σ -> wf_global_decl Σ d -> wf_global_decl (strip_env Σ) d. Proof. - intros wf; destruct d => /= //. + intros hcstrs wf; destruct d => /= //. destruct (cst_body c) => /= //. now eapply strip_wellformed_irrel. Qed. @@ -1086,7 +1104,9 @@ Qed. Definition switch_no_params (efl : EEnvFlags) := {| has_axioms := has_axioms; has_cstr_params := false; - term_switches := term_switches |}. + term_switches := term_switches ; + cstr_as_blocks := false + |}. Lemma strip_decl_wf (efl := all_env_flags) {Σ : GlobalContextMap.t} : wf_glob Σ -> @@ -1173,7 +1193,7 @@ Proof. rewrite strip_mkApps // /=. move: Heq. rewrite GlobalContextMap.lookup_inductive_pars_spec. - unfold wellformed in wfc. move/andP: wfc => [] hacc hc. + unfold wellformed in wfc. move/andP: wfc => [] /andP[] hacc hc bargs. unfold lookup_inductive_pars. destruct lookup_minductive eqn:heq => //. unfold lookup_constructor, lookup_inductive in hc. rewrite heq /= // in hc. Qed. diff --git a/erasure/theories/ESpineView.v b/erasure/theories/ESpineView.v index 7bee803c6..219591aec 100644 --- a/erasure/theories/ESpineView.v +++ b/erasure/theories/ESpineView.v @@ -17,11 +17,12 @@ Inductive t : term -> Set := | tLetIn n b b' : t (EAst.tLetIn n b b') | tApp (f : term) (l : list term) (napp : ~~ isApp f) (nnil : l <> nil) : t (mkApps f l) | tConst kn : t (tConst kn) -| tConstruct i n : t (tConstruct i n) +| tConstruct i n args : t (tConstruct i n args) | tCase ci p brs : t (tCase ci p brs) | tProj p c : t (tProj p c) | tFix mfix idx : t (tFix mfix idx) -| tCoFix mfix idx : t (tCoFix mfix idx). +| tCoFix mfix idx : t (tCoFix mfix idx) +| tPrim p : t (tPrim p). Derive Signature for t. Definition view : forall x : term, t x := @@ -36,7 +37,8 @@ Definition view : forall x : term, t x := (fun p t l => tCase p t l) (fun p t => tProj p t) (fun mfix n => tFix mfix n) - (fun mfix n => tCoFix mfix n). + (fun mfix n => tCoFix mfix n) + (fun p => tPrim p). Lemma view_mkApps {f v} (vi : t (mkApps f v)) : ~~ isApp f -> v <> [] -> exists hf vn, vi = tApp f v hf vn. diff --git a/erasure/theories/ESubstitution.v b/erasure/theories/ESubstitution.v index 33ff6b5c7..cec68e81e 100644 --- a/erasure/theories/ESubstitution.v +++ b/erasure/theories/ESubstitution.v @@ -49,11 +49,12 @@ Lemma Informative_extends: Proof. repeat intros ?. assert (extends_decls Σ Σ'0). - { destruct X0, X2. subst. cbn. split => //. - rewrite e -e0 //. - destruct s as [Σ'' eq]. destruct s0 as [Σ''' ->]. - rewrite eq. cbn. exists (Σ''' ++ Σ''). cbn. - now rewrite <- app_assoc. } + { destruct X0 as [eu [Σ'' eq] er], X2 as [eu' [Σ''' eq'] er']. + subst. cbn in *. split => //. + * rewrite eu -eu' //. + * exists (Σ''' ++ Σ''). cbn. rewrite <- app_assoc. + congruence. + * congruence. } edestruct H0; eauto. destruct H3. eapply weakening_env_declared_inductive in H; eauto; tc. @@ -559,6 +560,9 @@ Proof. eapply typing_wf_local. eassumption. + econstructor. eapply is_type_subst; eauto. + - cbn. depelim H1. + * cbn; constructor. + * constructor. eapply is_type_subst in X3; tea. - eapply H; eauto. Qed. diff --git a/erasure/theories/ETransform.v b/erasure/theories/ETransform.v index 9b34d1a0b..32701691d 100644 --- a/erasure/theories/ETransform.v +++ b/erasure/theories/ETransform.v @@ -7,7 +7,8 @@ Set Warnings "-notation-overridden". From MetaCoq.PCUIC Require PCUICAst PCUICAstUtils PCUICProgram PCUICTransform. Set Warnings "+notation-overridden". From MetaCoq.SafeChecker Require Import PCUICErrors PCUICWfEnvImpl. -From MetaCoq.Erasure Require EAstUtils ErasureFunction ErasureCorrectness EPretty Extract EOptimizePropDiscr ERemoveParams EProgram. +From MetaCoq.Erasure Require EAstUtils ErasureFunction ErasureCorrectness Extract + EOptimizePropDiscr ERemoveParams EProgram. Import PCUICAst (term) PCUICProgram PCUICTransform (eval_pcuic_program) Extract EProgram EAst Transform ERemoveParams. @@ -111,7 +112,7 @@ Qed. Import EWcbvEval (WcbvFlags, with_prop_case, with_guarded_fix). -Program Definition guarded_to_unguarded_fix {fl : EWcbvEval.WcbvFlags} {efl : EEnvFlags} (wguard : with_guarded_fix) : +Program Definition guarded_to_unguarded_fix {fl : EWcbvEval.WcbvFlags} {wcon : EWcbvEval.with_constructor_as_block = false} {efl : EEnvFlags} (wguard : with_guarded_fix) : Transform.t eprogram_env eprogram_env EAst.term EAst.term (eval_eprogram_env fl) (eval_eprogram_env (EWcbvEval.switch_unguarded_fix fl)) := {| name := "switching to unguarded fixpoints"; @@ -122,10 +123,10 @@ Program Definition guarded_to_unguarded_fix {fl : EWcbvEval.WcbvFlags} {efl : EE Next Obligation. cbn. eauto. Qed. Next Obligation. cbn. - move=> fl efl wguard [Σ t] v [wfp [etae etat]]. cbn in *. + move=> fl wcon efl wguard [Σ t] v [wfp [etae etat]]. cbn in *. intros [ev]. exists v. split => //. red. sq. cbn in *. - apply EEtaExpandedFix.eval_opt_to_target => //. 2:apply wfp. + unshelve eapply EEtaExpandedFix.eval_opt_to_target => //. auto. 2:apply wfp. now eapply EEtaExpandedFix.expanded_global_env_isEtaExp_env. now eapply EEtaExpandedFix.expanded_isEtaExp. Qed. @@ -133,21 +134,21 @@ Qed. Definition rebuild_wf_env {efl} (p : eprogram) (hwf : wf_eprogram efl p): eprogram_env := (GlobalContextMap.make p.1 (wf_glob_fresh p.1 (proj1 hwf)), p.2). -Program Definition rebuild_wf_env_transform {fl : EWcbvEval.WcbvFlags} {efl} : +Program Definition rebuild_wf_env_transform {fl : EWcbvEval.WcbvFlags} {efl} (with_exp : bool) : Transform.t eprogram eprogram_env EAst.term EAst.term (eval_eprogram fl) (eval_eprogram_env fl) := {| name := "rebuilding environment lookup table"; - pre p := wf_eprogram efl p /\ EEtaExpanded.expanded_eprogram_cstrs p; + pre p := wf_eprogram efl p /\ (with_exp ==> EEtaExpanded.expanded_eprogram_cstrs p); transform p pre := rebuild_wf_env p (proj1 pre); - post p := wf_eprogram_env efl p /\ EEtaExpanded.expanded_eprogram_env_cstrs p; + post p := wf_eprogram_env efl p /\ (with_exp ==> EEtaExpanded.expanded_eprogram_env_cstrs p); obseq g g' v v' := v = v' |}. Next Obligation. - cbn. intros fl efl input [wf exp]. cbn; split => //. + cbn. intros fl efl [] input [wf exp]; cbn; split => //. Qed. Next Obligation. - cbn. intros fl efl input v [] ev p'; exists v. split => //. + cbn. intros fl efl [] input v [] ev p'; exists v; split => //. Qed. -Program Definition remove_params_optimization {fl : EWcbvEval.WcbvFlags} +Program Definition remove_params_optimization {fl : EWcbvEval.WcbvFlags} {wcon : EWcbvEval.with_constructor_as_block = false} (efl := all_env_flags): Transform.t eprogram_env eprogram EAst.term EAst.term (eval_eprogram_env fl) (eval_eprogram fl) := {| name := "stripping constructor parameters"; @@ -156,7 +157,7 @@ Program Definition remove_params_optimization {fl : EWcbvEval.WcbvFlags} post p := wf_eprogram (switch_no_params efl) p /\ EEtaExpanded.expanded_eprogram_cstrs p; obseq g g' v v' := v' = (ERemoveParams.strip g.1 v) |}. Next Obligation. - move=> fl efl [Σ t] [wfp etap]. + move=> fl wcon efl [Σ t] [wfp etap]. simpl. cbn -[ERemoveParams.strip] in *. split. now eapply ERemoveParams.strip_program_wf. @@ -164,16 +165,16 @@ Next Obligation. Qed. Next Obligation. - red. move=> ? [Σ t] /= v [[wfe wft] etap] [ev]. - eapply ERemoveParams.strip_eval in ev; eauto. + red. move=> ? wcon [Σ t] /= v [[wfe wft] etap] [ev]. + unshelve eapply ERemoveParams.strip_eval in ev; eauto. eexists; split => /= //. now sq. cbn in *. - now eapply wellformed_closed_env. now move/andP: etap. + now eapply wellformed_closed_env. now eapply wellformed_closed. now move/andP: etap. Qed. -Program Definition remove_params_fast_optimization (fl : EWcbvEval.WcbvFlags) +Program Definition remove_params_fast_optimization (fl : EWcbvEval.WcbvFlags) {wcon : EWcbvEval.with_constructor_as_block = false} (efl := all_env_flags) : Transform.t eprogram_env eprogram EAst.term EAst.term (eval_eprogram_env fl) (eval_eprogram fl) := {| name := "stripping constructor parameters (faster?)"; @@ -182,7 +183,7 @@ Program Definition remove_params_fast_optimization (fl : EWcbvEval.WcbvFlags) post p := wf_eprogram (switch_no_params efl) p /\ EEtaExpanded.expanded_eprogram_cstrs p; obseq g g' v v' := v' = (ERemoveParams.strip g.1 v) |}. Next Obligation. - move=> fl efl [Σ t] [wfp etap]. + move=> fl wcon efl [Σ t] [wfp etap]. simpl. cbn -[ERemoveParams.strip] in *. rewrite -ERemoveParams.Fast.strip_fast -ERemoveParams.Fast.strip_env_fast. @@ -192,20 +193,20 @@ Next Obligation. Qed. Next Obligation. - red. move=> ? [Σ t] /= v [[wfe wft] etap] [ev]. + red. move=> ? wcon [Σ t] /= v [[wfe wft] etap] [ev]. rewrite -ERemoveParams.Fast.strip_fast -ERemoveParams.Fast.strip_env_fast. - eapply ERemoveParams.strip_eval in ev; eauto. + unshelve eapply ERemoveParams.strip_eval in ev; eauto. eexists; split => /= //. now sq. cbn in *. - now eapply wellformed_closed_env. now move/andP: etap. + now eapply wellformed_closed_env. now eapply wellformed_closed. now move/andP: etap. Qed. Import EOptimizePropDiscr EWcbvEval. -Program Definition optimize_prop_discr_optimization {fl : WcbvFlags} {efl : EEnvFlags} {hastrel : has_tRel} {hastbox : has_tBox} : +Program Definition optimize_prop_discr_optimization {fl : WcbvFlags} {wcon : with_constructor_as_block = false} {efl : EEnvFlags} {hastrel : has_tRel} {hastbox : has_tBox} : Transform.t eprogram_env eprogram EAst.term EAst.term (eval_eprogram_env fl) (eval_eprogram (disable_prop_cases fl)) := {| name := "optimize_prop_discr"; transform p _ := optimize_program p ; @@ -214,22 +215,23 @@ Program Definition optimize_prop_discr_optimization {fl : WcbvFlags} {efl : EEnv obseq g g' v v' := v' = EOptimizePropDiscr.optimize g.1 v |}. Next Obligation. - move=> fl efl hastrel hastbox [Σ t] [wfp etap]. + move=> fl wcon efl hastrel hastbox [Σ t] [wfp etap]. cbn in *. split. - now eapply optimize_program_wf. - now eapply optimize_program_expanded. Qed. Next Obligation. - red. move=> fl efl hastrel hastbox [Σ t] /= v [wfe wft] [ev]. + red. move=> fl wcon efl hastrel hastbox [Σ t] /= v [wfe wft] [ev]. eapply EOptimizePropDiscr.optimize_correct in ev; eauto. eexists; split => //. red. sq; auto. cbn. apply wfe. eapply wellformed_closed_env, wfe. eapply wellformed_closed, wfe. + Unshelve. eauto. Qed. From MetaCoq.Erasure Require Import EInlineProjections. -Program Definition inline_projections_optimization {fl : WcbvFlags} (efl := all_env_flags) +Program Definition inline_projections_optimization {fl : WcbvFlags} {wcon : EWcbvEval.with_constructor_as_block = false} (efl := switch_no_params all_env_flags) {hastrel : has_tRel} {hastbox : has_tBox} : Transform.t eprogram_env eprogram EAst.term EAst.term (eval_eprogram_env fl) (eval_eprogram fl) := {| name := "primitive projection inlining"; @@ -239,14 +241,41 @@ Program Definition inline_projections_optimization {fl : WcbvFlags} (efl := all_ obseq g g' v v' := v' = EInlineProjections.optimize g.1 v |}. Next Obligation. - move=> fl efl hastrel hastbox [Σ t] [wfp etap]. + move=> fl wcon efl hastrel hastbox [Σ t] [wfp etap]. cbn in *. split. - now eapply optimize_program_wf. - now eapply optimize_program_expanded. Qed. Next Obligation. - red. move=> fl hastrel hastbox [Σ t] /= v [wfe wft] [ev]. + red. move=> fl wcon hastrel hastbox [Σ t] /= v [wfe wft] [ev]. eapply EInlineProjections.optimize_correct in ev; eauto. eexists; split => //. red. sq; auto. cbn. apply wfe. - cbn. eapply wfe. -Qed. \ No newline at end of file + cbn. eapply wfe. Unshelve. auto. +Qed. + +From MetaCoq.Erasure Require Import EConstructorsAsBlocks. + +Program Definition constructors_as_blocks_transformation (efl : EEnvFlags) + {has_app : has_tApp} {has_pars : has_cstr_params = false} {has_cstrblocks : cstr_as_blocks = false} : + Transform.t eprogram_env eprogram EAst.term EAst.term (eval_eprogram_env target_wcbv_flags) (eval_eprogram block_wcbv_flags) := + {| name := "transforming to constuctors as blocks"; + transform p _ := EConstructorsAsBlocks.transform_blocks_program p ; + pre p := wf_eprogram_env efl p /\ EEtaExpanded.expanded_eprogram_env_cstrs p; + post p := wf_eprogram (switch_cstr_as_blocks efl) p ; + obseq g g' v v' := v' = EConstructorsAsBlocks.transform_blocks g.1 v |}. + +Next Obligation. + move=> efl hasapp haspars hascstrs [Σ t] [] [wftp wft] /andP [etap etat]. + cbn in *. split. + - eapply transform_wf_global; eauto. + - eapply transform_wellformed; eauto. +Qed. +Next Obligation. + red. move=> efl hasapp haspars hascstrs [Σ t] /= v [[wfe1 wfe2] wft] [ev]. + eexists. split; [ | eauto]. + unfold EEtaExpanded.expanded_eprogram_env_cstrs in *. + revert wft. move => /andP // [e1 e2]. + econstructor. + cbn -[transform_blocks]. + eapply transform_blocks_eval; cbn; eauto. +Qed. diff --git a/erasure/theories/EWcbvEval.v b/erasure/theories/EWcbvEval.v index c498a85ef..abb7bb6bf 100644 --- a/erasure/theories/EWcbvEval.v +++ b/erasure/theories/EWcbvEval.v @@ -27,13 +27,19 @@ Local Ltac inv H := inversion H; subst. (** ** Big step version of weak cbv beta-zeta-iota-fix-delta reduction. *) -Definition atom t := + +(* Tells if the evaluation relation should include match-prop and proj-prop reduction rules. + Also, are constructors represented as blocks or higher-order. *) +Class WcbvFlags := { with_prop_case : bool ; with_guarded_fix : bool ; with_constructor_as_block : bool }. + +Definition atom `{wfl : WcbvFlags} Σ t := match t with | tBox - | tConstruct _ _ | tCoFix _ _ | tLambda _ _ - | tFix _ _ => true + | tFix _ _ + | tPrim _ => true + | tConstruct ind c [] => negb with_constructor_as_block && isSome (lookup_constructor Σ ind c) | _ => false end. @@ -47,31 +53,64 @@ Definition isStuckFix t (args : list term) := | _ => false end. -Lemma atom_mkApps f l : atom (mkApps f l) -> (l = []) /\ atom f. +Lemma atom_mkApps {wfl : WcbvFlags} Σ f l : atom Σ (mkApps f l) -> (l = []) /\ atom Σ f. Proof. revert f; induction l using rev_ind. simpl. intuition auto. simpl. intros. now rewrite mkApps_app in H. Qed. -(* Tells if the evaluation relation should include match-prop and proj-prop reduction rules. *) -Class WcbvFlags := { with_prop_case : bool ; with_guarded_fix : bool }. - Definition disable_prop_cases fl : WcbvFlags := - {| with_prop_case := false; with_guarded_fix := fl.(@with_guarded_fix) |}. + {| with_prop_case := false; with_guarded_fix := fl.(@with_guarded_fix) ; with_constructor_as_block := fl.(@with_constructor_as_block) |}. Definition switch_unguarded_fix fl : WcbvFlags := - EWcbvEval.Build_WcbvFlags fl.(@with_prop_case) false. + EWcbvEval.Build_WcbvFlags fl.(@with_prop_case) false fl.(@with_constructor_as_block). + +Definition default_wcbv_flags := {| with_prop_case := true ; with_guarded_fix := true ; with_constructor_as_block := false |}. +Definition opt_wcbv_flags := {| with_prop_case := false ; with_guarded_fix := true ; with_constructor_as_block := false|}. +Definition target_wcbv_flags := {| with_prop_case := false ; with_guarded_fix := false ; with_constructor_as_block := false |}. + + +Inductive All2_Set {A B : Set} (R : A -> B -> Set) : list A -> list B -> Set := + All2_nil : All2_Set R [] [] +| All2_cons : forall (x : A) (y : B) (l : list A) (l' : list B), + R x y -> All2_Set R l l' -> All2_Set R (x :: l) (y :: l'). +Arguments All2_nil {_ _ _}. +Arguments All2_cons {_ _ _ _ _ _ _}. +Derive Signature for All2_Set. +Derive NoConfusionHom for All2_Set. +#[global] Hint Constructors All2_Set : core. + +Section All2_size. + Context {A B : Set} (P : A -> B -> Set) (fn : forall x1 x2, P x1 x2 -> size). + Fixpoint all2_size {l1 l2} (f : All2_Set P l1 l2) : size := + match f with + | All2_nil => 0 + | All2_cons _ _ _ _ rxy rll' => fn _ _ rxy + all2_size rll' + end. +End All2_size. + +Lemma All2_Set_All2 {A B : Set} (R : A -> B -> Set) l l' : All2_Set R l l' -> All2 R l l'. +Proof. + induction 1; constructor; auto. +Qed. +#[export] Hint Resolve All2_Set_All2 : core. -Definition default_wcbv_flags := {| with_prop_case := true ; with_guarded_fix := true |}. -Definition opt_wcbv_flags := {| with_prop_case := false ; with_guarded_fix := true |}. -Definition target_wcbv_flags := {| with_prop_case := false ; with_guarded_fix := false |}. +Coercion All2_Set_All2 : All2_Set >-> All2. + +Lemma All2_All2_Set {A B : Set} (R : A -> B -> Set) l l' : All2 R l l' -> All2_Set R l l'. +Proof. + induction 1; constructor; auto. +Qed. +#[export] Hint Immediate All2_All2_Set : core. Section Wcbv. Context {wfl : WcbvFlags}. Context (Σ : global_declarations). (* The local context is fixed: we are only doing weak reductions *) + + Local Unset Elimination Schemes. - Inductive eval : term -> term -> Type := + Inductive eval : term -> term -> Set := (** Reductions *) | eval_box a t t' : eval a tBox -> @@ -93,7 +132,19 @@ Section Wcbv. (** Case *) | eval_iota ind pars cdecl discr c args brs br res : - eval discr (mkApps (tConstruct ind c) args) -> + with_constructor_as_block = false -> + eval discr (mkApps (tConstruct ind c []) args) -> + constructor_isprop_pars_decl Σ ind c = Some (false, pars, cdecl) -> + nth_error brs c = Some br -> + #|args| = pars + cdecl.(cstr_nargs) -> + #|skipn pars args| = #|br.1| -> + eval (iota_red pars args br) res -> + eval (tCase (ind, pars) discr brs) res + + (** Case *) + | eval_iota_block ind pars cdecl discr c args brs br res : + with_constructor_as_block = true -> + eval discr (tConstruct ind c args) -> constructor_isprop_pars_decl Σ ind c = Some (false, pars, cdecl) -> nth_error brs c = Some br -> #|args| = pars + cdecl.(cstr_nargs) -> @@ -159,7 +210,18 @@ Section Wcbv. (** Proj *) | eval_proj p cdecl discr args a res : - eval discr (mkApps (tConstruct p.(proj_ind) 0) args) -> + with_constructor_as_block = false -> + eval discr (mkApps (tConstruct p.(proj_ind) 0 []) args) -> + constructor_isprop_pars_decl Σ p.(proj_ind) 0 = Some (false, p.(proj_npars), cdecl) -> + #|args| = p.(proj_npars) + cdecl.(cstr_nargs) -> + nth_error args (p.(proj_npars) + p.(proj_arg)) = Some a -> + eval a res -> + eval (tProj p discr) res + + (** Proj *) + | eval_proj_block p cdecl discr args a res : + with_constructor_as_block = true -> + eval discr (tConstruct p.(proj_ind) 0 args) -> constructor_isprop_pars_decl Σ p.(proj_ind) 0 = Some (false, p.(proj_npars), cdecl) -> #|args| = p.(proj_npars) + cdecl.(cstr_nargs) -> nth_error args (p.(proj_npars) + p.(proj_arg)) = Some a -> @@ -175,17 +237,26 @@ Section Wcbv. (** Constructor congruence: we do not allow over-applications *) | eval_construct ind c mdecl idecl cdecl f args a a' : + with_constructor_as_block = false -> lookup_constructor Σ ind c = Some (mdecl, idecl, cdecl) -> - eval f (mkApps (tConstruct ind c) args) -> + eval f (mkApps (tConstruct ind c []) args) -> #|args| < cstr_arity mdecl cdecl -> eval a a' -> - eval (tApp f a) (tApp (mkApps (tConstruct ind c) args) a') + eval (tApp f a) (tApp (mkApps (tConstruct ind c []) args) a') + (** Constructor congruence: we do not allow over-applications *) + | eval_construct_block ind c mdecl idecl cdecl args args' : + with_constructor_as_block = true -> + lookup_constructor Σ ind c = Some (mdecl, idecl, cdecl) -> + #|args| = cstr_arity mdecl cdecl -> + All2_Set eval args args' -> + eval (tConstruct ind c args) (tConstruct ind c args') (** Atoms (non redex-producing heads) applied to values are values *) | eval_app_cong f f' a a' : eval f f' -> - ~~ (isLambda f' || (if with_guarded_fix then isFixApp f' else isFix f') || isBox f' || isConstructApp f') -> + ~~ (isLambda f' || (if with_guarded_fix then isFixApp f' else isFix f') || isBox f' || isConstructApp f' + || isPrimApp f') -> eval a a' -> eval (tApp f a) (tApp f' a') @@ -197,7 +268,7 @@ Section Wcbv. (** Atoms are values (includes abstractions, cofixpoints and constructors) *) - | eval_atom t : atom t -> eval t t. + | eval_atom t : atom Σ t -> eval t t. Hint Constructors eval : core. Derive Signature for eval. @@ -214,9 +285,10 @@ Section Wcbv. Variant value_head (nargs : nat) : term -> Type := | value_head_cstr ind c mdecl idecl cdecl : + with_constructor_as_block = false -> lookup_constructor Σ ind c = Some (mdecl, idecl, cdecl) -> nargs <= cstr_arity mdecl cdecl -> - value_head nargs (tConstruct ind c) + value_head nargs (tConstruct ind c []) | value_head_cofix mfix idx : value_head nargs (tCoFix mfix idx) | value_head_fix mfix idx rarg fn : cunfold_fix mfix idx = Some (rarg, fn) -> @@ -227,12 +299,320 @@ Section Wcbv. Derive Signature NoConfusion for value_head. Inductive value : term -> Type := - | value_atom t : atom t -> value t + | value_atom t : atom Σ t -> value t + | value_constructor ind c mdecl idecl cdecl args : + with_constructor_as_block = true -> + lookup_constructor Σ ind c = Some (mdecl, idecl, cdecl) -> + #|args| = cstr_arity mdecl cdecl -> + All value args -> value (tConstruct ind c args) | value_app_nonnil f args : value_head #|args| f -> args <> [] -> All value args -> value (mkApps f args). Derive Signature for value. End Wcbv. +Fixpoint eval_depth {wfl : WcbvFlags} {Σ : EAst.global_declarations} {t1 t2 : EAst.term} (ev : eval Σ t1 t2) { struct ev } : nat. +Proof. + rename eval_depth into aux. + destruct ev. + all:try match goal with + | [ H : eval _ _ _, H' : eval _ _ _, H'' : eval _ _ _ |- _ ] => + apply aux in H; apply aux in H'; apply aux in H''; exact (S (Nat.max H (Nat.max H' H''))) + | [ H : eval _ _ _, H' : eval _ _ _ |- _ ] => + apply aux in H; apply aux in H'; exact (S (Nat.max H H')) + | [ H : eval _ _ _ |- _ ] => apply aux in H; exact (S H) + end. + exact (S (all2_size _ (fun x y ev => aux wfl Σ x y ev) a)). + exact 1. +Defined. + +Set Equations Transparent. +Section eval_rect. + + Variables (wfl : WcbvFlags) (Σ : global_declarations) (P : forall x y, eval Σ x y → Type). + + Equations All2_over {A B : Set} {P : A → B → Set} {l : list A} {l' : list B} : + All2_Set P l l' → (∀ (x : A) (y : B), P x y → Type) → Type := + | All2_nil, _ := unit + | All2_cons rxy rll', Q => Q _ _ rxy × All2_over rll' Q. + + Lemma eval_rect : + (∀ (a t t' : term) (e : eval Σ a tBox), + P a tBox e + → ∀ e0 : eval Σ t t', + P t t' e0 → P (tApp a t) tBox (eval_box Σ a t t' e e0)) + → (∀ (f0 : term) (na : name) (b a a' res : term) + (e : eval Σ f0 (tLambda na b)), + P f0 (tLambda na b) e + → ∀ e0 : eval Σ a a', + P a a' e0 + → ∀ e1 : eval Σ (csubst a' 0 b) res, + P (csubst a' 0 b) res e1 + → P (tApp f0 a) res (eval_beta Σ f0 na b a a' res e e0 e1)) + → (∀ (na : name) (b0 b0' b1 res : term) (e : eval Σ b0 b0'), + P b0 b0' e + → ∀ e0 : eval Σ (csubst b0' 0 b1) res, + P (csubst b0' 0 b1) res e0 + → P (tLetIn na b0 b1) res (eval_zeta Σ na b0 b0' b1 res e e0)) + → (∀ (ind : inductive) (pars : nat) (cdecl : constructor_body) + (discr : term) (c : nat) (args : list term) + (brs : list (list name × term)) (br : list name × term) + (res : term) (e : with_constructor_as_block = false) + (e0 : eval Σ discr (mkApps (tConstruct ind c []) args)), + P discr (mkApps (tConstruct ind c []) args) e0 + → ∀ (e1 : constructor_isprop_pars_decl Σ ind c = + Some (false, pars, cdecl)) (e2 : + nth_error brs c = + Some br) + (e3 : #|args| = pars + cstr_nargs cdecl) + (e4 : #|skipn pars args| = #|br.1|) + (e5 : eval Σ (iota_red pars args br) res), + P (iota_red pars args br) res e5 + → P (tCase (ind, pars) discr brs) res + (eval_iota Σ ind pars cdecl discr c args brs br res e e0 + e1 e2 e3 e4 e5)) + → (∀ (ind : inductive) (pars : nat) (cdecl : constructor_body) + (discr : term) (c : nat) (args : list term) + (brs : list (list name × term)) (br : list name × term) + (res : term) (e : with_constructor_as_block = true) + (e0 : eval Σ discr (tConstruct ind c args)), + P discr (tConstruct ind c args) e0 + → ∀ (e1 : constructor_isprop_pars_decl Σ ind c = + Some (false, pars, cdecl)) + (e2 : nth_error brs c = Some br) + (e3 : #|args| = pars + cstr_nargs cdecl) + (e4 : #|skipn pars args| = #|br.1|) + (e5 : eval Σ (iota_red pars args br) res), + P (iota_red pars args br) res e5 + → P (tCase (ind, pars) discr brs) res + (eval_iota_block Σ ind pars cdecl discr c args brs br + res e e0 e1 e2 e3 e4 e5)) + → (∀ (ind : inductive) (pars : nat) (discr : term) + (brs : list (list name × term)) (n : list name) + (f4 res : term) (i : with_prop_case) + (e : eval Σ discr tBox), + P discr tBox e + → ∀ (e0 : inductive_isprop_and_pars Σ ind = Some (true, pars)) + (e1 : brs = [(n, f4)]) (e2 : eval Σ + (substl + (repeat tBox #|n|) f4) res), + P (substl (repeat tBox #|n|) f4) res e2 + → P (tCase (ind, pars) discr brs) res + (eval_iota_sing Σ ind pars discr brs n f4 res i e e0 + e1 e2)) + → (∀ (f5 : term) (mfix : mfixpoint term) + (idx : nat) (argsv : list term) (a av fn res : term) + (guarded : with_guarded_fix) (e : + eval Σ f5 + (mkApps + (tFix mfix idx) argsv)), + P f5 (mkApps (tFix mfix idx) argsv) e + → ∀ e0 : eval Σ a av, + P a av e0 + → ∀ (e1 : cunfold_fix mfix idx = Some (#|argsv|, fn)) + (e2 : eval Σ (tApp (mkApps fn argsv) av) res), + P (tApp (mkApps fn argsv) av) res e2 + → P (tApp f5 a) res + (eval_fix Σ f5 mfix idx argsv a av fn res + guarded e e0 e1 e2)) + → (∀ (f6 : term) (mfix : mfixpoint term) + (idx : nat) (argsv : list term) + (a av : term) (narg : nat) (fn : term) + (guarded : with_guarded_fix) (e : + eval Σ f6 + (mkApps + (tFix mfix idx) argsv)), + P f6 (mkApps (tFix mfix idx) argsv) e + → ∀ e0 : eval Σ a av, + P a av e0 + → ∀ (e1 : cunfold_fix mfix idx = Some (narg, fn)) + (l : #|argsv| < narg), + P (tApp f6 a) + (tApp (mkApps (tFix mfix idx) argsv) av) + (eval_fix_value Σ f6 mfix idx argsv a av narg fn + guarded e e0 e1 l)) + → (∀ (f7 : term) (mfix : mfixpoint term) + (idx : nat) (a av fn res : term) + (narg : nat) (unguarded : with_guarded_fix = false) + (e : eval Σ f7 (tFix mfix idx)), + P f7 (tFix mfix idx) e + → ∀ (e0 : cunfold_fix mfix idx = Some (narg, fn)) + (e1 : eval Σ a av), + P a av e1 + → ∀ e2 : eval Σ (tApp fn av) res, + P (tApp fn av) res e2 + → P (tApp f7 a) res + (eval_fix' Σ f7 mfix idx a av fn res narg + unguarded e e0 e1 e2)) + → (∀ (ip : inductive × nat) (mfix : mfixpoint term) + (idx : nat) (args : list term) + (discr : term) (narg : nat) + (fn : term) (brs : list (list name × term)) + (res : term) (e : eval Σ discr + (mkApps (tCoFix mfix idx) args)), + P discr (mkApps (tCoFix mfix idx) args) e + → ∀ (e0 : cunfold_cofix mfix idx = Some (narg, fn)) + (e1 : eval Σ (tCase ip (mkApps fn args) brs) res), + P (tCase ip (mkApps fn args) brs) res e1 + → P (tCase ip discr brs) res + (eval_cofix_case Σ ip mfix idx args discr narg + fn brs res e e0 e1)) + → (∀ (p : projection) (mfix : mfixpoint term) + (idx : nat) (args : list term) + (discr : term) (narg : nat) + (fn res : term) (e : eval Σ discr + (mkApps + (tCoFix mfix idx) args)), + P discr (mkApps (tCoFix mfix idx) args) e + → ∀ (e0 : cunfold_cofix mfix idx = Some (narg, fn)) + (e1 : eval Σ (tProj p (mkApps fn args)) res), + P (tProj p (mkApps fn args)) res e1 + → P (tProj p discr) res + (eval_cofix_proj Σ p mfix idx args discr + narg fn res e e0 e1)) + → (∀ (c : kername) (decl : constant_body) + (body : term) (isdecl : + declared_constant Σ c decl) + (res : term) (e : cst_body decl = Some body) + (e0 : eval Σ body res), + P body res e0 + → P (tConst c) res + (eval_delta Σ c decl body isdecl res e e0)) + → (∀ (p : projection) (cdecl : constructor_body) + (discr : term) (args : list term) + (a res : term) (e : with_constructor_as_block = + false) + (e0 : eval Σ discr + (mkApps (tConstruct (proj_ind p) 0 []) + args)), + P discr + (mkApps (tConstruct (proj_ind p) 0 []) args) + e0 + → ∀ (e1 : constructor_isprop_pars_decl Σ + (proj_ind p) 0 = + Some (false, proj_npars p, cdecl)) + (e2 : #|args| = + proj_npars p + cstr_nargs cdecl) + (e3 : nth_error args + (proj_npars p + proj_arg p) = + Some a) (e4 : eval Σ a res), + P a res e4 + → P (tProj p discr) res + (eval_proj Σ p cdecl discr args a res e + e0 e1 e2 e3 e4)) + → (∀ (p : projection) (cdecl : constructor_body) + (discr : term) (args : list term) + (a res : term) (e : + with_constructor_as_block = + true) + (e0 : eval Σ discr + (tConstruct (proj_ind p) 0 args)), + P discr (tConstruct (proj_ind p) 0 args) e0 + → ∀ (e1 : constructor_isprop_pars_decl Σ + (proj_ind p) 0 = + Some (false, proj_npars p, cdecl)) + (e2 : #|args| = + proj_npars p + cstr_nargs cdecl) + (e3 : nth_error args + (proj_npars p + proj_arg p) = + Some a) (e4 : eval Σ a res), + P a res e4 + → P (tProj p discr) res + (eval_proj_block Σ p cdecl discr args + a res e e0 e1 e2 e3 e4)) + → (∀ (p : projection) + (discr : term) (i : with_prop_case) + (e : eval Σ discr tBox), + P discr tBox e + → ∀ e0 : inductive_isprop_and_pars Σ + (proj_ind p) = + Some (true, proj_npars p), + P (tProj p discr) tBox + (eval_proj_prop Σ p discr i e e0)) + → (∀ (ind : inductive) + (c : nat) (mdecl : mutual_inductive_body) + (idecl : one_inductive_body) + (cdecl : constructor_body) + (f14 : term) (args : list term) + (a a' : term) (e : + with_constructor_as_block = + false) + (e0 : lookup_constructor Σ ind c = + Some (mdecl, idecl, cdecl)) + (e1 : eval Σ f14 + (mkApps (tConstruct ind c []) args)), + P f14 (mkApps (tConstruct ind c []) args) + e1 + → ∀ (l : #|args| < cstr_arity mdecl cdecl) + (e2 : eval Σ a a'), + P a a' e2 + → P (tApp f14 a) + (tApp + (mkApps + (tConstruct ind c []) args) + a') + (eval_construct Σ ind c mdecl + idecl cdecl f14 args a a' e e0 + e1 l e2)) + → (∀ (ind : inductive) + (c : nat) (mdecl : mutual_inductive_body) + (idecl : one_inductive_body) + (cdecl : constructor_body) + (args args' : + list term) (e : + with_constructor_as_block = + true) + (e0 : lookup_constructor Σ ind c = + Some (mdecl, idecl, cdecl)) + (e1 : #|args| = cstr_arity mdecl cdecl) + (a : All2_Set (eval Σ) args args') + (iha : All2_over a P), + P (tConstruct ind c args) + (tConstruct ind c args') + (eval_construct_block Σ ind c mdecl + idecl cdecl args args' e e0 e1 a)) + → (∀ (f16 f' a a' : term) + (e : eval Σ f16 f'), + P f16 f' e + → ∀ (i : ~~ + (isLambda f' + || + (if with_guarded_fix + then isFixApp f' + else isFix f') || + isBox f' + || + isConstructApp f' + || isPrimApp f')) + (e0 : eval Σ a a'), + P a a' e0 + → P (tApp f16 a) + (tApp f' a') + (eval_app_cong Σ f16 f' a a' e + i e0)) + → (∀ (t : term) (i : atom Σ t), + P t t (eval_atom Σ t i)) + → ∀ (t t0 : term) (e : eval Σ t t0), + P t t0 e. + Proof using Type. + intros ????????????????????? H. + revert t t0 H. + fix aux 3. + move aux at top. + intros t t0 H. + destruct H. + all:try match goal with + | [ H : _ |- _ ] => + eapply H; (unshelve eapply aux || tea); tea; cbn; try lia + end. + clear -aux a. revert args args' a. + fix aux' 3. destruct a. constructor. constructor. apply aux. apply aux'. + Qed. + + Definition eval_rec := eval_rect. + Definition eval_ind := eval_rect. + +End eval_rect. + Global Hint Constructors value : value. Section Wcbv. @@ -245,19 +625,24 @@ Section Wcbv. Lemma value_app f args : value_head #|args| f -> All value args -> value (mkApps f args). Proof. destruct args. - - intros [] hv; now constructor. + - intros [] hv; constructor; try easy. cbn [atom mkApps]. now rewrite e e0. - intros vh av. eapply value_app_nonnil => //. Qed. Lemma value_values_ind : forall P : term -> Type, - (forall t, atom t -> P t) -> + (forall t, atom Σ t -> P t) -> + (forall (ind : inductive) (c : nat) (mdecl : mutual_inductive_body) (idecl : one_inductive_body) (cdecl : constructor_body) + (args : list term) (e : with_constructor_as_block = true) (e0 : lookup_constructor Σ ind c = Some (mdecl, idecl, cdecl)) + (l : #|args| = cstr_arity mdecl cdecl) (a : All value args) , All P args -> + P (tConstruct ind c args)) -> (forall f args, value_head #|args| f -> args <> [] -> All value args -> All P args -> P (mkApps f args)) -> forall t : term, value t -> P t. Proof. - intros P ??. + intros P X X0 X1. fix value_values_ind 2. destruct 1. - apply X; auto. - - eapply X0; auto; tea. + - eapply X0; auto; tea. clear -a value_values_ind. induction a; econstructor; auto. + - eapply X1; auto; tea. clear v n. revert args a. fix aux 2. destruct 1. constructor; auto. constructor. now eapply value_values_ind. now apply aux. Defined. @@ -270,19 +655,26 @@ Section Wcbv. Proof. destruct t; auto. Qed. Hint Resolve isStuckfix_nApp : core. - Lemma atom_nApp {t} : atom t -> ~~ isApp t. + Lemma atom_nApp {t} : atom Σ t -> ~~ isApp t. Proof. destruct t; auto. Qed. Hint Resolve atom_nApp : core. Lemma value_mkApps_inv t l : ~~ isApp t -> value (mkApps t l) -> - ((l = []) /\ atom t) + ([× l <> [], value_head #|l| t & All value l]). + ((l = []) /\ atom Σ t) + + (l = [] × ∑ ind c mdecl idecl cdecl args, [ × with_constructor_as_block , lookup_constructor Σ ind c = Some (mdecl, idecl, cdecl), t = tConstruct ind c args, #|args| = cstr_arity mdecl cdecl & All value args]) + + ([× l <> [], value_head #|l| t & All value l]). Proof. intros H H'. generalize_eq x (mkApps t l). revert x H' t H. apply: value_values_ind. - intros. subst. now eapply atom_mkApps in H. + - intros * wcon lup len H IH t ht hcon. + destruct l using rev_ind. + + cbn in hcon. invs hcon. left. right. + repeat eexists; eauto. + + rewrite mkApps_app in hcon. invs hcon. - intros * vh nargs hargs ih t isapp appeq. move: (value_head_nApp vh) => Ht. right. apply mkApps_eq_inj in appeq => //. intuition subst; auto => //. @@ -294,8 +686,17 @@ Section Wcbv. All value l. Proof. intros val not_app. - now apply value_mkApps_inv in val as [(-> & ?)|[]]. + now apply value_mkApps_inv in val as [[(-> & ?) | [-> ] ] |[]]. Qed. + + Lemma eval_Construct_inv ind c args e : + eval (tConstruct ind c args) e -> + ∑ args', e = tConstruct ind c args' × All2 eval args args'. + Proof. + intros H. depind H. + - repeat eexists; eauto. + - invs i. destruct args; invs H0. exists []. repeat econstructor. + Qed. Lemma eval_to_value e e' : eval e e' -> value e'. Proof. @@ -304,34 +705,51 @@ Section Wcbv. - change (tApp ?h ?a) with (mkApps h [a]). rewrite -mkApps_app. apply value_mkApps_inv in IHev1; [|easy]. - destruct IHev1 as [(-> & _)|[]]. + destruct IHev1 as [[(-> & _) | [-> ] ] |[]]. + apply value_app; auto. len. cbn in *. econstructor; tea. destruct with_guarded_fix => //. cbn; auto. - + depelim v. rewrite e0 in e. noconf e. + + apply value_app; auto. len. + cbn in *. econstructor; tea. + destruct with_guarded_fix => //. cbn; auto. + + depelim v. rewrite e1 in e. noconf e. eapply value_app; auto. econstructor; tea. destruct with_guarded_fix => //. len; lia. apply All_app_inv; auto. - apply value_mkApps_inv in IHev1; [|easy]. - destruct IHev1 as [(-> & _)|[]]. + destruct IHev1 as [[(-> & _)|[-> ]] | []]. + + cbn. eapply (value_app _ [a']); cbn; auto. econstructor; tea. + cbn. eapply (value_app _ [a']); cbn; auto. econstructor; tea. + rewrite -[tApp _ _](mkApps_app _ _ [a']). eapply value_app. cbn; auto. econstructor; tea. cbn; len. eapply All_app_inv; auto. - + + - econstructor 2; tea. now rewrite -(All2_length a). + clear -a iha. induction a. constructor. + destruct iha as [va' ih]. + constructor. exact va'. now apply IHa. + - destruct (mkApps_elim f' [a']). eapply value_mkApps_inv in IHev1 => //. destruct IHev1 as [?|[]]; intuition subst. * rewrite H in i |- *. simpl in *. - apply (value_app f0 [a']). - destruct f0; simpl in * |- *; try congruence. + apply (value_app f [a']). + destruct f; simpl in * |- *; try congruence. + rewrite !negb_or /= in i; rtoProp; intuition auto. + rewrite !negb_or /= in i; rtoProp; intuition auto. + destruct with_guarded_fix. - now cbn in i. now cbn in i. + now cbn in i. now cbn in i. + constructor. + + cbn in i. destruct with_guarded_fix; cbn in i; rtoProp; intuition auto. + econstructor; auto. + * destruct b0 as (ind & c & mdecl & idecl & cdecl & args & [H1 H2 H3 H4]). + rewrite -[tApp _ _](mkApps_app _ (firstn n l) [a']). + rewrite a0 in i |- *. simpl in *. + apply (value_app f [a']). + destruct f; simpl in * |- *; try congruence. + + rewrite !negb_or /= in i; rtoProp; intuition auto. + + destruct with_guarded_fix. now cbn in i. now cbn in i. * rewrite -[tApp _ _](mkApps_app _ (firstn n l) [a']). eapply value_app; eauto with pcuic. 2:eapply All_app_inv; auto. len. @@ -353,7 +771,7 @@ Section Wcbv. value_head n t -> eval t t. Proof. destruct 1. - - now constructor. + - constructor; try easy. now cbn [atom]; rewrite e e0. - now eapply eval_atom. - now eapply eval_atom. Qed. @@ -362,9 +780,9 @@ Section Wcbv. (* It means no redex can remain at the head of an evaluated term. *) Lemma value_head_spec' n t : - value_head n t -> (~~ (isLambda t || isBox t)) && atom t. + value_head n t -> (~~ (isLambda t || isBox t)) && atom Σ t. Proof. - induction 1; cbn => //. + induction 1; auto. cbn [atom]; rewrite e e0 //. Qed. @@ -484,6 +902,7 @@ Section Wcbv. - destruct L using rev_ind. reflexivity. rewrite mkApps_app in i. inv i. + - EAstUtils.solve_discr. - EAstUtils.solve_discr. depelim v. Qed. @@ -528,6 +947,8 @@ Section Wcbv. unfold atom in isatom. destruct argsv using rev_case => //. split; auto. simpl. simpl in isatom. rewrite H //. rewrite mkApps_app /= // in isatom. + - intros. destruct argsv using rev_case => //. + rewrite mkApps_app in Heqtfix => //. - intros * vf hargs vargs ihargs eq. solve_discr => //. depelim vf. rewrite e. intros [= <- <-]. destruct with_guarded_fix => //. split => //. unfold isStuckFix. rewrite e. now apply Nat.leb_le. @@ -546,13 +967,14 @@ Section Wcbv. Qed. Lemma eval_mkApps_Construct ind c mdecl idecl cdecl f args args' : + with_constructor_as_block = false -> lookup_constructor Σ ind c = Some (mdecl, idecl, cdecl) -> - eval f (tConstruct ind c) -> + eval f (tConstruct ind c []) -> #|args| <= cstr_arity mdecl cdecl -> All2 eval args args' -> - eval (mkApps f args) (mkApps (tConstruct ind c) args'). + eval (mkApps f args) (mkApps (tConstruct ind c []) args'). Proof. - intros hdecl evf hargs. revert args'. + intros hblock hdecl evf hargs. revert args'. induction args using rev_ind; intros args' evargs. - depelim evargs. now cbn. - eapply All2_app_inv_l in evargs as [r1 [r2 [-> [evl evr]]]]. @@ -564,6 +986,17 @@ Section Wcbv. rewrite -(All2_length evl). lia. Qed. + Lemma eval_mkApps_Construct_block ind c mdecl idecl cdecl f args args' : + with_constructor_as_block -> + lookup_constructor Σ ind c = Some (mdecl, idecl, cdecl) -> + eval f (tConstruct ind c []) -> + #|args| = cstr_arity mdecl cdecl -> + All2 eval args args' -> + eval (tConstruct ind c args) (tConstruct ind c args'). + Proof. + intros. econstructor; tea. auto. + Qed. + Lemma eval_mkApps_CoFix f mfix idx args args' : eval f (tCoFix mfix idx) -> All2 eval args args' -> @@ -577,7 +1010,8 @@ Section Wcbv. rewrite !mkApps_app /=. eapply eval_app_cong; tea. eapply IHargs => //. - rewrite isFixApp_mkApps // /= isConstructApp_mkApps // !negb_or. rtoProp; intuition auto. + rewrite isFixApp_mkApps // /= isConstructApp_mkApps // !negb_or isPrimApp_mkApps. + rtoProp; intuition auto. apply nisLambda_mkApps => //. destruct with_guarded_fix => //; eapply nisFix_mkApps => //. apply nisBox_mkApps => //. @@ -620,6 +1054,9 @@ Section Wcbv. Proof. move: e; eapply value_values_ind; simpl; intros; eauto with value. - now constructor. + - assert (All2 eval args args). + { clear -X; induction X; constructor; auto. } + econstructor; tea; auto. - assert (All2 eval args args). { clear -X0; induction X0; constructor; auto. } eapply eval_mkApps_cong => //. now eapply value_head_final. @@ -656,9 +1093,18 @@ Section Wcbv. apply mkApps_eq_inj in apps_eq as (eq1 & eq2); try easy. noconf eq1. noconf eq2. noconf IHev1. - pose proof e0. rewrite e4 in H. noconf H. - pose proof e as e'. rewrite e3 in e'. noconf e'. - rewrite -> (uip e e3), (uip e0 e4), (uip e1 e5), (uip e2 e6). + assert (e = e0) by apply uip. subst e0. + pose proof e1. rewrite e5 in H. noconf H. + assert (e1 = e5) by apply uip. subst e5. + assert (br0 = br) as -> by congruence. + rewrite -> (uip e8 e4), (uip e2 e6), (uip e3 e7), (uip e4 e8). + specialize (IHev2 _ ev'2); noconf IHev2. + reflexivity. + - depelim ev'; try go. + + specialize (IHev1 _ ev'1); noconf IHev1. + pose proof e1. rewrite e5 in H. noconf H. + assert (br0 = br) as -> by congruence. + rewrite -> (uip e e0), (uip e1 e5), (uip e8 e4), (uip e2 e6), (uip e3 e7), (uip e4 e8). specialize (IHev2 _ ev'2); noconf IHev2. reflexivity. - depelim ev'; try go. @@ -666,7 +1112,7 @@ Section Wcbv. noconf e2. simpl. specialize (IHev1 _ ev'1); noconf IHev1. simpl. - pose proof (uip e e1). subst. + pose proof (uip e0 e). subst. pose proof (uip i i0). subst i0. now specialize (IHev2 _ ev'2); noconf IHev2. - depelim ev'; try go. @@ -676,13 +1122,13 @@ Section Wcbv. noconf IHev1. specialize (IHev2 _ ev'2); noconf IHev2. assert (fn0 = fn) as -> by congruence. - assert (e0 = e) as -> by now apply uip. + assert (e1 = e) as -> by now apply uip. rewrite (uip guarded guarded0). now specialize (IHev3 _ ev'3); noconf IHev3. + specialize (IHev1 _ ev'1). pose proof (mkApps_eq_inj (f_equal pr1 IHev1) eq_refl eq_refl) as (? & <-). noconf H. - exfalso; rewrite e0 in e. + exfalso; rewrite e1 in e. noconf e. lia. + specialize (IHev1 _ ev'1). @@ -695,7 +1141,7 @@ Section Wcbv. + specialize (IHev1 _ ev'1). pose proof (mkApps_eq_inj (f_equal pr1 IHev1) eq_refl eq_refl) as (? & <-). noconf H. - exfalso; rewrite e0 in e. + exfalso; rewrite e1 in e. noconf e. lia. + specialize (IHev1 _ ev'1). @@ -705,7 +1151,7 @@ Section Wcbv. specialize (IHev2 _ ev'2); noconf IHev2. assert (narg0 = narg) as -> by congruence. assert (fn0 = fn) as -> by congruence. - assert (e0 = e) as -> by now apply uip. + assert (e1 = e) as -> by now apply uip. rewrite (uip guarded guarded0). now assert (l0 = l) as -> by now apply PCUICWcbvEval.le_irrel. + specialize (IHev1 _ ev'1). @@ -760,46 +1206,67 @@ Section Wcbv. specialize (IHev1 _ ev'1). pose proof (mkApps_eq_inj (f_equal pr1 IHev1) eq_refl eq_refl) as (? & <-). noconf H. noconf IHev1. - pose proof e as e'. rewrite e2 in e'; noconf e'. - rewrite -> (uip e e2), (uip e0 e3). - pose proof e4 as e4'. rewrite e1 in e4'; noconf e4'. - rewrite (uip e1 e4). + assert (a0 = a) as -> by congruence. + pose proof e1 as e'. rewrite e4 in e'; noconf e'. + rewrite -> (uip e6 e3), (uip e1 e4), (uip e2 e5). + rewrite -> (uip e e0). + now specialize (IHev2 _ ev'2); noconf IHev2. + - depelim ev'; try go. + specialize (IHev1 _ ev'1); noconf IHev1. + assert (a0 = a) as -> by congruence. + pose proof e1 as e'. rewrite e4 in e'; noconf e'. + rewrite -> (uip e e0), (uip e1 e4). cbn. + rewrite -> (uip e3 e6), (uip e2 e5). now specialize (IHev2 _ ev'2); noconf IHev2. - depelim ev'; try go. specialize (IHev _ ev'). noconf IHev. rewrite (uip e e0). now rewrite (uip i i0). - - depelim ev'; try go. + - depelim ev'; try now go. + move: (IHev1 _ ev'1). eapply DepElim.simplification_sigma1 => heq IHev1'. apply mkApps_eq_inj in heq as H'; auto. destruct H' as (H' & <-). noconf H'. noconf IHev1'. - pose proof e as e'. rewrite e0 in e'; noconf e'. + pose proof e0 as e'. rewrite e2 in e'; noconf e'. specialize (IHev2 _ ev'2). noconf IHev2. - now rewrite -> (uip e e0), (PCUICWcbvEval.le_irrel _ _ l l0). + now rewrite -> (uip e e1), (uip e0 e2), (PCUICWcbvEval.le_irrel _ _ l l0). + specialize (IHev1 _ ev'1). noconf IHev1. exfalso. rewrite isConstructApp_mkApps in i. cbn in i. rewrite !negb_or in i. rtoProp; intuition auto. + - depelim ev'; try go. + + pose proof e0. rewrite e3 in H; noconf H. + rewrite -> (uip e0 e3); clear e0. + rewrite -> (uip e1 e4); clear e1. + rewrite -> (uip e e2); clear e. + assert ({| pr1 := args'; pr2 := a |} = {| pr1 := args'0; pr2 := a0 |}). clear -iha. + { induction a in iha, args'0, a0 |- *. cbn. depelim a0. reflexivity. + destruct iha. depelim a0. + specialize (IHa a1). specialize (IHa _ a0). noconf IHa. + specialize (e _ e0). now noconf e. } + now noconf H. + + exfalso. invs i. destruct args; invs H0. + rewrite e in H1; cbn in H1. discriminate. - depelim ev'; try go. + exfalso. rewrite !negb_or in i. specialize (IHev1 _ ev'1); noconf IHev1. cbn in i. rtoProp; intuition auto. + exfalso. rewrite !negb_or in i. specialize (IHev1 _ ev'1); noconf IHev1. cbn in i. rewrite guarded in i. rtoProp; intuition auto. - rewrite isFixApp_mkApps in H2 => //. + rewrite isFixApp_mkApps in H3 => //. + exfalso. rewrite !negb_or in i. specialize (IHev1 _ ev'1); noconf IHev1. cbn in i. rewrite guarded in i. rtoProp; intuition auto. - rewrite isFixApp_mkApps in H2 => //. + rewrite isFixApp_mkApps in H3 => //. + exfalso. rewrite !negb_or in i. specialize (IHev1 _ ev'1); noconf IHev1. cbn in i. rewrite unguarded in i. now cbn in i. + exfalso. rewrite !negb_or in i. specialize (IHev1 _ ev'1); noconf IHev1. cbn in i. rtoProp; intuition auto. - now rewrite isConstructApp_mkApps in H0. + now rewrite isConstructApp_mkApps in H1. + specialize (IHev1 _ ev'1); noconf IHev1. specialize (IHev2 _ ev'2); noconf IHev2. now assert (i0 = i) as -> by now apply uip. - depelim ev'; try go. - now assert (i0 = i) as -> by now apply uip. + 2: now assert (i0 = i) as -> by now apply uip. + exfalso. invs i. rewrite e in H0. destruct args; cbn in H0; invs H0. Qed. Lemma eval_unique {t v} : @@ -953,27 +1420,19 @@ Section WcbvEnv. induction ev; try solve [econstructor; eauto using (extends_lookup_constructor wf ex), (extends_constructor_isprop_pars_decl wf ex), (extends_is_propositional wf ex)]. econstructor; eauto. - red in isdecl |- *. eauto using extends_lookup. + red in isdecl |- *. eauto using extends_lookup. econstructor; tea. + eauto using extends_lookup_constructor. + clear -a iha. induction a; constructor; eauto. apply iha. apply IHa, iha. + constructor. + destruct t => //. cbn [atom] in i. destruct l => //. destruct lookup_constructor eqn:hl => //. + eapply (extends_lookup_constructor wf ex) in hl. now cbn [atom]. + cbn in i. now rewrite andb_false_r in i. Qed. End WcbvEnv. Scheme eval_nondep := Minimality for eval Sort Prop. -Fixpoint eval_depth {wfl : WcbvFlags} {Σ : EAst.global_declarations} {t1 t2 : EAst.term} (ev : eval Σ t1 t2) { struct ev } : nat. -Proof. - rename eval_depth into aux. - destruct ev. - all:try match goal with - | [ H : eval _ _ _, H' : eval _ _ _, H'' : eval _ _ _ |- _ ] => - apply aux in H; apply aux in H'; apply aux in H''; exact (S (Nat.max H (Nat.max H' H''))) - | [ H : eval _ _ _, H' : eval _ _ _ |- _ ] => - apply aux in H; apply aux in H'; exact (S (Nat.max H H')) - | [ H : eval _ _ _ |- _ ] => apply aux in H; exact (S H) - end. - exact 1. -Defined. - Lemma isLambda_mkApps f l : ~~ isLambda f -> ~~ EAst.isLambda (mkApps f l). Proof. induction l using rev_ind; simpl; auto => //. @@ -1058,6 +1517,16 @@ Proof. now eapply IHΣ. Qed. +Lemma All2_over_impl {A : Set} (P : A -> A -> Set) l l' (a : All2_Set P l l') {Q R} + (ha : All2_over a (fun t u _ => Q t u)) (arl : All R l) : + (forall x y, Q x y -> R x -> R y) -> All R l'. +Proof. + intros qr. + induction a; constructor. + - eapply qr. eapply ha. now depelim arl. + - depelim arl. eapply IHa. apply ha. apply arl. +Qed. + (** Evaluation preserves closedness: *) Lemma eval_closed {wfl : WcbvFlags} Σ : closed_env Σ -> @@ -1075,7 +1544,12 @@ Proof. move: IHev1; rewrite closedn_mkApps => /andP[] _ clargs. apply IHev2. rewrite /iota_red. eapply closed_substl. now rewrite forallb_rev forallb_skipn. - len. rewrite e2. eapply nth_error_forallb in Hc'; tea. + len. rewrite e4. eapply nth_error_forallb in Hc'; tea. + now rewrite Nat.add_0_r in Hc'. + - specialize (IHev1 Hc). + apply IHev2. rewrite /iota_red. + eapply closed_substl. now rewrite forallb_rev forallb_skipn. + len. rewrite e4. eapply nth_error_forallb in Hc'; tea. now rewrite Nat.add_0_r in Hc'. - subst brs. cbn in Hc'. rewrite andb_true_r in Hc'. eapply IHev2. eapply closed_substl. @@ -1111,9 +1585,14 @@ Proof. rewrite closedn_mkApps /= => clargs. eapply IHev2; eauto. eapply nth_error_forallb in clargs; tea. + - have := (IHev1 Hc). intros clargs. + eapply IHev2; eauto. + eapply nth_error_forallb in clargs; tea. - have := (IHev1 Hc). rewrite closedn_mkApps /= => clargs. rewrite clargs IHev2 //. + - eapply forallb_All in Hc. eapply All2_over_impl in iha; tea. solve_all. + cbn; intros; intuition auto. - rtoProp; intuition auto. Qed. @@ -1124,10 +1603,11 @@ Ltac forward_keep H := assert (H' : X) ; [|specialize (H H')] end. -Definition mk_env_flags has_ax has_pars tfl := +Definition mk_env_flags has_ax has_pars tfl has_blocks := {| has_axioms := has_ax; has_cstr_params := has_pars; - term_switches := tfl |}. + term_switches := tfl ; + cstr_as_blocks := has_blocks |}. Global Hint Rewrite andb_true_r andb_false_r : simplifications. Global Hint Rewrite orb_false_r orb_true_r : simplifications. @@ -1148,6 +1628,11 @@ Proof. - eapply IHev2; eauto. eapply wellformed_iota_red_brs; tea => //. rewrite wellformed_mkApps // in H2. move/andP: H2 => [] //. + - eapply IHev2; eauto. + eapply wellformed_iota_red_brs; tea => //. + destruct cstr_as_blocks; solve_all. + destruct lookup_constructor_pars_args as [ [] | ]; rtoProp; repeat solve_all. + destruct args; cbn in H3; eauto; econstructor. - subst brs. eapply IHev2. sim in H0. eapply wellformed_substl => //. eapply All_forallb, All_repeat => //. @@ -1158,7 +1643,7 @@ Proof. rewrite wellformed_mkApps // clargs andb_true_r. eapply wellformed_cunfold_fix; tea => //. - eapply IHev3 => //. rtoProp; intuition auto. - eapply wellformed_cunfold_fix => //; tea. cbn. rewrite H H1 //. + eapply wellformed_cunfold_fix => //; tea. cbn. rewrite H H1 H2 //. - eapply IHev2. rewrite wellformed_mkApps //. rewrite wellformed_mkApps // in H2. move/andP: H2 => [Hfix Hargs]. @@ -1175,6 +1660,19 @@ Proof. eapply IHev2; eauto. move/andP: clargs => [/andP[] hasc wfc wfargs]. eapply nth_error_forallb in wfargs; tea. + - eapply IHev2. + eapply nth_error_forallb in e3; eauto. + destruct cstr_as_blocks; eauto. + destruct lookup_constructor_pars_args as [ [] | ]; rtoProp; repeat solve_all. + destruct args; cbn in H0; eauto. + - destruct cstr_as_blocks; try congruence. + destruct lookup_constructor_pars_args as [ [] | ]; rtoProp; repeat solve_all. + now rewrite (All2_length a) in H. + eapply All2_over_impl in iha; tea. + intuition auto. + eapply All2_over_impl in iha; tea. + intuition auto. + depelim a => //. Qed. Lemma remove_last_length {X} {l : list X} : @@ -1223,6 +1721,16 @@ Proof. * now cbn in i. Qed. +Lemma eval_to_values {wfl : WcbvFlags} Σ a a' : All2 (eval Σ) a a' -> All (value Σ) a'. +Proof. + induction 1; constructor; eauto using eval_to_value. +Defined. + +Lemma values_final {wfl : WcbvFlags} Σ a: All (value Σ) a -> All2 (eval Σ) a a. +Proof. + induction 1; constructor; eauto using value_final. +Defined. + Lemma size_final {wfl : WcbvFlags} Σ t v : forall He : eval Σ t v, ∑ He' : eval Σ v v, eval_depth He' <= eval_depth He. Proof. @@ -1235,6 +1743,13 @@ Proof. - unshelve eexists; eauto. eapply eval_fix_value; eauto. eapply IHHe1. eapply IHHe2. cbn. destruct IHHe1, IHHe2. lia. - unshelve eexists. eapply eval_construct; eauto. eapply IHHe1. eapply IHHe2. cbn. destruct IHHe1, IHHe2. cbn. lia. + - unshelve eexists. eapply eval_construct_block; eauto. + now rewrite -(All2_length a). + clear -a iha. induction a; constructor. destruct iha. apply s. apply IHa. apply iha. + cbn. + clear -a iha. + { induction a; cbn; try lia. + destruct iha. destruct s. cbn. specialize (IHa a0). lia. } - unshelve eexists. eapply eval_app_cong; eauto. eapply IHHe1. eapply IHHe2. cbn. destruct IHHe1, IHHe2. lia. Qed. @@ -1358,11 +1873,14 @@ Proof. Qed. Lemma eval_mkApps_Construct_inv {fl : WcbvFlags} Σ kn c args e : - eval Σ (mkApps (tConstruct kn c) args) e -> - ∑ args', (e = mkApps (tConstruct kn c) args') × All2 (eval Σ) args args'. + with_constructor_as_block = false -> + eval Σ (mkApps (tConstruct kn c []) args) e -> + ∑ args', [× isSome (lookup_constructor Σ kn c), (e = mkApps (tConstruct kn c []) args') & All2 (eval Σ) args args']. Proof. + intros hblock. revert e; induction args using rev_ind; intros e. - - intros ev. depelim ev. exists []=> //. + - intros ev. depelim ev. congruence. exists []=> //. + split => //. cbn -[lookup_constructor] in i. now rewrite hblock /= in i. - intros ev. rewrite mkApps_app /= in ev. depelim ev; try solve_discr. destruct (IHargs _ ev1) as [? []]. solve_discr. @@ -1376,6 +1894,23 @@ Proof. * now cbn in i. Qed. +Lemma eval_mkApps_Construct_block_inv {fl : WcbvFlags} Σ kn c args oargs e : + with_constructor_as_block -> + eval Σ (mkApps (tConstruct kn c args) oargs) e -> + ∑ args', oargs = [] × (e = tConstruct kn c args') × All2 (eval Σ) args args'. +Proof. + intros hblock. + revert e; induction oargs using rev_ind; intros e. + - intros ev. depelim ev. + + eexists. split. reflexivity. split. reflexivity. auto. + + invs i. destruct args; invs H0. exists []. repeat econstructor. + - intros ev. rewrite mkApps_app /= in ev. + depelim ev; try solve_discr. + all: try specialize (IHoargs _ ev1) as (? & ? & E & ?); try congruence; try solve_discr; try noconf E. + * subst. cbn in i. destruct with_guarded_fix; cbn in *; eauto. + * invs i. +Qed. + Lemma eval_mkApps_inv_size {wfl : WcbvFlags} {Σ f args v} : forall ev : eval Σ (mkApps f args) v, ∑ f' args' (evf : eval Σ f f'), @@ -1464,31 +1999,34 @@ Proof. Qed. Lemma eval_mkApps_Construct_size {wfl : WcbvFlags} {Σ ind c args v} : - forall ev : eval Σ (mkApps (tConstruct ind c) args) v, - ∑ args' (evf : eval Σ (tConstruct ind c) (tConstruct ind c)), + with_constructor_as_block = false -> + forall ev : eval Σ (mkApps (tConstruct ind c []) args) v, + ∑ args' (evf : eval Σ (tConstruct ind c []) (tConstruct ind c [])), [× eval_depth evf <= eval_depth ev, All2 (fun a a' => ∑ eva : eval Σ a a', eval_depth eva < eval_depth ev) args args' & - v = mkApps (tConstruct ind c) args']. + v = mkApps (tConstruct ind c []) args']. Proof. - intros ev. + intros hblock ev. destruct (eval_mkApps_inv_size ev) as [f'' [args' [? []]]]. - exists args'. - exists (eval_atom _ (tConstruct ind c) eq_refl). + exists args'. + destruct (eval_mkApps_Construct_inv _ _ _ _ _ hblock ev) as [? []]. subst v. + unshelve eexists (eval_atom _ (tConstruct ind c []) _). + cbn -[lookup_constructor]. now rewrite hblock. cbn. split => //. destruct ev; cbn => //; auto with arith. clear l. - destruct (eval_mkApps_Construct_inv _ _ _ _ _ ev) as [? []]. subst v. - eapply (eval_mkApps_Construct_inv _ _ _ []) in x as [? []]. subst f''. depelim a1. + eapply (eval_mkApps_Construct_inv _ _ _ [] _ hblock) in x as [? []]; auto. subst f''. depelim a1. f_equal. eapply eval_deterministic_all; tea. - eapply All2_impl; tea; cbn; eauto. now intros x y []. + eapply All2_impl; tea; cbn; eauto. now intros x y []. Qed. Lemma eval_construct_size {fl : WcbvFlags} [Σ kn c args e] : - forall (ev : eval Σ (mkApps (tConstruct kn c) args) e), - ∑ args', (e = mkApps (tConstruct kn c) args') × + with_constructor_as_block = false -> + forall (ev : eval Σ (mkApps (tConstruct kn c []) args) e), + ∑ args', (e = mkApps (tConstruct kn c []) args') × All2 (fun x y => ∑ ev' : eval Σ x y, eval_depth ev' < eval_depth ev) args args'. Proof. - intros ev; destruct (eval_mkApps_Construct_size ev) as [args'[evf [_ hargs hv]]]. + intros hblock ev; destruct (eval_mkApps_Construct_size hblock ev) as [args'[evf [_ hargs hv]]]. exists args'; intuition auto. Qed. @@ -1501,7 +2039,6 @@ Proof. revert e H2; induction x using rev_ind; cbn; intros; eauto. eapply All2_app_inv_l in X as (l1' & l2' & -> & H' & H2). depelim H2. - specialize (IHx e _ H' H). simpl. + specialize (IHx e _ H'). simpl. rewrite mkApps_app. simpl. econstructor; eauto. -Qed. - +Qed. \ No newline at end of file diff --git a/erasure/theories/EWcbvEvalCstrsAsBlocksInd.v b/erasure/theories/EWcbvEvalCstrsAsBlocksInd.v new file mode 100644 index 000000000..ff7801f00 --- /dev/null +++ b/erasure/theories/EWcbvEvalCstrsAsBlocksInd.v @@ -0,0 +1,489 @@ +(* Distributed under the terms of the MIT license. *) +From Coq Require Import Utf8 Program ssreflect ssrbool. +From MetaCoq.Template Require Import config utils Kernames BasicAst EnvMap. +From MetaCoq.Erasure Require Import EAst EAstUtils EInduction ELiftSubst EWcbvEval EGlobalEnv + EWellformed ECSubst EInduction EWcbvEvalInd EEtaExpanded. + +Set Asymmetric Patterns. +From Equations Require Import Equations. +Set Equations Transparent. +Local Set Keyed Unification. + +#[export] +Hint Constructors eval : core. + +Definition atomic_term (t : term) := + match t with + | tBox | tConst _ | tRel _ | tVar _ | tPrim _ => true + | _ => false + end. + +Definition has_atom {etfl : ETermFlags} (t : term) := + match t with + | tBox => has_tBox + | tConst _ => has_tConst + | tRel _ => has_tRel + | tVar _ => has_tVar + | tPrim _ => has_tPrim + | _ => false + end. + +Section OnSubterm. + Context {etfl : ETermFlags}. + Inductive on_subterms (Q : nat -> term -> Type) (n : nat) : term -> Type := + | on_atom t : has_atom t -> atomic_term t -> on_subterms Q n t + | on_evar k l : has_tEvar -> All (Q n) l -> on_subterms Q n (tEvar k l) + | on_lambda na t : has_tLambda -> Q (S n) t -> on_subterms Q n (tLambda na t) + | on_letin na t u : has_tLetIn -> Q n t -> Q (S n) u -> on_subterms Q n (tLetIn na t u) + | on_app f u : has_tApp -> Q n f -> Q n u -> on_subterms Q n (tApp f u) + | on_cstr i k args : has_tConstruct -> All (Q n) args -> on_subterms Q n (tConstruct i k args) + | on_case ci discr brs : has_tCase -> Q n discr -> + All (fun br => Q (#|br.1| + n) br.2) brs -> on_subterms Q n (tCase ci discr brs) + | on_proj p c : has_tProj -> Q n c -> on_subterms Q n (tProj p c) + | on_fix mfix idx : has_tFix -> All (fun d => Q (#|mfix| + n) d.(dbody)) mfix -> on_subterms Q n (tFix mfix idx) + | on_cofix mfix idx : has_tCoFix -> All (fun d => Q (#|mfix| + n) d.(dbody)) mfix -> on_subterms Q n (tCoFix mfix idx). + Derive Signature for on_subterms. +End OnSubterm. + +Class Qpres {etfl : ETermFlags} (Q : nat -> term -> Type) := qpres : forall n t, Q n t -> on_subterms Q n t. +#[export] Hint Mode Qpres - ! : typeclass_instances. + +Class Qapp {etfl : ETermFlags} (Q : nat -> term -> Type) := qapp : has_tApp -> forall n f args, Q n (mkApps f args) <~> Q n f × All (Q n) args. +#[export] Hint Mode Qapp - ! : typeclass_instances. + +Class Qcase {etfl : ETermFlags} (Q : nat -> term -> Type) := qcase : has_tCase -> + forall n ci discr brs, Q n (tCase ci discr brs) -> forall discr', Q n discr' -> Q n (tCase ci discr' brs). +#[export] Hint Mode Qcase - ! : typeclass_instances. + +(* Class Qcstr {etfl : ETermFlags} (Q : nat -> term -> Type) := *) + (* qcstr : has_tConstruct -> forall i n args, Q n (tConstruct i n args) Q n discr × All (fun br => Q (#|br.1| + n) br.2) brs. *) +(* #[export] Hint Mode Qcase - ! : typeclass_instances. *) + +Class Qproj {etfl : ETermFlags} (Q : nat -> term -> Type) := qproj : has_tProj -> forall n p discr, Q n (tProj p discr) -> forall discr', Q n discr' -> Q n (tProj p discr'). +#[export] Hint Mode Qproj - ! : typeclass_instances. + +Class Qfix {etfl : ETermFlags} (Q : nat -> term -> Type) := qfix : has_tFix -> forall n mfix idx, idx < #|mfix| -> Q n (tFix mfix idx) -> forall idx', idx' < #|mfix| -> Q n (tFix mfix idx'). +#[export] Hint Mode Qfix - ! : typeclass_instances. +Class Qcofix {etfl : ETermFlags} (Q : nat -> term -> Type) := qcofix : has_tCoFix -> forall n mfix idx, idx < #|mfix| -> Q n (tCoFix mfix idx) -> forall idx', idx' < #|mfix| -> Q n (tCoFix mfix idx'). +#[export] Hint Mode Qcofix - ! : typeclass_instances. +Class Qsubst (Q : nat -> term -> Type) := qsubst : forall t l, Q (#|l|) t -> All (Q 0) l -> Q 0 (substl l t). +#[export] Hint Mode Qsubst ! : typeclass_instances. +Class Qfixs (Q : nat -> term -> Type) := qfixs : forall mfix idx, Q 0 (tFix mfix idx) -> + forall args fn, cunfold_fix mfix idx = Some (args, fn) -> + Q 0 fn. +#[export] Hint Mode Qfixs ! : typeclass_instances. +Class Qcofixs (Q : nat -> term -> Type) := qcofixs : forall mfix idx, Q 0 (tCoFix mfix idx) -> + forall args fn, cunfold_cofix mfix idx = Some (args, fn) -> + Q 0 fn. +#[export] Hint Mode Qcofixs ! : typeclass_instances. + +Lemma Qfix_subst {etfl : ETermFlags} mfix Q : has_tFix -> Qfix Q -> Qpres Q -> forall idx, idx < #|mfix| -> Q 0 (tFix mfix idx) -> All (Q 0) (fix_subst mfix). +Proof. + intros hasfix qfix qpre; unfold fix_subst. + generalize (Nat.le_refl #|mfix|). + generalize #|mfix| at 1 4. + induction n. intros. constructor; auto. + intros. constructor. eapply qfix => //. 2:tea. tea. + eapply IHn. lia. 2:tea. assumption. +Qed. + +Lemma Qcofix_subst {etfl : ETermFlags} mfix Q : has_tCoFix -> Qcofix Q -> Qpres Q -> forall idx, idx < #|mfix| -> Q 0 (tCoFix mfix idx) -> All (Q 0) (cofix_subst mfix). +Proof. + intros hascofix qcofix qpre; unfold cofix_subst. + generalize (Nat.le_refl #|mfix|). + generalize #|mfix| at 1 4. + induction n. intros. constructor; auto. + intros. constructor. eapply qcofix => //. 2:tea. tea. + eapply IHn. lia. 2:tea. assumption. +Qed. + +#[export] Instance Qsubst_Qfixs {etfl : ETermFlags} Q : Qpres Q -> Qfix Q -> Qsubst Q -> Qfixs Q. +Proof. + move=> qpres qfix; rewrite /Qsubst /Qfixs. + intros Hs mfix idx hfix args fn. + assert (hasfix : has_tFix). + { eapply qpres in hfix. now depelim hfix. } + rewrite /cunfold_fix. + destruct nth_error eqn:hnth => //. + pose proof (nth_error_Some_length hnth). + epose proof (Qfix_subst _ _ hasfix qfix qpres idx H hfix). + intros [= <-]. subst fn. + eapply Hs. rewrite fix_subst_length //. + eapply qpres in hfix. depelim hfix. depelim i0. eapply nth_error_all in a; tea. now rewrite Nat.add_0_r in a. + assumption. +Qed. + +#[export] Instance Qsubst_Qcofixs {etfl : ETermFlags} Q : Qpres Q -> Qcofix Q -> Qsubst Q -> Qcofixs Q. +Proof. + move=> qpres qfix; rewrite /Qsubst /Qfixs. + intros Hs mfix idx hfix args fn. + assert (hasfix : has_tCoFix). + { eapply qpres in hfix. now depelim hfix. } + rewrite /cunfold_cofix. + destruct nth_error eqn:hnth => //. + pose proof (nth_error_Some_length hnth). + epose proof (Qcofix_subst _ _ hasfix qfix qpres idx H hfix). + intros [= <-]. subst fn. + eapply Hs. rewrite cofix_subst_length //. + eapply qpres in hfix. depelim hfix. depelim i0. eapply nth_error_all in a; tea. now rewrite Nat.add_0_r in a. + assumption. +Qed. + +Class Qconst Σ (Q : nat -> term -> Type) := qconst : + ∀ kn decl, declared_constant Σ kn decl → + match cst_body decl with + | None => unit + | Some b => Q 0 b + end. +#[export] Hint Mode Qconst - ! : typeclass_instances. + +Set Warnings "-future-coercion-class-field". +Class Qpreserves {etfl : ETermFlags} (Q : nat -> term -> Type) Σ := + { qpres_qpres :> Qpres Q; + qpres_qcons :> Qconst Σ Q; + qpres_qapp :> Qapp Q; + qpres_qcase :> Qcase Q; + qpres_qproj :> Qproj Q; + qpres_qsubst :> Qsubst Q; + qpres_qfix :> Qfix Q; + qpres_qcofix :> Qcofix Q }. +Set Warnings "+future-coercion-class-field". + +Lemma eval_preserve_mkApps_ind : +∀ (wfl : WcbvFlags), with_constructor_as_block = true -> forall {efl : EEnvFlags} (Σ : global_declarations) + (P' : term → term → Type) + (Q : nat -> term -> Type) + {Qpres : Qpreserves Q Σ} + (P := (fun x y => [× P' x y, Q 0 x & Q 0 y])%type) + (HPQ : ∀ t u, eval Σ t u -> Q 0 t -> P' t u -> Q 0 u), + wf_glob Σ -> + has_tApp -> + (∀ (a t t' : term), + eval Σ a tBox -> + P a tBox → + eval Σ t t' → P t t' → P' (tApp a t) tBox) → + (∀ (f0 : term) (na : name) (b a a' res : term), + eval Σ f0 (tLambda na b) → + P f0 (tLambda na b) + → eval Σ a a' + → P a a' + → eval Σ (ECSubst.csubst a' 0 b) res + → P (ECSubst.csubst a' 0 b) res → P' (tApp f0 a) res) + → (∀ (na : name) (b0 b0' b1 res : term), + eval Σ b0 b0' + → P b0 b0' + -> Q 1 b1 + → eval Σ (ECSubst.csubst b0' 0 b1) res + → P (ECSubst.csubst b0' 0 b1) res → + P' (tLetIn na b0 b1) res) + → (∀ (ind : inductive) (pars : nat) cdecl (discr : term) + (c : nat) (args : list term) (brs : + list + (list name × term)) + (br : list name × term) (res : term), + eval Σ discr (tConstruct ind c args) + → P discr (tConstruct ind c args) + → constructor_isprop_pars_decl Σ ind c = Some (false, pars, cdecl) + → nth_error brs c = Some br + → #|args| = pars + cdecl.(cstr_nargs) + → #|skipn pars args| = #|br.1| + -> Q #|br.1| br.2 + → eval Σ (iota_red pars args br) res + → P (iota_red pars args br) res + → P' (tCase (ind, pars) discr brs) res) + → (∀ (ind : inductive) (pars : nat) (discr : term) + (brs : list (list name × term)) + (n : list name) (f3 res : term), + with_prop_case + → eval Σ discr tBox + → P discr tBox + → inductive_isprop_and_pars Σ ind = Some (true, pars) + → brs = [(n, f3)] + -> Q #|n| f3 + → eval Σ (ECSubst.substl (repeat tBox #|n|) f3) + res + → P (ECSubst.substl (repeat tBox #|n|) f3) res + → P' (tCase (ind, pars) discr brs) res) + → (∀ (f4 : term) (mfix : mfixpoint term) + (idx : nat) (argsv : list term) + (a av fn res : term), + with_guarded_fix -> + eval Σ f4 (mkApps (tFix mfix idx) argsv) + → P f4 (mkApps (tFix mfix idx) argsv) + → eval Σ a av + → P a av + → cunfold_fix mfix idx = Some (#|argsv|, fn) + -> Q 0 fn + → eval Σ (tApp (mkApps fn argsv) av) res + → P (tApp (mkApps fn argsv) av) res + → P' (tApp f4 a) res) + → (∀ (f5 : term) (mfix : mfixpoint term) + (idx : nat) (argsv : list term) + (a av : term) (narg : nat) (fn : term), + with_guarded_fix -> + eval Σ f5 (mkApps (tFix mfix idx) argsv) + → P f5 (mkApps (tFix mfix idx) argsv) + → eval Σ a av + → P a av + → cunfold_fix mfix idx = Some (narg, fn) + → #|argsv| < narg + → P' (tApp f5 a) + (tApp + (mkApps (tFix mfix idx) argsv) av)) + → (∀ (f5 : term) (mfix : mfixpoint term) + (idx : nat) (a av : term) (narg : nat) (fn : term) res, + with_guarded_fix = false -> + eval Σ f5 (tFix mfix idx) + → P f5 (tFix mfix idx) + → cunfold_fix mfix idx = Some (narg, fn) + -> eval Σ a av -> P a av + → eval Σ (tApp fn av) res + → P (tApp fn av) res + → P' (tApp f5 a) res) → + + (∀ (ip : inductive × nat) (mfix : mfixpoint term) + (idx : nat) (args : list term) + (narg : nat) discr (fn : term) (brs : + list + (list name × term)) + (res : term), + cunfold_cofix mfix idx = Some (narg, fn) + -> eval Σ discr (mkApps (tCoFix mfix idx) args) + -> P discr (mkApps (tCoFix mfix idx) args) + → eval Σ (tCase ip (mkApps fn args) brs) res + → P (tCase ip (mkApps fn args) brs) res + → P' + (tCase ip discr brs) + res) + → (∀ (p : projection) (mfix : mfixpoint term) + (idx : nat) (args : list term) + (narg : nat) discr (fn res : term), + has_tProj -> + cunfold_cofix mfix idx = Some (narg, fn) + -> eval Σ discr (mkApps (tCoFix mfix idx) args) + -> P discr (mkApps (tCoFix mfix idx) args) + → eval Σ (tProj p (mkApps fn args)) res + → P (tProj p (mkApps fn args)) res + → P' + (tProj p discr) res) + → (∀ (c : kername) (decl : constant_body) + (body : term), + declared_constant Σ c decl + → ∀ res : term, + cst_body decl = Some body + → eval Σ body res + → P body res → P' (tConst c) res) + → (∀ p cdecl (discr : term) (args : list term) a (res : term), + has_tProj -> + eval Σ discr (tConstruct p.(proj_ind) 0 args) + → P discr (tConstruct p.(proj_ind) 0 args) + → constructor_isprop_pars_decl Σ p.(proj_ind) 0 = Some (false, p.(proj_npars), cdecl) + → #|args| = p.(proj_npars) + cdecl.(cstr_nargs) + -> nth_error args (p.(proj_npars) + p.(proj_arg)) = Some a + -> eval Σ a res + → P a res + → P' (tProj p discr) res) + → (∀ p (discr : term), + has_tProj -> + with_prop_case + → eval Σ discr tBox + → P discr tBox + → inductive_isprop_and_pars Σ p.(proj_ind) = Some (true, p.(proj_npars)) + → P' (tProj p discr) tBox) → + (∀ (f11 f' : term) a a', + forall (ev : eval Σ f11 f'), + P f11 f' -> + (forall t u (ev' : eval Σ t u), eval_depth ev' <= eval_depth ev -> Q 0 t -> P t u) → + ~~ (isLambda f' || (if with_guarded_fix then isFixApp f' else isFix f') || isBox f' + || isConstructApp f' || isPrimApp f') → + eval Σ a a' → P a a' → + P' (tApp f11 a) (tApp f' a')) → + (∀ ind i mdecl idecl cdecl args args', + lookup_constructor Σ ind i = Some (mdecl, idecl, cdecl) -> + #|args| = cstr_arity mdecl cdecl -> + All2 (eval Σ) args args' -> + All2 P args args' -> + P' (tConstruct ind i args) (tConstruct ind i args')) → + + (∀ t : term, atom Σ t → Q 0 t -> P' t t) -> + ∀ (t t0 : term), Q 0 t -> eval Σ t t0 → P' t t0. +Proof. + intros wfl hcon. intros * Qpres P P'Q wfΣ hasapp. + assert (qfixs: Qfixs Q) by tc. + assert (qcofixs: Qcofixs Q) by tc. + intros. + pose proof (p := @Fix_F { t : _ & { t0 : _ & { qt : Q 0 t & eval Σ t t0 }}}). + specialize (p (MR lt (fun x => eval_depth x.π2.π2.π2))). + set(foo := existT _ t (existT _ t0 (existT _ X15 H)) : { t : _ & { t0 : _ & { qt : Q 0 t & eval Σ t t0 }}}). + change t with (projT1 foo). + change t0 with (projT1 (projT2 foo)). + revert foo. + match goal with + |- let foo := _ in @?P foo => specialize (p (fun x => P x)) + end. + forward p. + 2:{ apply p. apply measure_wf, lt_wf. } + clear p. + rename X15 into qt. rename X13 into Xcappexp. + rename X14 into Qatom. + clear t t0 qt H. + intros (t & t0 & qt & ev). + intros IH. + set (IH' t t0 q H := IH (t; t0; q; H)). clearbody IH'; clear IH; rename IH' into IH. + cbn in IH. unfold MR in IH; cbn in IH. cbn. + Ltac ih := + match goal with + [ IH : forall x y, ?Q 0 x -> _ |- _ ] => unshelve eapply IH; tea; cbn; try lia + end. + Ltac hp' P'Q := intros ?; repeat split => //; try eapply P'Q; tea. + assert (and_assum : forall x y, P' x y -> + ((P' x y) -> Q 0 x × Q 0 y) -> + P x y). + { intuition auto. red. intuition auto. } + Ltac ih' P'Q := + match goal with + | [ H : _, IH : forall x y, ?Q 0 x -> _ |- _ ] => + eapply H; tea; (apply and_assum; [ih|hp' P'Q]) + end. + Ltac myt hyp anda P'Q := eapply hyp; tea; (apply and_assum; [ih|hp' P'Q]). + + destruct ev. + 1-18:eapply qpres in qt as qt'; depelim qt' => //. + all:try congruence. + - eapply X; tea; (apply and_assum; [ih|hp' P'Q]). + - assert (ql : Q 0 (tLambda na b)). + { eapply P'Q; tea. ih. } + assert (qs: Q 0 (csubst a' 0 b)). + { eapply qpres in ql. depelim ql => //. + eapply (qsubst b [a']) in q1. now cbn in q1. + repeat constructor. + eapply P'Q; tea; ih. } + eapply X0; tea; (apply and_assum; [ih|hp' P'Q]). + - assert (qs : Q 0 (csubst b0' 0 b1)). + { eapply (qsubst b1 [b0']) in q0. now cbn in q0. + repeat constructor. + eapply P'Q; tea; ih. } + eapply X1; tea; (apply and_assum; [ih|hp' P'Q]). + - assert (Q 0 (iota_red pars args br)). + { unfold iota_red. + eapply nth_error_all in a; tea. cbn in a. + rewrite -e3 in a. + rewrite -(List.rev_length (skipn pars args)) in a. + rewrite Nat.add_0_r in a. + eapply (qsubst _ (List.rev (skipn pars args))) in a. + 2:{ eapply All_rev, All_skipn. + assert (Q 0 (tConstruct ind c args)). + eapply P'Q; tea; ih. eapply qpres in X13. + depelim X13 => //. } + exact a. } + eapply nth_error_all in a; tea; cbn. rewrite Nat.add_0_r in a. + eapply X2; tea; (apply and_assum; [ih|hp' P'Q]). + - assert (Q 0 (substl (repeat tBox #|n|) f)). + { subst brs. eapply All_tip in a. cbn in a. + rewrite -(repeat_length tBox #|n|) Nat.add_0_r in a. + eapply (qsubst _ (repeat tBox #|n|)) in a => //. + eapply All_repeat. eapply P'Q; tea; ih. } + eapply X3; tea. 1,3:(apply and_assum; [ih|hp' P'Q]). + subst brs. depelim a. now rewrite Nat.add_0_r in q0. + - pose proof (ev1' := ev1). eapply P'Q in ev1' => //. 2:{ clear ev1'; ih. } + eapply qapp in ev1' as [hfix qargs] => //. + assert (hastfix : has_tFix). + { eapply qpres in hfix. now depelim hfix. } + assert (qf : Q 0 fn). + { eapply (qfixs mfix idx) in hfix; tea. } + assert (qa : Q 0 (tApp (mkApps fn argsv) av)). + { rewrite -[tApp _ _](mkApps_app _ _ [av]). + unshelve eapply (qapp _ _ _ _).2; auto. + split => //. + eapply (qfixs mfix idx) in hfix; tea. + eapply All_app_inv => //. eapply All_tip.1. + eapply P'Q; tea; ih. } + eapply X4; tea. 1-3:(apply and_assum; [ih|hp' P'Q]). + - eapply X5; tea; (apply and_assum; [ih|hp' P'Q]). + - assert (qav : Q 0 av). + { eapply P'Q; tea; ih. } + assert (qa : Q 0 (tApp fn av)). + { pose proof (ev1' := ev1). eapply P'Q in ev1' => //. 2:clear ev1'; ih. + eapply qfixs in ev1'. cbn in IH. eapply ev1' in e. + unshelve eapply (qapp _ _ _ [av]); tea; split => //. now eapply All_tip.1. } + eapply X6; tea. 1-3:(apply and_assum; [ih|hp' P'Q]). + - assert (qa : Q 0 (tCase ip (mkApps fn args) brs)). + { eapply qcase; tea => //. + pose proof (ev1' := ev1). eapply P'Q in ev1' => //. + eapply qapp in ev1' as [hfix qargs] => //. + eapply qapp => //. split => //. + eapply (qcofixs mfix idx) in hfix; tea. + clear ev1'; ih. } + eapply X7; tea; (apply and_assum; [ih|hp' P'Q]). + - cbn in IH. + assert (qa : Q 0 (tProj p (mkApps fn args))). + { pose proof (ev1' := ev1). eapply P'Q in ev1' => //. + eapply qapp in ev1' as [hfix ?] => //. + eapply qproj; tea => //. eapply qapp => //. split => //. + eapply (qcofixs mfix idx) in hfix; tea. + clear ev1'; ih. } + eapply X8; tea; (apply and_assum; [ih|hp' P'Q]). + - assert (Q 0 body). + { cbn in IH; eapply (qconst (Q:=Q)) in isdecl. now rewrite e in isdecl. } + eapply X9; tea; (apply and_assum; [ih|hp' P'Q]). + - assert (Q 0 a). + { pose proof (ev1' := ev1). eapply P'Q in ev1' => //. + eapply qpres in ev1'; depelim ev1' => //. + { eapply nth_error_all in a0; tea. } + clear ev1'; ih. } + eapply X10; tea; (apply and_assum; [ih|hp' P'Q]). + - unshelve eapply X11; tea; try (intros; apply and_assum; [ih|hp' P'Q]). + - rename args into cargs. + eapply Xcappexp; tea. eauto. + cbn in IH. + clear -P'Q IH a a0 and_assum. + revert a0; induction a; constructor; auto. depelim a0. + apply and_assum; [ih|hp' P'Q]. + eapply IHa. cbn. intros. eapply (IH _ _ q H). cbn. lia. + now depelim a0. + - eapply (X12 _ _ _ _ ev1); tea. + 1,3:(apply and_assum; [ih|hp' P'Q]). + intros. apply and_assum; [ih|hp' P'Q]. + - eapply Qatom; tea. +Qed. + +Lemma Qpreserves_wellformed (efl : EEnvFlags) Σ : wf_glob Σ -> Qpreserves (fun n x => wellformed Σ n x) Σ. +Proof. + intros clΣ. + split. + - red. move=> n t. + destruct t; cbn -[lookup_constructor lookup_constructor_pars_args]; intuition auto; try solve [constructor; auto]. + rtoProp; intuition auto. + constructor => //. + eapply on_evar; rtoProp; intuition auto. solve_all. + eapply on_lambda;rtoProp; intuition auto. + eapply on_letin; rtoProp; intuition auto. + eapply on_app; rtoProp; intuition auto. + constructor => //; rtoProp; intuition auto. + move/andP: H => [] /andP[] has isl hf => //. + eapply on_cstr => //. destruct cstr_as_blocks. + rtoProp; intuition auto. solve_all. destruct l => //. + eapply on_case; rtoProp; intuition auto. solve_all. + eapply on_proj; rtoProp; intuition auto. + rtoProp; intuition auto. + eapply on_fix => //. move/andP: H0 => [] _ ha. solve_all. + rtoProp; intuition auto. + eapply on_cofix => //. move/andP: H0 => [] _ ha. solve_all. + - red. intros kn decl. + move/(lookup_env_wellformed clΣ). + unfold wf_global_decl. destruct cst_body => //. + - red. move=> hasapp n t args. rewrite wellformed_mkApps //. + split; intros; rtoProp; intuition auto; solve_all. + - red. + move=> hascase n ci discr brs. simpl. + destruct lookup_inductive eqn:hl => /= //. + intros; rtoProp; intuition auto; solve_all. + - red. simpl. move=> hasproj n p discr wf discr' wf'. + simpl. rtoProp; intuition auto. + - red. move=> t args clt cll. + eapply wellformed_substl. solve_all. now rewrite Nat.add_0_r. + - red. move=> n mfix idx. cbn. unfold EWellformed.wf_fix. + intros; rtoProp; intuition auto; solve_all. now apply Nat.ltb_lt. + - red. move=> n mfix idx. cbn. unfold EWellformed.wf_fix. + intros; rtoProp; intuition auto; solve_all. now apply Nat.ltb_lt. +Qed. diff --git a/erasure/theories/EWcbvEvalEtaInd.v b/erasure/theories/EWcbvEvalEtaInd.v index 8707820dc..f58a2ea6b 100644 --- a/erasure/theories/EWcbvEvalEtaInd.v +++ b/erasure/theories/EWcbvEvalEtaInd.v @@ -14,17 +14,18 @@ Hint Constructors eval : core. Definition atomic_term (t : term) := match t with - | tBox | tConstruct _ _ | tConst _ | tRel _ | tVar _ => true + | tBox | tConstruct _ _ _ | tConst _ | tRel _ | tVar _ | tPrim _ => true | _ => false end. Definition has_atom {etfl : ETermFlags} (t : term) := match t with | tBox => has_tBox - | tConstruct _ _ => has_tConstruct + | tConstruct _ _ _ => has_tConstruct | tConst _ => has_tConst | tRel _ => has_tRel | tVar _ => has_tVar + | tPrim _ => has_tPrim | _ => false end. @@ -50,16 +51,16 @@ Class Qpres {etfl : ETermFlags} (Q : nat -> term -> Type) := qpres : forall n t, Class Qapp {etfl : ETermFlags} (Q : nat -> term -> Type) := qapp : has_tApp -> forall n f args, Q n (mkApps f args) <~> Q n f × All (Q n) args. #[export] Hint Mode Qapp - ! : typeclass_instances. -Class Qcase {etfl : ETermFlags} (Q : nat -> term -> Type) := qcase : has_tCoFix -> has_tCase -> forall n ci discr brs, Q n (tCase ci discr brs) <~> - Q n discr × All (fun br => Q (#|br.1| + n) br.2) brs. +Class Qcase {etfl : ETermFlags} (Q : nat -> term -> Type) := qcase : has_tCase -> + forall n ci discr brs, Q n (tCase ci discr brs) -> forall discr', Q n discr' -> Q n (tCase ci discr' brs). #[export] Hint Mode Qcase - ! : typeclass_instances. -Class Qproj {etfl : ETermFlags} (Q : nat -> term -> Type) := qproj : has_tProj -> forall n p discr, Q n (tProj p discr) <~> Q n discr. +Class Qproj {etfl : ETermFlags} (Q : nat -> term -> Type) := qproj : has_tProj -> forall n p discr, Q n (tProj p discr) -> forall discr', Q n discr' -> Q n (tProj p discr'). #[export] Hint Mode Qproj - ! : typeclass_instances. -Class Qfix {etfl : ETermFlags} (Q : nat -> term -> Type) := qfix : has_tFix -> forall n mfix idx, idx < #|mfix| -> Q n (tFix mfix idx) <~> All (fun d => Q (#|mfix| + n) d.(dbody)) mfix. +Class Qfix {etfl : ETermFlags} (Q : nat -> term -> Type) := qfix : has_tFix -> forall n mfix idx, idx < #|mfix| -> Q n (tFix mfix idx) -> forall idx', idx' < #|mfix| -> Q n (tFix mfix idx'). #[export] Hint Mode Qfix - ! : typeclass_instances. -Class Qcofix {etfl : ETermFlags} (Q : nat -> term -> Type) := qcofix : has_tCoFix -> forall n mfix idx, idx < #|mfix| -> Q n (tCoFix mfix idx) <~> All (fun d => Q (#|mfix| + n) d.(dbody)) mfix. +Class Qcofix {etfl : ETermFlags} (Q : nat -> term -> Type) := qcofix : has_tCoFix -> forall n mfix idx, idx < #|mfix| -> Q n (tCoFix mfix idx) -> forall idx', idx' < #|mfix| -> Q n (tCoFix mfix idx'). #[export] Hint Mode Qcofix - ! : typeclass_instances. Class Qsubst (Q : nat -> term -> Type) := qsubst : forall t l, Q (#|l|) t -> All (Q 0) l -> Q 0 (substl l t). #[export] Hint Mode Qsubst ! : typeclass_instances. @@ -72,22 +73,24 @@ Class Qcofixs (Q : nat -> term -> Type) := qcofixs : forall mfix idx, Q 0 (tCoFi Q 0 fn. #[export] Hint Mode Qcofixs ! : typeclass_instances. -Lemma Qfix_subst {etfl : ETermFlags} mfix Q : has_tFix -> Qfix Q -> All (λ d : def term, Q (#|mfix| + 0) (dbody d)) mfix -> All (Q 0) (fix_subst mfix). +Lemma Qfix_subst {etfl : ETermFlags} mfix Q : has_tFix -> Qfix Q -> Qpres Q -> forall idx, idx < #|mfix| -> Q 0 (tFix mfix idx) -> All (Q 0) (fix_subst mfix). Proof. - intros hasfix qfix; unfold fix_subst. + intros hasfix qfix qpre; unfold fix_subst. generalize (Nat.le_refl #|mfix|). generalize #|mfix| at 1 4. induction n. intros. constructor; auto. - intros. constructor. eapply qfix => //. eapply IHn. lia. exact X. + intros. constructor. eapply qfix => //. 2:tea. tea. + eapply IHn. lia. 2:tea. assumption. Qed. -Lemma Qcofix_subst {etfl : ETermFlags} mfix Q : has_tCoFix -> Qcofix Q -> All (λ d : def term, Q (#|mfix| + 0) (dbody d)) mfix -> All (Q 0) (cofix_subst mfix). +Lemma Qcofix_subst {etfl : ETermFlags} mfix Q : has_tCoFix -> Qcofix Q -> Qpres Q -> forall idx, idx < #|mfix| -> Q 0 (tCoFix mfix idx) -> All (Q 0) (cofix_subst mfix). Proof. - intros hasfix qfix; unfold cofix_subst. + intros hascofix qcofix qpre; unfold cofix_subst. generalize (Nat.le_refl #|mfix|). generalize #|mfix| at 1 4. induction n. intros. constructor; auto. - intros. constructor. eapply qfix => //. eapply IHn. lia. exact X. + intros. constructor. eapply qcofix => //. 2:tea. tea. + eapply IHn. lia. 2:tea. assumption. Qed. #[export] Instance Qsubst_Qfixs {etfl : ETermFlags} Q : Qpres Q -> Qfix Q -> Qsubst Q -> Qfixs Q. @@ -97,29 +100,29 @@ Proof. assert (hasfix : has_tFix). { eapply qpres in hfix. now depelim hfix. } rewrite /cunfold_fix. - eapply qpres in hfix. depelim hfix => //. destruct nth_error eqn:hnth => //. - eapply nth_error_all in hnth; tea. cbn in hnth. - rewrite Nat.add_0_r in hnth. + pose proof (nth_error_Some_length hnth). + epose proof (Qfix_subst _ _ hasfix qfix qpres idx H hfix). intros [= <-]. subst fn. eapply Hs. rewrite fix_subst_length //. - now apply Qfix_subst. + eapply qpres in hfix. depelim hfix. depelim i0. eapply nth_error_all in a; tea. now rewrite Nat.add_0_r in a. + assumption. Qed. #[export] Instance Qsubst_Qcofixs {etfl : ETermFlags} Q : Qpres Q -> Qcofix Q -> Qsubst Q -> Qcofixs Q. Proof. - move=> qpres qfix; rewrite /Qsubst /Qcofixs. + move=> qpres qfix; rewrite /Qsubst /Qfixs. intros Hs mfix idx hfix args fn. - assert (hastcofix : has_tCoFix). + assert (hasfix : has_tCoFix). { eapply qpres in hfix. now depelim hfix. } rewrite /cunfold_cofix. - eapply qpres in hfix. depelim hfix => //. destruct nth_error eqn:hnth => //. - eapply nth_error_all in hnth; tea. cbn in hnth. - rewrite Nat.add_0_r in hnth. + pose proof (nth_error_Some_length hnth). + epose proof (Qcofix_subst _ _ hasfix qfix qpres idx H hfix). intros [= <-]. subst fn. eapply Hs. rewrite cofix_subst_length //. - now apply Qcofix_subst. + eapply qpres in hfix. depelim hfix. depelim i0. eapply nth_error_all in a; tea. now rewrite Nat.add_0_r in a. + assumption. Qed. Class Qconst Σ (Q : nat -> term -> Type) := qconst : @@ -130,6 +133,7 @@ Class Qconst Σ (Q : nat -> term -> Type) := qconst : end. #[export] Hint Mode Qconst - ! : typeclass_instances. +Set Warnings "-future-coercion-class-field". Class Qpreserves {etfl : ETermFlags} (Q : nat -> term -> Type) Σ := { qpres_qpres :> Qpres Q; qpres_qcons :> Qconst Σ Q; @@ -139,9 +143,10 @@ Class Qpreserves {etfl : ETermFlags} (Q : nat -> term -> Type) Σ := qpres_qsubst :> Qsubst Q; qpres_qfix :> Qfix Q; qpres_qcofix :> Qcofix Q }. +Set Warnings "+future-coercion-class-field". Lemma eval_preserve_mkApps_ind : -∀ (wfl : WcbvFlags) {efl : EEnvFlags} (Σ : global_declarations) +∀ (wfl : WcbvFlags), with_constructor_as_block = false -> forall {efl : EEnvFlags} (Σ : global_declarations) (P' : term → term → Type) (Q : nat -> term -> Type) {Qpres : Qpreserves Q Σ} @@ -175,8 +180,8 @@ Lemma eval_preserve_mkApps_ind : (list name × term)) (br : list name × term) (res : term), forallb (λ x : list name × term, isEtaExp Σ x.2) brs -> - eval Σ discr (mkApps (tConstruct ind c) args) - → P discr (mkApps (tConstruct ind c) args) + eval Σ discr (mkApps (tConstruct ind c []) args) + → P discr (mkApps (tConstruct ind c []) args) → constructor_isprop_pars_decl Σ ind c = Some (false, pars, cdecl) → nth_error brs c = Some br → #|args| = pars + cdecl.(cstr_nargs) @@ -280,8 +285,8 @@ Lemma eval_preserve_mkApps_ind : → (∀ p cdecl (discr : term) (args : list term) a (res : term), has_tProj -> eval Σ discr - (mkApps (tConstruct p.(proj_ind) 0) args) - → P discr (mkApps (tConstruct p.(proj_ind) 0) args) + (mkApps (tConstruct p.(proj_ind) 0 []) args) + → P discr (mkApps (tConstruct p.(proj_ind) 0 []) args) → constructor_isprop_pars_decl Σ p.(proj_ind) 0 = Some (false, p.(proj_npars), cdecl) → #|args| = p.(proj_npars) + cdecl.(cstr_nargs) -> nth_error args (p.(proj_npars) + p.(proj_arg)) = Some a @@ -299,7 +304,8 @@ Lemma eval_preserve_mkApps_ind : forall (ev : eval Σ f11 f'), P f11 f' -> (forall t u (ev' : eval Σ t u), eval_depth ev' <= eval_depth ev -> Q 0 t -> isEtaExp Σ t -> P t u) → - ~~ (isLambda f' || (if with_guarded_fix then isFixApp f' else isFix f') || isBox f' || isConstructApp f') → + ~~ (isLambda f' || (if with_guarded_fix then isFixApp f' else isFix f') || isBox f' || isConstructApp f' || + isPrimApp f') → eval Σ a a' → P a a' → isEtaExp Σ (tApp f' a') -> P' (tApp f11 a) (tApp f' a')) → @@ -308,15 +314,15 @@ Lemma eval_preserve_mkApps_ind : #|args| = cstr_arity mdecl cdecl -> All2 (eval Σ) args args' -> isEtaExp_app Σ ind i #|args| -> - Q 0 (mkApps (tConstruct ind i) args) -> - Q 0 (mkApps (tConstruct ind i) args') -> + Q 0 (mkApps (tConstruct ind i []) args) -> + Q 0 (mkApps (tConstruct ind i []) args') -> All2 P args args' -> - P' (mkApps (tConstruct ind i) args) (mkApps (tConstruct ind i) args')) → + P' (mkApps (tConstruct ind i []) args) (mkApps (tConstruct ind i []) args')) → - (∀ t : term, atom t → Q 0 t -> isEtaExp Σ t -> P' t t) -> + (∀ t : term, atom Σ t → Q 0 t -> isEtaExp Σ t -> P' t t) -> ∀ (t t0 : term), Q 0 t -> isEtaExp Σ t -> eval Σ t t0 → P' t t0. Proof. - intros * Qpres P P'Q etaΣ wfΣ hasapp. + intros wfl hcon. intros * Qpres P P'Q etaΣ wfΣ hasapp. assert (qfixs: Qfixs Q) by tc. assert (qcofixs: Qcofixs Q) by tc. intros. @@ -362,22 +368,22 @@ Proof. eapply H; tea; (apply and_assum; [ih|hp' P'Q]) end. destruct ev. - 1-15:eapply qpres in qt as qt'; depelim qt' => //. + 1-18:eapply qpres in qt as qt'; depelim qt' => //. - move/isEtaExp_tApp. destruct decompose_app as [hd args] eqn:da. destruct (construct_viewc hd) eqn:cv. - * move=> [] argsn [] ha [] ht /andP[] etaind etaargs. + * move=> [] argsn [] ha [] ht /andP[] /andP[] etaind etaargs bargs. destruct block_args; inv bargs. clear IH; rewrite ha in ev1. elimtype False. - eapply eval_mkApps_Construct_inv in ev1 as [ex []]. solve_discr. + eapply eval_mkApps_Construct_inv in ev1 as [ex []]. solve_discr. auto. * move=> /and4P [] etat0 etaargs etaa etat. split. eapply X; tea; (apply and_assum; [ih|hp' P'Q]). iheta q. - move/isEtaExp_tApp. destruct decompose_app as [hd args] eqn:da. destruct (construct_viewc hd) eqn:cv. - * move=> [] argsn [] ha [] ht /andP[] etaind etaargs. + * move=> [] argsn [] ha [] ht /andP[] /andP[] etaind etaargs bargs. destruct block_args; inv bargs. clear IH; rewrite ha in ev1. elimtype False. - eapply eval_mkApps_Construct_inv in ev1 as [ex []]. solve_discr. + eapply eval_mkApps_Construct_inv in ev1 as [ex []]. solve_discr. auto. * move=> /and4P [] etat0 etaargs etaa etat. assert (ql : Q 0 (tLambda na b)). { eapply P'Q; tea. ih. } @@ -404,25 +410,26 @@ Proof. - simp_eta. move=> /andP[etad etabrs]. assert (isEtaExp Σ (iota_red pars args br)). { eapply isEtaExp_iota_red. - assert (isEtaExp Σ (mkApps (tConstruct ind c) args)) by iheta q. - rewrite isEtaExp_mkApps_napp /= // in H. + assert (isEtaExp Σ (mkApps (tConstruct ind c []) args)) by iheta q. + rewrite isEtaExp_mkApps_napp /= // in H. rewrite andb_true_r in H. now move/andP: H => []. - now clear IH; eapply nth_error_forallb in e0; tea. } + now clear IH; eapply nth_error_forallb in e1; tea. } assert (Q 0 (iota_red pars args br)). { unfold iota_red. eapply nth_error_all in a; tea. cbn in a. - rewrite -e2 in a. + rewrite -e3 in a. rewrite -(List.rev_length (skipn pars args)) in a. rewrite Nat.add_0_r in a. eapply (qsubst _ (List.rev (skipn pars args))) in a. 2:{ eapply All_rev, All_skipn. - assert (Q 0 (mkApps (tConstruct ind c) args)). + assert (Q 0 (mkApps (tConstruct ind c []) args)). eapply P'Q; tea; ih. eapply qapp in X13; tea. eapply X13. } exact a. } split. eapply X2; tea. 1,3:(apply and_assum; [ih|hp' P'Q]). eapply nth_error_all in a; tea; cbn. now rewrite Nat.add_0_r in a. iheta X13. + - congruence. - simp_eta; move=> /andP[etad etabrs]. assert (isEtaExp Σ (substl (repeat tBox #|n|) f)). { eapply isEtaExp_substl => //. rewrite forallb_repeat //. @@ -438,9 +445,9 @@ Proof. - move/isEtaExp_tApp. destruct decompose_app as [hd args] eqn:da. destruct (construct_viewc hd) eqn:cv. - * move=> [] argsn [] ha [] ht /andP[] etaind etaargs. + * move=> [] argsn [] ha [] ht /andP[] /andP[] etaind etaargs bargs. destruct block_args; inv bargs. clear IH; rewrite ha in ev1. elimtype False. - eapply eval_mkApps_Construct_inv in ev1 as [ex []]. solve_discr. + eapply eval_mkApps_Construct_inv in ev1 as [ex []]. solve_discr. auto. * move=> /and4P [] etat0 etaargs etaa etat. pose proof (ev1' := ev1). eapply P'Q in ev1' => //. 2:{ clear ev1'; ih. } eapply qapp in ev1' as [hfix qargs] => //. @@ -472,9 +479,9 @@ Proof. - move/isEtaExp_tApp. destruct decompose_app as [hd args] eqn:da. destruct (construct_viewc hd) eqn:cv. - * move=> [] argsn [] ha [] ht /andP[] etaind etaargs. + * move=> [] argsn [] ha [] ht /andP[] /andP[] etaind etaargs bargs. destruct block_args; inv bargs. clear IH; rewrite ha in ev1. elimtype False. - eapply eval_mkApps_Construct_inv in ev1 as [ex []]. solve_discr. + eapply eval_mkApps_Construct_inv in ev1 as [ex []]. solve_discr. auto. * move=> /and4P [] etat0 etaargs etaa etat. assert (isEtaExp Σ (tApp (mkApps (tFix mfix idx) argsv) av)). { rewrite -[tApp _ _](mkApps_app _ _ [av]). @@ -488,9 +495,9 @@ Proof. - move/isEtaExp_tApp. destruct decompose_app as [hd args] eqn:da. destruct (construct_viewc hd) eqn:cv. - * move=> [] argsn [] ha [] ht /andP[] etaind etaargs. + * move=> [] argsn [] ha [] ht /andP[] /andP[] etaind etaargs bargs. destruct block_args; inv bargs. clear IH; rewrite ha in ev1. elimtype False. - eapply eval_mkApps_Construct_inv in ev1 as [ex []]. solve_discr. + eapply eval_mkApps_Construct_inv in ev1 as [ex []]. solve_discr. auto. * move=> /and4P [] etat0 etaargs etaa etat. assert (qav : Q 0 av). { eapply P'Q; tea; ih. } @@ -513,11 +520,9 @@ Proof. iheta qa. - simp_eta. move=> /andP[etad etabrs]. assert (qa : Q 0 (tCase ip (mkApps fn args) brs)). - { pose proof (ev1' := ev1). eapply P'Q in ev1' => //. + { eapply qcase; tea => //. + pose proof (ev1' := ev1). eapply P'Q in ev1' => //. eapply qapp in ev1' as [hfix qargs] => //. - unshelve eapply (qcase _ _ _ _ _ _).2 => //. - { now eapply qpres in hfix; depelim hfix. } auto. - split => //. eapply qapp => //. split => //. eapply (qcofixs mfix idx) in hfix; tea. clear ev1'; ih. } @@ -539,7 +544,7 @@ Proof. assert (qa : Q 0 (tProj p (mkApps fn args))). { pose proof (ev1' := ev1). eapply P'Q in ev1' => //. eapply qapp in ev1' as [hfix ?] => //. - eapply qproj => //. eapply qapp => //. split => //. + eapply qproj; tea => //. eapply qapp => //. split => //. eapply (qcofixs mfix idx) in hfix; tea. clear ev1'; ih. } assert (etafn : isEtaExp Σ fn && forallb (isEtaExp Σ) args). @@ -571,13 +576,14 @@ Proof. { eapply nth_error_all in qargs; tea. } clear ev1'; ih. } assert (isEtaExp Σ a). - { assert (isEtaExp Σ (mkApps (tConstruct p.(proj_ind) 0) args)) by iheta q. + { assert (isEtaExp Σ (mkApps (tConstruct p.(proj_ind) 0 []) args)) by iheta q. move: H; simp_eta. rewrite isEtaExp_mkApps_napp // /=. - move=> /andP[] etaapp etaargs. - eapply nth_error_forallb in etaargs; tea. } + move=> /andP[] /andP[] etaapp etaargs. + eapply nth_error_forallb in etaargs; tea. eauto. } split. eapply X10; tea; (apply and_assum; [ih|hp' P'Q]). iheta X13. + - congruence. - simp_eta => etadiscr. split. unshelve eapply X11; tea; try (intros; apply and_assum; [ih|hp' P'Q]). now idtac. @@ -585,11 +591,11 @@ Proof. rename args into cargs. destruct decompose_app as [hd args] eqn:da. destruct (construct_viewc hd) eqn:cv. - * move=> [] argsn [] ha [] ht /andP[] etaind etaargs. + * move=> [] argsn [] ha [] ht /andP[] /andP[] etaind etaargs bargs. destruct block_args; inv bargs. assert (eval_depth ev1 = eval_depth ev1) by reflexivity. set (ev1' := ev1). change ev1 with ev1' in H at 1. clearbody ev1'. move: H. subst f. - pose proof (eval_construct_size ev1') as [ex []]. + pose proof (eval_construct_size hcon ev1') as [ex []]. cbn in IH. intros eq. assert (All2 (λ x y : term, ∑ ev' : eval Σ x y, eval_depth ev' < S (Nat.max (eval_depth ev1) (eval_depth ev2))) (remove_last args ++ [a]) (ex ++ [a'])). @@ -613,12 +619,12 @@ Proof. eapply All2_All_mix_left in X15. 2:exact X14. eapply All2_All_right; tea; cbn. intros ? ? [? [? [? []]]]. split. eapply P'Q; tea. apply p. apply p. } - eapply mkApps_eq_inj in e0 as [] => //. subst ex. noconf H. + eapply mkApps_eq_inj in e1 as [] => //. subst ex. noconf H. split. unshelve eapply Xcappexp; tea. + rewrite ht -remove_last_last //. move: etaind; rewrite /isEtaExp_app. - rewrite (lookup_constructor_pars_args_cstr_arity _ _ _ _ _ _ e). + rewrite (lookup_constructor_pars_args_cstr_arity _ _ _ _ _ _ e0). move/Nat.leb_le. move: l. rewrite /cstr_arity. eapply All2_length in X13. move: X13. rewrite ht /= -remove_last_last //. len. @@ -639,26 +645,28 @@ Proof. + rewrite isEtaExp_Constructor. apply/andP. split. rewrite -(All2_length X16). rewrite ht -remove_last_last //. - eapply All_forallb. eapply All_impl; tea. cbn; intuition auto. + rtoProp. split. eauto. + eapply All_forallb. eapply All_impl; tea. cbn; intuition auto. auto. * move=> /and4P [] etat0 etaargs etaa etat. rewrite -[tApp _ a'](mkApps_app _ _ [a']). - assert (P' f (mkApps (tConstruct ind c) cargs) × isEtaExp Σ (mkApps (tConstruct ind c) cargs)). + assert (P' f (mkApps (tConstruct ind c []) cargs) × isEtaExp Σ (mkApps (tConstruct ind c []) cargs)). { unshelve eapply IH; tea. cbn. lia. } elimtype False. destruct X13 as [p'f etac]. move: etac. rewrite isEtaExp_Constructor. move/andP => []. rewrite /isEtaExp_app. - rewrite /lookup_constructor_pars_args e /=. - move/Nat.leb_le. clear IH. move: l; rewrite /cstr_arity. lia. + rewrite /lookup_constructor_pars_args e0 /=. + move => /andP[] /Nat.leb_le. clear IH. move: l; rewrite /cstr_arity. lia. + - congruence. - move/isEtaExp_tApp. destruct decompose_app as [hd args] eqn:da. destruct (construct_viewc hd) eqn:cv. - * move=> [] argsn [] ha [] ht /andP[] etaind etaargs. + * move=> [] argsn [] ha [] ht /andP[] /andP[] etaind etaargs bargs. destruct block_args; inv bargs. assert (eval_depth ev1 = eval_depth ev1) by reflexivity. set (ev1' := ev1). change ev1 with ev1' in H at 1. clearbody ev1'. move: H. subst f. exfalso. eapply eval_mkApps_Construct_inv in ev1' as [? [hf' hargs']]. subst f'. - clear IH; move: i; rewrite !negb_or isConstructApp_mkApps /= !andb_false_r //. + clear IH; move: i; rewrite !negb_or isConstructApp_mkApps /= !andb_false_r //. auto. * move=> /and4P [] etat0 etaargs etaa etat. split. eapply (X12 _ _ _ _ ev1); tea. 1,3:(apply and_assum; [ih|hp' P'Q]). @@ -672,12 +680,66 @@ Proof. - intros ise. split => //. eapply Qatom; tea. Qed. -#[export] Instance Qpreserves_True (etfl := all_term_flags) Σ : Qpreserves (fun _ _ => True) Σ. +Definition term_flags := + {| + has_tBox := true; + has_tRel := true; + has_tVar := false; + has_tEvar := false; + has_tLambda := true; + has_tLetIn := true; + has_tApp := true; + has_tConst := true; + has_tConstruct := true; + has_tCase := true; + has_tProj := false; + has_tFix := true; + has_tCoFix := false; + has_tPrim := true + |}. + +Definition env_flags := + {| has_axioms := false; + has_cstr_params := false; + term_switches := term_flags ; + cstr_as_blocks := false + |}. + +From MetaCoq.Erasure Require Import ELiftSubst. +Lemma Qpreserves_wellformed (efl : EEnvFlags) Σ : + cstr_as_blocks = false -> + wf_glob Σ -> Qpreserves (fun n x => wellformed Σ n x) Σ. Proof. - split; intros; red; intros; try split; intuition auto. - { destruct t; try solve [constructor; auto; auto using All_True]. } - { destruct cst_body => //. } - all:apply All_True. + intros cstbl clΣ. + split. + - red. move=> n t. + destruct t; cbn [wellformed]; rtoProp; intuition auto; try solve [constructor; auto]. + all:cbn; rtoProp; intuition auto. + constructor; cbn => //. + eapply on_evar; auto. solve_all. + eapply on_lambda; auto. + eapply on_letin; rtoProp; intuition auto. + eapply on_app; rtoProp; intuition auto. + constructor; cbn; auto. rewrite cstbl in H0. + destruct l => //. constructor => //. + eapply on_case; rtoProp; intuition auto. ELiftSubst.solve_all. + eapply on_proj; auto. + eapply on_fix; eauto. move/andP: H0 => [] _ wf. solve_all. + eapply on_cofix; eauto. move/andP: H0 => [] _ wf. solve_all. + - red. intros kn decl. + move/(lookup_env_wellformed clΣ). + unfold wf_global_decl. destruct cst_body => //. + - red. move=> hasapp n t args. rewrite wellformed_mkApps //. + split; intros; rtoProp; intuition auto; solve_all. + - red. intros. simpl in H0. simpl. rtoProp; intuition auto. + - red. move=> hasproj n p discr. simpl; rtoProp; intuition auto. + rtoProp; intuition auto. + - red. move=> t args clt cll. + eapply wellformed_substl. solve_all. now rewrite Nat.add_0_r. + - red. move=> n mfix idx. cbn. unfold EWellformed.wf_fix. + intros; rtoProp; intuition auto; solve_all. now apply Nat.ltb_lt. + - red. move=> n mfix idx. cbn. unfold EWellformed.wf_fix. + intros; rtoProp; intuition auto; solve_all. now apply Nat.ltb_lt. Qed. Ltac destruct_nary_times := @@ -688,18 +750,22 @@ Ltac destruct_nary_times := | [ H : [× _, _, _, _ & _] |- _ ] => destruct H end. -Lemma eval_etaexp {fl : WcbvFlags} (efl := all_env_flags) {Σ a a'} : +Lemma eval_etaexp {fl : WcbvFlags} (efl := env_flags) {Σ a a'} : + with_constructor_as_block = false -> isEtaExp_env Σ -> wf_glob Σ -> + wellformed Σ 0 a -> eval Σ a a' -> isEtaExp Σ a -> isEtaExp Σ a'. Proof. - intros etaΣ wfΣ ev eta. - generalize I. intros q. revert a a' q eta ev. - eapply (eval_preserve_mkApps_ind (efl:=all_env_flags) fl Σ (fun _ x => isEtaExp Σ x) (fun _ _ => True) (Qpres := Qpreserves_True Σ)) => //. + intros hcon etaΣ wfΣ wf ev eta. + revert a a' wf eta ev. + eapply (eval_preserve_mkApps_ind (efl:=env_flags) fl hcon Σ (fun _ x => isEtaExp Σ x) (fun n t => wellformed Σ n t) + (Qpres := Qpreserves_wellformed env_flags Σ eq_refl wfΣ)) => //. all:intros; repeat destruct_nary_times. all:intuition auto. + - eapply eval_wellformed; tea => //. - rewrite isEtaExp_Constructor => //. - rewrite -(All2_length X0) H1. + rewrite -(All2_length X0) H1. cbn. rtoProp; intuition eauto. cbn; eapply All_forallb. eapply All2_All_right; tea. cbn. intros x y []; auto. Qed. diff --git a/erasure/theories/EWcbvEvalInd.v b/erasure/theories/EWcbvEvalInd.v index 97a600227..0680ec4b4 100644 --- a/erasure/theories/EWcbvEvalInd.v +++ b/erasure/theories/EWcbvEvalInd.v @@ -37,18 +37,36 @@ Section eval_mkApps_rect. → eval Σ (ECSubst.csubst b0' 0 b1) res → P (ECSubst.csubst b0' 0 b1) res → P (tLetIn na b0 b1) res) - → (∀ (ind : Kernames.inductive) (pars : nat) cdecl (discr : term) - (c : nat) (args : list term) (brs : list (list BasicAst.name × term)) - (br : list BasicAst.name × term) (res : term), - eval Σ discr (mkApps (tConstruct ind c) args) - → P discr (mkApps (tConstruct ind c) args) - → constructor_isprop_pars_decl Σ ind c = Some (false, pars, cdecl) - → nth_error brs c = Some br - → #|args| = pars + cdecl.(cstr_nargs) - → #|skipn pars args| = #|br.1| - → eval Σ (iota_red pars args br) res - → P (iota_red pars args br) res - → P (tCase (ind, pars) discr brs) res) + → (∀ (ind : inductive) (pars : nat) (cdecl : constructor_body) + (discr : term) (c : nat) (args : list term) + (brs : list (list name × term)) (br : list name × term) + (res : term) (e : with_constructor_as_block = false) + (e0 : eval Σ discr (mkApps (tConstruct ind c []) args)), + P discr (mkApps (tConstruct ind c []) args) + → ∀ (e1 : constructor_isprop_pars_decl Σ ind c = + Some (false, pars, cdecl)) (e2 : + nth_error brs c = + Some br) + (e3 : #|args| = pars + cstr_nargs cdecl) + (e4 : #|skipn pars args| = #|br.1|) + (e5 : eval Σ (iota_red pars args br) res), + P (iota_red pars args br) res + → P (tCase (ind, pars) discr brs) res) + → (∀ (ind : inductive) (pars : nat) (cdecl : constructor_body) + (discr : term) (c : nat) (args : list term) + (brs : list (list name × term)) (br : list name × term) + (res : term) (e : with_constructor_as_block = true) + (e0 : eval Σ discr (tConstruct ind c args)), + P discr (tConstruct ind c args) + → ∀ (e1 : constructor_isprop_pars_decl Σ ind c = + Some (false, pars, cdecl)) + (e2 : nth_error brs c = Some br) + (e3 : #|args| = pars + cstr_nargs cdecl) + (e4 : #|skipn pars args| = #|br.1|) + (e5 : eval Σ (iota_red pars args br) res), + P (iota_red pars args br) res + → P (tCase (ind, pars) discr brs) res) + → (∀ (ind : Kernames.inductive) (pars : nat) (discr : term) (brs : list (list BasicAst.name × term)) (n : list BasicAst.name) (f3 res : term), @@ -60,6 +78,7 @@ Section eval_mkApps_rect. → eval Σ (ECSubst.substl (repeat tBox #|n|) f3) res → P (ECSubst.substl (repeat tBox #|n|) f3) res → P (tCase (ind, pars) discr brs) res) + → (∀ (f4 : term) (mfix : mfixpoint term) (idx : nat) (argsv : list term) (a av fn res : term), @@ -121,16 +140,47 @@ Section eval_mkApps_rect. cst_body decl = Some body → eval Σ body res → P body res → P (tConst c) res) - → (∀ p (discr : term) (args : list term) - (res : term) cdecl a, - eval Σ discr (mkApps (tConstruct p.(proj_ind) 0) args) - → P discr (mkApps (tConstruct p.(proj_ind) 0) args) - → constructor_isprop_pars_decl Σ p.(proj_ind) 0 = Some (false, p.(proj_npars), cdecl) - → #|args| = p.(proj_npars) + cdecl.(cstr_nargs) - -> nth_error args (p.(proj_npars) + p.(proj_arg)) = Some a - -> eval Σ a res - → P a res - → P (tProj p discr) res) + + → (∀ (p : projection) (cdecl : constructor_body) + (discr : term) (args : list term) + (a res : term) (e : with_constructor_as_block = + false) + (e0 : eval Σ discr + (mkApps + (tConstruct + (proj_ind p) 0 []) args)), + P discr + (mkApps + (tConstruct (proj_ind p) 0 []) + args) + → ∀ (e1 : constructor_isprop_pars_decl Σ + (proj_ind p) 0 = + Some (false, proj_npars p, cdecl)) + (e2 : #|args| = + proj_npars p + cstr_nargs cdecl) + (e3 : nth_error args + (proj_npars p + proj_arg p) = + Some a) (e4 : eval Σ a res), + P a res + → P (tProj p discr) res) + → (∀ (p : projection) (cdecl : constructor_body) + (discr : term) (args : list term) + (a res : term) (e : + with_constructor_as_block = + true) + (e0 : eval Σ discr + (tConstruct (proj_ind p) 0 args)), + P discr (tConstruct (proj_ind p) 0 args) + → ∀ (e1 : constructor_isprop_pars_decl Σ + (proj_ind p) 0 = + Some (false, proj_npars p, cdecl)) + (e2 : #|args| = + proj_npars p + cstr_nargs cdecl) + (e3 : nth_error args + (proj_npars p + proj_arg p) = + Some a) (e4 : eval Σ a res), + P a res + → P (tProj p discr) res) → (∀ p (discr : term), with_prop_case @@ -139,30 +189,64 @@ Section eval_mkApps_rect. → inductive_isprop_and_pars Σ p.(proj_ind) = Some (true, p.(proj_npars)) → P (tProj p discr) tBox) - → (∀ ind c mdecl idecl cdecl f args a a', - lookup_constructor Σ ind c = Some (mdecl, idecl, cdecl) -> - forall (ev : eval Σ f (mkApps (tConstruct ind c) args)), - IH _ _ ev -> + → (∀ (ind : inductive) + (c : nat) (mdecl : mutual_inductive_body) + (idecl : one_inductive_body) + (cdecl : constructor_body) + (f14 : term) (args : list term) + (a a' : term) + (e : with_constructor_as_block = false) + (e0 : lookup_constructor Σ ind c = + Some (mdecl, idecl, cdecl)) + (e1 : eval Σ f14 + (mkApps + (tConstruct ind c []) + args)), + IH _ _ e1 -> + P f14 + (mkApps (tConstruct ind c []) + args) + → ∀ (l : #|args| < cstr_arity mdecl cdecl) + (e2 : eval Σ a a'), + P a a' + → P (tApp f14 a) + (tApp + (mkApps + (tConstruct ind c + []) args) a')) - P f (mkApps (tConstruct ind c) args) -> - #|args| < cstr_arity mdecl cdecl -> - eval Σ a a' -> - P a a' -> - P (tApp f a) (tApp (mkApps (tConstruct ind c) args) a')) + → (∀ (ind : inductive) + (c : nat) (mdecl : mutual_inductive_body) + (idecl : one_inductive_body) + (cdecl : constructor_body) + (args args' : list term) + (e : with_constructor_as_block = true) + (e0 : lookup_constructor Σ ind c = + Some (mdecl, idecl, cdecl)) + (l : #|args| = cstr_arity mdecl cdecl) + (e1 : All2 (eval Σ) args args'), + All2 P args args' + → P (tConstruct ind c args) (tConstruct ind c args')) - → (∀ (f11 f' : term) a a' , - forall (ev : eval Σ f11 f'), - P f11 f' -> - IH _ _ ev - → ~~ (isLambda f' || (if with_guarded_fix then isFixApp f' else isFix f') || isBox f' - || isConstructApp f') - → eval Σ a a' - → P a a' - → P (tApp f11 a) (tApp f' a')) - → (∀ t : term, atom t → P t t) + → (∀ (f15 f' a a' : term) (e : eval Σ f15 f'), + P f15 f' -> IH _ _ e + → ∀ (i : ~~ + (isLambda f' + || + (if with_guarded_fix + then isFixApp f' + else isFix f') || + isBox f' || + isConstructApp f' || isPrimApp f')) + (e0 : eval Σ a a'), + P a a' + → P (tApp f15 a) + (tApp f' a') + ) + → (∀ t : term, atom Σ t → P t t) → ∀ t t0 : term, eval Σ t t0 → P t t0. Proof using Type. - intros ?????????????????? H. + intros ????????????????????? H. pose proof (p := @Fix_F { t : _ & { t0 : _ & eval Σ t t0 }}). specialize (p (MR lt (fun x => eval_depth x.π2.π2))). set(foo := existT _ t (existT _ t0 H) : { t : _ & { t0 : _ & eval Σ t t0 }}). @@ -190,7 +274,10 @@ Proof using Type. | [ H : _ |- _ ] => unshelve eapply H; try match goal with |- eval _ _ _ => tea end; tea; unfold IH; intros; unshelve eapply IH'; tea; cbn; try lia end]. + - eapply X15; tea; auto. + clear -a IH'. induction a; constructor. + eapply (IH' _ _ r). cbn. lia. apply IHa. + intros. eapply (IH' _ _ H). cbn. lia. Qed. End eval_mkApps_rect. - diff --git a/erasure/theories/EWellformed.v b/erasure/theories/EWellformed.v index 27828e501..c1e2d74d9 100644 --- a/erasure/theories/EWellformed.v +++ b/erasure/theories/EWellformed.v @@ -33,13 +33,18 @@ Class ETermFlags := ; has_tProj : bool ; has_tFix : bool ; has_tCoFix : bool + ; has_tPrim : bool }. +Set Warnings "-future-coercion-class-field". Class EEnvFlags := { has_axioms : bool; has_cstr_params : bool; - term_switches :> ETermFlags }. - + term_switches :> ETermFlags ; + cstr_as_blocks : bool ; + }. +Set Warnings "+future-coercion-class-field". + Definition all_term_flags := {| has_tBox := true ; has_tRel := true @@ -54,12 +59,20 @@ Definition all_term_flags := ; has_tProj := true ; has_tFix := true ; has_tCoFix := true + ; has_tPrim := true |}. Definition all_env_flags := {| has_axioms := true; term_switches := all_term_flags; - has_cstr_params := true |}. + has_cstr_params := true ; + cstr_as_blocks := false |}. + +Definition all_env_flags_blocks := + {| has_axioms := true; + term_switches := all_term_flags; + has_cstr_params := true ; + cstr_as_blocks := true |}. Section wf. @@ -76,6 +89,8 @@ Section wf. Definition wf_fix_gen (wf : nat -> term -> bool) k mfix idx := let k' := List.length mfix + k in (idx true | _ => false end. Fixpoint wellformed k (t : term) : bool := match t with @@ -88,7 +103,7 @@ Section wf. let brs' := List.forallb (fun br => wellformed (#|br.1| + k) br.2) brs in isSome (lookup_inductive Σ ind.1) && wellformed k c && brs' | tProj p c => has_tProj && isSome (lookup_projection Σ p) && wellformed k c - | tFix mfix idx => has_tFix && wf_fix_gen wellformed k mfix idx + | tFix mfix idx => has_tFix && List.forallb (isLambda ∘ dbody) mfix && wf_fix_gen wellformed k mfix idx | tCoFix mfix idx => has_tCoFix && wf_fix_gen wellformed k mfix idx | tBox => has_tBox | tConst kn => has_tConst && @@ -96,8 +111,13 @@ Section wf. | Some d => has_axioms || isSome d.(cst_body) | _ => false end - | tConstruct ind c => has_tConstruct && isSome (lookup_constructor Σ ind c) + | tConstruct ind c block_args => has_tConstruct && isSome (lookup_constructor Σ ind c) && + if cstr_as_blocks then match lookup_constructor_pars_args Σ ind c with + | Some (p, a) => (p + a) == #|block_args| + | _ => true end + && forallb (wellformed k) block_args else is_nil block_args | tVar _ => has_tVar + | tPrim _ => has_tPrim end. End wf. @@ -158,7 +178,9 @@ Section EEnvFlags. autorewrite with map; simpl wellformed in *; intuition auto; unfold wf_fix, test_def, test_snd in *; - try solve [simpl lift; simpl closed; f_equal; auto; repeat (rtoProp; simpl in *; solve_all)]; try easy. + try solve [simpl lift; simpl closed; f_equal; auto; repeat (rtoProp; simpl in *; solve_all)]; try easy. + destruct cstr_as_blocks. 2: destruct args; eauto; solve_all. + rtoProp. solve_all. Qed. Lemma wellformed_closed_decl {t} : wf_global_decl Σ t -> closed_decl t. @@ -176,7 +198,9 @@ Section EEnvFlags. simpl wellformed in *; intuition auto; unfold wf_fix, test_def, test_snd in *; try solve [simpl lift; simpl closed; f_equal; auto; repeat (rtoProp; simpl in *; solve_all)]; try easy. - eapply Nat.ltb_lt. now eapply Nat.ltb_lt in H2. + - eapply Nat.ltb_lt. now eapply Nat.ltb_lt in H2. + - destruct cstr_as_blocks; eauto. solve_all. + destruct lookup_constructor_pars_args as [ [] |]; rtoProp; repeat solve_all. Qed. Lemma wellformed_lift n k k' t : wellformed k t -> wellformed (k + n) (lift n k' t). @@ -193,6 +217,8 @@ Section EEnvFlags. elim (Nat.ltb_spec); auto. apply Nat.ltb_lt in H1. lia. simpl; rewrite H0 /=. elim (Nat.ltb_spec); auto. intros. apply Nat.ltb_lt in H1. lia. + - destruct cstr_as_blocks; eauto. destruct lookup_constructor_pars_args as [ [] | ]; rtoProp; repeat solve_all. + destruct args; firstorder. - solve_all. rewrite Nat.add_assoc. eauto. - len. move/andP: H1 => [] -> ha. cbn. solve_all. rewrite Nat.add_assoc; eauto. @@ -231,13 +257,16 @@ Section EEnvFlags. - specialize (IHt2 (S k')). rewrite <- Nat.add_succ_comm in IHt2. eapply IHt2; auto. + - destruct cstr_as_blocks; eauto. + destruct lookup_constructor_pars_args as [ [] | ]; rtoProp; repeat solve_all. now destruct args; inv H0. - specialize (a (#|x.1| + k')) => //. rewrite Nat.add_assoc (Nat.add_comm k) in a. rewrite !Nat.add_assoc. eapply a => //. now rewrite !Nat.add_assoc in b. + - destruct (dbody x) => //. - intros. now len. - specialize (a (#|m| + k')). - len. now rewrite !Nat.add_assoc !(Nat.add_comm k) in a, b |- *. + len. now rewrite !Nat.add_assoc !(Nat.add_comm k) in a, b0 |- *. - intros. now len. - specialize (a (#|m| + k')); len. now rewrite !Nat.add_assoc !(Nat.add_comm k) in a, b |- *. @@ -277,14 +306,16 @@ Section EEnvFlags. Qed. Lemma wellformed_fix_subst mfix {hast : has_tFix}: + forallb (isLambda ∘ dbody) mfix -> forallb (EAst.test_def (wellformed (#|mfix| + 0))) mfix -> forallb (wellformed 0) (fix_subst mfix). Proof using Type. - intros hm. unfold fix_subst. - generalize (le_refl #|mfix|). + intros hm hm'. unfold fix_subst. + generalize (Nat.le_refl #|mfix|). move: {1 3}#|mfix| => n. induction n => //. - intros hn. cbn. rewrite hast /=. rewrite /wf_fix_gen hm /= andb_true_r. + intros hn. cbn. rewrite hast /=. rewrite /wf_fix_gen hm' /= andb_true_r. + rewrite hm. cbn. apply/andP; split. apply Nat.ltb_lt. lia. apply IHn. lia. Qed. @@ -293,7 +324,7 @@ Section EEnvFlags. forallb (wellformed 0) (cofix_subst mfix). Proof using Type. intros hm. unfold cofix_subst. - generalize (le_refl #|mfix|). + generalize (Nat.le_refl #|mfix|). move: {1 3}#|mfix| => n. induction n => //. intros hn. cbn. rewrite hasco /=. rewrite /wf_fix_gen hm /= andb_true_r. @@ -308,7 +339,7 @@ Section EEnvFlags. move=> cl. rewrite /cunfold_fix. destruct nth_error eqn:heq => //. - cbn in cl. move/andP: cl => [hastf /andP[] hidx cl]. + cbn in cl. move/andP: cl => [/andP[] hastf isfix /andP[] hidx cl]. have := (nth_error_forallb heq cl) => cld. move=> [=] _ <-. eapply wellformed_substl => //. now eapply wellformed_fix_subst. @@ -435,6 +466,8 @@ Proof. induction t using EInduction.term_forall_list_ind; cbn => //; intros; rtoProp; intuition auto; solve_all. all:try destruct lookup_env eqn:hl => //; try rewrite (extends_lookup wf ex hl). all:try destruct g => //. + - destruct cstr_as_blocks; eauto; solve_all. + destruct lookup_constructor_pars_args as [ [] | ]; rtoProp; repeat solve_all. - move/andP: H0 => [] hn hf. unfold wf_fix. rewrite hn /=. solve_all. - move/andP: H0 => [] hn hf. unfold wf_fix. rewrite hn /=. solve_all. Qed. diff --git a/erasure/theories/EWndEval.v b/erasure/theories/EWndEval.v deleted file mode 100644 index ce6779e55..000000000 --- a/erasure/theories/EWndEval.v +++ /dev/null @@ -1,67 +0,0 @@ -(* Distributed under the terms of the MIT license. *) -From MetaCoq.Erasure Require Import EAst ELiftSubst EGlobalEnv. - -(** * 1-step non-deterministic weak reduction **) - - -Section Wnd. - Context (Σ : global_declarations). - (* The local context is fixed: we are only doing weak reductions *) - -Inductive Wnd : term -> term -> Prop := - (*** contraction steps ***) -(** Constant unfolding *) -| wConst c decl body (isdecl: declared_constant Σ c decl): - decl.(cst_body) = Some body -> Wnd (tConst c) body -(** Beta *) -| wBeta na a b: Wnd (tApp (tLambda na b) a) (subst10 a b) -(** Let *) -| wLet na b0 b1: Wnd (tLetIn na b0 b1) (subst10 b0 b1). - - - -End Wnd. - -(******************************** -| sConst: forall (s:string) (t:Term), - LookupDfn s p t -> wndEval (TConst s) t -| sBeta: forall (nm:name) (bod arg:Term), - wndEval (TApp (TLambda nm bod) arg) (whBetaStep bod arg) -(* note: [instantiate] is total *) -| sLetIn: forall (nm:name) (dfn bod:Term), - wndEval (TLetIn nm dfn bod) (instantiate dfn 0 bod) -(* Case argument must be in Canonical form *) -(* n is the number of parameters of the datatype *) -| sCase: forall (ml:inductive * nat) (s mch:Term) - (args ts:Terms) (brs:Brs) (n npars nargs:nat), - canonicalP mch = Some (n, npars, nargs, args) -> - tskipn (snd ml) args = Some ts -> - whCaseStep n ts brs = Some s -> - wndEval (TCase ml mch brs) s -| sFix: forall (dts:Defs) (m:nat) (arg:Term) (x:Term) (ix:nat), - (** ix is index of recursive argument **) - dnthBody m dts = Some (x, ix) -> - wndEval (TApp (TFix dts m) arg) (pre_whFixStep x dts arg) -| sProofApp arg: wndEval (TApp TProof arg) TProof -| sProj: forall bod r npars nargs args arg x ind, - canonicalP bod = Some (r, npars, nargs, args) -> - List.nth_error args (npars + arg) = Some x -> - wndEval (TProj (ind, npars, arg) bod) x -(*** congruence steps ***) -(** no xi rules: sLambdaR, sLetInR, - *** no congruence on Case branches ***) -| sAppFn: forall (t r arg:Term), - wndEval t r -> wndEval (TApp t arg) (TApp r arg) -| sAppArg: forall (t arg brg:Term), - wndEval arg brg -> wndEval (TApp t arg) (TApp t brg) -| sLetInDef:forall (nm:name) (d1 d2 bod:Term), - wndEval d1 d2 -> wndEval (TLetIn nm d1 bod) (TLetIn nm d2 bod) -| sCaseArg: forall (nl:inductive * nat) (mch can:Term) (brs:Brs), - wndEval mch can -> wndEval (TCase nl mch brs) (TCase nl can brs) -| sProjBod: forall prj bod Bod, - wndEval bod Bod -> wndEval (TProj prj bod) (TProj prj Bod). -#[global] -Hint Constructors wndEval. - - -**********************) diff --git a/erasure/theories/Erasure.v b/erasure/theories/Erasure.v index 11ff060f7..83c149053 100644 --- a/erasure/theories/Erasure.v +++ b/erasure/theories/Erasure.v @@ -1,13 +1,12 @@ (* Distributed under the terms of the MIT license. *) From Coq Require Import Program ssreflect ssrbool. -From MetaCoq.Template Require Import Transform bytestring config utils. +From MetaCoq.Template Require Import Transform bytestring config utils EtaExpand TemplateProgram. From MetaCoq.PCUIC Require PCUICAst PCUICAstUtils PCUICProgram. From MetaCoq.SafeChecker Require Import PCUICErrors PCUICWfEnvImpl. From MetaCoq.Erasure Require EAstUtils ErasureFunction ErasureCorrectness EPretty Extract. From MetaCoq.Erasure Require Import ETransform. Import PCUICProgram. -Import TemplateProgram (template_eta_expand). Import PCUICTransform (template_to_pcuic_transform, pcuic_expand_lets_transform). Import bytestring. @@ -27,13 +26,40 @@ Obligation Tactic := program_simpl. Import EWcbvEval. +Axiom assume_welltyped_template_program_expansion : + forall p (wtp : ∥ wt_template_program_env p ∥), + let p' := EtaExpand.eta_expand_program p in + ∥ wt_template_program p' ∥ /\ EtaExpand.expanded_program p'. + +Axiom assume_preservation_template_program_env_expansion : + forall p (wtp : ∥ wt_template_program_env p ∥) v, + eval_template_program_env p v -> + ∥ eval_template_program (EtaExpand.eta_expand_program p) (EtaExpand.eta_expand p.1 [] v) ∥. + +Program Definition eta_expand : Transform.t template_program_env template_program Ast.term Ast.term + eval_template_program_env eval_template_program := + {| name := "eta expand cstrs and fixpoints"; + pre := fun p => ∥ wt_template_program_env p ∥ ; + transform p _ := EtaExpand.eta_expand_program p ; + post := fun p => ∥ wt_template_program p ∥ /\ EtaExpand.expanded_program p; + obseq p p' v v' := v' = EtaExpand.eta_expand p.1 [] v |}. +Next Obligation. + destruct p. now apply assume_welltyped_template_program_expansion. +Qed. +Next Obligation. + red. intros p v [wt] ev. + apply assume_preservation_template_program_env_expansion in ev as [ev']; eauto. +Qed. + Program Definition erasure_pipeline {guard : abstract_guard_impl} (efl := EWellformed.all_env_flags) : Transform.t TemplateProgram.template_program EProgram.eprogram Ast.term EAst.term TemplateProgram.eval_template_program - (EProgram.eval_eprogram {| with_prop_case := false; with_guarded_fix := false |}) := - (* Eta expansion of constructors and fixpoints *) - template_eta_expand ▷ + (EProgram.eval_eprogram {| with_prop_case := false; with_guarded_fix := false; with_constructor_as_block := true |}) := + (* Build an efficient lookup map for the following eta-expansion phase *) + build_template_program_env ▷ + (* Eta-expand constructors and fixpoint *) + eta_expand ▷ (* Casts are removed, application is binary, case annotations are inferred from the global environment *) template_to_pcuic_transform ▷ (* Branches of cases are expanded to bind only variables, constructor types are expanded accordingly *) @@ -43,63 +69,53 @@ Program Definition erasure_pipeline {guard : abstract_guard_impl} (efl := EWellf (* Simulation of the guarded fixpoint rules with a single unguarded one: the only "stuck" fixpoints remaining are unapplied. This translation is a noop on terms and environments. *) - guarded_to_unguarded_fix eq_refl ▷ + guarded_to_unguarded_fix (wcon := eq_refl) eq_refl ▷ (* Remove all constructor parameters *) - remove_params_optimization ▷ + remove_params_optimization (wcon := eq_refl) ▷ (* Rebuild the efficient lookup table *) - rebuild_wf_env_transform (efl := ERemoveParams.switch_no_params EWellformed.all_env_flags) ▷ + rebuild_wf_env_transform (efl := ERemoveParams.switch_no_params EWellformed.all_env_flags) true ▷ (* Remove all cases / projections on propositional content *) - optimize_prop_discr_optimization (efl := ERemoveParams.switch_no_params EWellformed.all_env_flags) (hastrel := eq_refl) (hastbox := eq_refl) ▷ + optimize_prop_discr_optimization (efl := ERemoveParams.switch_no_params EWellformed.all_env_flags) (wcon := eq_refl) (hastrel := eq_refl) (hastbox := eq_refl) ▷ (* Rebuild the efficient lookup table *) - rebuild_wf_env_transform (efl := EWellformed.all_env_flags) ▷ + rebuild_wf_env_transform (efl := ERemoveParams.switch_no_params EWellformed.all_env_flags) true ▷ (* Inline projections to cases *) - inline_projections_optimization (fl := EWcbvEval.target_wcbv_flags) (hastrel := eq_refl) (hastbox := eq_refl). + inline_projections_optimization (fl := EWcbvEval.target_wcbv_flags) (wcon := eq_refl) (hastrel := eq_refl) (hastbox := eq_refl) ▷ + let efl := EInlineProjections.disable_projections_env_flag (ERemoveParams.switch_no_params EWellformed.all_env_flags) in + (* Rebuild the efficient lookup table *) + rebuild_wf_env_transform (efl := efl) true ▷ + (* First-order constructor representation *) + constructors_as_blocks_transformation efl (has_app := eq_refl) (has_pars := eq_refl) (has_cstrblocks := eq_refl). + (* At the end of erasure we get a well-formed program (well-scoped globally and localy), without - parameters in inductive declarations. The constructor applications are also expanded, and - the evaluation relation does not need to consider guarded fixpoints or case analyses on propositional - content. All fixpoint bodies start with a lambda as well. *) + parameters in inductive declarations. The constructor applications are also transformed to a first-order + "block" application, of the right length, and the evaluation relation does not need to consider guarded + fixpoints or case analyses on propositional content. All fixpoint bodies start with a lambda as well. + Finally, projections are inlined to cases, so no `tProj` remains. *) Import EGlobalEnv EWellformed. -Lemma wf_global_switch_no_params (efl : EWellformed.EEnvFlags) Σ : - wf_glob (efl := ERemoveParams.switch_no_params efl) Σ -> - wf_glob (efl := efl) Σ. -Proof. - induction 1; constructor; auto. - destruct d; cbn in *. auto. - move/andP: H0 => [] hasp. unfold wf_minductive. - cbn in hasp. rewrite hasp. rewrite orb_true_r //. -Qed. - -Lemma wf_eprogram_switch_no_params (p : EProgram.eprogram) : - EProgram.wf_eprogram (ERemoveParams.switch_no_params all_env_flags) p -> - EProgram.wf_eprogram all_env_flags p. -Proof. - destruct p as [Σ p]. - intros []; split; cbn in * => //. - now eapply wf_global_switch_no_params. -Qed. - Next Obligation. destruct H. split => //. sq. now eapply ETransform.expanded_eprogram_env_expanded_eprogram_cstrs. Qed. -Next Obligation. - split => //. - now apply wf_eprogram_switch_no_params. -Qed. Definition run_erase_program {guard : abstract_guard_impl} := run erasure_pipeline. Program Definition erasure_pipeline_fast {guard : abstract_guard_impl} (efl := EWellformed.all_env_flags) := - template_eta_expand ▷ + build_template_program_env ▷ + eta_expand ▷ template_to_pcuic_transform ▷ pcuic_expand_lets_transform ▷ erase_transform ▷ - guarded_to_unguarded_fix eq_refl ▷ - remove_params_fast_optimization _ ▷ - rebuild_wf_env_transform (efl := ERemoveParams.switch_no_params EWellformed.all_env_flags) ▷ - optimize_prop_discr_optimization (efl := ERemoveParams.switch_no_params EWellformed.all_env_flags) (hastrel := eq_refl) (hastbox := eq_refl). + guarded_to_unguarded_fix (wcon := eq_refl) eq_refl ▷ + remove_params_fast_optimization (wcon := eq_refl) _ ▷ + rebuild_wf_env_transform (efl := ERemoveParams.switch_no_params EWellformed.all_env_flags) true ▷ + optimize_prop_discr_optimization (efl := ERemoveParams.switch_no_params EWellformed.all_env_flags) (wcon := eq_refl) (hastrel := eq_refl) (hastbox := eq_refl) ▷ + rebuild_wf_env_transform (efl := ERemoveParams.switch_no_params EWellformed.all_env_flags) true ▷ + inline_projections_optimization (fl := EWcbvEval.target_wcbv_flags) (wcon := eq_refl) (hastrel := eq_refl) (hastbox := eq_refl) ▷ + let efl := EInlineProjections.disable_projections_env_flag (ERemoveParams.switch_no_params EWellformed.all_env_flags) in + rebuild_wf_env_transform (efl := efl) true ▷ + constructors_as_blocks_transformation efl (has_app := eq_refl) (has_pars := eq_refl) (has_cstrblocks := eq_refl). Next Obligation. destruct H; split => //. now eapply ETransform.expanded_eprogram_env_expanded_eprogram_cstrs. Qed. @@ -108,20 +124,39 @@ Definition run_erase_program_fast {guard : abstract_guard_impl} := run erasure_p Local Open Scope string_scope. +Axiom fake_guard_impl_properties : +forall (fix_cofix: PCUICTyping.FixCoFix) + (Σ: PCUICAst.PCUICEnvironment.global_env_ext) + (Γ: PCUICAst.PCUICEnvironment.context) + (mfix: BasicAst.mfixpoint PCUICAst.term), +PCUICTyping.guard fix_cofix Σ Γ mfix <-> fake_guard_impl fix_cofix Σ Γ mfix. + + Global Program Instance fake_guard_impl : abstract_guard_impl := {| guard_impl := fake_guard_impl |}. -Next Obligation. Admitted. +Next Obligation. apply fake_guard_impl_properties. Qed. (** This uses the retyping-based erasure and assumes that the global environment and term are welltyped (for speed). As such this should only be used for testing, or when we know that the environment is wellformed and the term well-typed (e.g. when it comes directly from a Coq definition). *) -Definition erase_and_print_template_program {cf : checker_flags} (p : Ast.Env.program) + + +Axiom assume_that_we_only_erase_on_welltyped_programs : forall {cf : checker_flags}, + forall (p : Ast.Env.program), squash (TemplateProgram.wt_template_program p). + +Program Definition erase_and_print_template_program (p : Ast.Env.program) : string := - let p' := run_erase_program p (sq (todo "assuming quoted environment and term are well-typed")) in + let p' := run_erase_program p _ in time "Pretty printing" EPretty.print_program p'. +Next Obligation. + now eapply assume_that_we_only_erase_on_welltyped_programs. +Qed. -Program Definition erase_fast_and_print_template_program {cf : checker_flags} (p : Ast.Env.program) +Program Definition erase_fast_and_print_template_program (p : Ast.Env.program) : string := - let p' := run_erase_program_fast p (sq (todo "wf_env and welltyped term")) in + let p' := run_erase_program_fast p _ in time "pretty-printing" EPretty.print_program p'. +Next Obligation. + now eapply assume_that_we_only_erase_on_welltyped_programs. +Qed. \ No newline at end of file diff --git a/erasure/theories/ErasureCorrectness.v b/erasure/theories/ErasureCorrectness.v index 4d21b5b6a..04c3b6405 100644 --- a/erasure/theories/ErasureCorrectness.v +++ b/erasure/theories/ErasureCorrectness.v @@ -325,7 +325,7 @@ Proof. invs H2. -- exists x2. split; eauto. - constructor. econstructor. eauto. 2:eauto. + constructor. econstructor. eauto. eauto. 2:eauto. 4:{ unfold EGlobalEnv.iota_red. rewrite ECSubst.substl_subst //. rewrite forallb_rev forallb_skipn //. @@ -1021,7 +1021,7 @@ Proof. eapply erases_deps_eval in Hed1; tea. eapply erases_deps_mkApps_inv in Hed1 as []. depelim H8. - constructor. eapply Ee.eval_construct; tea. + constructor. eapply Ee.eval_construct; tea. eauto. eapply (EGlobalEnv.declared_constructor_lookup H9). rewrite -(Forall2_length H7). rewrite /EAst.cstr_arity. @@ -1073,13 +1073,17 @@ Proof. ++ cbn. invs H1. cbn in *. eapply ssrbool.negbTE, is_FixApp_erases. econstructor; eauto. - rewrite orb_false_r !negb_or in i. now move/andP: i => []. + rewrite orb_false_r !negb_or in i. + now move/andP: i => [] /andP []. ++ cbn in *. invs H1. invs i. -- eauto. -- rewrite !negb_or in i. rtoProp; intuition auto. - eapply is_ConstructApp_erases in H8; tea. + eapply is_ConstructApp_erases in H9; tea. + now move/negbTE: H9. + -- rewrite !negb_or in i. rtoProp; intuition auto. + eapply is_PrimApp_erases in H8; tea. now move/negbTE: H8. + exists EAst.tBox. split. 2: now constructor; econstructor. econstructor. @@ -1102,7 +1106,8 @@ Proof. * eexists. split. 2: now constructor; econstructor. econstructor; eauto. + invs He. - * eexists. split. 2: now constructor; econstructor. + * eexists. split. 2:{ constructor. eapply EWcbvEval.eval_atom. cbn [EWcbvEval.atom]. + depelim Hed. eapply EGlobalEnv.declared_constructor_lookup in H0. now rewrite H0. } econstructor; eauto. * eexists. split. 2: now constructor; econstructor. eauto. @@ -1114,7 +1119,11 @@ Proof. * eexists. split; eauto. now constructor; econstructor. * eexists. split. 2: now constructor; econstructor. econstructor; eauto. - Unshelve. all: repeat econstructor. + Unshelve. all: repeat econstructor. + + invs He. + * eexists. split; eauto. now constructor; econstructor. + * eexists. split. 2: now constructor; econstructor. + econstructor; eauto. Qed. (* Print Assumptions erases_correct. *) @@ -1137,17 +1146,19 @@ Proof. cbn. apply IHer, wf. Qed. -Lemma erases_global_decls_fresh univs {Σ : global_declarations} kn Σ' : fresh_global kn Σ -> erases_global_decls univs Σ Σ' -> EGlobalEnv.fresh_global kn Σ'. +Lemma erases_global_decls_fresh univs retro {Σ : global_declarations} kn Σ' : fresh_global kn Σ -> + erases_global_decls univs retro Σ Σ' -> EGlobalEnv.fresh_global kn Σ'. Proof. induction 2; constructor; eauto; now depelim H. Qed. Import EWellformed. -Lemma erases_mutual_inductive_body_wf (efl := all_env_flags) {Σ univs Σ' kn mib mib'} : +Lemma erases_mutual_inductive_body_wf (efl := all_env_flags) {Σ univs retro Σ' kn mib mib'} : erases_mutual_inductive_body mib mib' -> let udecl := PCUICLookup.universes_decl_of_decl (InductiveDecl mib) in - on_global_decl cumulSpec0 (PCUICEnvTyping.lift_typing typing) ({| universes := univs; declarations := Σ |}, udecl) kn + on_global_decl cumulSpec0 (PCUICEnvTyping.lift_typing typing) + ({| universes := univs; declarations := Σ; retroknowledge := retro |}, udecl) kn (InductiveDecl mib) -> wf_global_decl Σ' (E.InductiveDecl mib'). Proof. diff --git a/erasure/theories/ErasureFunction.v b/erasure/theories/ErasureFunction.v index cca85f2c9..f93b2dc09 100644 --- a/erasure/theories/ErasureFunction.v +++ b/erasure/theories/ErasureFunction.v @@ -374,10 +374,6 @@ Section Erase. | _ => try red; try reflexivity || discriminates end. - Equations erase_prim (ep : prim_val term) : PCUICPrimitive.prim_val E.term := - erase_prim (_; primIntModel i) := (_; primIntModel i); - erase_prim (_; primFloatModel f) := (_; primFloatModel f). - Opaque is_erasableb. #[tactic="idtac"] @@ -393,7 +389,7 @@ Section Erase. | tSort u := !%prg | tConst kn u := E.tConst kn | tInd kn u := !%prg - | tConstruct kn k u := E.tConstruct kn k + | tConstruct kn k u := E.tConstruct kn k [] | tProd _ _ _ := !%prg | tLambda na b b' := let t' := erase (vass na b :: Γ) b' _ in E.tLambda na.(binder_name) t' @@ -419,8 +415,8 @@ Section Erase. | tCoFix mfix n := let Γ' := (fix_context mfix ++ Γ)%list in let mfix' := erase_cofix Γ' mfix _ in - E.tCoFix mfix' n } - (* erase Γ (tPrim p) Ht _ := E.tPrim (erase_prim p) *) + E.tCoFix mfix' n + | tPrim p := E.tPrim (erase_prim_val p) } } } where erase_terms (Γ : context) (l : list term) (Hl : forall Σ : global_env_ext, abstract_env_ext_rel X Σ -> ∥ All (welltyped Σ Γ) l ∥) : list E.term := { erase_terms Γ [] _ := []; @@ -718,7 +714,8 @@ Definition erase_mutual_inductive_body (mib : mutual_inductive_body) : E.mutual_ let bds := mib.(ind_bodies) in let arities := arities_context bds in let bodies := map erase_one_inductive_body bds in - {| E.ind_npars := mib.(ind_npars); + {| E.ind_finite := mib.(ind_finite); + E.ind_npars := mib.(ind_npars); E.ind_bodies := bodies; |}. Import EnvMap. @@ -796,11 +793,16 @@ Proof. intro ext. (* ext eqext. *) assert (hl : Hlookup X_type X X_type' X'). - { red. intros. + { red. intros. specialize (ext _ _ H H0) as [[?] ?]. + split. intros. rewrite -(abstract_env_lookup_correct _ _ H). rewrite -(abstract_env_lookup_correct _ _ H0). - rewrite H1 H2. specialize (ext _ _ H H0) as [[?] ?]. pose proof (abstract_env_ext_wf _ H) as [?]. - eapply extends_lookup_env in H2; try apply e; eauto. clear -H1 H2. congruence. } + rewrite H2 H3. pose proof (abstract_env_ext_wf _ H) as [?]. + eapply extends_lookup_env in H3; try apply e; eauto. clear -H2 H3. congruence. + destruct X0. + rewrite -(abstract_env_ext_retroknowledge_correct _ H). + rewrite -(abstract_env_ext_retroknowledge_correct _ H0). + congruence. } simp is_erasableb. set (obl := is_erasableb_obligation_2 _ _ _ _). clearbody obl. set(ty := (type_of_typing X_type' _ _ _ wt')) in *. @@ -909,7 +911,7 @@ Next Obligation. pose proof (abstract_env_wf _ HX) as [wfX]. assert (prop': forall Σ : global_env, abstract_env_rel X Σ -> exists d, Σ.(declarations) = d :: decls). { now eexists. } - pose proof (abstract_pop_decls_correct X decls prop' _ _ HX H). + destruct (abstract_pop_decls_correct X decls prop' _ _ HX H) as [? []]. clear H. specialize (prop _ HX). destruct x, Σ, H0; cbn in *. subst. sq. destruct wfX. depelim o0. split => //. Qed. @@ -921,11 +923,11 @@ Next Obligation. pose proof (abstract_env_wf _ HX) as [wfX]. assert (prop': forall Σ : global_env, abstract_env_rel X Σ -> exists d, Σ.(declarations) = d :: decls). { now eexists. } - pose proof (abstract_pop_decls_correct X decls prop' _ _ HX HX'). + pose proof (abstract_pop_decls_correct X decls prop' _ _ HX HX') as [? []]. pose proof (abstract_make_wf_env_ext_correct _ _ _ _ _ HX' H). clear H HX'. specialize (prop _ HX). destruct x, Σ as [[] u], H0; cbn in *. - subst. sq. inversion H1. subst. clear H1. destruct wfX. cbn in *. - rewrite prop in o0. depelim o0. apply o2. + subst. sq. inversion H3. subst. clear H3. destruct wfX. cbn in *. + rewrite prop in o0. depelim o0. cbn in o2. apply o2. Qed. Next Obligation. pose proof (abstract_env_exists X) as [[? HX]]. @@ -1447,20 +1449,21 @@ Proof. red. simpl. unshelve epose (abstract_pop_decls_correct X decls _ Σ Σpop wfΣ wfpop). { intros. now eexists. } split => //. intuition eauto. - exists [(kn, ConstantDecl c)]; intuition eauto. rewrite H0; eauto. - rewrite indeps. unshelve epose proof (abstract_pop_decls_correct X decls _ Σ Σpop wfΣ wfpop) as [Hpop Hpop']. + exists [(kn, ConstantDecl c)]; intuition eauto. rewrite H0; eauto. + now destruct a. + rewrite indeps. unshelve epose proof (abstract_pop_decls_correct X decls _ Σ Σpop wfΣ wfpop) as [Hpop [Hpop' Hpop'']]. { intros. now eexists. } pose (prf' := prf _ wfΣ). - destruct Σ. cbn in *. rewrite Hpop' prf'. rewrite <- Hpop at 1. + destruct Σ. cbn in *. rewrite Hpop' Hpop'' prf'. rewrite <- Hpop at 1. eapply (erases_deps_cons Σpop). rewrite <- Hpop'. apply wf. - rewrite Hpop. rewrite prf' in wf. destruct wf. now rewrite Hpop' in o0. + rewrite Hpop. rewrite prf' in wf. destruct wf. now rewrite Hpop'' Hpop' in o0. pose proof (erase_constant_body_correct' H0). specialize_Σ wfmake. sq. destruct H1 as [bod [bodty [[Hbod Hebod] Heqdeps]]]. rewrite (abstract_make_wf_env_ext_correct Xpop (cst_universes c) _ Σpop Σmake wfpop wfmake) in Hbod, Hebod. eapply (erase_global_erases_deps (Σ := (Σpop, cst_universes c))); simpl; auto. - { constructor; simpl; auto. depelim wf. rewrite Hpop' in o0. + { constructor; simpl; auto. depelim wf. rewrite Hpop' Hpop'' in o0. cbn in o0, o. rewrite prf' in o0. rewrite <- Hpop in o0. rewrite Hpop' in o. clear -o o0. now depelim o0. depelim wf. rewrite Hpop' in o0. @@ -1496,7 +1499,7 @@ Proof. set (Xmake := abstract_make_wf_env_ext Xpop (cst_universes c) _). epose proof (abstract_env_exists Xpop) as [[Σp wfpop]]. pose proof (abstract_env_wf _ wfpop) as [wfΣp]. - unshelve epose proof (abstract_pop_decls_correct X decls _ _ _ wfΣ wfpop) as [Hpop Hpop']. + unshelve epose proof (abstract_pop_decls_correct X decls _ _ _ wfΣ wfpop) as [Hpop [Hpop' Hpop'']]. { intros. now eexists. } pose proof (prf _ wfΣ). destruct Σ. cbn in *. subst. eapply global_erases_with_deps_cons; eauto. @@ -1514,7 +1517,7 @@ Proof. cbn. set (Xpop := abstract_pop_decls X). epose proof (abstract_env_exists Xpop) as [[Σp wfpop]]. pose proof (abstract_env_wf _ wfpop) as [wfΣp]. - unshelve epose proof (abstract_pop_decls_correct X decls _ Σ Σp wfΣ wfpop) as [Hpop Hpop']. + unshelve epose proof (abstract_pop_decls_correct X decls _ Σ Σp wfΣ wfpop) as [Hpop [Hpop' Hpop'']]. { intros. now eexists. } pose proof (prf _ wfΣ). destruct Σ. cbn in *. subst. eapply global_erases_with_deps_weaken. eauto. @@ -1529,7 +1532,7 @@ Proof. ++ simpl. set (Xpop := abstract_pop_decls X). epose proof (abstract_env_exists Xpop) as [[Σp wfpop]]. pose proof (abstract_env_wf _ wfpop) as [wfΣp]. - unshelve epose proof (abstract_pop_decls_correct X decls _ Σ Σp wfΣ wfpop) as [Hpop Hpop']. + unshelve epose proof (abstract_pop_decls_correct X decls _ Σ Σp wfΣ wfpop) as [Hpop [Hpop' Hpop'']]. { intros. now eexists. } pose proof (prf _ wfΣ). destruct Σ. cbn in *. subst. destruct (KernameSet.mem kn deps) eqn:eqkn. @@ -1551,7 +1554,7 @@ Proof. intros. pose proof (abstract_env_irr _ H0 wfpop). subst. sq; eexists; eauto. eapply KernameSet.subset_spec. - intros ? hin'. eapply sub. eapply KernameSet.singleton_spec in hin'. now subst. } + intros ? hin'. eapply sub. eapply KernameSet.singleton_spec in hin'. now subst. } Qed. Lemma erase_correct (wfl := Ee.default_wcbv_flags) X_type (X : X_type.π1) @@ -1585,7 +1588,8 @@ Proof. rewrite (abstract_make_wf_env_ext_correct X univs wfext _ _ wfΣX wfΣex); eauto. Qed. -Lemma global_env_ind (P : global_env -> Type) (Pnil : forall univs, P {| universes := univs; declarations := [] |}) +Lemma global_env_ind (P : global_env -> Type) + (Pnil : forall univs retro, P {| universes := univs; declarations := []; retroknowledge := retro |}) (Pcons : forall (Σ : global_env) d, P Σ -> P (add_global_decl Σ d)) (Σ : global_env) : P Σ. Proof. @@ -1595,15 +1599,16 @@ Proof. Qed. Lemma on_global_env_ind (P : forall Σ : global_env, wf Σ -> Type) - (Pnil : forall univs (onu : on_global_univs univs), P {| universes := univs; declarations := [] |} - (onu, globenv_nil _ _ _)) + (Pnil : forall univs retro (onu : on_global_univs univs), P {| universes := univs; declarations := []; retroknowledge := retro |} + (onu, globenv_nil _ _ _ _)) (Pcons : forall (Σ : global_env) kn d (wf : wf Σ) (Hfresh : fresh_global kn Σ.(declarations)) (udecl := PCUICLookup.universes_decl_of_decl d) (onud : on_udecl Σ.(universes) udecl) - (pd : on_global_decl cumulSpec0 (lift_typing typing) ({| universes := Σ.(universes); declarations := Σ.(declarations) |}, udecl) kn d), + (pd : on_global_decl cumulSpec0 (lift_typing typing) + ({| universes := Σ.(universes); declarations := Σ.(declarations); retroknowledge := Σ.(retroknowledge) |}, udecl) kn d), P Σ wf -> P (add_global_decl Σ (kn, d)) - (fst wf, globenv_decl _ _ Σ.(universes) Σ.(declarations) kn d (snd wf) Hfresh onud pd)) + (fst wf, globenv_decl _ _ Σ.(universes) Σ.(retroknowledge) Σ.(declarations) kn d (snd wf) Hfresh onud pd)) (Σ : global_env) (wfΣ : wf Σ) : P Σ wfΣ. Proof. destruct Σ as [univs Σ]. destruct wfΣ; cbn in *. @@ -1943,13 +1948,14 @@ Section wffix. wf_fixpoints c && brs' | tProj p c => wf_fixpoints c | tFix mfix idx => - (idx (isLambda d.(dbody) || isBox d.(dbody)) && wf_fixpoints d.(dbody)) mfix + (idx isLambda d.(dbody) && wf_fixpoints d.(dbody)) mfix | tCoFix mfix idx => (idx true - | tConstruct ind c => true + | tConstruct ind c _ => true | tVar _ => true | tBox => true + | tPrim _ => true end. End wffix. @@ -2100,7 +2106,7 @@ Proof. pose proof (abstract_env_wf _ wf) as [wfΣ]. assert (erases_mutual_inductive_body m (erase_mutual_inductive_body m)). { eapply (erases_mutual (mdecl:=kn)); tea. } - eapply (erases_mutual_inductive_body_wf (univs := Σ.(universes)) (Σ := decls) (kn := kn) (Σ' := Σ')) in H; tea. + eapply (erases_mutual_inductive_body_wf (univs := Σ.(universes)) (retro := Σ.(retroknowledge)) (Σ := decls) (kn := kn) (Σ' := Σ')) in H; tea. rewrite -(heq _ wf). now destruct Σ. Qed. @@ -2183,10 +2189,10 @@ Proof. pose proof (prf _ wf) as prf'. eapply (erase_global_ind_decl_wf_glob (kn:=kn')). intros. - unshelve epose proof (abstract_pop_decls_correct X decls _ _ _ wf H) as [? ?]. + unshelve epose proof (abstract_pop_decls_correct X decls _ _ _ wf H) as [? [? ?]]. { now eexists. } destruct Σ, Σ0. cbn in *. rewrite prf' in wfΣ. - depelim wfΣ. cbn in *. rewrite <- H1, H0. + depelim wfΣ. cbn in *. rewrite <- H1, H0, <- H2. now depelim o0. eapply erase_global_decls_fresh => //. pose proof (abstract_env_wf _ wf) as [wfΣ]. @@ -2243,9 +2249,9 @@ Proof. revert deps X prf. induction etaΣ; intros deps. intros. constructor. intros. pose proof (abstract_env_exists (abstract_pop_decls X)) as [[Σpop wfpop]]. - unshelve epose proof (abstract_pop_decls_correct X Σ _ _ _ wf wfpop) as [? ?]. + unshelve epose proof (abstract_pop_decls_correct X Σ _ _ _ wf wfpop) as [? [? ?]]. { now eexists. } - destruct Σpop. cbn in H0, H1. subst. + destruct Σpop. cbn in H0, H1, H2. subst. destruct decl as [kn []]; destruct (KernameSet.mem kn deps) eqn:eqkn; simpl; rewrite eqkn. constructor; [eapply IHetaΣ; auto|]. @@ -2458,9 +2464,9 @@ Section EraseGlobalFast. Definition decls_prefix decls (Σ' : global_env) := ∑ Σ'', declarations Σ' = Σ'' ++ decls. -Lemma on_global_decls_prefix {cf} Pcmp P univs decls decls' : - on_global_decls Pcmp P univs (decls ++ decls') -> - on_global_decls Pcmp P univs decls'. +Lemma on_global_decls_prefix {cf} Pcmp P univs retro decls decls' : + on_global_decls Pcmp P univs retro (decls ++ decls') -> + on_global_decls Pcmp P univs retro decls'. Proof. induction decls => //. intros ha; depelim ha. @@ -2468,7 +2474,7 @@ Proof. Qed. Lemma decls_prefix_wf {decls Σ} : - decls_prefix decls Σ -> wf Σ -> wf {| universes := Σ.(universes); declarations := decls |}. + decls_prefix decls Σ -> wf Σ -> wf {| universes := Σ.(universes); declarations := decls; retroknowledge := Σ.(retroknowledge) |}. Proof. intros [Σ' hd] wfΣ. split. apply wfΣ. @@ -2484,14 +2490,15 @@ Qed. Lemma weaken_prefix {decls Σ kn decl} : decls_prefix decls Σ -> wf Σ -> - lookup_env {| universes := Σ; declarations := decls |} kn = Some decl -> + lookup_env {| universes := Σ; declarations := decls; retroknowledge := Σ.(retroknowledge) |} kn = Some decl -> on_global_decl cumulSpec0 (lift_typing typing) (Σ, universes_decl_of_decl decl) kn decl. Proof. intros prefix wfΣ. have wfdecls := decls_prefix_wf prefix wfΣ. epose proof (weakening_env_lookup_on_global_env (lift_typing typing) _ Σ kn decl weaken_env_prop_typing wfdecls wfΣ). - forward X. red; split => //. cbn. apply incl_cs_refl. + forward X. red; split => //. cbn. apply incl_cs_refl. cbn. + apply Retroknowledge.extends_refl. now apply (X wfdecls). Qed. @@ -2573,12 +2580,8 @@ Proof. now apply IHsuffix. Qed. -Definition add_suffix suffix Σ := - {| universes := Σ.(universes); declarations := suffix ++ Σ.(declarations) |}. +Definition add_suffix suffix Σ := set_declarations Σ (suffix ++ Σ.(declarations)). -Lemma eta_global_env Σ : Σ = {| universes := Σ.(universes); declarations := Σ.(declarations) |}. -Proof. now destruct Σ. Qed. - Lemma add_suffix_cons d suffix Σ : add_suffix (d :: suffix) Σ = add_global_decl (add_suffix suffix Σ) d. Proof. reflexivity. Qed. @@ -2589,7 +2592,7 @@ Lemma global_erased_with_deps_weaken_prefix suffix Σ Σ' kn : Proof. induction suffix. - unfold add_suffix; cbn. intros wf hg. - now rewrite -eta_global_env. + now rewrite /set_declarations /= -eta_global_env. - rewrite add_suffix_cons. intros wf H. destruct a as [kn' d]. eapply global_erases_with_deps_weaken => //. apply IHsuffix => //. @@ -2694,7 +2697,7 @@ Qed.*) Lemma erase_global_deps_fast_spec_gen {deps} {X_type X X'} {decls hprefix hprefix'} : - (forall Σ Σ', abstract_env_rel X Σ -> abstract_env_rel X' Σ' -> universes Σ = universes Σ') -> + (forall Σ Σ', abstract_env_rel X Σ -> abstract_env_rel X' Σ' -> universes Σ = universes Σ' /\ retroknowledge Σ = retroknowledge Σ') -> erase_global_decls_fast deps X_type X decls hprefix = erase_global_decls X_type deps X' decls hprefix'. Proof. @@ -2704,7 +2707,7 @@ Proof. pose proof (abstract_env_exists X') as [[Σ' wfΣ']]. pose proof (abstract_env_wf _ wfΣ) as [wf]. pose proof (abstract_env_exists (abstract_pop_decls X')) as [[? wfpop]]. - unshelve epose proof (abstract_pop_decls_correct X' decls _ _ _ wfΣ' wfpop) as [? ?]. + unshelve epose proof (abstract_pop_decls_correct X' decls _ _ _ wfΣ' wfpop) as [? [? ?]]. { now eexists. } destruct a as [kn []]. @@ -2718,24 +2721,28 @@ Proof. destruct (hprefix _ wfΣ) as [[Σ'' eq]]. eapply erase_constant_body_suffix; cbn => //. intros. - epose proof (abstract_make_wf_env_ext_correct X (cst_universes c) _ _ _ wfΣ H1). - epose proof (abstract_make_wf_env_ext_correct (abstract_pop_decls X') (cst_universes c) _ _ _ wfpop H2). + epose proof (abstract_make_wf_env_ext_correct X (cst_universes c) _ _ _ wfΣ H2). + epose proof (abstract_make_wf_env_ext_correct (abstract_pop_decls X') (cst_universes c) _ _ _ wfpop H3). subst. split => //. sq; red. cbn. - rewrite eq. rewrite <- H0. split. symmetry. apply equ; eauto. - eexists (Σ'' ++ [(kn, ConstantDecl c)]). subst. now rewrite -app_assoc. } + rewrite eq. rewrite <- H0, <- H1. split. symmetry. apply equ; eauto. + eexists (Σ'' ++ [(kn, ConstantDecl c)]). subst. now rewrite -app_assoc. subst. + symmetry. now apply equ. + } destruct KernameSet.mem => //; f_equal; eapply IHdecls. - intros. unshelve epose proof (abstract_pop_decls_correct X' decls _ _ _ wfΣ' H2) as [? ?]. - { now eexists. } rewrite <- H4. apply equ; eauto. - intros. unshelve epose proof (abstract_pop_decls_correct X' decls _ _ _ wfΣ' H2) as [? ?]. - { now eexists. } rewrite <- H4. apply equ; eauto. + intros. unshelve epose proof (abstract_pop_decls_correct X' decls _ _ _ wfΣ' H3) as [? ?]. + { now eexists. } intuition auto. rewrite <- H6. apply equ; eauto. rewrite <- H7; apply equ; auto. + intros. unshelve epose proof (abstract_pop_decls_correct X' decls _ _ _ wfΣ' H3) as [? ?]. + { now eexists. } intuition auto. rewrite <- H6. apply equ; eauto. rewrite <- H7; apply equ; auto. - cbn. destruct KernameSet.mem => //; f_equal; eapply IHdecls. - intros. unshelve epose proof (abstract_pop_decls_correct X' decls _ _ _ wfΣ' H2) as [? ?]. - { now eexists. } rewrite <- H4. apply equ; eauto. - intros. unshelve epose proof (abstract_pop_decls_correct X' decls _ _ _ wfΣ' H2) as [? ?]. - { now eexists. } rewrite <- H4. apply equ; eauto. + intros. unshelve epose proof (abstract_pop_decls_correct X' decls _ _ _ wfΣ' H3) as [? ?]. + { now eexists. } + intuition auto. rewrite <- H6. apply equ; eauto. rewrite <- H7; apply equ; auto. + intros. unshelve epose proof (abstract_pop_decls_correct X' decls _ _ _ wfΣ' H3) as [? ?]. + { now eexists. } + intuition auto. rewrite <- H6. apply equ; eauto. rewrite <- H7; apply equ; auto. Qed. Lemma erase_global_deps_fast_spec {deps} {X_type X} {decls hprefix hprefix'} : diff --git a/erasure/theories/ErasureProperties.v b/erasure/theories/ErasureProperties.v index 8450c1c80..96e5d25b0 100644 --- a/erasure/theories/ErasureProperties.v +++ b/erasure/theories/ErasureProperties.v @@ -152,6 +152,16 @@ Proof. induction 1; cbn; try congruence. cbn. now rewrite EAstUtils.head_tApp. Qed. +Lemma is_PrimApp_erases Σ Γ t t' : + Σ;;; Γ |- t ⇝ℇ t' -> + negb (isPrimApp t) -> negb (EAstUtils.isPrimApp t'). +Proof. induction 1; cbn; try congruence. +- unfold isPrimApp in *. clear IHerases2. + cbn. rewrite head_tapp. + unfold EAstUtils.isPrimApp in *. + cbn. now rewrite EAstUtils.head_tApp. +Qed. + Lemma erases_isLambda {Σ Γ t u} : Σ ;;; Γ |- t ⇝ℇ u -> isLambda t -> EAst.isLambda u || EAstUtils.isBox u. Proof. @@ -494,6 +504,7 @@ Section wellscoped. Fixpoint wellformed (t : term) : bool := match t with | tRel i => true + | tPrim p => true | tEvar ev args => List.forallb (wellformed) args | tLambda _ N M => wellformed N && wellformed M | tApp u v => wellformed u && wellformed v @@ -635,7 +646,7 @@ Proof. simpl; try solve [solve_all]. - now apply Nat.ltb_lt. - eapply trans_lookup_constant in wfa; tea. - - eapply trans_lookup_constructor in wfa; tea. + - eapply trans_lookup_constructor in wfa; tea. now rewrite wfa. - move/andP: wfa => [] /andP[] lookup wfc wfbrs. apply/andP. split. apply/andP. split; eauto. eapply trans_lookup_inductive; tea. @@ -660,7 +671,7 @@ Proof. unfold EAst.test_def; simpl; eauto. rewrite fix_context_length in b1. move/andP: b0 => //; eauto. move=> [] wft /andP[] isl wf; eauto. - eapply b1; tea. now rewrite app_length fix_context_length. + eapply b1; tea. eapply b. now rewrite app_length fix_context_length. - epose proof (All2_length X0). unfold EWellformed.wf_fix_gen. rewrite -H0. move/andP: wfa => [] ->. @@ -677,7 +688,8 @@ Lemma eval_empty_brs {wfl : Ee.WcbvFlags} Σ ci p e : Σ ⊢ E.tCase ci p [] ▷ Proof. intros He. depind He. - - clear -e0. now rewrite nth_error_nil in e0. + - clear -e2. now rewrite nth_error_nil in e2. + - clear -e2. now rewrite nth_error_nil in e2. - discriminate. - eapply IHHe2. - cbn in i. discriminate. @@ -693,7 +705,8 @@ Proof. - depelim He1. clear -H. symmetry in H. elimtype False. destruct args using rev_case. discriminate. rewrite EAstUtils.mkApps_app in H. discriminate. - - exists n, f. intuition auto. + - depelim He1. + - exists n, f4. intuition auto. - depelim He1. clear -H. symmetry in H. elimtype False. destruct args using rev_case. discriminate. rewrite EAstUtils.mkApps_app in H. discriminate. @@ -709,6 +722,8 @@ Proof. depind He. - pose proof (Ee.eval_deterministic He1 Hc). subst c'. econstructor; eauto. now eapply Ee.value_final, Ee.eval_to_value. + - pose proof (Ee.eval_deterministic He1 Hc). subst c'. + eapply Ee.eval_iota_block; eauto. now eapply Ee.value_final, Ee.eval_to_value. - pose proof (Ee.eval_deterministic He1 Hc). subst c'. eapply Ee.eval_iota_sing; tea. now constructor. - pose proof (Ee.eval_deterministic He1 Hc). subst c'. @@ -726,6 +741,8 @@ Proof. depind He. - pose proof (eval_trans' Hc He1); subst discr. econstructor; eauto. + - pose proof (eval_trans' Hc He1); subst discr. + now econstructor; eauto. - pose proof (eval_trans' Hc He1); subst discr. eapply Ee.eval_iota_sing; tea. - pose proof (eval_trans' Hc He1); subst discr. @@ -739,13 +756,15 @@ Lemma eval_proj_eval_inv_discr {wfl : Ee.WcbvFlags} {Σ p c c' e} : Σ ⊢ E.tProj p c' ▷ e. Proof. intros He Hc. - depind He. + depind He. - pose proof (eval_trans' Hc He1); subst discr. econstructor; eauto. - pose proof (eval_trans' Hc He1); subst discr. - eapply Ee.eval_proj; tea. + now econstructor; tea. + - pose proof (eval_trans' Hc He1); subst discr. + now econstructor; tea. - pose proof (eval_trans' Hc He); subst discr. - eapply Ee.eval_proj_prop; tea. + now econstructor; tea. - cbn in i. discriminate. Qed. diff --git a/erasure/theories/Extract.v b/erasure/theories/Extract.v index 94b6fb0a9..1a02b412e 100644 --- a/erasure/theories/Extract.v +++ b/erasure/theories/Extract.v @@ -1,7 +1,7 @@ (* Distributed under the terms of the MIT license. *) From Coq Require Import Program. -From MetaCoq.Template Require Import config utils. -From MetaCoq.PCUIC Require Import PCUICAst PCUICAstUtils PCUICTyping +From MetaCoq.Template Require Import config utils Primitive. +From MetaCoq.PCUIC Require Import PCUICAst PCUICAstUtils PCUICPrimitive PCUICTyping PCUICElimination PCUICWcbvEval. From MetaCoq.Erasure Require EAst EGlobalEnv. @@ -35,6 +35,15 @@ Reserved Notation "Σ ;;; Γ |- s ⇝ℇ t" (at level 50, Γ, s, t at next level Definition erase_context (Γ : context) : list name := map (fun d => d.(decl_name).(binder_name)) Γ. +Definition erase_prim_model {t : prim_tag} (e : @prim_model term t) : @prim_model E.term t := + match e in @prim_model _ x return prim_model E.term x with + | primIntModel i => primIntModel i + | primFloatModel f => primFloatModel f + end. + +Definition erase_prim_val (p : prim_val term) : prim_val E.term := + (p.π1; erase_prim_model p.π2). + Inductive erases (Σ : global_env_ext) (Γ : context) : term -> E.term -> Prop := erases_tRel : forall i : nat, Σ;;; Γ |- tRel i ⇝ℇ E.tRel i | erases_tVar : forall n : ident, Σ;;; Γ |- tVar n ⇝ℇ E.tVar n @@ -55,7 +64,7 @@ Inductive erases (Σ : global_env_ext) (Γ : context) : term -> E.term -> Prop : Σ;;; Γ |- tConst kn u ⇝ℇ E.tConst kn | erases_tConstruct : forall (kn : inductive) (k : nat) (n : Instance.t), isPropositional Σ kn false -> - Σ;;; Γ |- tConstruct kn k n ⇝ℇ E.tConstruct kn k + Σ;;; Γ |- tConstruct kn k n ⇝ℇ E.tConstruct kn k [] | erases_tCase1 (ci : case_info) (p : predicate term) (c : term) (brs : list (branch term)) (c' : E.term) (brs' : list (list name × E.term)) : @@ -84,7 +93,9 @@ Inductive erases (Σ : global_env_ext) (Γ : context) : term -> E.term -> Prop : × Σ;;; Γ ,,, fix_context mfix |- dbody d ⇝ℇ E.dbody d') mfix mfix' -> Σ;;; Γ |- tCoFix mfix n ⇝ℇ E.tCoFix mfix' n - | erases_box : forall t : term, isErasable Σ Γ t -> Σ;;; Γ |- t ⇝ℇ E.tBox where "Σ ;;; Γ |- s ⇝ℇ t" := (erases Σ Γ s t). + | erases_tPrim : forall p, Σ;;; Γ |- tPrim p ⇝ℇ E.tPrim (erase_prim_val p) + | erases_box : forall t : term, isErasable Σ Γ t -> Σ;;; Γ |- t ⇝ℇ E.tBox + where "Σ ;;; Γ |- s ⇝ℇ t" := (erases Σ Γ s t). Lemma erases_forall_list_ind Σ (P : context -> term -> E.term -> Prop) @@ -113,7 +124,7 @@ Lemma erases_forall_list_ind P Γ (tConst kn u) (E.tConst kn)) (Hconstruct : forall Γ kn k n, isPropositional Σ kn false -> - P Γ (tConstruct kn k n) (E.tConstruct kn k)) + P Γ (tConstruct kn k n) (E.tConstruct kn k [])) (Hcase : forall Γ ci p c brs c' brs', PCUICElimination.Informative Σ ci.(ci_ind) -> Σ;;; Γ |- c ⇝ℇ c' -> @@ -153,6 +164,7 @@ Lemma erases_forall_list_ind (dbody d) (EAst.dbody d') ) mfix mfix' -> P Γ (tCoFix mfix n) (E.tCoFix mfix' n)) + (Hprim : forall Γ p, P Γ (tPrim p) (E.tPrim (erase_prim_val p))) (Hbox : forall Γ t, isErasable Σ Γ t -> P Γ t E.tBox) : forall Γ t t0, Σ;;; Γ |- t ⇝ℇ t0 -> @@ -215,18 +227,18 @@ Definition erases_mutual_inductive_body (mib : mutual_inductive_body) (mib' : E. Forall2 erases_one_inductive_body bds (mib'.(E.ind_bodies)) /\ mib.(ind_npars) = mib'.(E.ind_npars). -Inductive erases_global_decls (univs : ContextSet.t) : global_declarations -> E.global_declarations -> Prop := -| erases_global_nil : erases_global_decls univs [] [] +Inductive erases_global_decls (univs : ContextSet.t) retro : global_declarations -> E.global_declarations -> Prop := +| erases_global_nil : erases_global_decls univs retro [] [] | erases_global_cnst Σ cb cb' kn Σ' : - erases_constant_body ({| universes := univs; declarations := Σ |}, cst_universes cb) cb cb' -> - erases_global_decls univs Σ Σ' -> - erases_global_decls univs ((kn, ConstantDecl cb) :: Σ) ((kn, E.ConstantDecl cb') :: Σ') + erases_constant_body ({| universes := univs; declarations := Σ; retroknowledge := retro |}, cst_universes cb) cb cb' -> + erases_global_decls univs retro Σ Σ' -> + erases_global_decls univs retro ((kn, ConstantDecl cb) :: Σ) ((kn, E.ConstantDecl cb') :: Σ') | erases_global_ind Σ mib mib' kn Σ' : erases_mutual_inductive_body mib mib' -> - erases_global_decls univs Σ Σ' -> - erases_global_decls univs((kn, InductiveDecl mib) :: Σ) ((kn, E.InductiveDecl mib') :: Σ'). + erases_global_decls univs retro Σ Σ' -> + erases_global_decls univs retro ((kn, InductiveDecl mib) :: Σ) ((kn, E.InductiveDecl mib') :: Σ'). -Definition erases_global Σ Σ' := erases_global_decls Σ.(universes) Σ.(declarations) Σ'. +Definition erases_global Σ Σ' := erases_global_decls Σ.(universes) Σ.(retroknowledge) Σ.(declarations) Σ'. Definition inductive_arity (t : term) := match fst (decompose_app t) with @@ -266,7 +278,7 @@ Inductive erases_deps (Σ : global_env) (Σ' : E.global_declarations) : E.term - EGlobalEnv.declared_constructor Σ' (ind, c) mdecl' idecl' cdecl' -> erases_mutual_inductive_body mdecl mdecl' -> erases_one_inductive_body idecl idecl' -> - erases_deps Σ Σ' (E.tConstruct ind c) + erases_deps Σ Σ' (E.tConstruct ind c []) | erases_deps_tCase p mdecl idecl mdecl' idecl' discr brs : declared_inductive Σ (fst p) mdecl idecl -> EGlobalEnv.declared_inductive Σ' (fst p) mdecl' idecl' -> @@ -287,7 +299,8 @@ Inductive erases_deps (Σ : global_env) (Σ' : E.global_declarations) : E.term - erases_deps Σ Σ' (E.tFix defs i) | erases_deps_tCoFix defs i : Forall (fun d => erases_deps Σ Σ' (E.dbody d)) defs -> - erases_deps Σ Σ' (E.tCoFix defs i). + erases_deps Σ Σ' (E.tCoFix defs i) +| erases_deps_tPrim p : erases_deps Σ Σ' (E.tPrim p). Definition option_is_none {A} (o : option A) := match o with diff --git a/erasure/theories/Extraction.v b/erasure/theories/Extraction.v index a3272fdcb..d88201128 100644 --- a/erasure/theories/Extraction.v +++ b/erasure/theories/Extraction.v @@ -1,5 +1,5 @@ (* Distributed under the terms of the MIT license. *) -From Coq Require Import Ascii FSets ExtrOcamlBasic ExtrOcamlZInt ExtrOCamlFloats ExtrOCamlInt63. +From Coq Require Import Ascii FSets ExtrOcamlBasic ExtrOCamlFloats ExtrOCamlInt63. From MetaCoq.Template Require Import utils. (** * Extraction setup for the erasure phase of template-coq. diff --git a/erasure/theories/README.md b/erasure/theories/README.md new file mode 100644 index 000000000..72fb993d4 --- /dev/null +++ b/erasure/theories/README.md @@ -0,0 +1,83 @@ +# Erasure + +Implementation of a verified extraction pipeline from PCUIC to untyped lambda calculus +extended with a box construct for erased terms. + + +| File | Description | +|-------------------------|------------------------------------------------------| +| [Prelim] | Preliminaries on PCUIC +| [EArities] | Meta-theoretic lemmas on PCUIC needed for erasure correctness +| [EAst] | AST of λ-box terms +| [EAstUtils] | Utility definitions and lemmas on the AST +| [ELiftSubst] | Lifting and substitution for λ-box terms +| [ECSubst] | Definition of closed substitution (without lifting) +| [EReflect] | Reflection of equality on the AST +| [ESpineView] | Spine-view of λ-box terms (i.e., n-ary applications) +| [EDeps] | Definitions of λ-box term dependencies (used to optimize erasure) +| [EEnvMap] | Efficient global environment definition +| [EGlobalEnv] | Global environment interface +| [EGenericMapEnv] | Generic well-formedness preservation proof for global environments +| [EEtaExpanded] | Eta-expansion predicates on λ-box terms, only for constructors +| [EEtaExpandedFix] | Eta-expansion predicates on λ-box terms, for constructors and fixpoints +| [EInduction] | Induction principles on λ-box terms +| [EExtends] | Weakening of global environments +| [EPretty] | Pretty-printing of λ-box programs +| [EProgram] | Definition of well-formed λ-box programs and associated evaluation +| [EWcbvEval] | Weak call-by-value evaluation definition +| [EWcbvEvalEtaInd] | Induction principle on weak call-by-value evaluation preserving eta-expansion +| [EWcbvEvalInd] | Induction principle on weak call-by-value evaluation +| [EWellformed] | Well-formedness predicate on erased terms +| [Extract] | The erasure relation +| [ESubstitution] | Substitution and weakening lemmas for the erasure relation +| [ErasureCorrectness] | The erasure relation correctness proof +| [ErasureProperties] | Properties of the erasure relation +| [ErasureFunction] | The erasure function defined on well-typed terms and its correctness proof +| [EInlineProjections] | Transformation that inlines projections to cases +| [EOptimizePropDiscr] | Transformation removing cases on propositional content +| [EConstructorsAsBlocks] | Transform constructor applications into an atomic construct (always fully-applied constructors) +| [ERemoveParams] | Remove constructor parameters +| [ETransform] | Definitions of transformations from PCUIC to λ-box +| [Erasure] | The complete erasure pipeline +| [Extraction] | Extraction directives for the plugin +| [Loader] | Loads the erasure plugin + +[EAll]: EAll.v +[EArities]: EArities.v +[EAst]: EAst.v +[EAstUtils]: EAstUtils.v +[ECSubst]: ECSubst.v +[ECoFixToFix]: ECoFixToFix.v +[EDeps]: EDeps.v +[EEnvMap]: EEnvMap.v +[EGenericMapEnv]: EGenericMapEnv.v +[EEtaExpanded]: EEtaExpanded.v +[EEtaExpandedFix]: EEtaExpandedFix.v +[EExtends]: EExtends.v +[EGlobalEnv]: EGlobalEnv.v +[EInduction]: EInduction.v +[EInlineProjections]: EInlineProjections.v +[ELiftSubst]: ELiftSubst.v +[EOptimizePropDiscr]: EOptimizePropDiscr.v +[EPretty]: EPretty.v +[EProgram]: EProgram.v +[EReflect]: EReflect.v +[ERemoveParams]: ERemoveParams.v +[ESpineView]: ESpineView.v +[ESubstitution]: ESubstitution.v +[ETransform]: ETransform.v +[EWcbvEval]: EWcbvEval.v +[EWcbvEvalEtaInd]: EWcbvEvalEtaInd.v +[EWcbvEvalInd]: EWcbvEvalInd.v +[EWellformed]: EWellformed.v +[EWndEval]: EWndEval.v +[EWtAst]: EWtAst.v +[Erasure]: Erasure.v +[EConstructorsAsBlocks]: EConstructorsAsBlocks.v +[ErasureCorrectness]: ErasureCorrectness.v +[ErasureFunction]: ErasureFunction.v +[ErasureProperties]: ErasureProperties.v +[Extract]: Extract.v +[Extraction]: Extraction.v +[Loader]: Loader.v +[Prelim]: Prelim.v \ No newline at end of file diff --git a/examples/Makefile b/examples/Makefile index aef42de36..73691022f 100644 --- a/examples/Makefile +++ b/examples/Makefile @@ -3,9 +3,13 @@ all: examples examples: Makefile.coq $(MAKE) -f Makefile.coq TIMED=$(TIMED) -Makefile.coq: Makefile +Makefile.coq: Makefile _CoqProject coq_makefile -f _CoqProject -o Makefile.coq +_CoqProject: _CoqProject.in metacoq-config + cat metacoq-config > _CoqProject + cat _CoqProject.in >> _CoqProject + clean: Makefile.coq $(MAKE) -f Makefile.coq clean diff --git a/examples/_CoqProject b/examples/_CoqProject deleted file mode 100644 index 4fed14df7..000000000 --- a/examples/_CoqProject +++ /dev/null @@ -1,12 +0,0 @@ --Q ../template-coq/theories MetaCoq.Template --Q ../pcuic/theories MetaCoq.PCUIC --Q ../safechecker/theories MetaCoq.SafeChecker --Q ../erasure/theories MetaCoq.Erasure --R . MetaCoq.Examples - -demo.v -add_constructor.v -tauto.v -typing_correctness.v -metacoq_tour_prelude.v -metacoq_tour.v \ No newline at end of file diff --git a/examples/_CoqProject.in b/examples/_CoqProject.in new file mode 100644 index 000000000..c5492b0c2 --- /dev/null +++ b/examples/_CoqProject.in @@ -0,0 +1,9 @@ +-R . MetaCoq.Examples + +demo.v +constructor_tac.v +add_constructor.v +tauto.v +typing_correctness.v +metacoq_tour_prelude.v +metacoq_tour.v \ No newline at end of file diff --git a/examples/constructor_tac.v b/examples/constructor_tac.v new file mode 100644 index 000000000..31f58df31 --- /dev/null +++ b/examples/constructor_tac.v @@ -0,0 +1,43 @@ +From Coq Require Import List. +From MetaCoq.Template Require Import All Loader. +Import MCMonadNotation. +Open Scope bs. + +Definition constructor (goal : Ast.term): TemplateMonad typed_term := + let '(hd, iargs) := decompose_app goal in + match hd with + | Ast.tInd ind u => + qi <- tmQuoteInductive (inductive_mind ind) ;; + match nth_error qi.(Ast.Env.ind_bodies) (inductive_ind ind) with + | Some oib => + let cstrs := Ast.Env.ind_ctors oib in + match cstrs with + | [] => tmFail "no constructor in this inductive type" + | hd :: _ => + let args := cstr_args hd in + let params := firstn qi.(ind_npars) iargs in + let args := (params ++ map (fun _ => Ast.hole) args)%list in + let term := Ast.tApp (Ast.tConstruct ind 0 u) args in + term' <- tmEval all term ;; + tmUnquote term' + end + | None => tmFail "anomaly" + end + | _ => tmFail "goal is not an inductive type" + end. + +Ltac constructor_tac := + match goal with + |- ?T => + let k tm := refine tm.(my_projT2) in + unshelve quote_term T ltac:(fun gl => run_template_program (constructor gl) k) + end. + +Goal True. + constructor_tac. +Qed. + +Goal True + False. + repeat constructor_tac. +Qed. + diff --git a/examples/metacoq_tour_prelude.v b/examples/metacoq_tour_prelude.v index b068a0daa..a9cb95f4f 100644 --- a/examples/metacoq_tour_prelude.v +++ b/examples/metacoq_tour_prelude.v @@ -23,7 +23,8 @@ Definition univ := Level.Level "s". (* TODO move to SafeChecker *) Definition gctx : global_env_ext := - ({| universes := (LS.union (LevelSet.singleton Level.lzero) (LevelSet.singleton univ), ConstraintSet.empty); declarations := [] |}, Monomorphic_ctx). + ({| universes := (LS.union (LevelSet.singleton Level.lzero) (LevelSet.singleton univ), ConstraintSet.empty); + declarations := []; retroknowledge := Retroknowledge.empty |}, Monomorphic_ctx). (** We use the environment checker to produce the proof that gctx, which is a singleton with only universe "s" declared is well-formed. *) diff --git a/examples/typing_correctness.v b/examples/typing_correctness.v index 020950344..22c5d57e4 100644 --- a/examples/typing_correctness.v +++ b/examples/typing_correctness.v @@ -1,3 +1,68 @@ +(*From MetaCoq.Template Require Import config All. +From MetaCoq.PCUIC Require Import PCUICAst PCUICAstUtils PCUICTyping PCUICLiftSubst TemplateToPCUIC. +From MetaCoq.SafeChecker Require Import PCUICErrors PCUICWfEnv PCUICWfEnvImpl PCUICTypeChecker PCUICSafeChecker. +From Equations Require Import Equations. + + + + +Polymorphic Inductive list@{u} (A : Type@{u}) : Type@{u} := +(* | nil : list A *) +(* | cons : A -> list A -> list A *) +. + +Polymorphic Inductive rtree@{u} : Type@{u} := +| node : list rtree -> rtree. + +Universe u. + +Polymorphic Inductive empty@{u} : Type@{u} :=. + +Polymorphic Inductive unit@{u} : Type@{u} := tt. + +MetaCoq Quote Recursively Definition empty_sig_full_template := (fun (A : Type@{u}) (x : A) => x). +Definition empty_sig_full := trans_template_program empty_sig_full_template. + +MetaCoq Quote Recursively Definition empty_full_template := empty@{u}. +Definition empty_full := trans_template_program empty_full_template. + +MetaCoq Quote Recursively Definition unit_full_template := tt@{u}. +Definition unit_full := trans_template_program unit_full_template. + +MetaCoq Quote Recursively Definition list_full_template := list@{u}. +Definition list_full := trans_template_program list_full_template. + +MetaCoq Quote Recursively Definition rtree_full_template := rtree@{u}. +Definition rtree_full := trans_template_program rtree_full_template. + +Definition extract_gctx : PCUICProgram.pcuic_program -> global_env_ext := + fun p => (p.1.1.(PCUICProgram.trans_env_env), p.1.2). + +Definition gctx := Eval cbv in extract_gctx empty_full. (* Change here *) + +Global Program Instance fake_guard_impl : abstract_guard_impl := +{| guard_impl := fake_guard_impl |}. +Next Obligation. Admitted. + +Local Existing Instance PCUICSN.default_normalizing. +Import MCMonadNotation. + +Definition make_wf_env_ext (Σ : global_env_ext) : EnvCheck wf_env_ext wf_env_ext := + '(exist Σ' pf) <- check_wf_ext optimized_abstract_env_impl Σ ;; + ret Σ'. + +Local Existing Instance default_checker_flags. + +Definition gctx_wf_env : wf_env_ext. +Proof. + let wf_proof := eval hnf in (make_wf_env_ext gctx) in + match wf_proof with + | CorrectDecl _ ?x => exact x + | ?z => set (error := z) + (* idtac z ; fail "Couldn't prove the global environment is well-formed" *) + end. +Defined. +*) (* Distributed under the terms of the MIT license. *) From MetaCoq.Template Require Import config Universes Loader. From MetaCoq.PCUIC Require Import PCUICAst PCUICAstUtils PCUICTyping PCUICLiftSubst. @@ -23,7 +88,8 @@ Definition univ := Level.Level "s". (* TODO move to SafeChecker *) Definition gctx : global_env_ext := - ({| universes := (LS.union (LevelSet.singleton Level.lzero) (LevelSet.singleton univ), ConstraintSet.empty); declarations := [] |}, Monomorphic_ctx). + ({| universes := (LS.union (LevelSet.singleton Level.lzero) (LevelSet.singleton univ), ConstraintSet.empty); declarations := [] + ; retroknowledge := Retroknowledge.empty |}, Monomorphic_ctx). (** We use the environment checker to produce the proof that gctx, which is a singleton with only universe "s" declared is well-formed. *) @@ -86,7 +152,6 @@ Time Qed. *) Lemma identity_typing (u := Universe.make univ): -typing_result (∑ t : term, forall Σ0 : global_env_ext, Σ0 = @@ -94,7 +159,8 @@ typing_result universes := (LS.union (LevelSet.singleton Level.lzero) (LevelSet.singleton univ), ConstraintSet.empty); - declarations := [] + declarations := []; + retroknowledge := Retroknowledge.empty |}, Monomorphic_ctx) -> ∥ Σ0;;; [] |- t : tProd (bNamed "s") (tSort u) (tImpl (tRel 0) (tRel 0)) ∥). @@ -106,7 +172,7 @@ Proof. pose (T := tProd (bNamed "s") (tSort u) (tImpl (tRel 0) (tRel 0))). pose (Σ := gctx_wf_env). let t := uconstr:(check_inh Σ [] wfΓ impl (T:=T)) in - let proof := eval cbn in t in + let proof := eval hnf in t in match proof with | Checked ?d => exact_no_check d | TypeError ?e => @@ -115,7 +181,6 @@ Proof. | _ => set (blocked := proof) (* fail "Anomaly: unexpected return value: " proof *) end. - exact blocked. Defined. (* Print Opaque Dependencies identity_typing. *) diff --git a/html/config.js b/html/config.js new file mode 100644 index 000000000..211cbb228 --- /dev/null +++ b/html/config.js @@ -0,0 +1,72 @@ +var coqdocjs = coqdocjs || {}; + +coqdocjs.repl = { + "fun": "λ", + "forall": "∀", + "exists": "∃", + "~": "¬", + "/\\": "∧", + "\\/": "∨", + "->": "→", + "<-": "←", + "<->": "↔", + "=>": "⇒", + "<>": "≠", + "<=": "≤", + ">=": "≥", + "el": "∈", + "nel": "∉", + "<<=": "⊆", + "<<": "⊂", + "|-": "⊢", + "++": "⧺", + "===": "≡", + "=/=": "≢", + "=~=": "≅", + "==>": "⟹", + "lhd": "⊲", + "rhd": "⊳", + "nat": "ℕ", + "alpha": "α", + "beta": "β", + "gamma": "γ", + "delta": "δ", + "epsilon": "ε", + "eta": "η", + "iota": "ι", + "kappa": "κ", + "lambda": "λ", + "mu": "μ", + "nu": "ν", + "lia": "ω", + "phi": "ϕ", + "pi": "π", + "psi": "ψ", + "rho": "ρ", + "sigma": "σ", + "tau": "τ", + "theta": "θ", + "xi": "ξ", + "zeta": "ζ", + "Delta": "Δ", + "Gamma": "Γ", + "Pi": "Π", + "Sigma": "Σ", + "Lia": "Ω", + "Xi": "Ξ" +}; + +coqdocjs.subscr = { + "0" : "₀", + "1" : "₁", + "2" : "₂", + "3" : "₃", + "4" : "₄", + "5" : "₅", + "6" : "₆", + "7" : "₇", + "8" : "₈", + "9" : "₉", +}; + +coqdocjs.replInText = ["==>","<=>", "=>", "->", "<-", ":="]; diff --git a/html/coqdoc.css b/html/coqdoc.css index dbc930f5e..48096e555 100644 --- a/html/coqdoc.css +++ b/html/coqdoc.css @@ -230,6 +230,10 @@ tr.infrulemiddle hr { color: rgb(40%,0%,40%); } +.id[title="binder"] { + color: rgb(40%,0%,40%); +} + .id[type="definition"] { color: rgb(0%,40%,0%); } @@ -327,3 +331,8 @@ ul.doclist { margin-top: 0em; margin-bottom: 0em; } + +.code :target { + border: 2px solid #D4D4D4; + background-color: #e5eecc; +} diff --git a/html/coqdocjs.css b/html/coqdocjs.css new file mode 100644 index 000000000..575fc3dd0 --- /dev/null +++ b/html/coqdocjs.css @@ -0,0 +1,224 @@ +/* replace unicode */ + +.id[repl] .hidden { + font-size: 0; +} + +.id[repl]:before{ + content: attr(repl); +} + +/* folding proofs */ + +@keyframes show-proof { + 0% { + max-height: 1.2em; + opacity: 1; + } + 99% { + max-height: 1000em; + } + 100%{ + } +} + +@keyframes hide-proof { + from { + visibility: visible; + max-height: 10em; + opacity: 1; + } + to { + max-height: 1.2em; + } +} + +.proof { + cursor: pointer; +} +.proof * { + cursor: pointer; +} + +.proof { + overflow: hidden; + position: relative; + transition: opacity 1s; + display: inline-block; +} + +.proof[show="false"] { + max-height: 1.2em; + visibility: visible; + opacity: 0.3; +} + +.proof[show="false"][animate] { + animation-name: hide-proof; + animation-duration: 0.25s; +} + +.proof[show=true] { + animation-name: show-proof; + animation-duration: 10s; +} + +.proof[show="false"]:before { + position: absolute; + visibility: visible; + width: 100%; + height: 100%; + display: block; + opacity: 0; + content: "M"; +} +.proof[show="false"]:hover:before { + content: ""; +} + +.proof[show="false"] + br + br { + display: none; +} + +.proof[show="false"]:hover { + visibility: visible; + opacity: 0.5; +} + +#toggle-proofs[proof-status="no-proofs"] { + display: none; +} + +#toggle-proofs[proof-status="some-hidden"]:before { + content: "Show Proofs"; +} + +#toggle-proofs[proof-status="all-shown"]:before { + content: "Hide Proofs"; +} + + +/* page layout */ + +html, body { + height: 100%; + margin:0; + padding:0; +} + +body { + display: flex; + flex-direction: column +} + +#content { + flex: 1; + overflow: auto; + display: flex; + flex-direction: column; +} +#content:focus { + outline: none; /* prevent glow in OS X */ +} + +#main { + display: block; + padding: 16px; + padding-top: 1em; + padding-bottom: 2em; + margin-left: auto; + margin-right: auto; + max-width: 60em; + flex: 1 0 auto; +} + +.libtitle { + display: none; +} + +/* header */ +#header { + width:100%; + padding: 0; + margin: 0; + display: flex; + align-items: center; + background-color: rgb(21,57,105); + color: white; + font-weight: bold; + overflow: hidden; +} + + +.button { + cursor: pointer; +} + +#header * { + text-decoration: none; + vertical-align: middle; + margin-left: 15px; + margin-right: 15px; +} + +#header > .right, #header > .left { + display: flex; + flex: 1; + align-items: center; +} +#header > .left { + text-align: left; +} +#header > .right { + flex-direction: row-reverse; +} + +#header a, #header .button { + color: white; + box-sizing: border-box; +} + +#header a { + border-radius: 0; + padding: 0.2em; +} + +#header .button { + background-color: rgb(63, 103, 156); + border-radius: 1em; + padding-left: 0.5em; + padding-right: 0.5em; + margin: 0.2em; +} + +#header a:hover, #header .button:hover { + background-color: rgb(181, 213, 255); + color: black; +} + +#header h1 { padding: 0; + margin: 0;} + +/* footer */ +#footer { + text-align: center; + opacity: 0.5; + font-size: 75%; +} + +/* hyperlinks */ + +@keyframes highlight { + 50%{ + background-color: black; + } +} + +:target * { + animation-name: highlight; + animation-duration: 1s; +} + +a[name]:empty { + float: right; +} diff --git a/html/coqdocjs.js b/html/coqdocjs.js new file mode 100644 index 000000000..1a0b066d3 --- /dev/null +++ b/html/coqdocjs.js @@ -0,0 +1,184 @@ +var coqdocjs = coqdocjs || {}; +(function(){ + +function replace(s){ + var m; + if (m = s.match(/^(.+)'/)) { + return replace(m[1])+"'"; + } else if (m = s.match(/^([A-Za-z]+)_?(\d+)$/)) { + return replace(m[1])+m[2].replace(/\d/g, function(d){return coqdocjs.subscr[d]}); + } else if (coqdocjs.repl.hasOwnProperty(s)){ + return coqdocjs.repl[s] + } else { + return s; + } +} + +function toArray(nl){ + return Array.prototype.slice.call(nl); +} + +function replInTextNodes() { + coqdocjs.replInText.forEach(function(toReplace){ + toArray(document.getElementsByClassName("code")).concat(toArray(document.getElementsByClassName("inlinecode"))).forEach(function(elem){ + toArray(elem.childNodes).forEach(function(node){ + if (node.nodeType != Node.TEXT_NODE) return; + var fragments = node.textContent.split(toReplace); + node.textContent = fragments[fragments.length-1]; + for (var k = 0; k < fragments.length - 1; ++k) { + node.parentNode.insertBefore(document.createTextNode(fragments[k]),node); + var replacement = document.createElement("span"); + replacement.appendChild(document.createTextNode(toReplace)); + replacement.setAttribute("class", "id"); + replacement.setAttribute("type", "keyword"); + node.parentNode.insertBefore(replacement, node); + } + }); + }); + }); +} + +function replNodes() { + toArray(document.getElementsByClassName("id")).forEach(function(node){ + if (["var", "variable", "keyword", "notation", "definition", "inductive"].indexOf(node.getAttribute("type"))>=0){ + var text = node.textContent; + var replText = replace(text); + if(text != replText) { + node.setAttribute("repl", replText); + node.setAttribute("title", text); + var hidden = document.createElement("span"); + hidden.setAttribute("class", "hidden"); + while (node.firstChild) { + hidden.appendChild(node.firstChild); + } + node.appendChild(hidden); + } + } + }); +} + +function isVernacStart(l, t){ + t = t.trim(); + for(var s of l){ + if (t == s || t.startsWith(s+" ") || t.startsWith(s+".")){ + return true; + } + } + return false; +} + +function isProofStart(s){ + return isVernacStart(["Proof"], s); +} + +function isProofEnd(s){ + return isVernacStart(["Qed", "Admitted", "Defined", "Abort"], s); +} + +function proofStatus(){ + var proofs = toArray(document.getElementsByClassName("proof")); + if(proofs.length) { + for(var proof of proofs) { + if (proof.getAttribute("show") === "false") { + return "some-hidden"; + } + } + return "all-shown"; + } + else { + return "no-proofs"; + } +} + +function updateView(){ + document.getElementById("toggle-proofs").setAttribute("proof-status", proofStatus()); +} + +function foldProofs() { + var hasCommands = true; + var nodes = document.getElementsByClassName("command"); + if(nodes.length == 0) { + hasCommands = false; + console.log("no command tags found") + nodes = document.getElementsByClassName("id"); + } + toArray(nodes).forEach(function(node){ + if(isProofStart(node.textContent)) { + var proof = document.createElement("span"); + proof.setAttribute("class", "proof"); + + node.parentNode.insertBefore(proof, node); + if(proof.previousSibling.nodeType === Node.TEXT_NODE) + proof.appendChild(proof.previousSibling); + while(node && !isProofEnd(node.textContent)) { + proof.appendChild(node); + node = proof.nextSibling; + } + if (proof.nextSibling) proof.appendChild(proof.nextSibling); // the Qed + if (!hasCommands && proof.nextSibling) proof.appendChild(proof.nextSibling); // the dot after the Qed + + proof.addEventListener("click", function(proof){return function(e){ + if (e.target.parentNode.tagName.toLowerCase() === "a") + return; + proof.setAttribute("show", proof.getAttribute("show") === "true" ? "false" : "true"); + proof.setAttribute("animate", ""); + updateView(); + };}(proof)); + proof.setAttribute("show", "false"); + } + }); +} + +function toggleProofs(){ + var someProofsHidden = proofStatus() === "some-hidden"; + toArray(document.getElementsByClassName("proof")).forEach(function(proof){ + proof.setAttribute("show", someProofsHidden); + proof.setAttribute("animate", ""); + }); + updateView(); +} + +function repairDom(){ + // pull whitespace out of command + toArray(document.getElementsByClassName("command")).forEach(function(node){ + while(node.firstChild && node.firstChild.textContent.trim() == ""){ + console.log("try move"); + node.parentNode.insertBefore(node.firstChild, node); + } + }); + toArray(document.getElementsByClassName("id")).forEach(function(node){ + node.setAttribute("type", node.getAttribute("title")); + }); + toArray(document.getElementsByClassName("idref")).forEach(function(ref){ + toArray(ref.childNodes).forEach(function(child){ + if (["var", "variable"].indexOf(child.getAttribute("type")) > -1) + ref.removeAttribute("href"); + }); + }); + +} + +function fixTitle(){ + var url = "/" + window.location.pathname; + var modulename = "." + url.substring(url.lastIndexOf('/')+1, url.lastIndexOf('.')); + modulename = modulename.substring(modulename.lastIndexOf('.')+1); + if (modulename === "toc") {modulename = "Table of Contents";} + else if (modulename === "indexpage") {modulename = "Index";} + else {modulename = modulename + ".v";}; + document.title = modulename; +} + +function postprocess(){ + repairDom(); + replInTextNodes() + replNodes(); + foldProofs(); + document.getElementById("toggle-proofs").addEventListener("click", toggleProofs); + updateView(); +} + +fixTitle(); +document.addEventListener('DOMContentLoaded', postprocess); + +coqdocjs.toggleProofs = toggleProofs; +})(); diff --git a/html/resources/footer.html b/html/resources/footer.html new file mode 100644 index 000000000..d0f79a884 --- /dev/null +++ b/html/resources/footer.html @@ -0,0 +1,8 @@ + +

+ + + + diff --git a/html/resources/header.html b/html/resources/header.html new file mode 100644 index 000000000..cc81721b4 --- /dev/null +++ b/html/resources/header.html @@ -0,0 +1,27 @@ + + + + + + + + + + + + + +
+
diff --git a/make-opam-files.sh b/make-opam-files.sh new file mode 100755 index 000000000..be6bb62a5 --- /dev/null +++ b/make-opam-files.sh @@ -0,0 +1,23 @@ +#/usr/bin/env bash +echo "Target directory: " $1 +echo "Target version: " $2 +echo "Releases package: " $3 + +wget $3 +archive=`basename $3` +hash=`shasum -a 512 $archive | cut -f 1 -d " "` + +echo "Shasum = " $hash + +for f in *.opam; +do + opamf=${f/.opam/}; + target=$1/$opamf/$opamf.$2/opam; + echo $opamf; + mkdir $1/$opamf/$opamf.$2 + gsed -e "/^version:.*/d" $f > $target + echo url { >> $target + echo " src:" \"$3\" >> $target + echo " checksum:" \"sha512=$hash\" >> $target + echo } >> $target +done \ No newline at end of file diff --git a/pcuic/theories/Bidirectional/BDFromPCUIC.v b/pcuic/theories/Bidirectional/BDFromPCUIC.v index abd5f9a09..6d5f18112 100644 --- a/pcuic/theories/Bidirectional/BDFromPCUIC.v +++ b/pcuic/theories/Bidirectional/BDFromPCUIC.v @@ -372,6 +372,10 @@ Proof. intros ? [? s]. by apply conv_check in s ; auto. + - intros p prim_ty cdecl wfΓ' hp hdecl pinv. + eexists. split; [econstructor; tea|]. + eapply ws_cumul_pb_refl; fvs. + - intros ? ? ? ? ? ? (?&?&?) ? (?&?&?) ?. eexists. split. diff --git a/pcuic/theories/Bidirectional/BDStrengthening.v b/pcuic/theories/Bidirectional/BDStrengthening.v index 005c0fd6e..9a406d9b6 100644 --- a/pcuic/theories/Bidirectional/BDStrengthening.v +++ b/pcuic/theories/Bidirectional/BDStrengthening.v @@ -467,6 +467,7 @@ Section OnFreeVars. by move: Hmfix => /andP []. - easy. + - easy. - intros ? ? ? ? ? ? _ HT Hred. intros ? HΓ Ht. @@ -857,6 +858,9 @@ Proof using wfΣ. by rewrite shiftnP0. + by apply rename_wf_cofixpoint. + - intros. red. intros P Δ f hf ht. + cbn. econstructor; tea. + - intros. red. intros P Δ f hf ht. econstructor ; eauto. rewrite -/(rename f (tSort u)). diff --git a/pcuic/theories/Bidirectional/BDToPCUIC.v b/pcuic/theories/Bidirectional/BDToPCUIC.v index 52f57b9ab..bb53ce6a2 100644 --- a/pcuic/theories/Bidirectional/BDToPCUIC.v +++ b/pcuic/theories/Bidirectional/BDToPCUIC.v @@ -413,6 +413,9 @@ Section BDToPCUICTyping. apply weakening. all: auto. + - red; intros. + now econstructor. + - red ; intros. now eapply type_reduction. diff --git a/pcuic/theories/Bidirectional/BDTyping.v b/pcuic/theories/Bidirectional/BDTyping.v index 527ec59d4..3ed6180ca 100644 --- a/pcuic/theories/Bidirectional/BDTyping.v +++ b/pcuic/theories/Bidirectional/BDTyping.v @@ -120,6 +120,12 @@ Inductive infering `{checker_flags} (Σ : global_env_ext) (Γ : context) : term wf_cofixpoint Σ mfix -> Σ ;;; Γ |- tCoFix mfix n ▹ dtype decl +| infer_Prim p prim_ty cdecl : + primitive_constant Σ (prim_val_tag p) = Some prim_ty -> + declared_constant Σ prim_ty cdecl -> + primitive_invariants cdecl -> + Σ ;;; Γ |- tPrim p ▹ tConst prim_ty [] + with infering_sort `{checker_flags} (Σ : global_env_ext) (Γ : context) : term -> Universe.t -> Type := | infer_sort_Sort t T u: Σ ;;; Γ |- t ▹ T -> @@ -438,6 +444,12 @@ Section BidirectionalInduction. wf_cofixpoint Σ mfix -> Pinfer Γ (tCoFix mfix n) (dtype decl)) -> + (forall (Γ : context) p prim_ty cdecl, + primitive_constant Σ (prim_val_tag p) = Some prim_ty -> + declared_constant Σ prim_ty cdecl -> + primitive_invariants cdecl -> + Pinfer Γ (tPrim p) (tConst prim_ty [])) -> + (forall (Γ : context) (t T : term) (u : Universe.t), Σ ;;; Γ |- t ▹ T -> Pinfer Γ t T -> @@ -466,7 +478,7 @@ Section BidirectionalInduction. env_prop_bd. Proof using Type. intros Pdecl_check Pdecl_sort Pdecl_check_rel Pdecl_sort_rel HΓ HΓRel HRel HSort HProd HLambda HLetIn HApp HConst HInd HConstruct HCase - HProj HFix HCoFix HiSort HiProd HiInd HCheck ; unfold env_prop_bd. + HProj HFix HCoFix HPrim HiSort HiProd HiInd HCheck ; unfold env_prop_bd. pose (@Fix_F typing_sum (precompose lt typing_sum_size) Ptyping_sum) as p. forward p. 2:{ @@ -667,6 +679,8 @@ Section BidirectionalInduction. apply IH. cbn. lia. + - unshelve eapply HPrim; eauto. + - destruct i. unshelve (eapply HiSort ; try eassumption) ; try eassumption. all:applyIH. diff --git a/pcuic/theories/Bidirectional/BDUnique.v b/pcuic/theories/Bidirectional/BDUnique.v index 1cf71de61..c58ee1d3d 100644 --- a/pcuic/theories/Bidirectional/BDUnique.v +++ b/pcuic/theories/Bidirectional/BDUnique.v @@ -56,7 +56,7 @@ Proof using wfΣ. all: intros ; red ; auto. 1-9,11-13: intros ? T' ty_T' ; inversion_clear ty_T'. - 14-16: intros. + 14-17: intros. - rewrite H in H0. inversion H0. subst. clear H0. @@ -225,6 +225,12 @@ Proof using wfΣ. * fvs. * now eapply type_is_open_term, infering_typing. + - inversion X1; subst. + rewrite H in H2; noconf H2. + have eq := (declared_constant_inj _ _ H0 H3); subst cdecl0. + exists (tConst prim_ty []). + split; eapply closed_red_refl; fvs. + - inversion X3 ; subst. eapply X0 in X4 as [T'' []]; subst ; tea. eapply into_closed_red in X1 ; fvs. diff --git a/pcuic/theories/PCUICAlpha.v b/pcuic/theories/PCUICAlpha.v index bc86190c2..f5a612243 100644 --- a/pcuic/theories/PCUICAlpha.v +++ b/pcuic/theories/PCUICAlpha.v @@ -994,6 +994,8 @@ Section Alpha. now apply infer_typing_sort_impl with id ihmfix; intros []. + apply eq_term_upto_univ_cumulSpec, eq_term_leq_term, upto_names_impl_eq_term. now symmetry. + - intros p prim_ty cdecl IH prim decl pinv Δ v e e'. + depelim e. econstructor; tea. now apply IH. - intros t A B X wf ht iht har ihar hcu Δ v e e'. eapply (type_ws_cumul_pb (pb:=Cumul)). diff --git a/pcuic/theories/PCUICAst.v b/pcuic/theories/PCUICAst.v index 61996e02b..68b2fc9b1 100644 --- a/pcuic/theories/PCUICAst.v +++ b/pcuic/theories/PCUICAst.v @@ -206,9 +206,8 @@ Inductive term := | tCase (indn : case_info) (p : predicate term) (c : term) (brs : list (branch term)) | tProj (p : projection) (c : term) | tFix (mfix : mfixpoint term) (idx : nat) -| tCoFix (mfix : mfixpoint term) (idx : nat). -(** We use faithful models of primitive type values in PCUIC *) -(* | tPrim (prim : prim_val term). *) +| tCoFix (mfix : mfixpoint term) (idx : nat) +| tPrim (prim : prim_val term). Derive NoConfusion for term. @@ -487,7 +486,7 @@ Instance subst_instance_constr : UnivSubst term := | tCoFix mfix idx => let mfix' := List.map (map_def (subst_instance_constr u) (subst_instance_constr u)) mfix in tCoFix mfix' idx - (* | tPrim _ => c *) + | tPrim _ => c end. (** Tests that the term is closed over [k] universe variables *) diff --git a/pcuic/theories/PCUICCanonicity.v b/pcuic/theories/PCUICCanonicity.v index 56b1e9ace..3616c78ee 100644 --- a/pcuic/theories/PCUICCanonicity.v +++ b/pcuic/theories/PCUICCanonicity.v @@ -556,205 +556,8 @@ Qed. - subst concl; eapply typing_spine_more_inv in sp; try lia. Qed. - (* Lemma app_fix_prod_indarg Σ mfix idx args na dom codom decl : - wf Σ.1 -> - Σ ;;; [] |- mkApps (tFix mfix idx) args : tProd na dom codom -> - nth_error mfix idx = Some decl -> - #|args| = decl.(rarg) -> - ∑ ind u indargs, dom = mkApps (tInd ind u) indargs * - isType Σ [] (mkApps (tInd ind u) indargs) * - (check_recursivity_kind Σ.1 (inductive_mind ind) Finite). - Proof. - intros wfΣ tapp. - eapply inversion_mkApps in tapp as [A [Hfix Hargs]]; eauto. - eapply inversion_Fix in Hfix;eauto. - destruct Hfix as [decl [fixg [Hnth [Hist [_ [wf cum]]]]]]. - rewrite /wf_fixpoint in wf. *) - End Spines. -(* -Section Normalization. - Context {cf:checker_flags} (Σ : global_env_ext). - Context {wfΣ : wf Σ}. - - Section reducible. - Lemma reducible Γ t : sum (∑ t', red1 Σ Γ t t') (forall t', red1 Σ Γ t t' -> False). - Proof. - Local Ltac lefte := left; eexists; econstructor; eauto. - Local Ltac leftes := left; eexists; econstructor; solve [eauto]. - Local Ltac righte := right; intros t' red; depelim red; solve_discr; eauto 2. - induction t in Γ |- * using term_forall_list_ind. - (*all:try solve [righte]. - - destruct (nth_error Γ n) eqn:hnth. - destruct c as [na [b|] ty]; [lefte|righte]. - * rewrite hnth; reflexivity. - * rewrite hnth /= // in e. - * righte. rewrite hnth /= // in e. - - admit. - - destruct (IHt1 Γ) as [[? ?]|]; [lefte|]. - destruct (IHt2 (Γ ,, vass n t1)) as [[? ?]|]; [|righte]. - leftes. - - destruct (IHt1 Γ) as [[? ?]|]; [lefte|]. - destruct (IHt2 (Γ ,, vass n t1)) as [[? ?]|]; [|righte]. - leftes. - - destruct (IHt1 Γ) as [[? ?]|]; [lefte|]. - destruct (IHt2 Γ) as [[? ?]|]; [lefte|]. - destruct (IHt3 (Γ ,, vdef n t1 t2)) as [[? ?]|]; [|]. - leftes. lefte. - - destruct (IHt1 Γ) as [[? ?]|]; [lefte|]. - destruct (IHt2 Γ) as [[? ?]|]; [leftes|]. - destruct (PCUICParallelReductionConfluence.view_lambda_fix_app t1 t2). - * rewrite [tApp _ _](mkApps_app _ _ [a]). - destruct (unfold_fix mfix i) as [[rarg body]|] eqn:unf. - destruct (is_constructor rarg (l ++ [a])) eqn:isc; [leftes|]; eauto. - right => t' red; depelim red; solve_discr; eauto. - rewrite mkApps_app in H. noconf H. eauto. - rewrite mkApps_app in H. noconf H. eauto. - eapply (f_equal (@length _)) in H1. rewrite /= app_length /= // in H1; lia. - eapply (f_equal (@length _)) in H1. rewrite /= app_length /= // in H1; lia. - righte; try (rewrite mkApps_app in H; noconf H); eauto. - eapply (f_equal (@length _)) in H1. rewrite /= app_length /= // in H1; lia. - eapply (f_equal (@length _)) in H1. rewrite /= app_length /= // in H1; lia. - * admit. - * righte. destruct args using rev_case; solve_discr; noconf H. - rewrite H in i. eapply negb_False; eauto. - rewrite mkApps_app; eapply isFixLambda_app_mkApps' => //. - - admit. - - admit. - - admit. - - admit. - - admit.*) - - Qed. - End reducible. - - Lemma reducible' Γ t : sum (∑ t', red1 Σ Γ t t') (normal Σ Γ t). - Proof. - Ltac lefte := left; eexists; econstructor; eauto. - Ltac leftes := left; eexists; econstructor; solve [eauto]. - Ltac righte := right; (solve [repeat (constructor; eauto)])||(repeat constructor). - induction t in Γ |- * using term_forall_list_ind. - all:try solve [righte]. - - destruct (nth_error Γ n) eqn:hnth. - destruct c as [na [b|] ty]; [lefte|]. - * rewrite hnth; reflexivity. - * right. do 2 constructor; rewrite hnth /= //. - * righte. rewrite hnth /= //. - - admit. - - destruct (IHt1 Γ) as [[? ?]|]; [lefte|]. - destruct (IHt2 (Γ ,, vass n t1)) as [[? ?]|]; [|]. - leftes. right; solve[constructor; eauto]. - - destruct (IHt1 Γ) as [[? ?]|]; [lefte|]. - destruct (IHt2 (Γ ,, vass n t1)) as [[? ?]|]; [leftes|leftes]. - - destruct (IHt1 Γ) as [[? ?]|]; [lefte|]. - destruct (IHt2 Γ) as [[? ?]|]; [leftes|]. - destruct (PCUICParallelReductionConfluence.view_lambda_fix_app t1 t2). - * rewrite [tApp _ _](mkApps_app _ _ [a]). - destruct (unfold_fix mfix i) as [[rarg body]|] eqn:unf. - destruct (is_constructor rarg (l ++ [a])) eqn:isc; [leftes|]; eauto. - right; constructor. rewrite mkApps_app. constructor. admit. admit. admit. - * admit. - * admit. - - admit. - - admit. - - admit. - - admit. - - admit. - Qed. - - Lemma normalizer {Γ t ty} : - Σ ;;; Γ |- t : ty -> - ∑ nf, (red Σ.1 Γ t nf) * normal Σ Γ nf. - Proof. - intros Hty. - unshelve epose proof (PCUICSN.normalisation Σ Γ t (iswelltyped _ _ _ ty Hty)). - clear ty Hty. - move: t H. eapply Fix_F. - intros x IH. - destruct (reducible' Γ x) as [[t' red]|nred]. - specialize (IH t'). forward IH by (constructor; auto). - destruct IH as [nf [rednf norm]]. - exists nf; split; auto. now transitivity t'. - exists x. split; [constructor|assumption]. - Qed. - - Derive Signature for neutral normal. - - Lemma typing_var {Γ n ty} : Σ ;;; Γ |- (tVar n) : ty -> False. - Proof. intros Hty; depind Hty; eauto. Qed. - - Lemma typing_evar {Γ n l ty} : Σ ;;; Γ |- (tEvar n l) : ty -> False. - Proof. intros Hty; depind Hty; eauto. Qed. - - Definition axiom_free Σ := - forall c decl, declared_constant Σ c decl -> cst_body decl <> None. - - Lemma neutral_empty t ty : axiom_free Σ -> Σ ;;; [] |- t : ty -> neutral Σ [] t -> False. - Proof. - intros axfree typed ne. - pose proof (PCUICClosed.subject_closed wfΣ typed) as cl. - depind ne. - - now simpl in cl. - - now eapply typing_var in typed. - - now eapply typing_evar in typed. - - eapply inversion_Const in typed as [decl [wfd [declc [cu cum]]]]; eauto. - specialize (axfree _ _ declc). specialize (H decl). - destruct (cst_body decl); try congruence. - now specialize (H t declc eq_refl). - - simpl in cl; move/andP: cl => [clf cla]. - eapply inversion_App in typed as [na [A [B [Hf _]]]]; eauto. - - simpl in cl; move/andP: cl => [/andP[_ clc] _]. - eapply inversion_Case in typed; pcuicfo eauto. - - eapply inversion_Proj in typed; pcuicfo auto. - Qed. - - Lemma ind_normal_constructor t i u args : - axiom_free Σ -> - Σ ;;; [] |- t : mkApps (tInd i u) args -> normal Σ [] t -> construct_cofix_discr (head t). - Proof. - intros axfree Ht capp. destruct capp. - - eapply neutral_empty in H; eauto. - - eapply inversion_Sort in Ht as (? & ? & ? & ? & ?); auto. - eapply ws_cumul_pb_Sort_l_inv in c as (? & ? & ?). - eapply invert_red_mkApps_tInd in r as (? & eq & ?); eauto; eauto. - solve_discr. - - eapply inversion_Prod in Ht as (? & ? & ? & ? & ?); auto. - eapply ws_cumul_pb_Sort_l_inv in c as (? & ? & ?). - eapply invert_red_mkApps_tInd in r as (? & eq & ?); eauto; eauto. - solve_discr. - - eapply inversion_Lambda in Ht as (? & ? & ? & ? & ?); auto. - eapply ws_cumul_pb_Prod_l_inv in c as (? & ? & ? & (? & ?) & ?); auto. - eapply invert_red_mkApps_tInd in r as (? & eq & ?); eauto; eauto. - solve_discr. - - now rewrite head_mkApps /= /head /=. - - eapply PCUICValidity.inversion_mkApps in Ht as (? & ? & ?); auto. - eapply inversion_Ind in t as (? & ? & ? & decli & ? & ?); auto. - eapply PCUICSpine.typing_spine_strengthen in t0; eauto. - pose proof (on_declared_inductive wfΣ as decli) [onind oib]. - rewrite oib.(ind_arity_eq) in t0. - rewrite !subst_instance_it_mkProd_or_LetIn in t0. - eapply typing_spine_arity_mkApps_Ind in t0; eauto. - eexists; split; [sq|]; eauto. - now do 2 eapply isArity_it_mkProd_or_LetIn. - - admit. (* wf of fixpoints *) - - now rewrite /head /=. - Qed. - - Lemma red_normal_constructor t i u args : - axiom_free Σ -> - Σ ;;; [] |- t : mkApps (tInd i u) args -> - ∑ hnf, (red Σ.1 [] t hnf) * construct_cofix_discr (head hnf). - Proof. - intros axfree Ht. destruct (normalizer Ht) as [nf [rednf capp]]. - exists nf; split; auto. - eapply subject_reduction in Ht; eauto. - now eapply ind_normal_constructor. - Qed. - -End Normalization. -*) - (** Evaluation is a subrelation of reduction: *) Tactic Notation "redt" uconstr(y) := eapply (CRelationClasses.transitivity (R:=red _ _) (y:=y)). @@ -968,6 +771,56 @@ Section WeakNormalization. Σ ;;; [] |- t : ty -> False. Proof. eauto using wh_neutral_empty_gen. Qed. + + Require Import Equations.Type.Relation_Properties. + + (* TODO move *) + Lemma invert_red_axiom {Γ cst u cdecl T} : + declared_constant Σ cst cdecl -> + cst_body cdecl = None -> + Σ ;;; Γ ⊢ tConst cst u ⇝ T -> + T = tConst cst u. + Proof using wfΣ. + intros hdecl hb. + generalize_eq x (tConst cst u). + move=> e [clΓ clt] red. + revert cst u hdecl hb e. + eapply clos_rt_rt1n_iff in red. + induction red; simplify_dep_elim. + - reflexivity. + - depelim r; solve_discr. congruence. + Qed. + + Lemma ws_cumul_pb_Axiom_l_inv {pb Γ cst u cdecl T} : + declared_constant Σ cst cdecl -> + cst_body cdecl = None -> + Σ ;;; Γ ⊢ tConst cst u ≤[pb] T -> + ∑ u', Σ ;;; Γ ⊢ T ⇝ tConst cst u' × PCUICEquality.R_universe_instance (eq_universe Σ) u u'. + Proof using wfΣ. + intros hdecl hb H. + eapply ws_cumul_pb_red in H as (v & v' & [tv tv' eqp]). + epose proof (invert_red_axiom hdecl hb tv). subst v. + depelim eqp. + exists u'. split => //. + Qed. + + Lemma invert_cumul_axiom_ind {Γ cst cdecl u ind u' args} : + declared_constant Σ cst cdecl -> + cst_body cdecl = None -> + Σ ;;; Γ ⊢ tConst cst u ≤ mkApps (tInd ind u') args -> False. + Proof using wfΣ. + intros hd hb ht; eapply ws_cumul_pb_Axiom_l_inv in ht as (u'' & hred & hcmp); eauto. + eapply invert_red_mkApps_tInd in hred as (? & []); auto. solve_discr. + Qed. + + Lemma invert_cumul_axiom_prod {Γ cst cdecl u na dom codom} : + declared_constant Σ cst cdecl -> + cst_body cdecl = None -> + Σ ;;; Γ ⊢ tConst cst u ≤ tProd na dom codom -> False. + Proof using wfΣ. + intros hd hb ht; eapply ws_cumul_pb_Axiom_l_inv in ht as (u'' & hred & hcmp); eauto. + eapply invert_red_prod in hred as (? & ? & []); auto. discriminate. + Qed. Lemma wh_normal_ind_discr t i u args : axiom_free_value Σ [] t -> @@ -989,7 +842,9 @@ Section WeakNormalization. - exfalso; eapply invert_ind_ind; eauto. - exfalso; eapply invert_fix_ind; eauto. - now rewrite head_mkApps /head /=. - (* - now eapply inversion_Prim in typed. *) + - eapply inversion_Prim in typed as [prim_ty [cdecl [? ? ? [? hp]]]]; eauto. + eapply invert_cumul_axiom_ind in w; eauto. + apply hp. Qed. Lemma whnf_ind_finite t ind u indargs : diff --git a/pcuic/theories/PCUICCumulProp.v b/pcuic/theories/PCUICCumulProp.v index 5ed924225..def617b1d 100644 --- a/pcuic/theories/PCUICCumulProp.v +++ b/pcuic/theories/PCUICCumulProp.v @@ -1097,7 +1097,7 @@ Proof using Hcf Hcf'. [ H : leq_term_napp _ _ _ _ |- _ ] => depelim H end; assert (wf_ext Σ) by (split; assumption). - 14:{ assert (wf_ext Σ) by (split; assumption). specialize (X1 _ _ H X5 _ X6). + 15:{ assert (wf_ext Σ) by (split; assumption). specialize (X1 _ _ H X5 _ X6). eapply cumul_prop_cum_l; tea. eapply cumulSpec_cumulAlgo_curry in X4; tea; fvs. } @@ -1315,6 +1315,10 @@ Proof using Hcf Hcf'. { now eapply cumul_prop_is_open in cum as []. } eapply eq_term_eq_term_prop_impl; eauto. now symmetry in a. + + - depelim X2. + eapply inversion_Prim in X1 as [prim_ty' [cdecl' []]]; tea. + rewrite H in e. noconf e. eapply cumul_cumul_prop; eauto. pcuic. Qed. End no_prop_leq_type. diff --git a/pcuic/theories/PCUICEquality.v b/pcuic/theories/PCUICEquality.v index ff3b500b6..dc1e8f158 100644 --- a/pcuic/theories/PCUICEquality.v +++ b/pcuic/theories/PCUICEquality.v @@ -360,7 +360,7 @@ Inductive eq_term_upto_univ_napp Σ (Re Rle : Universe.t -> Universe.t -> Prop) ) mfix mfix' -> Σ ⊢ tCoFix mfix idx <==[ Rle , napp ] tCoFix mfix' idx -(* | eq_Prim i : eq_term_upto_univ_napp Σ Re Rle napp (tPrim i) (tPrim i) *) +| eq_Prim i : eq_term_upto_univ_napp Σ Re Rle napp (tPrim i) (tPrim i) where " Σ ⊢ t <==[ Rle , napp ] u " := (eq_term_upto_univ_napp Σ _ Rle napp t u) : type_scope. Notation eq_term_upto_univ Σ Re Rle := (eq_term_upto_univ_napp Σ Re Rle 0). @@ -1291,7 +1291,7 @@ Proof. eapply eq_term_upto_univ_trans; exact _. Qed. -(* todo: rename *) +(* TODO: rename *) (* Definition nleq_term t t' := *) (* eqb_term_upto_univ eqb eqb t t'. *) diff --git a/pcuic/theories/PCUICEtaExpand.v b/pcuic/theories/PCUICEtaExpand.v index 2eafbe40f..b098cafa9 100644 --- a/pcuic/theories/PCUICEtaExpand.v +++ b/pcuic/theories/PCUICEtaExpand.v @@ -1,3 +1,5 @@ +From Coq Require Import ssreflect. +From Equations Require Import Equations. From MetaCoq.PCUIC Require Import PCUICAst PCUICAstUtils PCUICTyping PCUICProgram TemplateToPCUIC. Definition isConstruct t := @@ -46,7 +48,8 @@ Inductive expanded (Γ : list nat) : term -> Prop := declared_constructor Σ (ind, c) mind idecl cdecl -> #|args| >= (ind_npars mind + context_assumptions (cstr_args cdecl)) -> Forall (expanded Γ) args -> - expanded Γ (mkApps (tConstruct ind c u) args). + expanded Γ (mkApps (tConstruct ind c u) args) +| expanded_tPrim p : expanded Γ (tPrim p). End expanded. Derive Signature for expanded. @@ -119,9 +122,10 @@ Lemma expanded_ind : declared_constructor Σ (ind, c) mind idecl cdecl -> #|args| >= ind_npars mind + context_assumptions (cstr_args cdecl) -> Forall (expanded Σ Γ) args -> Forall (P Γ) args -> P Γ (mkApps (tConstruct ind c u) args)) -> + (forall Γ p, P Γ (tPrim p)) -> forall (Γ : list nat) (t : term), expanded Σ Γ t -> P Γ t. Proof. - intros Σ P HRel HVar HEvar HSort HProd HLamdba HLetIn HApp HConst HInd HCase HProj HFix HCoFix HConstruct. + intros Σ P HRel HVar HEvar HSort HProd HLamdba HLetIn HApp HConst HInd HCase HProj HFix HCoFix HConstruct HPrim. fix f 3. intros Γ t Hexp. destruct Hexp; eauto. - eapply HRel; eauto. clear - f H0. induction H0; econstructor; eauto. @@ -146,6 +150,8 @@ Proof. clear - H1 f. induction H1; econstructor; eauto. Qed. +From MetaCoq.PCUIC Require Import PCUICInductiveInversion PCUICLiftSubst PCUICSigmaCalculus. + Record expanded_constant_decl Σ (cb : constant_body) : Prop := { expanded_body : on_Some_or_None (expanded Σ []) cb.(cst_body); }. (* expanded_type : expanded Σ [] cb.(Ast.Env.cst_type) }. *) @@ -169,24 +175,19 @@ Definition expanded_decl Σ d := | InductiveDecl idecl => expanded_minductive_decl Σ idecl end. -Inductive expanded_global_declarations (univs : ContextSet.t) : forall (Σ : global_declarations), Prop := -| expanded_global_nil : expanded_global_declarations univs [] -| expanded_global_cons decl Σ : expanded_global_declarations univs Σ -> - expanded_decl {| universes := univs; declarations := Σ |} decl.2 -> - expanded_global_declarations univs (decl :: Σ). +Inductive expanded_global_declarations (univs : ContextSet.t) retro : forall (Σ : global_declarations), Prop := +| expanded_global_nil : expanded_global_declarations univs retro [] +| expanded_global_cons decl Σ : expanded_global_declarations univs retro Σ -> + expanded_decl {| universes := univs; declarations := Σ; retroknowledge := retro |} decl.2 -> + expanded_global_declarations univs retro (decl :: Σ). Definition expanded_global_env (g : global_env) := - expanded_global_declarations g.(universes) g.(declarations). + expanded_global_declarations g.(universes) g.(retroknowledge) g.(declarations). Definition expanded_pcuic_program (p : pcuic_program) := expanded_global_env p.1 /\ expanded p.1 [] p.2. -From Coq Require Import ssreflect. -From Equations Require Import Equations. - -From MetaCoq.PCUIC Require Import PCUICInductiveInversion PCUICLiftSubst PCUICSigmaCalculus. - Lemma All_tip {A} {P : A -> Type} {a : A} : P a <~> All P [a]. Proof. split; intros. repeat constructor; auto. now depelim X. Qed. diff --git a/pcuic/theories/PCUICExchange.v b/pcuic/theories/PCUICExchange.v deleted file mode 100644 index 4c028d39a..000000000 --- a/pcuic/theories/PCUICExchange.v +++ /dev/null @@ -1,260 +0,0 @@ - -(* Distributed under the terms of the MIT license. *) -From Coq Require Import Morphisms. -From MetaCoq.Template Require Import config utils. -From MetaCoq.PCUIC Require Import PCUICAst PCUICAstUtils PCUICCases PCUICInduction - PCUICLiftSubst PCUICUnivSubst PCUICEquality PCUICTyping PCUICWeakeningEnv - PCUICClosed PCUICReduction PCUICPosition PCUICGeneration - PCUICSigmaCalculus PCUICRename PCUICOnFreeVars. - -Require Import ssreflect ssrbool. -From Equations Require Import Equations. - -Implicit Types cf : checker_flags. - -(* l, r, p -> r, l, p *) -Definition exchange_renaming l r p := - fun i => - if p <=? i then - if p + r <=? i then - if p + r + l <=? i then i - else i - r - else i + l - else i. - -Variant exchange_renaming_spec l r p i : nat -> Type := -| exch_below : i < p -> exchange_renaming_spec l r p i i -| exch_right : p <= i < p + r -> exchange_renaming_spec l r p i (i + l) -| exch_left : p + r <= i < p + r + l -> exchange_renaming_spec l r p i (i - r) -| exch_above : p + r + l <= i -> exchange_renaming_spec l r p i i. - -Lemma exchange_renamingP l r p i : - exchange_renaming_spec l r p i (exchange_renaming l r p i). -Proof. - unfold exchange_renaming. - case: leb_spec_Set; [|constructor; auto]. - elim: leb_spec_Set; [|constructor; auto]. - elim: leb_spec_Set; [|constructor; auto]. - intros. - constructor 4; auto. -Qed. - -Lemma shiftn_exchange_renaming n l r p : - shiftn n (exchange_renaming l r p) =1 - exchange_renaming l r (n + p). -Proof. - intros i. - case: exchange_renamingP. - * case: shiftnP; try lia. - case: exchange_renamingP; lia. - * case: shiftnP; try lia. - case: exchange_renamingP; lia. - * case: shiftnP; try lia. - case: exchange_renamingP; lia. - * case: shiftnP; try lia. - case: exchange_renamingP; lia. -Qed. - -Lemma exchange_renaming_lift_renaming l r p i k : - i < p -> - exchange_renaming l r p (lift_renaming (S i) 0 k) = - lift_renaming (S i) 0 - (shiftn (p - S i) (exchange_renaming l r 0) k). -Proof. - intros ip. - rewrite shiftn_exchange_renaming. - rewrite /lift_renaming /=. - case: exchange_renamingP; try lia; intros Hp. - all: case: exchange_renamingP; lia. -Qed. - -Definition exchange_contexts Γ Γl Γr Δ := - (Γ ,,, rename_context (strengthen 0 #|Γl|) Γr ,,, - rename_context (lift_renaming #|Γr| 0) Γl ,,, - rename_context (exchange_renaming #|Γl| #|Γr| 0) Δ). - -Definition exchange_rename Γl Γr Δ i := - if Δ <=? i then - if Δ + Γr <=? i then - if Δ + Γr + Γl <=? i then ren_id - else (lift_renaming Γr (Γl - S (i - Γr - Δ))) - else (shiftn (Γr - S (i - Δ)) (strengthen 0 Γl)) - else (exchange_renaming Γl Γr (Δ - S i)). - -Lemma lookup_exchange_contexts Γ Γl Γr Δ i : - nth_error (exchange_contexts Γ Γl Γr Δ) (exchange_renaming #|Γl| #|Γr| #|Δ| i) = - option_map (map_decl (rename (exchange_rename #|Γl| #|Γr| #|Δ| i))) - (nth_error (Γ ,,, Γl,,, Γr,,, Δ) i). -Proof. - rewrite /exchange_renaming /exchange_contexts /exchange_rename. - case: (leb_spec_Set #|Δ| i) => hΔ. - * case: leb_spec_Set => hΓr. - + case: leb_spec_Set => hΓl. - - do 6 (rewrite nth_error_app_ge; len; try lia => //). - assert (i - #|Δ| - #|Γl| - #|Γr| = i - #|Δ| - #|Γr| - #|Γl|) as -> by lia. - now rewrite rename_ren_id map_decl_id option_map_id. - - rewrite nth_error_app_ge; len; try lia => //. - rewrite nth_error_app_lt; len; try lia => //. - rewrite nth_error_app_ge; len; try lia => //. - rewrite nth_error_app_ge; len; try lia => //. - rewrite nth_error_app_lt; len; try lia => //. - rewrite nth_error_rename_context. - assert (i - #|Δ| - #|Γr| = i - #|Γr| - #|Δ|) as -> by lia. - apply option_map_ext => //. - intros d. apply map_decl_ext => t. - now rewrite shiftn_lift_renaming Nat.add_0_r. - + rewrite nth_error_app_ge; len; try lia => //. - rewrite nth_error_app_ge; len; try lia => //. - rewrite nth_error_app_lt; len; try lia => //. - rewrite nth_error_app_ge; len; try lia => //. - rewrite nth_error_app_lt; len; try lia => //. - rewrite nth_error_rename_context. - assert (i + #|Γl| - #|Δ| - #|Γl| = i - #|Δ|) as -> by lia. - reflexivity. - * rewrite nth_error_app_lt; len; try lia => //. - rewrite nth_error_app_lt; len; try lia => //. - rewrite nth_error_rename_context. - now rewrite shiftn_exchange_renaming Nat.add_0_r. -Qed. - -(* -Lemma exchange_renaming_add Γl Γr Δ n : - exchange_renaming Γl Γr Δ n = n + exchange_renaming Γl Γr Δ 0. -Proof. - case: exchange_renamingP; case: exchange_renamingP; simpl; try lia. - - intros. - *) - -Lemma exchange_rename_Δ Γl Γr Δ i (k : nat) : - (* noccur_between_ctx 0 Γl Γr -> *) - i < Δ -> - (* From the i-prefix of Γ Γl Γr Δ to Γ Γr Γl Δ *) - exchange_renaming Γl Γr Δ (S i + k) = - S (i + exchange_renaming Γl Γr (Δ - S i) k). -Proof. - rewrite /exchange_renaming. - repeat nat_compare_specs; lia. -Qed. - -Lemma exchange_rename_Γr Γl Γr Δ i (k : nat) : - (* noccur_between_ctx 0 Γl Γr -> *) - Δ <= i < Δ + Γr -> - k < Γr - S (i - Δ) \/ Γr - S (i - Δ) + Γl <= k -> - (* From the i-prefix of Γ Γl Γr Δ to Γ Γr Γl Δ *) - exchange_renaming Γl Γr Δ (S i + k) = - S (i + Γl + strengthen (Γr - S (i - Δ)) Γl k). -Proof. - rewrite /exchange_renaming /strengthen. - repeat nat_compare_specs. -Qed. -(* -Lemma exchange_rename_Γl Γl Γr Δ i (k : nat) : - (* noccur_between_ctx 0 Γl Γr -> *) - Δ + Γr <= i < Δ + Γr + Γl -> - (* From the i-prefix of Γ Γl Γr Δ to Γ Γr Γl Δ *) - exchange_renaming Γl Γr Δ (S i + k) = - S (i + exchange_renaming Γl Γr (Δ - S i) k). -Proof. - rewrite /exchange_renaming. - repeat nat_compare_specs; lia. -Qed. *) - - -Lemma exchange_lift_rename {Γ Γl Γr Δ : context} {i d} : - noccur_between_ctx 0 #|Γl| Γr -> - nth_error (Γ,,, Γl,,, Γr,,, Δ) i = Some d -> - rename_decl (fun k => exchange_renaming #|Γl| #|Γr| #|Δ| (S (i + k))) d = - rename_decl (fun k => S (exchange_renaming #|Γl| #|Γr| #|Δ| i + exchange_rename #|Γl| #|Γr| #|Δ| i k)) d. -Proof. - intros nocc hlen. - move: hlen. - case: lookup_declP => // d' Hi hnth [=]; intros ->; [|move: hnth; len in Hi]. - { apply map_decl_ext, rename_ext => k. - rewrite {2}/exchange_renaming /exchange_rename. nat_compare_specs. - now apply exchange_rename_Δ. } - case: lookup_declP => // d' Hi' hnth [=]; intros ->; [|move: hnth; len in Hi']. - { eapply nth_error_noccur_between_ctx in nocc; eauto. - simpl in nocc. move: nocc. - apply rename_decl_ext_cond => k Hk. - rewrite {2}/exchange_renaming /exchange_rename. - repeat nat_compare_specs. - rewrite shiftn_strengthen_rel Nat.add_0_r //. - now rewrite exchange_rename_Γr. } - case: lookup_declP => // d' Hi'' hnth [=]; intros ->; [|move: hnth; len in Hi'']. - { apply map_decl_ext, rename_ext => k. - rewrite /exchange_renaming /exchange_rename /lift_renaming; - repeat nat_compare_specs. } - { move/nth_error_Some_length => hlen. - apply map_decl_ext, rename_ext => k. - rewrite /exchange_renaming /exchange_rename; repeat nat_compare_specs. - now unfold ren_id. } -Qed. - -Lemma exchange_urenaming P Γ Γl Γr Δ : - noccur_between_ctx 0 #|Γl| Γr -> - urenaming P - (exchange_contexts Γ Γl Γr Δ) - (Γ ,,, Γl ,,, Γr ,,, Δ) - (exchange_renaming #|Γl| #|Γr| #|Δ|). -Proof. - intros nocc i d hpi hnth. - rewrite lookup_exchange_contexts hnth => /=. - eexists; split; eauto. - pose proof (exchange_lift_rename nocc hnth). - rewrite !rename_compose /lift_renaming /=. - destruct d as [na [b|] ty]; noconf H; simpl in *. - - split => //. - split => //. - f_equal. - rewrite !rename_compose. - rewrite /lift_renaming /= //. - - split => //. -Qed. - - -Lemma exchange_wf_local {cf: checker_flags} {Σ : global_env_ext} {wfΣ : wf Σ} {Γ Γl Γr Δ} : - noccur_between_ctx 0 #|Γl| Γr -> - wf_local Σ (Γ ,,, Γl ,,, Γr ,,, Δ) -> - wf_local Σ (exchange_contexts Γ Γl Γr Δ). -Proof. - intros nocc wf. - pose proof (env_prop_wf_local _ _ typing_rename_prop _ wfΣ _ wf). - simpl in X. rewrite /exchange_contexts. - eapply All_local_env_app_inv in X as [XΓ XΓ']. - apply wf_local_app_ind => //. - - rewrite rename_context_lift_context /strengthen /=. - eapply weakening_wf_local_eq; eauto with wf. - * admit. - * now len. - - intros wfstr. - apply All_local_env_fold. - eapply (All_local_env_impl_ind XΓ'). - intros Δ' t [T|] IH; unfold lift_typing; simpl. - * intros Hf. red. - eapply meta_conv_all. 2: reflexivity. - 2-3:now rewrite shiftn_exchange_renaming. - apply Hf. split. - + apply wf_local_app; auto. - apply All_local_env_fold in IH. apply IH. - + setoid_rewrite shiftn_exchange_renaming. apply exchange_urenaming. - - intros [s Hs]; exists s. red. - rewrite -/(lift_context #|Γ''| 0 Δ). - rewrite Nat.add_0_r !lift_rename. apply Hs. - split. - + apply wf_local_app; auto. - apply All_local_env_fold in IH. apply IH. - + apply (weakening_renaming Γ Δ Γ''). -Qed. - -Lemma exchange_typing `{cf : checker_flags} {Σ : global_env_ext} {wfΣ : wf Σ} {Γ Γ' Γ''} {t T} : - wf_local Σ (Γ ,,, Γ'') -> - Σ ;;; Γ ,,, Γ' |- t : T -> - Σ ;;; Γ ,,, Γ'' ,,, lift_context #|Γ''| 0 Γ' |- lift #|Γ''| #|Γ'| t : lift #|Γ''| #|Γ'| T. -Proof. - intros wfext Ht. - rewrite !lift_rename. - eapply (env_prop_typing _ _ typing_rename_prop); eauto. - split. - - eapply weakening_wf_local; eauto with pcuic. - - now apply weakening_renaming. -Qed. diff --git a/pcuic/theories/PCUICExpandLets.v b/pcuic/theories/PCUICExpandLets.v index b6984670a..132f46a3d 100644 --- a/pcuic/theories/PCUICExpandLets.v +++ b/pcuic/theories/PCUICExpandLets.v @@ -40,7 +40,7 @@ Fixpoint trans (t : term) : term := | tCoFix mfix idx => let mfix' := List.map (map_def trans trans) mfix in tCoFix mfix' idx - (* | tPrim i => tPrim i *) + | tPrim i => tPrim i end. Notation trans_decl := (map_decl trans). @@ -108,7 +108,8 @@ Definition trans_global_decls (d : PCUICEnvironment.global_declarations) : globa Definition trans_global_env (d : PCUICEnvironment.global_env) : global_env := {| universes := d.(PCUICEnvironment.universes); - declarations := trans_global_decls d.(PCUICEnvironment.declarations) |}. + declarations := trans_global_decls d.(PCUICEnvironment.declarations); + retroknowledge := d.(PCUICEnvironment.retroknowledge) |}. Definition trans_global (Σ : PCUICEnvironment.global_env_ext) : global_env_ext := (trans_global_env (fst Σ), snd Σ). diff --git a/pcuic/theories/PCUICExpandLetsCorrectness.v b/pcuic/theories/PCUICExpandLetsCorrectness.v index e24bde637..163110814 100644 --- a/pcuic/theories/PCUICExpandLetsCorrectness.v +++ b/pcuic/theories/PCUICExpandLetsCorrectness.v @@ -3838,6 +3838,11 @@ Proof. eapply (subject_is_open_term (Σ := Σ)); tea. len in IHdb. eauto. + rewrite trans_wf_cofixpoint //. + - cbn. econstructor. + 3:eapply trans_declared_constant. all:eauto. + destruct X0 as [s []]; exists s; split => //. + * cbn. rewrite H1 => //. + * cbn. now rewrite H2. - eapply (type_ws_cumul_pb (pb:=Cumul)). + eauto. + now exists s. @@ -4674,13 +4679,13 @@ Proof. auto. Qed. Lemma trans_wf {cf} {Σ : global_env_ext} : wf Σ -> wf_trans Σ. Proof. rewrite /PCUICEnvironment.fst_ctx. - destruct Σ as [[gunivs Σ] udecl]; cbn. intros [onu wfΣ]; cbn in *. + destruct Σ as [[gunivs Σ retro] udecl]; cbn. intros [onu wfΣ]; cbn in *. induction wfΣ as [|Σ0 kn d X IHX f udecl' onu' ond]. constructor; auto. constructor. have onud : on_udecl gunivs (PCUICLookup.universes_decl_of_decl (trans_global_decl d)). - { apply (trans_on_udecl (Σ:= {| universes := gunivs; declarations := Σ0 |})) in onu'. destruct d => //. } + { apply (trans_on_udecl (Σ:= {| universes := gunivs; declarations := Σ0; retroknowledge := retro |})) in onu'. destruct d => //. } cbn; constructor; eauto. rename Σ0 into Σd. - set (Σ0 := {| universes := gunivs; declarations := Σd |}). + set (Σ0 := {| universes := gunivs; declarations := Σd; retroknowledge := retro |}). rename X into Xd. set (X := (onu, Xd) : wf Σ0). constructor; auto; try apply IHX. @@ -5148,6 +5153,13 @@ Proof. now rewrite (isConstructApp_mkApps f1 [f2]). Qed. +Lemma isPrimApp_trans f : isPrimApp f = isPrimApp (trans f). +Proof. + induction f => //. cbn. + rewrite (isPrimApp_mkApps (trans f1) [trans f2]). + now rewrite (isPrimApp_mkApps f1 [f2]). +Qed. + Lemma trans_wcbveval {cf} {Σ} {wfΣ : wf Σ} t u : closed t -> eval Σ t u -> eval (trans_global_env Σ) (trans t) (trans u). @@ -5324,8 +5336,7 @@ Proof. - move=> /= /andP[] clf cla. eapply eval_app_cong; eauto. - rewrite -isFixApp_trans. - rewrite -isConstructApp_trans. + rewrite -isFixApp_trans -isConstructApp_trans -isPrimApp_trans. clear -i. induction f' => /= //. - move=> clt. eapply eval_atom. @@ -5410,7 +5421,9 @@ Proof. now repeat constructor. Qed. -Lemma wf_cons_inv {cf} univs (Σ : global_declarations) d : wf {| universes := univs; declarations := d :: Σ |} -> wf {| universes := univs; declarations := Σ |}. +Lemma wf_cons_inv {cf} univs retro (Σ : global_declarations) d : + wf {| universes := univs; declarations := d :: Σ; retroknowledge := retro |} -> + wf {| universes := univs; declarations := Σ; retroknowledge := retro |}. Proof. intros []. split => //. now depelim o0. Qed. diff --git a/pcuic/theories/PCUICFirstorder.v b/pcuic/theories/PCUICFirstorder.v index abf48f983..15a6cf4ac 100644 --- a/pcuic/theories/PCUICFirstorder.v +++ b/pcuic/theories/PCUICFirstorder.v @@ -66,14 +66,13 @@ Section firstorder. Definition firstorder_mutind (mind : mutual_inductive_body) := (* if forallb (fun decl => firstorder_type decl.(decl_type)) mind.(ind_params) then *) + (mind.(ind_finite) == Finite) && forallb (firstorder_oneind mind) mind.(ind_bodies) (* else repeat false (length mind.(ind_bodies)). *). Definition firstorder_ind (i : inductive) := match lookup_env Σ.1 (inductive_mind i) with - | Some (InductiveDecl mind) => - check_recursivity_kind (lookup_env Σ) (inductive_mind i) Finite && - firstorder_mutind mind + | Some (InductiveDecl mind) => firstorder_mutind mind | _ => false end. @@ -145,11 +144,12 @@ Proof using Type. red. sq. unfold PCUICEnvironment.fst_ctx in *. rewrite d1 in H |- *. solve_all. - unfold firstorder_mutind in H0. - rewrite d2. eapply forallb_nth_error in H0; tea. + unfold firstorder_mutind in H. + rewrite d2. move/andP: H => [ind H0]. + eapply forallb_nth_error in H0; tea. erewrite d2 in H0. cbn in H0. unfold firstorder_oneind in H0. solve_all. - destruct (ind_sort oind) eqn:E2; inv H1. + destruct (ind_sort oind) eqn:E2; inv H0. eapply PCUICInductives.declared_inductive_type in d. rewrite d. rewrite E2. now rewrite destArity_it_mkProd_or_LetIn. @@ -262,36 +262,43 @@ Proof using Type. move=> n. destruct a; cbn. f_equal. apply hp. apply IHΓ. Qed. -Lemma plookup_env_lookup_env Σ kn b : +Arguments firstorder_mutind : clear implicits. + +Lemma plookup_env_lookup_env {Σ : global_env_ext} kn b : plookup_env (firstorder_env Σ) kn = Some b -> - ∑ decl, lookup_env Σ kn = Some decl × + ∑ Σ' decl, lookup_env Σ kn = Some decl × + extends_decls Σ' Σ × match decl with | ConstantDecl _ => b = false | InductiveDecl mind => - b = check_recursivity_kind (lookup_env Σ) kn Finite && - firstorder_mutind (Σb := firstorder_env Σ) mind + b = firstorder_mutind (firstorder_env' (declarations Σ')) mind end. Proof using. - destruct Σ as [[univs Σ] ext]. + destruct Σ as [[univs Σ retro] ext]. induction Σ; cbn => //. destruct a as [kn' d] => //. cbn. case: eqb_specT. - * intros ->. eexists; split => //. - destruct d => //. cbn in H. rewrite eqb_refl in H. congruence. admit. - (* intros neq h. specialize (IHΣ h) as [decl [Hdecl ?]]. - eexists; split => //. exact Hdecl. - destruct decl => //. cbn. - rewrite /lookup_env /=. rewrite y. f_equal. - unfold check_recursivity_kind. case: eqb_spec => //. - unfold firstorder_mutind. unfold firstorder_oneind. - eapply forallb_ext. intros x. f_equal. - eapply forallb_ext. intros cstr. unfold firstorder_con. - eapply alli_ext => i' [] => /= _ _ ty. - unfold firstorder_type. - admit. - - cbn. -*) -Admitted. + * intros ->. + destruct d => //; cbn; rewrite eqb_refl => [=] <-; + exists {| universes := univs; declarations := Σ; retroknowledge := retro |}. + eexists; split => //. cbn. split => //. + red. split => //. eexists (_ :: []); cbn; trea. + eexists; split => //. cbn; split => //. + red. split => //. eexists (_ :: []); cbn; trea. + * intros neq h. + destruct d => //. cbn in h. + move: h. case: eqb_specT=> // _ h'. + unfold firstorder_env in IHΣ. cbn in IHΣ. + specialize (IHΣ h') as [Σ' [decl [Hdecl [ext' ?]]]]. + exists Σ', decl; split => //. split => //. + destruct ext' as [equ [Σ'' eq]]. split => //. + eexists (_ :: Σ''). cbn in *. rewrite eq. trea. + move: h. cbn. apply neqb in neq. rewrite (negbTE neq). + intros h'; specialize (IHΣ h') as [Σ' [decl [Hdecl [ext' ?]]]]. + exists Σ', decl; split => //. split => //. + destruct ext' as [equ [Σ'' eq]]. split => //. + eexists (_ :: Σ''). cbn in *. rewrite eq. trea. +Qed. Lemma firstorder_spine_let {Σ : global_env_ext} {wfΣ : wf Σ} {Γ na a A B args T'} : firstorder_spine Σ Γ (B {0 := a}) args T' -> @@ -329,6 +336,101 @@ Proof using Type. now eapply isType_ws_cumul_pb_refl. eauto. Qed. +Arguments firstorder_type : clear implicits. + +(* Lemma firstorder_env'_app x y : + firstorder_env' (x ++ y) = firstorder_env' x ++ firstorder_env' y. +Proof. + induction x in y |- *; cbn => //. + destruct a => //. destruct g => //. cbn. f_equal; eauto. + cbn; f_equal; eauto. + f_equal. f_equal. eauto. *) + +Import PCUICGlobalMaps. + +Lemma fresh_global_app decls decls' kn : + fresh_global kn (decls ++ decls') -> + fresh_global kn decls /\ fresh_global kn decls'. +Proof. + induction decls => /= //. + - intros f; split => //. + - intros f; depelim f. + specialize (IHdecls f) as []. + split; eauto. constructor => //. +Qed. + +Lemma plookup_env_Some_not_fresh g kn b : + plookup_env (firstorder_env' g) kn = Some b -> + ~ PCUICGlobalMaps.fresh_global kn g. +Proof. + induction g; cbn => //. + destruct a => //. destruct g0 => //. + - cbn. + case: eqb_spec. + + move=> -> [=]. + intros neq hf. depelim hf. now cbn in H. + + move=> neq hl hf. + apply IHg => //. now depelim hf. + - cbn. + case: eqb_spec. + + move=> -> [=]. + intros neq hf. depelim hf. now cbn in H. + + move=> neq hl hf. + apply IHg => //. now depelim hf. +Qed. + +Lemma plookup_env_extends {Σ Σ' : global_env} kn b : + extends_decls Σ' Σ -> + wf Σ -> + plookup_env (firstorder_env' (declarations Σ')) kn = Some b -> + plookup_env (firstorder_env' (declarations Σ)) kn = Some b. +Proof. + intros [equ [Σ'' eq] eqr]. rewrite eq. + clear equ eqr. intros []. clear o. + rewrite eq in o0. clear eq. move: o0. + generalize (declarations Σ'). clear Σ'. + induction Σ''. + - cbn => //. + - cbn. destruct a => //. intros gs ong. + depelim ong. specialize (IHΣ'' _ ong). + destruct g => //. + * intros hl. specialize (IHΣ'' hl). + eapply plookup_env_Some_not_fresh in hl. + cbn. case: eqb_spec. + + intros <-. apply fresh_global_app in f as []. + contradiction. + + now intros neq. + * intros hl. specialize (IHΣ'' hl). + eapply plookup_env_Some_not_fresh in hl. + cbn. case: eqb_spec. + + intros <-. apply fresh_global_app in f as []. + contradiction. + + now intros neq. +Qed. + +Lemma firstorder_mutind_ext {Σ Σ' : global_env_ext} m : + extends_decls Σ' Σ -> + wf Σ -> + firstorder_mutind (firstorder_env' (declarations Σ')) m -> + firstorder_mutind (firstorder_env Σ) m. +Proof. + intros [equ [Σ'' eq]] wf. + unfold firstorder_env. rewrite eq. + unfold firstorder_mutind. + move/andP => [] -> /=. apply forallb_impl => x _. + unfold firstorder_oneind. + move/andP => [] h -> /=; rewrite andb_true_r. + eapply forallb_impl; tea => c _. + unfold firstorder_con. + eapply alli_impl => i [] _ _ ty. + unfold firstorder_type. + destruct decompose_app => // /=. + destruct t => //. destruct ind => //. + destruct plookup_env eqn:hl => //. destruct b => //. + eapply (plookup_env_extends (Σ:=Σ)) in hl. 2:split; eauto. + rewrite eq in hl. rewrite hl //. apply wf. +Qed. + Lemma firstorder_args {Σ : global_env_ext} {wfΣ : wf Σ} { mind cbody i n ui args u pandi oind} : declared_constructor Σ (i, n) mind oind cbody -> PCUICArities.typing_spine Σ [] (type_of_constructor mind cbody (i, n) ui) args (mkApps (tInd i u) pandi) -> @@ -350,25 +452,27 @@ Proof using Type. { clear Hspine. destruct Hdecl as [[d1 d3] d2]. pose proof d3 as Hdecl. unfold firstorder_ind in Hind. rewrite d1 in Hind. solve_all. clear a. + move/andP: Hind => [indf H0]. eapply forallb_nth_error in H0 as H'. erewrite d3 in H'. unfold firstorder_oneind in H'. cbn in H'. rtoProp. - eapply nth_error_forallb in H1. 2: eauto. - unfold firstorder_con in H1. - revert H1. cbn. + eapply nth_error_forallb in H. 2: eauto. + unfold firstorder_con in H. + revert H. cbn. unfold cstr_concl. rewrite PCUICUnivSubst.subst_instance_mkApps subst_mkApps. rewrite subst_instance_length app_length. unfold cstr_concl_head. rewrite PCUICInductives.subst_inds_concl_head. now eapply nth_error_Some_length in Hdecl. rewrite -app_length. - generalize (cstr_args cbody ++ ind_params mind)%list. clear -d1 H H0 Hdecl. + generalize (cstr_args cbody ++ ind_params mind)%list. + clear -wfΣ d1 indf H1 H0 Hdecl. (* generalize conclusion to mkApps tInd args *) intros c. change (list context_decl) with context in c. move: (map (subst (inds _ _ _) _) _). intros args. - rewrite (alli_subst_instance _ ui (fun k t => firstorder_type #|ind_bodies mind| k t)). + rewrite (alli_subst_instance _ ui (fun k t => firstorder_type _ #|ind_bodies mind| k t)). { intros k t. rewrite /firstorder_type. rewrite -PCUICUnivSubstitutionConv.subst_instance_decompose_app /=. @@ -424,7 +528,7 @@ Proof using Type. rewrite Nat.add_0_r in fot. eapply Nat.ltb_lt in fot. cbn. rewrite nth_error_inds. lia. cbn. econstructor. - { rewrite /firstorder_ind d1 H H0 //. } + { rewrite /firstorder_ind d1 /= /firstorder_mutind indf H0 //. } intros x. rewrite /subst1 PCUICLiftSubst.subst_it_mkProd_or_LetIn subst_mkApps /=. len. rewrite -subst_app_context' // PCUICSigmaCalculus.subst_context_decompo. @@ -458,8 +562,9 @@ Proof using Type. constructor. { unfold firstorder_ind. destruct ind. cbn in *. destruct plookup_env eqn:hp => //. - eapply plookup_env_lookup_env in hp as [decl [eq ]]. - rewrite eq. destruct decl; subst b => //. } + eapply plookup_env_lookup_env in hp as [Σ' [decl [eq [ext he]]]]. + rewrite eq. destruct decl; subst b => //. + eapply (firstorder_mutind_ext (Σ' := (empty_ext Σ'))); tea. } intros x. rewrite /subst1 PCUICLiftSubst.subst_it_mkProd_or_LetIn subst_mkApps /=; len. rewrite -subst_app_context' // PCUICSigmaCalculus.subst_context_decompo. eapply X. now len. len. @@ -560,7 +665,10 @@ Proof using Type. red in Hfo. unfold firstorder_ind in Hfo. rewrite Hlookup in Hfo. eapply andb_true_iff in Hfo as [Hfo _]. - eapply check_recursivity_kind_inj in Hty; eauto. congruence. + rewrite /check_recursivity_kind Hlookup in Hty. + apply eqb_eq in Hfo, Hty. congruence. + + eapply inversion_Prim in Hty as [prim_ty [cdecl [wf hp hdecl [s []] cum]]]; eauto. + now eapply invert_cumul_axiom_ind in cum; tea. - destruct t; inv Hhead. + exfalso. now eapply invert_ind_ind in Hty. + apply inversion_mkApps in Hty as Hcon; auto. @@ -593,7 +701,8 @@ Proof using Type. red in Hfo. unfold firstorder_ind in Hfo. rewrite Hlookup in Hfo. eapply andb_true_iff in Hfo as [Hfo _]. - eapply check_recursivity_kind_inj in Hty; eauto. congruence. + rewrite /check_recursivity_kind Hlookup in Hty. + apply eqb_eq in Hfo, Hty. congruence. Qed. End cf. diff --git a/pcuic/theories/PCUICInversion.v b/pcuic/theories/PCUICInversion.v index b97fc475d..1a5fbd28f 100644 --- a/pcuic/theories/PCUICInversion.v +++ b/pcuic/theories/PCUICInversion.v @@ -6,7 +6,7 @@ From MetaCoq.PCUIC Require Import PCUICAst PCUICCases PCUICLiftSubst PCUICUnivSu PCUICOnFreeVars PCUICClosedTyp PCUICWellScopedCumulativity. Require Import Equations.Prop.DepElim. -(* todo: make wf arguments implicit *) +(* TODO: make wf arguments implicit *) Section Inversion. Context {cf : checker_flags}. @@ -335,13 +335,23 @@ Section Inversion. intros Γ mfix idx T h. invtac h. Qed. - (** At this stage we don't typecheck primitive values *) - (* Lemma inversion_Prim : - forall {Γ i T}, - Σ ;;; Γ |- tPrim i : T -> False. + Lemma inversion_Prim : + forall {Γ p T}, + Σ ;;; Γ |- tPrim p : T -> + ∑ prim_ty cdecl, + [× wf_local Σ Γ, + primitive_constant Σ (prim_val_tag p) = Some prim_ty, + declared_constant Σ prim_ty cdecl, + primitive_invariants cdecl & + Σ ;;; Γ ⊢ tConst prim_ty [] ≤ T]. Proof. - intros Γ i T h. now depind h. - Qed. *) + intros Γ p T h. depind h. + - exists prim_ty, cdecl; split => //. + eapply ws_cumul_pb_refl; fvs. + - destruct IHh1 as [prim_ty [cdecl []]]. + exists prim_ty, cdecl. split => //. + transitivity A; tea. eapply cumulSpec_cumulAlgo_curry; tea; fvs. + Qed. Lemma inversion_it_mkLambda_or_LetIn : forall {Γ Δ t T}, diff --git a/pcuic/theories/PCUICNormal.v b/pcuic/theories/PCUICNormal.v index 990faf564..9416c0e80 100644 --- a/pcuic/theories/PCUICNormal.v +++ b/pcuic/theories/PCUICNormal.v @@ -40,23 +40,7 @@ Section Normal. Context (Σ : global_env). (* Relative to reduction flags *) - Inductive whnf (Γ : context) : term -> Type := - | whnf_ne t : whne Γ t -> whnf Γ t - | whnf_sort s : whnf Γ (tSort s) - | whnf_prod na A B : whnf Γ (tProd na A B) - | whnf_lam na A B : whnf Γ (tLambda na A B) - | whnf_cstrapp i n u v : whnf Γ (mkApps (tConstruct i n u) v) - | whnf_indapp i u v : whnf Γ (mkApps (tInd i u) v) - | whnf_fixapp mfix idx v : - match unfold_fix mfix idx with - | Some (rarg, body) => nth_error v rarg = None - | None => True - end -> - whnf Γ (mkApps (tFix mfix idx) v) - | whnf_cofixapp mfix idx v : whnf Γ (mkApps (tCoFix mfix idx) v) - (* | whnf_prim p : whnf Γ (tPrim p) *) - - with whne (Γ : context) : term -> Type := + Inductive whne (Γ : context) : term -> Type := | whne_rel i : option_map decl_body (nth_error Γ i) = Some None -> whne Γ (tRel i) @@ -119,6 +103,23 @@ Section Normal. RedFlags.iota flags = false -> whne Γ (tProj p c). + (* Relative to reduction flags *) + Inductive whnf (Γ : context) : term -> Type := + | whnf_ne t : whne Γ t -> whnf Γ t + | whnf_sort s : whnf Γ (tSort s) + | whnf_prod na A B : whnf Γ (tProd na A B) + | whnf_lam na A B : whnf Γ (tLambda na A B) + | whnf_cstrapp i n u v : whnf Γ (mkApps (tConstruct i n u) v) + | whnf_indapp i u v : whnf Γ (mkApps (tInd i u) v) + | whnf_fixapp mfix idx v : + match unfold_fix mfix idx with + | Some (rarg, body) => nth_error v rarg = None + | None => True + end -> + whnf Γ (mkApps (tFix mfix idx) v) + | whnf_cofixapp mfix idx v : whnf Γ (mkApps (tCoFix mfix idx) v) + | whnf_prim p : whnf Γ (tPrim p). + Lemma whne_mkApps : forall Γ t args, whne Γ t -> @@ -256,8 +257,8 @@ Proof. lia. - destruct (mkApps_elim t l). apply mkApps_eq_inj in eq as (<-&<-); auto. - (* - destruct l using MCList.rev_ind; [|now rewrite mkApps_app in eq]. *) - (* cbn in *; subst; auto. *) + - destruct l using MCList.rev_ind; [|now rewrite mkApps_app in eq]. + cbn in *; subst; auto. Qed. Lemma whnf_fixapp' {flags} Σ Γ mfix idx narg body v : @@ -390,11 +391,11 @@ Proof with eauto using sq with pcuic; try congruence. constructor. assumption. -- left. constructor. eapply whnf_fixapp. rewrite E1. eauto. - (* * destruct v as [ | ? v]... + * destruct v as [ | ? v]... right. intros [w]. depelim w. depelim w. all:help. clear IHt. eapply whne_mkApps_inv in w as []... -- depelim w. help. - -- destruct s0 as [? [? [? [? [? [? ?]]]]]]. congruence. *) + -- destruct s0 as [? [? [? [? [? [? ?]]]]]]. congruence. + right. intros [w]. eapply n. constructor. now eapply whnf_mkApps_inv. - destruct (IHt Γ) as [_ []]. + left. destruct s as [w]. constructor. now eapply whne_mkApps. @@ -940,7 +941,7 @@ Proof. destruct s as [->|(?&?)]; [easy|]. now inv e. - eapply red1_mkApps_tCoFix_inv in r as [[(?&->&?)|(?&->&?)]|(?&->&?)]; eauto. - (* - depelim r. solve_discr. *) + - depelim r. solve_discr. Qed. Lemma whnf_pres Σ Γ t t' : @@ -1013,8 +1014,8 @@ Inductive whnf_red Σ Γ : term -> term -> Type := red Σ Γ (dtype d) (dtype d') × red Σ (Γ,,, fix_context mfix) (dbody d) (dbody d')) mfix mfix' -> - whnf_red Σ Γ (tCoFix mfix idx) (tCoFix mfix' idx). -(* | whnf_red_tPrim i : whnf_red Σ Γ (tPrim i) (tPrim i). *) + whnf_red Σ Γ (tCoFix mfix idx) (tCoFix mfix' idx) +| whnf_red_tPrim i : whnf_red Σ Γ (tPrim i) (tPrim i). Derive Signature for whnf_red. @@ -1516,7 +1517,7 @@ Proof. cbn. intros ? ? (?&[= -> -> ->]). auto. - (* - depelim r; solve_discr. *) + - depelim r; solve_discr. Qed. Lemma whnf_red_inv {cf:checker_flags} {Σ : global_env_ext} Γ t t' : @@ -1607,7 +1608,7 @@ Proof. - apply eq_term_upto_univ_napp_mkApps_l_inv in eq as (?&?&(?&?)&->). depelim e. apply whnf_cofixapp. - (* - depelim eq; auto. *) + - depelim eq; auto. Qed. Lemma whnf_eq_term {cf:checker_flags} f Σ φ Γ t t' : diff --git a/pcuic/theories/PCUICParallelReduction.v b/pcuic/theories/PCUICParallelReduction.v index d5ad4ad2e..23c8322e4 100644 --- a/pcuic/theories/PCUICParallelReduction.v +++ b/pcuic/theories/PCUICParallelReduction.v @@ -231,7 +231,7 @@ Section ParallelReduction. | tSort _ | tInd _ _ | tConstruct _ _ _ => true - (* | tPrim _ => true *) + | tPrim _ => true | _ => false end. diff --git a/pcuic/theories/PCUICParallelReductionConfluence.v b/pcuic/theories/PCUICParallelReductionConfluence.v index 2240ffa25..9971569a0 100644 --- a/pcuic/theories/PCUICParallelReductionConfluence.v +++ b/pcuic/theories/PCUICParallelReductionConfluence.v @@ -1527,7 +1527,7 @@ Section Rho. rename r (rho Γ t) = rho Δ (rename r t). Proof using cf Σ wfΣ. revert t Γ Δ r P. - refine (PCUICDepth.term_ind_depth_app _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _); + refine (PCUICDepth.term_ind_depth_app _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _); intros until Γ; intros Δ r P Hr ont; try subst Γ; try rename Γ0 into Γ; repeat inv_on_free_vars. all:auto 2. diff --git a/pcuic/theories/PCUICPrincipality.v b/pcuic/theories/PCUICPrincipality.v index 7d0723bc4..31c6a3894 100644 --- a/pcuic/theories/PCUICPrincipality.v +++ b/pcuic/theories/PCUICPrincipality.v @@ -333,7 +333,11 @@ Section Principality. rewrite nthe' in nthe; noconf nthe. repeat split; eauto. eapply type_CoFix; eauto. - (* - now apply inversion_Prim in hA. *) + - apply inversion_Prim in hA as [prim_ty [cdecl []]] => //; pcuic. + exists (tConst prim_ty []). + intros B hB. + apply inversion_Prim in hB as [prim_ty' [cdecl' []]] => //; pcuic. + econstructor; tea. Qed. (** A weaker version that is often convenient to use. *) @@ -471,9 +475,7 @@ Proof. [ H : leq_term _ _ _ _ |- _ ] => depelim H end. all:try solve [econstructor; eauto]. - 13:{ eapply type_Cumul'. - eapply X1; eauto. now exists s. - auto. } + - eapply inversion_Sort in X0 as [wf [wfs cum]]; auto. eapply type_Cumul' with (tSort (Universe.super s)). constructor; auto. eapply PCUICArities.isType_Sort; pcuic. @@ -717,8 +719,14 @@ Proof. destruct a as [[[eqty _] _] _]. constructor. apply eq_term_empty_leq_term in eqty. now eapply leq_term_empty_leq_term. -Qed. + - depelim X2. + econstructor; tea. + + - eapply type_Cumul'. + eapply X1; eauto. now exists s. + auto. +Qed. Lemma typing_eq_term {cf:checker_flags} (Σ : global_env_ext) Γ t t' T T' : wf_ext Σ -> diff --git a/pcuic/theories/PCUICProgress.v b/pcuic/theories/PCUICProgress.v index 609b82a49..e08411aac 100644 --- a/pcuic/theories/PCUICProgress.v +++ b/pcuic/theories/PCUICProgress.v @@ -255,6 +255,13 @@ forall (P : global_env_ext -> context -> term -> term -> Type) wf_cofixpoint Σ.1 mfix -> P Σ Γ (tCoFix mfix n) decl.(dtype)) -> + (forall Σ (wfΣ : wf Σ.1) (Γ : context) (wfΓ : wf_local Σ Γ) (p : prim_val) prim_ty cdecl, + PΓ Σ Γ -> + primitive_constant Σ.1 (prim_val_tag p) = Some prim_ty -> + declared_constant Σ.1 prim_ty cdecl -> + primitive_invariants cdecl -> + P Σ Γ (tPrim p) (tConst prim_ty [])) -> + (forall Σ (wfΣ : wf Σ.1) (Γ : context) (wfΓ : wf_local Σ Γ) (t A B : term) s, PΓ Σ Γ -> Σ ;;; Γ |- t : A -> @@ -429,6 +436,13 @@ Lemma typing_ind_env `{cf : checker_flags} : wf_cofixpoint Σ.1 mfix -> P Σ Γ (tCoFix mfix n) decl.(dtype)) -> + (forall Σ (wfΣ : wf Σ.1) (Γ : context) (wfΓ : wf_local Σ Γ) (p : prim_val) prim_ty cdecl, + PΓ Σ Γ -> + primitive_constant Σ.1 (prim_val_tag p) = Some prim_ty -> + declared_constant Σ.1 prim_ty cdecl -> + primitive_invariants cdecl -> + P Σ Γ (tPrim p) (tConst prim_ty [])) -> + (forall Σ (wfΣ : wf Σ.1) (Γ : context) (wfΓ : wf_local Σ Γ) (t A B : term) s, PΓ Σ Γ -> Σ ;;; Γ |- t : A -> @@ -441,7 +455,7 @@ Lemma typing_ind_env `{cf : checker_flags} : env_prop P PΓ. Proof. intros P Pdecl PΓ; unfold env_prop. - intros XΓ X X0 X1 X2 X3 X4 X5 X6 X7 X8 X9 X10 X11 X12 Σ wfΣ Γ t T H. + intros XΓ X X0 X1 X2 X3 X4 X5 X6 X7 X8 X9 X10 X11 X12 X13 Σ wfΣ Γ t T H. apply typing_ind_env_app_size; eauto. Qed. @@ -540,6 +554,17 @@ Proof. now eapply ws_cumul_pb_Sort_Prod_inv in w. Qed. +Lemma typing_spine_axiom {cf : checker_flags} {Σ : global_env_ext} {wfΣ : wf Σ} Γ cst u cdecl args T : + declared_constant Σ cst cdecl -> + cdecl.(cst_body) = None -> + typing_spine Σ Γ (tConst cst u) args T -> args = []. +Proof. + intros hdecl hb. + induction args => //. + intros sp. depelim sp. + now eapply invert_cumul_axiom_prod in w. +Qed. + Lemma typing_value_head_napp {cf : checker_flags} {Σ : global_env_ext} {wfΣ : wf Σ} fn args hd T : negb (isApp fn) -> Σ ;;; [] |- mkApps fn (args ++ [hd]) : T -> @@ -594,6 +619,11 @@ Proof. * (* cofix *) right. eapply value_app; eauto with pcuic. now constructor. + * (* primitive *) + cbn. + eapply inversion_Prim in hfn as [prim_ty [cdecl [hwf hp hdecl [s []]]]]; tea. + eapply typing_spine_strengthen in hcum. 3:tea. 2:{ eapply validity; econstructor; eauto. now exists s. } + now eapply typing_spine_axiom, app_tip_nil in hcum. Qed. Lemma typing_value_head {cf : checker_flags} {Σ : global_env_ext} {wfΣ : wf Σ} fn args hd T : @@ -735,7 +765,7 @@ Proof. 1,2: now rewrite closed_subst; eauto; econstructor; eauto. - now rewrite e0 /cstr_arity -e1 -e2. - rewrite !tApp_mkApps -!mkApps_app. econstructor. eauto. - unfold is_constructor. now rewrite nth_error_app2 // minus_diag. + unfold is_constructor. now rewrite nth_error_app2 // Nat.sub_diag. - unfold cunfold_cofix in e. destruct nth_error as [d | ] eqn:E; try congruence. inversion e; subst. econstructor. unfold unfold_cofix. rewrite E. repeat f_equal. @@ -876,7 +906,7 @@ Lemma wcbv_standardization {Σ i u args mind} {t v : term} : wf_ext Σ -> axiom_ @firstorder_ind Σ (firstorder_env Σ) i -> red Σ [] t v -> (forall v', PCUICReduction.red1 Σ [] v v' -> False) -> - squash (eval Σ t v). + ∥ eval Σ t v ∥. Proof. intros Hwf Hax Hty Hdecl Hfo Hred Hirred. unshelve edestruct @ws_wcbv_standardization. diff --git a/pcuic/theories/PCUICSafeLemmata.v b/pcuic/theories/PCUICSafeLemmata.v index 92f2d72b7..bf439d604 100644 --- a/pcuic/theories/PCUICSafeLemmata.v +++ b/pcuic/theories/PCUICSafeLemmata.v @@ -346,7 +346,7 @@ Section Lemmata. destruct h; depelim wf; simpl in *. all: destruct l; econstructor; eauto. Qed. - (* todo: rename alpha_eq *) + (* TODO: rename alpha_eq *) Lemma compare_decls_conv Γ Γ' : eq_context_upto_names Γ Γ' -> conv_context cumulAlgo_gen Σ Γ Γ'. diff --git a/pcuic/theories/PCUICToTemplate.v b/pcuic/theories/PCUICToTemplate.v index 6307aac9b..24901b2f9 100644 --- a/pcuic/theories/PCUICToTemplate.v +++ b/pcuic/theories/PCUICToTemplate.v @@ -11,11 +11,11 @@ Definition uint63_from_model (i : uint63_model) : Uint63.int := Definition float64_from_model (f : float64_model) : PrimFloat.float := FloatOps.SF2Prim (proj1_sig f). -(* Definition trans_prim (t : prim_val) : Ast.term := +Definition trans_prim (t : prim_val) : Ast.term := match t.π2 with - | primIntModel i => Ast.tInt (uint63_from_model i) - | primFloatModel f => Ast.tFloat (float64_from_model f) - end. *) + | primIntModel i => Ast.tInt i + | primFloatModel f => Ast.tFloat f + end. Definition trans_predicate (t : PCUICAst.predicate Ast.term) : predicate Ast.term := {| pparams := t.(PCUICAst.pparams); @@ -51,7 +51,7 @@ Fixpoint trans (t : PCUICAst.term) : Ast.term := | PCUICAst.tCoFix mfix idx => let mfix' := List.map (map_def trans trans) mfix in tCoFix mfix' idx - (* | PCUICAst.tPrim i => trans_prim i *) + | PCUICAst.tPrim i => trans_prim i end. Notation trans_decl := (map_decl trans). @@ -106,7 +106,8 @@ Definition trans_global_decls (d : PCUICEnvironment.global_declarations) : globa Definition trans_global_env (d : PCUICEnvironment.global_env) : global_env := {| universes := d.(PCUICEnvironment.universes); - declarations := trans_global_decls d.(PCUICEnvironment.declarations) |}. + declarations := trans_global_decls d.(PCUICEnvironment.declarations); + retroknowledge := d.(PCUICEnvironment.retroknowledge) |}. Definition trans_global (Σ : PCUICEnvironment.global_env_ext) : global_env_ext := (trans_global_env (fst Σ), snd Σ). diff --git a/pcuic/theories/PCUICToTemplateCorrectness.v b/pcuic/theories/PCUICToTemplateCorrectness.v index 08fe79677..90ced7113 100644 --- a/pcuic/theories/PCUICToTemplateCorrectness.v +++ b/pcuic/theories/PCUICToTemplateCorrectness.v @@ -102,7 +102,7 @@ Proof. rewrite b. now rewrite forget_types_length map_context_length. - f_equal; auto; red in X; solve_list. - f_equal; auto; red in X; solve_list. - (* - destruct p as [? []]; eauto. *) + - destruct p as [? []]; eauto. Qed. Definition on_fst {A B C} (f:A->C) (p:A×B) := (f p.1, p.2). @@ -275,7 +275,7 @@ Proof. cbn in *. now rewrite e e0. + apply IHX. - (* - destruct p as [? []]; eauto. *) + - destruct p as [? []]; eauto. Qed. Lemma trans_subst10 u B: @@ -325,7 +325,7 @@ Proof. destruct p. now rewrite e e0. + apply IHX. - (* - destruct p as [? []]; eauto. *) + - destruct p as [? []]; eauto. Qed. Lemma trans_subst_instance_ctx Γ u : @@ -441,7 +441,7 @@ Proof. - rewrite <- IHx3. reflexivity. - destruct (trans x1);cbn;trivial. - (* - destruct prim as [? []]; eauto. *) + - destruct prim as [? []]; eauto. Qed. Lemma trans_mkProd_or_LetIn a t: @@ -474,7 +474,7 @@ Proof. destruct t; cbnr. generalize (trans t1) (trans t2); clear. induction t; intros; cbnr. - (* destruct prim as [? []]; cbnr. *) + destruct prim as [? []]; cbnr. Qed. Lemma trans_unfold_fix mfix idx narg fn : @@ -1019,7 +1019,7 @@ Proof. cbn; eauto. cbn in p0. destruct p0. eauto. - cbn. red in X. solve_all. - cbn. red in X. solve_all. - (* - destruct p as [? []]; constructor. *) + - destruct p as [? []]; constructor. Qed. #[global] Hint Resolve trans_wf : wf. @@ -1433,7 +1433,7 @@ Proof. red in X0. solve_all_one. eapply trans_eq_context_gen_eq_binder_annot in a. now rewrite !map_context_trans. - (* - destruct p as [? []]; constructor. *) + - destruct p as [? []]; constructor. Qed. Lemma trans_leq_term {cf} Σ ϕ T U : @@ -1666,26 +1666,26 @@ Proof. - eapply IHt3 in e as e'. assumption. - noconf e. simpl. now destruct (mkApp_ex (trans t1) (trans t2)) as [f [args ->]]. - (* - noconf e. now destruct prim as [? []] => /=. *) + - noconf e. now destruct prim as [? []] => /=. Qed. Lemma trans_isApp t : PCUICAst.isApp t = false -> Ast.isApp (trans t) = false. Proof. destruct t => //. - (* now destruct prim as [? []]. *) + now destruct prim as [? []]. Qed. Lemma trans_nisApp t : ~~ PCUICAst.isApp t -> ~~ Ast.isApp (trans t). Proof. destruct t => //. - (* now destruct prim as [? []]. *) + now destruct prim as [? []]. Qed. Lemma trans_destInd t : ST.destInd t = TT.destInd (trans t). Proof. destruct t => //. simpl. now destruct (mkApp_ex (trans t1) (trans t2)) as [f [u ->]]. - (* now destruct prim as [? []]. *) + now destruct prim as [? []]. Qed. Lemma trans_decompose_app t : @@ -2347,6 +2347,11 @@ Proof. + fold trans;subst types. now apply trans_mfix_All2. + now rewrite trans_wf_cofixpoint. + - cbn. destruct p as [? []]; cbn; econstructor; eauto. + 1,3: eapply trans_declared_constant; tea. + all:move: X0; rewrite /Ast.Env.primitive_invariants /primitive_invariants; + intros [s []]; exists s; split => //; + destruct cdecl as [ty [?|] ?]; cbn in *; subst; auto => //. - eapply TT.type_Conv. + eassumption. + eassumption. diff --git a/pcuic/theories/PCUICTyping.v b/pcuic/theories/PCUICTyping.v index 69328e905..8a7ceddb2 100644 --- a/pcuic/theories/PCUICTyping.v +++ b/pcuic/theories/PCUICTyping.v @@ -1,6 +1,6 @@ (* Distributed under the terms of the MIT license. *) -From MetaCoq.Template Require Import config utils. -From MetaCoq.PCUIC Require Import PCUICAst PCUICAstUtils +From MetaCoq.Template Require Import config utils Primitive. +From MetaCoq.PCUIC Require Import PCUICAst PCUICAstUtils PCUICPrimitive PCUICLiftSubst PCUICUnivSubst PCUICEquality PCUICUtils PCUICPosition. From MetaCoq.PCUIC Require Export PCUICCumulativitySpec. From MetaCoq.PCUIC Require Export PCUICCases. @@ -10,7 +10,7 @@ Import MCMonadNotation. (* TODO: remove this export *) From MetaCoq Require Export LibHypsNaming. -Require Import ssreflect. +Require Import ssreflect ssrbool. Require Import Equations.Type.Relation. From Equations Require Import Equations. Set Equations With UIP. @@ -137,7 +137,6 @@ Definition wf_cofixpoint_gen | _ => false end. - Definition wf_cofixpoint (Σ : global_env) := wf_cofixpoint_gen (lookup_env Σ). Reserved Notation "'wf_local' Σ Γ " (at level 9, Σ, Γ at next level). @@ -262,6 +261,13 @@ Inductive typing `{checker_flags} (Σ : global_env_ext) (Γ : context) : term -> wf_cofixpoint Σ mfix -> Σ ;;; Γ |- tCoFix mfix n : decl.(dtype) +| type_Prim p prim_ty cdecl : + wf_local Σ Γ -> + primitive_constant Σ (prim_val_tag p) = Some prim_ty -> + declared_constant Σ prim_ty cdecl -> + primitive_invariants cdecl -> + Σ ;;; Γ |- tPrim p : tConst prim_ty [] + | type_Cumul : forall t A B s, Σ ;;; Γ |- t : A -> Σ ;;; Γ |- B : tSort s -> @@ -399,6 +405,7 @@ Proof. (all_size _ (fun x p => (infer_sort_size (typing_sort_size typing_size)) Σ _ _ p) a0)) (all_size _ (fun x p => typing_size Σ _ _ _ p) a1))). - exact (S (Nat.max (Nat.max (All_local_env_size typing_size _ _ a) (all_size _ (fun x p => (infer_sort_size (typing_sort_size typing_size)) Σ _ _ p) a0)) (all_size _ (fun x p => typing_size Σ _ _ _ p) a1))). + - exact (S (All_local_env_size typing_size _ _ a)). Defined. Lemma typing_size_pos `{checker_flags} {Σ Γ t T} (d : Σ ;;; Γ |- t : T) : typing_size d > 0. @@ -718,6 +725,13 @@ Lemma typing_ind_env_app_size `{cf : checker_flags} : All (on_def_body (lift_typing2 typing P Σ) types Γ) mfix -> wf_cofixpoint Σ mfix -> P Σ Γ (tCoFix mfix n) decl.(dtype)) -> + + (forall Σ (wfΣ : wf Σ.1) (Γ : context) (wfΓ : wf_local Σ Γ) (p : prim_val term) prim_ty cdecl, + PΓ Σ Γ -> + primitive_constant Σ (prim_val_tag p) = Some prim_ty -> + declared_constant Σ prim_ty cdecl -> + primitive_invariants cdecl -> + P Σ Γ (tPrim p) (tConst prim_ty [])) -> (forall Σ (wfΣ : wf Σ.1) (Γ : context) (wfΓ : wf_local Σ Γ) (t A B : term) s, PΓ Σ Γ -> @@ -731,7 +745,7 @@ Lemma typing_ind_env_app_size `{cf : checker_flags} : env_prop P PΓ. Proof. intros P Pdecl PΓ. - intros XΓ X X0 X1 X2 X3 X4 X5 X6 X7 X8 X9 X10 X11 X12 Σ wfΣ Γ t T H. + intros XΓ X X0 X1 X2 X3 X4 X5 X6 X7 X8 X9 X10 X11 X12 X13 Σ wfΣ Γ t T H. (* NOTE (Danil): while porting to 8.9, I had to split original "pose" into 2 pieces, otherwise it takes forever to execure the "pose", for some reason *) pose proof (@Fix_F { Σ & { wfΣ : wf Σ.1 & { Γ & { t & { T & Σ ;;; Γ |- t : T }}}}}) as p0. @@ -753,7 +767,7 @@ Proof. intros (Σ & wfΣ & Γ & t & t0 & H). simpl. intros IH. simpl in IH. split. - - clear X X0 X1 X2 X3 X4 X5 X6 X7 X8 X9 X10 X11 X12. + - clear X X0 X1 X2 X3 X4 X5 X6 X7 X8 X9 X10 X11 X12 X13. destruct Σ as [Σ φ]. red. cbn. do 2 red in wfΣ. cbn in wfΣ. destruct Σ as [univs Σ]; cbn in *. @@ -828,7 +842,7 @@ Proof. forward IH. constructor 2. simpl. apply H0. split; apply IH. } - rename X13 into X14. + (* rename X13 into X14. *) assert (Hdecls: typing_size H > 1 -> Forall_decls_typing P Σ.1). { specialize (X14 _ _ _ (type_Prop _)). @@ -1163,6 +1177,13 @@ Lemma typing_ind_env `{cf : checker_flags} : All (on_def_body (lift_typing2 typing P Σ) types Γ) mfix -> wf_cofixpoint Σ mfix -> P Σ Γ (tCoFix mfix n) decl.(dtype)) -> + + (forall Σ (wfΣ : wf Σ.1) (Γ : context) (wfΓ : wf_local Σ Γ) (p : prim_val term) prim_ty cdecl, + PΓ Σ Γ -> + primitive_constant Σ (prim_val_tag p) = Some prim_ty -> + declared_constant Σ prim_ty cdecl -> + primitive_invariants cdecl -> + P Σ Γ (tPrim p) (tConst prim_ty [])) -> (forall Σ (wfΣ : wf Σ.1) (Γ : context) (wfΓ : wf_local Σ Γ) (t A B : term) s, PΓ Σ Γ -> @@ -1176,7 +1197,7 @@ Lemma typing_ind_env `{cf : checker_flags} : env_prop P PΓ. Proof. intros P Pdecl PΓ; unfold env_prop. - intros XΓ X X0 X1 X2 X3 X4 X5 X6 X7 X8 X9 X10 X11 X12 Σ wfΣ Γ t T H. + intros XΓ X X0 X1 X2 X3 X4 X5 X6 X7 X8 X9 X10 X11 X12 X13 Σ wfΣ Γ t T H. apply typing_ind_env_app_size; eauto. Qed. @@ -1220,22 +1241,23 @@ Section All_local_env. { Σ' : global_env & [× extends Σ' Σ, on_global_env cumulSpec0 P Σ' & on_global_decl cumulSpec0 P (Σ', universes_decl_of_decl decl) c decl] }. Proof using Type. - destruct Σ as [univs Σ]; rewrite /on_global_env /lookup_env; cbn. + destruct Σ as [univs Σ retro]; rewrite /on_global_env /lookup_env; cbn. intros [cu Σp]. induction Σp; simpl. congruence. destruct (eqb_specT c kn); subst. - intros [= ->]. - exists ({| universes := univs; declarations := Σ |}). + exists ({| universes := univs; declarations := Σ; retroknowledge := retro |}). split. - * red; cbn. split; [split;[lsets|csets]|]. + * red; cbn. split; [split;[lsets|csets]| |]. exists [(kn, decl)] => //. + apply Retroknowledge.extends_refl. * split => //. * apply o0. - intros hl. destruct (IHΣp hl) as [Σ' []]. exists Σ'. split=> //. destruct e as [eu ed]. red; cbn in *. - split; [auto|]. + split; [auto| |auto]. destruct ed as [Σ'' ->]. exists (Σ'' ,, (kn, d)) => //. Qed. diff --git a/pcuic/theories/PCUICValidity.v b/pcuic/theories/PCUICValidity.v index e06af09b5..ff25a7ed6 100644 --- a/pcuic/theories/PCUICValidity.v +++ b/pcuic/theories/PCUICValidity.v @@ -393,6 +393,14 @@ Section Validity. - (* CoFix *) eapply nth_error_all in X0 as [s Hs]; pcuic. + - (* Primitive *) + destruct X0 as [s [hty hbod huniv]]. + exists s@[[]]. + change (tSort s@[[]]) with (tSort s)@[[]]. + rewrite -hty. + refine (type_Const _ _ _ [] _ wfΓ H0 _). + rewrite huniv //. + - (* Conv *) now exists s. Qed. diff --git a/pcuic/theories/PCUICWcbvEval.v b/pcuic/theories/PCUICWcbvEval.v index af953cb78..2ef868d78 100644 --- a/pcuic/theories/PCUICWcbvEval.v +++ b/pcuic/theories/PCUICWcbvEval.v @@ -46,7 +46,8 @@ Definition atom t := | tCoFix _ _ | tLambda _ _ _ | tSort _ - | tProd _ _ _ => true + | tProd _ _ _ + | tPrim _ => true | _ => false end. @@ -111,6 +112,14 @@ Definition isAxiom Σ x := | _ => false end. +Definition isPrim t := + match t with + | tPrim _ => true + | _ => false + end. + +Definition isPrimApp t := isPrim (head t). + Definition substl defs body : term := fold_left (fun bod term => csubst term 0 bod) defs body. @@ -155,6 +164,9 @@ Proof. destruct args using rev_case => //. rewrite mkApps_app /= //. Qed. Lemma nisArityHead_mkApps f args : ~~ isArityHead f -> ~~ isArityHead (mkApps f args). Proof. destruct args using rev_case => //. rewrite mkApps_app /= //. Qed. +Lemma nisPrim_mkApps f args : ~~ isPrim f -> ~~ isPrim (mkApps f args). +Proof. destruct args using rev_case => //. rewrite mkApps_app /= //. Qed. + (* Lemma isLambda_mkApps f args : ~~ isApp f -> isLambda f = isLambda (mkApps f args). Proof. destruct args using rev_case => //. rewrite mkApps_app /= //. Qed. *) @@ -175,6 +187,9 @@ Proof. now rewrite /isConstructApp head_mkApps. Qed. +Lemma isPrimApp_mkApps f args : isPrimApp (mkApps f args) = isPrimApp f. +Proof. now rewrite /isPrimApp head_mkApps. Qed. + Section Wcbv. Context (Σ : global_env). @@ -262,7 +277,7 @@ Section Wcbv. (** Non redex-producing heads applied to values are values *) | eval_app_cong f f' a a' : eval f f' -> - ~~ (isLambda f' || isFixApp f' || isArityHead f' || isConstructApp f') -> + ~~ (isLambda f' || isFixApp f' || isArityHead f' || isConstructApp f' || isPrimApp f') -> eval a a' -> eval (tApp f a) (tApp f' a') @@ -443,12 +458,12 @@ Section Wcbv. - destruct (mkApps_elim f' [a']). eapply value_mkApps_inv in IHev1 => //. destruct IHev1 as [?|[]]; intuition subst. - * rewrite a0. - simpl. rewrite a0 in i. simpl in *. + * rewrite a0 /=. + rewrite a0 in i. simpl in *. apply (value_app f0 [a']). destruct f0; simpl in * |- *; try congruence. - constructor. - econstructor; auto. auto. + all:try solve [repeat constructor; auto]. + auto. * rewrite -[tApp _ _](mkApps_app _ (firstn n l) [a']). eapply value_app; auto. len. rewrite isFixApp_mkApps // isConstructApp_mkApps // in i. @@ -506,7 +521,8 @@ Section Wcbv. rewrite !mkApps_app /=. eapply eval_app_cong; tea. eapply IHargs => //. - rewrite isFixApp_mkApps // /= isConstructApp_mkApps // !negb_or. rtoProp; intuition auto. + rewrite isFixApp_mkApps // /= isConstructApp_mkApps // !negb_or isPrimApp_mkApps. + rtoProp; intuition auto. apply nisLambda_mkApps => //. apply nisArityHead_mkApps => //. Qed. @@ -523,7 +539,8 @@ Section Wcbv. rewrite !mkApps_app /=. eapply eval_app_cong; tea. eapply IHargs => //. - rewrite isFixApp_mkApps // /= isConstructApp_mkApps // !negb_or. rtoProp; intuition auto. + rewrite isFixApp_mkApps // /= isConstructApp_mkApps // !negb_or isPrimApp_mkApps. + rtoProp; intuition auto. apply nisLambda_mkApps => //. apply nisArityHead_mkApps => //. Qed. diff --git a/pcuic/theories/PCUICWeakeningEnv.v b/pcuic/theories/PCUICWeakeningEnv.v index 954c66c65..3290b8f05 100644 --- a/pcuic/theories/PCUICWeakeningEnv.v +++ b/pcuic/theories/PCUICWeakeningEnv.v @@ -436,6 +436,7 @@ Proof using P Pcmp cf. split => //. - red. rewrite eq. apply onu. - rewrite eq. rewrite eq' in ond. + rewrite -e in ond. revert ond; clear. induction Σ''; cbn; auto. intros H; depelim H. diff --git a/pcuic/theories/Syntax/PCUICDepth.v b/pcuic/theories/Syntax/PCUICDepth.v index f8c5ac716..4dd36099b 100644 --- a/pcuic/theories/Syntax/PCUICDepth.v +++ b/pcuic/theories/Syntax/PCUICDepth.v @@ -1,5 +1,4 @@ (* Distributed under the terms of the MIT license. *) -(* Distributed under the terms of the MIT license. *) From Coq Require Import ssreflect Program Lia BinPos Arith.Compare_dec Bool. From MetaCoq.Template Require Import utils LibHypsNaming. From MetaCoq.PCUIC Require Import PCUICAst PCUICAstUtils PCUICCases PCUICSize PCUICInduction. @@ -335,10 +334,10 @@ Lemma term_forall_ctx_list_ind : (forall Γ (m : mfixpoint term) (n : nat), All_local_env (PCUICInduction.on_local_decl (fun Γ' t => P (Γ ,,, Γ') t)) (fix_context m) -> tFixProp (P Γ) (P (Γ ,,, fix_context m)) m -> P Γ (tCoFix m n)) -> - (* (forall Γ p, P Γ (tPrim p)) -> *) + (forall Γ p, P Γ (tPrim p)) -> forall Γ (t : term), P Γ t. Proof. - intros ???????????????? Γ t. + intros ????????????????? Γ t. revert Γ t. set(foo:=CoreTactics.the_end_of_the_section). intros. Subterm.rec_wf_rel aux t (MR lt depth); unfold MR in *; simpl. clear H1. assert (auxl : forall Γ {A} (l : list A) (f : A -> term), @@ -456,10 +455,10 @@ Lemma term_ind_depth_app : (forall (m : mfixpoint term) (n : nat), onctx P (fix_context m) -> tFixProp P P m -> P (tCoFix m n)) -> - (* (forall p, P (tPrim p)) -> *) + (forall p, P (tPrim p)) -> forall (t : term), P t. Proof. - intros ???????????????? t. + intros ????????????????? t. revert t. set(foo:=CoreTactics.the_end_of_the_section). intros. Subterm.rec_wf_rel aux t (MR lt depth); unfold MR in *; simpl. clear H0. assert (auxl : forall {A} (l : list A) (f : A -> term), diff --git a/pcuic/theories/Syntax/PCUICInduction.v b/pcuic/theories/Syntax/PCUICInduction.v index d21e9d86e..61d4cf427 100644 --- a/pcuic/theories/Syntax/PCUICInduction.v +++ b/pcuic/theories/Syntax/PCUICInduction.v @@ -19,8 +19,6 @@ Import PCUICEnvTyping. Allows to get the right induction principle on lists of terms appearing in the term syntax (in evar, applications, branches of cases and (co-)fixpoints. *) -(* Notation prim_ind P p := (P (tPrim p)). *) - (** Custom induction principle on syntax, dealing with the various lists appearing in terms. *) Lemma term_forall_list_ind : @@ -43,7 +41,7 @@ Lemma term_forall_list_ind : (forall (s : projection) (t : term), P t -> P (tProj s t)) -> (forall (m : mfixpoint term) (n : nat), tFixProp P P m -> P (tFix m n)) -> (forall (m : mfixpoint term) (n : nat), tFixProp P P m -> P (tCoFix m n)) -> - (* (forall p, prim_ind P p) -> *) + (forall p, P (tPrim p)) -> forall t : term, P t. Proof. intros until t. revert t. @@ -261,11 +259,11 @@ Lemma term_forall_mkApps_ind : (forall (s : projection) (t : term), P t -> P (tProj s t)) -> (forall (m : mfixpoint term) (n : nat), tFixProp P P m -> P (tFix m n)) -> (forall (m : mfixpoint term) (n : nat), tFixProp P P m -> P (tCoFix m n)) -> - (* (forall i, prim_ind P i) -> *) + (forall i, P (tPrim i)) -> forall t : term, P t. Proof. intros until t. - (* rename X14 into Pprim. *) + rename X14 into Pprim. assert (Acc (MR lt size) t) by eapply measure_wf, Wf_nat.lt_wf. induction H. rename X14 into auxt. clear H. rename x into t. move auxt at top. @@ -487,10 +485,10 @@ Lemma term_forall_ctx_list_ind : (forall Γ (m : mfixpoint term) (n : nat), All_local_env (on_local_decl (fun Γ' t => P (Γ ,,, Γ') t)) (fix_context m) -> tFixProp (P Γ) (P (Γ ,,, fix_context m)) m -> P Γ (tCoFix m n)) -> - (* (forall Γ p, P Γ (tPrim p)) -> *) + (forall Γ p, P Γ (tPrim p)) -> forall Γ (t : term), P Γ t. Proof. - intros ???????????????? Γ t. + intros ????????????????? Γ t. revert Γ t. set(foo:=CoreTactics.the_end_of_the_section). intros. Subterm.rec_wf_rel aux t (MR lt size); unfold MR in *; simpl. clear H1. assert (auxl : forall Γ {A} (l : list A) (f : A -> term), @@ -594,7 +592,7 @@ Lemma term_ind_size_app : tFixProp P P m -> P (tFix m n)) -> (forall (m : mfixpoint term) (n : nat), tFixProp (P) P m -> P (tCoFix m n)) -> - (* (forall p, P (tPrim p)) -> *) + (forall p, P (tPrim p)) -> forall (t : term), P t. Proof. intros. diff --git a/pcuic/theories/Syntax/PCUICNamelessDef.v b/pcuic/theories/Syntax/PCUICNamelessDef.v index 19ed333d1..26e45d4c9 100644 --- a/pcuic/theories/Syntax/PCUICNamelessDef.v +++ b/pcuic/theories/Syntax/PCUICNamelessDef.v @@ -57,7 +57,7 @@ Fixpoint nameless (t : term) : bool := | tCoFix mfix idx => forallb (fun d => banon d.(dname)) mfix && forallb (test_def nameless nameless) mfix - (* | tPrim _ => true *) + | tPrim _ => true end. Notation nameless_ctx := (forallb (nameless_decl nameless)). @@ -105,7 +105,7 @@ Fixpoint nl (t : term) : term := | tProj p c => tProj p (nl c) | tFix mfix idx => tFix (map (map_def_anon nl nl) mfix) idx | tCoFix mfix idx => tCoFix (map (map_def_anon nl nl) mfix) idx - (* | tPrim p => tPrim p *) + | tPrim p => tPrim p end. Definition nlctx (Γ : context) : context := @@ -158,7 +158,8 @@ Definition nl_global_declarations (Σ : global_declarations) : global_declaratio Definition nl_global_env (Σ : global_env) : global_env := {| universes := Σ.(universes); - declarations := nl_global_declarations Σ.(declarations) |}. + declarations := nl_global_declarations Σ.(declarations); + retroknowledge := Σ.(retroknowledge) |}. Definition nlg (Σ : global_env_ext) : global_env_ext := let '(Σ, φ) := Σ in diff --git a/pcuic/theories/Syntax/PCUICOnFreeVars.v b/pcuic/theories/Syntax/PCUICOnFreeVars.v index d0b222e9f..8074815a7 100644 --- a/pcuic/theories/Syntax/PCUICOnFreeVars.v +++ b/pcuic/theories/Syntax/PCUICOnFreeVars.v @@ -87,7 +87,7 @@ Fixpoint on_free_vars (p : nat -> bool) (t : term) : bool := | tFix mfix idx | tCoFix mfix idx => List.forallb (test_def (on_free_vars p) (on_free_vars (shiftnP #|mfix| p))) mfix | tVar _ | tSort _ | tConst _ _ | tInd _ _ | tConstruct _ _ _ => true - (* | tPrim _ => true *) + | tPrim _ => true end. Lemma on_free_vars_ext (p q : nat -> bool) t : @@ -1379,7 +1379,7 @@ Lemma term_on_free_vars_ind : (forall p (m : mfixpoint term) (i : nat), tFixProp (on_free_vars p) (on_free_vars (shiftnP #|fix_context m| p)) m -> tFixProp (P p) (P (shiftnP #|fix_context m| p)) m -> P p (tCoFix m i)) -> - (* (forall p pr, P p (tPrim pr)) -> *) + (forall p pr, P p (tPrim pr)) -> forall p (t : term), on_free_vars p t -> P p t. Proof. intros until t. revert p t. diff --git a/pcuic/theories/Syntax/PCUICReflect.v b/pcuic/theories/Syntax/PCUICReflect.v index 8c84308eb..73c6d6441 100644 --- a/pcuic/theories/Syntax/PCUICReflect.v +++ b/pcuic/theories/Syntax/PCUICReflect.v @@ -114,6 +114,7 @@ Fixpoint eqb_term (u v : term) : bool := eqb x.(rarg) y.(rarg) && eqb x.(dname) y.(dname)) mfix mfix' + | tPrim p, tPrim p' => eqb p p' | _, _ => false end. diff --git a/pcuic/theories/TemplateToPCUIC.v b/pcuic/theories/TemplateToPCUIC.v index daa0db547..d503a79a9 100644 --- a/pcuic/theories/TemplateToPCUIC.v +++ b/pcuic/theories/TemplateToPCUIC.v @@ -1,8 +1,8 @@ (* Distributed under the terms of the MIT license. *) From Coq Require Import Uint63 FloatOps FloatAxioms. -From MetaCoq.Template Require Import config utils AstUtils EnvMap. +From MetaCoq.Template Require Import config utils AstUtils Primitive EnvMap. From MetaCoq.Template Require TemplateProgram. -From MetaCoq.PCUIC Require Import PCUICAst PCUICCases PCUICProgram. +From MetaCoq.PCUIC Require Import PCUICAst PCUICPrimitive PCUICCases PCUICProgram. Lemma to_Z_bounded_bool (i : Uint63.int) : ((0 <=? Uint63.to_Z i) && (Uint63.to_Z i let mfix' := List.map (map_def trans trans) mfix in tCoFix mfix' idx - (* | Ast.tInt n => tPrim (primInt; primIntModel (uint63_to_model n)) *) - (* | Ast.tFloat n => tPrim (primFloat; primFloatModel (float64_to_model n)) *) + | Ast.tInt n => tPrim (primInt; primIntModel n) + | Ast.tFloat n => tPrim (primFloat; primFloatModel n) end. Definition trans_decl (d : Ast.Env.context_decl) := @@ -166,14 +166,14 @@ Definition trans_global_decls env (d : Ast.Env.global_declarations) : global_env let decl' := on_snd (trans_global_decl Σ') decl in add_global_decl Σ' decl') env d. -Definition empty_trans_env univs := - let init_global_env := {| universes := univs; declarations := [] |} in +Definition empty_trans_env univs retro := + let init_global_env := {| universes := univs; declarations := []; retroknowledge := retro |} in {| trans_env_env := init_global_env; trans_env_map := EnvMap.empty; trans_env_repr := fun y => eq_refl |}. Definition trans_global_env (d : Ast.Env.global_env) : global_env_map := - let init := empty_trans_env d.(Ast.Env.universes) in + let init := empty_trans_env d.(Ast.Env.universes) d.(Ast.Env.retroknowledge) in trans_global_decls init d.(Ast.Env.declarations). Definition trans_global (Σ : Ast.Env.global_env_ext) : global_env_ext_map := diff --git a/pcuic/theories/TemplateToPCUICCorrectness.v b/pcuic/theories/TemplateToPCUICCorrectness.v index 250cda12d..d8081e7f2 100644 --- a/pcuic/theories/TemplateToPCUICCorrectness.v +++ b/pcuic/theories/TemplateToPCUICCorrectness.v @@ -92,7 +92,7 @@ Lemma trans_lookup_minductive {cf} {Σ : global_env_map} mind : wf Σ -> Proof. intros wf. unfold TransLookup.lookup_minductive. - rewrite (EnvMap .lookup_spec Σ.(declarations)) //. + rewrite (EnvMap.lookup_spec Σ.(declarations)) //. now eapply wf_fresh_globals. apply Σ. Qed. @@ -151,7 +151,7 @@ Lemma extends_trans_global_decls_acc (Σ' : global_env_map) (Σ : Ast.Env.global extends Σ' (trans_global_decls Σ' Σ). Proof. induction Σ. - * split; cbn. apply incl_cs_refl. now exists []. + * split; cbn. apply incl_cs_refl. now exists []. apply Retroknowledge.extends_refl. * rewrite /=. destruct IHΣ as [univs [Σ'' eq]]. cbn in *. split; cbn; auto. @@ -177,14 +177,14 @@ Lemma trans_lookup_env {cf} {Σ : Ast.Env.global_env} cst {wfΣ : Typing.wf Σ} lookup_env (trans_global_env Σ) cst = Some (trans_global_decl (trans_global_env Σ') d)] end. Proof. - destruct Σ as [univs Σ]. + destruct Σ as [univs Σ retro]. induction Σ. - cbn; auto. - unfold Ast.Env.lookup_env. cbn -[trans_global_env]. destruct eq_kername eqn:eqk. change (eq_kername cst a.1) with (eqb cst a.1) in eqk. apply eqb_eq in eqk; subst. - eexists {| S.Env.universes := univs; S.Env.declarations := Σ |}. + eexists {| S.Env.universes := univs; S.Env.declarations := Σ; S.Env.retroknowledge := retro |}. split. * split => //. now exists [a]. * destruct wfΣ as [onu ond]. depelim ond. @@ -192,7 +192,8 @@ Proof. * eapply TypingWf.typing_wf_sigma in wfΣ. destruct wfΣ as [onu ond]. now depelim ond. * split => //. - now exists [(a.1, trans_global_decl (trans_global_env {| S.Env.universes := univs; S.Env.declarations := Σ |}) a.2)]. + now exists [(a.1, trans_global_decl (trans_global_env {| S.Env.universes := univs; S.Env.declarations := Σ; + S.Env.retroknowledge := retro |}) a.2)]. * cbn. now rewrite eq_kername_refl. * destruct wfΣ as [onu ond]. depelim ond. specialize (IHΣ (onu, ond)). @@ -224,6 +225,7 @@ Proof. split. - eapply cs_subset_trans; tea. - eexists (s' ++ s); cbn. rewrite eq' eq. now rewrite app_assoc. + - now etransitivity; tea. Qed. Lemma trans_weakening {cf} Σ {Σ' : global_env_map} t : @@ -2204,6 +2206,13 @@ Proof. now rewrite global_ext_levels_trans. Qed. +Lemma trans_env_retroknowledge Σ : retroknowledge (trans_global_env Σ) = S.Env.retroknowledge Σ. +Proof. + destruct Σ as [univs decls retro]. + rewrite /trans_global_env /=. + induction decls; cbn; auto. +Qed. + Local Hint Resolve trans_wf_universe : trans. Local Hint Transparent Ast.Env.global_env_ext : trans. Local Hint Transparent Universe.t : trans. @@ -2444,6 +2453,18 @@ Proof. now eapply TypingWf.typing_wf in Hs'. -- destruct decl; reflexivity. + - cbn. econstructor; cbn; eauto. + + rewrite trans_env_retroknowledge //. + + now apply forall_decls_declared_constant. + + move: X0; rewrite /Ast.Env.primitive_invariants /primitive_invariants. + intros [s []]; exists s; split => //; + destruct cdecl as [ty [?|] ?]; cbn in *; subst; auto => //. + - cbn. econstructor; cbn; eauto. + + rewrite trans_env_retroknowledge //. + + now apply forall_decls_declared_constant. + + move: X0; rewrite /Ast.Env.primitive_invariants /primitive_invariants. + intros [s []]; exists s; split => //; + destruct cdecl as [ty [?|] ?]; cbn in *; subst; auto => //. - assert (WfAst.wf Σ B). { now apply typing_wf in X2. } eapply type_Cumul; eauto. @@ -2954,9 +2975,18 @@ Proof. induction Σ => /= //. Qed. +Lemma trans_env_env_retroknowledge {Σ : Ast.Env.global_env} : + retroknowledge (trans_env_env (trans_global_env Σ)) = Ast.Env.retroknowledge Σ. +Proof. + destruct Σ as [univs Σ] . + unfold trans_global_env; cbn -[trans_global_decls]. + induction Σ => /= //. +Qed. + Lemma env_eq (g g' : global_env) : g.(universes) = g'.(universes) -> g.(declarations) = g'.(declarations) -> + g.(retroknowledge) = g'.(retroknowledge) -> g = g'. Proof. destruct g, g'; cbn. congruence. @@ -2983,7 +3013,7 @@ Lemma trans_on_global_env `{checker_flags} Σ : Proof. intros X X0. simpl in *. - destruct Σ as [univs Σ]. + destruct Σ as [univs Σ retro]. destruct X0 as [onu ond]. split => //. { now rewrite trans_env_env_universes. } cbn -[trans_global_env] in *. @@ -2995,13 +3025,14 @@ Proof. clear -o. now erewrite trans_global_decl_universes in o. - simpl. - set (Σg := {| Ast.Env.universes := univs; Ast.Env.declarations := Σ |}). + set (Σg := {| Ast.Env.universes := univs; Ast.Env.declarations := Σ; Ast.Env.retroknowledge := retro |}). set (X0 := (onu, ond) : Typing.wf Σg). assert (trans_env_env (trans_global_env Σg) = {| universes := univs; - declarations := declarations (trans_global_decls (empty_trans_env univs) Σ) |}) as <-. - { apply env_eq. - now rewrite trans_env_env_universes. reflexivity. } + declarations := declarations (trans_global_decls (empty_trans_env univs retro) Σ) |}) as <-. + { apply env_eq. + now rewrite trans_env_env_universes. reflexivity. + now rewrite trans_env_env_retroknowledge. } assert (wfΣg : PCUICTyping.wf (trans_global_env Σg)). { split; rewrite trans_env_env_universes //. } have wfdecl := on_global_decl_wf (Σ := (Σg, udecl)) X0 o0. @@ -3014,7 +3045,7 @@ Proof. * destruct o0 as [onI onP onNP]. simpl. change (trans_env_env (trans_global_env Σg), Ast.Env.ind_universes m) with (global_env_ext_map_global_env_ext (trans_global (Σg, Ast.Env.ind_universes m))) in *. - change (trans_global_decls (empty_trans_env univs) Σ) with (global_env_ext_map_global_env_map (trans_global (Σg, Ast.Env.ind_universes m))). + change (trans_global_decls (empty_trans_env univs retro) Σ) with (global_env_ext_map_global_env_map (trans_global (Σg, Ast.Env.ind_universes m))). constructor; auto. -- have wfpars := on_global_inductive_wf_params wfdecl. eapply on_global_inductive_wf_bodies in wfdecl. @@ -3223,7 +3254,7 @@ Proof. move=> [univs' [i [i' []]]] vu cu cu' hl. exists univs', i, i'; split => //. all:change (trans_env_env (trans_global_env Σg), univs') with (global_env_ext_map_global_env_ext (trans_global (Σg, univs'))); - now eapply trans_consistent_instance_ext_gen. + now eapply trans_consistent_instance_ext_gen. Qed. Lemma template_to_pcuic_env {cf} Σ : Template.Typing.wf Σ -> wf (trans_global_env Σ). diff --git a/pcuic/theories/TemplateToPCUICExpanded.v b/pcuic/theories/TemplateToPCUICExpanded.v index a338bbaa0..3ba301f97 100644 --- a/pcuic/theories/TemplateToPCUICExpanded.v +++ b/pcuic/theories/TemplateToPCUICExpanded.v @@ -35,11 +35,12 @@ Proof. Qed. Import PCUICWeakeningEnv. - +(* TODO move *) Lemma extends_decls_trans Σ Σ' Σ'' : extends_decls Σ Σ' -> extends_decls Σ' Σ'' -> extends_decls Σ Σ''. Proof. - intros [? [ext ?]] [? [ext' ?]]. subst. split. now transitivity Σ'. - rewrite e0 in e2. exists (ext' ++ ext). now rewrite -app_assoc. + intros [e [ext e'] er] [e0 [ext' e0'] er']. subst. split. now transitivity Σ'. + exists (ext' ++ ext). now rewrite -app_assoc. + congruence. Qed. Lemma declared_minductive_expanded Σ c mdecl : @@ -240,13 +241,17 @@ Proof with eauto using expanded. Qed. -Lemma wf_cons_inv {cf} univs (Σ : global_declarations) d : wf {| universes := univs; declarations := d :: Σ |} -> wf {| universes := univs; declarations := Σ |}. +Lemma wf_cons_inv {cf} Σ' (Σ : global_declarations) d : + wf (set_declarations Σ' (d :: Σ)) -> wf (set_declarations Σ' Σ). Proof. intros []. split => //. now depelim o0. Qed. -Lemma template_wf_cons_inv {cf} univs (Σ : Ast.Env.global_declarations) d : Typing.wf {| Ast.Env.universes := univs; Ast.Env.declarations := d :: Σ |} -> - let Σ' := {| Ast.Env.universes := univs; Ast.Env.declarations := Σ |} in +Lemma template_wf_cons_inv {cf} univs retro (Σ : Ast.Env.global_declarations) d : + Typing.wf {| Ast.Env.universes := univs; Ast.Env.declarations := d :: Σ; + Ast.Env.retroknowledge := retro |} -> + let Σ' := {| Ast.Env.universes := univs; Ast.Env.declarations := Σ; + Ast.Env.retroknowledge := retro |} in Typing.wf Σ' × Typing.on_global_decl Typing.cumul_gen (WfAst.wf_decl_pred) (Σ', Ast.universes_decl_of_decl d.2) d.1 d.2 × ST.on_udecl univs (Ast.universes_decl_of_decl d.2). Proof. @@ -259,20 +264,14 @@ Proof. cbn. split => //. Qed. -Lemma trans_global_env_cons univs (Σ : Ast.Env.global_declarations) decl : - trans_global_env {| S.Env.universes := univs; S.Env.declarations := decl :: Σ |} = - let Σ' := trans_global_env {| S.Env.universes := univs; S.Env.declarations := Σ |} in +Lemma trans_global_env_cons univs retro (Σ : Ast.Env.global_declarations) decl : + trans_global_env {| S.Env.universes := univs; S.Env.declarations := decl :: Σ; S.Env.retroknowledge := retro |} = + let Σ' := trans_global_env {| S.Env.universes := univs; S.Env.declarations := Σ; S.Env.retroknowledge := retro |} in add_global_decl Σ' (decl.1, trans_global_decl Σ' decl.2). Proof. reflexivity. Qed. Arguments trans_global_env : simpl never. -Lemma eta_global_env Σ : Σ = {| universes := Σ.(universes); declarations := Σ.(declarations) |}. -Proof. now destruct Σ. Qed. - -Lemma eta_template_global_env Σ : Σ = {| S.Env.universes := Σ.(S.Env.universes); S.Env.declarations := Σ.(S.Env.declarations) |}. -Proof. now destruct Σ. Qed. - Lemma All_fold_map (P : context -> context_decl -> Type) (f : Ast.Env.context_decl -> context_decl) ctx : All_fold P (map f ctx) <~> All_fold (fun Γ d => P (map f Γ) (f d)) ctx. Proof. diff --git a/pcuic/theories/TemplateToPCUICWcbvEval.v b/pcuic/theories/TemplateToPCUICWcbvEval.v index 976f22402..ca9e7cd53 100644 --- a/pcuic/theories/TemplateToPCUICWcbvEval.v +++ b/pcuic/theories/TemplateToPCUICWcbvEval.v @@ -432,7 +432,7 @@ Qed. Lemma eval_mkApps_cong Σ f args : value Σ f -> All (value Σ) args -> - ~~ (isLambda f || isFixApp f || isArityHead f || isConstructApp f) -> + ~~ (isLambda f || isFixApp f || isArityHead f || isConstructApp f || isPrimApp f) -> eval Σ (mkApps f args) (mkApps f args). Proof. intros vf a. move: a. @@ -447,8 +447,10 @@ Proof. destruct args using rev_case; cbn in hf' => //. rewrite !mkApps_app /= orb_false_r in hf'. rewrite -[tApp _ _](mkApps_app _ _ [x0]) in hf'. - rewrite isFixApp_mkApps isConstructApp_mkApps in hf'. - move/orP: hf' => [] ->; now rewrite !orb_true_r. + rewrite isFixApp_mkApps isConstructApp_mkApps isPrimApp_mkApps in hf'. + move/orP: hf' => []. + * move/orP => [] ->; now rewrite !orb_true_r. + * move=> ->; now rewrite orb_true_r. Qed. Lemma isLambda_mkApps {f args} : args <> [] -> ~~ isLambda (mkApps f args). @@ -463,6 +465,12 @@ Proof. rewrite mkApps_app /= //. Qed. +Lemma isPrim_mkApps {f args} : args <> [] -> ~~ isPrim (mkApps f args). +Proof. + destruct args using rev_case; cbn; try congruence. + rewrite mkApps_app /= //. +Qed. + Lemma isFixApp_trans Σ f : ~~ Ast.isApp f -> isFixApp (trans Σ f) -> WcbvEval.isFixApp f. Proof. rewrite /isFixApp /WcbvEval.isFixApp. @@ -778,9 +786,11 @@ Proof. eapply isLambda_mkApps. destruct args => //. eapply isArityHead_mkApps. destruct args => //. rewrite isConstructApp_mkApps //. + rewrite isPrimApp_mkApps //. eapply isLambda_mkApps. destruct args => //. eapply isArityHead_mkApps. destruct args => //. rewrite isConstructApp_mkApps //. + rewrite isPrimApp_mkApps //. - eapply eval_atom. destruct t => //. diff --git a/pcuic/theories/Typing/PCUICClosedTyp.v b/pcuic/theories/Typing/PCUICClosedTyp.v index 04e5f9bdc..27553e428 100644 --- a/pcuic/theories/Typing/PCUICClosedTyp.v +++ b/pcuic/theories/Typing/PCUICClosedTyp.v @@ -834,7 +834,7 @@ Lemma term_closedn_list_ind : (forall k (s : projection) (t : term), P k t -> P k (tProj s t)) -> (forall k (m : mfixpoint term) (n : nat), tFixProp (P k) (P (#|fix_context m| + k)) m -> P k (tFix m n)) -> (forall k (m : mfixpoint term) (n : nat), tFixProp (P k) (P (#|fix_context m| + k)) m -> P k (tCoFix m n)) -> - (* (forall k p, P k (tPrim p)) -> *) + (forall k p, P k (tPrim p)) -> forall k (t : term), closedn k t -> P k t. Proof. intros until t. revert k t. @@ -946,7 +946,7 @@ Lemma term_noccur_between_list_ind : (forall k n (s : projection) (t : term), P k n t -> P k n (tProj s t)) -> (forall k n (m : mfixpoint term) (i : nat), tFixProp (P k n) (P (#|fix_context m| + k) n) m -> P k n (tFix m i)) -> (forall k n (m : mfixpoint term) (i : nat), tFixProp (P k n) (P (#|fix_context m| + k) n) m -> P k n (tCoFix m i)) -> - (* (forall k n p, P k n (tPrim p)) -> *) + (forall k n p, P k n (tPrim p)) -> forall k n (t : term), noccur_between k n t -> P k n t. Proof. intros until t. revert k n t. diff --git a/pcuic/theories/Typing/PCUICInstTyp.v b/pcuic/theories/Typing/PCUICInstTyp.v index 6e11638ca..3ea034fc6 100644 --- a/pcuic/theories/Typing/PCUICInstTyp.v +++ b/pcuic/theories/Typing/PCUICInstTyp.v @@ -572,6 +572,9 @@ Proof. * now apply inst_wf_cofixpoint. * reflexivity. + - intros Σ wfΣ Γ wfΓ p pty cdecl _ hp hdecl pinv Δ σ hΔ hσ. + cbn. econstructor; tea. + - intros Σ wfΣ Γ wfΓ t A B X hwf ht iht hB ihB hcum Δ σ hΔ hσ. eapply type_Cumul. + eapply iht. all: auto. diff --git a/pcuic/theories/Typing/PCUICRenameTyp.v b/pcuic/theories/Typing/PCUICRenameTyp.v index 7fbf364cf..1c3e765d4 100644 --- a/pcuic/theories/Typing/PCUICRenameTyp.v +++ b/pcuic/theories/Typing/PCUICRenameTyp.v @@ -1044,6 +1044,9 @@ Proof. * now eapply rename_wf_cofixpoint. + reflexivity. + - intros Σ wfΣ Γ wfΓ p pty cdecl _ hp hdecl pinv P Δ f hf. + cbn. econstructor; tea. apply hf. + - intros Σ wfΣ Γ wfΓ t A B X hwf ht iht htB ihB cum P Δ f hf. eapply type_Cumul. + eapply iht; tea. diff --git a/pcuic/theories/Typing/PCUICUnivSubstitutionTyp.v b/pcuic/theories/Typing/PCUICUnivSubstitutionTyp.v index 5e7e866d1..5fefd80fe 100644 --- a/pcuic/theories/Typing/PCUICUnivSubstitutionTyp.v +++ b/pcuic/theories/Typing/PCUICUnivSubstitutionTyp.v @@ -366,7 +366,9 @@ Proof using Type. unfold wf_cofixpoint, wf_cofixpoint_gen. rewrite map_map_compose. now rewrite subst_instance_check_one_cofix. - + + - econstructor; eauto. + - intros t0 A B X X0 X1 X2 X3 X4 cum u univs wfΣ' H. econstructor. + eapply X2; aa. diff --git a/pcuic/theories/Typing/PCUICWeakeningEnvTyp.v b/pcuic/theories/Typing/PCUICWeakeningEnvTyp.v index 13f76088f..682c33772 100644 --- a/pcuic/theories/Typing/PCUICWeakeningEnvTyp.v +++ b/pcuic/theories/Typing/PCUICWeakeningEnvTyp.v @@ -74,6 +74,20 @@ Qed. #[global] Hint Resolve extends_wf_fixpoint extends_wf_cofixpoint : extends. +Lemma extends_primitive_constant Σ Σ' p t : + extends Σ Σ' -> + primitive_constant Σ p = Some t -> + primitive_constant Σ' p = Some t. +Proof. + intros [_ _ ext]. + unfold primitive_constant. + case: ext. + destruct p; case => //. + - move=> _. case => //. + - move=> _; case => //. + - case => //. +Qed. +Local Hint Resolve extends_primitive_constant : extends. Lemma weakening_env `{checker_flags} : env_prop (fun Σ Γ t T => @@ -277,9 +291,9 @@ Proof. intros HP wfΣ' Hext HΣ. assert (wfΣ := extends_decls_wf _ _ wfΣ' Hext). destruct HΣ as [onu onΣ]. - destruct Σ as [univs Σ]; cbn in *. + destruct Σ as [univs Σ retro]; cbn in *. induction onΣ; simpl. 1: congruence. - assert (HH: extends_decls {| universes := univs; declarations := Σ |} Σ'). { + assert (HH: extends_decls {| universes := univs; declarations := Σ; retroknowledge := retro |} Σ'). { destruct Hext as [univs' [Σ'' HΣ'']]. split; eauto. exists (Σ'' ++ [(kn, d)]). now rewrite <- app_assoc. } @@ -298,9 +312,9 @@ Lemma weakening_env_lookup_on_global_env `{checker_flags} P Σ Σ' c decl : Proof. intros HP wfΣ wfΣ' Hext HΣ. destruct HΣ as [onu onΣ]. - destruct Σ as [univs Σ]; cbn in *. + destruct Σ as [univs Σ retro]; cbn in *. induction onΣ; simpl. 1: congruence. - assert (HH: extends {| universes := univs; declarations := Σ |} Σ'). { + assert (HH: extends {| universes := univs; declarations := Σ; retroknowledge := retro |} Σ'). { destruct Hext as [univs' [Σ'' HΣ'']]. split; eauto. exists (Σ'' ++ [(kn, d)]). now rewrite <- app_assoc. } @@ -322,6 +336,7 @@ Proof. split => //. - split; [lsets|csets]. - exists []; simpl; destruct Σ; eauto. + - apply Retroknowledge.extends_refl. Qed. Lemma weaken_decls_lookup_on_global_env `{checker_flags} P Σ c decl : diff --git a/pcuic/theories/utils/PCUICAstUtils.v b/pcuic/theories/utils/PCUICAstUtils.v index 6c6ced243..0e358d01a 100644 --- a/pcuic/theories/utils/PCUICAstUtils.v +++ b/pcuic/theories/utils/PCUICAstUtils.v @@ -40,7 +40,7 @@ Fixpoint string_of_term (t : term) := ^ string_of_term c ^ ")" | tFix l n => "Fix(" ^ (string_of_list (string_of_def string_of_term) l) ^ "," ^ string_of_nat n ^ ")" | tCoFix l n => "CoFix(" ^ (string_of_list (string_of_def string_of_term) l) ^ "," ^ string_of_nat n ^ ")" - (* | tPrim i => "Int(" ^ string_of_prim string_of_term i ^ ")" *) + | tPrim i => "Int(" ^ string_of_prim string_of_term i ^ ")" end. Ltac change_Sk := @@ -205,7 +205,7 @@ Fixpoint remove_arity (n : nat) (t : term) : term := | O => t | S n => match t with | tProd _ _ B => remove_arity n B - | _ => t (* todo *) + | _ => t (* TODO *) end end. @@ -282,7 +282,7 @@ Fixpoint decompose_prod_n_assum (Γ : context) n (t : term) : option (context * end end. -(* todo move *) +(* TODO move *) Lemma it_mkLambda_or_LetIn_app l l' t : it_mkLambda_or_LetIn (l ++ l') t = it_mkLambda_or_LetIn l' (it_mkLambda_or_LetIn l t). Proof. induction l in l', t |- *; simpl; auto. Qed. @@ -402,7 +402,7 @@ Ltac merge_All := #[global] Hint Rewrite @map_def_id @map_id : map. -(* todo move *) +(* TODO move *) Ltac close_All := match goal with | H : Forall _ _ |- Forall _ _ => apply (Forall_impl H); clear H; simpl diff --git a/pcuic/theories/utils/PCUICPretty.v b/pcuic/theories/utils/PCUICPretty.v index 796f6d879..0ca19b5d2 100644 --- a/pcuic/theories/utils/PCUICPretty.v +++ b/pcuic/theories/utils/PCUICPretty.v @@ -117,6 +117,13 @@ Module PrintTermTree. Import bytestring.Tree. Infix "^" := append. + Definition print_prim {term} (soft : term -> Tree.t) (p : prim_val) : Tree.t := + match p.π2 return Tree.t with + | primIntModel f => "(int: " ^ Primitive.string_of_prim_int f ^ ")" + | primFloatModel f => "(float: " ^ Primitive.string_of_float f ^ ")" + (* | primArrayModel a => "(array:" ^ ")" *) + end. + Section Aux. Context (print_term : list ident -> bool -> bool -> term -> t). @@ -260,7 +267,7 @@ Module PrintTermTree. | tCoFix l n => parens top ("let cofix " ^ print_defs print_term Γ l ^ nl ^ " in " ^ List.nth_default (string_of_nat n) (map (string_of_aname ∘ dname) l) n) - (* | tPrim i => parens top (string_of_prim (print_term Γ true false) i) *) + | tPrim i => parens top (print_prim (print_term Γ true false) i) end. End env. @@ -284,22 +291,28 @@ Module PrintTermTree. else print_list (print_one_cstr Γpars mib) nl oib.(ind_ctors). End env. + Definition print_recursivity_kind k := + match k with + | Finite => "Inductive" + | CoFinite => "CoInductive" + | BiFinite => "Variant" + end. + Fixpoint print_env_aux (short : bool) (prefix : nat) (Σ : global_env) (acc : t) : t := match prefix with | 0 => match Σ.(declarations) with [] => acc | _ => ("..." ^ nl ^ acc) end | S n => - let univs := Σ.(universes) in match Σ.(declarations) with | [] => acc - | (kn, InductiveDecl mib) :: Σ => - let Σ' := ({| universes := univs; declarations := Σ |}, mib.(ind_universes)) in + | (kn, InductiveDecl mib) :: decls => + let Σ' := (set_declarations Σ decls, mib.(ind_universes)) in let names := fresh_names Σ' [] (arities_context mib.(ind_bodies)) in print_env_aux short n Σ'.1 - ("Inductive " ^ - print_list (print_one_ind Σ' short names mib) nl mib.(ind_bodies) ^ "." ^ + (print_recursivity_kind mib.(ind_finite) ^ " " ^ + print_list (print_one_ind Σ' short names mib) (nl ^ "with ") mib.(ind_bodies) ^ "." ^ nl ^ acc) - | (kn, ConstantDecl cb) :: Σ => - let Σ' := ({| universes := univs; declarations := Σ |}, cb.(cst_universes)) in + | (kn, ConstantDecl cb) :: decls => + let Σ' := (set_declarations Σ decls, cb.(cst_universes)) in print_env_aux short n Σ'.1 ((match cb.(cst_body) with | Some _ => "Definition " diff --git a/pcuic/theories/utils/PCUICPrimitive.v b/pcuic/theories/utils/PCUICPrimitive.v index 83e2f3d18..2c21a212c 100644 --- a/pcuic/theories/utils/PCUICPrimitive.v +++ b/pcuic/theories/utils/PCUICPrimitive.v @@ -1,14 +1,9 @@ (* Distributed under the terms of the MIT license. *) -From MetaCoq.Template Require Import utils Universes BasicAst Reflect +From MetaCoq.Template Require Import utils Universes BasicAst Primitive Reflect Environment EnvironmentTyping. From Equations Require Import Equations. From Coq Require Import ssreflect. - -Variant prim_tag := - | primInt - | primFloat. - (* | primArray. *) -Derive NoConfusion EqDec for prim_tag. +From Coq Require Import Uint63 SpecFloat. (** We don't enforce the type of the array here*) Record array_model (term : Type) := @@ -22,8 +17,11 @@ Instance array_model_eqdec {term} (e : EqDec term) : EqDec (array_model term). Proof. eqdec_proof. Qed. Inductive prim_model (term : Type) : prim_tag -> Type := -| primIntModel (i : uint63_model) : prim_model term primInt -| primFloatModel (f : float64_model) : prim_model term primFloat. +| primIntModel (i : PrimInt63.int) : prim_model term primInt +| primFloatModel (f : PrimFloat.float) : prim_model term primFloat. + +(* | primIntModel (i : Int63.t) : prim_model term primInt *) +(* | primFloatModel (f : float64_model) : prim_model term primFloat. *) (* | primArrayModel (a : array_model term) : prim_model term primArray. *) Arguments primIntModel {term}. Arguments primFloatModel {term}. @@ -33,8 +31,8 @@ Derive Signature NoConfusion for prim_model. Definition prim_model_of (term : Type) (p : prim_tag) : Type := match p with - | primInt => uint63_model - | primFloat => float64_model + | primInt => PrimInt63.int + | primFloat => PrimFloat.float (* | primArray => array_model term *) end. @@ -62,11 +60,11 @@ Local Obligation Tactic := idtac. #[program] #[global] Instance reflect_eq_uint63 : ReflectEq uint63_model := - { eqb x y := eqb (proj1_sig x) (proj1_sig y) }. + { eqb x y := Z.eqb (proj1_sig x) (proj1_sig y) }. Next Obligation. cbn -[eqb]. intros x y. - elim: eqb_spec. constructor. + elim: Z.eqb_spec. constructor. now apply exist_irrel_eq. intros neq; constructor => H'; apply neq; now subst x. Qed. @@ -74,7 +72,7 @@ Qed. #[global] Instance reflect_eq_spec_float : ReflectEq SpecFloat.spec_float := EqDec_ReflectEq _. -#[program] +(* #[program] #[global] Instance reflect_eq_float64 : ReflectEq float64_model := { eqb x y := eqb (proj1_sig x) (proj1_sig y) }. @@ -84,7 +82,7 @@ Next Obligation. elim: eqb_spec. constructor. now apply exist_irrel_eq. intros neq; constructor => H'; apply neq; now subst x. -Qed. +Qed. *) (** Propositional UIP is needed below *) Set Equations With UIP. @@ -107,7 +105,7 @@ Definition string_of_float64_model (f : float64_model) := Definition string_of_prim {term} (soft : term -> string) (p : prim_val term) : string := match p.π2 return string with - | primIntModel f => "(int: " ^ string_of_Z (proj1_sig f) ^ ")" - | primFloatModel f => "(float: " ^ string_of_float64_model f ^ ")" + | primIntModel f => "(int: " ^ string_of_prim_int f ^ ")" + | primFloatModel f => "(float: " ^ string_of_float f ^ ")" (* | primArrayModel a => "(array:" ^ ")" *) end. diff --git a/safechecker/_PluginProject.in b/safechecker/_PluginProject.in index 2afc08a08..f46c9c616 100644 --- a/safechecker/_PluginProject.in +++ b/safechecker/_PluginProject.in @@ -9,18 +9,14 @@ src/META.coq-metacoq-safechecker # From template src/ssrbool.ml src/ssrbool.mli -# src/ssreflect.ml -# src/ssreflect.mli src/uGraph0.ml src/uGraph0.mli src/wGraph.ml src/wGraph.mli -src/envMap.mli -src/envMap.ml # From PCUIC -# src/pCUICPrimitive.mli -# src/pCUICPrimitive.ml +src/pCUICPrimitive.mli +src/pCUICPrimitive.ml src/pCUICAst.ml src/pCUICAst.mli src/pCUICAstUtils.ml diff --git a/safechecker/src/metacoq_safechecker_plugin.mlpack b/safechecker/src/metacoq_safechecker_plugin.mlpack index 726c1a658..5557f37d6 100644 --- a/safechecker/src/metacoq_safechecker_plugin.mlpack +++ b/safechecker/src/metacoq_safechecker_plugin.mlpack @@ -2,13 +2,14 @@ Utils Ssrbool WGraph UGraph0 -EnvMap Reflect +MCProd Classes0 Logic1 Relation Relation_Properties +PCUICPrimitive PCUICAst PCUICCases PCUICAstUtils diff --git a/safechecker/theories/Extraction.v b/safechecker/theories/Extraction.v index b269dda4f..0da97e699 100644 --- a/safechecker/theories/Extraction.v +++ b/safechecker/theories/Extraction.v @@ -1,6 +1,6 @@ (* Distributed under the terms of the MIT license. *) -From Coq Require Import OrdersTac Ascii ExtrOcamlBasic ExtrOcamlZInt ExtrOCamlInt63 ExtrOCamlFloats. -From MetaCoq.Template Require Import utils MC_ExtrOCamlZPosInt. +From Coq Require Import OrdersTac Ascii ExtrOcamlBasic ExtrOCamlInt63 ExtrOCamlFloats. +From MetaCoq.Template Require Import utils. From MetaCoq.SafeChecker Require Import PCUICSafeChecker PCUICSafeConversion SafeTemplateChecker. @@ -37,12 +37,19 @@ Extraction Inline Equations.Prop.Logic.True_rect_dep Equations.Prop.Logic.False_ Extraction Inline PCUICPrimitive.prim_val_reflect_eq. Cd "src". +Axiom fake_abstract_guard_impl_properties: + forall (fix_cofix : PCUICTyping.FixCoFix) + (Σ : PCUICAst.PCUICEnvironment.global_env_ext) + (Γ : PCUICAst.PCUICEnvironment.context) + (mfix : BasicAst.mfixpoint PCUICAst.term), + PCUICTyping.guard fix_cofix Σ Γ mfix <-> + PCUICWfEnvImpl.fake_guard_impl fix_cofix Σ Γ mfix. #[local,program] Instance fake_abstract_guard_impl : PCUICWfEnvImpl.abstract_guard_impl := { guard_impl := PCUICWfEnvImpl.fake_guard_impl }. -Next Obligation. Admitted. +Next Obligation. eapply fake_abstract_guard_impl_properties. Qed. Definition infer_and_print_template_program_with_guard {cf} {nor} := @SafeTemplateChecker.infer_and_print_template_program cf nor fake_abstract_guard_impl. diff --git a/safechecker/theories/PCUICConsistency.v b/safechecker/theories/PCUICConsistency.v index 8f3b61e19..10c51c03e 100644 --- a/safechecker/theories/PCUICConsistency.v +++ b/safechecker/theories/PCUICConsistency.v @@ -116,7 +116,7 @@ Qed. Definition binder := {| binder_name := nNamed "P"; binder_relevance := Relevant |}. Definition global_env_add (Σ : global_env) d := - {| universes := Σ.(universes); declarations := d :: Σ.(declarations) |}. + {| universes := Σ.(universes); declarations := d :: Σ.(declarations); retroknowledge := Σ.(retroknowledge) |}. Theorem pcuic_consistent {cf:checker_flags} {nor : normalizing_flags} {guard : abstract_guard_impl} (_Σ :referenced_impl_ext) t : @@ -164,7 +164,8 @@ Proof. eapply (env_prop_typing weakening_env) in cons; auto. 2:instantiate (1:=Σext.1). 3:{ split; auto; cbn. split; [lsets|csets]. - exists [(make_fresh_name Σ.1, InductiveDecl False_mib)]; reflexivity. } + exists [(make_fresh_name Σ.1, InductiveDecl False_mib)]; reflexivity. + apply Retroknowledge.extends_refl. } 2: now destruct wf'. set (Σ' := Σext.1) in cons. diff --git a/safechecker/theories/PCUICEqualityDec.v b/safechecker/theories/PCUICEqualityDec.v index a78cd14b7..9dea125c2 100644 --- a/safechecker/theories/PCUICEqualityDec.v +++ b/safechecker/theories/PCUICEqualityDec.v @@ -13,7 +13,7 @@ Local Set Keyed Unification. Set Default Goal Selector "!". -(*todo move*) +(* TODO move*) Lemma consistent_instance_wf_universe `{checker_flags} Σ uctx u : consistent_instance_ext Σ uctx u -> @@ -157,7 +157,7 @@ Fixpoint eqb_term_upto_univ_napp eqb_binder_annot x.(dname) y.(dname) ) mfix mfix' -(* | tPrim p, tPrim p' => eqb p p' *) + | tPrim p, tPrim p' => eqb p p' | _, _ => false end. @@ -740,7 +740,7 @@ Proof. constructor. constructor. constructor ; try easy. now inversion e3. -(* - cbn - [eqb]. eqspecs. do 2 constructor. *) + - cbn - [eqb]. eqspecs. do 2 constructor. Qed. Lemma eqb_term_upto_univ_impl (equ lequ : _ -> _ -> bool) diff --git a/safechecker/theories/PCUICErrors.v b/safechecker/theories/PCUICErrors.v index 2307380e3..cd71648b6 100644 --- a/safechecker/theories/PCUICErrors.v +++ b/safechecker/theories/PCUICErrors.v @@ -363,6 +363,13 @@ Inductive env_error := | IllFormedDecl (e : string) (e : type_error) | AlreadyDeclared (id : string). +Definition string_of_env_error Σ (e : env_error) := + match e with + | IllFormedDecl decl_name typ_error => + "Type error on " ^ decl_name ^ " " ^ string_of_type_error Σ typ_error + | AlreadyDeclared decl_name => + "Name is already declared in environment " ^ decl_name + end. Section EnvCheck. diff --git a/safechecker/theories/PCUICRetypingEnvIrrelevance.v b/safechecker/theories/PCUICRetypingEnvIrrelevance.v index ef9ab5500..3ee28ed16 100644 --- a/safechecker/theories/PCUICRetypingEnvIrrelevance.v +++ b/safechecker/theories/PCUICRetypingEnvIrrelevance.v @@ -33,10 +33,11 @@ Definition Hlookup {cf} (X_type : abstract_env_ext_impl) (X : X_type.π1) (X_typ (X' : X_type'.π1) := forall Σ : global_env_ext, abstract_env_ext_rel X Σ -> forall Σ' : global_env_ext, abstract_env_ext_rel X' Σ' -> - forall kn decl decl', + (forall kn decl decl', lookup_env Σ kn = Some decl -> lookup_env Σ' kn = Some decl' -> - abstract_env_lookup X kn = abstract_env_lookup X' kn. + abstract_env_lookup X kn = abstract_env_lookup X' kn) /\ + (abstract_env_ext_retroknowledge X = abstract_env_ext_retroknowledge X'). Definition reduce_stack_eq {cf} {fl} {X_type : abstract_env_ext_impl} {X : X_type.π1} Γ t π wi : reduce_stack fl X_type X Γ t π wi = ` (reduce_stack_full fl X_type X Γ t π wi). Proof. @@ -148,7 +149,8 @@ Section infer_irrel. eapply (welltyped_mkApps_inv (Σ := Σ') _ _ _ H2) in wi' as []. destruct H0, H3. eapply inversion_Const in X0 as [decl [_ [Hdecl _]]]; eauto. - eapply inversion_Const in X1 as [decl' [_ [Hdecl' _]]]; eauto. } + eapply inversion_Const in X1 as [decl' [_ [Hdecl' _]]]; eauto. + now eapply hl. } destruct PCUICSafeReduce.inspect => //. destruct PCUICSafeReduce.inspect => //. destruct x as [[]|] => //; simp _reduce_stack. 2-3:bang. @@ -608,6 +610,18 @@ Proof. clear -e0 eq'. congruence. - cbn -[infer]. unfold infer; rewrite Heq /= //. - cbn -[infer]. unfold infer; rewrite Heq /= //. + - cbn -[infer]. simp infer. + eapply elim_inspect => y eq. + assert (abstract_env_ext_retroknowledge X = abstract_env_ext_retroknowledge X'). + { epose proof (abstract_env_ext_exists X) as [[Σ wfΣ]]. + epose proof (abstract_env_ext_wf X wfΣ) as [hwfΣ]. + epose proof (abstract_env_ext_exists X') as [[Σ' wfΣ']]. + epose proof (abstract_env_ext_wf X' wfΣ') as [hwfΣ']. + apply (hl _ wfΣ _ wfΣ'). } + assert (primitive_constant X_type X p.π1 = primitive_constant X_type' X' p.π1). + { unfold primitive_constant. now rewrite H. } + clear Heq. rewrite H0 in eqp. rewrite -eq in eqp. + destruct y; simp infer; cbn; congruence. Qed. Lemma sort_of_type_irrel diff --git a/safechecker/theories/PCUICSafeChecker.v b/safechecker/theories/PCUICSafeChecker.v index 0a7d2dd10..1a8ac6453 100644 --- a/safechecker/theories/PCUICSafeChecker.v +++ b/safechecker/theories/PCUICSafeChecker.v @@ -387,7 +387,7 @@ Section CheckEnv. + clear -Hl HΣ ct. destruct HΣ as [_ HΣ]. specialize (HΣ (l, ct, l') Hl). split; apply LevelSet.union_spec; right; apply HΣ. - Defined. + Qed. Definition check_wf_env_ext_prop X X_ext ext := (forall Σ : global_env, abstract_env_rel X Σ -> abstract_env_ext_rel X_ext (Σ, ext)) @@ -1868,10 +1868,12 @@ Section CheckEnv. (check_cstr_variance X mdecl id indices mdeclvar cs _ _)) idecl.(ind_ctors) (get_wt_indices X_ext wfar wfpars n idecl indices hnth heq Hcs)) ;; lets <- - monad_All (P := fun x => if @lets_in_constructor_types _ - then true else is_assumption_context (cstr_args x)) + monad_All (P := fun x => if @lets_in_constructor_types _ as _ return Prop then true else is_assumption_context (cstr_args x)) (fun cs => if @lets_in_constructor_types _ - then ret _ else (if is_assumption_context (cstr_args cs) then ret _ else EnvError X_env_ext_type X_ext (IllFormedDecl "No lets in constructor types allowed, you need to set the checker flag lets_in_constructor_types to [true]." + then ret _ else + (if is_assumption_context (cstr_args cs) then ret _ + else EnvError X_env_ext_type X_ext + (IllFormedDecl "No lets in constructor types allowed, you need to set the checker flag lets_in_constructor_types to [true]." (Msg "No lets in constructor types allowed, you need to set the checker flag lets_in_constructor_types to [true].") )) ) idecl.(ind_ctors) ;; ret (cs; _). @@ -1902,7 +1904,7 @@ Section CheckEnv. rewrite /cstr_concl /=. f_equal. rewrite /cstr_concl_head. lia_f_equal. - now destruct wtinds. - destruct lets_in_constructor_types; eauto. - Qed. + Qed. Definition check_projections_type (mind : kername) (mdecl : mutual_inductive_body) (i : nat) (idecl : one_inductive_body) @@ -2362,8 +2364,9 @@ End monad_Alli_nth_forall. lsets. Qed. - Program Definition check_univs (univs : ContextSet.t) - : EnvCheck X_env_ext_type ({ X : X_env_type | (forall Σ, abstract_env_rel X Σ -> Σ = {| universes := univs; declarations := [] |}) + Program Definition check_univs (univs : ContextSet.t) (retro : Retroknowledge.t) + : EnvCheck X_env_ext_type ({ X : X_env_type | + (forall Σ, abstract_env_rel X Σ -> Σ = {| universes := univs; declarations := []; retroknowledge := retro |}) /\ ∥ on_global_univs univs ∥ }) := let id := "toplevel" in let levels := ContextSet.levels univs in @@ -2378,7 +2381,7 @@ End monad_Alli_nth_forall. | None => fun _ => raise (abstract_env_ext_empty, IllFormedDecl id (Msg "constraints trivially not satisfiable")) | Some uctx => fun _ => check_eq_true_lazy (@abstract_env_is_consistent _ X_env_type X_env_ext_type _ uctx) (fun _ => (abstract_env_ext_empty, IllFormedDecl id (Msg "constraints not satisfiable"))) ;; - ret (let Hunivs := _ in exist (abstract_env_init univs Hunivs) _) end eq_refl . + ret (let Hunivs := _ in exist (abstract_env_init univs retro Hunivs) _) end eq_refl . Next Obligation. intros. have decll : ConstraintSet.For_all (declared_cstr_levels (ContextSet.levels univs)) (ContextSet.constraints univs). @@ -2406,25 +2409,25 @@ End monad_Alli_nth_forall. * red. apply decll. Qed. Next Obligation. - cbv beta. intros univs id levels X H H0 Hconsistent ? ? Hunivs. clearbody Hunivs. + cbv beta. intros univs retro id levels X H H0 Hconsistent ? ? Hunivs. clearbody Hunivs. split. - - intros. eapply (abstract_env_irr _ _ (abstract_env_init_correct _ _)); eauto. + - intros. eapply (abstract_env_irr _ _ (abstract_env_init_correct _ _ _)); eauto. - now sq. Unshelve. eauto. Qed. Obligation Tactic := Tactics.program_simpl. - Program Fixpoint check_wf_decls (univs : ContextSet.t) + Program Fixpoint check_wf_decls (univs : ContextSet.t) (retro : Retroknowledge.t) (decls : global_declarations) : EnvCheck X_env_ext_type ({ X : X_env_type | - (forall Σ, abstract_env_rel X Σ -> Σ = {| universes := univs; declarations := decls |})}) + (forall Σ, abstract_env_rel X Σ -> Σ = {| universes := univs; declarations := decls; retroknowledge := retro |})}) := match decls with [] => - X <- check_univs univs ;; + X <- check_univs univs retro ;; ret (exist (proj1_sig X) _) | d :: decls => - '(exist X wf_) <- check_wf_decls univs decls ;; + '(exist X wf_) <- check_wf_decls univs retro decls ;; isfresh <- check_fresh d.1 decls ;; let udecl := universes_decl_of_decl d.2 in X' <- make_abstract_env_ext X d.1 udecl ;; @@ -2442,6 +2445,7 @@ End monad_Alli_nth_forall. now rewrite wf_ in a. - rewrite wf_ in y. erewrite <- abstract_env_univ_correct ; eauto. erewrite <- abstract_env_global_declarations_correct; eauto. + erewrite <- (abstract_env_retroknowledge_correct); eauto. now rewrite wf_. Qed. @@ -2455,7 +2459,7 @@ End monad_Alli_nth_forall. Program Definition check_wf_env (Σ : global_env) : EnvCheck X_env_ext_type ({ X : X_env_type | abstract_env_rel X Σ}) := - X <- check_wf_decls Σ.(universes) Σ.(declarations) ;; + X <- check_wf_decls Σ.(universes) Σ.(retroknowledge) Σ.(declarations) ;; ret (exist (proj1_sig X) _). Next Obligation. diff --git a/safechecker/theories/PCUICSafeConversion.v b/safechecker/theories/PCUICSafeConversion.v index b3a733b30..45620a02e 100644 --- a/safechecker/theories/PCUICSafeConversion.v +++ b/safechecker/theories/PCUICSafeConversion.v @@ -213,8 +213,7 @@ Section Conversion. Defined. Derive Signature for Subterm.lexprod. - Derive Signature for dlexmod. - + Lemma R_aux_Acc : forall Γ t p w q s, (forall Σ, abstract_env_ext_rel X Σ -> welltyped Σ Γ t) -> @@ -5144,7 +5143,7 @@ Qed. - reflexivity. Qed. - (* TODO move to PCUICNormal + (* TODO move to PCUICNormal *) Lemma whnf_mkApps_tPrim_inv : forall (f : RedFlags.t) (Σ : global_env) (Γ : context) p (args : list term), whnf f Σ Γ (mkApps (tPrim p) args) -> args = []. @@ -5160,7 +5159,7 @@ Qed. rewrite mkApps_app in teq. cbn in teq. noconf teq. eauto. - Qed. *) + Qed. Lemma reducible_head_None Σ (wfΣ : abstract_env_ext_rel X Σ) Γ t π h : isApp t = false -> @@ -5220,9 +5219,9 @@ Qed. - constructor; eexists _, (decompose_stack π).1. split; [constructor; eauto with pcuic|]. eauto with pcuic. -(* - apply whnf_mkApps_tPrim_inv in wh as ->. + - apply whnf_mkApps_tPrim_inv in wh as ->. constructor; eexists _, []. - eauto using whnf_red with pcuic.*) + eauto using whnf_red with pcuic. - constructor; eexists _, (decompose_stack π).1. clear H. erewrite <- abstract_env_lookup_correct in e; eauto. split; [econstructor|]; eauto. @@ -5710,7 +5709,9 @@ Qed. _isconv Fallback Γ t1 π1 h1 t2 π2 h2 aux := λ { | leq | hx | r1 | r2 | hd := _isconv_fallback Γ leq t1 π1 h1 t2 π2 h2 r1 r2 hd hx aux }. - + + Derive Signature for dlexmod. + Lemma welltyped_R_zipc Σ (wfΣ : abstract_env_ext_rel X Σ) Γ : forall x y : pack Γ, welltyped Σ Γ (zipc (tm1 x) (stk1 x)) -> R Γ y x -> welltyped Σ Γ (zipc (tm1 y) (stk1 y)). Proof using Type. @@ -5850,13 +5851,13 @@ match (LevelSet.add Level.lzero LevelSet.empty, ConstraintSet.empty); declarations := [] |}, Monomorphic_ctx); - referenced_impl_ext_wf := todo "foo" + referenced_impl_ext_wf := TODO "foo" |} [] Cumul (tSort (Universe.lType (Universe.make' (Level.lzero, 0)))) - (todo "") (tSort (Universe.lType (Universe.make' (Level.lzero, 0)))) - (todo "") + (TODO "") (tSort (Universe.lType (Universe.make' (Level.lzero, 0)))) + (TODO "") with | ConvSuccess => "success" -| ConvError _ => todo "foo" +| ConvError _ => TODO "foo" end = "success". Proof. lazy. reflexivity. diff --git a/safechecker/theories/PCUICSafeReduce.v b/safechecker/theories/PCUICSafeReduce.v index 22c0a4f1f..ebe0fca75 100644 --- a/safechecker/theories/PCUICSafeReduce.v +++ b/safechecker/theories/PCUICSafeReduce.v @@ -1116,44 +1116,6 @@ Corollary R_Acc_aux : End reducewf. - (* Equations reduce_stack_full (Γ : context) (t : term) (π : stack) - (h : forall Σ (wfΣ : abstract_env_ext_rel X Σ), welltyped Σ Γ (zip (t,π))) : - { t' : term * stack | forall Σ (wfΣ : abstract_env_ext_rel X Σ), Req Σ Γ t' (t, π) /\ Pr t' π /\ Pr' t' } := - reduce_stack_full Γ t π h := - Fix_F (R := fun t t' => forall Σ (wfΣ : abstract_env_ext_rel X Σ), R Σ Γ t t') - (fun x => (forall Σ (wfΣ : abstract_env_ext_rel X Σ), welltyped Σ Γ (zip x)) - -> { t' : term * stack | forall Σ (wfΣ : abstract_env_ext_rel X Σ), Req Σ Γ t' x /\ Pr t' (snd x) /\ Pr' t' }) - (fun t' f => _) (x := (t, π)) _ _. - Next Obligation. - eapply _reduce_stack. - - assumption. - - intros t' π' h'. - eapply f. - + assumption. - + intros. specialize (h' _ wfΣ). simple inversion h'. - * cbn in H1. cbn in H2. - inversion H1. subst. inversion H2. subst. clear H1 H2. - intros. - destruct (hΣ _ wfΣ) as [wΣ]. - eapply cored_welltyped. - ++ eassumption. - ++ eapply H; eauto. - ++ eauto. - * cbn in H1. cbn in H2. - inversion H1. subst. inversion H2. subst. clear H1 H2. - intros. cbn. rewrite H3. eauto. - Defined. - Next Obligation. - revert h. generalize (t, π). - refine (Acc_intro_generator - (R:=fun x y => forall Σ (wfΣ : abstract_env_ext_rel X Σ), R Σ Γ x y) - (P:=fun x => forall Σ (wfΣ : abstract_env_ext_rel X Σ), welltyped Σ Γ (zip x)) - (fun x y Px Hy => _) 1000 _); intros. - - simpl in *. eapply welltyped_R_pres; eauto. - - destruct (abstract_env_ext_exists X) as [[Σ wfΣ]]. - destruct (hΣ _ wfΣ) as [hΣ]. eapply R_Acc; eassumption. - Defined. *) - Definition reduce_stack Γ t π h := let '(exist ts _) := reduce_stack_full Γ t π h in ts. @@ -1262,44 +1224,6 @@ Corollary R_Acc_aux : refine (reduce_stack_sound _ _ _ _ [] _); eauto. Qed. - (* (* Potentially hard? Ok with SN? *) *) - (* Lemma Ind_canonicity : *) - (* forall Γ ind uni args t, *) - (* Σ ;;; Γ |- t : mkApps (tInd ind uni) args -> *) - (* RedFlags.iota flags -> *) - (* let '(u,l) := decompose_app t in *) - (* (isLambda u -> l = []) -> *) - (* whnf flags Σ Γ u -> *) - (* discr_construct u -> *) - (* whne flags Σ Γ u. *) - (* Proof. *) - (* intros Γ ind uni args t ht hiota. *) - (* case_eq (decompose_app t). *) - (* intros u l e hl h d. *) - (* induction h. *) - (* - assumption. *) - (* - apply decompose_app_inv in e. subst. *) - (* (* Inversion on ht *) *) - (* admit. *) - (* - apply decompose_app_inv in e. subst. *) - (* (* Inversion on ht *) *) - (* admit. *) - (* - cbn in hl. specialize (hl eq_refl). subst. *) - (* apply decompose_app_inv in e. subst. cbn in ht. *) - (* (* Inversion on ht *) *) - (* admit. *) - (* - apply decompose_app_eq_mkApps in e. subst. *) - (* cbn in d. simp discr_construct in d. easy. *) - (* - apply decompose_app_inv in e. subst. *) - (* (* Inversion on ht *) *) - (* admit. *) - (* - apply decompose_app_inv in e. subst. *) - (* (* Not very clear now. *) - (* Perhaps we ought to show whnf of the mkApps entirely. *) - (* And have a special whne case for Fix that don't reduce? *) - (* *) *) - (* Abort. *) - Scheme Acc_ind' := Induction for Acc Sort Prop. Lemma Fix_F_prop : @@ -1390,6 +1314,8 @@ Corollary R_Acc_aux : unfold is_true in typ. unfold PCUICAst.PCUICEnvironment.fst_ctx in *. congruence. + - eapply inversion_Prim in typ as (prim_ty & cdecl & [? ? ? [? []]]); tea. + now eapply invert_cumul_axiom_ind in w; tea. Qed. Definition isCoFix_app t := @@ -1421,7 +1347,8 @@ Corollary R_Acc_aux : - exfalso; eapply invert_fix_ind; eauto. - unfold isCoFix_app in cof. now rewrite decompose_app_mkApps in cof. - (* - now eapply inversion_Prim in typ. *) + - eapply inversion_Prim in typ as [prim_ty [cdecl [? ? ? [? []]]]]; tea. + now eapply invert_cumul_axiom_ind in w; tea. Qed. Lemma whnf_fix_arg_whne mfix idx body Σ Γ t before args aftr ty : @@ -1585,13 +1512,21 @@ Corollary R_Acc_aux : apply inversion_App in h as (?&?&?&?&?); auto. apply inversion_Prod in t0 as (?&?&?&?&?); auto. eapply PCUICConversion.ws_cumul_pb_Sort_Prod_inv; eauto. - (* + pose proof hΣ. - sq. - exfalso. - destruct (hΣ _ wfΣ) as [hΣ]. - specialize (h _ wfΣ). - eapply welltyped_context in h as [s Hs]; tas. - now eapply inversion_Prim in Hs. *) + + unfold zipp. + case_eq (decompose_stack π). intros l ρ e. + apply decompose_stack_eq in e. subst. + destruct l. + * simpl. eauto with pcuic. + * exfalso. + destruct (hΣ _ wfΣ) as [hΣ]. + cbn in h. zip fold in h. + specialize (h _ wfΣ). + apply welltyped_context in h; auto. + simpl in h. rewrite stack_context_appstack in h. + destruct h as [T h]. + apply inversion_App in h as (?&?&?&?&?); auto. + apply inversion_Prim in t0 as (prim_ty & cdecl & [? ? ? [s []]]); auto. + eapply PCUICCanonicity.invert_cumul_axiom_prod; eauto. - unfold zipp. case_eq (decompose_stack π). intros l ρ e. constructor. constructor. eapply whne_mkApps. eapply whne_rel_nozeta. assumption. @@ -2166,56 +2101,4 @@ Section ReduceFns. Local Instance wellfounded Σ wfΣ : WellFounded (@hnf_subterm_rel _ Σ) := @wf_hnf_subterm _ _ (heΣ _ X Σ wfΣ). - (** not used anymore **) - (* - Equations? (noeqns) reduce_to_arity (Γ : context) (T : term) - (wt : forall Σ (wfΣ : abstract_env_ext_rel X Σ), welltyped Σ Γ T) - : (conv_arity Γ T) + {forall Σ (wfΣ : abstract_env_ext_rel X Σ), ~ Is_conv_to_Arity Σ Γ T} - by wf ((Γ ; T ; wt) : (∑ Γ t, forall Σ (wfΣ : abstract_env_ext_rel X Σ), welltyped Σ Γ t)) hnf_subterm_rel := - reduce_to_arity Γ T wt with inspect (hnf Γ T wt) := - | exist Thnf eqhnf with view_prod_sortc Thnf := { - | view_prod_sort_prod na A B with reduce_to_arity (Γ,, vass na A) B _ := { - | inleft car => inleft {| conv_ar_context := (na, A) :: conv_ar_context car; - conv_ar_univ := conv_ar_univ car |}; - | inright nocar => inright _ - }; - | view_prod_sort_sort u => inleft {| conv_ar_context := []; - conv_ar_univ := u |}; - | view_prod_sort_other Thnf notprod notsort => inright _ - }. - Proof. - all: pose proof (@hnf_sound Γ T wt) as [r]. - all: rewrite <- ?eqhnf in r. - all: destruct HΣ as [wf]. - - destruct wt as (?&typ). - eapply subject_reduction_closed in r; eauto. - apply inversion_Prod in r as (?&?&?&?&?); auto. - econstructor; eauto. - - constructor. - eexists _; split. 1:eapply r. - unshelve eexists _; [constructor; constructor|]; auto. - - destruct car as [c_ar c_univ [c_red]]; cbn. - constructor. - etransitivity; eauto. - eapply closed_red_prod_codom; eauto. - - eapply Is_conv_to_Arity_red in H as (?&[r']&isar); eauto. - apply invert_red_prod in r' as (?&?&[-> ? ?]); auto. - contradiction nocar. - eexists; eauto using sq. - - constructor; auto. - - pose proof (@hnf_complete Γ T wt) as [w]. - destruct HΣ. - apply Is_conv_to_Arity_inv in H as [(na&A&B&[r'])|(u&[r'])]; auto. - + eapply PCUICContextConversion.closed_red_confluence in r' as (?&r1&r2); eauto. - apply invert_red_prod in r2 as (?&?&[-> ? ?]); auto. - eapply whnf_red_inv in r1; eauto. - depelim r1. - rewrite H in notprod; auto. - + eapply PCUICContextConversion.closed_red_confluence in r' as (?&r1&r2); eauto. - apply invert_red_sort in r2 as ->. - eapply whnf_red_inv in r1; eauto. - depelim r1. - rewrite H in notsort; cbn in *; auto. - Qed. *) - End ReduceFns. diff --git a/safechecker/theories/PCUICSafeRetyping.v b/safechecker/theories/PCUICSafeRetyping.v index f159b06ea..362c52d59 100644 --- a/safechecker/theories/PCUICSafeRetyping.v +++ b/safechecker/theories/PCUICSafeRetyping.v @@ -283,7 +283,23 @@ Qed. wt : wellinferred _ _ _ |- _ => try clear infer ; destruct wt as [T HT] end. + + Definition primitive_constant (tag : Primitive.prim_tag) : option kername := + let retro := abstract_env_ext_retroknowledge X in + match tag with + | Primitive.primInt => Retroknowledge.retro_int63 retro + | Primitive.primFloat => Retroknowledge.retro_float64 retro + end. + Lemma primitive_constant_spec tag : + forall Σ (wfΣ : abstract_env_ext_rel X Σ), + primitive_constant tag = PCUICEnvironment.primitive_constant Σ tag. + Proof. + intros. + unfold primitive_constant, PCUICEnvironment.primitive_constant. + destruct tag => //; + now rewrite <- (abstract_env_ext_retroknowledge_correct (Σ := Σ) X). + Qed. Equations infer (Γ : context) (wfΓ : forall Σ (wfΣ : abstract_env_ext_rel X Σ), ∥ wf_local Σ Γ ∥) (t : term) (wt : forall Σ (wfΣ : abstract_env_ext_rel X Σ), wellinferred Σ Γ t) : @@ -291,7 +307,7 @@ Qed. by struct t := infer Γ wfΓ (tRel n) wt with inspect (option_map (lift0 (S n) ∘ decl_type) (nth_error Γ n)) := - { | exist None _ => !; + { | exist None _ => ! | exist (Some t) _ => ret t }; infer Γ wfΓ (tVar n) wt := !; @@ -321,17 +337,17 @@ Qed. ret (subst10 a pi.π2.π2.π1); infer Γ wfΓ (tConst cst u) wt with inspect (abstract_env_lookup X cst) := - { | exist (Some (ConstantDecl d)) _ := ret (subst_instance u d.(cst_type)); + { | exist (Some (ConstantDecl d)) _ := ret (subst_instance u d.(cst_type)) | _ := ! }; infer Γ wfΓ (tInd ind u) wt with inspect (lookup_ind_decl ind) := - { | exist (Checked decl) _ := ret (subst_instance u decl.π2.π1.(ind_type)); + { | exist (Checked decl) _ := ret (subst_instance u decl.π2.π1.(ind_type)) | exist (TypeError e) _ := ! }; infer Γ wfΓ (tConstruct ind k u) wt with inspect (lookup_ind_decl ind) := { | exist (Checked decl) _ with inspect (nth_error decl.π2.π1.(ind_ctors) k) := - { | exist (Some cdecl) _ => ret (type_of_constructor decl.π1 cdecl (ind, k) u); - | exist None _ => ! }; + { | exist (Some cdecl) _ => ret (type_of_constructor decl.π1 cdecl (ind, k) u) + | exist None _ => ! } | exist (TypeError e) _ => ! }; infer Γ wfΓ (tCase ci p c brs) wt @@ -346,20 +362,22 @@ Qed. { | exist (Some pdecl) _ with inspect (reduce_to_ind Γ (infer Γ wfΓ c _) _) := { | exist (Checked_comp indargs) _ => let ty := pdecl.(proj_type) in - ret (subst0 (c :: List.rev (indargs.π2.π2.π1)) (subst_instance indargs.π2.π1 ty)); - | exist (TypeError_comp _ _) _ => ! }; - | exist None _ => ! }; + ret (subst0 (c :: List.rev (indargs.π2.π2.π1)) (subst_instance indargs.π2.π1 ty)) + | exist (TypeError_comp _ _) _ => ! } + | exist None _ => ! } | exist (TypeError e) _ => ! }; infer Γ wfΓ (tFix mfix n) wt with inspect (nth_error mfix n) := - { | exist (Some f) _ => ret f.(dtype); + { | exist (Some f) _ => ret f.(dtype) | exist None _ => ! }; infer Γ wfΓ (tCoFix mfix n) wt with inspect (nth_error mfix n) := - { | exist (Some f) _ => ret f.(dtype); - | exist None _ => ! }. + { | exist (Some f) _ => ret f.(dtype) + | exist None _ => ! }; - (* infer Γ wfΓ (tPrim p) wt := !. *) + infer Γ wfΓ (tPrim p) wt with inspect (primitive_constant p.π1) := + { | exist (Some prim_ty) eqp => ret (tConst prim_ty []) + | exist None _ => ! }. Next Obligation. cbn; intros; sq. @@ -755,6 +773,25 @@ Qed. congruence. Qed. + Next Obligation. + cbn. + destruct (abstract_env_ext_exists X) as [[Σ wfΣ]]. + intros. specialize (wt _ wfΣ). destruct wt. + inversion X0; subst. + cbn in eqp. rewrite (primitive_constant_spec _ Σ) // in eqp. + rewrite /= -eqp in H0. noconf H0. split. + intros; erewrite (abstract_env_ext_irr _ wfΣ0 wfΣ); eauto. + Qed. + + Next Obligation. + cbn in *. + destruct (abstract_env_ext_exists X) as [[Σ wfΣ]]. + intros. specialize (wt _ wfΣ). destruct wt. + inversion X0; subst. + rewrite (primitive_constant_spec _ Σ) // in e. + rewrite /= -e in H0. noconf H0. + Qed. + Definition type_of Γ wfΓ t wt : term := (infer Γ wfΓ t wt). Definition principal_typing Σ Γ t P := diff --git a/safechecker/theories/PCUICTypeChecker.v b/safechecker/theories/PCUICTypeChecker.v index 5aacad2bf..51c9edc6f 100644 --- a/safechecker/theories/PCUICTypeChecker.v +++ b/safechecker/theories/PCUICTypeChecker.v @@ -1225,6 +1225,24 @@ Section Typecheck. now do 3 eapply (proj1 (eq_annots_fold _ _ _)) in e. Qed. + Definition primitive_constant (tag : Primitive.prim_tag) : option kername := + let retro := abstract_env_ext_retroknowledge X in + match tag with + | Primitive.primInt => Retroknowledge.retro_int63 retro + | Primitive.primFloat => Retroknowledge.retro_float64 retro + end. + + Lemma primitive_constant_spec tag : + forall Σ (wfΣ : abstract_env_ext_rel X Σ), + primitive_constant tag = PCUICEnvironment.primitive_constant Σ tag. + Proof. + intros. + unfold primitive_constant, PCUICEnvironment.primitive_constant. + destruct tag => //; + now rewrite <- (abstract_env_ext_retroknowledge_correct (Σ := Σ) X). + Qed. + + Section check_mfix. Context (infer : forall (Γ : context) (HΓ : forall Σ (wfΣ : abstract_env_ext_rel X Σ), ∥ wf_local Σ Γ ∥) (t : term), typing_result_comp ({ A : term & forall Σ (wfΣ : abstract_env_ext_rel X Σ), ∥ Σ ;;; Γ |- t ▹ A ∥ })) (Γ : context) (wfΓ : forall Σ (wfΣ : abstract_env_ext_rel X Σ), ∥ wf_local Σ Γ ∥). @@ -1331,7 +1349,7 @@ Section Typecheck. infer Γ HΓ (tEvar ev _) := raise (UnboundEvar ev) ; - infer Γ HΓ (tSort u) with inspect (abstract_env_wf_universeb _ X u) := { + infer Γ HΓ (tSort u) with inspect (@abstract_env_ext_wf_universeb _ _ _ X u) := { | exist true _ := ret (tSort (Universe.super u);_) ; | exist false _ := raise (Msg ("Sort contains an undeclared level " ^ string_of_sort u)) } ; @@ -1457,9 +1475,20 @@ Section Typecheck. guarded <- check_eq_true (abstract_env_cofixguard X Γ mfix) (Msg "Unguarded cofixpoint") ;; wfcofix <- check_eq_true (wf_cofixpoint_gen (abstract_env_lookup X) mfix) (Msg "Ill-formed cofixpoint: not producing values in a mutually coinductive family") ;; ret (dtype decl; _) - }. + }; - (* infer Γ HΓ (tPrim _) := raise (Msg "Primitive types are not supported"). *) + infer Γ HΓ (tPrim p) with inspect (primitive_constant p.π1) := + { | exist None _ := raise (Msg "primitive type is not registered in the environment"); + | exist (Some prim_ty) eqp with inspect (abstract_env_lookup X prim_ty) := { + | exist (Some (ConstantDecl d)) HH => + let ty := d.(cst_type) in + check_eq_true (eqb d.(cst_body) None) (Msg "primitive type is registered to a defined constant") ;; + check_eq_true (eqb d.(cst_universes) Monomorphic_ctx) (Msg "primitive type is registered to a polymorphic constant") ;; + check_eq_true (isSort d.(cst_type)) (Msg "primitive type is registered to an axiom whose type is not a sort") ;; + ret (tConst prim_ty []; _) + | _ => raise (UndeclaredConstant prim_ty) + } + }. (* tRel *) Next Obligation. intros; sq; now econstructor. Qed. @@ -1475,15 +1504,15 @@ Section Typecheck. Next Obligation. specialize_Σ wfΣ; sq. symmetry in e. - erewrite <- abstract_env_wf_universeb_correct in e; eauto. + erewrite <- abstract_env_ext_wf_universeb_correct in e; eauto. eapply (elimT wf_universe_reflect) in e. - sq; econstructor; tas. exact X_type.π2.π2. + sq; econstructor; tas. Qed. Next Obligation. destruct (abstract_env_ext_exists X) as [[Σ wfΣ]]. specialize_Σ wfΣ; sq. - inversion X1 ; subst. erewrite <- abstract_env_wf_universeb_correct in e0; eauto. - move: H0 e0 => /wf_universe_reflect -> //. exact X_type.π2.π2. + inversion X1 ; subst. erewrite <- abstract_env_ext_wf_universeb_correct in e0; eauto. + move: H0 e0 => /wf_universe_reflect -> //. Qed. (* tProd *) Next Obligation. @@ -1769,7 +1798,7 @@ Section Typecheck. Qed. Next Obligation. - (*todo: factor*) + (*TODO: factor*) cbn in *. pose proof (heΣ _ wfΣ) as [heΣ]. specialize_Σ wfΣ ; sq. apply eqb_eq in i. subst I. eapply eqb_eq in i0. @@ -2509,19 +2538,82 @@ Section Typecheck. inversion X1 ; subst. congruence. Qed. + Next Obligation. + eapply eqb_eq in i. eapply eqb_eq in i0. + rewrite -(abstract_env_lookup_correct _ (Σ := Σ)) // in HH. + split. econstructor. rewrite eqp. + now rewrite -primitive_constant_spec. red. + now rewrite -HH. + destruct (cst_type d) eqn:hty => //. + exists u. split => //. + Qed. + Next Obligation. + destruct (abstract_env_ext_exists X) as [[Σ wfΣ]]. + cbn in *. specialize_Σ wfΣ ; sq. + depelim X1. + eapply eqb_eq in i. eapply eqb_eq in i0. + rewrite -(abstract_env_lookup_correct _ (Σ := Σ)) // in HH. + rewrite (primitive_constant_spec _ _ wfΣ) in eqp. + rewrite e1 in eqp. noconf eqp. + symmetry in HH. rewrite /declared_constant in d0. + rewrite d0 in HH; noconf HH. + destruct p1 as [s' []]. rewrite H in absurd. now apply absurd. + Qed. + Next Obligation. + destruct (abstract_env_ext_exists X) as [[Σ wfΣ]]. + cbn in *. specialize_Σ wfΣ ; sq. + depelim X1. + eapply eqb_eq in i. + rewrite -(abstract_env_lookup_correct _ (Σ := Σ)) // in HH. + rewrite (primitive_constant_spec _ _ wfΣ) in eqp. + rewrite e1 in eqp. noconf eqp. + symmetry in HH. rewrite /declared_constant in d0. + rewrite d0 in HH; noconf HH. + destruct p1 as [s' []]. apply absurd. case: eqb_spec => //. + Qed. + + + Next Obligation. + destruct (abstract_env_ext_exists X) as [[Σ wfΣ]]. + cbn in *. specialize_Σ wfΣ ; sq. + depelim X1. + rewrite -(abstract_env_lookup_correct _ (Σ := Σ)) // in HH. + rewrite (primitive_constant_spec _ _ wfΣ) in eqp. + rewrite e1 in eqp. noconf eqp. + symmetry in HH. rewrite /declared_constant in d0. + rewrite d0 in HH; noconf HH. + destruct p1 as [s' []]. apply absurd. case: eqb_spec => //. + Qed. -(* - Program Definition check_isWfArity Γ (HΓ : ∥ wf_local Σ Γ ∥) A - : typing_result_comp (∥ isWfArity Σ Γ A ∥) := - match destArity [] A with - | None => raise (Msg (print_term Σ Γ A ^ " is not an arity")) - | Some (ctx, s) => XX <- check_context (Γ ,,, ctx) ;; - ret _ - end. Next Obligation. - destruct XX. constructor. exists ctx, s. - split; auto. - Defined. *) + destruct (abstract_env_ext_exists X) as [[Σ wfΣ]]. + cbn in *. specialize_Σ wfΣ ; sq. + depelim X1. + rewrite -(abstract_env_lookup_correct _ (Σ := Σ)) // in e0. + rewrite (primitive_constant_spec _ _ wfΣ) in eqp. + rewrite e1 in eqp. noconf eqp. + symmetry in e0. rewrite /declared_constant in d. + rewrite d in e0; noconf e0. + Qed. + + Next Obligation. + destruct (abstract_env_ext_exists X) as [[Σ wfΣ]]. + cbn in *. specialize_Σ wfΣ ; sq. + depelim X1. + rewrite -(abstract_env_lookup_correct _ (Σ := Σ)) // in e0. + rewrite (primitive_constant_spec _ _ wfΣ) in eqp. + rewrite e1 in eqp. noconf eqp. + symmetry in e0. rewrite /declared_constant in d. + rewrite e0 in d; noconf d. + Qed. + + Next Obligation. + destruct (abstract_env_ext_exists X) as [[Σ wfΣ]]. + cbn in *. specialize_Σ wfΣ ; sq. + depelim X1. + rewrite (primitive_constant_spec _ _ wfΣ) in e0. + unfold prim_val_tag in e1. congruence. + Qed. Definition check_isType := infer_isType infer. diff --git a/safechecker/theories/PCUICWfEnv.v b/safechecker/theories/PCUICWfEnv.v index 37a9a65f5..e533fbe97 100644 --- a/safechecker/theories/PCUICWfEnv.v +++ b/safechecker/theories/PCUICWfEnv.v @@ -4,12 +4,13 @@ From MetaCoq.Template Require Import config utils uGraph EnvMap. From MetaCoq.PCUIC Require Import PCUICAst PCUICAstUtils PCUICEquality PCUICReduction PCUICReflect PCUICSafeLemmata PCUICTyping PCUICGlobalEnv PCUICWfUniverses. -Record on_global_decls_dec {cf:checker_flags} (univs : ContextSet.t) (Σ : global_declarations) (kn : kername) (d : global_decl) := +Record on_global_decls_dec {cf:checker_flags} (univs : ContextSet.t) retro (Σ : global_declarations) (kn : kername) (d : global_decl) := { kn_fresh : fresh_global kn Σ ; udecl := universes_decl_of_decl d ; on_udecl_udecl : on_udecl univs udecl ; - on_global_decl_d : on_global_decl cumulSpec0 (lift_typing typing) ({| universes := univs; declarations := Σ |}, udecl) kn d + on_global_decl_d : on_global_decl cumulSpec0 (lift_typing typing) + ({| universes := univs; declarations := Σ; retroknowledge := retro |}, udecl) kn d }. Definition level_mem : global_env_ext -> Level.t -> bool @@ -17,6 +18,7 @@ Definition level_mem : global_env_ext -> Level.t -> bool Class abstract_env_ext_struct {cf:checker_flags} (abstract_env_impl : Type) := { abstract_env_lookup : abstract_env_impl -> kername -> option global_decl; + abstract_env_ext_retroknowledge : abstract_env_impl -> Retroknowledge.t; abstract_env_conv_pb_relb : abstract_env_impl -> conv_pb -> Universe.t -> Universe.t -> bool; abstract_env_compare_global_instance : abstract_env_impl -> (Universe.t -> Universe.t -> bool) -> global_reference -> nat -> list Level.t -> list Level.t -> bool; abstract_env_level_mem : abstract_env_impl -> Level.t -> bool; @@ -32,11 +34,12 @@ Class abstract_env_ext_struct {cf:checker_flags} (abstract_env_impl : Type) := { Class abstract_env_struct {cf:checker_flags} (abstract_env_impl abstract_env_ext_impl : Type) := { abstract_env_empty : abstract_env_impl; - abstract_env_init (cs:ContextSet.t) : on_global_univs cs -> abstract_env_impl; + abstract_env_init (cs:ContextSet.t) (retro : Retroknowledge.t) : on_global_univs cs -> abstract_env_impl; abstract_env_univ : abstract_env_impl -> ContextSet.t; abstract_env_global_declarations : abstract_env_impl -> global_declarations; + abstract_env_retroknowledge : abstract_env_impl -> Retroknowledge.t; abstract_env_add_decl X (kn:kername) (d:global_decl) : - ∥ on_global_decls_dec (abstract_env_univ X) (abstract_env_global_declarations X) kn d ∥ -> abstract_env_impl; + ∥ on_global_decls_dec (abstract_env_univ X) (abstract_env_retroknowledge X) (abstract_env_global_declarations X) kn d ∥ -> abstract_env_impl; abstract_env_empty_ext : abstract_env_impl -> abstract_env_ext_impl; abstract_env_is_consistent : VSet.t * GoodConstraintSet.t -> bool ; abstract_env_is_consistent_uctx : abstract_env_impl -> VSet.t * GoodConstraintSet.t -> bool ; @@ -58,16 +61,6 @@ Definition abstract_env_eq {cf:checker_flags} {abstract_env_impl : Type} `{!abst Definition abstract_env_leq {cf:checker_flags} {abstract_env_impl : Type} `{!abstract_env_ext_struct abstract_env_impl} (X:abstract_env_impl) := abstract_env_conv_pb_relb X Cumul. -Definition abstract_env_wf_universeb {cf:checker_flags} (abstract_env_impl : Type) `{!abstract_env_ext_struct abstract_env_impl} - : abstract_env_impl -> Universe.t -> bool - := fun X s => match s with - | Universe.lType l => - LevelExprSet.for_all - (fun l0 : LevelExprSet.elt => - abstract_env_level_mem X (LevelExpr.get_level l0)) l - | _ => true - end. - Class abstract_env_ext_prop {cf:checker_flags} (abstract_env_impl : Type) `{!abstract_env_ext_struct abstract_env_impl} : Prop := { abstract_env_ext_exists X : ∥ ∑ Σ , abstract_env_ext_rel X Σ ∥; abstract_env_ext_wf X {Σ} : abstract_env_ext_rel X Σ -> ∥ wf_ext Σ ∥ ; @@ -75,7 +68,9 @@ Class abstract_env_ext_prop {cf:checker_flags} (abstract_env_impl : Type) `{!abs abstract_env_ext_rel X Σ -> abstract_env_ext_rel X Σ' -> Σ = Σ'; abstract_env_lookup_correct X {Σ} c : abstract_env_ext_rel X Σ -> lookup_env Σ c = abstract_env_lookup X c ; - abstract_env_compare_universe_correct X {Σ} (wfΣ : abstract_env_ext_rel X Σ) conv_pb u u' : + abstract_env_ext_retroknowledge_correct X {Σ : global_env_ext} (wfΣ : abstract_env_ext_rel X Σ) : + Σ.(retroknowledge) = abstract_env_ext_retroknowledge X ; + abstract_env_compare_universe_correct X {Σ} (wfΣ : abstract_env_ext_rel X Σ) conv_pb u u' : wf_universe Σ u -> wf_universe Σ u' -> compare_universe conv_pb Σ u u' <-> abstract_env_conv_pb_relb X conv_pb u u'; @@ -109,8 +104,9 @@ Class abstract_env_prop {cf:checker_flags} (abstract_env_impl abstract_env_ext_i abstract_env_global_declarations_correct X {Σ} : abstract_env_rel X Σ -> declarations Σ = abstract_env_global_declarations X ; - abstract_env_init_correct univs cuniv : - abstract_env_rel (abstract_env_init univs cuniv) {| universes := univs; declarations := [] |} ; + abstract_env_init_correct univs retro cuniv : + abstract_env_rel (abstract_env_init univs retro cuniv) + {| universes := univs; declarations := []; retroknowledge := retro |} ; abstract_env_add_decl_correct X Σ kn d H : abstract_env_rel X Σ -> abstract_env_rel (abstract_env_add_decl X kn d H) (add_global_decl Σ (kn,d)); abstract_env_add_uctx_rel X {Σ} uctx udecl H H' : @@ -130,28 +126,19 @@ Class abstract_env_prop {cf:checker_flags} (abstract_env_impl abstract_env_ext_i <-> abstract_env_is_consistent_uctx X uctx ; abstract_env_univ_correct X {Σ} (wfΣ : abstract_env_rel X Σ) : (Σ:ContextSet.t) = abstract_env_univ X ; + abstract_env_retroknowledge_correct X {Σ : global_env} (wfΣ : abstract_env_rel X Σ) : + Σ.(retroknowledge) = abstract_env_retroknowledge X ; abstract_pop_decls_correct X decls (prf : forall Σ : global_env, abstract_env_rel X Σ -> exists d, Σ.(declarations) = d :: decls) : let X' := abstract_pop_decls X in forall Σ Σ', abstract_env_rel X Σ -> abstract_env_rel X' Σ' -> - Σ'.(declarations) = decls /\ Σ.(universes) = Σ'.(universes) ; + Σ'.(declarations) = decls /\ Σ.(universes) = Σ'.(universes) /\ + Σ.(retroknowledge) = Σ'.(retroknowledge); abstract_make_wf_env_ext_correct X univs prf : let X' := abstract_make_wf_env_ext X univs prf in forall Σ Σ', abstract_env_rel X Σ -> abstract_env_ext_rel X' Σ' -> Σ' = (Σ, univs) }. - -Definition abstract_env_wf_universeb_correct (abstract_env_impl : Type) - `{abstract_env_ext_prop abstract_env_impl} - X {Σ} (wfΣ : abstract_env_ext_rel X Σ) u : wf_universeb Σ u = abstract_env_wf_universeb _ X u. -Proof. - destruct u as [| |t]; auto. - destruct t. cbn. repeat rewrite for_all_elements. - induction (LevelExprSet.elements t_set); cbn; auto. - rewrite <- IHl. erewrite <- abstract_env_level_mem_correct; eauto. - reflexivity. -Defined. - Definition abstract_env_ext_impl {cf:checker_flags} := ∑ X Y, @abstract_env_ext_prop _ X Y. Global Instance abstract_env_ext_impl_abstract_env_struct {cf:checker_flags} (Σ : abstract_env_ext_impl) : abstract_env_ext_struct Σ.π1. diff --git a/safechecker/theories/PCUICWfEnvImpl.v b/safechecker/theories/PCUICWfEnvImpl.v index 2a361bfbb..d284b97c8 100644 --- a/safechecker/theories/PCUICWfEnvImpl.v +++ b/safechecker/theories/PCUICWfEnvImpl.v @@ -87,7 +87,8 @@ Record referenced_impl {cf:checker_flags} := { referenced_impl_graph_wf := projT2 (graph_of_wf referenced_impl_wf) }. -Definition init_env : global_env := {| universes := (LS.singleton Level.lzero , CS.empty); declarations := [] |}. +Definition init_env : global_env := + {| universes := (LS.singleton Level.lzero , CS.empty); declarations := []; retroknowledge := Retroknowledge.empty |}. Definition on_global_univ_init_env : on_global_univs init_env. repeat split. @@ -96,7 +97,7 @@ Definition on_global_univ_init_env : on_global_univs init_env. - red. unshelve eexists. + econstructor; eauto. intros; exact 1%positive. + red. intros ? ?. cbn in *. inversion H. -Defined. +Qed. Definition check_conv_pb_relb_correct {cf:checker_flags} (Σ : global_env_ext) (HΣ : ∥ wf_ext Σ ∥) G (HG : is_graph_of_uctx G (global_ext_uctx Σ)) conv_pb u u' : @@ -116,11 +117,12 @@ Proof. - apply (check_leqb_universe_spec' G (global_ext_levels Σ, global_ext_constraints Σ)); eauto. + eapply wf_ext_global_uctx_invariants; eauto. + eapply wf_ext_consistent; eauto. -Defined. +Qed. Global Instance canonical_abstract_env_ext_struct {cf:checker_flags} {guard : abstract_guard_impl} : abstract_env_ext_struct referenced_impl_ext := {| abstract_env_lookup := fun Σ => lookup_env (referenced_impl_env_ext Σ) ; + abstract_env_ext_retroknowledge := fun Σ => (referenced_impl_env_ext Σ).(retroknowledge) ; abstract_env_conv_pb_relb := fun Σ conv_pb => conv_pb_relb (referenced_impl_ext_graph Σ) conv_pb ; abstract_env_compare_global_instance := fun Σ => compare_global_instance (referenced_impl_env_ext Σ) @@ -137,7 +139,7 @@ Global Instance canonical_abstract_env_ext_struct {cf:checker_flags} {guard : ab match Σ.(declarations) with [] => Σ | (d::decls) => - {| referenced_impl_env := {| universes := Σ.(universes); declarations := decls |} |} + {| referenced_impl_env := {| universes := Σ.(universes); declarations := decls; retroknowledge := Σ.(retroknowledge) |} |} end. Next Obligation. destruct Σ.(referenced_impl_wf). sq. @@ -154,10 +156,10 @@ Program Global Instance canonical_abstract_env_struct {cf:checker_flags} {guard abstract_env_struct referenced_impl referenced_impl_ext := {| abstract_env_empty := {| - referenced_impl_env := {| universes := init_env ; declarations := [] |}; + referenced_impl_env := {| universes := init_env ; declarations := []; retroknowledge := Retroknowledge.empty |}; |} ; - abstract_env_init := fun cs H => {| - referenced_impl_env := {| universes := cs ; declarations := [] |}; + abstract_env_init := fun cs retro H => {| + referenced_impl_env := {| universes := cs ; declarations := []; retroknowledge := retro |}; |} ; abstract_env_add_decl := fun X kn d H => {| referenced_impl_env := add_global_decl X.(referenced_impl_env) (kn,d); @@ -166,6 +168,7 @@ Program Global Instance canonical_abstract_env_struct {cf:checker_flags} {guard |} ; abstract_env_univ X := X ; abstract_env_global_declarations X := declarations X; + abstract_env_retroknowledge X := X.(retroknowledge) ; abstract_env_is_consistent uctx := wGraph.is_acyclic (make_graph uctx); abstract_env_is_consistent_uctx X uctx := let G := referenced_impl_graph X in @@ -206,6 +209,7 @@ Record wf_env_ext {cf:checker_flags} {guard : abstract_guard_impl} := { Global Instance optimized_abstract_env_ext_struct {cf:checker_flags} {guard : abstract_guard_impl} : abstract_env_ext_struct wf_env_ext := {| abstract_env_lookup := fun Σ k => EnvMap.lookup k (wf_env_ext_map Σ); + abstract_env_ext_retroknowledge := fun X => X.(wf_env_ext_referenced).(retroknowledge); abstract_env_conv_pb_relb X := abstract_env_conv_pb_relb X.(wf_env_ext_referenced); abstract_env_compare_global_instance X := abstract_env_compare_global_instance X.(wf_env_ext_referenced); abstract_env_level_mem X := abstract_env_level_mem X.(wf_env_ext_referenced); @@ -215,7 +219,8 @@ Global Instance optimized_abstract_env_ext_struct {cf:checker_flags} {guard : ab abstract_env_ext_rel X := abstract_env_ext_rel X.(wf_env_ext_referenced); |}. -Lemma wf_env_eta {cf : checker_flags} (Σ : wf_env) : {| universes := Σ.(universes); declarations := Σ.(declarations) |} = Σ. +Lemma wf_env_eta {cf : checker_flags} (Σ : wf_env) : + {| universes := Σ.(universes); declarations := Σ.(declarations); retroknowledge := Σ.(retroknowledge) |} = Σ. Proof. destruct Σ => /= //. destruct referenced_impl_env => //. Qed. @@ -245,10 +250,10 @@ Program Definition wf_env_empty {cf:checker_flags} {guard : abstract_guard_impl} wf_env_map := EnvMap.empty; |}. -Program Definition wf_env_init {cf:checker_flags} {guard : abstract_guard_impl} cs : +Program Definition wf_env_init {cf:checker_flags} {guard : abstract_guard_impl} cs retro : on_global_univs cs -> wf_env := fun H => {| - wf_env_referenced := abstract_env_init cs H; + wf_env_referenced := abstract_env_init cs retro H; wf_env_map := EnvMap.empty; |}. @@ -257,7 +262,8 @@ Lemma reference_pop_decls_correct {cf:checker_flags} (X:referenced_impl) decls exists d, Σ.(declarations) = d :: decls) : let X' := referenced_pop X in forall Σ Σ', Σ = X -> Σ' = X' -> - Σ'.(declarations) = decls /\ Σ.(universes) = Σ'.(universes). + Σ'.(declarations) = decls /\ Σ.(universes) = Σ'.(universes) /\ + Σ.(retroknowledge) = Σ'.(retroknowledge). Proof. cbn; intros; subst. specialize (prf _ eq_refl). unfold referenced_pop. cbn. set (referenced_pop_obligation_1 cf X). @@ -327,9 +333,9 @@ Next Obligation. sq. destruct H. apply EnvMap.repr_add; eauto; try eapply wf_fresh_globals; eauto. apply wf_env_map_repr. -Defined. -Next Obligation. apply wf_env_map_repr. Defined. -Next Obligation. apply wf_env_map_repr. Defined. +Qed. +Next Obligation. apply wf_env_map_repr. Qed. +Next Obligation. apply wf_env_map_repr. Qed. Section WfEnv. Context {cf : checker_flags} {guard : abstract_guard_impl}. @@ -391,7 +397,7 @@ Section GraphSpec. Local Definition HΣ' : ∥ wf_ext Σ ∥. Proof. destruct HΣ, Hφ; now constructor. - Defined. + Qed. Lemma check_constraints_spec ctrs : check_constraints G ctrs -> valid_constraints (global_ext_constraints Σ) ctrs. @@ -413,7 +419,7 @@ Section GraphSpec. now eapply global_ext_uctx_consistent. pose proof (wf_ext_global_uctx_invariants Σ H0) as [H1 H2]. split; eauto. - Defined. + Qed. Lemma is_graph_of_uctx_levels (l : Level.t) : LevelSet.mem l (uGraph.wGraph.V G) <-> @@ -435,9 +441,9 @@ End GraphSpec. Program Global Instance canonical_abstract_env_ext_prop {cf:checker_flags} {guard : abstract_guard_impl} : @abstract_env_ext_prop _ _ canonical_abstract_env_ext_struct := {| abstract_env_ext_exists := fun Σ => sq (referenced_impl_env_ext Σ ; eq_refl); |}. -Next Obligation. wf_env. Defined. +Next Obligation. wf_env. Qed. Next Obligation. apply check_conv_pb_relb_correct; eauto; wf_env. - apply (graph_of_wf_ext X).π2. Defined. + apply (graph_of_wf_ext X).π2. Qed. Next Obligation. eapply reflect_iff. eapply reflect_R_global_instance; eauto. move => ? ? /wf_universe_reflect ? - /wf_universe_reflect ?. apply iff_reflect; apply check_conv_pb_relb_correct with (conv_pb := Conv); eauto; wf_env. @@ -447,7 +453,7 @@ Next Obligation. eapply reflect_iff. eapply reflect_R_global_instance; eauto. all: rewrite wf_universeb_instance_forall. revert H; move => / wf_universe_instanceP ?; eauto. revert H0; move => / wf_universe_instanceP ?; eauto. -Defined. +Qed. Next Obligation. split; intros. - eapply check_constraints_complete; eauto. apply referenced_impl_sq_wf. apply Σudecl_ref. @@ -456,21 +462,21 @@ Next Obligation. split; intros. - eapply check_constraints_spec; eauto. apply referenced_impl_sq_wf. apply Σudecl_ref. apply (graph_of_wf_ext X).π2. - Defined. -Next Obligation. apply guard_correct. Defined. + Qed. +Next Obligation. apply guard_correct. Qed. Program Global Instance optimized_abstract_env_ext_prop {cf:checker_flags} {guard : abstract_guard_impl} : @abstract_env_ext_prop _ _ optimized_abstract_env_ext_struct := {| abstract_env_ext_exists := fun Σ => sq (referenced_impl_env_ext Σ ; eq_refl); |}. -Next Obligation. wf_env. Defined. +Next Obligation. wf_env. Qed. Next Obligation. pose (referenced_impl_ext_wf X). sq. erewrite EnvMap.lookup_spec; try reflexivity. 1: apply wf_fresh_globals; eauto. 1: apply wf_env_ext_map_repr. Qed. -Next Obligation. now rewrite (abstract_env_compare_universe_correct X.(wf_env_ext_referenced)). Defined. -Next Obligation. now rewrite (abstract_env_compare_global_instance_correct X.(wf_env_ext_referenced)); eauto. Defined. -Next Obligation. now rewrite (abstract_env_check_constraints_correct X.(wf_env_ext_referenced)); eauto. Defined. -Next Obligation. eapply guard_correct. Defined. +Next Obligation. now rewrite (abstract_env_compare_universe_correct X.(wf_env_ext_referenced)). Qed. +Next Obligation. now rewrite (abstract_env_compare_global_instance_correct X.(wf_env_ext_referenced)); eauto. Qed. +Next Obligation. now rewrite (abstract_env_check_constraints_correct X.(wf_env_ext_referenced)); eauto. Qed. +Next Obligation. eapply guard_correct. Qed. Program Global Instance canonical_abstract_env_prop {cf:checker_flags} {guard : abstract_guard_impl} : @abstract_env_prop _ _ _ canonical_abstract_env_ext_struct canonical_abstract_env_struct. @@ -495,7 +501,8 @@ Next Obligation. apply: consistent_ext_on_full_ext=> //. apply: add_uctx_subgraph. Qed. -Next Obligation. apply (reference_pop_decls_correct X decls prf X (referenced_pop X) eq_refl eq_refl). +Next Obligation. + apply (reference_pop_decls_correct X decls prf X (referenced_pop X) eq_refl eq_refl). Qed. Program Global Instance optimized_abstract_env_prop {cf:checker_flags} {guard : abstract_guard_impl} : diff --git a/template-coq/_CoqProject b/template-coq/_CoqProject index 42d7f6b8b..aedc2aed0 100644 --- a/template-coq/_CoqProject +++ b/template-coq/_CoqProject @@ -32,6 +32,8 @@ theories/utils/MCUtils.v theories/utils/MC_ExtrOCamlZPosInt.v theories/utils/ReflectEq.v +theories/Primitive.v + # common theories/common/uGraph.v @@ -49,6 +51,7 @@ theories/AstUtils.v theories/Reflect.v theories/ReflectAst.v theories/EnvMap.v +theories/TemplateEnvMap.v theories/Induction.v theories/EnvironmentTyping.v theories/WfAst.v diff --git a/template-coq/_PluginProject b/template-coq/_PluginProject index 48927416f..61c21bf00 100644 --- a/template-coq/_PluginProject +++ b/template-coq/_PluginProject @@ -21,18 +21,20 @@ gen-src/ast0.ml gen-src/ast0.mli gen-src/ast_denoter.ml gen-src/ast_quoter.ml +gen-src/primitive.mli +gen-src/primitive.ml gen-src/astUtils.ml gen-src/astUtils.mli gen-src/basicAst.ml gen-src/basicAst.mli gen-src/basics.ml gen-src/basics.mli +gen-src/binNums.mli +gen-src/binNums.ml gen-src/binInt.ml gen-src/binInt.mli gen-src/binNat.ml gen-src/binNat.mli -gen-src/binNums.ml -gen-src/binNums.mli gen-src/binPosDef.ml gen-src/binPosDef.mli gen-src/binPos.ml @@ -102,6 +104,8 @@ gen-src/logic2.mli gen-src/logic2.ml gen-src/relation.mli gen-src/relation.ml +gen-src/mCProd.mli +gen-src/mCProd.ml gen-src/mCPrelude.mli gen-src/mCPrelude.ml gen-src/mCCompare.ml @@ -112,8 +116,6 @@ gen-src/mCList.ml gen-src/mCList.mli gen-src/mCOption.ml gen-src/mCOption.mli -gen-src/mCProd.ml -gen-src/mCProd.mli gen-src/mCRelations.ml gen-src/mCRelations.mli gen-src/mCReflect.mli @@ -202,15 +204,16 @@ gen-src/kernames.mli gen-src/kernames.ml gen-src/universes0.ml gen-src/universes0.mli - +gen-src/transform.mli +gen-src/transform.ml gen-src/termEquality.mli gen-src/termEquality.ml +gen-src/envMap.mli +gen-src/envMap.ml +gen-src/templateEnvMap.mli +gen-src/templateEnvMap.ml gen-src/typing0.mli gen-src/typing0.ml -gen-src/transform.mli -gen-src/transform.ml -gen-src/etaExpand.mli -gen-src/etaExpand.ml gen-src/templateProgram.mli gen-src/templateProgram.ml diff --git a/template-coq/gen-src/cRelationClasses.mli.orig b/template-coq/gen-src/cRelationClasses.mli.orig index c49080220..49a8d3f48 100644 --- a/template-coq/gen-src/cRelationClasses.mli.orig +++ b/template-coq/gen-src/cRelationClasses.mli.orig @@ -14,6 +14,10 @@ type ('a, 'r) coq_Reflexive = 'a -> 'r val reflexivity : ('a1, 'a2) coq_Reflexive -> 'a1 -> 'a2 +type ('a, 'r) complement = __ + +type ('a, 'r) coq_Irreflexive = ('a, ('a, 'r) complement) coq_Reflexive + type ('a, 'r) coq_Symmetric = 'a -> 'a -> 'r -> 'r val symmetry : ('a1, 'a2) coq_Symmetric -> 'a1 -> 'a1 -> 'a2 -> 'a2 @@ -33,9 +37,10 @@ val coq_PreOrder_Reflexive : val coq_PreOrder_Transitive : ('a1, 'a2) coq_PreOrder -> ('a1, 'a2) coq_Transitive -type ('a, 'r) coq_StrictOrder = - ('a, 'r) coq_Transitive - (* singleton inductive, whose constructor was Build_StrictOrder *) +type ('a, 'r) coq_StrictOrder = { coq_StrictOrder_Irreflexive : ('a, 'r) + coq_Irreflexive; + coq_StrictOrder_Transitive : ('a, 'r) + coq_Transitive } val coq_StrictOrder_Transitive : ('a1, 'a2) coq_StrictOrder -> ('a1, 'a2) coq_Transitive @@ -104,19 +109,18 @@ val iff_equivalence : (__, __) coq_Equivalence val arrow_Reflexive_obligation_1 : ('a1, 'a1) arrow -val arrow_Reflexive : ('a1, 'a1) arrow +val arrow_Reflexive : (__, __) arrow val arrow_Transitive_obligation_1 : ('a1, 'a2) arrow -> ('a2, 'a3) arrow -> ('a1, 'a3) arrow -val arrow_Transitive : - ('a1, 'a2) arrow -> ('a2, 'a3) arrow -> ('a1, 'a3) arrow +val arrow_Transitive : (__, __) arrow -> (__, __) arrow -> (__, __) arrow -val iffT_Reflexive : ('a1, 'a1) iffT +val iffT_Reflexive : (__, __) iffT -val iffT_Symmetric : ('a1, 'a2) iffT -> ('a2, 'a1) iffT +val iffT_Symmetric : (__, __) iffT -> (__, __) iffT -val iffT_Transitive : ('a1, 'a2) iffT -> ('a2, 'a3) iffT -> ('a1, 'a3) iffT +val iffT_Transitive : (__, __) iffT -> (__, __) iffT -> (__, __) iffT type ('a, 'x0, 'x) relation_equivalence = 'a -> 'a -> ('x0, 'x) iffT diff --git a/template-coq/gen-src/metacoq_template_plugin.mlpack b/template-coq/gen-src/metacoq_template_plugin.mlpack index 95a8f5e8f..375c85e5c 100644 --- a/template-coq/gen-src/metacoq_template_plugin.mlpack +++ b/template-coq/gen-src/metacoq_template_plugin.mlpack @@ -11,6 +11,7 @@ PeanoNat Specif Basics BinPosDef +BinNums BinPos BinNat BinInt @@ -42,7 +43,6 @@ MSetDecide MSetList MSetAVL MSetProperties -BinNums EqDec CRelationClasses Compare_dec @@ -77,6 +77,7 @@ Signature All_Forall Config0 Kernames +Primitive BasicAst Universes0 Environment @@ -91,6 +92,7 @@ Pretty Common0 Extractable Logic0 +EnvMap Tm_util Reification @@ -102,8 +104,8 @@ Plugin_core Run_extractable Transform +TemplateEnvMap TermEquality Typing0 -EtaExpand TemplateProgram diff --git a/template-coq/gen-src/specFloat.ml.orig b/template-coq/gen-src/specFloat.ml.orig new file mode 100644 index 000000000..612fa74ed --- /dev/null +++ b/template-coq/gen-src/specFloat.ml.orig @@ -0,0 +1,546 @@ +open BinInt +open BinNums +open BinPos +open Bool +open Datatypes +open Zbool +open Zpower + +type spec_float = +| S754_zero of bool +| S754_infinity of bool +| S754_nan +| S754_finite of bool * positive * coq_Z + +(** val emin : coq_Z -> coq_Z -> coq_Z **) + +let emin prec emax = + Z.sub (Z.sub (Zpos (Coq_xI Coq_xH)) emax) prec + +(** val fexp : coq_Z -> coq_Z -> coq_Z -> coq_Z **) + +let fexp prec emax e = + Z.max (Z.sub e prec) (emin prec emax) + +(** val digits2_pos : positive -> positive **) + +let rec digits2_pos = function +| Coq_xI p -> Pos.succ (digits2_pos p) +| Coq_xO p -> Pos.succ (digits2_pos p) +| Coq_xH -> Coq_xH + +(** val coq_Zdigits2 : coq_Z -> coq_Z **) + +let coq_Zdigits2 n = match n with +| Z0 -> n +| Zpos p -> Zpos (digits2_pos p) +| Zneg p -> Zpos (digits2_pos p) + +(** val canonical_mantissa : coq_Z -> coq_Z -> positive -> coq_Z -> bool **) + +let canonical_mantissa prec emax m e = + coq_Zeq_bool (fexp prec emax (Z.add (Zpos (digits2_pos m)) e)) e + +(** val bounded : coq_Z -> coq_Z -> positive -> coq_Z -> bool **) + +let bounded prec emax m e = + (&&) (canonical_mantissa prec emax m e) (Z.leb e (Z.sub emax prec)) + +(** val valid_binary : coq_Z -> coq_Z -> spec_float -> bool **) + +let valid_binary prec emax = function +| S754_finite (_, m, e) -> bounded prec emax m e +| _ -> true + +(** val iter_pos : ('a1 -> 'a1) -> positive -> 'a1 -> 'a1 **) + +let rec iter_pos f n x = + match n with + | Coq_xI n' -> iter_pos f n' (iter_pos f n' (f x)) + | Coq_xO n' -> iter_pos f n' (iter_pos f n' x) + | Coq_xH -> f x + +type location = +| Coq_loc_Exact +| Coq_loc_Inexact of comparison + +(** val location_rect : 'a1 -> (comparison -> 'a1) -> location -> 'a1 **) + +let location_rect f f0 = function +| Coq_loc_Exact -> f +| Coq_loc_Inexact c -> f0 c + +(** val location_rec : 'a1 -> (comparison -> 'a1) -> location -> 'a1 **) + +let location_rec f f0 = function +| Coq_loc_Exact -> f +| Coq_loc_Inexact c -> f0 c + +type shr_record = { shr_m : coq_Z; shr_r : bool; shr_s : bool } + +(** val shr_m : shr_record -> coq_Z **) + +let shr_m s = + s.shr_m + +(** val shr_r : shr_record -> bool **) + +let shr_r s = + s.shr_r + +(** val shr_s : shr_record -> bool **) + +let shr_s s = + s.shr_s + +(** val shr_1 : shr_record -> shr_record **) + +let shr_1 mrs = + let { shr_m = m; shr_r = r; shr_s = s } = mrs in + let s0 = (||) r s in + (match m with + | Z0 -> { shr_m = Z0; shr_r = false; shr_s = s0 } + | Zpos p0 -> + (match p0 with + | Coq_xI p -> { shr_m = (Zpos p); shr_r = true; shr_s = s0 } + | Coq_xO p -> { shr_m = (Zpos p); shr_r = false; shr_s = s0 } + | Coq_xH -> { shr_m = Z0; shr_r = true; shr_s = s0 }) + | Zneg p0 -> + (match p0 with + | Coq_xI p -> { shr_m = (Zneg p); shr_r = true; shr_s = s0 } + | Coq_xO p -> { shr_m = (Zneg p); shr_r = false; shr_s = s0 } + | Coq_xH -> { shr_m = Z0; shr_r = true; shr_s = s0 })) + +(** val loc_of_shr_record : shr_record -> location **) + +let loc_of_shr_record mrs = + let { shr_m = _; shr_r = shr_r0; shr_s = shr_s0 } = mrs in + if shr_r0 + then if shr_s0 then Coq_loc_Inexact Gt else Coq_loc_Inexact Eq + else if shr_s0 then Coq_loc_Inexact Lt else Coq_loc_Exact + +(** val shr_record_of_loc : coq_Z -> location -> shr_record **) + +let shr_record_of_loc m = function +| Coq_loc_Exact -> { shr_m = m; shr_r = false; shr_s = false } +| Coq_loc_Inexact c -> + (match c with + | Eq -> { shr_m = m; shr_r = true; shr_s = false } + | Lt -> { shr_m = m; shr_r = false; shr_s = true } + | Gt -> { shr_m = m; shr_r = true; shr_s = true }) + +(** val shr : shr_record -> coq_Z -> coq_Z -> shr_record * coq_Z **) + +let shr mrs e n = match n with +| Zpos p -> ((iter_pos shr_1 p mrs), (Z.add e n)) +| _ -> (mrs, e) + +(** val shr_fexp : + coq_Z -> coq_Z -> coq_Z -> coq_Z -> location -> shr_record * coq_Z **) + +let shr_fexp prec emax m e l = + shr (shr_record_of_loc m l) e + (Z.sub (fexp prec emax (Z.add (coq_Zdigits2 m) e)) e) + +(** val round_nearest_even : coq_Z -> location -> coq_Z **) + +let round_nearest_even mx = function +| Coq_loc_Exact -> mx +| Coq_loc_Inexact c -> + (match c with + | Eq -> if Z.even mx then mx else Z.add mx (Zpos Coq_xH) + | Lt -> mx + | Gt -> Z.add mx (Zpos Coq_xH)) + +(** val binary_round_aux : + coq_Z -> coq_Z -> bool -> coq_Z -> coq_Z -> location -> spec_float **) + +let binary_round_aux prec emax sx mx ex lx = + let (mrs', e') = shr_fexp prec emax mx ex lx in + let (mrs'', e'') = + shr_fexp prec emax + (round_nearest_even mrs'.shr_m (loc_of_shr_record mrs')) e' + Coq_loc_Exact + in + (match mrs''.shr_m with + | Z0 -> S754_zero sx + | Zpos m -> + if Z.leb e'' (Z.sub emax prec) + then S754_finite (sx, m, e'') + else S754_infinity sx + | Zneg _ -> S754_nan) + +(** val shl_align : positive -> coq_Z -> coq_Z -> positive * coq_Z **) + +let shl_align mx ex ex' = + match Z.sub ex' ex with + | Zneg d -> ((shift_pos d mx), ex') + | _ -> (mx, ex) + +(** val binary_round : + coq_Z -> coq_Z -> bool -> positive -> coq_Z -> spec_float **) + +let binary_round prec emax sx mx ex = + let (mz, ez) = + shl_align mx ex (fexp prec emax (Z.add (Zpos (digits2_pos mx)) ex)) + in + binary_round_aux prec emax sx (Zpos mz) ez Coq_loc_Exact + +(** val binary_normalize : + coq_Z -> coq_Z -> coq_Z -> coq_Z -> bool -> spec_float **) + +let binary_normalize prec emax m e szero = + match m with + | Z0 -> S754_zero szero + | Zpos m0 -> binary_round prec emax false m0 e + | Zneg m0 -> binary_round prec emax true m0 e + +(** val coq_SFopp : spec_float -> spec_float **) + +let coq_SFopp = function +| S754_zero sx -> S754_zero (negb sx) +| S754_infinity sx -> S754_infinity (negb sx) +| S754_nan -> S754_nan +| S754_finite (sx, mx, ex) -> S754_finite ((negb sx), mx, ex) + +(** val coq_SFabs : spec_float -> spec_float **) + +let coq_SFabs = function +| S754_zero _ -> S754_zero false +| S754_infinity _ -> S754_infinity false +| S754_nan -> S754_nan +| S754_finite (_, mx, ex) -> S754_finite (false, mx, ex) + +(** val coq_SFcompare : spec_float -> spec_float -> comparison option **) + +let coq_SFcompare f1 f2 = + match f1 with + | S754_zero _ -> + (match f2 with + | S754_zero _ -> Some Eq + | S754_infinity s -> Some (if s then Gt else Lt) + | S754_nan -> None + | S754_finite (s, _, _) -> Some (if s then Gt else Lt)) + | S754_infinity s -> + (match f2 with + | S754_infinity s0 -> + Some (if s then if s0 then Eq else Lt else if s0 then Gt else Eq) + | S754_nan -> None + | _ -> Some (if s then Lt else Gt)) + | S754_nan -> None + | S754_finite (s1, m1, e1) -> + (match f2 with + | S754_zero _ -> Some (if s1 then Lt else Gt) + | S754_infinity s -> Some (if s then Gt else Lt) + | S754_nan -> None + | S754_finite (s2, m2, e2) -> + Some + (if s1 + then if s2 + then (match Z.compare e1 e2 with + | Eq -> coq_CompOpp (Pos.compare_cont Eq m1 m2) + | Lt -> Gt + | Gt -> Lt) + else Lt + else if s2 + then Gt + else (match Z.compare e1 e2 with + | Eq -> Pos.compare_cont Eq m1 m2 + | x -> x))) + +(** val coq_SFeqb : spec_float -> spec_float -> bool **) + +let coq_SFeqb f1 f2 = + match coq_SFcompare f1 f2 with + | Some c -> (match c with + | Eq -> true + | _ -> false) + | None -> false + +(** val coq_SFltb : spec_float -> spec_float -> bool **) + +let coq_SFltb f1 f2 = + match coq_SFcompare f1 f2 with + | Some c -> (match c with + | Lt -> true + | _ -> false) + | None -> false + +(** val coq_SFleb : spec_float -> spec_float -> bool **) + +let coq_SFleb f1 f2 = + match coq_SFcompare f1 f2 with + | Some c -> (match c with + | Gt -> false + | _ -> true) + | None -> false + +(** val coq_SFclassify : coq_Z -> spec_float -> Float64.float_class **) + +let coq_SFclassify prec = function +| S754_zero s -> if s then NZero else PZero +| S754_infinity s -> if s then NInf else PInf +| S754_nan -> NaN +| S754_finite (s, m, _) -> + if s + then if Pos.eqb (digits2_pos m) (Z.to_pos prec) then NNormal else NSubn + else if Pos.eqb (digits2_pos m) (Z.to_pos prec) then PNormal else PSubn + +(** val coq_SFmul : + coq_Z -> coq_Z -> spec_float -> spec_float -> spec_float **) + +let coq_SFmul prec emax x y = + match x with + | S754_zero sx -> + (match y with + | S754_zero sy -> S754_zero (xorb sx sy) + | S754_finite (sy, _, _) -> S754_zero (xorb sx sy) + | _ -> S754_nan) + | S754_infinity sx -> + (match y with + | S754_infinity sy -> S754_infinity (xorb sx sy) + | S754_finite (sy, _, _) -> S754_infinity (xorb sx sy) + | _ -> S754_nan) + | S754_nan -> S754_nan + | S754_finite (sx, mx, ex) -> + (match y with + | S754_zero sy -> S754_zero (xorb sx sy) + | S754_infinity sy -> S754_infinity (xorb sx sy) + | S754_nan -> S754_nan + | S754_finite (sy, my, ey) -> + binary_round_aux prec emax (xorb sx sy) (Zpos (Pos.mul mx my)) + (Z.add ex ey) Coq_loc_Exact) + +(** val cond_Zopp : bool -> coq_Z -> coq_Z **) + +let cond_Zopp b m = + if b then Z.opp m else m + +(** val coq_SFadd : + coq_Z -> coq_Z -> spec_float -> spec_float -> spec_float **) + +let coq_SFadd prec emax x y = + match x with + | S754_zero sx -> + (match y with + | S754_zero sy -> if eqb sx sy then x else S754_zero false + | S754_nan -> S754_nan + | _ -> y) + | S754_infinity sx -> + (match y with + | S754_infinity sy -> if eqb sx sy then x else S754_nan + | S754_nan -> S754_nan + | _ -> x) + | S754_nan -> S754_nan + | S754_finite (sx, mx, ex) -> + (match y with + | S754_zero _ -> x + | S754_infinity _ -> y + | S754_nan -> S754_nan + | S754_finite (sy, my, ey) -> + let ez = Z.min ex ey in + binary_normalize prec emax + (Z.add (cond_Zopp sx (Zpos (fst (shl_align mx ex ez)))) + (cond_Zopp sy (Zpos (fst (shl_align my ey ez))))) ez false) + +(** val coq_SFsub : + coq_Z -> coq_Z -> spec_float -> spec_float -> spec_float **) + +let coq_SFsub prec emax x y = + match x with + | S754_zero sx -> + (match y with + | S754_zero sy -> if eqb sx (negb sy) then x else S754_zero false + | S754_infinity sy -> S754_infinity (negb sy) + | S754_nan -> S754_nan + | S754_finite (sy, my, ey) -> S754_finite ((negb sy), my, ey)) + | S754_infinity sx -> + (match y with + | S754_infinity sy -> if eqb sx (negb sy) then x else S754_nan + | S754_nan -> S754_nan + | _ -> x) + | S754_nan -> S754_nan + | S754_finite (sx, mx, ex) -> + (match y with + | S754_zero _ -> x + | S754_infinity sy -> S754_infinity (negb sy) + | S754_nan -> S754_nan + | S754_finite (sy, my, ey) -> + let ez = Z.min ex ey in + binary_normalize prec emax + (Z.sub (cond_Zopp sx (Zpos (fst (shl_align mx ex ez)))) + (cond_Zopp sy (Zpos (fst (shl_align my ey ez))))) ez false) + +(** val new_location_even : coq_Z -> coq_Z -> location **) + +let new_location_even nb_steps k = + if coq_Zeq_bool k Z0 + then Coq_loc_Exact + else Coq_loc_Inexact (Z.compare (Z.mul (Zpos (Coq_xO Coq_xH)) k) nb_steps) + +(** val new_location_odd : coq_Z -> coq_Z -> location **) + +let new_location_odd nb_steps k = + if coq_Zeq_bool k Z0 + then Coq_loc_Exact + else Coq_loc_Inexact + (match Z.compare + (Z.add (Z.mul (Zpos (Coq_xO Coq_xH)) k) (Zpos Coq_xH)) + nb_steps with + | Eq -> Lt + | x -> x) + +(** val new_location : coq_Z -> coq_Z -> location **) + +let new_location nb_steps = + if Z.even nb_steps + then new_location_even nb_steps + else new_location_odd nb_steps + +(** val coq_SFdiv_core_binary : + coq_Z -> coq_Z -> coq_Z -> coq_Z -> coq_Z -> coq_Z -> + (coq_Z * coq_Z) * location **) + +let coq_SFdiv_core_binary prec emax m1 e1 m2 e2 = + let d1 = coq_Zdigits2 m1 in + let d2 = coq_Zdigits2 m2 in + let e' = + Z.min (fexp prec emax (Z.sub (Z.add d1 e1) (Z.add d2 e2))) (Z.sub e1 e2) + in + let s = Z.sub (Z.sub e1 e2) e' in + let m' = match s with + | Z0 -> m1 + | Zpos _ -> Z.shiftl m1 s + | Zneg _ -> Z0 in + let (q, r) = Z.div_eucl m' m2 in ((q, e'), (new_location m2 r)) + +(** val coq_SFdiv : + coq_Z -> coq_Z -> spec_float -> spec_float -> spec_float **) + +let coq_SFdiv prec emax x y = + match x with + | S754_zero sx -> + (match y with + | S754_infinity sy -> S754_zero (xorb sx sy) + | S754_finite (sy, _, _) -> S754_zero (xorb sx sy) + | _ -> S754_nan) + | S754_infinity sx -> + (match y with + | S754_zero sy -> S754_infinity (xorb sx sy) + | S754_finite (sy, _, _) -> S754_infinity (xorb sx sy) + | _ -> S754_nan) + | S754_nan -> S754_nan + | S754_finite (sx, mx, ex) -> + (match y with + | S754_zero sy -> S754_infinity (xorb sx sy) + | S754_infinity sy -> S754_zero (xorb sx sy) + | S754_nan -> S754_nan + | S754_finite (sy, my, ey) -> + let (p, lz) = coq_SFdiv_core_binary prec emax (Zpos mx) ex (Zpos my) ey + in + let (mz, ez) = p in binary_round_aux prec emax (xorb sx sy) mz ez lz) + +(** val coq_SFsqrt_core_binary : + coq_Z -> coq_Z -> coq_Z -> coq_Z -> (coq_Z * coq_Z) * location **) + +let coq_SFsqrt_core_binary prec emax m e = + let d = coq_Zdigits2 m in + let e' = + Z.min (fexp prec emax (Z.div2 (Z.add (Z.add d e) (Zpos Coq_xH)))) + (Z.div2 e) + in + let s = Z.sub e (Z.mul (Zpos (Coq_xO Coq_xH)) e') in + let m' = match s with + | Z0 -> m + | Zpos _ -> Z.shiftl m s + | Zneg _ -> Z0 in + let (q, r) = Z.sqrtrem m' in + let l = + if coq_Zeq_bool r Z0 + then Coq_loc_Exact + else Coq_loc_Inexact (if Z.leb r q then Lt else Gt) + in + ((q, e'), l) + +(** val coq_SFsqrt : coq_Z -> coq_Z -> spec_float -> spec_float **) + +let coq_SFsqrt prec emax x = match x with +| S754_zero _ -> x +| S754_infinity s -> if s then S754_nan else x +| S754_nan -> S754_nan +| S754_finite (s, mx, ex) -> + if s + then S754_nan + else let (p, lz) = coq_SFsqrt_core_binary prec emax (Zpos mx) ex in + let (mz, ez) = p in binary_round_aux prec emax false mz ez lz + +(** val coq_SFnormfr_mantissa : coq_Z -> spec_float -> coq_N **) + +let coq_SFnormfr_mantissa prec = function +| S754_finite (_, mx, ex) -> if Z.eqb ex (Z.opp prec) then Npos mx else N0 +| _ -> N0 + +(** val coq_SFldexp : coq_Z -> coq_Z -> spec_float -> coq_Z -> spec_float **) + +let coq_SFldexp prec emax f e = + match f with + | S754_finite (sx, mx, ex) -> binary_round prec emax sx mx (Z.add ex e) + | _ -> f + +(** val coq_SFfrexp : coq_Z -> coq_Z -> spec_float -> spec_float * coq_Z **) + +let coq_SFfrexp prec emax f = match f with +| S754_finite (sx, mx, ex) -> + if Pos.leb (Z.to_pos prec) (digits2_pos mx) + then ((S754_finite (sx, mx, (Z.opp prec))), (Z.add ex prec)) + else let d = Z.sub prec (Zpos (digits2_pos mx)) in + ((S754_finite (sx, (shift_pos (Z.to_pos d) mx), (Z.opp prec))), + (Z.sub (Z.add ex prec) d)) +| _ -> (f, (Z.sub (Z.mul (Zneg (Coq_xO Coq_xH)) emax) prec)) + +(** val coq_SFone : coq_Z -> coq_Z -> spec_float **) + +let coq_SFone prec emax = + binary_round prec emax false Coq_xH Z0 + +(** val coq_SFulp : coq_Z -> coq_Z -> spec_float -> spec_float **) + +let coq_SFulp prec emax x = + coq_SFldexp prec emax (coq_SFone prec emax) + (fexp prec emax (snd (coq_SFfrexp prec emax x))) + +(** val coq_SFpred_pos : coq_Z -> coq_Z -> spec_float -> spec_float **) + +let coq_SFpred_pos prec emax x = match x with +| S754_finite (_, mx, _) -> + let d = + if Pos.eqb (Coq_xO mx) (shift_pos (Z.to_pos prec) Coq_xH) + then coq_SFldexp prec emax (coq_SFone prec emax) + (fexp prec emax + (Z.sub (snd (coq_SFfrexp prec emax x)) (Zpos Coq_xH))) + else coq_SFulp prec emax x + in + coq_SFsub prec emax x d +| _ -> x + +(** val coq_SFmax_float : coq_Z -> coq_Z -> spec_float **) + +let coq_SFmax_float prec emax = + S754_finite (false, (Pos.sub (shift_pos (Z.to_pos prec) Coq_xH) Coq_xH), + (Z.sub emax prec)) + +(** val coq_SFsucc : coq_Z -> coq_Z -> spec_float -> spec_float **) + +let coq_SFsucc prec emax x = match x with +| S754_zero _ -> coq_SFldexp prec emax (coq_SFone prec emax) (emin prec emax) +| S754_infinity s -> if s then coq_SFopp (coq_SFmax_float prec emax) else x +| S754_nan -> x +| S754_finite (s, _, _) -> + if s + then coq_SFopp (coq_SFpred_pos prec emax (coq_SFopp x)) + else coq_SFadd prec emax x (coq_SFulp prec emax x) + +(** val coq_SFpred : coq_Z -> coq_Z -> spec_float -> spec_float **) + +let coq_SFpred prec emax f = + coq_SFopp (coq_SFsucc prec emax (coq_SFopp f)) diff --git a/template-coq/src/ast_denoter.ml b/template-coq/src/ast_denoter.ml index 7d15e7460..4555b298a 100644 --- a/template-coq/src/ast_denoter.ml +++ b/template-coq/src/ast_denoter.ml @@ -51,6 +51,7 @@ struct type quoted_constant_body = constant_body type quoted_global_decl = global_decl type quoted_global_declarations = (kername * global_decl) list + type quoted_retroknowledge = Environment.Retroknowledge.t type quoted_global_env = global_env type quoted_program = program @@ -122,8 +123,8 @@ struct | Coq_tProj (a,b) -> ACoq_tProj (a,b) | Coq_tFix (a,b) -> ACoq_tFix (List.map unquote_def a,b) | Coq_tCoFix (a,b) -> ACoq_tCoFix (List.map unquote_def a,b) - (* | Coq_tInt i -> ACoq_tInt i *) - (* | Coq_tFloat f -> ACoq_tFloat f *) + | Coq_tInt i -> ACoq_tInt i + | Coq_tFloat f -> ACoq_tFloat f let unquote_string = Caml_bytestring.caml_string_of_bytestring diff --git a/template-coq/src/ast_quoter.ml b/template-coq/src/ast_quoter.ml index a48e2ccf0..fd0414535 100644 --- a/template-coq/src/ast_quoter.ml +++ b/template-coq/src/ast_quoter.ml @@ -52,6 +52,7 @@ struct type quoted_constant_body = constant_body type quoted_global_decl = global_decl type quoted_global_declarations = global_declarations + type quoted_retroknowledge = Environment.Retroknowledge.t type quoted_global_env = global_env type quoted_program = program @@ -135,8 +136,8 @@ struct let quote_proj ind p a = { proj_ind = ind; proj_npars = p; proj_arg = a } let quote_constraint_type = function - | Univ.Lt -> Universes0.ConstraintType.Le 1 - | Univ.Le -> Universes0.ConstraintType.Le 0 + | Univ.Lt -> Universes0.ConstraintType.Le BinNums.(Zpos Coq_xH) + | Univ.Le -> Universes0.ConstraintType.Le BinNums.Z0 | Univ.Eq -> Universes0.ConstraintType.Eq let is_Lt = function @@ -232,8 +233,8 @@ struct let mkInd i u = Coq_tInd (i, u) let mkConstruct (ind, i) u = Coq_tConstruct (ind, i, u) let mkLetIn na b t t' = Coq_tLetIn (na,b,t,t') - (* let mkInt i = Coq_tInt i - let mkFloat f = Coq_tFloat f *) + let mkInt i = Coq_tInt i + let mkFloat f = Coq_tFloat f let rec seq f t = if f < t then @@ -260,7 +261,7 @@ struct in let defs = List.fold_left mk_fun [] (seq 0 (Array.length ns)) in let block = List.rev defs in - Coq_tFix (block, a) + Coq_tCoFix (block, a) let mkCase (ind, npar, r) (univs, pars, pctx, pret) c brs = let info = { ci_ind = ind; ci_npar = npar; ci_relevance = r } in @@ -310,7 +311,15 @@ struct let add_global_decl kn a b = (kn, a) :: b - let mk_global_env universes declarations = { universes; declarations } + type pre_quoted_retroknowledge = + { retro_int63 : quoted_kernel_name option; + retro_float64 : quoted_kernel_name option } + + let quote_retroknowledge r = + { Environment.Retroknowledge.retro_int63 = r.retro_int63; + Environment.Retroknowledge.retro_float64 = r.retro_float64 } + + let mk_global_env universes declarations retroknowledge = { universes; declarations; retroknowledge } let mk_program decls tm = (decls, tm) let quote_mind_finiteness = function diff --git a/template-coq/src/constr_quoter.ml b/template-coq/src/constr_quoter.ml index 81ea5449f..f796d4df4 100644 --- a/template-coq/src/constr_quoter.ml +++ b/template-coq/src/constr_quoter.ml @@ -408,8 +408,17 @@ struct let pair = pairl tkername tglobal_decl kn d in constr_mkApp (c_cons, [| global_pairty (); pair; l|]) - let mk_global_env univs decls = - constr_mkApp (tBuild_global_env, [| univs; decls |]) + type pre_quoted_retroknowledge = + { retro_int63 : quoted_kernel_name option; + retro_float64 : quoted_kernel_name option } + + let quote_retroknowledge r = + let rint63 = to_coq_option (Lazy.force tkername) (fun x -> x) r.retro_int63 in + let rfloat64 = to_coq_option (Lazy.force tkername) (fun x -> x) r.retro_float64 in + constr_mkApp (tmk_retroknowledge, [| rint63; rfloat64 |]) + + let mk_global_env univs decls retro = + constr_mkApp (tBuild_global_env, [| univs; decls; retro |]) let mk_program f s = pairl tglobal_env tTerm f s diff --git a/template-coq/src/constr_reification.ml b/template-coq/src/constr_reification.ml index 9ee2a9f0c..389bcb321 100644 --- a/template-coq/src/constr_reification.ml +++ b/template-coq/src/constr_reification.ml @@ -48,6 +48,7 @@ struct type quoted_global_decl = Constr.t (* of type Ast.global_decl *) type quoted_global_declarations = Constr.t (* of type Ast.global_declarations *) type quoted_global_env = Constr.t (* of type Ast.global_env *) + type quoted_retroknowledge = Constr.t (* of type Retroknowledge.t *) type quoted_program = Constr.t (* of type Ast.program *) let resolve (tm : string) : Constr.t Lazy.t = @@ -219,6 +220,7 @@ struct let tglobal_decl = ast "global_decl" let tConstantDecl = ast "ConstantDecl" let tInductiveDecl = ast "InductiveDecl" + let tmk_retroknowledge = ast "mk_retroknowledge" let tBuild_global_env = ast "Build_global_env" let tglobal_env = ast "global_env" diff --git a/template-coq/src/denoter.ml b/template-coq/src/denoter.ml index 8f69cfd3f..b6bb08ccc 100644 --- a/template-coq/src/denoter.ml +++ b/template-coq/src/denoter.ml @@ -158,8 +158,8 @@ struct let p' = Names.Projection.make p' false in let evm, t' = aux env evm t in evm, Constr.mkProj (p', t') - (* | ACoq_tInt x -> evm, Constr.mkInt (D.unquote_int63 x) *) - (* | ACoq_tFloat x -> evm, Constr.mkFloat (D.unquote_float64 x) *) + | ACoq_tInt x -> evm, Constr.mkInt (D.unquote_int63 x) + | ACoq_tFloat x -> evm, Constr.mkFloat (D.unquote_float64 x) in aux env evm trm diff --git a/template-coq/src/quoter.ml b/template-coq/src/quoter.ml index d1bb15c4c..1fb874a7b 100644 --- a/template-coq/src/quoter.ml +++ b/template-coq/src/quoter.ml @@ -67,8 +67,8 @@ sig val mkProj : quoted_proj -> t -> t val mkFix : (quoted_int array * quoted_int) * (quoted_aname array * t array * t array) -> t val mkCoFix : quoted_int * (quoted_aname array * t array * t array) -> t - (* val mkInt : quoted_int63 -> t - val mkFloat : quoted_float64 -> t *) + val mkInt : quoted_int63 -> t + val mkFloat : quoted_float64 -> t val mkBindAnn : quoted_name -> quoted_relevance -> quoted_aname val mkName : quoted_ident -> quoted_name @@ -153,7 +153,13 @@ sig val empty_global_declarations : unit -> quoted_global_declarations val add_global_decl : quoted_kernel_name -> quoted_global_decl -> quoted_global_declarations -> quoted_global_declarations - val mk_global_env : quoted_univ_contextset -> quoted_global_declarations -> quoted_global_env + type pre_quoted_retroknowledge = + { retro_int63 : quoted_kernel_name option; + retro_float64 : quoted_kernel_name option } + + val quote_retroknowledge : pre_quoted_retroknowledge -> quoted_retroknowledge + + val mk_global_env : quoted_univ_contextset -> quoted_global_declarations -> quoted_retroknowledge -> quoted_global_env val mk_program : quoted_global_env -> t -> quoted_program end @@ -326,11 +332,9 @@ struct let t', acc = quote_term acc env sigma c in let mib = Environ.lookup_mind (fst (Projection.inductive p)) (snd env) in (Q.mkProj p' t', add_inductive (Projection.inductive p) mib acc) - (* | Constr.Int i -> (Q.mkInt (Q.quote_int63 i), acc) - | Constr.Float f -> (Q.mkFloat (Q.quote_float64 f), acc) *) + | Constr.Int i -> (Q.mkInt (Q.quote_int63 i), acc) + | Constr.Float f -> (Q.mkFloat (Q.quote_float64 f), acc) | Constr.Meta _ -> failwith "Meta not supported by TemplateCoq" - | Constr.Int _ -> failwith "Primitive ints not supported by TemplateCoq" - | Constr.Float _ -> failwith "Primitive floats not supported by TemplateCoq" | Constr.Array _ -> failwith "Primitive arrays not supported by TemplateCoq" in aux acc env trm @@ -558,7 +562,15 @@ struct time (Pp.str"Quoting empty universe context") (fun uctx -> Q.quote_univ_contextset uctx) Univ.ContextSet.empty) in - let env = Q.mk_global_env univs decls in + let retro = + let retro = env.Environ.retroknowledge in + let quote_retro = Option.map (fun c -> Q.quote_kn (Names.Constant.canonical c)) in + let pre = + { Q.retro_int63 = quote_retro retro.Retroknowledge.retro_int63 ; + Q.retro_float64 = quote_retro retro.Retroknowledge.retro_float64 } + in Q.quote_retroknowledge pre + in + let env = Q.mk_global_env univs decls retro in Q.mk_program env tm let quote_rel_context env sigma ctx = diff --git a/template-coq/src/reification.ml b/template-coq/src/reification.ml index f08134676..524fc9779 100644 --- a/template-coq/src/reification.ml +++ b/template-coq/src/reification.ml @@ -48,6 +48,7 @@ sig type quoted_constant_body type quoted_global_decl type quoted_global_declarations + type quoted_retroknowledge type quoted_global_env type quoted_program (* the return type of quote_recursively *) diff --git a/template-coq/src/run_template_monad.ml b/template-coq/src/run_template_monad.ml index 83d4b8324..6540d2abe 100644 --- a/template-coq/src/run_template_monad.ml +++ b/template-coq/src/run_template_monad.ml @@ -299,12 +299,34 @@ let declare_inductive (env: Environ.env) (evm: Evd.evar_map) (infer_univs : bool if infer_univs then let ctx, mind = Tm_util.RetypeMindEntry.infer_mentry_univs env evm' mind in debug (fun () -> Pp.(str "Declaring universe context " ++ Univ.pr_universe_context_set (Level.pr) ctx)); - DeclareUctx.declare_universe_context ~poly:false ctx; + DeclareUctx.declare_universe_context ~poly:false ctx; Evd.merge_context_set Evd.UnivRigid evm ctx, mind else evm, mind in let names = (UState.Monomorphic_entry Univ.ContextSet.empty, Names.Id.Map.empty) in - ignore (DeclareInd.declare_mutual_inductive_with_eliminations mind names []); + let primitive_expected = + match mind.mind_entry_record with + | Some (Some _) -> true + | _ -> false + in + let ind_kn = DeclareInd.declare_mutual_inductive_with_eliminations ~primitive_expected mind names [] in + if primitive_expected + then begin + let open Record.Internal in + let dflt_pf = { pf_coercion = false; pf_instance = false; pf_priority = None; pf_locality = OptDefault; pf_canonical = false; pf_reversible = false} in + let decl_projs i oie = + let ind = (ind_kn, i) in + let univs = (Entries.Monomorphic_entry, Names.Id.Map.empty) in + let inhabitant_id = List.hd oie.mind_entry_consnames in + let fields, _ = Term.decompose_prod_assum (List.hd oie.mind_entry_lc) in + let fieldimpls = List.map (fun _ -> []) fields in + let pfs = List.map (fun _ -> dflt_pf) fields in + let projections = Record.Internal.declare_projections ind univs ~kind:Decls.Definition inhabitant_id pfs fieldimpls fields in + let struc = Structures.Structure.make (Global.env()) ind projections in + Record.Internal.declare_structure_entry struc + in + List.iteri decl_projs mind.mind_entry_inds + end; evm let not_in_tactic s = diff --git a/template-coq/src/tm_util.ml b/template-coq/src/tm_util.ml index cd20914dd..0a798f01e 100644 --- a/template-coq/src/tm_util.ml +++ b/template-coq/src/tm_util.ml @@ -310,6 +310,6 @@ type ('term, 'nat, 'ident, 'name, 'quoted_sort, 'cast_kind, 'kername, 'inductive | ACoq_tProj of 'projection * 'term | ACoq_tFix of ('term, 'name, 'nat) amfixpoint * 'nat | ACoq_tCoFix of ('term, 'name, 'nat) amfixpoint * 'nat - (* | ACoq_tInt of 'int63 *) - (* | ACoq_tFloat of 'float64 *) + | ACoq_tInt of 'int63 + | ACoq_tFloat of 'float64 diff --git a/template-coq/theories/Ast.v b/template-coq/theories/Ast.v index 0f8aeda2d..ed4177f9f 100644 --- a/template-coq/theories/Ast.v +++ b/template-coq/theories/Ast.v @@ -415,10 +415,9 @@ Inductive term : Type := (discr:term) (branches : list (branch term)) | tProj (proj : projection) (t : term) | tFix (mfix : mfixpoint term) (idx : nat) -| tCoFix (mfix : mfixpoint term) (idx : nat). -(* Not supported yet *) -(* | tInt (i : Int63.int) *) -(* | tFloat (f : PrimFloat.float). *) +| tCoFix (mfix : mfixpoint term) (idx : nat) +| tInt (i : PrimInt63.int) +| tFloat (f : PrimFloat.float). (** This can be used to represent holes, that, when unquoted, turn into fresh existential variables. The fresh evar will depend on the whole context at this point in the term, despite the empty instance. @@ -557,8 +556,8 @@ Fixpoint noccur_between k n (t : term) : bool := #[global] Instance subst_instance_constr : UnivSubst term := fix subst_instance_constr u c {struct c} : term := match c with - | tRel _ | tVar _ => c - (* | tInt _ | tFloat _ => c *) + | tRel _ | tVar _ => c + | tInt _ | tFloat _ => c | tEvar ev args => tEvar ev (List.map (subst_instance_constr u) args) | tSort s => tSort (subst_instance_univ u s) | tConst c u' => tConst c (subst_instance_instance u u') diff --git a/template-coq/theories/AstUtils.v b/template-coq/theories/AstUtils.v index 48083d574..bb3fba025 100644 --- a/template-coq/theories/AstUtils.v +++ b/template-coq/theories/AstUtils.v @@ -1,19 +1,12 @@ (* For primitive integers and floats *) From Coq Require Numbers.Cyclic.Int63.Uint63 Floats.PrimFloat. (* Distributed under the terms of the MIT license. *) -From MetaCoq.Template Require Import utils BasicAst Ast Environment monad_utils. +From MetaCoq.Template Require Import utils BasicAst Primitive Ast Environment monad_utils. Require Import ssreflect ssrbool. Require Import ZArith. (** Raw term printing *) -Definition string_of_prim_int (i:Uint63.int) : string := - (* Better? DecimalString.NilZero.string_of_uint (BinNat.N.to_uint (BinInt.Z.to_N (Uint63.to_Z i))). ? *) - string_of_Z (Numbers.Cyclic.Int63.Uint63.to_Z i). - -Definition string_of_float (f : PrimFloat.float) := - "". - Module string_of_term_tree. Import bytestring.Tree. Infix "^" := append. @@ -71,8 +64,8 @@ Module string_of_term_tree. ^ string_of_term c ^ ")" | tFix l n => "Fix(" ^ (string_of_list (string_of_def string_of_term) l) ^ "," ^ string_of_nat n ^ ")" | tCoFix l n => "CoFix(" ^ (string_of_list (string_of_def string_of_term) l) ^ "," ^ string_of_nat n ^ ")" - (* | tInt i => "Int(" ^ string_of_prim_int i ^ ")" - | tFloat f => "Float(" ^ string_of_float f ^ ")" *) + | tInt i => "Int(" ^ string_of_prim_int i ^ ")" + | tFloat f => "Float(" ^ string_of_float f ^ ")" end. End string_of_term_tree. @@ -192,7 +185,7 @@ Fixpoint remove_arity (n : nat) (t : term) : term := | O => t | S n => match t with | tProd _ _ B => remove_arity n B - | _ => t (* todo *) + | _ => t (* TODO *) end end. @@ -258,7 +251,7 @@ Fixpoint strip_casts t := let mfix' := List.map (map_def strip_casts strip_casts) mfix in tCoFix mfix' idx | tRel _ | tVar _ | tSort _ | tConst _ _ | tInd _ _ | tConstruct _ _ _ => t - (* | tInt _ | tFloat _ => t *) + | tInt _ | tFloat _ => t end. Fixpoint decompose_prod_assum (Γ : context) (t : term) : context * term := diff --git a/template-coq/theories/Checker.v b/template-coq/theories/Checker.v index 593cd815e..cc20522e9 100644 --- a/template-coq/theories/Checker.v +++ b/template-coq/theories/Checker.v @@ -614,25 +614,6 @@ Definition check_conv `{checker_flags} {F:Fuel} := check_conv_gen Conv. Definition is_graph_of_global_env_ext `{checker_flags} Σ G := is_graph_of_uctx G (global_ext_uctx Σ). -Lemma conv_spec : forall `{checker_flags} {F:Fuel} Σ G Γ t u, - is_graph_of_global_env_ext Σ G -> - Σ ;;; Γ |- t = u <~> check_conv (fst Σ) G Γ t u = Checked (). -Proof. - intros. todo "Checker.conv_spec". -Defined. - -Lemma cumul_spec : forall `{checker_flags} {F:Fuel} Σ G Γ t u, - is_graph_of_global_env_ext Σ G -> - Σ ;;; Γ |- t <= u <~> check_conv_leq (fst Σ) G Γ t u = Checked (). -Proof. - intros. todo "Checker.cumul_spec". -Defined. - -Lemma reduce_cumul : - forall `{checker_flags} Σ Γ n t, Σ ;;; Γ |- try_reduce (fst Σ) Γ n t <= t. -Proof. intros. todo "Checker.reduce_cumul". Defined. - - Section Typecheck. Context {F : Fuel}. Context (Σ : global_env). @@ -818,7 +799,7 @@ Section Typecheck. | None => raise (IllFormedFix mfix n) end - (* | tInt _ | tFloat _ => raise (NotSupported "primitive types") *) + | tInt _ | tFloat _ => raise (NotSupported "primitive types") end. Definition check (Γ : context) (t : term) (ty : term) : typing_result unit := @@ -911,27 +892,27 @@ Section Checker. (fun ctr => wGraph.EdgeSet.add (edge_of_constraint ctr)) ctrs G.1.2, G.2). - Fixpoint check_wf_declarations (univs : ContextSet.t) (G : universes_graph) (g : global_declarations) + Fixpoint check_wf_declarations (univs : ContextSet.t) (retro : Retroknowledge.t) (G : universes_graph) (g : global_declarations) : EnvCheck () := match g with | [] => ret tt | g :: env => - check_wf_declarations univs G env ;; - check_wf_decl {| universes := univs; declarations := env |} G g.1 g.2 ;; + check_wf_declarations univs retro G env ;; + check_wf_decl {| universes := univs; declarations := env; retroknowledge := retro |} G g.1 g.2 ;; check_fresh g.1 env ;; ret tt end. Definition typecheck_program (p : program) : EnvCheck term := let Σ := fst p in - let (univs, decls) := (Σ.(universes), Σ.(declarations)) in + let '(univs, decls, retro) := (Σ.(universes), Σ.(declarations), Σ.(retroknowledge)) in match gc_of_constraints (snd univs) with | None => EnvError (IllFormedDecl "toplevel" (UnsatisfiableConstraints univs.2)) | Some ctrs => let G := add_gc_constraints ctrs init_graph in if wGraph.is_acyclic G then - check_wf_declarations univs G decls ;; + check_wf_declarations univs retro G decls ;; infer_term Σ G (snd p) else EnvError (IllFormedDecl "toplevel" (UnsatisfiableConstraints univs.2)) diff --git a/template-coq/theories/Constants.v b/template-coq/theories/Constants.v index 54c03a215..3a5d7783d 100644 --- a/template-coq/theories/Constants.v +++ b/template-coq/theories/Constants.v @@ -115,7 +115,6 @@ Register MetaCoq.Template.Universes.PropLevel.lProp as metacoq.ast.level.lprop. Register MetaCoq.Template.Universes.PropLevel.lSProp as metacoq.ast.level.lsprop. Register MetaCoq.Template.Universes.Level.lzero as metacoq.ast.level.lzero. Register MetaCoq.Template.Universes.Level.Var as metacoq.ast.level.Var. -(* FIXME*) Register MetaCoq.Template.Universes.Universe.lType as metacoq.ast.levelexpr.npe. Register MetaCoq.Template.Universes.LevelExprSet.Mkt as metacoq.ast.levelexprset.mkt. @@ -176,8 +175,8 @@ Register MetaCoq.Template.Ast.tCase as metacoq.ast.tCase. Register MetaCoq.Template.Ast.tProj as metacoq.ast.tProj. Register MetaCoq.Template.Ast.tFix as metacoq.ast.tFix. Register MetaCoq.Template.Ast.tCoFix as metacoq.ast.tCoFix. -(* Register MetaCoq.Template.Ast.tInt as metacoq.ast.tInt. -Register MetaCoq.Template.Ast.tFloat as metacoq.ast.tFloat. *) +Register MetaCoq.Template.Ast.tInt as metacoq.ast.tInt. +Register MetaCoq.Template.Ast.tFloat as metacoq.ast.tFloat. (* Local and global declarations *) Register MetaCoq.Template.Ast.parameter_entry as metacoq.ast.parameter_entry. @@ -197,7 +196,6 @@ Register MetaCoq.Template.Ast.Build_one_inductive_entry as metacoq.ast.Build_one Register MetaCoq.Template.Ast.mutual_inductive_entry as metacoq.ast.mutual_inductive_entry. Register MetaCoq.Template.Ast.Build_mutual_inductive_entry as metacoq.ast.Build_mutual_inductive_entry. -(* FIXME, now polymorphic *) Register MetaCoq.Template.BasicAst.context_decl as metacoq.ast.context_decl. Register MetaCoq.Template.BasicAst.mkdecl as metacoq.ast.mkdecl. Register MetaCoq.Template.Ast.Env.context as metacoq.ast.context. @@ -216,7 +214,8 @@ Register MetaCoq.Template.Ast.Env.Build_constant_body as metacoq.ast.Build_const Register MetaCoq.Template.Ast.Env.global_decl as metacoq.ast.global_decl. Register MetaCoq.Template.Ast.Env.ConstantDecl as metacoq.ast.ConstantDecl. Register MetaCoq.Template.Ast.Env.InductiveDecl as metacoq.ast.InductiveDecl. -Register MetaCoq.Template.Ast.Env.Build_global_env as metacoq.ast.Build_global_env. +Register MetaCoq.Template.Environment.Retroknowledge.mk_retroknowledge as metacoq.ast.mk_retroknowledge. +Register MetaCoq.Template.Ast.Env.mk_global_env as metacoq.ast.Build_global_env. Register MetaCoq.Template.Ast.Env.global_env as metacoq.ast.global_env. Register MetaCoq.Template.Ast.Env.global_env_ext as metacoq.ast.global_env_ext. Register MetaCoq.Template.Ast.Env.program as metacoq.ast.program. diff --git a/template-coq/theories/EnvMap.v b/template-coq/theories/EnvMap.v index 4ac31d63b..bfc2f1b3a 100644 --- a/template-coq/theories/EnvMap.v +++ b/template-coq/theories/EnvMap.v @@ -293,7 +293,7 @@ Context {A : Type}. Lemma pos_of_string_cont_inj s s' p : pos_of_string_cont s p = pos_of_string_cont s' p -> s = s'. Proof. induction s; destruct s' => /= //. - Admitted. + Qed. (* TODO *) Fixpoint pos_of_dirpath_cont (d : dirpath) (cont : positive) : positive := match d with @@ -324,7 +324,7 @@ Context {A : Type}. induction a; destruct m => /= //. cbn. - Admitted. + Qed. (* TODO *) Definition empty : t := PTree.empty _. diff --git a/template-coq/theories/Environment.v b/template-coq/theories/Environment.v index cdcb8e6cb..0ebd894c5 100644 --- a/template-coq/theories/Environment.v +++ b/template-coq/theories/Environment.v @@ -1,6 +1,6 @@ (* Distributed under the terms of the MIT license. *) -From Coq Require Import ssreflect ssrfun Morphisms Setoid. -From MetaCoq.Template Require Import utils BasicAst. +From Coq Require Import ssreflect ssrbool ssrfun Morphisms Setoid. +From MetaCoq.Template Require Import utils BasicAst Primitive. From MetaCoq.Template Require Import Universes. Module Type Term. @@ -25,6 +25,32 @@ Module Type Term. Notation lift0 n := (lift n 0). End Term. +Module Retroknowledge. + + Record t := mk_retroknowledge { + retro_int63 : option kername; + retro_float64 : option kername; + }. + + Definition empty := {| retro_int63 := None; retro_float64 := None |}. + + Definition extends (x y : t) := + option_extends x.(retro_int63) y.(retro_int63) /\ + option_extends x.(retro_float64) y.(retro_float64). + Existing Class extends. + + #[global] Instance extends_refl x : extends x x. + Proof. + split; apply option_extends_refl. + Qed. + + #[global] Instance extends_trans : RelationClasses.Transitive Retroknowledge.extends. + Proof. + intros x y z [] []; split; cbn; now etransitivity; tea. + Qed. + +End Retroknowledge. + Module Environment (T : Term). Import T. @@ -299,23 +325,31 @@ Module Environment (T : Term). Definition global_declarations := list (kername * global_decl). - Record global_env := + Record global_env := mk_global_env { universes : ContextSet.t; - declarations : global_declarations }. - + declarations : global_declarations; + retroknowledge : Retroknowledge.t }. + Coercion universes : global_env >-> ContextSet.t. Definition empty_global_env := {| universes := ContextSet.empty; - declarations := [] |}. + declarations := []; + retroknowledge := Retroknowledge.empty |}. Definition add_global_decl Σ decl := {| universes := Σ.(universes); - declarations := decl :: Σ.(declarations) |}. + declarations := decl :: Σ.(declarations); + retroknowledge := Σ.(retroknowledge) |}. - Lemma eta_global_env Σ : Σ = {| universes := Σ.(universes); declarations := Σ.(declarations) |}. + Lemma eta_global_env Σ : Σ = {| universes := Σ.(universes); declarations := Σ.(declarations); + retroknowledge := Σ.(retroknowledge) |}. Proof. now destruct Σ. Qed. + Definition set_declarations Σ decls := + {| universes := Σ.(universes); + declarations := decls; + retroknowledge := Σ.(retroknowledge) |}. Fixpoint lookup_global (Σ : global_declarations) (kn : kername) : option global_decl := match Σ with @@ -328,12 +362,14 @@ Module Environment (T : Term). Definition lookup_env (Σ : global_env) (kn : kername) := lookup_global Σ.(declarations) kn. Definition extends (Σ Σ' : global_env) := - Σ.(universes) ⊂_cs Σ'.(universes) × - ∑ Σ'', Σ'.(declarations) = Σ'' ++ Σ.(declarations). + [× Σ.(universes) ⊂_cs Σ'.(universes), + ∑ Σ'', Σ'.(declarations) = Σ'' ++ Σ.(declarations) & + Retroknowledge.extends Σ.(retroknowledge) Σ'.(retroknowledge)]. Definition extends_decls (Σ Σ' : global_env) := - Σ.(universes) = Σ'.(universes) × - ∑ Σ'', Σ'.(declarations) = Σ'' ++ Σ.(declarations). + [× Σ.(universes) = Σ'.(universes), + ∑ Σ'', Σ'.(declarations) = Σ'' ++ Σ.(declarations) & + Σ.(retroknowledge) = Σ'.(retroknowledge)]. Existing Class extends. Existing Class extends_decls. @@ -341,20 +377,31 @@ Module Environment (T : Term). #[global] Instance extends_decls_extends Σ Σ' : extends_decls Σ Σ' -> extends Σ Σ'. Proof. intros []. split => //. - rewrite e. split; [lsets|csets]. + rewrite e. split; [lsets|csets]. rewrite e0. apply Retroknowledge.extends_refl. Qed. #[global] Instance extends_decls_refl : CRelationClasses.Reflexive extends_decls. - Proof. red. intros x. now split => //; exists []. Qed. + Proof. red. intros x. split => //; try exists [] => //. Qed. Lemma extends_refl : CRelationClasses.Reflexive extends. - Proof. red. intros x. split; [apply incl_cs_refl | now exists []]. Qed. + Proof. red. intros x. split; [apply incl_cs_refl | now exists [] | apply Retroknowledge.extends_refl]. Qed. (* easy prefers this to the local hypotheses, which is annoying #[global] Instance extends_refl : CRelationClasses.Reflexive extends. Proof. apply extends_refl. Qed. *) + + Definition primitive_constant (Σ : global_env) (p : prim_tag) : option kername := + match p with + | primInt => Σ.(retroknowledge).(Retroknowledge.retro_int63) + | primFloat => Σ.(retroknowledge).(Retroknowledge.retro_float64) + end. + Definition primitive_invariants (cdecl : constant_body) := + ∑ s, [/\ cdecl.(cst_type) = tSort s, cdecl.(cst_body) = None & + cdecl.(cst_universes) = Monomorphic_ctx]. + + (** A context of global declarations + global universe constraints, i.e. a global environment *) diff --git a/template-coq/theories/EnvironmentTyping.v b/template-coq/theories/EnvironmentTyping.v index 336cbc254..859f77fa1 100644 --- a/template-coq/theories/EnvironmentTyping.v +++ b/template-coq/theories/EnvironmentTyping.v @@ -1,6 +1,6 @@ (* Distributed under the terms of the MIT license. *) -From Coq Require Import ssreflect. -From MetaCoq.Template Require Import config utils BasicAst Universes Environment. +From Coq Require Import ssreflect ssrbool. +From MetaCoq.Template Require Import config utils BasicAst Universes Environment Primitive. From Equations Require Import Equations. Module Lookup (T : Term) (E : EnvironmentSig T). @@ -1149,15 +1149,15 @@ Module GlobalMaps (T: Term) (E: EnvironmentSig T) (TU : TermUtils T E) (ET: EnvT Definition fresh_global (s : kername) (g : global_declarations) : Prop := Forall (fun g => g.1 <> s) g. - Inductive on_global_decls (univs : ContextSet.t) : global_declarations -> Type := - | globenv_nil : on_global_decls univs [] + Inductive on_global_decls (univs : ContextSet.t) (retro : Retroknowledge.t): global_declarations -> Type := + | globenv_nil : on_global_decls univs retro [] | globenv_decl Σ kn d : - on_global_decls univs Σ -> + on_global_decls univs retro Σ -> fresh_global kn Σ -> let udecl := universes_decl_of_decl d in on_udecl univs udecl -> - on_global_decl ({| universes := univs; declarations := Σ |}, udecl) kn d -> - on_global_decls univs (Σ ,, (kn, d)). + on_global_decl (mk_global_env univs Σ retro, udecl) kn d -> + on_global_decls univs retro (Σ ,, (kn, d)). Derive Signature for on_global_decls. Definition on_global_univs (c : ContextSet.t) := @@ -1168,7 +1168,7 @@ Module GlobalMaps (T: Term) (E: EnvironmentSig T) (TU : TermUtils T E) (ET: EnvT consistent cstrs. Definition on_global_env (g : global_env) : Type := - on_global_univs g.(universes) × on_global_decls g.(universes) g.(declarations). + on_global_univs g.(universes) × on_global_decls g.(universes) g.(retroknowledge) g.(declarations). Definition on_global_env_ext (Σ : global_env_ext) := on_global_env Σ.1 × on_udecl Σ.(universes) Σ.2. @@ -1226,10 +1226,10 @@ Module GlobalMaps (T: Term) (E: EnvironmentSig T) (TU : TermUtils T E) (ET: EnvT forall Σ, on_global_env Pcmp P Σ -> on_global_env Pcmp Q Σ. Proof. intros X Σ [cu IH]. split; auto. - revert cu IH; generalize (universes Σ) as univs, (declarations Σ). clear Σ. + revert cu IH; generalize (universes Σ) as univs, (retroknowledge Σ) as retro, (declarations Σ). clear Σ. induction g; intros; auto. constructor; auto. depelim IH. specialize (IHg cu IH). constructor; auto. - pose proof (globenv_decl _ _ _ _ _ _ IH f o). + pose proof (globenv_decl _ _ _ _ _ _ _ IH f o). assert (X' := fun Γ t T => X ({| universes := univs; declarations := _ |}, udecl) Γ t T (cu, IH) (cu, IHg)); clear X. rename X' into X. @@ -1342,7 +1342,7 @@ Module DeclarationTyping (T : Term) (E : EnvironmentSig T) (TU : TermUtils T E) unfold on_global_env in *. intros X [hu X0]. split; auto. simpl in *. destruct wfΣ as [cu wfΣ]. revert cu wfΣ. - revert X0. generalize (universes Σ) as univs, (declarations Σ). clear hu Σ. + revert X0. generalize (universes Σ) as univs, (retroknowledge Σ) as retro, (declarations Σ). clear hu Σ. induction 1; constructor; auto. { depelim wfΣ. eauto. } depelim wfΣ. specialize (IHX0 cu wfΣ). diff --git a/template-coq/theories/EtaExpand.v b/template-coq/theories/EtaExpand.v index 04a77ca1c..aaf301a1d 100644 --- a/template-coq/theories/EtaExpand.v +++ b/template-coq/theories/EtaExpand.v @@ -18,7 +18,9 @@ From MetaCoq.Template Require Export LiftSubst (* Lifting and substitution for terms *) UnivSubst (* Substitution of universe instances *) Typing (* Typing judgment *) - config (* Typing configuration *). + config (* Typing configuration *) + TemplateEnvMap (* Efficient lookup table *) + TemplateProgram. Open Scope nat. @@ -28,7 +30,7 @@ Import Template.Ast. Import ListNotations. Section Eta. - Context (Σ : global_declarations). + Context (Σ : GlobalEnvMap.t). (* Fixpoint remove_top_prod (t : Ast.term) (n : nat) := @@ -59,20 +61,12 @@ Section Eta. fold_right (fun d b => Ast.tLambda d.(decl_name) d.(decl_type) b) (mkApps (lift0 needed t) (prev_args ++ eta_args)) remaining_subst. Definition eta_constructor (ind : inductive) c u args := - match lookup_global Σ ind.(inductive_mind) with - | Some (InductiveDecl mind) => - match nth_error mind.(ind_bodies) ind.(inductive_ind) with - | Some idecl => - match nth_error idecl.(ind_ctors) c with - | Some cdecl => - let ty := (type_of_constructor mind cdecl (ind, c) u) in - let n := (ind_npars mind + context_assumptions (cstr_args cdecl)) in - Some (eta_single (Ast.tConstruct ind c u) args ty n) - | _ => None - end - | _ => None - end - | _ => None + match GlobalEnvMap.lookup_constructor Σ ind c with + | Some (mdecl, idecl, cdecl) => + let ty := (type_of_constructor mdecl cdecl (ind, c) u) in + let n := (ind_npars mdecl + context_assumptions (cstr_args cdecl)) in + Some (eta_single (Ast.tConstruct ind c u) args ty n) + | _ => None end. Definition eta_fixpoint (def : mfixpoint term) (i : nat) d (args : list term) := @@ -145,6 +139,7 @@ Section Eta. ++ string_of_kername ind.(inductive_mind)) end | tCast t1 k t2 => tCast (eta_expand Γ t1) k (eta_expand Γ t2) + | tInt _ | tFloat _ => t end. End Eta. @@ -209,21 +204,23 @@ Definition eta_minductive_decl Σ mdecl := ind_universes := mdecl.(ind_universes); ind_variance := mdecl.(ind_variance); |}. -Definition eta_global_declaration (Σ : global_declarations) decl : global_decl := +Definition eta_global_declaration (Σ : GlobalEnvMap.t) decl : global_decl := match decl with | ConstantDecl cb => ConstantDecl (eta_global_decl Σ cb) | InductiveDecl idecl => InductiveDecl (eta_minductive_decl Σ idecl) end. -Fixpoint eta_global_declarations (Σ : global_declarations) := - match Σ with - | [] => [] - | (kn, decl) :: Σ => (kn, eta_global_declaration Σ decl) :: eta_global_declarations Σ - end. +Definition eta_global_declarations (Σ : GlobalEnvMap.t) (decls : global_declarations) := + map (on_snd (eta_global_declaration Σ)) decls. -Definition eta_expand_global_env (Σ : global_env) := - {| universes := Σ.(universes); declarations := eta_global_declarations Σ.(declarations) |}. +Definition eta_expand_global_env (Σ : GlobalEnvMap.t) : global_env := + {| universes := Σ.(universes); declarations := eta_global_declarations Σ Σ.(declarations); + retroknowledge := Σ.(retroknowledge) |}. +Definition eta_expand_program (p : template_program_env) : Ast.Env.program := + let Σ' := eta_expand_global_env p.1 in + (Σ', eta_expand p.1 [] p.2). + (* Inductive tree := T : list tree -> tree. Fixpoint tmap (f : tree -> tree) (t : tree) := match t with T l => T (map (tmap f) l) end. @@ -295,7 +292,9 @@ Inductive expanded (Γ : list nat): term -> Prop := declared_constructor Σ (ind, c) mind idecl cdecl -> #|args| >= (ind_npars mind + context_assumptions (cstr_args cdecl)) -> Forall (expanded Γ) args -> - expanded Γ (tApp (tConstruct ind c u) args). + expanded Γ (tApp (tConstruct ind c u) args) +| expanded_tInt i : expanded Γ (tInt i) +| expanded_tFloat f : expanded Γ (tFloat f). End expanded. @@ -357,9 +356,12 @@ forall (Σ : global_env) (P : list nat -> term -> Prop), #|args| >= ind_npars mind + context_assumptions (cstr_args cdecl) -> Forall (expanded Σ Γ) args -> Forall (P Γ) args -> - P Γ(tApp (tConstruct ind c u) args)) -> forall Γ, forall t : term, expanded Σ Γ t -> P Γ t. + P Γ(tApp (tConstruct ind c u) args)) -> +(forall Γ i, P Γ (tInt i)) -> +(forall Γ f, P Γ (tFloat f)) -> + forall Γ, forall t : term, expanded Σ Γ t -> P Γ t. Proof. - intros Σ P HRel HRel_app HVar HEvar HSort HCast HProd HLamdba HLetIn HApp HConst HInd HConstruct HCase HProj HFix HCoFix HConstruct_app. + intros Σ P HRel HRel_app HVar HEvar HSort HCast HProd HLamdba HLetIn HApp HConst HInd HConstruct HCase HProj HFix HCoFix HConstruct_app Hint Hfloat. fix f 3. intros Γ t Hexp. destruct Hexp; eauto. all: match goal with [H : Forall _ _ |- _] => let all := fresh "all" in rename H into all end. @@ -409,22 +411,18 @@ Definition expanded_decl Σ d := | Ast.Env.InductiveDecl idecl => expanded_minductive_decl Σ idecl end. -Inductive expanded_global_declarations (univs : ContextSet.t) : forall (Σ : Ast.Env.global_declarations), Prop := -| expanded_global_nil : expanded_global_declarations univs [] -| expanded_global_cons decl Σ : expanded_global_declarations univs Σ -> - expanded_decl {| Ast.Env.universes := univs; Ast.Env.declarations := Σ |} decl.2 -> - expanded_global_declarations univs (decl :: Σ). +Inductive expanded_global_declarations (univs : ContextSet.t) (retro : Environment.Retroknowledge.t) : forall (Σ : Ast.Env.global_declarations), Prop := +| expanded_global_nil : expanded_global_declarations univs retro [] +| expanded_global_cons decl Σ : expanded_global_declarations univs retro Σ -> + expanded_decl {| Ast.Env.universes := univs; Ast.Env.declarations := Σ; Ast.Env.retroknowledge := retro |} decl.2 -> + expanded_global_declarations univs retro (decl :: Σ). Definition expanded_global_env (g : Ast.Env.global_env) := - expanded_global_declarations g.(Ast.Env.universes) g.(Ast.Env.declarations). + expanded_global_declarations g.(Ast.Env.universes) g.(Ast.Env.retroknowledge) g.(Ast.Env.declarations). Definition expanded_program (p : Ast.Env.program) := expanded_global_env p.1 /\ expanded p.1 [] p.2. -Definition eta_expand_program (p : Ast.Env.program) : Ast.Env.program := - let Σ' := eta_expand_global_env p.1 in - (Σ', eta_expand p.1.(declarations) [] p.2). - Definition isFix_app t := match fst (decompose_app t) with | tFix _ _ => true @@ -781,9 +779,9 @@ Proof. 2:{ replace (S n0 - #|l|) with 0 by lia. cbn. econstructor. } rewrite EE in H4. rewrite seq_app, rev_map_spec, map_app, rev_app_distr in H4. - eapply Forall_app in H4 as []. rewrite Min.min_l. 2: len; lia. + eapply Forall_app in H4 as []. rewrite Nat.min_l. 2: len; lia. rewrite <- EE in H0. - revert H0. len. rewrite !firstn_length, Min.min_l. 2:len;lia. + revert H0. len. rewrite !firstn_length, Nat.min_l. 2:len;lia. rewrite rev_map_spec. intros. rewrite Forall_forall in H0 |- *. intros. specialize (H0 _ H1). rewrite <- in_rev in H1. @@ -923,23 +921,60 @@ Proof. rewrite IHt2. cbn; lia. - rewrite IHt3. cbn. lia. *) +Import EnvMap. + +Definition repr_decls Σg Σ := + forall kn d, lookup_global Σ.(declarations) kn = Some d -> GlobalEnvMap.lookup_env Σg kn = Some d. +Import ssreflect. + +Lemma repr_lookup_constructor {Σg Σ} : + repr_decls Σg Σ -> + forall ind idx r, lookup_constructor Σ ind idx = Some r -> GlobalEnvMap.lookup_constructor Σg ind idx = Some r. +Proof. + intros hrepr ind idx r. + rewrite /lookup_constructor /lookup_inductive /lookup_minductive /lookup_env. + destruct lookup_global eqn:hl => //. + apply hrepr in hl. + rewrite /GlobalEnvMap.lookup_constructor /GlobalEnvMap.lookup_inductive /GlobalEnvMap.lookup_minductive hl //. +Qed. + +Import bytestring.String. + +Local Open Scope bs. + +Lemma constructor_declared {cf : checker_flags} {Σ Γ ind idx u ty} : + Σ ;;; Γ |- tConstruct ind idx u : ty -> + exists r, lookup_constructor Σ ind idx = Some r. +Proof. + intros H; depind H; eauto. + eexists. eapply declared_constructor_lookup in isdecl; tea. +Qed. Lemma eta_expand_expanded {cf : config.checker_flags} {Σ : global_env_ext} Γ Γ' t T : wf Σ -> typing Σ Γ t T -> Forall2 (fun x y => match x with Some (n, t) => y.(decl_type) = t /\ context_assumptions (decompose_prod_assum [] y.(decl_type)).1 >= n | None => True end) Γ' Γ -> - expanded Σ (map (fun x => match x with Some (n, _) => n | None => 0 end ) Γ') (eta_expand Σ.1.(declarations) Γ' t). + forall Σg : GlobalEnvMap.t, repr_decls Σg Σ.1 -> + expanded Σ (map (fun x => match x with Some (n, _) => n | None => 0 end ) Γ') (eta_expand Σg Γ' t). Proof. intros wf Hty. revert Γ'. - eapply @typing_ind_env with (t := t) (Σ := Σ) (P := fun Σ Γ t T => forall Γ', Forall2 (fun (x : option (nat × term)) (y : context_decl) => match x with - | Some (_, t0) => decl_type y = t0 /\ _ - | None => True - end) Γ' Γ -> - expanded Σ (map (fun x : option (nat × term) => match x with - | Some (n, _) => n - | None => 0 - end) Γ') (eta_expand (declarations Σ) Γ' t) - ) (PΓ := fun _ _ _ => True); intros; try now (cbn; eauto). + eapply @typing_ind_env with (t := t) (Σ := Σ) + (P := fun (Σ : global_env_ext) Γ t T => forall Γ', Forall2 (fun (x : option (nat × term)) (y : context_decl) => + match x with + | Some (_, t0) => decl_type y = t0 /\ _ + | None => True + end) Γ' Γ -> + forall Σg, repr_decls Σg Σ.1 -> + expanded Σ (map (fun x : option (nat × term) => + match x with + | Some (n, _) => n + | None => 0 + end) Γ') (eta_expand Σg Γ' t)) + (PΓ := fun _ _ _ => True); + repeat match goal with + | [ |- repr_decls _ _ -> _ ] => intros hrepr + | _ => intro + end; try now (cbn; eauto). - cbn. eapply Forall2_nth_error_Some_r in H1 as (? & ? & ?); eauto. rewrite H1. destruct x as [[] | ]. @@ -947,26 +982,26 @@ Proof. eapply expanded_fold_lambda. rewrite !Nat.sub_0_r. len. rewrite firstn_length. len. destruct n0. - * cbn. econstructor. now rewrite nth_error_map, H1. - * rewrite seq_S,rev_map_spec, map_app, rev_app_distr. subst. - rewrite <- context_assumptions_lift, !Min.min_l; try lia. + * cbn. econstructor. now rewrite nth_error_map H1. + * rewrite seq_S rev_map_spec map_app rev_app_distr. subst. + rewrite <- context_assumptions_lift, !Nat.min_l; try lia. econstructor. - -- rewrite nth_error_app2. 2: rewrite repeat_length; lia. - rewrite repeat_length. replace (S n0 + n - S n0) with n by lia. - now rewrite nth_error_map, H1. + -- rewrite nth_error_app2 repeat_length; try lia. + replace (S n0 + n - S n0) with n by lia. + now rewrite nth_error_map H1. -- len. now rewrite seq_length. -- eapply Forall_forall. intros x [ | (? & <- & [_ ?] % in_seq) % in_rev % in_map_iff]; subst. - all: econstructor; rewrite nth_error_app1; [eapply nth_error_repeat; lia | rewrite repeat_length; lia]. - + econstructor. now rewrite nth_error_map, H1. - - cbn. econstructor. eapply (H1 (up Γ')); econstructor; eauto. - - cbn. econstructor. eauto. eapply (H2 (up Γ')); econstructor; eauto. + all: econstructor; rewrite nth_error_app1; revgoals; [eapply nth_error_repeat; lia | rewrite repeat_length; lia]. + + econstructor. now rewrite nth_error_map H1. + - cbn. econstructor. eapply (H1 (up Γ')); tea; econstructor; eauto. + - cbn. econstructor. eauto. eapply (H2 (up Γ')); tea; econstructor; eauto. - specialize (H _ H2). assert (Forall(fun t : term => expanded Σ0 (map (fun x : option (nat × term) => match x with | Some p => let (n, _) := p in n | None => 0 - end) Γ') (eta_expand Σ0.(declarations) Γ' t)) l). { + end) Γ') (eta_expand Σg Γ' t)) l). { clear H1. clear X. induction X0; econstructor; eauto. } destruct t0; cbn. all: try now eapply expanded_mkApps; [ eauto | solve_all ]. @@ -980,15 +1015,15 @@ Proof. destruct H4. rewrite <- context_assumptions_lift. subst. lia. cbn. eapply expanded_mkApps. constructor. - now rewrite nth_error_map, E; cbn. + now rewrite nth_error_map E; cbn. solve_all. + cbn in H. unfold eta_constructor in *. - destruct lookup_global as [[] | ] eqn:E1; eauto. - destruct nth_error eqn:E2; eauto. - destruct (nth_error (ind_ctors o) idx) eqn:E3; eauto. + specialize (H Σg hrepr). + rewrite GlobalEnvMap.lookup_constructor_spec in H |- *. + destruct lookup_constructor as [[[mdecl idecl] cdecl]| ] eqn:E1; eauto. unfold eta_single in H. eapply expanded_fold_lambda. rewrite Nat.sub_0_r in H. - unfold mkApps in H. destruct (ind_npars m + context_assumptions (cstr_args c)) eqn:EE. + unfold mkApps in H. destruct (ind_npars mdecl + context_assumptions (cstr_args cdecl)) eqn:EE. * cbn in H. inversion H; subst. cbn. simpl_list. destruct l. -- cbn. econstructor; eauto. @@ -996,37 +1031,41 @@ Proof. rewrite lift0_id. setoid_rewrite map_ext. 3: eapply lift0_p. rewrite map_id. eapply Forall_typing_spine_Forall in X0. rewrite <- map_cons. revert X0. generalize (t0 :: l). intros l' X0. - solve_all. eapply H4. solve_all. reflexivity. - * eapply expanded_mkApps_tConstruct. split. split. red. all: eauto. + solve_all. eapply H4; auto. solve_all. reflexivity. + * eapply constructor_declared in X as [[[mdecl' idecl'] cdecl'] hc]. + have h := (repr_lookup_constructor hrepr _ _ _ hc). rewrite GlobalEnvMap.lookup_constructor_spec in h. + rewrite E1 in h. noconf h. + eapply expanded_mkApps_tConstruct. now eapply lookup_constructor_declared. rewrite rev_map_spec. simpl_list. rewrite EE. lia. eapply Forall_typing_spine_Forall in X0. assert ((context_assumptions - (decompose_prod_assum [] (type_of_constructor m c (ind, idx) u)).1) = ind_npars m + context_assumptions (cstr_args c)) as E. { + (decompose_prod_assum [] (type_of_constructor mdecl cdecl (ind, idx) u)).1) = ind_npars mdecl + context_assumptions (cstr_args cdecl)) as E. { eapply decompose_type_of_constructor; eauto. - split. split. red. all: eauto. } + now eapply lookup_constructor_declared. } eapply app_Forall. -- Opaque minus. solve_all. eapply @expanded_lift' with (Γ' := []). 2: reflexivity. reflexivity. 2: reflexivity. len. - { rewrite !firstn_length, !List.skipn_length. len. - rewrite E, EE. lia. + { rewrite !firstn_length !List.skipn_length. len. + rewrite E EE. lia. } cbn. eauto. -- rewrite rev_map_spec. eapply Forall_rev. eapply Forall_forall. intros ? (? & <- & ?) % in_map_iff. econstructor. eapply in_seq in H4 as [_ H4]. - len. rewrite nth_error_app1. 2: len. - eapply nth_error_repeat. cbn in *. - rewrite !firstn_length, !List.skipn_length. len. rewrite E, EE. + len. rewrite nth_error_app1; len. + rewrite !firstn_length !List.skipn_length. len. rewrite E EE. rewrite map_length in H4. lia. - rewrite !firstn_length, !List.skipn_length. len. rewrite E, EE. + eapply nth_error_repeat. cbn in *. + rewrite !firstn_length !List.skipn_length. len. rewrite E EE. rewrite map_length in H4. lia. - + cbn in H. unfold eta_fixpoint in *. + + specialize (H _ hrepr). + cbn in H. unfold eta_fixpoint in *. rewrite nth_error_map in H |- *. destruct (nth_error mfix idx) eqn:Eid; eauto. cbn in *. eapply expanded_fold_lambda. eapply expanded_mkApps_tFix; fold lift. - 2:{rewrite !nth_error_map, Eid. reflexivity. } + 2:{ rewrite !nth_error_map Eid. cbn. len. reflexivity. } ++ cbn. rewrite <- context_assumptions_lift. eapply wf_fixpoint_rarg; eauto. 2: eapply nth_error_In; eauto. clear - X. depind X; eauto. @@ -1059,12 +1098,12 @@ Proof. f_equal. rewrite !mapi_map. now eapply mapi_ext. } eapply expanded_unlift with (Γ'' := repeat 0 #|l|). 2: now rewrite <- app_assoc. - rewrite simpl_lift. 2:{ len. rewrite !firstn_length, !List.skipn_length. lia. } + rewrite -> simpl_lift. 2:{ len. rewrite !firstn_length !List.skipn_length. lia. } 2:{ len. lia. } eapply apply_expanded. eauto. simpl_list. f_equal. f_equal. ** rewrite !mapi_map. now eapply mapi_ext. - ** rewrite !firstn_length, !List.skipn_length. + ** rewrite !firstn_length !List.skipn_length. rewrite app_assoc. f_equal. rewrite <- repeat_app. f_equal. len. destruct context_assumptions; @@ -1072,15 +1111,15 @@ Proof. ** f_equal. len. lia. ++ eapply Forall_typing_spine_Forall in X0. eapply app_Forall. ** solve_all. eapply @expanded_lift' with (Γ' := []). all: try now reflexivity. 2: eauto. - len. rewrite !firstn_length, !List.skipn_length. + len. rewrite !firstn_length !List.skipn_length. eapply typing_wf_fixpoint in X. eapply wf_fixpoint_rarg in X. 2: eauto. 2: eapply nth_error_In; eauto. len. lia. ** rewrite rev_map_spec. eapply Forall_rev. eapply Forall_forall. intros ? (? & <- & ?) % in_map_iff. econstructor. eapply in_seq in H4 as [_ H4]. autorewrite with len in H4 |- *. - rewrite !firstn_length, !List.skipn_length. - rewrite nth_error_app1. eapply nth_error_repeat. + rewrite !firstn_length !List.skipn_length. + rewrite -> nth_error_app1. eapply nth_error_repeat. -- len. eapply Nat.lt_le_trans. eauto. cbn. eapply typing_wf_fixpoint in X. @@ -1093,55 +1132,57 @@ Proof. lia. ++ destruct l; cbn in *; try congruence. ++ cbn. eauto. - - cbn. pose proof isdecl as isdecl'. destruct isdecl as [[]]. red in H2. - unfold lookup_env in H2. - unfold eta_constructor. unfold fst_ctx in *. cbn in *. rewrite H2, H3, H4. + - cbn. pose proof isdecl as isdecl'. + unfold eta_constructor. + eapply declared_constructor_lookup in isdecl'. + eapply (repr_lookup_constructor hrepr) in isdecl'. rewrite isdecl'. + rewrite GlobalEnvMap.lookup_constructor_spec in isdecl'. eapply expanded_fold_lambda. rewrite Nat.sub_0_r. eapply expanded_mkApps_tConstruct; eauto. - rewrite rev_map_spec. now simpl_list. rewrite rev_map_spec, <- List.map_rev. + rewrite rev_map_spec. now simpl_list. rewrite rev_map_spec -!List.map_rev. eapply Forall_forall. intros ? (? & <- & ?) % in_map_iff. econstructor. - eapply in_rev, in_seq in H5 as [_ ?]. cbn in *. len. + eapply in_rev, in_seq in H2 as [_ ?]. cbn in *. len. rewrite !firstn_length. len. assert ((context_assumptions (decompose_prod_assum [] (type_of_constructor mdecl cdecl (ind, i) u)).1) = ind_npars mdecl + context_assumptions (cstr_args cdecl)) as ->. { eapply decompose_type_of_constructor; eauto. } - rewrite nth_error_app1. now rewrite nth_error_repeat. rewrite repeat_length. lia. + rewrite nth_error_app1. 2:now rewrite nth_error_repeat. rewrite repeat_length. lia. - cbn. econstructor; eauto. * unfold map_branches. solve_all. - clear -X1 H8. + clear -hrepr X1 H8. set (Γ'' := map _ Γ'). cbn. - enough (All (expanded Σ0 Γ'') (map (eta_expand (declarations Σ0) Γ') (pparams p ++ indices))). + enough (All (expanded Σ0 Γ'') (map (eta_expand Σg Γ') (pparams p ++ indices))). now rewrite map_app in X; eapply All_app in X as []. eapply All_map. induction X1. + constructor. - + constructor; auto. eapply t0. solve_all. + + constructor; auto. eapply t1; solve_all; auto. + auto. * solve_all. specialize (b (repeat None #|bcontext y| ++ Γ'))%list. - rewrite map_app, map_repeat in b. eapply b. + rewrite map_app map_repeat in b. eapply b; eauto. eapply Forall2_app; solve_all. assert (#| (case_branch_context_gen (ci_ind ci) mdecl (pparams p) (puinst p) (bcontext y) x)| = #|bcontext y|). { clear - a0. unfold case_branch_context_gen. rewrite map2_length. - rewrite Min.min_l; try lia. eapply All2_length in a0. + rewrite Nat.min_l; try lia. eapply All2_length in a0. unfold inst_case_context. unfold subst_context. unfold subst_instance, subst_instance_context, map_context. - rewrite fold_context_k_length, map_length. unfold aname. lia. + rewrite fold_context_k_length map_length. unfold aname. lia. } revert H9. generalize ((case_branch_context_gen (ci_ind ci) mdecl (pparams p) - (puinst p) (bcontext y) x)). clear. + (puinst p) (bcontext y) x)). clear -hrepr. induction #|bcontext y|; intros []; cbn; intros; try congruence; econstructor; eauto. - - cbn. rewrite nth_error_map, H0. cbn. unfold eta_fixpoint. unfold fst_ctx in *. cbn in *. + - cbn. rewrite nth_error_map H0. cbn. unfold eta_fixpoint. unfold fst_ctx in *. cbn in *. eapply expanded_fold_lambda. assert (#|(decompose_prod (dtype decl)).1.1| = #|(decompose_prod (dtype decl)).1.2|) as E1. { eapply decompose_prod12. } assert (rarg decl < context_assumptions (decompose_prod_assum [] (dtype decl)).1) as E2. { eapply wf_fixpoint_rarg; eauto. now eapply nth_error_In. } eapply expanded_mkApps_tFix. + shelve. - + fold lift. rewrite !nth_error_map, H0. cbn. len. reflexivity. + + fold lift. rewrite !nth_error_map H0. cbn. len. reflexivity. + len. rewrite seq_length. lia. + fold lift. len. assert (Forall (fun x => isLambda (dbody x)) mfix). @@ -1150,11 +1191,11 @@ Proof. { now eapply isLambda_lift, isLambda_eta_expand. } destruct a as (? & ? & ?). destruct a0 as (? & ?). - rewrite !firstn_length. rewrite !Nat.min_l; try lia. + rewrite !firstn_length. rewrite -> !Nat.min_l; try lia. eapply expanded_lift'. - 5: eapply e0. 2: reflexivity. 2: now len. + 5: eapply e0; eauto. 2: reflexivity. 2: now len. 2: now len. - { rewrite map_app. f_equal. rewrite map_rev. f_equal. now rewrite !mapi_map, map_mapi. } + { rewrite map_app. f_equal. rewrite map_rev. f_equal. now rewrite !mapi_map map_mapi. } eapply Forall2_app; solve_all. subst types. unfold Typing.fix_context. eapply All2_rev. eapply All2_mapi. eapply All_All2_refl, Forall_All, Forall_forall. @@ -1166,13 +1207,13 @@ Proof. eapply Forall_forall. intros ? (? & <- & ?) % in_map_iff. econstructor. eapply in_seq in H4 as [_ ?]. cbn in *. len. rewrite !firstn_length. - rewrite nth_error_app1. eapply nth_error_repeat. + rewrite -> nth_error_app1. eapply nth_error_repeat. len; lia. rewrite repeat_length. len; lia. + cbn - [rev_map seq]. rewrite rev_map_spec. cbn. rewrite Nat.sub_0_r. cbn. destruct List.rev; cbn; congruence. - cbn. econstructor; eauto. eapply All_Forall, All_map, All_impl. eapply (All_mix X X0). intros ? ((? & ? & ?) & ? & ?). cbn. specialize (e0 (repeat None #|mfix| ++ Γ'))%list. - rewrite map_app, map_repeat in e0. len. eapply e0. + rewrite map_app map_repeat in e0. len. eapply e0; auto. eapply Forall2_app; eauto. unfold types. assert (#|Typing.fix_context mfix| = #|mfix|). { unfold Typing.fix_context. now len. } revert H4. generalize (Typing.fix_context mfix). clear. @@ -1218,13 +1259,13 @@ Proof. case: eqb_specT => eq //. Qed. -Lemma eta_lookup_global Σ kn decl : - lookup_global Σ kn = Some decl -> - ∑ Σ', lookup_global (eta_global_declarations Σ) kn = Some (eta_global_declaration Σ' decl). +Lemma eta_lookup_global {Σ : GlobalEnvMap.t} kn decl : + lookup_env Σ kn = Some decl -> + lookup_global (eta_global_declarations Σ Σ.(declarations)) kn = Some (eta_global_declaration Σ decl). Proof. move/lookup_lookup_global_env => [] Σ' hl. - exists Σ'. move: hl. - induction Σ; cbn => //. + move: hl. + induction (declarations Σ); cbn => //. destruct a as [kn' []] => /=. case: eqb_spec. intros ->. intros [= <- <-] => //. intros neq. auto. @@ -1232,75 +1273,81 @@ Proof. intros neq. auto. Qed. +Lemma lookup_global_map_on_snd f decls kn : lookup_global (map (on_snd f) decls) kn = option_map f (lookup_global decls kn). +Proof. + induction decls; cbn => //. + case: eqb_spec. + - now intros ->. + - now intros neq. +Qed. + Lemma eta_lookup_global_error Σ ind : - lookup_global (eta_global_declarations Σ) (inductive_mind ind) = None -> - lookup_global Σ (inductive_mind ind) = None. + lookup_global (eta_global_declarations Σ Σ.(declarations)) (inductive_mind ind) = None -> + lookup_global Σ.(declarations) (inductive_mind ind) = None. Proof. - induction Σ; cbn => //. - destruct a as [kn []] => /=. - destruct (eqb_spec (inductive_mind ind) kn) => //. - destruct (eqb_spec (inductive_mind ind) kn) => //. + unfold eta_global_declarations. + rewrite lookup_global_map_on_snd. destruct lookup_global => //. Qed. -Lemma eta_declared_constructor {Σ ind mdecl idecl cdecl} : +Lemma eta_declared_constructor {Σ : GlobalEnvMap.t} {ind mdecl idecl cdecl} : declared_constructor Σ ind mdecl idecl cdecl -> - ∑ Σ', - (* extends_decls Σ' Σ × *) - declared_constructor (eta_expand_global_env Σ) ind (eta_minductive_decl Σ' mdecl) - (eta_inductive_decl Σ' mdecl idecl) (eta_constructor_decl Σ' mdecl cdecl). + declared_constructor (eta_expand_global_env Σ) ind (eta_minductive_decl Σ mdecl) + (eta_inductive_decl Σ mdecl idecl) (eta_constructor_decl Σ mdecl cdecl). Proof. rewrite /declared_constructor. intros [[] ?]. move: H. rewrite /declared_inductive /declared_minductive /lookup_env /=. destruct (lookup_global Σ.(declarations) _) eqn:heq => //. - move: (eta_lookup_global Σ.(declarations) (inductive_mind ind.1) g heq) => [Σ'] hl. - intros [= ->]. exists Σ'. rewrite hl; split => //. + move: (eta_lookup_global (inductive_mind ind.1) g heq) => hl. + intros [= ->]. rewrite hl; split => //. split => //. rewrite nth_error_map H0 //. rewrite nth_error_map H1 //. Qed. -Lemma expanded_env_irrel univs decls Γ t : - let Σ := {| universes := univs; declarations := decls |} in +Import ssreflect ssrbool. + +Definition same_cstr_info Σ Σ' := + forall ind idx mdecl idecl cdecl, + declared_constructor Σ (ind, idx) mdecl idecl cdecl -> + exists mdecl' idecl' cdecl', + [/\ declared_constructor Σ' (ind, idx) mdecl' idecl' cdecl', + mdecl.(ind_npars) = mdecl'.(ind_npars) & + context_assumptions cdecl.(cstr_args) = context_assumptions cdecl'.(cstr_args)]. + +Lemma expanded_env_irrel Σ Σ' Γ t : + same_cstr_info Σ Σ' -> expanded Σ Γ t -> - let Σ' := {| universes := univs; declarations := eta_global_declarations decls |} in expanded Σ' Γ t. Proof. - intros Σ exp Σ'. - move: exp. + intros hrepr. induction 1 using expanded_ind. all: try solve [constructor; auto]. - eapply expanded_tRel_app; tea. - - eapply eta_declared_constructor in H as [Σ'' decl']. - eapply expanded_tConstruct. tea. cbn. - unfold eta_context. - rewrite context_assumptions_fold_context_k_defs //. + - eapply hrepr in H as [mdecl' [idecl' [cdecl' [hdecl hpars hass]]]]. + eapply expanded_tConstruct; tea. lia. - eapply expanded_tFix; tea. solve_all. - - eapply eta_declared_constructor in H as [Σ'' decl']. - eapply expanded_tConstruct_app; tea. cbn. - rewrite context_assumptions_fold_context_k_defs //. + - eapply hrepr in H as [mdecl' [idecl' [cdecl' [hdecl hpars hass]]]]. + eapply expanded_tConstruct_app; tea. cbn. lia. Qed. -Lemma expanded_context_env_irrel univs decls Γ t : - let Σ := {| universes := univs; declarations := decls |} in +Lemma expanded_context_env_irrel Σ Σ' Γ t : + same_cstr_info Σ Σ' -> expanded_context Σ Γ t -> - let Σ' := {| universes := univs; declarations := eta_global_declarations decls |} in expanded_context Σ' Γ t. Proof. - intros Σ exp Σ'. - move: exp. unfold expanded_decl. + unfold expanded_decl. unfold expanded_context. - intros []; split. eapply All_fold_impl; tea; cbn => ?? []; constructor. + intros hrepr []; split. eapply All_fold_impl; tea; cbn => ?? []; constructor. eapply expanded_env_irrel; tea. Qed. -Lemma expanded_decl_env_irrel univs decls t : - let Σ := {| universes := univs; declarations := decls |} in +Lemma expanded_decl_env_irrel (Σ Σ' : global_env) t : + same_cstr_info Σ Σ' -> expanded_decl Σ t -> - let Σ' := {| universes := univs; declarations := eta_global_declarations decls |} in expanded_decl Σ' t. Proof. - intros Σ exp Σ'. - move: exp. unfold expanded_decl. + intros hrepr. + unfold expanded_decl. destruct t => //. intros []. constructor. destruct (cst_body c) => //. cbn in *. @@ -1333,29 +1380,51 @@ Qed. Existing Class Typing.wf_ext. -Lemma eta_expand_context {cf} {Σ ctx} {wfΣ : Typing.wf_ext Σ} : - on_context (lift_typing typing) Σ ctx -> - expanded_context Σ [] (eta_context Σ.(declarations) 0 ctx). +Definition global_env_ext_map := GlobalEnvMap.t × universes_decl. + +Definition global_env_ext_map_global_env_map (Σgext : global_env_ext_map) : GlobalEnvMap.t := Σgext.1. + +Definition global_env_ext_map_global_env_ext (Σgext : global_env_ext_map) : global_env_ext := + (Σgext.1.(GlobalEnvMap.env), Σgext.2). + +Coercion global_env_ext_map_global_env_map : global_env_ext_map >-> GlobalEnvMap.t. +Coercion global_env_ext_map_global_env_ext : global_env_ext_map >-> global_env_ext. + +Lemma repr_global_env_map (Σ : GlobalEnvMap.t) : repr_decls Σ Σ. +Proof. + destruct Σ as []. + unfold repr_decls. + intros kn d. + cbn. rewrite GlobalEnvMap.lookup_env_spec. now cbn. +Qed. + +Lemma eta_expand_context {cf} {Σ} {Σg : global_env_ext_map} {ctx} {wfΣ : Typing.wf_ext Σ} : + repr_decls Σg Σ -> + on_context (lift_typing typing) Σ ctx -> + expanded_context Σ [] (eta_context Σg 0 ctx). Proof. unfold on_context. - red. intros wf. sq. + red. intros hrepr wf. sq. rewrite /eta_context. eapply All_fold_fold_context_k_defs. induction wf; cbn; auto; try constructor; auto. cbn. constructor. cbn. constructor. len. rewrite app_nil_r. - red in t0, t1. - forward (eta_expand_expanded (Σ := Σ) Γ (repeat None #|Γ|) _ _ wfΣ t1). + red in t1, t2. + forward (eta_expand_expanded (Σ := Σ) Γ (repeat None #|Γ|) _ _ wfΣ t2). clear. induction Γ; cbn; constructor; auto. + intros. specialize (H _ hrepr). + move: H. now rewrite map_repeat. Qed. -Lemma eta_expand_context_sorts {cf} {Σ ctx ctx' cunivs} {wfΣ : Typing.wf_ext Σ} : +Lemma eta_expand_context_sorts {cf} {Σ} {Σg : global_env_ext_map} {ctx ctx' cunivs} {wfΣ : Typing.wf_ext Σ} : + repr_decls Σg Σ -> sorts_local_ctx (lift_typing typing) Σ ctx ctx' cunivs -> - expanded_context Σ (repeat 0 #|ctx|) (eta_context Σ.(declarations) #|ctx| ctx'). + expanded_context Σ (repeat 0 #|ctx|) (eta_context Σg #|ctx| ctx'). Proof. - intros hs. constructor. + intros hrepr hs. constructor. eapply All_fold_fold_context_k_defs. cbn. len. induction ctx' in hs, cunivs |- *; cbn; auto. constructor; eauto. @@ -1363,10 +1432,11 @@ Proof. specialize (IHctx' cunivs hs). constructor; auto. constructor. len. rewrite repeat_app. destruct p as [[s Hs] ?]. - epose proof (eta_expand_expanded (Σ := Σ) _ (repeat None (#|ctx'| + #|ctx|)) _ _ wfΣ t). + epose proof (eta_expand_expanded (Σ := Σ) _ (repeat None (#|ctx'| + #|ctx|)) _ _ wfΣ t0). forward H. clear. rewrite -app_context_length. induction (_ ,,, _); cbn; constructor; auto. + specialize (H _ hrepr). now rewrite map_repeat !repeat_app in H. destruct cunivs => //. destruct hs. constructor; eauto. constructor. @@ -1376,17 +1446,19 @@ Lemma eta_context_length g n ctx : #|eta_context g n ctx| = #|ctx|. Proof. now rewrite /eta_context; len. Qed. #[export] Hint Rewrite @eta_context_length : len. -Lemma eta_expand_global_decl_expanded {cf : checker_flags} g kn d : - Typing.wf_ext g -> - on_global_decl cumul_gen (lift_typing typing) g kn d -> - expanded_decl g (eta_global_declaration g.(declarations) d). +Lemma eta_expand_global_decl_expanded {cf : checker_flags} (Σ : global_env_ext) (Σg : global_env_ext_map) kn d : + repr_decls Σg Σ -> + Typing.wf_ext Σ -> + on_global_decl cumul_gen (lift_typing typing) Σ kn d -> + expanded_decl Σ (eta_global_declaration Σg d). Proof. - intros wf ond. + intros hrepr wf ond. destruct d; cbn in *. - unfold on_constant_decl in ond. destruct c as [na body ty rel]; cbn in *. destruct body. constructor => //; cbn. - apply (eta_expand_expanded (Σ := g) [] [] t na wf ond). constructor. + apply (eta_expand_expanded (Σ := Σ) [] [] t0 na wf ond). constructor. + apply hrepr. destruct ond as [s Hs]. constructor => //. - destruct ond as [onI onP onN onV]. constructor. cbn. @@ -1399,27 +1471,114 @@ Proof. eapply All2_All_left; tea; cbn => cdecl cunivs onc. constructor. cbn. len. pose proof onc.(on_cargs). - eapply eta_expand_context_sorts in X0. now len in X0. + eapply eta_expand_context_sorts in X0. now len in X0. exact hrepr. len. len. pose proof onc.(on_ctype). destruct X0. - epose proof (eta_expand_expanded (Σ := g) _ (repeat None #|ind_bodies m|) _ _ wf t). + epose proof (eta_expand_expanded (Σ := Σ) _ (repeat None #|ind_bodies m|) _ _ wf t0). forward H. rewrite -arities_context_length. clear. induction (arities_context _); constructor; auto. + specialize (H _ hrepr). now rewrite map_repeat in H. Qed. -Lemma eta_expand_global_env_expanded {cf : checker_flags} g : - Typing.wf g -> - expanded_global_env (eta_expand_global_env g). +Lemma eta_context_assumptions Σ n Γ : context_assumptions Γ = context_assumptions (eta_context Σ n Γ). +Proof. + now rewrite /eta_context context_assumptions_fold_context_k_defs. +Qed. + +Lemma same_cstr_info_eta (Σ : global_env) (Σg: GlobalEnvMap.t) : + same_cstr_info Σ + {| universes := Σ.(universes) ; + declarations := List.map (on_snd (eta_global_declaration Σg)) Σ.(declarations); + retroknowledge := Σ.(retroknowledge) |}. +Proof. + destruct Σ as [univs Σ]; cbn. + induction Σ; intros ind idx mdecl idecl cdecl. + - unfold declared_constructor, declared_inductive, declared_minductive. + cbn => [[[]]] //. + - unfold declared_constructor, declared_inductive, declared_minductive. + cbn. destruct a as [kn decl]; cbn. + case: eqb_spec. + * move=> _ [] [] [= ->] hnth hnth'. + do 3 eexists; cbn. split. split. split => //. + cbn. rewrite nth_error_map hnth; reflexivity. + cbn. rewrite nth_error_map hnth'; reflexivity. + now cbn. cbn. apply eta_context_assumptions. + * move=> _ [] [] hl hnth htnh'. + red in IHΣ. + specialize (IHΣ ind idx mdecl idecl cdecl). + forward IHΣ. repeat split => //. + destruct IHΣ as [mdecl' [idecl' [cdecl' []]]]. + exists mdecl', idecl', cdecl'; repeat split => //. +Qed. + +Lemma lookup_global_Some_fresh Σ c decl : + lookup_global Σ c = Some decl -> ~ (fresh_global c Σ). +Proof. + induction Σ; cbn. 1: congruence. + destruct (eqb_spec c a.1); subst. + - intros [= <-] H2. inv H2. + contradiction. + - intros H1 H2. apply IHΣ; tas. + now inv H2. +Qed. + +Lemma lookup_env_Some_fresh Σ c decl : + lookup_env Σ c = Some decl -> ~ (fresh_global c Σ.(declarations)). +Proof. + apply lookup_global_Some_fresh. +Qed. + +Lemma lookup_global_extends Σ Σ' kn d : + lookup_env Σ kn = Some d -> + extends_decls Σ Σ' -> + EnvMap.fresh_globals Σ'.(declarations) -> + lookup_env Σ' kn = Some d. +Proof. + destruct Σ as [univs Σ retro]. + destruct Σ' as [univs' Σ' retro']. + cbn. move=> hl [] /=; intros <- [Σ'' ->] extretro. + induction Σ''; cbn; auto. + case: eqb_spec. + - intros ->. intros fr. + depelim fr. eapply lookup_global_Some_fresh in hl. cbn in hl. + red in H. eapply Forall_app in H as [frl frr]. contradiction. + - move=> _ hf. now depelim hf. +Qed. + +Lemma eta_expand_global_env_expanded {cf : checker_flags} (Σ : global_env_ext_map) : + Typing.wf Σ -> + expanded_global_env (eta_expand_global_env Σ). Proof. - destruct g as [univs Σ]; cbn. + destruct Σ as [Σ univs]; cbn. unfold expanded_global_env. cbn. unfold Typing.wf, Typing.on_global_env. intros [onu ond]. cbn in *. + destruct Σ as []. cbn in *. + assert (extends_decls env env). red; split => //. now exists []. + revert X. + move: map repr wf. + generalize env at 1 2 4 6 7. + destruct env as [univs' decls retro']. cbn in *. induction ond; cbn; constructor; auto. - set (Σ' := {| universes := univs; declarations := Σ |}). - cbn. epose proof (eta_expand_global_decl_expanded (Σ', udecl) kn d). + apply: IHond. + { cbn. destruct X as [equ [Σ' ext]]. red. split. auto. + rewrite ext. cbn. unfold snoc. exists (Σ' ++ [(kn, d)])%list. now rewrite -app_assoc. + apply e. } + set (Σ' := {| universes := univs'; declarations := Σ; retroknowledge := retro' |}) in *. + set (Σg := {| GlobalEnvMap.env := _ |}). Unshelve. + destruct X as [equ [Σ'' ext]]. cbn in *. destruct env as [univs0 env]. cbn in *. subst univs0. + subst env. + pose proof (eta_expand_global_decl_expanded (Σ', udecl) (Σg, univs) kn d). cbn in H. - eapply expanded_decl_env_irrel, H. - split => //. exact o0. + forward H. { + move=> kn' d' /= hl. + rewrite GlobalEnvMap.lookup_env_spec /=. + cbn. unfold snoc. + eapply (lookup_global_extends Σ' (set_declarations Σ' (Σ'' ++ (kn, d) :: Σ)%list)); eauto. + split => //. cbn. now exists (Σ'' ++ [(kn, d)])%list; rewrite -app_assoc. } + forward H. split. cbn. split => //. now cbn. + specialize (H o0). + eapply expanded_decl_env_irrel in H; tea. + apply (same_cstr_info_eta Σ' Σg). Qed. diff --git a/template-coq/theories/Extraction.v b/template-coq/theories/Extraction.v index 09110a606..b4050d5e4 100644 --- a/template-coq/theories/Extraction.v +++ b/template-coq/theories/Extraction.v @@ -7,10 +7,8 @@ From Coq Require Ascii Extraction ZArith NArith. From MetaCoq.Template Require Import utils Ast Reflect Induction. -From Coq Require Import FSets ExtrOcamlBasic ExtrOCamlFloats - ExtrOCamlInt63. -From MetaCoq.Template Require Import MC_ExtrOCamlZPosInt. - +From Coq Require Import FSets ExtrOcamlBasic ExtrOCamlFloats ExtrOCamlInt63. + (* Ignore [Decimal.int] before the extraction issue is solved: https://github.com/coq/coq/issues/7017. *) Extract Inductive Decimal.int => unit [ "(fun _ -> ())" "(fun _ -> ())" ] "(fun _ _ _ -> assert false)". diff --git a/template-coq/theories/Induction.v b/template-coq/theories/Induction.v index 3363d287c..6ca818ccb 100644 --- a/template-coq/theories/Induction.v +++ b/template-coq/theories/Induction.v @@ -30,8 +30,8 @@ Lemma term_forall_list_ind : (forall (s : projection) (t : term), P t -> P (tProj s t)) -> (forall (m : mfixpoint term) (n : nat), tFixProp P P m -> P (tFix m n)) -> (forall (m : mfixpoint term) (n : nat), tFixProp P P m -> P (tCoFix m n)) -> - (* (forall i, P (tInt i)) -> - (forall f, P (tFloat f)) -> *) + (forall i, P (tInt i)) -> + (forall f, P (tFloat f)) -> forall t : term, P t. Proof. intros until t. revert t. @@ -73,8 +73,8 @@ Lemma term_forall_list_rect : (forall (s : projection) (t : term), P t -> P (tProj s t)) -> (forall (m : mfixpoint term) (n : nat), tFixType P P m -> P (tFix m n)) -> (forall (m : mfixpoint term) (n : nat), tFixType P P m -> P (tCoFix m n)) -> - (* (forall i, P (tInt i)) -> - (forall f, P (tFloat f)) -> *) + (forall i, P (tInt i)) -> + (forall f, P (tFloat f)) -> forall t : term, P t. Proof. intros until t. revert t. diff --git a/template-coq/theories/LiftSubst.v b/template-coq/theories/LiftSubst.v index 28f215634..5a506f748 100644 --- a/template-coq/theories/LiftSubst.v +++ b/template-coq/theories/LiftSubst.v @@ -461,7 +461,7 @@ Qed. Lemma noccur_between_subst k n t : noccur_between k n t -> closedn (n + k) t -> closedn k t. Proof. -Admitted. *) +Qed. *) (* TODO *) Lemma strip_casts_lift n k t : strip_casts (lift n k t) = lift n k (strip_casts t). @@ -524,4 +524,4 @@ Proof. pose (subst_context_snoc n k ctx a). unfold snoc in e. rewrite e. clear e. simpl. rewrite -> IHctx. pose (subst_context_snoc n k ctx a). simpl. now destruct a as [na [b|] ty]. -Qed. \ No newline at end of file +Qed. diff --git a/template-coq/theories/Pretty.v b/template-coq/theories/Pretty.v index c6da78d3e..3a3c37dd9 100644 --- a/template-coq/theories/Pretty.v +++ b/template-coq/theories/Pretty.v @@ -1,5 +1,5 @@ (* Distributed under the terms of the MIT license. *) -From MetaCoq Require Import utils Ast AstUtils Environment LiftSubst Universes. +From MetaCoq Require Import utils Ast AstUtils Primitive Environment LiftSubst Universes. (** * Pretty printing *) @@ -248,8 +248,8 @@ Module PrintTermTree. | tCoFix l n => parens top ("let cofix " ^ print_defs print_term Γ l ^ nl ^ " in " ^ List.nth_default (string_of_nat n) (map (string_of_name ∘ binder_name ∘ dname) l) n) - (* | tInt i => "Int(" ^ string_of_prim_int i ^ ")" - | tFloat f => "Float(" ^ string_of_float f ^ ")" *) + | tInt i => "Int(" ^ string_of_prim_int i ^ ")" + | tFloat f => "Float(" ^ string_of_float f ^ ")" end. Definition pr_context_decl Γ (c : context_decl) : ident * t := @@ -302,11 +302,18 @@ Module PrintTermTree. | Polymorphic_entry uctx => Polymorphic_ctx (fst uctx, snd (snd uctx)) end. + Definition print_recursivity_kind k := + match k with + | Finite => "Inductive" + | CoFinite => "CoInductive" + | BiFinite => "Variant" + end. + Definition print_mib Σ with_universes (short : bool) (mib : mutual_inductive_body) : t := let Σ' := (Σ, mib.(ind_universes)) in let names := fresh_names Σ' [] (arities_context mib.(ind_bodies)) in - ("Inductive " ^ - print_list (print_one_ind Σ' with_universes short names mib) nl mib.(ind_bodies) ^ "." ^ nl). + (print_recursivity_kind mib.(ind_finite) ^ " " ^ + print_list (print_one_ind Σ' with_universes short names mib) (nl ^ "with ") mib.(ind_bodies) ^ "." ^ nl). Definition mie_arities_context mie := rev_map (fun ind => vass (mkBindAnn (nNamed ind.(mind_entry_typename)) Relevant) @@ -316,21 +323,22 @@ Module PrintTermTree. Definition print_mie Σ with_universes (short : bool) (mie : mutual_inductive_entry) : t := let Σ' := (Σ, universes_decl_of_universes_entry mie.(mind_entry_universes)) in let names := fresh_names Σ' [] (mie_arities_context mie) in - ("Inductive " ^ - print_list (print_one_ind_entry Σ' with_universes short names mie) nl mie.(mind_entry_inds) ^ "." ^ nl). + (print_recursivity_kind mie.(mind_entry_finite) ^ " " ^ + print_list (print_one_ind_entry Σ' with_universes short names mie) (nl ^ "with ") mie.(mind_entry_inds) ^ "." ^ nl). Fixpoint print_env_aux with_universes (short : bool) (prefix : nat) (Σ : global_env) (acc : t) : t := match prefix with | 0 => match Σ.(declarations) with [] => acc | _ => ("..." ^ nl ^ acc) end | S n => let univs := Σ.(Env.universes) in + let retro := Σ.(Env.retroknowledge) in match Σ.(declarations) with | [] => acc | (kn, InductiveDecl mib) :: Σ => - let Σ := {| Env.universes := univs; declarations := Σ |} in + let Σ := {| Env.universes := univs; declarations := Σ; retroknowledge := retro |} in print_env_aux with_universes short n Σ (print_mib Σ with_universes short mib ^ acc) | (kn, ConstantDecl cb) :: Σ => - let Σ' := ({| Env.universes := univs; declarations := Σ |}, cb.(cst_universes)) in + let Σ' := ({| Env.universes := univs; declarations := Σ; retroknowledge := retro |}, cb.(cst_universes)) in print_env_aux with_universes short n Σ'.1 ((match cb.(cst_body) with | Some _ => "Definition " diff --git a/template-coq/theories/Primitive.v b/template-coq/theories/Primitive.v new file mode 100644 index 000000000..9ad48c064 --- /dev/null +++ b/template-coq/theories/Primitive.v @@ -0,0 +1,18 @@ +(* Primitive types *) + +From Coq Require Import Uint63 PrimFloat. +From MetaCoq.Template Require Import bytestring MCString. +Local Open Scope bs. + +Variant prim_tag := + | primInt + | primFloat. + (* | primArray. *) +Derive NoConfusion EqDec for prim_tag. + +Definition string_of_prim_int (i:Uint63.int) : string := + (* Better? DecimalString.NilZero.string_of_uint (BinNat.N.to_uint (BinInt.Z.to_N (Int63.to_Z i))). ? *) + string_of_Z (Uint63.to_Z i). + +Definition string_of_float (f : PrimFloat.float) := + "". \ No newline at end of file diff --git a/template-coq/theories/ReflectAst.v b/template-coq/theories/ReflectAst.v index 0c36570de..2192cfd5e 100644 --- a/template-coq/theories/ReflectAst.v +++ b/template-coq/theories/ReflectAst.v @@ -152,10 +152,10 @@ Proof. subst. inversion e1. subst. destruct (eq_dec rarg rarg0) ; nodec. subst. left. reflexivity. - (* - destruct (Int63.eqs i i0) ; nodec. + - destruct (eq_dec i i0) ; nodec. subst. left. reflexivity. - destruct (eq_dec f f0) ; nodec. - subst. left. reflexivity. *) + subst. left. reflexivity. Defined. #[global] Instance reflect_term : ReflectEq term := diff --git a/template-coq/theories/TemplateCheckWf.v b/template-coq/theories/TemplateCheckWf.v index 492d0b29a..0d6a9f1e9 100644 --- a/template-coq/theories/TemplateCheckWf.v +++ b/template-coq/theories/TemplateCheckWf.v @@ -1,5 +1,5 @@ From Coq Require Import List. -From MetaCoq.Template Require Import config Transform TemplateProgram Pretty All Loader. +From MetaCoq.Template Require Import config Transform TemplateProgram Pretty EtaExpand All Loader. Import ListNotations. Import MCMonadNotation. Import bytestring. @@ -7,10 +7,8 @@ Open Scope bs_scope. #[local] Existing Instance config.default_checker_flags. -Definition run_eta_program := Transform.run template_eta_expand. - Definition eta_expand p := - run_eta_program p (todo "assume well-typedness"). + EtaExpand.eta_expand_program p. Definition check_def (d : kername × global_decl) : TemplateMonad unit := match d.2 with @@ -66,10 +64,12 @@ Definition check_wf (g : Ast.Env.program) : TemplateMonad unit := monad_map check_def g.1.(declarations) ;; tmMsg "Wellformed global environment" ;; ret tt. -Definition check_wf_eta (g : Ast.Env.program) : TemplateMonad unit := - monad_map check_def (eta_expand g).1.(declarations) ;; +Axiom assume_wt_template_program : forall p : Ast.Env.program, ∥ wt_template_program p ∥. + +Definition check_wf_eta (p : Ast.Env.program) : TemplateMonad unit := + monad_map check_def (eta_expand (make_template_program_env p (assume_wt_template_program p))).1.(declarations) ;; tmMsg "Wellformed eta-expanded global environment" ;; ret tt. (* To test that a program's eta-expansion is indeed well-typed according to Coq's kernel use: - MetaCoq Run (tmQuoteRec wf_program >>= check_wf_eta). *) \ No newline at end of file + MetaCoq Run (tmQuoteRec wf_program >>= check_wf_eta). *) diff --git a/template-coq/theories/TemplateEnvMap.v b/template-coq/theories/TemplateEnvMap.v new file mode 100644 index 000000000..3c9bcf16c --- /dev/null +++ b/template-coq/theories/TemplateEnvMap.v @@ -0,0 +1,85 @@ +From Coq Require Import ssreflect ssrbool. +From Equations Require Import Equations. +From MetaCoq.Template Require Import config utils Kernames EnvMap Ast Typing. +Import MCMonadNotation. + +Lemma fresh_globals_cons_inv {Σ : global_declarations} {d} : EnvMap.fresh_globals (d :: Σ) -> EnvMap.fresh_globals Σ. +Proof. intros H; now depelim H. Qed. + +Lemma wf_fresh_globals {cf : checker_flags} (Σ : global_env) : wf Σ -> EnvMap.fresh_globals Σ.(declarations). +Proof. + destruct Σ as [univs Σ]; cbn. + move=> [] onu; cbn. induction 1; constructor; auto. +Qed. + +Local Coercion declarations : global_env >-> global_declarations. + +Module GlobalEnvMap. + Record t := + { env :> global_env; + map : EnvMap.t global_decl; + repr : EnvMap.repr env.(declarations) map; + wf : EnvMap.fresh_globals env.(declarations) }. + + Definition lookup_env Σ kn := EnvMap.lookup kn Σ.(map). + + Lemma lookup_env_spec (Σ : t) kn : lookup_env Σ kn = Env.lookup_env Σ kn. + Proof. + rewrite /lookup_env /Env.lookup_env. + apply (EnvMap.lookup_spec Σ.(env).(declarations)); apply Σ. + Qed. + + Definition lookup_minductive Σ kn : option mutual_inductive_body := + decl <- lookup_env Σ kn;; + match decl with + | ConstantDecl _ => None + | InductiveDecl mdecl => ret mdecl + end. + + Lemma lookup_minductive_spec Σ kn : lookup_minductive Σ kn = Ast.lookup_minductive Σ kn. + Proof. + rewrite /lookup_minductive /Ast.lookup_minductive. + rewrite lookup_env_spec //. + Qed. + + Definition lookup_inductive Σ kn : option (mutual_inductive_body * one_inductive_body) := + mdecl <- lookup_minductive Σ (inductive_mind kn) ;; + idecl <- nth_error mdecl.(ind_bodies) (inductive_ind kn) ;; + ret (mdecl, idecl). + + Lemma lookup_inductive_spec Σ kn : lookup_inductive Σ kn = Ast.lookup_inductive Σ kn. + Proof. + rewrite /lookup_inductive /Ast.lookup_inductive. + rewrite lookup_minductive_spec //. + Qed. + + Definition lookup_constructor Σ kn c : option (mutual_inductive_body * one_inductive_body * constructor_body) := + '(mdecl, idecl) <- lookup_inductive Σ kn ;; + cdecl <- nth_error idecl.(ind_ctors) c ;; + ret (mdecl, idecl, cdecl). + + Lemma lookup_constructor_spec Σ kn : lookup_constructor Σ kn = Ast.lookup_constructor Σ kn. + Proof. + rewrite /lookup_constructor /Ast.lookup_constructor. + rewrite lookup_inductive_spec //. + Qed. + + Definition lookup_projection Σ (p : projection) : + option (mutual_inductive_body * one_inductive_body * constructor_body * projection_body) := + '(mdecl, idecl, cdecl) <- lookup_constructor Σ p.(proj_ind) 0 ;; + pdecl <- nth_error idecl.(ind_projs) p.(proj_arg) ;; + ret (mdecl, idecl, cdecl, pdecl). + + Lemma lookup_projection_spec Σ kn : lookup_projection Σ kn = Ast.lookup_projection Σ kn. + Proof. + rewrite /lookup_projection /Ast.lookup_projection. + rewrite lookup_constructor_spec //. + Qed. + + Program Definition make (g : global_env) (Hg : EnvMap.fresh_globals g.(declarations)): t := + {| env := g; + map := EnvMap.of_global_env g.(declarations) |}. + +End GlobalEnvMap. + +Coercion GlobalEnvMap.env : GlobalEnvMap.t >-> global_env. diff --git a/template-coq/theories/TemplateProgram.v b/template-coq/theories/TemplateProgram.v index f243eaca5..f2b7dda31 100644 --- a/template-coq/theories/TemplateProgram.v +++ b/template-coq/theories/TemplateProgram.v @@ -2,17 +2,17 @@ From MetaCoq.Template Require Import utils + Transform Ast (* The term AST *) Typing (* Typing judgment *) config (* Typing configuration *) - Transform WcbvEval - EtaExpand. - -Import Transform. + TemplateEnvMap. Definition template_program := Ast.Env.program. +Definition template_program_env := (TemplateEnvMap.GlobalEnvMap.t * Ast.term). + (** Well-typedness of template programs *) Definition wt_template_program {cf : checker_flags} (p : template_program) := @@ -24,36 +24,32 @@ Definition wt_template_program {cf : checker_flags} (p : template_program) := Definition eval_template_program (p : Ast.Env.program) (v : Ast.term) := ∥ WcbvEval.eval p.1 p.2 v ∥. -(* Eta-expansion *) +(** Well-typedness of template programs with efficient environments *) -Definition template_expand_obseq (p p' : template_program) (v v' : Ast.term) := - v' = EtaExpand.eta_expand p.1.(Ast.Env.declarations) [] v. - -Local Obligation Tactic := idtac. +Definition wt_template_program_env {cf : checker_flags} (p : template_program_env) := + let Σ := Ast.Env.empty_ext p.1 in + wf_ext Σ × ∑ T, Σ ;;; [] |- p.2 : T. -Program Definition template_eta_expand {cf : checker_flags} : self_transform template_program Ast.term eval_template_program eval_template_program := - {| name := "eta-expansion of template program"; - pre p := ∥ wt_template_program p ∥; - transform p _ := EtaExpand.eta_expand_program p; - post p := ∥ wt_template_program p ∥ /\ EtaExpand.expanded_program p; - obseq := template_expand_obseq |}. -Next Obligation. - intros cf [Σ t] [[wfext ht]]. - cbn. split. split. todo "eta-expansion preserves wf ext and typing". - red. - destruct ht as [T ht]. - split; cbn. eapply EtaExpand.eta_expand_global_env_expanded. apply wfext. - eapply EtaExpand.expanded_env_irrel. - epose proof (EtaExpand.eta_expand_expanded (Σ := Ast.Env.empty_ext Σ) [] [] t T). - forward H. apply wfext. specialize (H ht). - forward H by constructor. cbn in H. - destruct Σ; cbn in *. exact H. -Qed. +(** Evaluation relation on template programs *) + +Definition eval_template_program_env (p : template_program_env) (v : Ast.term) := + ∥ WcbvEval.eval p.1 p.2 v ∥. + +Import Transform. + +Lemma wt_template_program_fresh {cf : checker_flags} p : ∥ wt_template_program p ∥ -> EnvMap.EnvMap.fresh_globals (declarations p.1). +Proof. intros [[wfΣ _]]. eapply TemplateEnvMap.wf_fresh_globals, wfΣ. Qed. + +Definition make_template_program_env {cf : checker_flags} (p : template_program) (wtp : ∥ wt_template_program p ∥) : template_program_env := + (GlobalEnvMap.make p.1 (wt_template_program_fresh p wtp), p.2). + +Program Definition build_template_program_env {cf : checker_flags} : + Transform.t template_program template_program_env Ast.term Ast.term eval_template_program eval_template_program_env := + {| name := "rebuilding environment lookup table"; + pre p := ∥ wt_template_program p ∥ ; + transform p pre := make_template_program_env p pre; + post p := ∥ wt_template_program_env p ∥; + obseq g g' v v' := v = v' |}. Next Obligation. - red. intros cf [Σ t] v [[]]. - unfold eval_template_program. - cbn. intros ev. - exists (EtaExpand.eta_expand (Ast.Env.declarations Σ) [] v). split. split. - todo "eta-expansion preserves evaluation". - red. reflexivity. + cbn. exists v. cbn; split; auto. Qed. diff --git a/template-coq/theories/TermEquality.v b/template-coq/theories/TermEquality.v index 2940294c9..958478b62 100644 --- a/template-coq/theories/TermEquality.v +++ b/template-coq/theories/TermEquality.v @@ -256,10 +256,10 @@ Inductive eq_term_upto_univ_napp Σ (Re Rle : Universe.t -> Universe.t -> Prop) eq_term_upto_univ_napp Σ Re Re 0 t1 t1' -> eq_cast_kind c c' -> eq_term_upto_univ_napp Σ Re Re 0 t2 t2' -> - eq_term_upto_univ_napp Σ Re Rle napp (tCast t1 c t2) (tCast t1' c' t2'). + eq_term_upto_univ_napp Σ Re Rle napp (tCast t1 c t2) (tCast t1' c' t2') -(* | eq_Int i : eq_term_upto_univ_napp Σ Re Rle napp (tInt i) (tInt i) -| eq_Float f : eq_term_upto_univ_napp Σ Re Rle napp (tFloat f) (tFloat f). *) +| eq_Int i : eq_term_upto_univ_napp Σ Re Rle napp (tInt i) (tInt i) +| eq_Float f : eq_term_upto_univ_napp Σ Re Rle napp (tFloat f) (tFloat f). Notation eq_term_upto_univ Σ Re Rle := (eq_term_upto_univ_napp Σ Re Rle 0). diff --git a/template-coq/theories/Typing.v b/template-coq/theories/Typing.v index 0baa1ae66..0970a8b2f 100644 --- a/template-coq/theories/Typing.v +++ b/template-coq/theories/Typing.v @@ -3,7 +3,7 @@ From Equations.Type Require Import Relation. From Equations Require Import Equations. From Coq Require Import ssreflect Wellfounded Relation_Operators CRelationClasses. -From MetaCoq.Template Require Import config utils Ast AstUtils Environment +From MetaCoq.Template Require Import config utils Ast AstUtils Environment Primitive LiftSubst UnivSubst EnvironmentTyping Reflect ReflectAst TermEquality WfAst. Import MCMonadNotation. @@ -840,6 +840,20 @@ Inductive typing `{checker_flags} (Σ : global_env_ext) (Γ : context) : term -> wf_cofixpoint Σ mfix -> Σ ;;; Γ |- tCoFix mfix n : decl.(dtype) +| type_Int p prim_ty cdecl : + wf_local Σ Γ -> + primitive_constant Σ primInt = Some prim_ty -> + declared_constant Σ prim_ty cdecl -> + primitive_invariants cdecl -> + Σ ;;; Γ |- tInt p : tConst prim_ty [] + +| type_Float p prim_ty cdecl : + wf_local Σ Γ -> + primitive_constant Σ primFloat = Some prim_ty -> + declared_constant Σ prim_ty cdecl -> + primitive_invariants cdecl -> + Σ ;;; Γ |- tFloat p : tConst prim_ty [] + | type_Conv t A B s : Σ ;;; Γ |- t : A -> Σ ;;; Γ |- B : tSort s -> @@ -952,6 +966,8 @@ Proof. (all2i_size _ (fun _ x y p => Nat.max (typing_size _ _ _ _ p.1.2) (typing_size _ _ _ _ p.2)) a0))))). - exact (S (Nat.max (Nat.max (All_local_env_size typing_size _ _ a) (all_size _ (fun x p => infer_sort_size (typing_sort_size typing_size) Σ _ _ p) a0)) (all_size _ (fun x p => typing_size Σ _ _ _ p) a1))). - exact (S (Nat.max (Nat.max (All_local_env_size typing_size _ _ a) (all_size _ (fun x p => infer_sort_size (typing_sort_size typing_size) Σ _ _ p) a0)) (all_size _ (fun x p => typing_size Σ _ _ _ p) a1))). + - exact (S (All_local_env_size typing_size _ _ a)). + - exact (S (All_local_env_size typing_size _ _ a)). Defined. Lemma typing_size_pos `{checker_flags} {Σ Γ t T} (d : Σ ;;; Γ |- t : T) : typing_size d > 0. @@ -1224,6 +1240,20 @@ Lemma typing_ind_env `{cf : checker_flags} : wf_cofixpoint Σ.1 mfix -> P Σ Γ (tCoFix mfix n) decl.(dtype)) -> + (forall Σ (wfΣ : wf Σ) (Γ : context) (wfΓ : wf_local Σ Γ) p prim_ty cdecl, + PΓ Σ Γ wfΓ -> + primitive_constant Σ primInt = Some prim_ty -> + declared_constant Σ prim_ty cdecl -> + primitive_invariants cdecl -> + P Σ Γ (tInt p) (tConst prim_ty [])) -> + + (forall Σ (wfΣ : wf Σ) (Γ : context) (wfΓ : wf_local Σ Γ) p prim_ty cdecl, + PΓ Σ Γ wfΓ -> + primitive_constant Σ primFloat = Some prim_ty -> + declared_constant Σ prim_ty cdecl -> + primitive_invariants cdecl -> + P Σ Γ (tFloat p) (tConst prim_ty [])) -> + (forall Σ (wfΣ : wf Σ) (Γ : context) (wfΓ : wf_local Σ Γ) (t A B : term) s, PΓ Σ Γ wfΓ -> Σ ;;; Γ |- t : A -> @@ -1237,7 +1267,7 @@ Lemma typing_ind_env `{cf : checker_flags} : Proof. intros P Pdecl PΓ; unfold env_prop. intros XΓ. - intros X X0 Xcast X1 X2 X3 X4 X5 X6 X7 X8 X9 X10 X11 X12 Σ wfΣ Γ wfΓ t T H. + intros X X0 Xcast X1 X2 X3 X4 X5 X6 X7 X8 X9 X10 X11 Xint Xfloat X12 Σ wfΣ Γ wfΓ t T H. (* NOTE (Danil): while porting to 8.9, I had to split original "pose" into 2 pieces, otherwise it takes forever to execure the "pose", for some reason *) pose (@Fix_F ({ Σ : global_env_ext & { wfΣ : wf Σ & { Γ & { t & { T & Σ ;;; Γ |- t : T }}}}})) as p0. @@ -1540,16 +1570,17 @@ Lemma lookup_on_global_env `{checker_flags} {Pcmp P} {Σ : global_env} {c decl} { Σ' : global_env_ext & on_global_env Pcmp P Σ' × extends_decls Σ' Σ × on_global_decl Pcmp P Σ' c decl }. Proof. unfold on_global_env. - destruct Σ as [univs Σ]; cbn. intros [cu ond]. + destruct Σ as [univs Σ retro]; cbn. intros [cu ond]. induction ond; cbn in * => //. case: eqb_specT => [-> [= <-]| ne]. - - exists ({| universes := univs; declarations := Σ |}, udecl). + - exists ({| universes := univs; declarations := Σ; retroknowledge := retro |}, udecl). split; try constructor; tas. - cbn. now split => //; exists [(kn, d)]. + cbn. split => //=. now exists [(kn, d)]. - intros hl. - destruct (IHond hl) as [[Σ' udecl'] [ong [[equ ext] ond']]]. - exists (Σ', udecl'). cbn in equ |- *. subst univs. repeat split; cbn; auto; try apply ong. - cbn in ext. destruct ext as [Σ'' ->]. cbn. + destruct (IHond hl) as [[Σ' udecl'] [ong [[equ ext extretro] ond']]]. + exists (Σ', udecl'). cbn in equ |- *. subst univs. split; cbn; auto; try apply ong. + split; cbn; auto. split; cbn; auto. + cbn in ext. destruct ext as [Σ'' ->]. cbn in *. now exists ((kn, d) :: Σ''). Qed. diff --git a/template-coq/theories/TypingWf.v b/template-coq/theories/TypingWf.v index 039211c4e..2f4fa1624 100644 --- a/template-coq/theories/TypingWf.v +++ b/template-coq/theories/TypingWf.v @@ -179,8 +179,8 @@ Hint Extern 10 => constructor : wf. #[global] Hint Resolve All_skipn : wf. -Lemma on_global_decls_extends_not_fresh {cf} {univs} k (Σ : global_declarations) k' (Σ' : global_declarations) P : - on_global_decls cumul_gen P univs ((k :: Σ) ++ [k'] ++ Σ') -> k.1 = k'.1 -> False. +Lemma on_global_decls_extends_not_fresh {cf} {univs retro} k (Σ : global_declarations) k' (Σ' : global_declarations) P : + on_global_decls cumul_gen P univs retro ((k :: Σ) ++ [k'] ++ Σ') -> k.1 = k'.1 -> False. Proof. intros H eq. depelim H. diff --git a/template-coq/theories/Universes.v b/template-coq/theories/Universes.v index e14b89f0a..9375bc449 100644 --- a/template-coq/theories/Universes.v +++ b/template-coq/theories/Universes.v @@ -118,30 +118,6 @@ Module Level. all: intro; now constructor. Qed. - (* Bonus *) - Definition eqb (l1 l2 : Level.t) : bool - := match compare l1 l2 with Eq => true | _ => false end. - - Global Instance eqb_refl : Reflexive eqb. - Proof. - intros []; unfold eqb; cbnr. - - rewrite (ssreflect.iffRL (string_compare_eq _ _)). all: auto. reflexivity. - - rewrite Nat.compare_refl. reflexivity. - Qed. - - Lemma eqb_spec l l' : reflect (eq l l') (eqb l l'). - Proof. - destruct l, l'; cbn; try constructor; try reflexivity; try discriminate. - - apply iff_reflect. unfold eqb; cbn. - destruct (CompareSpec_string t0 t1); split; intro HH; - try reflexivity; try discriminate; try congruence. - all: inversion HH; subst; now apply irreflexivity in H. - - apply iff_reflect. unfold eqb; cbn. - destruct (Nat.compare_spec n n0); split; intro HH; - try reflexivity; try discriminate; try congruence. - all: inversion HH; subst; now apply Nat.lt_irrefl in H. - Qed. - Definition eq_level l1 l2 := match l1, l2 with | Level.lzero, Level.lzero => true @@ -149,7 +125,7 @@ Module Level. | Level.Var n1, Level.Var n2 => ReflectEq.eqb n1 n2 | _, _ => false end. - + #[global, program] Instance reflect_level : ReflectEq Level.t := { eqb := eq_level }. @@ -163,6 +139,19 @@ Module Level. - destruct (ReflectEq.eqb_spec n n0) ; nodec. constructor. subst. reflexivity. Defined. + + Global Instance eqb_refl : @Reflexive Level.t eqb. + Proof. + intros x. apply ReflectEq.eqb_refl. + Qed. + + Definition eqb := eq_level. + + Lemma eqb_spec l l' : reflect (eq l l') (eqb l l'). + Proof. + apply reflectProp_reflect. + now generalize (eqb_spec l l'). + Qed. Definition eq_leibniz (x y : t) : eq x y -> x = y := id. @@ -2531,7 +2520,7 @@ Definition polymorphic_instance uctx := | Monomorphic_ctx => Instance.empty | Polymorphic_ctx c => fst (snd (AUContext.repr c)) end. -(* todo: duplicate of polymorphic_instance *) +(* TODO: duplicate of polymorphic_instance *) Definition abstract_instance decl := match decl with | Monomorphic_ctx => Instance.empty diff --git a/template-coq/theories/WfAst.v b/template-coq/theories/WfAst.v index c7f0994c8..05aec3d71 100644 --- a/template-coq/theories/WfAst.v +++ b/template-coq/theories/WfAst.v @@ -54,9 +54,9 @@ Inductive wf {Σ} : term -> Type := wf (tProj p t) | wf_tFix mfix k : All (fun def => wf def.(dtype) × wf def.(dbody)) mfix -> wf (tFix mfix k) -| wf_tCoFix mfix k : All (fun def => wf def.(dtype) × wf def.(dbody)) mfix -> wf (tCoFix mfix k). -(* | wf_tInt i : wf (tInt i) *) -(* | wf_tFloat f : wf (tFloat f). *) +| wf_tCoFix mfix k : All (fun def => wf def.(dtype) × wf def.(dbody)) mfix -> wf (tCoFix mfix k) +| wf_tInt i : wf (tInt i) +| wf_tFloat f : wf (tFloat f). Arguments wf : clear implicits. Derive Signature for wf. @@ -65,7 +65,7 @@ Derive Signature for wf. Definition wf_Inv Σ (t : term) : Type := match t with | tRel _ | tVar _ | tSort _ => unit - (* | tInt _ | tFloat _ *) + | tInt _ | tFloat _ => unit | tEvar n l => All (wf Σ) l | tCast t k t' => wf Σ t * wf Σ t' | tProd na t b => wf Σ t * wf Σ b @@ -147,11 +147,11 @@ Lemma term_wf_forall_list_ind Σ : P t -> P (tProj s t)) -> (forall (m : mfixpoint term) (n : nat), tFixProp P P m -> P (tFix m n)) -> (forall (m : mfixpoint term) (n : nat), tFixProp P P m -> P (tCoFix m n)) -> - (* (forall i, P (tInt i)) -> - (forall f, P (tFloat f)) -> *) + (forall i, P (tInt i)) -> + (forall f, P (tFloat f)) -> forall t : term, wf Σ t -> P t. Proof. - intros P H2 H3 H4 H5 H6 H7 H8 H9 H10 H11 H12 H13 H14 H15 H16 H17 (*H18 H19*). + intros P H2 H3 H4 H5 H6 H7 H8 H9 H10 H11 H12 H13 H14 H15 H16 H17 H18 H19. intros until t. revert t. apply (term_forall_list_rect (fun t => wf Σ t -> P t)); intros; try solve [match goal with diff --git a/template-coq/theories/common/uGraph.v b/template-coq/theories/common/uGraph.v index 239a050af..49326d738 100644 --- a/template-coq/theories/common/uGraph.v +++ b/template-coq/theories/common/uGraph.v @@ -2034,46 +2034,6 @@ Section CheckLeq. End CheckLeq. - -Section CheckLeq'. - Context {cf:checker_flags}. - - Context (G : universes_graph) - uctx (Huctx: global_gc_uctx_invariants uctx) (HC : gc_consistent uctx.2) - (HG : G = make_graph uctx). - - (*Lemma check_gc_constraint_complete gcs - : gc_consistent gcs -> check_gc_constraints G gcs. - Proof. - unfold check_gc_constraints. cbn. - intros [v Hv]. - unfold gc_satisfies in Hv. - apply GoodConstraintSetFact.for_all_iff in Hv; eauto. 2:typeclasses eauto. - apply GoodConstraintSetFact.for_all_iff; eauto. typeclasses eauto. - intros gc hc. specialize (Hv gc hc). cbn in Hv. - unfold gc_satisfies0 in Hv. - destruct gc as [l z l'|k l|k n|l k|n k]. - - cbn. apply (leqb_level_n_spec G uctx Huctx HC HG). admit. admit. - intros v' Hv'. cbn. - specialize (HH v Hv). cbn in *. toProp. - pose proof (val_level_of_variable_level v l). - pose proof (val_level_of_variable_level v l'). - destruct l, l'; cbn in *; lled; lia. - - intros HH v Hv; apply leqb_level_n_spec0 in HH. - specialize (HH v Hv). cbn -[Z.of_nat] in HH. unfold gc_satisfies0. toProp. - cbn in *. lled; lia. - - intros HH v Hv; apply leqb_level_n_spec0 in HH. - specialize (HH v Hv). cbn in HH. unfold gc_satisfies0. toProp. - lled; lia. - - intros HH v Hv; apply leqb_level_n_spec0 in HH. - specialize (HH v Hv). cbn in HH. unfold gc_satisfies0. toProp. - lled; lia. - - intros HH v Hv; apply leqb_level_n_spec0 in HH. - specialize (HH v Hv). cbn in HH. unfold gc_satisfies0. toProp. - lled; lia. - Qed. *) -End CheckLeq'. - (* This section: specif in term of raw uctx *) Section CheckLeq2. Context {cf:checker_flags}. @@ -3024,7 +2984,7 @@ Proof. apply: make_graph_invariants. Qed. -#[global] Existing Instance correct_labelling_proper. +#[export] Existing Instance correct_labelling_proper. Lemma correct_labelling_of_valuation_satisfies_iff `{checker_flags} [uctx G v] : is_graph_of_uctx G uctx -> diff --git a/template-coq/theories/monad_utils.v b/template-coq/theories/monad_utils.v index 07cc7c175..dc3f08eac 100644 --- a/template-coq/theories/monad_utils.v +++ b/template-coq/theories/monad_utils.v @@ -1,6 +1,3 @@ -(* todo(gmm): This file should really be replaced by a real - * monad library. - *) Require Import Arith List. From MetaCoq.Template Require Import All_Forall MCSquash. From Equations Require Import Equations. diff --git a/template-coq/theories/utils/All_Forall.v b/template-coq/theories/utils/All_Forall.v index 48c35cca6..ebf29f7b4 100644 --- a/template-coq/theories/utils/All_Forall.v +++ b/template-coq/theories/utils/All_Forall.v @@ -1767,7 +1767,7 @@ Proof. move=> [= <-]. now rewrite (IHHa _ E'). Qed. -(* todo: move *) +(* TODO: move *) Lemma All_mapi {A B} P f l k : Alli (fun i x => P (f i x)) k l -> All P (@mapi_rec A B f l k). Proof. diff --git a/template-coq/theories/utils/ByteCompare.v b/template-coq/theories/utils/ByteCompare.v index e3c43b214..0ffc097bb 100644 --- a/template-coq/theories/utils/ByteCompare.v +++ b/template-coq/theories/utils/ByteCompare.v @@ -1,7 +1,529 @@ From Coq Require Import Strings.Byte NArith.BinNat. +(* To make byte comparison more efficient and avoid reallocating the same number + many times, we precompute the representation in N. *) + +Module ByteN. +Definition N0 := 0%N. +Definition N1 := 1%N. +Definition N2 := 2%N. +Definition N3 := 3%N. +Definition N4 := 4%N. +Definition N5 := 5%N. +Definition N6 := 6%N. +Definition N7 := 7%N. +Definition N8 := 8%N. +Definition N9 := 9%N. +Definition N10 := 10%N. +Definition N11 := 11%N. +Definition N12 := 12%N. +Definition N13 := 13%N. +Definition N14 := 14%N. +Definition N15 := 15%N. +Definition N16 := 16%N. +Definition N17 := 17%N. +Definition N18 := 18%N. +Definition N19 := 19%N. +Definition N20 := 20%N. +Definition N21 := 21%N. +Definition N22 := 22%N. +Definition N23 := 23%N. +Definition N24 := 24%N. +Definition N25 := 25%N. +Definition N26 := 26%N. +Definition N27 := 27%N. +Definition N28 := 28%N. +Definition N29 := 29%N. +Definition N30 := 30%N. +Definition N31 := 31%N. +Definition N32 := 32%N. +Definition N33 := 33%N. +Definition N34 := 34%N. +Definition N35 := 35%N. +Definition N36 := 36%N. +Definition N37 := 37%N. +Definition N38 := 38%N. +Definition N39 := 39%N. +Definition N40 := 40%N. +Definition N41 := 41%N. +Definition N42 := 42%N. +Definition N43 := 43%N. +Definition N44 := 44%N. +Definition N45 := 45%N. +Definition N46 := 46%N. +Definition N47 := 47%N. +Definition N48 := 48%N. +Definition N49 := 49%N. +Definition N50 := 50%N. +Definition N51 := 51%N. +Definition N52 := 52%N. +Definition N53 := 53%N. +Definition N54 := 54%N. +Definition N55 := 55%N. +Definition N56 := 56%N. +Definition N57 := 57%N. +Definition N58 := 58%N. +Definition N59 := 59%N. +Definition N60 := 60%N. +Definition N61 := 61%N. +Definition N62 := 62%N. +Definition N63 := 63%N. +Definition N64 := 64%N. +Definition N65 := 65%N. +Definition N66 := 66%N. +Definition N67 := 67%N. +Definition N68 := 68%N. +Definition N69 := 69%N. +Definition N70 := 70%N. +Definition N71 := 71%N. +Definition N72 := 72%N. +Definition N73 := 73%N. +Definition N74 := 74%N. +Definition N75 := 75%N. +Definition N76 := 76%N. +Definition N77 := 77%N. +Definition N78 := 78%N. +Definition N79 := 79%N. +Definition N80 := 80%N. +Definition N81 := 81%N. +Definition N82 := 82%N. +Definition N83 := 83%N. +Definition N84 := 84%N. +Definition N85 := 85%N. +Definition N86 := 86%N. +Definition N87 := 87%N. +Definition N88 := 88%N. +Definition N89 := 89%N. +Definition N90 := 90%N. +Definition N91 := 91%N. +Definition N92 := 92%N. +Definition N93 := 93%N. +Definition N94 := 94%N. +Definition N95 := 95%N. +Definition N96 := 96%N. +Definition N97 := 97%N. +Definition N98 := 98%N. +Definition N99 := 99%N. +Definition N100 := 100%N. +Definition N101 := 101%N. +Definition N102 := 102%N. +Definition N103 := 103%N. +Definition N104 := 104%N. +Definition N105 := 105%N. +Definition N106 := 106%N. +Definition N107 := 107%N. +Definition N108 := 108%N. +Definition N109 := 109%N. +Definition N110 := 110%N. +Definition N111 := 111%N. +Definition N112 := 112%N. +Definition N113 := 113%N. +Definition N114 := 114%N. +Definition N115 := 115%N. +Definition N116 := 116%N. +Definition N117 := 117%N. +Definition N118 := 118%N. +Definition N119 := 119%N. +Definition N120 := 120%N. +Definition N121 := 121%N. +Definition N122 := 122%N. +Definition N123 := 123%N. +Definition N124 := 124%N. +Definition N125 := 125%N. +Definition N126 := 126%N. +Definition N127 := 127%N. +Definition N128 := 128%N. +Definition N129 := 129%N. +Definition N130 := 130%N. +Definition N131 := 131%N. +Definition N132 := 132%N. +Definition N133 := 133%N. +Definition N134 := 134%N. +Definition N135 := 135%N. +Definition N136 := 136%N. +Definition N137 := 137%N. +Definition N138 := 138%N. +Definition N139 := 139%N. +Definition N140 := 140%N. +Definition N141 := 141%N. +Definition N142 := 142%N. +Definition N143 := 143%N. +Definition N144 := 144%N. +Definition N145 := 145%N. +Definition N146 := 146%N. +Definition N147 := 147%N. +Definition N148 := 148%N. +Definition N149 := 149%N. +Definition N150 := 150%N. +Definition N151 := 151%N. +Definition N152 := 152%N. +Definition N153 := 153%N. +Definition N154 := 154%N. +Definition N155 := 155%N. +Definition N156 := 156%N. +Definition N157 := 157%N. +Definition N158 := 158%N. +Definition N159 := 159%N. +Definition N160 := 160%N. +Definition N161 := 161%N. +Definition N162 := 162%N. +Definition N163 := 163%N. +Definition N164 := 164%N. +Definition N165 := 165%N. +Definition N166 := 166%N. +Definition N167 := 167%N. +Definition N168 := 168%N. +Definition N169 := 169%N. +Definition N170 := 170%N. +Definition N171 := 171%N. +Definition N172 := 172%N. +Definition N173 := 173%N. +Definition N174 := 174%N. +Definition N175 := 175%N. +Definition N176 := 176%N. +Definition N177 := 177%N. +Definition N178 := 178%N. +Definition N179 := 179%N. +Definition N180 := 180%N. +Definition N181 := 181%N. +Definition N182 := 182%N. +Definition N183 := 183%N. +Definition N184 := 184%N. +Definition N185 := 185%N. +Definition N186 := 186%N. +Definition N187 := 187%N. +Definition N188 := 188%N. +Definition N189 := 189%N. +Definition N190 := 190%N. +Definition N191 := 191%N. +Definition N192 := 192%N. +Definition N193 := 193%N. +Definition N194 := 194%N. +Definition N195 := 195%N. +Definition N196 := 196%N. +Definition N197 := 197%N. +Definition N198 := 198%N. +Definition N199 := 199%N. +Definition N200 := 200%N. +Definition N201 := 201%N. +Definition N202 := 202%N. +Definition N203 := 203%N. +Definition N204 := 204%N. +Definition N205 := 205%N. +Definition N206 := 206%N. +Definition N207 := 207%N. +Definition N208 := 208%N. +Definition N209 := 209%N. +Definition N210 := 210%N. +Definition N211 := 211%N. +Definition N212 := 212%N. +Definition N213 := 213%N. +Definition N214 := 214%N. +Definition N215 := 215%N. +Definition N216 := 216%N. +Definition N217 := 217%N. +Definition N218 := 218%N. +Definition N219 := 219%N. +Definition N220 := 220%N. +Definition N221 := 221%N. +Definition N222 := 222%N. +Definition N223 := 223%N. +Definition N224 := 224%N. +Definition N225 := 225%N. +Definition N226 := 226%N. +Definition N227 := 227%N. +Definition N228 := 228%N. +Definition N229 := 229%N. +Definition N230 := 230%N. +Definition N231 := 231%N. +Definition N232 := 232%N. +Definition N233 := 233%N. +Definition N234 := 234%N. +Definition N235 := 235%N. +Definition N236 := 236%N. +Definition N237 := 237%N. +Definition N238 := 238%N. +Definition N239 := 239%N. +Definition N240 := 240%N. +Definition N241 := 241%N. +Definition N242 := 242%N. +Definition N243 := 243%N. +Definition N244 := 244%N. +Definition N245 := 245%N. +Definition N246 := 246%N. +Definition N247 := 247%N. +Definition N248 := 248%N. +Definition N249 := 249%N. +Definition N250 := 250%N. +Definition N251 := 251%N. +Definition N252 := 252%N. +Definition N253 := 253%N. +Definition N254 := 254%N. +Definition N255 := 255%N. + +Definition to_N (x : byte) := + match x with + | "000"%byte => N0 + | "001"%byte => N1 + | "002"%byte => N2 + | "003"%byte => N3 + | "004"%byte => N4 + | "005"%byte => N5 + | "006"%byte => N6 + | "007"%byte => N7 + | "008"%byte => N8 + | "009"%byte => N9 + | "010"%byte => N10 + | "011"%byte => N11 + | "012"%byte => N12 + | "013"%byte => N13 + | "014"%byte => N14 + | "015"%byte => N15 + | "016"%byte => N16 + | "017"%byte => N17 + | "018"%byte => N18 + | "019"%byte => N19 + | "020"%byte => N20 + | "021"%byte => N21 + | "022"%byte => N22 + | "023"%byte => N23 + | "024"%byte => N24 + | "025"%byte => N25 + | "026"%byte => N26 + | "027"%byte => N27 + | "028"%byte => N28 + | "029"%byte => N29 + | "030"%byte => N30 + | "031"%byte => N31 + | "032"%byte => N32 + | "033"%byte => N33 + | "034"%byte => N34 + | "035"%byte => N35 + | "036"%byte => N36 + | "037"%byte => N37 + | "038"%byte => N38 + | "039"%byte => N39 + | "040"%byte => N40 + | "041"%byte => N41 + | "042"%byte => N42 + | "043"%byte => N43 + | "044"%byte => N44 + | "045"%byte => N45 + | "046"%byte => N46 + | "047"%byte => N47 + | "048"%byte => N48 + | "049"%byte => N49 + | "050"%byte => N50 + | "051"%byte => N51 + | "052"%byte => N52 + | "053"%byte => N53 + | "054"%byte => N54 + | "055"%byte => N55 + | "056"%byte => N56 + | "057"%byte => N57 + | "058"%byte => N58 + | "059"%byte => N59 + | "060"%byte => N60 + | "061"%byte => N61 + | "062"%byte => N62 + | "063"%byte => N63 + | "064"%byte => N64 + | "065"%byte => N65 + | "066"%byte => N66 + | "067"%byte => N67 + | "068"%byte => N68 + | "069"%byte => N69 + | "070"%byte => N70 + | "071"%byte => N71 + | "072"%byte => N72 + | "073"%byte => N73 + | "074"%byte => N74 + | "075"%byte => N75 + | "076"%byte => N76 + | "077"%byte => N77 + | "078"%byte => N78 + | "079"%byte => N79 + | "080"%byte => N80 + | "081"%byte => N81 + | "082"%byte => N82 + | "083"%byte => N83 + | "084"%byte => N84 + | "085"%byte => N85 + | "086"%byte => N86 + | "087"%byte => N87 + | "088"%byte => N88 + | "089"%byte => N89 + | "090"%byte => N90 + | "091"%byte => N91 + | "092"%byte => N92 + | "093"%byte => N93 + | "094"%byte => N94 + | "095"%byte => N95 + | "096"%byte => N96 + | "097"%byte => N97 + | "098"%byte => N98 + | "099"%byte => N99 + | "100"%byte => N100 + | "101"%byte => N101 + | "102"%byte => N102 + | "103"%byte => N103 + | "104"%byte => N104 + | "105"%byte => N105 + | "106"%byte => N106 + | "107"%byte => N107 + | "108"%byte => N108 + | "109"%byte => N109 + | "110"%byte => N110 + | "111"%byte => N111 + | "112"%byte => N112 + | "113"%byte => N113 + | "114"%byte => N114 + | "115"%byte => N115 + | "116"%byte => N116 + | "117"%byte => N117 + | "118"%byte => N118 + | "119"%byte => N119 + | "120"%byte => N120 + | "121"%byte => N121 + | "122"%byte => N122 + | "123"%byte => N123 + | "124"%byte => N124 + | "125"%byte => N125 + | "126"%byte => N126 + | "127"%byte => N127 + | "128"%byte => N128 + | "129"%byte => N129 + | "130"%byte => N130 + | "131"%byte => N131 + | "132"%byte => N132 + | "133"%byte => N133 + | "134"%byte => N134 + | "135"%byte => N135 + | "136"%byte => N136 + | "137"%byte => N137 + | "138"%byte => N138 + | "139"%byte => N139 + | "140"%byte => N140 + | "141"%byte => N141 + | "142"%byte => N142 + | "143"%byte => N143 + | "144"%byte => N144 + | "145"%byte => N145 + | "146"%byte => N146 + | "147"%byte => N147 + | "148"%byte => N148 + | "149"%byte => N149 + | "150"%byte => N150 + | "151"%byte => N151 + | "152"%byte => N152 + | "153"%byte => N153 + | "154"%byte => N154 + | "155"%byte => N155 + | "156"%byte => N156 + | "157"%byte => N157 + | "158"%byte => N158 + | "159"%byte => N159 + | "160"%byte => N160 + | "161"%byte => N161 + | "162"%byte => N162 + | "163"%byte => N163 + | "164"%byte => N164 + | "165"%byte => N165 + | "166"%byte => N166 + | "167"%byte => N167 + | "168"%byte => N168 + | "169"%byte => N169 + | "170"%byte => N170 + | "171"%byte => N171 + | "172"%byte => N172 + | "173"%byte => N173 + | "174"%byte => N174 + | "175"%byte => N175 + | "176"%byte => N176 + | "177"%byte => N177 + | "178"%byte => N178 + | "179"%byte => N179 + | "180"%byte => N180 + | "181"%byte => N181 + | "182"%byte => N182 + | "183"%byte => N183 + | "184"%byte => N184 + | "185"%byte => N185 + | "186"%byte => N186 + | "187"%byte => N187 + | "188"%byte => N188 + | "189"%byte => N189 + | "190"%byte => N190 + | "191"%byte => N191 + | "192"%byte => N192 + | "193"%byte => N193 + | "194"%byte => N194 + | "195"%byte => N195 + | "196"%byte => N196 + | "197"%byte => N197 + | "198"%byte => N198 + | "199"%byte => N199 + | "200"%byte => N200 + | "201"%byte => N201 + | "202"%byte => N202 + | "203"%byte => N203 + | "204"%byte => N204 + | "205"%byte => N205 + | "206"%byte => N206 + | "207"%byte => N207 + | "208"%byte => N208 + | "209"%byte => N209 + | "210"%byte => N210 + | "211"%byte => N211 + | "212"%byte => N212 + | "213"%byte => N213 + | "214"%byte => N214 + | "215"%byte => N215 + | "216"%byte => N216 + | "217"%byte => N217 + | "218"%byte => N218 + | "219"%byte => N219 + | "220"%byte => N220 + | "221"%byte => N221 + | "222"%byte => N222 + | "223"%byte => N223 + | "224"%byte => N224 + | "225"%byte => N225 + | "226"%byte => N226 + | "227"%byte => N227 + | "228"%byte => N228 + | "229"%byte => N229 + | "230"%byte => N230 + | "231"%byte => N231 + | "232"%byte => N232 + | "233"%byte => N233 + | "234"%byte => N234 + | "235"%byte => N235 + | "236"%byte => N236 + | "237"%byte => N237 + | "238"%byte => N238 + | "239"%byte => N239 + | "240"%byte => N240 + | "241"%byte => N241 + | "242"%byte => N242 + | "243"%byte => N243 + | "244"%byte => N244 + | "245"%byte => N245 + | "246"%byte => N246 + | "247"%byte => N247 + | "248"%byte => N248 + | "249"%byte => N249 + | "250"%byte => N250 + | "251"%byte => N251 + | "252"%byte => N252 + | "253"%byte => N253 + | "254"%byte => N254 + | "255"%byte => N255 + end. +End ByteN. + Definition eqb (x y : byte) := - N.eqb (Byte.to_N x) (Byte.to_N y). + N.eqb (ByteN.to_N x) (ByteN.to_N y). Definition compare (x y : byte) := - N.compare (Byte.to_N x) (Byte.to_N y). + N.compare (ByteN.to_N x) (ByteN.to_N y). diff --git a/template-coq/theories/utils/MCOption.v b/template-coq/theories/utils/MCOption.v index 98500a7e3..7c13938c4 100644 --- a/template-coq/theories/utils/MCOption.v +++ b/template-coq/theories/utils/MCOption.v @@ -187,3 +187,19 @@ Lemma foroptb_impl {A} (f g : A -> bool) x : (forall x, f x -> g x) -> foroptb f Proof. move=> Hf; destruct x; simpl => //; apply Hf. Qed. + +(* Extension *) + +Inductive option_extends {A} : relation (option A) := +| option_ext_fill t : option_extends None (Some t) +| option_ext_keep t : option_extends (Some t) (Some t) +| option_ext_non : option_extends None None. +Derive Signature for option_extends. + +#[export] Instance option_extends_refl {A} : RelationClasses.Reflexive (@option_extends A). +Proof. intros []; constructor. Qed. + +#[export] Instance option_extends_trans {A} : RelationClasses.Transitive (@option_extends A). +Proof. + intros x y z [] H; inv H; constructor. +Qed. diff --git a/template-coq/theories/utils/MCString.v b/template-coq/theories/utils/MCString.v index c5d6ef402..141cb7e1d 100644 --- a/template-coq/theories/utils/MCString.v +++ b/template-coq/theories/utils/MCString.v @@ -26,19 +26,21 @@ Definition print_list {A} (f : A -> string) (sep : string) (l : list A) : string Definition parens (top : bool) (s : string) := if top then s else "(" ++ s ++ ")". +Local Infix "::" := String.String. + Fixpoint string_of_uint n := match n with | Nil => "" - | D0 n => "0" ++ string_of_uint n - | D1 n => "1" ++ string_of_uint n - | D2 n => "2" ++ string_of_uint n - | D3 n => "3" ++ string_of_uint n - | D4 n => "4" ++ string_of_uint n - | D5 n => "5" ++ string_of_uint n - | D6 n => "6" ++ string_of_uint n - | D7 n => "7" ++ string_of_uint n - | D8 n => "8" ++ string_of_uint n - | D9 n => "9" ++ string_of_uint n + | D0 n => "0" :: string_of_uint n + | D1 n => "1" :: string_of_uint n + | D2 n => "2" :: string_of_uint n + | D3 n => "3" :: string_of_uint n + | D4 n => "4" :: string_of_uint n + | D5 n => "5" :: string_of_uint n + | D6 n => "6" :: string_of_uint n + | D7 n => "7" :: string_of_uint n + | D8 n => "8" :: string_of_uint n + | D9 n => "9" :: string_of_uint n end. Definition string_of_nat n : string := @@ -48,7 +50,7 @@ Definition string_of_nat n : string := Hint Resolve String.string_dec : eq_dec. Definition string_of_positive p := - string_of_nat (Pos.to_nat p). + string_of_uint (Pos.to_uint p). Definition string_of_Z (z : Z) : string := match z with diff --git a/template-coq/theories/utils/wGraph.v b/template-coq/theories/utils/wGraph.v index 3ae611d57..455baff60 100644 --- a/template-coq/theories/utils/wGraph.v +++ b/template-coq/theories/utils/wGraph.v @@ -960,6 +960,72 @@ Module WeightedGraph (V : UsualOrderedType) (VSet : MSetInterface.S with Module lia. Qed. + (* lsp = longest simple path *) + (* l is the list of authorized intermediate nodes *) + (* lsp0 (a::l) x y = max (lsp0 l x y) (lsp0 l x a + lsp0 l a y) *) + + Fixpoint lsp00_fast fuel (s : VSet.t) (x z : V.t) : Nbar.t := + let base := if V.eq_dec x z then Some 0 else None in + match fuel with + | 0%nat => base + | Datatypes.S fuel => + match VSet.mem x s with + | true => + let s := VSet.remove x s in + EdgeSet.fold + (fun '(src, w, tgt) acc => + if V.eq_dec src x then + Nbar.max acc (Some w + lsp00_fast fuel s tgt z) + else acc)%nbar + (E G) base + | false => base end + end. + + Lemma fold_left_map {A B C} (f : A -> B -> A) (g : C -> B) l acc : fold_left f (map g l) acc = + fold_left (fun acc x => f acc (g x)) l acc. + Proof. + induction l in acc |- *; cbn; auto. + Qed. + + Lemma fold_left_filter {A B} (f : A -> B -> A) (g : B -> bool) l acc : fold_left f (filter g l) acc = + fold_left (fun acc x => if g x then f acc x else acc) l acc. + Proof. + induction l in acc |- *; cbn; auto. + destruct (g a) => //=. + Qed. + + #[global] Instance fold_left_proper {A B} : Proper (`=2` ==> `=2`) (@fold_left A B). + Proof. + intros f g hfg x acc. + induction x in acc |- * => //. + cbn. rewrite (hfg acc a). apply IHx. + Qed. + + Lemma fold_left_equiv {A B C} (f : A -> B -> A) (g : A -> C -> A) (h : C -> B) l l' acc : + (forall acc x, f acc (h x) = g acc x) -> + l = map h l' -> + fold_left f l acc = fold_left g l' acc. + Proof. + intros hfg ->. + induction l' in acc |- *; cbn; auto. + rewrite fold_left_map. rewrite hfg. + apply fold_left_proper. exact hfg. + Qed. + + Lemma lsp00_optim fuel s x z : lsp00_fast fuel s x z = lsp00 fuel s x z. + Proof. + induction fuel in s, x, z |- *; auto. simpl. + destruct VSet.mem => //. + rewrite EdgeSet.fold_spec. + rewrite fold_left_map. + unfold succs. rewrite fold_left_map. + rewrite fold_left_filter. + eapply fold_left_proper => acc [[src w] tgt]; cbn. + destruct is_left => //. f_equal. now rewrite IHfuel. + Qed. + + Definition lsp_fast := lsp00_fast (VSet.cardinal (V G)) (V G). + (* Equations lsp0 (s : VSet.t) (x z : V.t) : Nbar.t by wf (VSet.cardinal s) *) (* := *) (* lsp0 s x z := *) @@ -978,6 +1044,10 @@ Module WeightedGraph (V : UsualOrderedType) (VSet : MSetInterface.S with Module Definition lsp := lsp0 (V G). + Lemma lsp_optim x y : lsp_fast x y = lsp x y. + Proof. + now rewrite /lsp /lsp_fast /lsp0 lsp00_optim. + Qed. Lemma lsp0_VSet_Equal {s s' x y} : VSet.Equal s s' -> lsp0 s x y = lsp0 s' x y. @@ -1132,7 +1202,7 @@ Module WeightedGraph (V : UsualOrderedType) (VSet : MSetInterface.S with Module | None => false end. - Lemma is_nonpos_spec n : is_nonpos n <~> ∑ z, n = Some z /\ z <= 0. + Lemma is_nonpos_spec n : is_nonpos n <-> exists z, n = Some z /\ z <= 0. Proof using Type. unfold is_nonpos. split. @@ -1388,7 +1458,7 @@ Module WeightedGraph (V : UsualOrderedType) (VSet : MSetInterface.S with Module Qed. Lemma le_Some_lsp {n x y} : (Some n <= lsp x y)%nbar -> - ∑ k, lsp x y = Some k /\ n <= k. + exists k, lsp x y = Some k /\ n <= k. Proof using Type. destruct lsp eqn:xy. simpl. intros. eexists; split; eauto. @@ -1577,9 +1647,10 @@ Module WeightedGraph (V : UsualOrderedType) (VSet : MSetInterface.S with Module now simpl. Qed. - Lemma is_acyclic_correct : reflect acyclic_no_loop is_acyclic. + Lemma is_acyclic_correct : reflectProp acyclic_no_loop is_acyclic. Proof using HI. - eapply reflect_logically_equiv. eapply acyclic_caract2. + eapply reflect_reflectProp, reflect_logically_equiv. + eapply acyclic_caract2. apply VSet_Forall_reflect; intro x. destruct (lsp x x). destruct z. constructor; reflexivity. all: constructor; discriminate. @@ -1720,7 +1791,7 @@ Module WeightedGraph (V : UsualOrderedType) (VSet : MSetInterface.S with Module * rewrite weight_SPath_sub; lia. Qed. - Lemma lsp_pathOf {x y} (p : PathOf G x y) : ∑ n, lsp G x y = Some n /\ weight p <= n. + Lemma lsp_pathOf {x y} (p : PathOf G x y) : exists n, lsp G x y = Some n /\ weight p <= n. Proof using HG HI. pose proof (lsp0_spec_le G (simplify2' G p)) as ineq. unfold lsp in *. @@ -1969,7 +2040,7 @@ Module WeightedGraph (V : UsualOrderedType) (VSet : MSetInterface.S with Module * rewrite weight_SPath_sub; lia. Qed. - Lemma lsp_pathOf {x y} (p : PathOf G x y) : ∑ n, lsp G x y = Some n. + Lemma lsp_pathOf {x y} (p : PathOf G x y) : exists n, lsp G x y = Some n. Proof using HI. pose proof (lsp0_spec_le G (simplify2' G p)) as ineq. unfold lsp in *. @@ -2431,13 +2502,14 @@ Module WeightedGraph (V : UsualOrderedType) (VSet : MSetInterface.S with Module Defined. Definition leqb_vertices z x y : bool := - if VSet.mem y (V G) then if is_left (Nbar.le_dec (Some z) (lsp G x y)) then true else false - else (Z.leb z 0 && (V.eq_dec x y || Nbar.le_dec (Some z) (lsp G x (s G))))%bool. + if VSet.mem y (V G) then if is_left (Nbar.le_dec (Some z) (lsp_fast G x y)) then true else false + else (Z.leb z 0 && (V.eq_dec x y || Nbar.le_dec (Some z) (lsp_fast G x (s G))))%bool. Lemma leqb_vertices_correct n x y : leq_vertices G n x y <-> leqb_vertices n x y. Proof using HG HI. - etransitivity. apply leq_vertices_caract. unfold leqb_vertices. + etransitivity. apply leq_vertices_caract. + rewrite /leqb_vertices !lsp_optim. destruct (VSet.mem y (V G)). - destruct (le_dec (Some n) (lsp G x y)); cbn; intuition. discriminate. @@ -2618,8 +2690,8 @@ Module WeightedGraph (V : UsualOrderedType) (VSet : MSetInterface.S with Module Definition reroot_spath_aux G s x z (p : SPath G s x z) y : VSet.In y (snodes G p) -> forall s' (q : SPath G s' z x), - Disjoint s s' -> { c : SPath G (VSet.union s s') y y | - sweight c = sweight p + sweight q }. + Disjoint s s' -> exists c : SPath G (VSet.union s s') y y, + sweight c = sweight p + sweight q . Proof. elim: p=> {x z}[s0 x|s0 s1 x y' z disj01 e p ih] /=. - move=> /VSetFact.empty_iff []. @@ -2639,7 +2711,7 @@ Module WeightedGraph (V : UsualOrderedType) (VSet : MSetInterface.S with Module Lemma reroot_spath G s x (p : SPath G s x x) y : VSet.In y (snodes G p) -> - { c : SPath G s y y | sweight c = sweight p } . + exists c : SPath G s y y, sweight c = sweight p. Proof. move=> yinp. pose (rx := spath_refl G VSet.empty x). @@ -2650,8 +2722,7 @@ Module WeightedGraph (V : UsualOrderedType) (VSet : MSetInterface.S with Module + apply: (SPath_sub _ _ c). move=> ? /VSet.union_spec [//|/VSet.empty_spec[]]. + rewrite weight_SPath_sub wc /rx /=; lia. - Defined. - + Qed. Section MapSPath. Context {G1 G2} (on_edge : forall x y, EdgeOf G1 x y -> EdgeOf G2 x y). diff --git a/test-suite/Makefile b/test-suite/Makefile index 93168ec11..a6cf61b73 100644 --- a/test-suite/Makefile +++ b/test-suite/Makefile @@ -5,9 +5,13 @@ all: bugs plugin-demo bugs: Makefile.coq $(MAKE) -f Makefile.coq TIMED=$(TIMED) -Makefile.coq: Makefile +Makefile.coq: Makefile _CoqProject coq_makefile -f _CoqProject -o Makefile.coq +_CoqProject: _CoqProject.in metacoq-config + cat metacoq-config > _CoqProject + cat _CoqProject.in >> _CoqProject + clean: Makefile.coq $(MAKE) -f Makefile.coq clean diff --git a/test-suite/_CoqProject b/test-suite/_CoqProject.in similarity index 75% rename from test-suite/_CoqProject rename to test-suite/_CoqProject.in index c00b71f65..cf3edbec7 100644 --- a/test-suite/_CoqProject +++ b/test-suite/_CoqProject.in @@ -1,7 +1,3 @@ --Q ../template-coq/theories MetaCoq.Template --Q ../pcuic/theories MetaCoq.PCUIC --Q ../safechecker/theories MetaCoq.SafeChecker --Q ../erasure/theories MetaCoq.Erasure -R . MetaCoq.TestSuite # list obtained with `ls -1 *.v` diff --git a/test-suite/bug369.v b/test-suite/bug369.v new file mode 100644 index 000000000..3f56702d8 --- /dev/null +++ b/test-suite/bug369.v @@ -0,0 +1,40 @@ +From MetaCoq.Template Require Import utils All. + +Definition anonb := {| binder_name := nAnon; binder_relevance := Relevant |}. +Definition bnamed n := {| binder_name := nNamed n; binder_relevance := Relevant |}. + +Definition mkImpl (A B : term) : term := + tProd anonb A B. + +Definition mkImplN name (A B : term) : term := + tProd (bnamed name) A B. + +Definition one_pt_i : one_inductive_entry := +{| + mind_entry_typename := "Point"; + mind_entry_arity := tSort Universe.type0; + mind_entry_consnames := ["mkPoint"]; + mind_entry_lc := [ + mkImplN "coordx"%bs (tRel 0) (mkImplN "coordy"%bs (tRel 1) (tApp (tRel 3) [tRel 2]))]; +|}. + +Definition mut_pt_i : mutual_inductive_entry := +{| + mind_entry_record := Some (Some "mkPoint" (* Irrelevant *)); + mind_entry_finite := BiFinite; + mind_entry_params := [{| decl_name := bnamed "A"; decl_body := None; + decl_type := (tSort Universe.type0) |}]; + mind_entry_inds := [one_pt_i]; + mind_entry_universes := Monomorphic_entry ContextSet.empty; + mind_entry_template := false; + mind_entry_variance := None; + mind_entry_private := None; +|}. + +MetaCoq Unquote Inductive mut_pt_i. + +Check fun p => p.(coordx _). +Check {| coordx := 0 ; coordy := 1 |}. + +Check eq_refl : {| coordx := 0 ; coordy := 1 |}.(coordx _) = 0. + diff --git a/test-suite/hott_example.v b/test-suite/hott_example.v index e11f48a28..584ff7326 100644 --- a/test-suite/hott_example.v +++ b/test-suite/hott_example.v @@ -1,4 +1,4 @@ - +Set Warnings "-future-coercion-class-field". Set Universe Polymorphism. (* Basic notations *) diff --git a/test-suite/plugin-demo/Makefile b/test-suite/plugin-demo/Makefile index 42c55bbfd..3f53a81b6 100644 --- a/test-suite/plugin-demo/Makefile +++ b/test-suite/plugin-demo/Makefile @@ -10,6 +10,14 @@ Makefile.coq: _CoqProject Makefile.plugin: _PluginProject coq_makefile -f _PluginProject -o Makefile.plugin +_CoqProject: _CoqProject.in metacoq-config + cat metacoq-config > _CoqProject + cat _CoqProject.in >> _CoqProject + +_PluginProject: _PluginProject.in metacoq-config + cat metacoq-config > _PluginProject + cat _PluginProject.in >> _PluginProject + plugin: Makefile.plugin coq $(MAKE) -f Makefile.plugin diff --git a/test-suite/plugin-demo/_CoqProject b/test-suite/plugin-demo/_CoqProject.in similarity index 56% rename from test-suite/plugin-demo/_CoqProject rename to test-suite/plugin-demo/_CoqProject.in index 2cd0a612c..7e1145643 100644 --- a/test-suite/plugin-demo/_CoqProject +++ b/test-suite/plugin-demo/_CoqProject.in @@ -1,7 +1,4 @@ META.coq-metacoq-demo-plugin --R ../../template-coq/theories MetaCoq.Template --I ../../template-coq/build --I ../../template-coq/ -R theories MetaCoq.ExtractedPluginDemo theories/Lens.v diff --git a/test-suite/plugin-demo/_PluginProject b/test-suite/plugin-demo/_PluginProject.in similarity index 81% rename from test-suite/plugin-demo/_PluginProject rename to test-suite/plugin-demo/_PluginProject.in index 3b643ec16..7d540d1a4 100644 --- a/test-suite/plugin-demo/_PluginProject +++ b/test-suite/plugin-demo/_PluginProject.in @@ -1,6 +1,4 @@ -generate-meta-for-package coq-metacoq-demo-plugin --R ../../template-coq/theories MetaCoq.Template --I ../../template-coq/ -I src -I gen-src diff --git a/test-suite/plugin-demo/theories/Extraction.v b/test-suite/plugin-demo/theories/Extraction.v index 2c4d5289e..2f4d22013 100644 --- a/test-suite/plugin-demo/theories/Extraction.v +++ b/test-suite/plugin-demo/theories/Extraction.v @@ -1,4 +1,4 @@ -Require Import Template.Extraction. +From MetaCoq Require Import Template.Extraction. Require Import Lens MyPlugin. Set Warnings "-extraction-opaque-accessed". diff --git a/test-suite/safechecker_test.v b/test-suite/safechecker_test.v index 616866b7f..863b120af 100644 --- a/test-suite/safechecker_test.v +++ b/test-suite/safechecker_test.v @@ -29,6 +29,7 @@ Definition bignat : nat := Nat.of_num_uint 10000%uint. MetaCoq SafeCheck bignat. MetaCoq CoqCheck bignat. +Set Warnings "-notation-overriden". From MetaCoq.TestSuite Require Import hott_example. MetaCoq SafeCheck @issect'. diff --git a/test-suite/self_erasure.v b/test-suite/self_erasure.v index 9f0718618..3d37be9e7 100644 --- a/test-suite/self_erasure.v +++ b/test-suite/self_erasure.v @@ -1,7 +1,5 @@ From MetaCoq.Erasure Require Import Loader Erasure. From MetaCoq.SafeChecker Require Import PCUICSafeChecker. Set MetaCoq Timing. -(* <1sec *) MetaCoq Fast Erase @erase_and_print_template_program. -(* 2sec *) MetaCoq Fast Erase @typecheck_program. diff --git a/translations/MiniHoTT.v b/translations/MiniHoTT.v index bbb3a6ef3..b83923b0f 100644 --- a/translations/MiniHoTT.v +++ b/translations/MiniHoTT.v @@ -1,4 +1,4 @@ - +Set Warnings "-notation-overridden". Local Set Primitive Projections. Record sigT {A} (P : A -> Type) : Type := existT @@ -93,6 +93,11 @@ Ltac transitivity x := etransitivity x. Notation idmap := (fun x => x). +Declare Scope equiv_scope. +Declare Scope path_scope. +Declare Scope fibration_scope. +Declare Scope trunc_scope. + Delimit Scope equiv_scope with equiv. Delimit Scope function_scope with function. Delimit Scope path_scope with path. @@ -134,7 +139,7 @@ Notation "g 'o' f" := (compose g%function f%function) (at level 40, left associa Definition composeD {A B C} (g : forall b, C b) (f : A -> B) := fun x : A => g (f x). Global Arguments composeD {A B C}%type_scope (g f)%function_scope x. #[global] -Hint Unfold composeD. +Hint Unfold composeD : core. Notation "g 'oD' f" := (composeD g f) (at level 40, left associativity) : function_scope. Notation "x = y :> A" := (paths A x y) : type_scope. @@ -266,8 +271,7 @@ Arguments center A {_}. Class Funext := { isequiv_apD10 : forall (A : Type) (P : A -> Type) f g, IsEquiv (@apD10 A P f g) }. -#[global] -Existing Instance isequiv_apD10. +Global Existing Instance isequiv_apD10. Definition path_forall `{Funext} {A : Type} {P : A -> Type} (f g : forall x : A, P x) : f == g -> f = g := (@apD10 A P f g)^-1. @@ -3040,8 +3044,7 @@ Definition equiv_path_sigma `(P : A -> Type) (u v : sigT P) := BuildEquiv _ _ (path_sigma_uncurried P u v) _. (* A contravariant version of [isequiv_path_sigma'] *) -#[global] -Instance isequiv_path_sigma_contra `{P : A -> Type} {u v : sigT P} +Global Instance isequiv_path_sigma_contra `{P : A -> Type} {u v : sigT P} : IsEquiv (path_sigma_uncurried_contra P u v) | 0. unshelve eapply (isequiv_adjointify (path_sigma_uncurried_contra P u v)). - intros []. exists 1. reflexivity. diff --git a/translations/MiniHoTT_paths.v b/translations/MiniHoTT_paths.v index db69119fb..7d910b9a1 100644 --- a/translations/MiniHoTT_paths.v +++ b/translations/MiniHoTT_paths.v @@ -1,4 +1,4 @@ - +Set Warnings "-notation-overridden". Local Set Primitive Projections. Record sigT {A} (P : A -> Type) : Type := existT @@ -33,18 +33,17 @@ Defined. (* *********************************************** *) - Arguments sigT {A}%type P%type. Arguments existT {A}%type P%type _ _. Arguments projT1 {A P} _ / . Arguments projT2 {A P} _ / . + Notation "'exists' x .. y , p" := (sigT (fun x => .. (sigT (fun y => p)) ..)) (at level 200, x binder, right associativity, format "'[' 'exists' '/ ' x .. y , '/ ' p ']'") : type_scope. Notation "{ x : A & P }" := (sigT (fun x:A => P)) : type_scope. - Definition relation (A : Type) := A -> A -> Type. Class Reflexive {A} (R : relation A) := @@ -97,6 +96,11 @@ Ltac transitivity x := etransitivity x. Notation idmap := (fun x => x). +Declare Scope equiv_scope. +Declare Scope path_scope. +Declare Scope fibration_scope. +Declare Scope trunc_scope. + Delimit Scope equiv_scope with equiv. Delimit Scope function_scope with function. Delimit Scope path_scope with path. diff --git a/translations/param_binary.v b/translations/param_binary.v index d148efce0..fd384daff 100644 --- a/translations/param_binary.v +++ b/translations/param_binary.v @@ -144,7 +144,7 @@ Fixpoint tsl_rec1_app (app : list term) (E : tsl_table) (t : term) : term := | tFix _ _ | tCoFix _ _ => todo "tsl" | tVar _ | tEvar _ _ => todo "tsl" | tLambda _ _ _ => tVar "impossible" - (* | tInt _ | tFloat _ => todo "impossible" *) + | tInt _ | tFloat _ => todo "tsl" end in apply app t1 end. @@ -218,6 +218,7 @@ MetaCoq Run ( tmUnquote tm' >>= tmDebug ). +Set Warnings "-unexpected-implicit-declaration". MetaCoq Run ( typ <- tmQuote (forall A B, B -> (A -> B -> B) -> B) ;; typ' <- tmEval all (tsl_rec1 [] typ) ;; diff --git a/translations/param_generous_packed.v b/translations/param_generous_packed.v index 29fe231d4..f4de49607 100644 --- a/translations/param_generous_packed.v +++ b/translations/param_generous_packed.v @@ -1,4 +1,5 @@ (* Distributed under the terms of the MIT license. *) +Set Warnings "-notation-overridden". From MetaCoq.Template Require Import utils Checker All. From MetaCoq.Translations Require Import translation_utils MiniHoTT_paths. diff --git a/translations/param_original.v b/translations/param_original.v index 4204c4226..63a1c8e03 100644 --- a/translations/param_original.v +++ b/translations/param_original.v @@ -105,7 +105,7 @@ Fixpoint tsl_rec1_app (app : option term) (E : tsl_table) (t : term) : term := | tFix _ _ | tCoFix _ _ => todo "tsl" | tVar _ | tEvar _ _ => todo "tsl" | tLambda _ _ _ => tVar "impossible" - (* | tInt _ | tFloat _ => todo "impossible" *) + | tInt _ | tFloat _ => todo "tsl" end in match app with Some t' => mkApp t1 (t' {3 := tRel 1} {2 := tRel 0}) | None => t1 end diff --git a/translations/standard_model.v b/translations/standard_model.v index 1d53656b9..7641f3e37 100644 --- a/translations/standard_model.v +++ b/translations/standard_model.v @@ -89,7 +89,6 @@ with tsl_ctx (ΣE : tsl_context) (Γ : context) {struct Γ} : tsl_result term := end. - #[global] Instance param : Translation := {| tsl_id := tsl_ident ; diff --git a/translations/times_bool_fun.v b/translations/times_bool_fun.v index 1696a9867..3f8164067 100644 --- a/translations/times_bool_fun.v +++ b/translations/times_bool_fun.v @@ -1,4 +1,6 @@ (* Distributed under the terms of the MIT license. *) +Set Warnings "-notation-overridden". + From MetaCoq.Template Require Import utils All Checker. From MetaCoq.Translations Require Import translation_utils MiniHoTT. Import MCMonadNotation. @@ -12,6 +14,7 @@ Arguments π1 {_ _} _. Arguments π2 {_ _} _. Arguments pair {_ _} _ _. +Declare Scope prod_scope. Notation "( x ; y )" := (pair x y) : prod_scope. Notation " A × B " := (prod A B) : type_scope. Open Scope prod_scope. @@ -37,8 +40,7 @@ Definition pairTrue typ tm := tApp tpair [typ; tbool; tm; ttrue]. Local Instance tit : config.checker_flags := config.type_in_type. -#[global] -Existing Instance Checker.default_fuel. +Local Existing Instance Checker.default_fuel. Fixpoint tsl_rec (fuel : nat) (Σ : global_env_ext) (E : tsl_table) (Γ : context) (t : term) {struct fuel} : tsl_result term := @@ -217,8 +219,7 @@ Fixpoint refresh_universes (t : term) {struct t} := | _ => t end. -#[global] -Instance tsl_fun : Translation +Global Instance tsl_fun : Translation := {| tsl_id := tsl_ident ; tsl_tm := fun ΣE t => t' <- tsl_rec fuel (fst ΣE) (snd ΣE) [] t ;; ret (refresh_universes t'); diff --git a/translations/times_bool_fun2.v b/translations/times_bool_fun2.v index cdd8fce87..71678ef4b 100644 --- a/translations/times_bool_fun2.v +++ b/translations/times_bool_fun2.v @@ -1,4 +1,6 @@ (* Distributed under the terms of the MIT license. *) +Set Warnings "-notation-overridden". + From MetaCoq.Template Require Import utils All. Unset Universe Checking. From MetaCoq.Translations Require Import translation_utils times_bool_fun MiniHoTT.