pax_global_header00006660000000000000000000000064146015601350014513gustar00rootroot0000000000000052 comment=8656694e2bb1f6afee7b8a3b1948cb88ca7a4c70 coq-elpi-2.1.0/000077500000000000000000000000001460156013500132245ustar00rootroot00000000000000coq-elpi-2.1.0/.gitattributes000066400000000000000000000000401460156013500161110ustar00rootroot00000000000000*.elpi linguist-language=prolog coq-elpi-2.1.0/.github/000077500000000000000000000000001460156013500145645ustar00rootroot00000000000000coq-elpi-2.1.0/.github/workflows/000077500000000000000000000000001460156013500166215ustar00rootroot00000000000000coq-elpi-2.1.0/.github/workflows/doc.yml000066400000000000000000000025601460156013500201140ustar00rootroot00000000000000# This is a basic workflow to help you get started with Actions name: DOC # Controls when the action will run. Triggers the workflow on push or pull request # events but only for the master branch on: push: branches: [ master ] pull_request: branches: [ master ] jobs: build: name: Build doc runs-on: ubuntu-latest steps: - name: workaround bug run: sudo apt-get update - name: checkout uses: actions/checkout@v2 - name: setup ocaml uses: avsm/setup-ocaml@v1 with: ocaml-version: 4.10.1 - name: install deps run: | export OPAMYES=true opam repo add coq https://coq.inria.fr/opam/released opam repo add coq-dev https://coq.inria.fr/opam/core-dev opam repo add extra-dev https://coq.inria.fr/opam/extra-dev opam update opam install coq-serapi . sudo apt-get update sudo apt-get install python3-pip -y pip3 install git+https://github.com/cpitclaudel/alectryon.git@c8ab1ec - name: build doc run: opam exec -- make doc COQ_ELPI_ALREADY_INSTALLED=1 - name: Save artifact uses: actions/upload-artifact@v2 with: path: doc - name: deploy uses: JamesIves/github-pages-deploy-action@4.1.4 if: ${{ github.ref == 'refs/heads/master' }} with: branch: gh-pages folder: doc coq-elpi-2.1.0/.github/workflows/main.yml000066400000000000000000000064101460156013500202710ustar00rootroot00000000000000# This is a basic workflow to help you get started with Actions name: CI # Controls when the action will run. Triggers the workflow on push or pull request # events but only for the master branch on: push: branches: [ master ] tags: [ "v*.*.*" ] pull_request: branches: [ master ] workflow_dispatch: inputs: suite: description: "Coq OPAM suite" required: true default: "released" type: choice options: - released - extra-dev env: OPAM_SUITE: ${{ inputs.suite }} jobs: build: runs-on: ubuntu-latest strategy: matrix: coq_version: - '8.19' ocaml_version: - '4.14-flambda' steps: - uses: actions/checkout@v2 - uses: coq-community/docker-coq-action@v1 with: opam_file: './coq-elpi.opam' coq_version: ${{ matrix.coq_version }} ocaml_version: ${{ matrix.ocaml_version }} export: 'OPAMWITHTEST' install: | startGroup "Install dependencies" opam pin add -n -y -k path $PACKAGE $WORKDIR opam update -y opam install -y -j 2 $PACKAGE --deps-only endGroup env: OPAMWITHTEST: 'true' play: runs-on: ubuntu-latest steps: - uses: actions/checkout@v2 - uses: avsm/setup-ocaml@v2 with: ocaml-compiler: 5.1.x - run: | opam install ./coq-elpi.opam release: runs-on: ubuntu-latest if: startsWith(github.ref, 'refs/tags/') #needs: [build] steps: - name: Checkout uses: actions/checkout@v3 - name: Inject slug/short variables uses: rlespinasse/github-slug-action@v4 - name: Create archive run: | VERSION="${GITHUB_REF_NAME_SLUG#v}" git archive -o coq-elpi-$VERSION.tar.gz --prefix=coq-elpi-$VERSION/ $GITHUB_SHA . - name: Release uses: softprops/action-gh-release@v1 with: files: coq-elpi-*.tar.gz fail_on_unmatched_files: true prerelease: true generate_release_notes: true name: Coq-Elpi ${{ github.ref }} for Coq XXX - name: Use OCaml 4.14.x uses: avsm/setup-ocaml@v2 with: ocaml-compiler: 4.14.x opam-local-packages: | !coq-elpi.opam - name: Write PAT env: OPAM_PUBLISH_TOKEN: ${{ secrets.OPAM_PUBLISH_TOKEN }} run: | mkdir -p ~/.opam/plugins/opam-publish printf "$OPAM_PUBLISH_TOKEN" > ~/.opam/plugins/opam-publish/coqelpibot.token - name: Setup SSH uses: webfactory/ssh-agent@v0.8.0 with: ssh-private-key: ${{ secrets.BOT_SSH_KEY }} - name: Install opam-publish # 2.0.3 because more recent versions do not respect OPAMYES run: opam install -y -j 2 opam-publish=2.0.3 - name: Publish run: | eval $(opam env) git config --global user.name coqelpibot git config --global user.email coqelpibot@inria.fr TAG=`git tag --sort=-v:refname|head -1` opam-publish --tag=$TAG --packages-directory=${OPAM_SUITE:-released}/packages --repo=coq/opam --no-browser -v ${TAG##v} https://github.com/LPCIC/coq-elpi/releases/download/$TAG/coq-elpi-${TAG##v}.tar.gz coq-elpi-2.1.0/.github/workflows/nix-action-coq-8.19.yml000066400000000000000000001433001460156013500225730ustar00rootroot00000000000000jobs: coq: needs: [] runs-on: ubuntu-latest steps: - name: Determine which commit to initially checkout run: "if [ ${{ github.event_name }} = \"push\" ]; then\n echo \"target_commit=${{\ \ github.sha }}\" >> $GITHUB_ENV\nelse\n echo \"target_commit=${{ github.event.pull_request.head.sha\ \ }}\" >> $GITHUB_ENV\nfi\n" - name: Git checkout uses: actions/checkout@v3 with: fetch-depth: 0 ref: ${{ env.target_commit }} - 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 mergeable=$(git merge --no-commit --no-ff ${{ github.event.pull_request.base.sha\ \ }} > /dev/null 2>&1; echo $?; git merge --abort > /dev/null 2>&1 || true)\n\ \ if [ -z \"$merge_commit\" -o \"x$mergeable\" != \"x0\" ]; 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@v3 with: fetch-depth: 0 ref: ${{ env.tested_commit }} - name: Cachix install uses: cachix/install-nix-action@v20 with: nix_path: nixpkgs=channel:nixpkgs-unstable - name: Cachix setup coq-elpi uses: cachix/cachix-action@v12 with: authToken: ${{ secrets.CACHIX_AUTH_TOKEN }} extraPullNames: coq, coq-community, math-comp name: coq-elpi - 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-8.19\" --argstr job \"coq\" \\\n --dry-run 2>&1 > /dev/null)\n\ echo $nb_dry_run\necho status=$(echo $nb_dry_run | grep \"built:\" | sed \"\ s/.*/built/\") >> $GITHUB_OUTPUT\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-8.19" --argstr job "coq" coq-elpi: needs: - coq runs-on: ubuntu-latest steps: - name: Determine which commit to initially checkout run: "if [ ${{ github.event_name }} = \"push\" ]; then\n echo \"target_commit=${{\ \ github.sha }}\" >> $GITHUB_ENV\nelse\n echo \"target_commit=${{ github.event.pull_request.head.sha\ \ }}\" >> $GITHUB_ENV\nfi\n" - name: Git checkout uses: actions/checkout@v3 with: fetch-depth: 0 ref: ${{ env.target_commit }} - 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 mergeable=$(git merge --no-commit --no-ff ${{ github.event.pull_request.base.sha\ \ }} > /dev/null 2>&1; echo $?; git merge --abort > /dev/null 2>&1 || true)\n\ \ if [ -z \"$merge_commit\" -o \"x$mergeable\" != \"x0\" ]; 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@v3 with: fetch-depth: 0 ref: ${{ env.tested_commit }} - name: Cachix install uses: cachix/install-nix-action@v20 with: nix_path: nixpkgs=channel:nixpkgs-unstable - name: Cachix setup coq-elpi uses: cachix/cachix-action@v12 with: authToken: ${{ secrets.CACHIX_AUTH_TOKEN }} extraPullNames: coq, coq-community, math-comp name: coq-elpi - id: stepCheck name: Checking presence of CI target coq-elpi run: "nb_dry_run=$(NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link \\\n --argstr\ \ bundle \"coq-8.19\" --argstr job \"coq-elpi\" \\\n --dry-run 2>&1 > /dev/null)\n\ echo $nb_dry_run\necho status=$(echo $nb_dry_run | grep \"built:\" | sed \"\ s/.*/built/\") >> $GITHUB_OUTPUT\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-8.19" --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-8.19" --argstr job "coq-elpi" hierarchy-builder: needs: - coq - coq-elpi runs-on: ubuntu-latest steps: - name: Determine which commit to initially checkout run: "if [ ${{ github.event_name }} = \"push\" ]; then\n echo \"target_commit=${{\ \ github.sha }}\" >> $GITHUB_ENV\nelse\n echo \"target_commit=${{ github.event.pull_request.head.sha\ \ }}\" >> $GITHUB_ENV\nfi\n" - name: Git checkout uses: actions/checkout@v3 with: fetch-depth: 0 ref: ${{ env.target_commit }} - 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 mergeable=$(git merge --no-commit --no-ff ${{ github.event.pull_request.base.sha\ \ }} > /dev/null 2>&1; echo $?; git merge --abort > /dev/null 2>&1 || true)\n\ \ if [ -z \"$merge_commit\" -o \"x$mergeable\" != \"x0\" ]; 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@v3 with: fetch-depth: 0 ref: ${{ env.tested_commit }} - name: Cachix install uses: cachix/install-nix-action@v20 with: nix_path: nixpkgs=channel:nixpkgs-unstable - name: Cachix setup coq-elpi uses: cachix/cachix-action@v12 with: authToken: ${{ secrets.CACHIX_AUTH_TOKEN }} extraPullNames: coq, coq-community, math-comp name: coq-elpi - id: stepCheck name: Checking presence of CI target hierarchy-builder run: "nb_dry_run=$(NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link \\\n --argstr\ \ bundle \"coq-8.19\" --argstr job \"hierarchy-builder\" \\\n --dry-run\ \ 2>&1 > /dev/null)\necho $nb_dry_run\necho status=$(echo $nb_dry_run | grep\ \ \"built:\" | sed \"s/.*/built/\") >> $GITHUB_OUTPUT\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-8.19" --argstr job "coq" - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: coq-elpi' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-8.19" --argstr job "coq-elpi" - 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-8.19" --argstr job "hierarchy-builder" mathcomp: needs: - coq - mathcomp-ssreflect - mathcomp-fingroup - mathcomp-algebra - mathcomp-solvable - mathcomp-field - mathcomp-character - hierarchy-builder runs-on: ubuntu-latest steps: - name: Determine which commit to initially checkout run: "if [ ${{ github.event_name }} = \"push\" ]; then\n echo \"target_commit=${{\ \ github.sha }}\" >> $GITHUB_ENV\nelse\n echo \"target_commit=${{ github.event.pull_request.head.sha\ \ }}\" >> $GITHUB_ENV\nfi\n" - name: Git checkout uses: actions/checkout@v3 with: fetch-depth: 0 ref: ${{ env.target_commit }} - 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 mergeable=$(git merge --no-commit --no-ff ${{ github.event.pull_request.base.sha\ \ }} > /dev/null 2>&1; echo $?; git merge --abort > /dev/null 2>&1 || true)\n\ \ if [ -z \"$merge_commit\" -o \"x$mergeable\" != \"x0\" ]; 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@v3 with: fetch-depth: 0 ref: ${{ env.tested_commit }} - name: Cachix install uses: cachix/install-nix-action@v20 with: nix_path: nixpkgs=channel:nixpkgs-unstable - name: Cachix setup coq-elpi uses: cachix/cachix-action@v12 with: authToken: ${{ secrets.CACHIX_AUTH_TOKEN }} extraPullNames: coq, coq-community, math-comp name: coq-elpi - id: stepCheck name: Checking presence of CI target mathcomp run: "nb_dry_run=$(NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link \\\n --argstr\ \ bundle \"coq-8.19\" --argstr job \"mathcomp\" \\\n --dry-run 2>&1 > /dev/null)\n\ echo $nb_dry_run\necho status=$(echo $nb_dry_run | grep \"built:\" | sed \"\ s/.*/built/\") >> $GITHUB_OUTPUT\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-8.19" --argstr job "coq" - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: mathcomp-ssreflect' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-8.19" --argstr job "mathcomp-ssreflect" - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: mathcomp-fingroup' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-8.19" --argstr job "mathcomp-fingroup" - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: mathcomp-algebra' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-8.19" --argstr job "mathcomp-algebra" - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: mathcomp-solvable' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-8.19" --argstr job "mathcomp-solvable" - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: mathcomp-field' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-8.19" --argstr job "mathcomp-field" - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: mathcomp-character' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-8.19" --argstr job "mathcomp-character" - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: hierarchy-builder' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-8.19" --argstr job "hierarchy-builder" - 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-8.19" --argstr job "mathcomp" mathcomp-algebra: needs: - coq - mathcomp-ssreflect - mathcomp-fingroup - hierarchy-builder runs-on: ubuntu-latest steps: - name: Determine which commit to initially checkout run: "if [ ${{ github.event_name }} = \"push\" ]; then\n echo \"target_commit=${{\ \ github.sha }}\" >> $GITHUB_ENV\nelse\n echo \"target_commit=${{ github.event.pull_request.head.sha\ \ }}\" >> $GITHUB_ENV\nfi\n" - name: Git checkout uses: actions/checkout@v3 with: fetch-depth: 0 ref: ${{ env.target_commit }} - 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 mergeable=$(git merge --no-commit --no-ff ${{ github.event.pull_request.base.sha\ \ }} > /dev/null 2>&1; echo $?; git merge --abort > /dev/null 2>&1 || true)\n\ \ if [ -z \"$merge_commit\" -o \"x$mergeable\" != \"x0\" ]; 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@v3 with: fetch-depth: 0 ref: ${{ env.tested_commit }} - name: Cachix install uses: cachix/install-nix-action@v20 with: nix_path: nixpkgs=channel:nixpkgs-unstable - name: Cachix setup coq-elpi uses: cachix/cachix-action@v12 with: authToken: ${{ secrets.CACHIX_AUTH_TOKEN }} extraPullNames: coq, coq-community, math-comp name: coq-elpi - id: stepCheck name: Checking presence of CI target mathcomp-algebra run: "nb_dry_run=$(NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link \\\n --argstr\ \ bundle \"coq-8.19\" --argstr job \"mathcomp-algebra\" \\\n --dry-run 2>&1\ \ > /dev/null)\necho $nb_dry_run\necho status=$(echo $nb_dry_run | grep \"\ built:\" | sed \"s/.*/built/\") >> $GITHUB_OUTPUT\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-8.19" --argstr job "coq" - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: mathcomp-ssreflect' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-8.19" --argstr job "mathcomp-ssreflect" - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: mathcomp-fingroup' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-8.19" --argstr job "mathcomp-fingroup" - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: hierarchy-builder' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-8.19" --argstr job "hierarchy-builder" - 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-8.19" --argstr job "mathcomp-algebra" mathcomp-analysis: needs: - coq - mathcomp-classical - mathcomp-field - mathcomp-bigenough - hierarchy-builder runs-on: ubuntu-latest steps: - name: Determine which commit to initially checkout run: "if [ ${{ github.event_name }} = \"push\" ]; then\n echo \"target_commit=${{\ \ github.sha }}\" >> $GITHUB_ENV\nelse\n echo \"target_commit=${{ github.event.pull_request.head.sha\ \ }}\" >> $GITHUB_ENV\nfi\n" - name: Git checkout uses: actions/checkout@v3 with: fetch-depth: 0 ref: ${{ env.target_commit }} - 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 mergeable=$(git merge --no-commit --no-ff ${{ github.event.pull_request.base.sha\ \ }} > /dev/null 2>&1; echo $?; git merge --abort > /dev/null 2>&1 || true)\n\ \ if [ -z \"$merge_commit\" -o \"x$mergeable\" != \"x0\" ]; 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@v3 with: fetch-depth: 0 ref: ${{ env.tested_commit }} - name: Cachix install uses: cachix/install-nix-action@v20 with: nix_path: nixpkgs=channel:nixpkgs-unstable - name: Cachix setup coq-elpi uses: cachix/cachix-action@v12 with: authToken: ${{ secrets.CACHIX_AUTH_TOKEN }} extraPullNames: coq, coq-community, math-comp name: coq-elpi - id: stepCheck name: Checking presence of CI target mathcomp-analysis run: "nb_dry_run=$(NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link \\\n --argstr\ \ bundle \"coq-8.19\" --argstr job \"mathcomp-analysis\" \\\n --dry-run\ \ 2>&1 > /dev/null)\necho $nb_dry_run\necho status=$(echo $nb_dry_run | grep\ \ \"built:\" | sed \"s/.*/built/\") >> $GITHUB_OUTPUT\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-8.19" --argstr job "coq" - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: mathcomp-classical' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-8.19" --argstr job "mathcomp-classical" - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: mathcomp-field' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-8.19" --argstr job "mathcomp-field" - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: mathcomp-bigenough' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-8.19" --argstr job "mathcomp-bigenough" - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: hierarchy-builder' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-8.19" --argstr job "hierarchy-builder" - 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-8.19" --argstr job "mathcomp-analysis" mathcomp-bigenough: needs: - coq - mathcomp-ssreflect runs-on: ubuntu-latest steps: - name: Determine which commit to initially checkout run: "if [ ${{ github.event_name }} = \"push\" ]; then\n echo \"target_commit=${{\ \ github.sha }}\" >> $GITHUB_ENV\nelse\n echo \"target_commit=${{ github.event.pull_request.head.sha\ \ }}\" >> $GITHUB_ENV\nfi\n" - name: Git checkout uses: actions/checkout@v3 with: fetch-depth: 0 ref: ${{ env.target_commit }} - 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 mergeable=$(git merge --no-commit --no-ff ${{ github.event.pull_request.base.sha\ \ }} > /dev/null 2>&1; echo $?; git merge --abort > /dev/null 2>&1 || true)\n\ \ if [ -z \"$merge_commit\" -o \"x$mergeable\" != \"x0\" ]; 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@v3 with: fetch-depth: 0 ref: ${{ env.tested_commit }} - name: Cachix install uses: cachix/install-nix-action@v20 with: nix_path: nixpkgs=channel:nixpkgs-unstable - name: Cachix setup coq-elpi uses: cachix/cachix-action@v12 with: authToken: ${{ secrets.CACHIX_AUTH_TOKEN }} extraPullNames: coq, coq-community, math-comp name: coq-elpi - id: stepCheck name: Checking presence of CI target mathcomp-bigenough run: "nb_dry_run=$(NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link \\\n --argstr\ \ bundle \"coq-8.19\" --argstr job \"mathcomp-bigenough\" \\\n --dry-run\ \ 2>&1 > /dev/null)\necho $nb_dry_run\necho status=$(echo $nb_dry_run | grep\ \ \"built:\" | sed \"s/.*/built/\") >> $GITHUB_OUTPUT\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-8.19" --argstr job "coq" - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: mathcomp-ssreflect' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-8.19" --argstr job "mathcomp-ssreflect" - 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-8.19" --argstr job "mathcomp-bigenough" mathcomp-character: needs: - coq - mathcomp-ssreflect - mathcomp-fingroup - mathcomp-algebra - mathcomp-solvable - mathcomp-field - hierarchy-builder runs-on: ubuntu-latest steps: - name: Determine which commit to initially checkout run: "if [ ${{ github.event_name }} = \"push\" ]; then\n echo \"target_commit=${{\ \ github.sha }}\" >> $GITHUB_ENV\nelse\n echo \"target_commit=${{ github.event.pull_request.head.sha\ \ }}\" >> $GITHUB_ENV\nfi\n" - name: Git checkout uses: actions/checkout@v3 with: fetch-depth: 0 ref: ${{ env.target_commit }} - 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 mergeable=$(git merge --no-commit --no-ff ${{ github.event.pull_request.base.sha\ \ }} > /dev/null 2>&1; echo $?; git merge --abort > /dev/null 2>&1 || true)\n\ \ if [ -z \"$merge_commit\" -o \"x$mergeable\" != \"x0\" ]; 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@v3 with: fetch-depth: 0 ref: ${{ env.tested_commit }} - name: Cachix install uses: cachix/install-nix-action@v20 with: nix_path: nixpkgs=channel:nixpkgs-unstable - name: Cachix setup coq-elpi uses: cachix/cachix-action@v12 with: authToken: ${{ secrets.CACHIX_AUTH_TOKEN }} extraPullNames: coq, coq-community, math-comp name: coq-elpi - id: stepCheck name: Checking presence of CI target mathcomp-character run: "nb_dry_run=$(NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link \\\n --argstr\ \ bundle \"coq-8.19\" --argstr job \"mathcomp-character\" \\\n --dry-run\ \ 2>&1 > /dev/null)\necho $nb_dry_run\necho status=$(echo $nb_dry_run | grep\ \ \"built:\" | sed \"s/.*/built/\") >> $GITHUB_OUTPUT\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-8.19" --argstr job "coq" - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: mathcomp-ssreflect' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-8.19" --argstr job "mathcomp-ssreflect" - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: mathcomp-fingroup' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-8.19" --argstr job "mathcomp-fingroup" - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: mathcomp-algebra' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-8.19" --argstr job "mathcomp-algebra" - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: mathcomp-solvable' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-8.19" --argstr job "mathcomp-solvable" - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: mathcomp-field' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-8.19" --argstr job "mathcomp-field" - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: hierarchy-builder' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-8.19" --argstr job "hierarchy-builder" - 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-8.19" --argstr job "mathcomp-character" mathcomp-classical: needs: - coq - mathcomp-algebra - mathcomp-finmap - hierarchy-builder runs-on: ubuntu-latest steps: - name: Determine which commit to initially checkout run: "if [ ${{ github.event_name }} = \"push\" ]; then\n echo \"target_commit=${{\ \ github.sha }}\" >> $GITHUB_ENV\nelse\n echo \"target_commit=${{ github.event.pull_request.head.sha\ \ }}\" >> $GITHUB_ENV\nfi\n" - name: Git checkout uses: actions/checkout@v3 with: fetch-depth: 0 ref: ${{ env.target_commit }} - 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 mergeable=$(git merge --no-commit --no-ff ${{ github.event.pull_request.base.sha\ \ }} > /dev/null 2>&1; echo $?; git merge --abort > /dev/null 2>&1 || true)\n\ \ if [ -z \"$merge_commit\" -o \"x$mergeable\" != \"x0\" ]; 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@v3 with: fetch-depth: 0 ref: ${{ env.tested_commit }} - name: Cachix install uses: cachix/install-nix-action@v20 with: nix_path: nixpkgs=channel:nixpkgs-unstable - name: Cachix setup coq-elpi uses: cachix/cachix-action@v12 with: authToken: ${{ secrets.CACHIX_AUTH_TOKEN }} extraPullNames: coq, coq-community, math-comp name: coq-elpi - id: stepCheck name: Checking presence of CI target mathcomp-classical run: "nb_dry_run=$(NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link \\\n --argstr\ \ bundle \"coq-8.19\" --argstr job \"mathcomp-classical\" \\\n --dry-run\ \ 2>&1 > /dev/null)\necho $nb_dry_run\necho status=$(echo $nb_dry_run | grep\ \ \"built:\" | sed \"s/.*/built/\") >> $GITHUB_OUTPUT\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-8.19" --argstr job "coq" - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: mathcomp-algebra' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-8.19" --argstr job "mathcomp-algebra" - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: mathcomp-finmap' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-8.19" --argstr job "mathcomp-finmap" - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: hierarchy-builder' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-8.19" --argstr job "hierarchy-builder" - 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-8.19" --argstr job "mathcomp-classical" mathcomp-field: needs: - coq - mathcomp-ssreflect - mathcomp-fingroup - mathcomp-algebra - mathcomp-solvable - hierarchy-builder runs-on: ubuntu-latest steps: - name: Determine which commit to initially checkout run: "if [ ${{ github.event_name }} = \"push\" ]; then\n echo \"target_commit=${{\ \ github.sha }}\" >> $GITHUB_ENV\nelse\n echo \"target_commit=${{ github.event.pull_request.head.sha\ \ }}\" >> $GITHUB_ENV\nfi\n" - name: Git checkout uses: actions/checkout@v3 with: fetch-depth: 0 ref: ${{ env.target_commit }} - 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 mergeable=$(git merge --no-commit --no-ff ${{ github.event.pull_request.base.sha\ \ }} > /dev/null 2>&1; echo $?; git merge --abort > /dev/null 2>&1 || true)\n\ \ if [ -z \"$merge_commit\" -o \"x$mergeable\" != \"x0\" ]; 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@v3 with: fetch-depth: 0 ref: ${{ env.tested_commit }} - name: Cachix install uses: cachix/install-nix-action@v20 with: nix_path: nixpkgs=channel:nixpkgs-unstable - name: Cachix setup coq-elpi uses: cachix/cachix-action@v12 with: authToken: ${{ secrets.CACHIX_AUTH_TOKEN }} extraPullNames: coq, coq-community, math-comp name: coq-elpi - id: stepCheck name: Checking presence of CI target mathcomp-field run: "nb_dry_run=$(NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link \\\n --argstr\ \ bundle \"coq-8.19\" --argstr job \"mathcomp-field\" \\\n --dry-run 2>&1\ \ > /dev/null)\necho $nb_dry_run\necho status=$(echo $nb_dry_run | grep \"\ built:\" | sed \"s/.*/built/\") >> $GITHUB_OUTPUT\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-8.19" --argstr job "coq" - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: mathcomp-ssreflect' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-8.19" --argstr job "mathcomp-ssreflect" - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: mathcomp-fingroup' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-8.19" --argstr job "mathcomp-fingroup" - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: mathcomp-algebra' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-8.19" --argstr job "mathcomp-algebra" - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: mathcomp-solvable' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-8.19" --argstr job "mathcomp-solvable" - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: hierarchy-builder' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-8.19" --argstr job "hierarchy-builder" - 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-8.19" --argstr job "mathcomp-field" mathcomp-fingroup: needs: - coq - mathcomp-ssreflect - hierarchy-builder runs-on: ubuntu-latest steps: - name: Determine which commit to initially checkout run: "if [ ${{ github.event_name }} = \"push\" ]; then\n echo \"target_commit=${{\ \ github.sha }}\" >> $GITHUB_ENV\nelse\n echo \"target_commit=${{ github.event.pull_request.head.sha\ \ }}\" >> $GITHUB_ENV\nfi\n" - name: Git checkout uses: actions/checkout@v3 with: fetch-depth: 0 ref: ${{ env.target_commit }} - 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 mergeable=$(git merge --no-commit --no-ff ${{ github.event.pull_request.base.sha\ \ }} > /dev/null 2>&1; echo $?; git merge --abort > /dev/null 2>&1 || true)\n\ \ if [ -z \"$merge_commit\" -o \"x$mergeable\" != \"x0\" ]; 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@v3 with: fetch-depth: 0 ref: ${{ env.tested_commit }} - name: Cachix install uses: cachix/install-nix-action@v20 with: nix_path: nixpkgs=channel:nixpkgs-unstable - name: Cachix setup coq-elpi uses: cachix/cachix-action@v12 with: authToken: ${{ secrets.CACHIX_AUTH_TOKEN }} extraPullNames: coq, coq-community, math-comp name: coq-elpi - id: stepCheck name: Checking presence of CI target mathcomp-fingroup run: "nb_dry_run=$(NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link \\\n --argstr\ \ bundle \"coq-8.19\" --argstr job \"mathcomp-fingroup\" \\\n --dry-run\ \ 2>&1 > /dev/null)\necho $nb_dry_run\necho status=$(echo $nb_dry_run | grep\ \ \"built:\" | sed \"s/.*/built/\") >> $GITHUB_OUTPUT\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-8.19" --argstr job "coq" - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: mathcomp-ssreflect' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-8.19" --argstr job "mathcomp-ssreflect" - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: hierarchy-builder' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-8.19" --argstr job "hierarchy-builder" - 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-8.19" --argstr job "mathcomp-fingroup" mathcomp-finmap: needs: - coq - mathcomp-ssreflect runs-on: ubuntu-latest steps: - name: Determine which commit to initially checkout run: "if [ ${{ github.event_name }} = \"push\" ]; then\n echo \"target_commit=${{\ \ github.sha }}\" >> $GITHUB_ENV\nelse\n echo \"target_commit=${{ github.event.pull_request.head.sha\ \ }}\" >> $GITHUB_ENV\nfi\n" - name: Git checkout uses: actions/checkout@v3 with: fetch-depth: 0 ref: ${{ env.target_commit }} - 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 mergeable=$(git merge --no-commit --no-ff ${{ github.event.pull_request.base.sha\ \ }} > /dev/null 2>&1; echo $?; git merge --abort > /dev/null 2>&1 || true)\n\ \ if [ -z \"$merge_commit\" -o \"x$mergeable\" != \"x0\" ]; 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@v3 with: fetch-depth: 0 ref: ${{ env.tested_commit }} - name: Cachix install uses: cachix/install-nix-action@v20 with: nix_path: nixpkgs=channel:nixpkgs-unstable - name: Cachix setup coq-elpi uses: cachix/cachix-action@v12 with: authToken: ${{ secrets.CACHIX_AUTH_TOKEN }} extraPullNames: coq, coq-community, math-comp name: coq-elpi - id: stepCheck name: Checking presence of CI target mathcomp-finmap run: "nb_dry_run=$(NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link \\\n --argstr\ \ bundle \"coq-8.19\" --argstr job \"mathcomp-finmap\" \\\n --dry-run 2>&1\ \ > /dev/null)\necho $nb_dry_run\necho status=$(echo $nb_dry_run | grep \"\ built:\" | sed \"s/.*/built/\") >> $GITHUB_OUTPUT\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-8.19" --argstr job "coq" - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: mathcomp-ssreflect' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-8.19" --argstr job "mathcomp-ssreflect" - 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-8.19" --argstr job "mathcomp-finmap" mathcomp-solvable: needs: - coq - mathcomp-ssreflect - mathcomp-fingroup - mathcomp-algebra - hierarchy-builder runs-on: ubuntu-latest steps: - name: Determine which commit to initially checkout run: "if [ ${{ github.event_name }} = \"push\" ]; then\n echo \"target_commit=${{\ \ github.sha }}\" >> $GITHUB_ENV\nelse\n echo \"target_commit=${{ github.event.pull_request.head.sha\ \ }}\" >> $GITHUB_ENV\nfi\n" - name: Git checkout uses: actions/checkout@v3 with: fetch-depth: 0 ref: ${{ env.target_commit }} - 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 mergeable=$(git merge --no-commit --no-ff ${{ github.event.pull_request.base.sha\ \ }} > /dev/null 2>&1; echo $?; git merge --abort > /dev/null 2>&1 || true)\n\ \ if [ -z \"$merge_commit\" -o \"x$mergeable\" != \"x0\" ]; 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@v3 with: fetch-depth: 0 ref: ${{ env.tested_commit }} - name: Cachix install uses: cachix/install-nix-action@v20 with: nix_path: nixpkgs=channel:nixpkgs-unstable - name: Cachix setup coq-elpi uses: cachix/cachix-action@v12 with: authToken: ${{ secrets.CACHIX_AUTH_TOKEN }} extraPullNames: coq, coq-community, math-comp name: coq-elpi - id: stepCheck name: Checking presence of CI target mathcomp-solvable run: "nb_dry_run=$(NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link \\\n --argstr\ \ bundle \"coq-8.19\" --argstr job \"mathcomp-solvable\" \\\n --dry-run\ \ 2>&1 > /dev/null)\necho $nb_dry_run\necho status=$(echo $nb_dry_run | grep\ \ \"built:\" | sed \"s/.*/built/\") >> $GITHUB_OUTPUT\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-8.19" --argstr job "coq" - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: mathcomp-ssreflect' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-8.19" --argstr job "mathcomp-ssreflect" - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: mathcomp-fingroup' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-8.19" --argstr job "mathcomp-fingroup" - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: mathcomp-algebra' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-8.19" --argstr job "mathcomp-algebra" - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: hierarchy-builder' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-8.19" --argstr job "hierarchy-builder" - 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-8.19" --argstr job "mathcomp-solvable" mathcomp-ssreflect: needs: - coq - hierarchy-builder runs-on: ubuntu-latest steps: - name: Determine which commit to initially checkout run: "if [ ${{ github.event_name }} = \"push\" ]; then\n echo \"target_commit=${{\ \ github.sha }}\" >> $GITHUB_ENV\nelse\n echo \"target_commit=${{ github.event.pull_request.head.sha\ \ }}\" >> $GITHUB_ENV\nfi\n" - name: Git checkout uses: actions/checkout@v3 with: fetch-depth: 0 ref: ${{ env.target_commit }} - 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 mergeable=$(git merge --no-commit --no-ff ${{ github.event.pull_request.base.sha\ \ }} > /dev/null 2>&1; echo $?; git merge --abort > /dev/null 2>&1 || true)\n\ \ if [ -z \"$merge_commit\" -o \"x$mergeable\" != \"x0\" ]; 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@v3 with: fetch-depth: 0 ref: ${{ env.tested_commit }} - name: Cachix install uses: cachix/install-nix-action@v20 with: nix_path: nixpkgs=channel:nixpkgs-unstable - name: Cachix setup coq-elpi uses: cachix/cachix-action@v12 with: authToken: ${{ secrets.CACHIX_AUTH_TOKEN }} extraPullNames: coq, coq-community, math-comp name: coq-elpi - id: stepCheck name: Checking presence of CI target mathcomp-ssreflect run: "nb_dry_run=$(NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link \\\n --argstr\ \ bundle \"coq-8.19\" --argstr job \"mathcomp-ssreflect\" \\\n --dry-run\ \ 2>&1 > /dev/null)\necho $nb_dry_run\necho status=$(echo $nb_dry_run | grep\ \ \"built:\" | sed \"s/.*/built/\") >> $GITHUB_OUTPUT\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-8.19" --argstr job "coq" - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: hierarchy-builder' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-8.19" --argstr job "hierarchy-builder" - 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-8.19" --argstr job "mathcomp-ssreflect" odd-order: needs: - coq - mathcomp-character - mathcomp-ssreflect - mathcomp-fingroup - mathcomp-algebra - mathcomp-solvable - mathcomp-field - mathcomp runs-on: ubuntu-latest steps: - name: Determine which commit to initially checkout run: "if [ ${{ github.event_name }} = \"push\" ]; then\n echo \"target_commit=${{\ \ github.sha }}\" >> $GITHUB_ENV\nelse\n echo \"target_commit=${{ github.event.pull_request.head.sha\ \ }}\" >> $GITHUB_ENV\nfi\n" - name: Git checkout uses: actions/checkout@v3 with: fetch-depth: 0 ref: ${{ env.target_commit }} - 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 mergeable=$(git merge --no-commit --no-ff ${{ github.event.pull_request.base.sha\ \ }} > /dev/null 2>&1; echo $?; git merge --abort > /dev/null 2>&1 || true)\n\ \ if [ -z \"$merge_commit\" -o \"x$mergeable\" != \"x0\" ]; 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@v3 with: fetch-depth: 0 ref: ${{ env.tested_commit }} - name: Cachix install uses: cachix/install-nix-action@v20 with: nix_path: nixpkgs=channel:nixpkgs-unstable - name: Cachix setup coq-elpi uses: cachix/cachix-action@v12 with: authToken: ${{ secrets.CACHIX_AUTH_TOKEN }} extraPullNames: coq, coq-community, math-comp name: coq-elpi - id: stepCheck name: Checking presence of CI target odd-order run: "nb_dry_run=$(NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link \\\n --argstr\ \ bundle \"coq-8.19\" --argstr job \"odd-order\" \\\n --dry-run 2>&1 > /dev/null)\n\ echo $nb_dry_run\necho status=$(echo $nb_dry_run | grep \"built:\" | sed \"\ s/.*/built/\") >> $GITHUB_OUTPUT\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-8.19" --argstr job "coq" - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: mathcomp-character' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-8.19" --argstr job "mathcomp-character" - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: mathcomp-ssreflect' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-8.19" --argstr job "mathcomp-ssreflect" - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: mathcomp-fingroup' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-8.19" --argstr job "mathcomp-fingroup" - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: mathcomp-algebra' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-8.19" --argstr job "mathcomp-algebra" - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: mathcomp-solvable' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-8.19" --argstr job "mathcomp-solvable" - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: mathcomp-field' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-8.19" --argstr job "mathcomp-field" - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: mathcomp' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-8.19" --argstr job "mathcomp" - 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-8.19" --argstr job "odd-order" name: Nix CI for bundle coq-8.19 'on': pull_request: paths: - .github/workflows/nix-action-coq-8.19.yml pull_request_target: paths-ignore: - .github/workflows/nix-action-coq-8.19.yml types: - opened - synchronize - reopened push: branches: - master coq-elpi-2.1.0/.gitignore000066400000000000000000000010301460156013500152060ustar00rootroot00000000000000*.o *.cmx *.cmo *.cmi *.a *.cmxa *.cmxs *.cma *.cmt *.cmti *.annot .*~ .*.swp *.vo *.vos *.vok *.d *.glob .*.aux *.html *.txt *.crashcoqide \#*\# etc/__pycache__/ /.deps.elpi src/coq_elpi_config.ml src/coq_elpi_vernacular_syntax.ml src/coq_elpi_arg_syntax.ml src/coq_elpi_builtins_HOAS.ml doc/ Makefile.coq Makefile.coq.conf .merlin Makefile.*.coq Makefile.*.coq.conf tests/test_glob/*.css META *.cache apps/coercion/src/coq_elpi_coercion_hook.ml .filestoinstall apps/tc/src/coq_elpi_tc_hook.ml apps/cs/src/coq_elpi_cs_hook.ml coq-elpi-2.1.0/.nix/000077500000000000000000000000001460156013500141005ustar00rootroot00000000000000coq-elpi-2.1.0/.nix/ coq-overlays/000077500000000000000000000000001460156013500167245ustar00rootroot00000000000000coq-elpi-2.1.0/.nix/ coq-overlays/mathcomp-classical /000077500000000000000000000000001460156013500225705ustar00rootroot00000000000000coq-elpi-2.1.0/.nix/ coq-overlays/mathcomp-classical /default.nix000066400000000000000000000001371460156013500247350ustar00rootroot00000000000000{ mathcomp-analysis, version ? null }: mathcomp-analysis.classical.override {inherit version;} coq-elpi-2.1.0/.nix/config.nix000066400000000000000000000016611460156013500160710ustar00rootroot00000000000000{ format = "1.0.0"; attribute = "coq-elpi"; default-bundle = "coq-8.19"; bundles = { "coq-8.19".coqPackages = { coq.override.version = "8.19+rc1"; hierarchy-builder.override.version = "master"; hierarchy-builder-shim.job = false; mathcomp.override.version = "master"; mathcomp.job = true; odd-order.override.version = "master"; odd-order.job = true; mathcomp-analysis.override.version = "master"; mathcomp-analysis.job = true; mathcomp-finmap.override.version = "master"; mathcomp-finmap.job = true; mathcomp-classical.override.version = "master"; mathcomp-classical.job = true; mathcomp-single-planB-src.job = false; mathcomp-single-planB.job = false; mathcomp-single.job = false; }; }; cachix.coq = {}; cachix.math-comp = {}; cachix.coq-community = {}; cachix.coq-elpi.authToken = "CACHIX_AUTH_TOKEN"; } coq-elpi-2.1.0/.nix/coq-nix-toolbox.nix000066400000000000000000000000531460156013500176600ustar00rootroot00000000000000"dd771a5001cd955514f2462cad7cdd90377530e3" coq-elpi-2.1.0/.nix/coq-overlays/000077500000000000000000000000001460156013500165245ustar00rootroot00000000000000coq-elpi-2.1.0/.nix/coq-overlays/coq-elpi/000077500000000000000000000000001460156013500202355ustar00rootroot00000000000000coq-elpi-2.1.0/.nix/coq-overlays/coq-elpi/default.nix000066400000000000000000000075631460156013500224140ustar00rootroot00000000000000{ lib, mkCoqDerivation, which, coq, version ? null }: with builtins; with lib; let elpi = coq.ocamlPackages.elpi.override (lib.switch coq.coq-version [ { case = "8.11"; out = { version = "1.11.4"; };} { case = "8.12"; out = { version = "1.12.0"; };} { case = "8.13"; out = { version = "1.13.7"; };} { case = "8.14"; out = { version = "1.13.7"; };} { case = "8.15"; out = { version = "1.15.0"; };} { case = "8.16"; out = { version = "1.17.0"; };} { case = "8.17"; out = { version = "1.17.0"; };} { case = "8.18"; out = { version = "v1.18.1"; };} { case = "8.19"; out = { version = "v1.18.2"; };} ] {} ); in mkCoqDerivation { pname = "elpi"; repo = "coq-elpi"; owner = "LPCIC"; inherit version; defaultVersion = lib.switch coq.coq-version [ { case = "8.18"; out = "1.19.0"; } { case = "8.17"; out = "1.18.0"; } { case = "8.16"; out = "1.15.6"; } { case = "8.15"; out = "1.14.0"; } { case = "8.14"; out = "1.11.2"; } { case = "8.13"; out = "1.11.1"; } { case = "8.12"; out = "1.8.3_8.12"; } { case = "8.11"; out = "1.6.3_8.11"; } ] null; release."1.19.0".sha256 = "sha256-kGoo61nJxeG/BqV+iQaV3iinwPStND+7+fYMxFkiKrQ="; release."1.18.0".sha256 = "sha256-2fCOlhqi4YkiL5n8SYHuc3pLH+DArf9zuMH7IhpBc2Y="; release."1.17.0".sha256 = "sha256-J8GatRKFU0ekNCG3V5dBI+FXypeHcLgC5QJYGYzFiEM="; release."1.15.6".sha256 = "sha256-qc0q01tW8NVm83801HHOBHe/7H1/F2WGDbKO6nCXfno="; release."1.15.1".sha256 = "sha256-NT2RlcIsFB9AvBhMxil4ZZIgx+KusMqDflj2HgQxsZg="; release."1.14.0".sha256 = "sha256:1v2p5dlpviwzky2i14cj7gcgf8cr0j54bdm9fl5iz1ckx60j6nvp"; release."1.13.0".sha256 = "1j7s7dlnjbw222gnbrsjgmjck1yrx7h6hwm8zikcyxi0zys17w7n"; release."1.12.1".sha256 = "sha256-4mO6/co7NcIQSGIQJyoO8lNWXr6dqz+bIYPO/G0cPkY="; release."1.11.2".sha256 = "0qk5cfh15y2zrja7267629dybd3irvxk1raz7z8qfir25a81ckd4"; release."1.11.1".sha256 = "10j076vc2hdcbm15m6s7b6xdzibgfcbzlkgjnlkr2vv9k13qf8kc"; release."1.10.1".sha256 = "1zsyx26dvj7pznfd2msl2w7zbw51q1nsdw0bdvdha6dga7ijf7xk"; release."1.9.7".sha256 = "0rvn12h9dpk9s4pxy32p8j0a1h7ib7kg98iv1cbrdg25y5vs85n1"; release."1.9.5".sha256 = "0gjdwmb6bvb5gh0a6ra48bz5fb3pr5kpxijb7a8mfydvar5i9qr6"; release."1.9.4".sha256 = "0nii7238mya74f9g6147qmpg6gv6ic9b54x5v85nb6q60d9jh0jq"; release."1.9.3".sha256 = "198irm800fx3n8n56vx1c6f626cizp1d7jfkrc6ba4iqhb62ma0z"; release."1.9.2".sha256 = "1rr2fr8vjkc0is7vh1461aidz2iwkigdkp6bqss4hhv0c3ijnn07"; release."1.8.3_8.12".sha256 = "15z2l4zy0qpw0ws7bvsmpmyv543aqghrfnl48nlwzn9q0v89p557"; release."1.8.3_8.12".version = "1.8.3"; release."1.8.2_8.12".sha256 = "1n6jwcdazvjgj8vsv2r9zgwpw5yqr5a1ndc2pwhmhqfl04b5dk4y"; release."1.8.2_8.12".version = "1.8.2"; release."1.8.1".sha256 = "1fbbdccdmr8g4wwpihzp4r2xacynjznf817lhijw6kqfav75zd0r"; release."1.8.0".sha256 = "13ywjg94zkbki22hx7s4gfm9rr87r4ghsgan23xyl3l9z8q0idd1"; release."1.7.0".sha256 = "1ws5cqr0xawv69prgygbl3q6dgglbaw0vc397h9flh90kxaqgyh8"; release."1.6.3_8.11".sha256 = "1j340cr2bv95clzzkkfmsjkklham1mj84cmiyprzwv20q89zr1hp"; release."1.6.3_8.11".version = "1.6.3"; release."1.6.2_8.11".sha256 = "06xrx0ljilwp63ik2sxxr7h617dgbch042xfcnfpy5x96br147rn"; release."1.6.2_8.11".version = "1.6.2"; release."1.6.1_8.11".sha256 = "0yyyh35i1nb3pg4hw7cak15kj4y6y9l84nwar9k1ifdsagh5zq53"; release."1.6.1_8.11".version = "1.6.1"; release."1.6.0_8.11".sha256 = "0ahxjnzmd7kl3gl38kyjqzkfgllncr2ybnw8bvgrc6iddgga7bpq"; release."1.6.0_8.11".version = "1.6.0"; release."1.6.0".sha256 = "0kf99i43mlf750fr7fric764mm495a53mg5kahnbp6zcjcxxrm0b"; releaseRev = v: "v${v}"; buildFlags = [ "OCAMLWARN=" ]; mlPlugin = true; propagatedBuildInputs = [ coq.ocamlPackages.findlib elpi ]; meta = { description = "Coq plugin embedding ELPI."; maintainers = [ maintainers.cohencyril ]; license = licenses.lgpl21Plus; }; } coq-elpi-2.1.0/.nix/coq-overlays/hierarchy-builder/000077500000000000000000000000001460156013500221265ustar00rootroot00000000000000coq-elpi-2.1.0/.nix/coq-overlays/hierarchy-builder/default.nix000066400000000000000000000023571460156013500243010ustar00rootroot00000000000000{ lib, mkCoqDerivation, which, coq, coq-elpi, version ? null, shim ? false }: with lib; mkCoqDerivation { pname = "hierarchy-builder" + optionalString shim "-shim"; owner = "math-comp"; inherit version; defaultVersion = with versions; switch coq.coq-version [ { case = range "8.13" "8.14"; out = "1.2.0"; } { case = range "8.12" "8.13"; out = "1.1.0"; } { case = isEq "8.11"; out = "0.10.0"; } ] null; release."1.2.0".sha256 = "0sk01rvvk652d86aibc8rik2m8iz7jn6mw9hh6xkbxlsvh50719d"; release."1.1.0".sha256 = "sha256-spno5ty4kU4WWiOfzoqbXF8lWlNSlySWcRReR3zE/4Q="; release."1.0.0".sha256 = "0yykygs0z6fby6vkiaiv3azy1i9yx4rqg8xdlgkwnf2284hffzpp"; release."0.10.0".sha256 = "1a3vry9nzavrlrdlq3cys3f8kpq3bz447q8c4c7lh2qal61wb32h"; releaseRev = v: "v${v}"; nativeBuildInputs = [ which ]; propagatedBuildInputs = [ coq-elpi ]; mlPlugin = true; buildPhase = "make build" + optionalString shim " -C shim"; installFlags = [ "DESTDIR=$(out)" "COQMF_COQLIB=lib/coq/${coq.coq-version}" ] ++ optional shim "-C shim"; meta = { description = "High level commands to declare a hierarchy based on packed classes"; maintainers = with maintainers; [ cohencyril siraben ]; license = licenses.mit; }; } coq-elpi-2.1.0/.nix/ocaml-overlays/000077500000000000000000000000001460156013500170355ustar00rootroot00000000000000coq-elpi-2.1.0/.nix/ocaml-overlays/elpi/000077500000000000000000000000001460156013500177665ustar00rootroot00000000000000coq-elpi-2.1.0/.nix/ocaml-overlays/elpi/default.nix000066400000000000000000000046131460156013500221360ustar00rootroot00000000000000{ lib , buildDunePackage, camlp5 , ocaml , menhir, menhirLib , atdgen , stdlib-shims , re, perl, ncurses , ppxlib, ppx_deriving , coqPackages , version ? if lib.versionAtLeast ocaml.version "4.08" then "1.17.0" else if lib.versionAtLeast ocaml.version "4.07" then "1.15.2" else "1.14.1" }: let p5 = camlp5; in let camlp5 = p5.override { legacy = true; }; in let fetched = coqPackages.metaFetch ({ release."1.17.0".sha256 = "sha256-DTxE8CvYl0et20pxueydI+WzraI6UPHMNvxyp2gU/+w="; release."1.16.5".sha256 = "sha256-tKX5/cVPoBeHiUe+qn7c5FIRYCwY0AAukN7vSd/Nz9A="; release."1.15.2".sha256 = "sha256-XgopNP83POFbMNyl2D+gY1rmqGg03o++Ngv3zJfCn2s="; release."1.15.0".sha256 = "sha256:1ngdc41sgyzyz3i3lkzjhnj66gza5h912virkh077dyv17ysb6ar"; release."1.14.1".sha256 = "sha256-BZPVL8ymjrE9kVGyf6bpc+GA2spS5JBpkUtZi04nPis="; release."1.13.7".sha256 = "10fnwz30bsvj7ii1vg4l1li5pd7n0qqmwj18snkdr5j9gk0apc1r"; release."1.13.5".sha256 = "02a6r23mximrdvs6kgv6rp0r2dgk7zynbs99nn7lphw2c4189kka"; release."1.13.1".sha256 = "12a9nbdvg9gybpw63lx3nw5wnxfznpraprb0wj3l68v1w43xq044"; release."1.13.0".sha256 = "0dmzy058m1mkndv90byjaik6lzzfk3aaac7v84mpmkv6my23bygr"; release."1.12.0".sha256 = "1agisdnaq9wrw3r73xz14yrq3wx742i6j8i5icjagqk0ypmly2is"; release."1.11.4".sha256 = "1m0jk9swcs3jcrw5yyw5343v8mgax238cjb03s8gc4wipw1fn9f5"; releaseRev = v: "v${v}"; location = { domain = "github.com"; owner = "LPCIC"; repo = "elpi"; }; }) version; in buildDunePackage rec { pname = "elpi"; inherit (fetched) version src; patches = lib.optional (version == "1.16.5") ./atd_2_10.patch; minimalOCamlVersion = "4.04"; duneVersion = "3"; # atdgen is both a library and executable nativeBuildInputs = [ perl ] ++ [ (if lib.versionAtLeast version "1.15" || version == "dev" then menhir else camlp5) ] ++ lib.optional (lib.versionAtLeast version "1.16" || version == "dev") atdgen; buildInputs = [ ncurses ] ++ lib.optional (lib.versionAtLeast version "1.16" || version == "dev") atdgen; propagatedBuildInputs = [ re stdlib-shims ] ++ [ menhirLib ] ++ [ ppxlib ppx_deriving ] ; meta = with lib; { description = "Embeddable λProlog Interpreter"; license = licenses.lgpl21Plus; maintainers = [ maintainers.vbgl ]; homepage = "https://github.com/LPCIC/elpi"; }; postPatch = '' substituteInPlace elpi_REPL.ml --replace "tput cols" "${ncurses}/bin/tput cols" ''; } coq-elpi-2.1.0/.ocamlformat000066400000000000000000000000051460156013500155240ustar00rootroot00000000000000m=120coq-elpi-2.1.0/.vscode/000077500000000000000000000000001460156013500145655ustar00rootroot00000000000000coq-elpi-2.1.0/.vscode/settings.json000066400000000000000000000017271460156013500173270ustar00rootroot00000000000000{ "files.exclude": { "**/*.o": true, "**/*.cmx": true, "**/*.cmo": true, "**/*.cmi": true, "**/*.a": true, "**/*.cmxa": true, "**/*.cmxs": true, "**/*.cma": true, "**/*.cmt": true, "**/*.cmti": true, "**/*.annot": true, "**/.*~": true, "**/.*.swp": true, "**/*.vo": true, "**/*.vos": true, "**/*.vok": true, "**/*.d": true, "**/*.glob": true, "**/.*.aux": true, "**/*.html": true, "**/*.crashcoqide": true, "**/\\#*\\#": true, ".deps.elpi": true, "src/coq_elpi_config.ml": true, "src/coq_elpi_vernacular_syntax.ml": true, "**/Makefile.coq": true, "**/Makefile.coq.conf": true, "**/.merlin": true }, "restructuredtext.confPath": "${workspaceFolder}/alectryon/recipes/sphinx", "ocaml.server.args": [ "--fallback-read-dot-merlin" ], }coq-elpi-2.1.0/Changelog.md000066400000000000000000001321471460156013500154450ustar00rootroot00000000000000# Changelog ## [2.1.0] - 29/03/2024 ### Commands - New `Elpi Accumulate dbname File filename` allows to accumulate a file int a db - Change `Elpi Db` now only creates (and initialises) a database for the specified phase ### API - New `coq.parse-attributes` support for the `attlabel` specification, see `coq-lib-common.elpi` for its documentation. - New `coq.goal->pp` - Replace `coq.replay-all-missing-synterp-actions` by (nestable) groups of actions - New `coq.begin-synterp-group` and `coq.end-synterp-group` primitives - New `coq.replay-synterp-action-group` primitive (replaces `coq.replay-all-missing-synterp-actions` in conjunction with a group) - New `coq.replay-next-synterp-actions` to replay all synterp actions until the next beginning/end of a synterp group - New `coq.primitive.projection-unfolded` to fold/unfold a primitive projection. Note that unfolded primitive projections are still compact terms, but they are displayed as `match` expressions and some Ltac code can see that. ## [2.0.2] - 01/02/2024 Requires Elpi 1.18.2 and Coq 8.19. ### API - Fix `coq.elaborate-*` does not erase the type annotation of `Let`s (regression introduced in 2.0.1). This fix may introduce differences in generated names - Fix `coq.elaborate-*` are not affected anymore by printing options ### Commands - Fix install the right initial parsing state (the one before any synterp action is re-played) ### HOAS - Fix evar instantiation loss when crossing the elpi/ltac border - Fix encoding of "definitional classes" (`Class` with no record) - Fix order of implicit arguments of `Record` ### Misc - Change requiring `elpi` does not load primitive integers nor primitive floats ### Apps - TC: avoid declaring options twice (could make vscoq2 fail) - CS: `cs` now takes a context, a term that is the projection of some structure applied to the parameters of the structure, a term to put a structure on and the solution to return ## [2.0.1] - 29/12/2023 Requires Elpi 1.18.1 and Coq 8.19. This minor release adds compatibility with Coq 8.19. ## [2.0.0] - 23/12/2023 Requires Elpi 1.18.1 and Coq 8.18. This major release accommodates for the separation of parsing from execution of Coq 8.18 enabling Coq-Elpi programs to be run efficiently (and correctly) under VSCoq 2.0. ### Documentation - New section about parsing/execution separation in the [Writing commands in Elpi](https://lpcic.github.io/coq-elpi/tutorial_coq_elpi_command.html) tutorial ### Commands - New `Elpi *` commands understand the `#[phase]` attribute, see the doc in the [README](README.md#vernacular-commands) file, and the section about the [separation of parsing from execution](README.md#separation-of-parsing-from-execution-of-vernacular-commands) - New `Elpi Export` understands an `As` clause to rename or alias a program when exported ### API - Change `coq.elpi.add-predicate` now locality can be changed - Experimental `coq.toposort` returns a valid topological ordering of the nodes of a graph - Change `coq.TC.db-for`, now instances are returned sorted wrt their priority - New `tc-priority`, contains the priority of an instance and if the priority has been given by the user or computed by `coq` - Change `tc-instance`, now the type is `gref -> tc-priority -> tc-instance` i.e. the priority is not an integer anymore - New `coq.ltac.fresh-id` to generate fresh names in the proof context - New `@no-tc!` attribute supported by `coq.ltac.call-ltac1` - New `coq.TC.get-inst-prio` returns the `tc-priority` of an instance - New `synterp-action` datatype - New `coq.replay-all-missing-synterp-actions` - New `coq.replay-synterp-action` - New `coq.next-synterp-action` - New `coq.synterp-actions` (parsing phase only) ### Apps - New `tc` app providing an implementation of a type class solver written in elpi. This app is experimental ## [1.19.3] - 12/10/2023 Requires Elpi 1.16.5 and Coq 8.18. ### Misc - Fix `Elpi Export` broken when used from VsCoq2 ### APIs - New `ltac1-tactic` opaque data type - New `tac` argument constructor - Change `coq.ltac.call-ltac1` now accepts either a string (tactic name) or a tactic expression (of type `ltac1-tactic`) - New `ltac_tactic:(...)` syntax to pass tactic expressions to Elpi tactics - New `coq.extra-dep` predicate ## [1.19.1] - 30/08/2023 Requires Elpi 1.16.5 and Coq 8.18. ### Misc - Automate release process ## [1.19.0] - 04/08/2023 Requires Elpi 1.16.5 and Coq 8.18. ### APPS - New `coercion` app providing `coercion` predicate to program coercions (thanks @proux01). This app is experimental. ### API - Removed option `@nonuniform!` as it disappears from Coq 8.18. (c.f. https://github.com/coq/coq/pull/17716 ) ## [1.18.0] - 27/07/2023 Requires Elpi 1.16.5 and Coq 8.17. ### Doc - Mention the trace browser for VSCode in the Elpi tutorial. ### API - New `coq.elpi.accumulate-clauses` takes a list of clauses which share the same DB and accumulation site - New `coq.elpi.add-predicate` to declare the signature of a new predicate into a Db - New `coq.elpi.predicate` to build a term of type `prop` out of a predicate name and arguments - Change `coq.env.global` now relates a term with a gref, instead of working one way only - Change `coq.elpi.accumulate*` generalise clauses over global universe level, and error if algebraic levels are present. It used to warn if levels were present. - New `coq.elaborate*skeleton` support the `@no-tc!` option to disable type class resolution - New `@global!` option for `coq.elpi.accumulate*` - New `coq.env.current-section-path` - New `coq.TC.db-tc` giving all type classes - New `coq.reduction.eta-contract` ### HOAS - Fix evar declarations were (rarely) generated at the wrong depth, possibly resulting in variable captures in types containing binders - Fix `assert false` in evar instantiation readback (eta contraction code was incomplete) - Fix resiliency in case a goal is closed by side effect (was raising fatal errors such as "Not a goal" or "Not a variable after goal") - Change assigning a hole linked to an evar *always* triggers type checking. This is necessary even if the term being assigned is well typed since one may still need to declare some universe constraints. - Change propagate type constraints in `Prop` inward (Coq 8.17 only). Eg. `Check (T -> _) : Prop` fails in 8.17 since `_` is assumed to be in `Type`. We propagate the constraint ourselves across `->`, `/\`, `\/` and `~`. - Quotations `{{ ... }}` are now parsed by Coq ensuring the end of input is reached. Spurious text results in a parse error. For example `{{ f ) }}` is no more accepted, as well as `{{ _.x }}` ### Vernacular - New `Elpi Print` also print the program in `.txt` format ### Runtime - Change compilation cache able to prevent most of lengthy compilations in Hierarchy-Builder for MathComp 2.0. In some cases Coq-Elpi is more picky about the order of accumulated files, in particular a file containing the spilling of a predicate `{p}` needs to be accumulated after the type or mode of `p` is declared ### APPS - `derive Inductive i {A}` now sets `A` implicit status globally - `lock Definition f {A}` now sets `A` implicit status globally ## [1.17.1] - 09/03/2023 Requires Elpi 1.16.5 and Coq 8.17. ### API: - New `coq.int->uint63` and `coq.float->float64` - Fix bug introduced in 1.17.0 affecting `coq.ltac.call-ltac1` ## [1.17.0] - 13/02/2023 Requires Elpi 1.16.5 and Coq 8.17. ### API - New `coq.modpath->library` - New `coq.modtypath->library` - Fix `coq.env.*` APIs generating inductives, definitions and modules now emit metadata in the `.glob` files so that `coqdoc` can generate hyperlinks ### APPS - Add `NES.{List,Print}`. - Support relative paths in `NES.{Open,List,Print}` (path `_.P` references top-level namespace `P`, paths without a leading `_.` are relative to the current namespace) ## [1.16.0] - 10/11/2022 Requires Elpi 1.16.5 and Coq 8.16. The main change is the `derive` app which must now be loaded by importing `derive.std` (just loading `derive` won't work). See the [new derive documentation](apps/derive). ### API - Change `coq.env.module` and `coq.env.module-type` do not fail if the module (type) contains a mutual inductive. The resulting `gref` is going to me unusable with most APIs, though. - Change `coq.env.module` returns a ADT describing the module contents - Change `coq.gref->path` and `coq.gref->id` do work on `gref` which point to mutual inductives. - New `coq.env.term-dependencies` computing all the `grefs` occurring in a term. - New `coq.redflag` and `coq.redflags` types for `@redflags!` option understood by `coq.reduction.lazy.*` `and coq.reduction.cbv.norm` - New `coq.env.fresh-global-id` ### APPS - Change `derive` usage. One should now import `From elpi.apps Require Import derive.std` - Change derivations `eq` and `eqOK` move to `derive.legacy` - New derivations `eqb` and `eqbOK` subsuming the previous ones ## [1.15.6] - 27-08-2022 Requires Elpi 1.16.5 and Coq 8.16. - Fix parse error location display for quotation code - Fix HOAS of inductives with non-uniform parameters ## [1.15.5] - 30-07-2022 Requires Elpi 1.16.5 and Coq 8.16. - Fix parse error location display for inline code - Fix HOAS of evars: pruning was not propagated to the type of the evar ## [1.15.4] - 26-07-2022 Requires Elpi 1.16.5 and Coq 8.16. - Fix lexical analysis inside quotations error location display - Fix drop of universe constraints attached to automatically generates universe levels (eg when `sort (typ X)` is passed to Coq) - Fix nix CI ## [1.15.3] - 20-07-2022 Requires Elpi 1.16.5 and Coq 8.16. - Fix parse error location display ## [1.15.2] - 19-07-2022 Requires Elpi 1.16.5 and Coq 8.16. - API: - Fix `coq.env.indt-decl` correctly handles universes in parameters of universe polymorphic inductive - Fix `coq.typecheck-indt-decl` ignores non uniform parameters to compute the universe level of the inductive - Fix `coq.elaborate-indt-decl-skeleton` ignores non uniform parameters to compute the universe level of the inductive ## [1.15.1] - 16-07-2022 Requires Elpi 1.16.5 and Coq 8.16. - API: - Fix `coq.elaborate*skeleton` does refresh universes - New `@keepunivs!` attribute to force skeleton APIs to not refresh universes. This is useful to keep a link between a universe declaration and the declaration itself but still elaborate it - Fix Coq-Elpi is reentrant when commands call tactics ## [1.15.0] - 13-07-2022 Requires Elpi 1.16.5 and Coq 8.16. The main changes are: - experimental support for universe polymorphism. One can read and write universe polymorphic terms and manipulate their constraint declarations. Terms now have a new `pglobal` term constructor, akin to `global` but for global references to universe polymorphic terms, also carrying a universe instance. The attribute `@uinstance!` can be used to pass or retrieve a universe instance to/from APIs to access the Coq environment, as in `@uinstance! I => coq.env.typeof GR Ty_at_I`. The meaning of `@uinstance! I =>` depends if `I` is an unset variable or a concrete universe instance. In the former case the API generate a fresh universe instance (for `GR`) and assign it to `I`; in the latter case it uses the provided universe instance. See [coq-builtin](coq-builtin.elpi) for the full documentation - command arguments are elaborated by Coq (unless told otherwise). As a consequence arguments can use the full Coq syntax, including deep pattern matching and tactics in terms. Raw arguments are (and will remain) available, but don't support that yet ### APPS - New experimental support for polymorphic definitions in `locker` - New example of `clearbody` tactic taking a list of names in `eltac` - Change `derive` sets, *globally*, `Uniform Inductive Parameters`. See https://coq.inria.fr/refman/language/core/inductive.html#coq:flag.Uniform-Inductive-Parameters for reference. The immediate effect is that inductive types uniform parameters don't have to be repeated in the types of the constructors (they can't vary anyway). Non-uniform parameters and indexes have to be passed, as usual. If the flag is unset by the user `Coq-Elpi` will raise a warning since inference of non-uniform parameters is not implemented ### HOAS - Change arguments to commands are elaborated by Coq by default - New attribute `#[arguments(raw)]` to get arguments in raw format (as in version 1.14 or below) - Change raw inductive declaration using `|` to mark non-uniform parameters is expected to not pass uniform parameters to the inductive type (the same behavior applies to elaborated arguments, making the two consistent) - Change `coercion` attribute for record fields now takes values `off`, `regular` or `reversible` - New `pglobal` term constructor carrying a `gref` and a `univ-instance` for universe polymorphic terms - New `upoly-indt-decl` argument type for polymorphic inductive types declarations - New `upoly-const-decl` argument type for polymorphic definitions - New `upoly-decl` data type for universe parameters declarations, i.e. the `@{u1 u2 | u1 < u2}` Coq syntax one can use for inductives or definitions - New `upoly-decl-cumul` data type for universe parameters declarations, i.e. the `@{u1 u2 | u1 < u2}` Coq syntax one can use for cumulative inductives - Rename `univ` -> `sort` i.e. `(sort S)` is a `term` and `S` can be `prop` or `(type U)` where `U` is a `univ` - New `univ-instance` opaque type to represent how a polymorphic constant is instantiated, i.e. `(pglobal GR I)` where `GR` is a `gref` and `I` a `univ-instance` - New `univ.variable` opaque type for `univ` which are not algebraic. This data type is used in `upoly-decl` and `upoly-decl-cumul` ### API - New `coq.env.indc->indt` - New `coq.env.dependencies` to compute the dependencies of a `gref` - New `coq.env.transitive-dependencies` - New `@nonuniform!` and `@reversible!` for `coq.coercion.declare` - New `@uinstance!` attribute supported by many `coq.env.*` APIs that can be used to read/write the universe instance of polymorphic constants. E.g. `@uinstance! UI => coq.env.typeof GR Ty` can instantiate `Ty` to `UI` if provided or set `UI` to a fresh instance if not - New `@udecl!` attribute to declare polymorphic constants or inductives, like the `@{u1 u2 | u1 < u2}` Coq syntax - New `@udecl-cumul!` attribute to declare polymorphic inductives, like the `@{+u1 u2 | u1 < u2}` Coq syntax - New `@univpoly!` shorter version of `@udecl!`, like the `#[universes(polymorphic)]` Coq syntax (without giving any other `@{u1 u2 | u1 < u2}` directive) - New `@univpoly-cumul!` shorter version of `@udecl-cumul!`, like the `#[universes(polymorphic,cumulative)]` Coq syntax - New `coq.env.global` API to craft a `term` from a `gref`. When used with spilling `{coq.env.global GR}` gives either `(global GR)` or `(pglobal GR I)` depending on `GR` being universe polymorphic or not. It understands the `@unistance!` attribute for both reading or setting `I` - New `coq.env.univpoly?` to tell if a `gref` is universe polymorphic and how many parameters it has - Change `coq.univ.leq` -> `coq.sort.leq` - Change `coq.univ.eq` -> `coq.sort.eq` - Change `coq.univ.sup` -> `coq.sort.sup` - New `coq.sort.pts-triple` computes the resulting `sort` of a product - New `coq.univ.constraints` gives all the universe constraints in a first class form - Change `coq.univ.new` does not take a list anymore - New `coq.univ` to find a global universe - New `coq.univ.global?` tests if a universe is global - New `coq.univ.variable` links a `univ` to a `univ.variable` (imposing an equality constraint if needed) - New `coq.univ.variable.constraints` finds all constraints talking about a variable - New `coq.univ.variable.of-term` finds all variables occurring in a term - New `coq.univ-instance` links a `univ-instance` to a list of of `univ.variable` - New `coq.univ-instance.unify-eq` unifies two `univ-instance` (for the same `gref`) - New `coq.univ-instance.unify-leq` unifies two `univ-instance` (for the same `gref`) - New `coq.univ.set` OCaml's set for `univ` - New `coq.univ.map` OCaml's map for `univ` - New `coq.univ.variable.set` OCaml's set for `univ.variable` - New `coq.univ.variable.map` OCaml's map for `univ.variable` ### Vernacular - New `Accumulate File ` to be used in tandem with Coq 8.16 `From Extra Dependency as ` ## [1.14.0] - 07-04-2022 Requires Elpi 1.15.0 and Coq 8.15. ### Vernacular - All `Elpi Bla` commands accept (and ignore with a warning) unknown attributes, to be forward compatible ## [1.13.0] - 08-02-2022 Requires Elpi 1.14.1 and Coq 8.15. ### Performance - New 1 slot cache for context read back to improve the speed of FFI calls needing to read back a large `coq_context` - New `Conversion.t` for `gref` handwritten to minimize allocations - New terms of the form `(global ...)` are now hashconsed - New `extra_goals` postprocessing removing `declare-evar/rm-evar` pairs which happen naturally writing code like `coq.unify-eq {{ f _ x }} {{ f y _ }}` (the `_` are solved immediately, no need to declare them to elpi) ### API - New `coq.hints.opaque` - New `coq.hints.set-opaque` - Change load `coq.ltac.*` also in commands (and not just tactics) so that commands can easily turn holes into goals and inhabit them calling regular tactics. - New `coq.hints.add-resolve` - Fix `coq.option.add` survives the end of a file - New `coq.env.begin-module-functor` - New `coq.env.begin-module-type-functor` - New `coq.env.apply-module-functor` - New `coq.env.apply-module-type-functor` - New `coq.inline` with constructors `coq.inline.no`, `coq.inline.at` and `coq.inline.default` - New `@inline-at! N` and `@inline!` macros - Change `coq.env.add-axiom` honors `@inline` macros ## [1.12.1] - 20-01-2022 Requires Elpi 1.13.6 and Coq 8.15. ### APPS - `derive Inductive i {A}` now correctly sets `A` implicit status - `lock Definition f {A}` now correctly sets `A` implicit status ### API - New `coq.arity->implicits` - New `coq.indt-decl->implicits` - New `coq.any-implicit?` ## [1.12.0] - 15-01-2021 Requires Elpi 1.13.6 and Coq 8.15. ### HOAS - Change `{{ p x }}` is no more interpreted as a primitive projection even if `p` is the associated constant - New `{{ x.(p) }}` is interpreted as a primitive projection if `p` is a primitive projection - New `{{ x.(@p params) }}` is interpreted as a regular projection even if `p` is a primitive projection, since primitive projections don't have parameters and the user wrote some ### API - Fix globalization of `arity` inside a section - New `coq.option` type to access Coq's GOption system (Set/Unset vernaculars) - New `coq.option.add` - New `coq.option.get` - New `coq.option.set` - New `coq.option.available?` - New `coq.bind-ind-parameters` ### APPS - New `locker` app providing `lock` and `mlock` commands ## [1.11.2] - 24-09-2021 Requires Elpi 1.13.6 and Coq 8.14. ### API - Change `coq.bind-ind-arity` preserves `let` - New `coq.bind-ind-arity-no-let` to reduce `let`, used in `coq.build-match` - Fix `coq.build-match` putting `let` bindings in `match` return type - Change `coq.map-under-fun` preserves `let` ## [1.11.1] - 24-09-2021 Requires Elpi 1.13.6 and Coq 8.13. ### API - New `coq.env.informative?` to know if a type can be eliminated to build a term of sort `Type` - Fix `coq.warning` is synchronized with Coq's Undo machinery - Retire the venerable "elpi fails" message, replaced with something more precise inviting the user to report a bug: errors should be taken care of and reported nicely by the programmer. - New `coq.uint63->int` - New `coq.float64->float` - New `coq.ltac.id-free?` tells if a given ident is already used to denote a goal hypothesis, or not. ### Derive - Fix derivation of induction principles for "data types" in `Prop` - Add derivation of `param1` for the equality test `eq` with name `t.param1_eq` - Fix `invert` and `idx2inv` when dealing with containers - New datatypes from the Coq's prelude are derived in advance, no need to to `derive nat` anymore. ## [1.11.0] - 30-06-2021 Requires Elpi 1.13.6 and Coq 8.13. ### HOAS - New node `proj` of type `projection -> int -> primitive-value` holding the projection name (a Coq detail) and the number of the field it projects (0 based), eg: `primitive (proj _ N)` stands for the projection for the Nth constructor field counting parameters. - Change `cs-instance` carries a `gref` ### API - New `coq.notation.add-abbreviation-for-tactic` to add a parsing rule for a tactic-in-term, along the lines of `Notation foo := ltac:(elpi mytactic arguments)` but passing `mytactic` the correct `elpi.loc` of invocation. - New `@pplevel!` attribute to control outermost parentheses in `coq.term->pp` and similar - New `coq.hints.add-mode` like the `Hint Mode` vernacular - New `coq.hints.modes` - New `coq.TC.declare-class` - Deprecate `coq.env.const-opaque?` -> `coq.env.opaque?` - Deprecate `coq.env.const-primitive?` -> `coq.env.primitive?` - Deprecate `coq.CS.canonical-projections` -> `coq.env.projections` - New `coq.env.primitive-projections` - Change `coq.warning` emits the same warning only once ## [1.10.3] - 18-06-2021 Requires Elpi 1.13.6 and Coq 8.13. ### Lib - Cleanup `elpi.loc` attribute, which now carries a real loc and not a string. Thanks to elpi 1.13.6 we can project out the components without messing with regular expressions. Moreover loc are printed in a consistent way on Unix and Windows. ## [1.10.2] - 11-06-2021 Requires Elpi 1.13.5 and Coq 8.13. ### API - Change `coq.gref->path` now (consistently) gives the path without the final id, which can be retrieved by `coq.gref->id`. ## [1.10.1] - 24-05-2021 Requires Elpi 1.13.5 and Coq 8.13. ### HOAS - Fix (reverse) the order of the context argument of `goal`. The head of the list is the most recent hypothesis and in the last to be loaded (the one with higher precedence) by implication when one writes `Ctx => ...`. - New `msolve` entry point for (possibly multi goal) tactics ### API - Fix argument interpretation for `coq.ltac.call-ltac1`, the context is now the one of the goal alone (and not the one of the goal plus the current one) - Rename `coq.ltac.then` to `coq.ltac.all` ## [1.10.0] - 21-05-2021 Requires Elpi 1.13.5 and Coq 8.13. ### Derive - New `lens` and `lens_laws` for regular and primitive records with or without parameters - `derive` takes `#[only(this, that)]` to select the desired derivations ### API - Fix `coq.elpi.accumulate` scope `current`, which was putting the closes in the current module for the current file, but was making them global for the files importing it - New scope `library` for `coq.elpi.accumulate` which links the clauses to the library, that is the module named after the file. - Fix databases are always available, no need to import files in the right order when databases have named clauses. The error "Error: unable to graft this clause: no clause named ..." should no more be raised in response to a `Require Import`. - New `coq.strategy.*` to `set` and `get` the unfolding priority of constants followed by the term comparison algorithm Coq uses at type checking time. - New `coq.env.record?` to test if an inductive is a record and if it has primitive projections - New `coq.env.recursive?` to test if an inductive is recursive - Change `coq.locate*` understands strings like `"lib:some.name"` which point to global references registered via the Coq `Register` command - New `coq.ltac.fail` like `coq.error` but catch by Ltac - New `@ltacfail!` to be used like `@ltacfail! Level => std.assert! ...` in tactic code to use `coq.ltac.fail` instead of `coq.error` in case of failure - Change failure as is `elpi fails` (no more clauses to try) or `elpi run out of steps` are not considered Ltac failures anymore, but rather fatal errors. Add a clause `solve _ _ :- coq.ltac.fail _` to preserve the old behavior. - New `coq.ltac.collect-goals` to turn unresolved unification variables into goals. - Fix `coq.env.add-const` now accepts an opaque definition with no given type. The body is assumed to be well typed and is quickly retypechecked. ### HOAS - Fix handling of default case in `match`, now Coq's `if _ then _ else _` works just fine. - New quotation `{{:gref id }}` and `{{:gref lib:qualid }}` that unfolds to the `gref` data type (`{{ id }}` and `{{ lib:qualid }}` unfold to terms) - Change `solve` only takes 2 arguments (the arguments passed at tactic invocation time are now part of the goal) and the first argument is a single goal, not a list thereof. The second argument is now a `sealed-goal`. - Change `refine` now generates a list of `sealed-goal`s - Change `goal` now carries two unification variables standing for the raw solution to goal and the elaborated, well typed, one. Assigning a term to the raw variable triggers a call to `coq.elaborate-skeleton` which in turn assigns the other one to the (partial) proof term. Assigning the elaborated variable directly does not trigger a type check of the term. ### Vernacular - New `attributes` tactic argument (for `Tactic Notation`) - New `elpi tac` can receive attributes via the usual `#[stuff] tac` syntax - New syntax to pass Elpi tactics arguments coming from Ltac variables: - `ltac_string:(v)` (for `v` of type `string` or `ident`) - `ltac_int:(v)` (for `v` of type `int` or `integer`) - `ltac_term:(v)` (for `v` of type `constr` or `open_constr` or `uconstr` or `hyp`) - `ltac_(string|int|term)_list:(v)` (for `v` of type `list` of ...) - `ltac_attributes:(v)` (for `v` of type `attributes`) Example: ```coq Tactic Notation "foo" string(X) ident(Y) int(Z) constr(T) constr_list(L) := elpi foo ltac_string:(X) ltac_string:(T) ltac_int:(Z) (T) ltac_term_list(L). ``` lets one write `foo "a" b 3 nat t1 t2 t3` in any Ltac context. For attributes one has to place `ltac_attributes:(v)` in front of `elpi`, as in: ```coq Tactic Notation "foo" "#[" attributes(A) "]" := ltac_attributes:(A) elpi foo. ``` Here the delimiters `#[` and `]` are chosen for consistency, you can use any "delimited" syntax really. The usual prefix notation is also possible with the following limitations due to a parsing conflicts in the Coq grammar (at the time of writing): ```coq Tactic Notation "#[" attributes(A) "]" "tac" := ltac_attributes:(A) elpi tac. ``` - `#[ att ] tac.` does not parse - `(#[ att ] tac).` works - `idtac; #[ att ] tac.` works - Change `-qua.lid` is no more understood as the string `"-qua.lid"` but as two strings (when passed to a command, syntax error when passed to a tactic) ## [1.9.7] - 15-04-2021 Requires Elpi 1.13.1 and Coq 8.13. ### Vernacular - New attribute `#[skip="rex"]` and `#[only="rex"]` for the `Elpi Acumulate` family of commands which let one accumulate a piece of (compatibility) code only on some Coq versions. ## [1.9.6] - 13-04-2021 Requires Elpi 1.13.1 and Coq 8.13. ### API - New `coq.reduction.lazy.norm` - New `coq.reduction.native.norm` - New `coq.reduction.native.available?` - Rename `coq.reduction.cbv.whd_all` -> `coq.reduction.cbv.norm` - Rename `coq.reduction.vm.whd_all` -> `coq.reduction.vm.norm` ## [1.9.5] - 26-03-2021 Requires Elpi 1.13 and Coq 8.13. ### Vernacular - Commands, Tactics and Db cannot be declared inside sections or modules (it never really worked, but now you get an error message). - Clauses which are accumulated via `coq.elpi.accumulate` and are not `@local!` survive section closing if they don't mention the section variables being discharged. ### Typechecker - Warnings can be turned into errors by passing Coq `-w +elpi.typecheck`. ### API - New `coq.CS.db-for` to filter the CS db given a projection or a canonical value, or both. - New `coq.warning` like `coq.warn` but with a category and name, so that the message can be silenced or turned into an error. ## [1.9.4] - 17-03-2021 Requires Elpi 1.13 and Coq 8.13. ### Elpi - Calls to APIs that only read the global state are much faster (thousands of times faster) - Fix compilation with OCaml 4.12 ### API - Fix issue with `coq.env.add-abbreviation` when given a term with binders having overlapping `name`s. - New `copy-indt-decl` - New `coq.coercion.declare` is able to infer the endpoints if omitted ## [1.9.3] - 18-02-2021 Requires Elpi 1.13 and Coq 8.13. ### Elpi - Fix issue with async-mode (Elpi commands can change the parser) ### API - New `attmap` attribute type to represent associative maps over strings, eg `#[foo(x = "a", y = "b")]` ## [1.9.2] - 12-02-2021 Requires Elpi 1.13 and Coq 8.13. ### API - Fix `elpi.loc` computation when run in interactive mode. - New `@using! S` attribute for `coq.env.add-const` akin to Coq's `#[using=S]`. ## [1.9.1] - 11-02-2021 Requires Elpi 1.13 and Coq 8.13. ### API - Fix `coq.env.add-section-variable` and `coq.env.add-axiom` were not handling universes correctly. ### Build system - New target `build` which only builds elpi and the apps - New target `test` which runs all tests for elpi and the apps - OPAM package only calls `test` only if requested, hence the package typically installs faster ## [1.9.0] - 10-02-2021 Requires Elpi 1.13 and Coq 8.13. ### HOAS - Fix `coq.env.indt-decl` to generate a `record-decl` for records. ### Elpi - Fix issue with the compiler cache when used in async-mode (via CoqIDE or vscoq). ### API - New type `coq.pp` and `coq.pp.box` to describe Coq's pretty printer box model - New `coq.pp->string` to turn formatting boxes into a string - New `coq.term->pp` to turn formatting boxes into a string - New `@ppall!` attribute to print terms in full details - New `@ppmost!` attribute to print terms in a reparsable way - New `@ppwidth! N` attribute to specify the maximal line length when turning formatting boxes into strings - New `fold-map` to map a term with an accumulator - New `coq.env.add-section-variable` - New `coq.env.add-axiom` - Deprecate `coq.env.add-const` for declaring axioms or section variables. The deprecation warning is called `elpi.add-const-for-axiom-or-sectionvar` and can be turned into an error by passing to `coqc` the option `-w +elpi.add-const-for-axiom-or-sectionvar` ### Tooling - The `COQ_ELPI_ATTRIBUTES=text` parses `text` as Coq attributes `#[elpi(text)]` and passes them to all commands. Attributes in the `elpi.` namespace are silently ignored by commands not using them. - Attribute `elpi.loc` carries the `loc` of the command being run (if exported with `Elpi Export cmd`). This location does not comprise control flags (eg `Fail`, `Time`) nor attributes. This limitation will be lifted in Coq 8.14 (8.13 does not expose this parsing information to plugins). ## [1.8.1] - 11-12-2020 Requires Elpi 1.12 and Coq 8.13. ### HOAS - Illformed terms like `global (const X)` (which have no representation in Coq) are now reported with a proper error message. Whe passed to `coq.term->string`, instead of a fatal error, we pick for the illformed sub term the `unknown_gref` special constant. ## [1.8.0] - 29-11-2020 Requires Elpi 1.12 and Coq 8.12. ### API - New `@primitive!` attribute for `coq.env.add-indt` allowing one to declare primitive records. So far no term syntax for primitive projects is supported, their "non primitive" version is always used instead. ### HOAS - Best effort support for Coq's `let (x, y, .. ) := t in ` in quotations. ### API - Fix `coq.term->gref` skips over casts ## [1.7.0] - 26-11-2020 Requires Elpi 1.12 and Coq 8.12. ### HOAS - New `primitive (uint63 )` term constructor - New `primitive (float64 )` term constructor ### API - New `coq.reduction.lazy.whd_all` - New `coq.reduction.cbv.whd_all` - New `coq.reduction.vm.whd_all` - New `coq.env.const-primitive?` - Fix argument `const-decl` is accepted even if the name is "_", allowing one to write `Elpi command Definition _ : type := body` - Fix `coq.notation.abbreviation` gives an error if too few arguments are provided ### Sources Major reorganization of sources: - src/ is for .ml files - elpi/ for .elpi files - theories/ for .v files meant to be installed - tests/ for the test suite, not to be installed - examples/ for tests (not to be installed) Moreover the apps/ directory is for applications written in Coq-Elpi, their structure follows the same convention ### NES (Namespace Emulation System) - POC application emulating name spaces on top of modules ### Elpi integration - Use Elpi 1.12 API to implement a compiler cache and avoid recompiling over and over the same programs. ## [1.6.0] - 21-08-2020 Requires Elpi 1.11 and Coq 8.12. ### UIs - Display failures generated by `std.assert!` as errors ### Derive - Use the new `coq.elaborate-skeleton` API to insert coercions ### Fix - Embedding for sorts was incorrectly mapping `Prop` to `sprop` - `coq.env.add-const` made 8.12 friendly with a workaround for coq/coq#12759 ### API - New `coq.elaborate-skeleton` and `coq.elaborate-ty-skeleton` that run Coq's elaborator on a term obtained by disregarding evars and universes in the given input. Unfortunately Coq's elaborator does not take terms as input, but glob terms, and the conversion function is not lossless. See also `lib:elpi.hole`. - New `coq.elaborate-indt-decl-skeleton` to elaborate an inductive type declaration. - New `coq.elaborate-arity-skeleton` to elaborate an arity. - New `coq.env.current-path` to get the current module path. - New `coq.modpath->path` and `coq.modpath->path` to get access to the components of a module path. - Change `coq.elpi.accumulate` understands the `@local!` attribute, which makes the clauses `Local` to the module into which they live. ### HOAS - New `lib:elpi.hole` constant that can be used in place of a unification variable to denote an implicit argument when calling `coq.*-skeleton` APIs ## [1.5.1] - 29-07-2020 Requires Elpi 1.11 and Coq 8.12. ### API: Locality is now supported by `coq.CS.declare-instance` ## [1.5.0] - 29-07-2020 Requires Elpi 1.11 and Coq 8.11. ### HOAS - New option `@holes!` to be assumed (as in `@holes! => ...`) before calling any Coq API. When this option is given unknown unification variables are interpreted as "implicit arguments" (linear holes that see all the variables in scope). If the unification variable is outside the pattern fragment the following heuristic is applied: arguments that are not variables are heuristically dropped; arguments which are variables but occur multiple times are kept only once (the first occurrence is kept, the others are dropped). ### API - New `coq.arguments.set-default-implicit` that behaves like `Arguments foo : default implicits` - Change of arguments of type `@global?` attributes `@local!` or `@global!`. In order to pass a locality directive one has to do something like `@global! => coq.add-something` Locality is understood by: - `coq.TC.declare-instance` - `coq.coercion.declare` - `coq.arguments.set-implicit` - `coq.arguments.set-default-implicit` - `coq.arguments.set-name` - `coq.arguments.set-scope` - `coq.arguments.set-simplification` - `coq.notation.add-abbreviation` - `coq.env.add-const` - Change of argument for deprecation to attribute `@deprecated! Since Message`. In order to pass a deprecation directive one has to do something like `@deprecated! "8.11.0" "use this instead" => coq.add-something` Deprecation is understood by: - `coq.notation.add-abbreviation` - New macro `@transparent!` with value `ff` to be used with `coq.env.add-const` ### Elaborator - `engine/elaborator.elpi` is now installed (but not used by default). One can `Elpi Accumulate "engine/elaborator.elpi".` in order to load it. It is too experimental to use it in production, but it is also hard to experiment with it without having it installed. ### CI - Switch to Github Actions and Coq Community's Docker workflow ### Bugfix - anonymous record fields are not given a generated name anymore - `coq.typecheck` and `coq.typecheck-ty` API now ensure that all unification problems required by type checking are actually solved by Coq's unifier - some debug printings used to raise errors in corner cases, now fixed ## [1.4.1] - 2020-06-10 Minor fixes - Missing opaque data type declaration for `abbreviation` (could lead to confusing type errors) - Parse also "keywords" where `qualified_name` is expected. `Elpi Export x.` turns `x` into a keyword, and that used to break commands `Elpi Something x ...`. Parsing of all commands is now resilient to this. ## [1.4.0] - 2020-05-19 Requires Elpi 1.11 and Coq 8.11 or 8.12. The main visible change is the `indt-decl` data type that now faithfully represents an inductive type declaration (including the implicit status of parameters). Also all the predicates implemented in `coq-lib` are now in the `coq.` namespace. ### API - New `coq.notation.abbreviation-body` to retrieve the number of arguments and body of a syntactic definition. - New `coq.id->name` to convert a relevant id into an irrelevant pretty printing hint. - New `coq.mk-n-holes ` to produce a list of flexible terms. - New `coq.env.indt-decl` to read for the environment an inductive type represented in HOAS form - `coq.env.indt->decl` renamed `coq.build-indt-decl` - New `coq.env.rename-indt-decl` - Change `coq.env.add-indt` now sets the imlicit status of the inductive type and its constructors (since the `parameter` constructor can carry it) - New `coq.arity->nparams` to count the number of parameters - Change `parse-attributes` made deterministic - Change `coq.unify-leq` and `coq.unify-eq` now return a diagnostic - Change `subst-prod` -> `coq.subst-prod` - Change `subst-fun` -> `coq.subst-fun` - Change `prod->fun` -> `coq.prod->fun` - Change `count-prods` -> `coq.count-prods` - Change `prod-R-fun` -> `coq.prod-R-fun` - Change `safe-dest-app` -> `coq.safe-dest-app` - Change `arity->sort` -> `coq.arity->sort` - Change `term->gref` -> `coq.term->gref` - Change `fresh-type` -> `coq.fresh-type` - Change `build-match` -> `coq.build-match` - Change `map-under-fun` -> `coq.map-under-fun` - Change `iter-under-fun` -> `coq.iter-under-fun` - Change `bind-ind-arity` -> `coq.bind-ind-arity` - Change `with-TC` -> `coq.with-TC` - Change `valid-attribute` -> `coq.valid-attribute` - Change `is-one-of` -> `coq.is-one-of` - Change `parse-attributes` -> `coq.parse-attributes` - Change `mk-app` -> `coq.mk-app` - Change `mk-app-uvar` -> `coq.mk-app-uvar` - Change `mk-eta` -> `coq.mk-eta` ### Universes - New support for `Type@{name}` in Coq `{{ quotations }}`. - Fix more precise promotion of universe variables to universe global names in builtins changing the Coq environment (eg `coq.env.add-const`). - New user error when `coq.elpi.accumulate` is given a clause that mentions universe variables: only global universes can be stored in a DB. ### HOAS - Change `indt-decl`: - the `parameter` constructor carries an `id`, `imlpicit_kind` and a type - the `coinductive` constructor was removed, the `inductive` one carries a `bool`, `tt` for inductive, `ff` for coinductive - the `inductive` constructor no more carries the number of non uniform parameters, and the inductive type arity (see below) is no more a simple term but rather an `arity` (all its parameters are non uniform) - the `constructor` constructor now carries an `arity` so that non uniform parameters can be represented faitfully - New `arity` data type, constructors are `parameter` (shared with `indt-decl`) and `arity`. - New `indt-decl` argument type introduced in version 1.3 now supports the syntax of inductive types (not just records). Eg `Elpi command Inductive P {A} t : I := | K1 .. | K2 ..`. - Change `context-item` now carries an `id` and an `implicit-kind` - Change `const-decl` now carries an arity to describe the parameters of the definition in a faithful way - New `@pi-parameter ID Ty p\ ...` to postulate a nominal `p` with type `Ty` and a name built out of the id `ID` ### Derive - New derivations `derive.invert` and `derive.idx2inv` now called by `derive` - New global command `derive` taking in input the name of an inductive or an inductive declaration. In the latter case all derivations are placed in a module named after the inductive ## [1.3.1] - 2020-03-01 Port to Coq 8.11, two API changes: - `field` constructor of `indt-decl` takes an argument of type `field-attributes` rather than a simple `bool`. The macro `@coercion!` works in both versions, as well as omitting the attribute using `_`. In 8.11 it is possible to disable canonical inference for a field using the `(canonical false)` attribute. - `coq.env.add-abbreviation` takes an extra argument (deprecation info). Code working on both versions can be obtained as follows: ```prolog if (coq.version _ 8 10 _) (std.unsafe-cast coq.notation.add-abbreviation F, F ... Abbrev) (std.unsafe-cast coq.notation.add-abbreviation G, G ... Deprecation Abbrev). ``` ## [1.3.0] - 2020-02-27 Requires Elpi 1.10 and Coq 8.10 or 8.11. The main visible change is that opaque data types such as `@constructor`, `@inductive` and `@constant` are now written without the `@`, since Elpi now supports the `typeabbrev` directive. The main invisible change is that code accumulated into commands and tactics is "compiled" by Elpi once and forall in the context in which it is accumulated. As a consequence Coq code inside `{{quotations}}` is processed in that, and only that, context of notations, scopes, etc. Data bases are compiled every time it is needed in the current Coq context, hence quotations should be used with care. The file `coq-HOAS.elpi` is now distributed as part of `coq-builtin.elpi`. ### Vernacular - New `Elpi Export command` to make `command` available without the `Elpi` prefix. - `Elpi command` (exported or not) can now access Coq's attributes (the `#[option]` thing). See the HOAS section below. - Coq keywords or symbols passed to command and tactics are interpreted as strings even if not quoted. Eg `Elpi command =>` is the same of `Elpi command "=>"`. - The identifiers `Record`, `Definition`, `Axioms` and `Context` are now reserved (see the HOAS section below). In order to pass them (as strings) one has to quote them. ### APIs - New `coq.typecheck-ty` to typecheck a type (outputs a universe) - New `coq.env.import/export-module`. - New `coq.env.begin/end-section`. - New `coq.notation.abbreviation` to unfold an abbreviation. - New `coq.locate-abbreviation` to locate abbreviations. - New `coq.locate-any` that never fails and gives a list of possible interpretations (term, abbreviation, module, module type). - Rename `coq.env.typeof-gr` to `coq.env.typeof`. - Rename `term->gr` to `germ->gref`. - Rename `coq.gr->*` to `coq.gref->*string*` - Change `coq.typecheck` and `coq.typecheck-indt-decl` so that they never fail and have a 3rd argument of type `diagnostic` (from Elpi 1.9) to signal success or errors (that can be printed). - Change `coq.elpi.accumulate` so that one can put the clause either in current module from which the program is started, or in the current module while the program runs (which can be different if one uses the `coq.env.begin-module` API). - Remove `coq.elaborate` and `coq.elaborate-indt-decl`. - Fix `coq.typecheck T TY` to uses Coq's unification to equate the type inferred for `T` and `TY` (when it is provided by the user). - Fix `coq.CS.*` w.r.t. default instances of canonical structures. - Fix all APIs changing the Coq global state to abort if they are used from a tactic. - Fix `coq.gr->string` to not duplicate the label part of the name ### HOAS - Change context entry `def` to not carry a cache for the normal form of the defined term (now cached by a specific `cache` context entry). `def` now carries the exact same information of a `let`, as `decl` carries the same information of a `fun`. - New `indt-decl` argument type with a concrete syntax that mimics the standard one for records. Eg `Elpi command Record x := K { f : T }`. - New `const-decl` argument type with a concrete syntax that mimics the standard one for definitions or axioms. Eg `Elpi command Definition x := t.`. - New `ctx-decl` argument type with a concrete syntax that mimics the standard one for contexts. Eg `Elpi command Context T (x : T).`. - Add to the context under which `main` is run the list of attributes passed to the command invocation (Coq syntax is for example `#[myflag]`). See the `attribute-value` data type in `coq-builtin.elpi` and `parse-attributes` helper in `coq-lib.elpi`. ## [1.2.0] - 2019-10-30 ### APIs - New `coq.gr->path` to get the path components as a list of strings - Failure of `coq.ltac.call` is now turned into logical failure, as any other Elpi tactic - Fix `coq.end.add-indt` in the case of record (was not flagging the inductive as such) - Fix `coq.version`, wrong parsing of beta versions - Expose `set` and `map` from Elpi 1.8 (generic data structure for ground terms) ### Documentation - Improve reflexive tactic demo - Fix documentation of `coq.gr->*` APIs - `coq-HOAS.elpi`, `coq-lib.elpi` and `coq-builtin.elpi` are now installed since they provide useful doc (but are not needed by the runtime, since they are embedded in `elpi.vo`) ## [1.1.0] - 2019-10-10 ### derive.param2 - interface made consistent with other derivations: `derive.param2` takes in input optional suffix, instead of the full name of the derived concept - storage of previous derivations based on Elpi Db - the derivation generates nicer types for relators over fixpoints (the new types are convertible to the old ones, but the fixpoint is not expanded). PR [#84](https://github.com/LPCIC/coq-elpi/pull/84/) by Cyril Cohen ### Documentation - Improved documentation of `coq.typecheck` ## [1.0.0] - 2019-10-09 - First public release coq-elpi-2.1.0/LICENSE000066400000000000000000000635351460156013500142450ustar00rootroot00000000000000 GNU LESSER GENERAL PUBLIC LICENSE Version 2.1, February 1999 Copyright (C) 1991, 1999 Free Software Foundation, Inc. 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA Everyone is permitted to copy and distribute verbatim copies of this license document, but changing it is not allowed. (This is the first released version of the Lesser GPL. It also counts as the successor of the GNU Library Public License, version 2, hence the version number 2.1.) Preamble The licenses for most software are designed to take away your freedom to share and change it. By contrast, the GNU General Public Licenses are intended to guarantee your freedom to share and change free software--to make sure the software is free for all its users. This license, the Lesser General Public License, applies to some specially designated software packages--typically libraries--of the Free Software Foundation and other authors who decide to use it. You can use it too, but we suggest you first think carefully about whether this license or the ordinary General Public License is the better strategy to use in any particular case, based on the explanations below. When we speak of free software, we are referring to freedom of use, not price. Our General Public Licenses are designed to make sure that you have the freedom to distribute copies of free software (and charge for this service if you wish); that you receive source code or can get it if you want it; that you can change the software and use pieces of it in new free programs; and that you are informed that you can do these things. To protect your rights, we need to make restrictions that forbid distributors to deny you these rights or to ask you to surrender these rights. These restrictions translate to certain responsibilities for you if you distribute copies of the library or if you modify it. For example, if you distribute copies of the library, whether gratis or for a fee, you must give the recipients all the rights that we gave you. You must make sure that they, too, receive or can get the source code. If you link other code with the library, you must provide complete object files to the recipients, so that they can relink them with the library after making changes to the library and recompiling it. And you must show them these terms so they know their rights. We protect your rights with a two-step method: (1) we copyright the library, and (2) we offer you this license, which gives you legal permission to copy, distribute and/or modify the library. To protect each distributor, we want to make it very clear that there is no warranty for the free library. Also, if the library is modified by someone else and passed on, the recipients should know that what they have is not the original version, so that the original author's reputation will not be affected by problems that might be introduced by others. Finally, software patents pose a constant threat to the existence of any free program. We wish to make sure that a company cannot effectively restrict the users of a free program by obtaining a restrictive license from a patent holder. Therefore, we insist that any patent license obtained for a version of the library must be consistent with the full freedom of use specified in this license. Most GNU software, including some libraries, is covered by the ordinary GNU General Public License. This license, the GNU Lesser General Public License, applies to certain designated libraries, and is quite different from the ordinary General Public License. We use this license for certain libraries in order to permit linking those libraries into non-free programs. When a program is linked with a library, whether statically or using a shared library, the combination of the two is legally speaking a combined work, a derivative of the original library. The ordinary General Public License therefore permits such linking only if the entire combination fits its criteria of freedom. The Lesser General Public License permits more lax criteria for linking other code with the library. We call this license the "Lesser" General Public License because it does Less to protect the user's freedom than the ordinary General Public License. It also provides other free software developers Less of an advantage over competing non-free programs. These disadvantages are the reason we use the ordinary General Public License for many libraries. However, the Lesser license provides advantages in certain special circumstances. For example, on rare occasions, there may be a special need to encourage the widest possible use of a certain library, so that it becomes a de-facto standard. To achieve this, non-free programs must be allowed to use the library. A more frequent case is that a free library does the same job as widely used non-free libraries. In this case, there is little to gain by limiting the free library to free software only, so we use the Lesser General Public License. In other cases, permission to use a particular library in non-free programs enables a greater number of people to use a large body of free software. For example, permission to use the GNU C Library in non-free programs enables many more people to use the whole GNU operating system, as well as its variant, the GNU/Linux operating system. Although the Lesser General Public License is Less protective of the users' freedom, it does ensure that the user of a program that is linked with the Library has the freedom and the wherewithal to run that program using a modified version of the Library. The precise terms and conditions for copying, distribution and modification follow. Pay close attention to the difference between a "work based on the library" and a "work that uses the library". The former contains code derived from the library, whereas the latter must be combined with the library in order to run. GNU LESSER GENERAL PUBLIC LICENSE TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION 0. This License Agreement applies to any software library or other program which contains a notice placed by the copyright holder or other authorized party saying it may be distributed under the terms of this Lesser General Public License (also called "this License"). Each licensee is addressed as "you". A "library" means a collection of software functions and/or data prepared so as to be conveniently linked with application programs (which use some of those functions and data) to form executables. The "Library", below, refers to any such software library or work which has been distributed under these terms. A "work based on the Library" means either the Library or any derivative work under copyright law: that is to say, a work containing the Library or a portion of it, either verbatim or with modifications and/or translated straightforwardly into another language. (Hereinafter, translation is included without limitation in the term "modification".) "Source code" for a work means the preferred form of the work for making modifications to it. For a library, complete source code means all the source code for all modules it contains, plus any associated interface definition files, plus the scripts used to control compilation and installation of the library. Activities other than copying, distribution and modification are not covered by this License; they are outside its scope. The act of running a program using the Library is not restricted, and output from such a program is covered only if its contents constitute a work based on the Library (independent of the use of the Library in a tool for writing it). Whether that is true depends on what the Library does and what the program that uses the Library does. 1. You may copy and distribute verbatim copies of the Library's complete source code as you receive it, in any medium, provided that you conspicuously and appropriately publish on each copy an appropriate copyright notice and disclaimer of warranty; keep intact all the notices that refer to this License and to the absence of any warranty; and distribute a copy of this License along with the Library. You may charge a fee for the physical act of transferring a copy, and you may at your option offer warranty protection in exchange for a fee. 2. You may modify your copy or copies of the Library or any portion of it, thus forming a work based on the Library, and copy and distribute such modifications or work under the terms of Section 1 above, provided that you also meet all of these conditions: a) The modified work must itself be a software library. b) You must cause the files modified to carry prominent notices stating that you changed the files and the date of any change. c) You must cause the whole of the work to be licensed at no charge to all third parties under the terms of this License. d) If a facility in the modified Library refers to a function or a table of data to be supplied by an application program that uses the facility, other than as an argument passed when the facility is invoked, then you must make a good faith effort to ensure that, in the event an application does not supply such function or table, the facility still operates, and performs whatever part of its purpose remains meaningful. (For example, a function in a library to compute square roots has a purpose that is entirely well-defined independent of the application. Therefore, Subsection 2d requires that any application-supplied function or table used by this function must be optional: if the application does not supply it, the square root function must still compute square roots.) These requirements apply to the modified work as a whole. If identifiable sections of that work are not derived from the Library, and can be reasonably considered independent and separate works in themselves, then this License, and its terms, do not apply to those sections when you distribute them as separate works. But when you distribute the same sections as part of a whole which is a work based on the Library, the distribution of the whole must be on the terms of this License, whose permissions for other licensees extend to the entire whole, and thus to each and every part regardless of who wrote it. Thus, it is not the intent of this section to claim rights or contest your rights to work written entirely by you; rather, the intent is to exercise the right to control the distribution of derivative or collective works based on the Library. In addition, mere aggregation of another work not based on the Library with the Library (or with a work based on the Library) on a volume of a storage or distribution medium does not bring the other work under the scope of this License. 3. You may opt to apply the terms of the ordinary GNU General Public License instead of this License to a given copy of the Library. To do this, you must alter all the notices that refer to this License, so that they refer to the ordinary GNU General Public License, version 2, instead of to this License. (If a newer version than version 2 of the ordinary GNU General Public License has appeared, then you can specify that version instead if you wish.) Do not make any other change in these notices. Once this change is made in a given copy, it is irreversible for that copy, so the ordinary GNU General Public License applies to all subsequent copies and derivative works made from that copy. This option is useful when you wish to copy part of the code of the Library into a program that is not a library. 4. You may copy and distribute the Library (or a portion or derivative of it, under Section 2) in object code or executable form under the terms of Sections 1 and 2 above provided that you accompany it with the complete corresponding machine-readable source code, which must be distributed under the terms of Sections 1 and 2 above on a medium customarily used for software interchange. If distribution of object code is made by offering access to copy from a designated place, then offering equivalent access to copy the source code from the same place satisfies the requirement to distribute the source code, even though third parties are not compelled to copy the source along with the object code. 5. A program that contains no derivative of any portion of the Library, but is designed to work with the Library by being compiled or linked with it, is called a "work that uses the Library". Such a work, in isolation, is not a derivative work of the Library, and therefore falls outside the scope of this License. However, linking a "work that uses the Library" with the Library creates an executable that is a derivative of the Library (because it contains portions of the Library), rather than a "work that uses the library". The executable is therefore covered by this License. Section 6 states terms for distribution of such executables. When a "work that uses the Library" uses material from a header file that is part of the Library, the object code for the work may be a derivative work of the Library even though the source code is not. Whether this is true is especially significant if the work can be linked without the Library, or if the work is itself a library. The threshold for this to be true is not precisely defined by law. If such an object file uses only numerical parameters, data structure layouts and accessors, and small macros and small inline functions (ten lines or less in length), then the use of the object file is unrestricted, regardless of whether it is legally a derivative work. (Executables containing this object code plus portions of the Library will still fall under Section 6.) Otherwise, if the work is a derivative of the Library, you may distribute the object code for the work under the terms of Section 6. Any executables containing that work also fall under Section 6, whether or not they are linked directly with the Library itself. 6. As an exception to the Sections above, you may also combine or link a "work that uses the Library" with the Library to produce a work containing portions of the Library, and distribute that work under terms of your choice, provided that the terms permit modification of the work for the customer's own use and reverse engineering for debugging such modifications. You must give prominent notice with each copy of the work that the Library is used in it and that the Library and its use are covered by this License. You must supply a copy of this License. If the work during execution displays copyright notices, you must include the copyright notice for the Library among them, as well as a reference directing the user to the copy of this License. Also, you must do one of these things: a) Accompany the work with the complete corresponding machine-readable source code for the Library including whatever changes were used in the work (which must be distributed under Sections 1 and 2 above); and, if the work is an executable linked with the Library, with the complete machine-readable "work that uses the Library", as object code and/or source code, so that the user can modify the Library and then relink to produce a modified executable containing the modified Library. (It is understood that the user who changes the contents of definitions files in the Library will not necessarily be able to recompile the application to use the modified definitions.) b) Use a suitable shared library mechanism for linking with the Library. A suitable mechanism is one that (1) uses at run time a copy of the library already present on the user's computer system, rather than copying library functions into the executable, and (2) will operate properly with a modified version of the library, if the user installs one, as long as the modified version is interface-compatible with the version that the work was made with. c) Accompany the work with a written offer, valid for at least three years, to give the same user the materials specified in Subsection 6a, above, for a charge no more than the cost of performing this distribution. d) If distribution of the work is made by offering access to copy from a designated place, offer equivalent access to copy the above specified materials from the same place. e) Verify that the user has already received a copy of these materials or that you have already sent this user a copy. For an executable, the required form of the "work that uses the Library" must include any data and utility programs needed for reproducing the executable from it. However, as a special exception, the materials to be distributed need not include anything that is normally distributed (in either source or binary form) with the major components (compiler, kernel, and so on) of the operating system on which the executable runs, unless that component itself accompanies the executable. It may happen that this requirement contradicts the license restrictions of other proprietary libraries that do not normally accompany the operating system. Such a contradiction means you cannot use both them and the Library together in an executable that you distribute. 7. You may place library facilities that are a work based on the Library side-by-side in a single library together with other library facilities not covered by this License, and distribute such a combined library, provided that the separate distribution of the work based on the Library and of the other library facilities is otherwise permitted, and provided that you do these two things: a) Accompany the combined library with a copy of the same work based on the Library, uncombined with any other library facilities. This must be distributed under the terms of the Sections above. b) Give prominent notice with the combined library of the fact that part of it is a work based on the Library, and explaining where to find the accompanying uncombined form of the same work. 8. You may not copy, modify, sublicense, link with, or distribute the Library except as expressly provided under this License. Any attempt otherwise to copy, modify, sublicense, link with, or distribute the Library is void, and will automatically terminate your rights under this License. However, parties who have received copies, or rights, from you under this License will not have their licenses terminated so long as such parties remain in full compliance. 9. You are not required to accept this License, since you have not signed it. However, nothing else grants you permission to modify or distribute the Library or its derivative works. These actions are prohibited by law if you do not accept this License. Therefore, by modifying or distributing the Library (or any work based on the Library), you indicate your acceptance of this License to do so, and all its terms and conditions for copying, distributing or modifying the Library or works based on it. 10. Each time you redistribute the Library (or any work based on the Library), the recipient automatically receives a license from the original licensor to copy, distribute, link with or modify the Library subject to these terms and conditions. You may not impose any further restrictions on the recipients' exercise of the rights granted herein. You are not responsible for enforcing compliance by third parties with this License. 11. If, as a consequence of a court judgment or allegation of patent infringement or for any other reason (not limited to patent issues), conditions are imposed on you (whether by court order, agreement or otherwise) that contradict the conditions of this License, they do not excuse you from the conditions of this License. If you cannot distribute so as to satisfy simultaneously your obligations under this License and any other pertinent obligations, then as a consequence you may not distribute the Library at all. For example, if a patent license would not permit royalty-free redistribution of the Library by all those who receive copies directly or indirectly through you, then the only way you could satisfy both it and this License would be to refrain entirely from distribution of the Library. If any portion of this section is held invalid or unenforceable under any particular circumstance, the balance of the section is intended to apply, and the section as a whole is intended to apply in other circumstances. It is not the purpose of this section to induce you to infringe any patents or other property right claims or to contest validity of any such claims; this section has the sole purpose of protecting the integrity of the free software distribution system which is implemented by public license practices. Many people have made generous contributions to the wide range of software distributed through that system in reliance on consistent application of that system; it is up to the author/donor to decide if he or she is willing to distribute software through any other system and a licensee cannot impose that choice. This section is intended to make thoroughly clear what is believed to be a consequence of the rest of this License. 12. If the distribution and/or use of the Library is restricted in certain countries either by patents or by copyrighted interfaces, the original copyright holder who places the Library under this License may add an explicit geographical distribution limitation excluding those countries, so that distribution is permitted only in or among countries not thus excluded. In such case, this License incorporates the limitation as if written in the body of this License. 13. The Free Software Foundation may publish revised and/or new versions of the Lesser General Public License from time to time. Such new versions will be similar in spirit to the present version, but may differ in detail to address new problems or concerns. Each version is given a distinguishing version number. If the Library specifies a version number of this License which applies to it and "any later version", you have the option of following the terms and conditions either of that version or of any later version published by the Free Software Foundation. If the Library does not specify a license version number, you may choose any version ever published by the Free Software Foundation. 14. If you wish to incorporate parts of the Library into other free programs whose distribution conditions are incompatible with these, write to the author to ask for permission. For software which is copyrighted by the Free Software Foundation, write to the Free Software Foundation; we sometimes make exceptions for this. Our decision will be guided by the two goals of preserving the free status of all derivatives of our free software and of promoting the sharing and reuse of software generally. NO WARRANTY 15. BECAUSE THE LIBRARY IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY FOR THE LIBRARY, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES PROVIDE THE LIBRARY "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE LIBRARY IS WITH YOU. SHOULD THE LIBRARY PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION. 16. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR REDISTRIBUTE THE LIBRARY AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE LIBRARY (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A FAILURE OF THE LIBRARY TO OPERATE WITH ANY OTHER SOFTWARE), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGES. END OF TERMS AND CONDITIONS How to Apply These Terms to Your New Libraries If you develop a new library, and you want it to be of the greatest possible use to the public, we recommend making it free software that everyone can redistribute and change. You can do so by permitting redistribution under these terms (or, alternatively, under the terms of the ordinary General Public License). To apply these terms, attach the following notices to the library. It is safest to attach them to the start of each source file to most effectively convey the exclusion of warranty; and each file should have at least the "copyright" line and a pointer to where the full notice is found. {description} Copyright (C) {year} {fullname} This library is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by the Free Software Foundation; either version 2.1 of the License, or (at your option) any later version. This library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public License for more details. You should have received a copy of the GNU Lesser General Public License along with this library; if not, write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA Also add information on how to contact you by electronic and paper mail. You should also get your employer (if you work as a programmer) or your school, if any, to sign a "copyright disclaimer" for the library, if necessary. Here is a sample; alter the names: Yoyodyne, Inc., hereby disclaims all copyright interest in the library `Frob' (a library for tweaking knobs) written by James Random Hacker. {signature of Ty Coon}, 1 April 1990 Ty Coon, President of Vice That's all there is to it! coq-elpi-2.1.0/Makefile000066400000000000000000000116141460156013500146670ustar00rootroot00000000000000 # detection of coq ifeq "$(COQBIN)" "" COQBIN := $(shell which coqc >/dev/null 2>&1 && dirname `which coqc`) endif ifeq "$(COQBIN)" "" $(error Coq not found, make sure it is installed in your PATH or set COQBIN) else $(info Using coq found in $(COQBIN), from COQBIN or PATH) endif export COQBIN := $(COQBIN)/ # detection of elpi ifeq "$(ELPIDIR)" "" ELPIDIR=$(shell ocamlfind query elpi 2>/dev/null) endif ifeq "$(ELPIDIR)" "" $(error Elpi not found, make sure it is installed in your PATH or set ELPIDIR) endif export ELPIDIR DEPS=$(ELPIDIR)/elpi.cmxa $(ELPIDIR)/elpi.cma APPS=$(addprefix apps/, derive eltac NES locker coercion cs tc) ifeq "$(COQ_ELPI_ALREADY_INSTALLED)" "" DOCDEP=build else DOCDEP= endif ifndef DOCDIR DOCDIR=$(shell $(COQBIN)/coqc -where)/../../share/doc/coq-elpi endif ifndef COQDOCINSTALL COQDOCINSTALL=$(DESTDIR)$(DOCDIR) endif all: $(MAKE) build-core $(MAKE) test-core $(MAKE) examples $(MAKE) build-apps $(MAKE) test-apps build-core: Makefile.coq $(DEPS) @echo "########################## building plugin ##########################" @if [ -x $(COQBIN)/coqtop.byte ]; then \ $(MAKE) --no-print-directory -f Makefile.coq bytefiles; \ fi @$(MAKE) --no-print-directory -f Makefile.coq opt build-apps: build-core @echo "########################## building APPS ############################" @$(foreach app,$(APPS),$(MAKE) -C $(app) build &&) true build: build-core build-apps test-core: Makefile.test.coq $(DEPS) build-core @echo "########################## testing plugin ##########################" @$(MAKE) --no-print-directory -f Makefile.test.coq test-apps: build-apps @echo "########################## testing APPS ############################" @$(foreach app,$(APPS),$(MAKE) -C $(app) test &&) true test: test-core test-apps examples: Makefile.examples.coq $(DEPS) build-core @echo "############################ examples ############################" @$(MAKE) --no-print-directory -f Makefile.examples.coq doc: $(DOCDEP) @echo "########################## generating doc ##########################" @mkdir -p doc @$(foreach tut,$(wildcard examples/tutorial*$(ONLY)*.v),\ echo ALECTRYON $(tut) && ./etc/alectryon_elpi.py \ --frontend coq+rst \ --output-directory doc \ --pygments-style vs \ -R theories elpi -Q src elpi \ $(tut) &&) true @cp stlc.html doc/ @cp etc/tracer.png doc/ .merlin: force @rm -f .merlin @$(MAKE) --no-print-directory -f Makefile.coq $@ .PHONY: force build all test doc Makefile.coq Makefile.coq.conf: src/coq_elpi_builtins_HOAS.ml src/coq_elpi_builtins_arg_HOAS.ml src/coq_elpi_config.ml _CoqProject @$(COQBIN)/coq_makefile -f _CoqProject -o Makefile.coq @$(MAKE) --no-print-directory -f Makefile.coq .merlin Makefile.test.coq Makefile.test.coq.conf: _CoqProject.test @$(COQBIN)/coq_makefile -f _CoqProject.test -o Makefile.test.coq Makefile.examples.coq Makefile.examples.coq.conf: _CoqProject.examples @$(COQBIN)/coq_makefile -f _CoqProject.examples -o Makefile.examples.coq src/coq_elpi_builtins_arg_HOAS.ml: elpi/coq-arg-HOAS.elpi Makefile.coq.local echo "(* Automatically generated from $<, don't edit *)" > $@ echo "(* Regenerate via 'make $@' *)" >> $@ echo "let code = {|" >> $@ cat $< >> $@ echo "|}" >> $@ src/coq_elpi_builtins_HOAS.ml: elpi/coq-HOAS.elpi Makefile.coq.local echo "(* Automatically generated from $<, don't edit *)" > $@ echo "(* Regenerate via 'make $@' *)" >> $@ echo "let code = {|" >> $@ cat $< >> $@ echo "|}" >> $@ src/coq_elpi_config.ml: echo "let elpi_dir = \"$(abspath $(ELPIDIR))\";;" > $@ clean: Makefile.coq Makefile.test.coq @$(MAKE) -f Makefile.coq $@ @$(MAKE) -f Makefile.test.coq $@ @$(foreach app,$(APPS),$(MAKE) -C $(app) $@ &&) true include Makefile.coq.conf V_FILES_TO_INSTALL := \ $(filter-out theories/wip/%.v,\ $(COQMF_VFILES)) install: @echo "########################## installing plugin ############################" @$(MAKE) -f Makefile.coq $@ VFILES="$(V_FILES_TO_INSTALL)" @if [ -x $(COQBIN)/coqtop.byte ]; then \ $(MAKE) -f Makefile.coq $@-byte VFILES="$(V_FILES_TO_INSTALL)"; \ fi -cp etc/coq-elpi.lang $(COQMF_COQLIB)/ide/ @echo "########################## installing APPS ############################" @$(foreach app,$(APPS),$(MAKE) -C $(app) $@ &&) true @echo "########################## installing doc ############################" -mkdir -p $(COQDOCINSTALL) -cp doc/* $(COQDOCINSTALL) @echo "########################## installed ############################" # compile just one file theories/%.vo: force @$(MAKE) --no-print-directory -f Makefile.coq $@ tests/%.vo: force build-core Makefile.test.coq @$(MAKE) --no-print-directory -f Makefile.test.coq $@ examples/%.vo: force build-core Makefile.test.coq @$(MAKE) --no-print-directory -f Makefile.test.coq $@ SPACE=$(XXX) $(YYY) apps/%.vo: force @$(MAKE) -C apps/$(word 1,$(subst /, ,$*)) \ $(subst $(SPACE),/,$(wordlist 2,99,$(subst /, ,$*))).vo nix: nix-shell --arg do-nothing true --run "updateNixToolBox & genNixActions"coq-elpi-2.1.0/Makefile.coq.local000066400000000000000000000014521460156013500165400ustar00rootroot00000000000000CAMLPKGS+= -package elpi,stdlib-shims CAMLFLAGS+= -bin-annot -g OCAMLWARN+=-warn-error -32 COQEXTRAFLAGS=-bt theories/elpi.vo: $(wildcard elpi/*.elpi) merlin-hook:: echo "S $(abspath $(ELPIDIR))" >> .merlin echo "B $(abspath $(ELPIDIR))" >> .merlin if [ "$(ELPIDIR)" != "elpi/findlib/elpi" ]; then\ echo "PKG elpi" >> .merlin;\ fi install-extra:: df="`$(COQMKFILE) -destination-of theories/elpi.vo $(COQLIBS)`";\ install -m 0644 elpi-builtin.elpi "$(COQLIBINSTALL)/$$df";\ install -m 0644 coq-builtin.elpi "$(COQLIBINSTALL)/$$df";\ install -m 0644 coq-builtin-synterp.elpi "$(COQLIBINSTALL)/$$df";\ install -m 0644 elpi/coq-lib-common.elpi "$(COQLIBINSTALL)/$$df";\ install -m 0644 elpi/coq-lib.elpi "$(COQLIBINSTALL)/$$df";\ install -m 0644 elpi/elpi_elaborator.elpi "$(COQLIBINSTALL)/$$df" coq-elpi-2.1.0/Makefile.release000066400000000000000000000007771460156013500163160ustar00rootroot00000000000000OPAM_SUITE=released TAG=$(shell git tag --sort=-v:refname|head -1) release: echo "Publishing tag $(TAG) in suite $(OPAM_SUITE)" echo "Hit ^C to stop, or type options (eg -n fro dry run) and return to continue:";\ read OPTS;\ TAG=$(TAG);\ opam-publish --tag=$(TAG) --packages-directory=$(OPAM_SUITE)/packages \ --repo=coq/opam --no-browser -v $${TAG##v} $$OPTS \ https://github.com/LPCIC/coq-elpi/releases/download/$$TAG/coq-elpi-$${TAG##v}.tar.gz release-rc: OPAM_SUITE=extra-dev release-rc: release coq-elpi-2.1.0/Makefile.test.coq.local000066400000000000000000000025571460156013500175250ustar00rootroot00000000000000tests/test_cache_async.vo: COQEXTRAFLAGS=-async-proofs on tests/test_COQ_ELPI_ATTRIBUTES.vo: export COQ_ELPI_ATTRIBUTES=test=yes,str="some-string" define test_link @F="$(1)";\ L1=`grep -n '^p 7\.' $$F | cut -d : -f 1`;\ L2=`grep -n '^p 2\.' $$F | cut -d : -f 1`;\ [ "$$L1" -gt "$$L2" ] || (echo "wrong link order in file $$F"; exit 1);\ for i in `seq 1 10`; do\ N=`grep "^p $$i\\\\." $$F | wc -l`;\ [ "$$N" = "1" ] || (echo "wrong linking: rule p $$i occurs $$N in file $$F"; exit 1);\ done;\ true endef post-all:: tests/test_glob.glob @echo "test coqdoc hyperlinks" @mkdir -p tests/test_glob/ @N=`coqdoc -d tests/test_glob -R tests elpi.tests tests/test_glob.v 2>&1 | grep -i warning | wc -l`;\ test $$N = 0 @echo "test link order" @diff -u tests/test_link_order1.txt tests/test_link_order2.txt @diff -u tests/test_link_order1.txt tests/test_link_order3.txt @diff -u tests/test_link_order1.txt tests/test_link_order4.txt @diff -u tests/test_link_order1.txt tests/test_link_order5.txt @diff -u tests/test_link_order1.txt tests/test_link_order6.txt @diff -u tests/test_link_order1.txt tests/test_link_order7.txt @diff -u tests/test_link_order1.txt tests/test_link_order8.txt @diff -u tests/test_link_order1.txt tests/test_link_order9.txt $(call test_link, tests/test_link_order1.txt) @diff -u tests/test_link_order_import3.ref tests/test_link_order_import3.txtcoq-elpi-2.1.0/README.md000066400000000000000000000623521460156013500145130ustar00rootroot00000000000000[![Docker CI](https://github.com/LPCIC/coq-elpi/actions/workflows/main.yml/badge.svg)](https://github.com/LPCIC/coq-elpi/actions/workflows/main.yml) [![Nix CI](https://github.com/LPCIC/coq-elpi/actions/workflows/nix-action-coq-8.19.yml/badge.svg)](https://github.com/LPCIC/coq-elpi/actions/workflows/nix-action-coq-8.19.yml) [![DOC](https://github.com/LPCIC/coq-elpi/actions/workflows/doc.yml/badge.svg)](https://github.com/LPCIC/coq-elpi/actions/workflows/doc.yml) [![project chat](https://img.shields.io/badge/zulip-join_chat-brightgreen.svg)](https://coq.zulipchat.com/#narrow/stream/253928-Elpi-users.20.26.20devs) Coq-Elpi logo # Coq-Elpi [Coq](https://github.com/coq/coq) plugin embedding [Elpi](https://github.com/LPCIC/elpi). ## What is Elpi [Elpi](https://github.com/LPCIC/elpi) provides an easy-to-embed implementation of a dialect of λProlog, a programming language well suited to manipulate abstract syntax trees containing binders and unification variables. ## What is Coq-Elpi Coq-Elpi provides a Coq plugin that lets one define new commands and tactics in Elpi. For that purpose it provides an embedding of Coq's terms into λProlog using the Higher-Order Abstract Syntax approach ([HOAS](https://en.wikipedia.org/wiki/Higher-order_abstract_syntax)). It also exports to Elpi a comprehensive set of Coq's primitives, so that one can print a message, access the environment of theorems and data types, define a new constant, declare implicit arguments, type classes instances, and so on. For convenience it also provides quotations and anti-quotations for Coq's syntax, so that one can write `{{ nat -> lp:X }}` in the middle of a λProlog program instead of the equivalent AST. ## What is the purpose of all that In the short term, provide an extension language for Coq well suited to manipulate terms containing binders. One can already use Elpi to implement commands and tactics. As ongoing research we are looking forward to express algorithms like higher order unification and type inference, and to provide an alternative elaborator for Coq. ## Installation The simplest way is to use [OPAM](http://opam.ocaml.org/) and type ``` opam repo add coq-released https://coq.inria.fr/opam/released opam install coq-elpi ``` ### Editor Setup The recommended user interface is [VSCoq](https://github.com/coq-community/vscoq/). We provide an [extension for vscode](https://github.com/LPCIC/coq-elpi-lang) in the market place, just look for Coq Elpi. The extension provides syntax hilighting for both languages even when they are nested via quotations and antiquotations.
Other editors (click to expand)

At the time of writing Proof General does not handle quotations correctly, see ProofGeneral/PG#437. In particular `Elpi Accumulate lp:{{ .... }}.` is used in tutorials to mix Coq and Elpi code without escaping. Coq-Elpi also accepts `Elpi Accumulate " .... ".` but strings part of the Elpi code needs to be escaped. Finally, for non-tutorial material, one can always put the code in an external file declared with `From some.load.path Extra Dependency "filename" as f.` and use `Elpi Accumulate File f.`. CoqIDE does handle quotations. The installation process puts [coq-elpi.lang](etc/coq-elpi.lang) in a place where CoqIDE can find it. Then you can select `coq-elpi` from the menu `Edit -> Preferences -> Colors`. For Vim users, [Coqtail](https://github.com/whonore/Coqtail) provides syntax highlighting and handles quotations.

Development version (click to expand)

To install the development version one can type ``` opam pin add coq-elpi https://github.com/LPCIC/coq-elpi.git ``` One can also clone this repository and type `make`, but check you have all the dependencies installed first (see [coq-elpi.opam](coq-elpi.opam)). We recommend to look at the [CI setup](.github/workflows) for ocaml versions being tested. Also, we recommend to install `dot-merlin-reader` and `ocaml-lsp-server` (version 1.15).

## Documentation ### Tutorials - [The Elpi programming language](https://lpcic.github.io/coq-elpi/tutorial_elpi_lang.html) is an Elpi tutorial, there is nothing Coq specific in there even if the tutorial uses Coq to step trough the various examples. If you never heard of λProlog or HOAS based languages (like Twelf or Beluga) then you are strongly encouraged to read this tutorial and have a look at [λProlog's home page](http://www.lix.polytechnique.fr/Labo/Dale.Miller/lProlog/) for additional documentation. Even if you are familiar with λProlog or HOAS it may be worth reading the last sections since they focus on Elpi specific features. Last but not least it covers common pitfalls for people with a background in functional programming and the tracing mechanisms (useful for debugging). - [HOAS of Coq terms](https://lpcic.github.io/coq-elpi/tutorial_coq_elpi_HOAS.html) focuses on how Coq terms are represented in Elpi, how to inspect them and call Coq APIs under a context of binders, and finally how holes ("evars" in Coq slang) are represented. It assumes the reader is familiar with Elpi. - [Writing commands in Elpi](https://lpcic.github.io/coq-elpi/tutorial_coq_elpi_command.html) focuses on how to write commands, in particular how to store a state across calls via so called DBs and how to handled command arguments. It assumes the reader is familiar with Elpi and the HOAS of Coq terms. - [Writing tactics in Elpi](https://lpcic.github.io/coq-elpi/tutorial_coq_elpi_tactic.html) describes how goals and tactics are represented, how to handle tactic arguments and finally how to define tactic notations. It assumes the reader is familiar with Elpi and the HOAS of Coq terms. - [Coq-Elpi in 20 minutes](https://youtu.be/m60rHnvCJ2o) video recording of a talk given at the Coq Users and Developers Workshop 2020. ### Small examples (proofs of concept) - [reification](examples/example_reflexive_tactic.v) is the typical use case for meta programs: reading the syntax of terms into an inductive representing a sub language on which some decision procedure can be implemented - [data bases](examples/example_data_base.v) shows how Elpi programs can store data and reuse it across multiple runs - [record expansion](examples/example_record_expansion.v) sketches a program to unpack records in a definition: it replaces an abstraction over a records with abstractions over all of its components - [record to sigma](examples/example_record_to_sigma.v) sketches a program that de-sugars a record type to iterated sigma types - [fuzzer](examples/example_fuzzer.v) sketches a program to alter an inductive type while preserving its well typedness. It makes nothing useful per se, but shows how to map a term and call the type checker deep inside it. - [tactics](examples/example_curry_howard_tactics.v) show how to create simple tactics by using (proof) terms and the elaborator of Coq - [generalize](examples/example_generalize.v) show how to abstract subterms out (one way to skin the cat, there are many) - [abs_evars](examples/example_abs_evars.v) show how to close a term containing holes (evars) with binders - [record import](examples/example_import_projections.v) gives short names to record projections applied to the given record instance. - [reduction surgery](examples/example_reduction_surgery.v) implements a tactic fine tuning cbv with a list of allowed unfoldings taken from a module. ### Applications written in Coq-Elpi - [Derive](apps/derive/examples/usage.v) shows how to obtain proved equality tests and a few extra gadgets out of inductive type declarations. See the [README](apps/derive/README.md) for the list of derivations. It comes bundled with Coq-Elpi. - [Locker](apps/locker) lets one hide the computational contents of definitions via modules or opaque locks. It comes bundled with Coq-Elpi. - [Hierarchy Builder](https://github.com/math-comp/hierarchy-builder) is a Coq extension to declare hierarchies of algebraic structures. - [Algebra Tactics](https://github.com/math-comp/algebra-tactics/) is a port of the `ring` and `field` tactics to the Mathematical Components library. - [Trakt](https://github.com/ecranceMERCE/trakt) is a generic goal preprocessing tool for proof automation tactics in Coq. - [Namespace Emulation System](apps/NES/examples/usage_NES.v) implements most of the features of namespaces (on top of Coq's modules). - [Dx](https://gitlab.univ-lille.fr/samuel.hym/dx) uses elpi to generate an intermediate representation of Coq terms, to be later tranformed into C. - [Coercion](apps/coercion) enable to program coercions in Elpi. It comes bundled with Coq-Elpi. ### Quick Reference In order to load Coq-Elpi use `From elpi Require Import elpi`. #### Vernacular commands
(click to expand) - `Elpi Command ` creates command named `` containing the preamble [elpi-command](elpi/elpi-command-template.elpi). - `Elpi Tactic ` creates a tactic `` containing the preamble [elpi-tactic](elpi/elpi-tactic-template.elpi). - `Elpi Db ` creates a Db (a program that is accumulated into other programs). `` is the initial contents of the Db, including the type declaration of its constituting predicates. It understands the `#[phase]` attribute, see [synterp-vs-interp](README.md#separation-of-parsing-from-execution-of-vernacular-commands). - `Elpi Program ` lower level primitive letting one crate a command/tactic with a custom preamble ``. - `From some.load.path Extra Dependency as `. - `Elpi Accumulate [|] [|File |Db ]` adds code to the current program (or `` or `` if specified). The code can be verbatim, from a file or a Db. File names `` must have been previously declared with the above command. It understands the `#[skip="rex"]` and `#[only="rex"]` which make the command a no op if the Coq version is matched (or not) by the given regular expression. It understands the `#[phase]` attribute, see [synterp-vs-interp](README.md#separation-of-parsing-from-execution-of-vernacular-commands) - `Elpi Typecheck []` typechecks the current program (or `` if specified). It understands the `#[phase]` attribute, see [synterp-vs-interp](README.md#separation-of-parsing-from-execution-of-vernacular-commands) - `Elpi Debug ` sets the variable ``, relevant for conditional clause compilation (the `:if VARIABLE` clause attribute). It understands the `#[phase]` attribute, see [synterp-vs-interp](README.md#separation-of-parsing-from-execution-of-vernacular-commands) - `Elpi Trace [[ ] *|Off]` enable/disable tracing, eventually limiting it to a specific range of execution steps or predicate names. It understands the `#[phase]` attribute, see [synterp-vs-interp](README.md#separation-of-parsing-from-execution-of-vernacular-commands) - `Elpi Trace Browser` enable/disable tracing for Elpi's [trace browser](). - `Elpi Bound Steps ` limits the number of steps an Elpi program can make. - `Elpi Print [ *]` prints the program `` to an HTML file named `.html` and a text file called `.txt` (or `` if provided) filtering out clauses whose file or clause-name matches ``. It understands the `#[phase]` attribute, see [synterp-vs-interp](README.md#separation-of-parsing-from-execution-of-vernacular-commands) where: - `` is a qualified Coq name, e.g. `derive.eq` or `my_program`. - `` is like `` but lives in a different namespace. By convention `` ends in `.db`, e.g. `derive.eq.db`. - `` is verbatim Elpi code, either `lp:{{ ... }}` or `" ... "` (in the latter case, strings delimiters need to be escaped following Coq rules, e.g. `lp:{{ coq.say "hello!" }}` becomes `" coq.say ""hello!"" "`). - `` is a string containing the path of an external file, e.g. `"this_file.elpi"`. - `` and `` are numbers, e.g. `17 24`. - `` is a regexp against which the predicate name is matched, e.g. `"derive.*"`.

#### Separation of parsing from execution of vernacular commands
(click to expand) Since version 8.18 Coq has separate parsing and execution phases, respectively called synterp and interp. Since Coq has an extensible grammar the parsing phase is not entirely performed by the parser: after parsing one sentence Coq evaluates its synterp action. The synterp actions of a command like `Import A.` are the subset of its effect which affect parsing, like enabling a notation. Later, during the execution phase Coq evaluates the its interp action, which includes effects like putting lemma names in scope or enables type class instances etc. Being able to parse an entire document quickly, without actually executing any sentence, is important for developing reactive user interfaces, but requires some extra work when defining new commands, in particular to separate their synterp actions from their interp ones. Each command defined with Coq-Elpi is split into two programs, one running during the parsing phase and the other one during the execution phase. ##### Declaration of synterp actions Each `Elpi Command` internally declares two programs with the same name. One to be run while the Coq document is parsed, the synterp-command, and the other one while it is executed, the interp command. `Elpi Accumulate`, by default, adds code to the interp-command. The `#[phase]` attribute can be used to accumulate code to the synterp-command or to both commands. `Elpi Typecheck` checks both commands. Each `Elpi Db` internally declares one db, by default for the interp phase. The `#[phase]` attribute can be used crate a database for the synterp phase, or for both phases. Note that databases for the two phases are distinct, no data is shared among them. In particular the `coq.elpi.accumulate*` API exists in both phases and only acts on data bases for the current phase. ##### The alignment of phases All synterp actions, i.e. calls to APIs dealing with modules and sections like begin/end-module or import/export, have to happen at *both* synterp and interp time and *in the same order*. In order to do so, the synterp-command may need to communicate data to the corresponding interp-command. There are two ways for doing so. The first one is to use, as the main entry points, the following ones: ``` pred main-synterp i:list argument, o:any. pred main-interp i:list argument, i:any. ``` Unlike `main` the former outputs a datum while the latter receives it in input. During the synterp phase the API `coq.synterp-actions` lists the actions performed so far. An excerpt from the [coq-builtin-synterp](coq-builtin-synterp.elpi) file: ``` % Action executed during the parsing phase (aka synterp) kind synterp-action type. type begin-module id -> synterp-action. type end-module modpath -> synterp-action. ``` The synterp-command can output data of that type, but also any other data it wishes. The second way to communicate data is implicit, but limited to synterp actions. Such synterp actions can be recorded into (nested) groups whose structure is declared using well-bracketed calls to predicates `coq.begin-synterp-group` and `coq.end-synterp-group` in the synterp phase. In the interp phase, one can then use predicate `coq.replay-synterp-action-group` to replay all the synterp actions of the group with the given name at once. In the case where one wishes to interleave code between the actions of a given group, it is also possible to match the synterp group structure at interp, via `coq.begin-synterp-group` and `coq.end-synterp-group`. Individual actions that are contained in the group then need to be replayed individually. One can use `coq.replay-next-synterp-actions` to replay all synterp actions until the next beginning/end of a synterp group. However, this is discouraged in favour of using groups explicitly, as this is more modular. Code that used to rely on the now-removed `coq.replay-all-missing-synterp-actions` predicate can rely on `coq.replay-next-synterp-actions` instead, but this is discouraged in favour of using groups explicitly) ##### Syntax of the `#[phase]` attribute - `#[phase="ph"]` where `"ph"` can be `"parsing"`, `"execution"` or `"both"` - `#[synterp]` is a shorthand for `#[phase="parsing"]` - `#[interp]` is a shorthand for `#[phase="execution]`

#### Invocation of Elpi code
(click to expand) - `Elpi *.` invokes the `main` predicate of the `` program passing a possible empty list of arguments. This is how you invoke a command. - `elpi *.` invokes the `solve` predicate of the `` program passing a possible empty list of arguments and the current goal. This is how you invoke a tactic. - `Elpi Export [As ]` makes it possible to invoke command `` (or `` if given) without the `Elpi` prefix or invoke tactic `` in the middle of a term just writing ` args` instead of `ltac:(elpi args)`. Note that in the case of tactics, all arguments are considered to be terms. Moreover, remember that one can use `Tactic Notation` to give the tactic a better syntax and a shorter name when used in the middle of a proof script. where `` can be: - a number, e.g. `3`, represented in Elpi as `(int 3)` - a string, e.g. `"foo"` or `bar.baz`, represented in Elpi as `(str "foo")` and `(str "bar.baz")`. Coq keywords and symbols are recognized as strings, eg `=>` requires no quotes. Quotes are necessary if the string contains a space or a character that is not accepted for qualified identifiers or if the string is `Definition`, `Axiom`, `Record`, `Structure`, `Inductive`, `CoInductive`, `Variant` or `Context`. - a term, e.g. `(3)` or `(f x)`, represented in Elpi as `(trm ...)`. Note that terms always require parentheses, that is `3` is a number while `(3)` is a Coq term and depending on the context could be a natural number (i.e. `S (S (S O))`) or a `Z` or ... See also the section Terms as arguments down below, and the syntax for Ltac variables down below. Commands also accept the following arguments (the syntax is as close as possible to the Coq one: [...] means optional, * means 0 or more). See the `argument` data type in `coq-builtin.elpi` for their HOAS encoding. See also the section Terms as arguments down below. - `Definition` _name_ _binder_* [`:` _term_] `:=` _term_ - `Axiom` _name_ `:` _term_ - [ `Record` | `Structure` ] _name_ _binder_* [`:` _sort_] `:=` [_name_] `{` _name_ `:` _term_ `;` * `}` - [ `Inductive` | `CoInductive` | `Variant` ] _name_ _binder_* [`|` _binder_*] [`:` _term_] `:=` `|` _name_ _binder_* `:` _term_ * - `Context` _binder_* ##### Ltac Variables Tactics also accept Ltac variables as follows: - `ltac_string:(v)` (for `v` of type `string` or `ident`) - `ltac_int:(v)` (for `v` of type `int` or `integer`) - `ltac_term:(v)` (for `v` of type `constr` or `open_constr` or `uconstr` or `hyp`) - `ltac_(string|int|term)_list:(v)` (for `v` of type `list` of ...) - `ltac_tactic:(t)` (for `t` of type `tactic_expr`) - `ltac_attributes:(v)` (for `v` of type `attributes`) For example: ```coq Tactic Notation "tac" string(X) ident(Y) int(Z) hyp(T) constr_list(L) simple_intropattern_list(P) := elpi tac ltac_string:(X) ltac_string:(Y) ltac_int:(Z) ltac_term:(T) ltac_term_list:(L) ltac_tactic:(intros P). ``` lets one write `tac "a" b 3 H t1 t2 t3 [|m]` in any Ltac context. Arguments are first interpreted by Ltac according to the types declared in the tactic notation and then injected in the corresponding Elpi argument. For example `H` must be an existing hypothesis, since it is typed with the `hyp` Ltac type, but in Elpi it will appear as a term, eg `trm c0`. Similarly `t1`, `t2` and `t3` are checked to be well typed and to contain no unresolved implicit arguments, since this is what the `constr` Ltac type means If they were typed as `open_constr` or `uconstr`, the last or both checks would be respectively skipped. In any case they are passed to the Elpi code as `trm ...`. Both `"a"` and `b` are passed to Elpi as `str ...`. Finally, `ltac_term:(T)` and `(T)` are *not* synonyms: but the former must be used when defining tactic notations, the latter when invoking elpi tactics directly. ##### Attributes Attributes are supported in both commands and tactics. Examples: - `#[ att ] Elpi cmd` - `#[ att ] cmd` for a command `cmd` exported via `Elpi Export cmd` - `#[ att ] elpi tac` - `Tactic Notation ... attributes(A) ... := ltac_attributes:(A) elpi tac`. Due to a parsing conflict in Coq grammar, at the time of writing this code: ```coq Tactic Notation "#[" attributes(A) "]" "tac" := ltac_attributes:(A) elpi tac. ``` has the following limitation: - `#[ att ] tac.` does not parse - `(#[ att ] tac).` works - `idtac; #[ att ] tac.` works ##### Terms as arguments Since version 1.15, terms passed to Elpi commands code via `(term)` or via a declaration (like `Record`, `Inductive` ...) are in elaborated format by default. This means that all Coq notational facilities are available, like deep pattern matching, or tactics in terms. One can use the attribute `#[arguments(raw)]` to declare a command which instead takes arguments in raw format. In that case, notations are unfolded, implicit arguments are expanded (holes `_` are added) and lexical analysis is performed (global names and bound names are identified, holes are applied to bound names in scope), but deep pattern matching or tactics in terms are not supported, and in particular type checking/inference is not performed. Once can use the `coq.typecheck` or `coq.elaborate-skeleton` APIs to fill in implicit arguments and insert coercions on raw terms. Terms passed to Elpi tactics via tactic notations can be forced to be elaborated beforehand by declaring the parameters to be of type `constr` or `open_constr`. Arguments of type `uconstr` are passed raw. ##### Testing/debugging: - `Elpi Query [] ` runs `` in the current program (or in `` if specified). - `Elpi Query [] ` runs `` in the current (synterp) program (or in `` if specified) and `` in the current program (or ``). - `elpi query [] *` runs the `` predicate (that must have the same signature of the default predicate `solve`).

#### Supported features of Gallina (core calculus of Coq)
(click to expand) - [x] functional core (fun, forall, match, application, let-in, sorts) - [x] evars (unification variables) - [x] single Inductive and CoInductive types (including parameters, non-uniform parameters, indexes) - [ ] mutual Inductive and CoInductive types - [x] fixpoints - [ ] mutual fixpoints - [ ] cofixpoints - [x] primitive records - [x] primitive projections - [x] primitive integers - [x] primitive floats - [ ] primitive arrays - [x] universe polymorphism - [x] modules - [x] module types - [x] functor application - [x] functor definition

#### Supported features of Gallina's extensions (extra logical features, APIs)
(click to expand) Checked boxes are available, unchecked boxes are planned, missing items are not planned. This is a high level list, for the details see [coq-builtin](coq-builtin.elpi). - [x] i/o: messages, warnings, errors, Coq version - [x] logical environment: read, write, locate + [x] dependencies between objects - [x] type classes database: read, write + [ ] take over resolution - [x] canonical structures database: read, write + [ ] take over resolution - [x] coercions database: read, write - [x] sections: open, close - [x] scope management: import, export - [x] hints: mode, opaque, resolve, strategy - [x] arguments: implicit, name, scope, simpl - [x] abbreviations: read, write, locate - [x] typing and elaboration - [x] unification - [x] reduction: `lazy`, `cbv`, `vm`, `native` - [x] flags for `lazy` and `cbv` - [x] ltac1: bridge to call ltac1 code, mono and multi-goal tactics - [x] option system: get, set, add - [x] pretty printer: boxes, printing width - [x] attributes: read

#### Relevant files - [coq-builtin](coq-builtin.elpi) documents the HOAS encoding of Coq terms and the API to access Coq - [coq-builtin-synterp](coq-builtin-synterp.elpi) documents APIs to interact with Coq at parsing time - [elpi-buitin](elpi-builtin.elpi) documents Elpi's standard library, you may look here for list processing code - [coq-lib](elpi/coq-lib.elpi) provides some utilities to manipulate Coq terms; it is an addendum to coq-builtin - [elpi-command-template](elpi/elpi-command-template.elpi) provides the pre-loaded code for `Elpi Command` (execution phase) - [elpi-command-template-synterp](elpi/elpi-command-template-synterp.elpi) provides the pre-loaded code for `Elpi Command` (parsing phase) - [elpi-tactic-template](elpi/elpi-tactic-template.elpi) provides the pre-loaded code for `Elpi Tactic` #### Organization of the repository The code of the Coq plugin is at the root of the repository in the [src](src/), [elpi](elpi/) and [theories](theories/) directories. The [apps](apps/) directory contains client applications written in Coq-Elpi. coq-elpi-2.1.0/_CoqProject000066400000000000000000000034011460156013500153550ustar00rootroot00000000000000-arg -w -arg +elpi.deprecated -R theories elpi -Q examples elpi.examples -Q tests elpi.tests -Q src elpi -Q apps/derive/tests elpi.apps.derive.tests -Q tests elpi.tests -Q elpi elpi # Derive -R apps/derive/theories elpi.apps -R apps/derive/tests elpi.apps.derive.tests -R apps/derive/examples elpi.apps.derive.examples # NES -R apps/NES/theories elpi.apps -R apps/NES/elpi elpi.apps.NES -R apps/NES/tests elpi.apps.NES.tests -R apps/NES/examples elpi.apps.NES.examples # Eltac -R apps/eltac/theories elpi.apps.eltac -R apps/eltac/tests elpi.apps.eltac.tests -R apps/eltac/examples elpi.apps.eltac.examples # Coercion -R apps/coercion/theories elpi.apps.coercion -R apps/coercion/tests elpi.apps.tc.coercion -I apps/coercion/src # CS -R apps/cs/theories elpi.apps.cs -R apps/cs/tests elpi.apps.tc.cs -I apps/cs/src # Type classes -R apps/tc/theories elpi.apps.tc -R apps/tc/tests elpi.apps.tc.tests -R apps/tc/elpi elpi.apps.tc -I apps/tc/src # Coq-elpi theories/elpi.v theories/wip/memoization.v -I src src/META.coq-elpi src/coq_elpi_graph.mli src/coq_elpi_graph.ml src/coq_elpi_vernacular_syntax.mlg src/coq_elpi_vernacular.ml src/coq_elpi_vernacular.mli src/coq_elpi_programs.ml src/coq_elpi_programs.mli src/coq_elpi_utils.mli src/coq_elpi_utils.ml src/coq_elpi_HOAS.ml src/coq_elpi_HOAS.mli src/coq_elpi_name_quotation.ml src/coq_elpi_glob_quotation.ml src/coq_elpi_glob_quotation.mli src/coq_elpi_arg_HOAS.ml src/coq_elpi_arg_HOAS.mli src/coq_elpi_arg_syntax.mlg src/coq_elpi_builtins_arg_HOAS.ml src/coq_elpi_builtins_HOAS.ml src/coq_elpi_builtins_synterp.ml src/coq_elpi_builtins_synterp.mli src/coq_elpi_builtins.ml src/coq_elpi_builtins.mli src/coq_elpi_config.ml src/elpi_plugin.mlpack coq-elpi-2.1.0/_CoqProject.examples000066400000000000000000000011611460156013500171730ustar00rootroot00000000000000-arg -w -arg +elpi.deprecated -arg -bt -Q theories elpi -Q examples elpi.examples -Q tests elpi.tests -I src/ -Q elpi unreleased -docroot elpi examples/tutorial_elpi_lang.v examples/tutorial_coq_elpi_HOAS.v examples/tutorial_coq_elpi_command.v examples/tutorial_coq_elpi_tactic.v examples/example_reflexive_tactic.v examples/example_curry_howard_tactics.v examples/example_data_base.v examples/example_record_expansion.v examples/example_record_to_sigma.v examples/example_fuzzer.v examples/example_generalize.v examples/example_import_projections.v examples/example_reduction_surgery.v examples/example_abs_evars.v coq-elpi-2.1.0/_CoqProject.test000066400000000000000000000024741460156013500163440ustar00rootroot00000000000000-arg -w -arg +elpi.deprecated -arg -bt -Q theories elpi -Q examples elpi.examples -Q tests elpi.tests -I src/ -Q elpi unreleased -docroot elpi tests/test_API.v tests/test_API_elaborate.v tests/test_API_typecheck.v tests/test_API_env.v tests/test_API_module.v tests/test_API_section.v tests/test_API_TC_CS.v tests/test_API_arguments.v tests/test_API_notations.v tests/test_API2.v tests/test_HOAS.v tests/test_arg_HOAS.v tests/test_quotation.v tests/test_vernacular1.v tests/test_vernacular2.v tests/test_tactic.v tests/test_elaborator.v tests/test_ltac.v tests/test_ltac2.v tests/test_ltac3.v tests/test_cache_async.v tests/test_COQ_ELPI_ATTRIBUTES.v tests/perf_calls.v tests/test_require_bad_order.v tests/test_ctx_cache.v tests/test_libobject_A.v tests/test_libobject_B.v tests/test_libobject_C.v tests/test_glob.v tests/test_link_perf.v tests/test_link_order1.v tests/test_link_order2.v tests/test_link_order3.v tests/test_link_order4.v tests/test_link_order5.v tests/test_link_order6.v tests/test_link_order7.v tests/test_link_order8.v tests/test_link_order9.v tests/test_API_new_pred.v tests/test_link_order_import0.v tests/test_link_order_import1.v tests/test_link_order_import2.v tests/test_link_order_import3.v tests/test_query_extra_dep.v tests/test_toposort.v tests/test_synterp.v tests/test_checker.v tests/test_replay.v coq-elpi-2.1.0/apps/000077500000000000000000000000001460156013500141675ustar00rootroot00000000000000coq-elpi-2.1.0/apps/NES/000077500000000000000000000000001460156013500146145ustar00rootroot00000000000000coq-elpi-2.1.0/apps/NES/Makefile000066400000000000000000000022501460156013500162530ustar00rootroot00000000000000# detection of coq ifeq "$(COQBIN)" "" COQBIN := $(shell which coqc >/dev/null 2>&1 && dirname `which coqc`) endif ifeq "$(COQBIN)" "" $(error Coq not found, make sure it is installed in your PATH or set COQBIN) else $(info Using coq found in $(COQBIN), from COQBIN or PATH) endif export COQBIN := $(COQBIN)/ all: build test build: Makefile.coq @$(MAKE) --no-print-directory -f Makefile.coq test: Makefile.test.coq @$(MAKE) --no-print-directory -f Makefile.test.coq theories/%.vo: force @$(MAKE) --no-print-directory -f Makefile.coq $@ tests/%.vo: force build Makefile.test.coq @$(MAKE) --no-print-directory -f Makefile.test.coq $@ examples/%.vo: force build Makefile.test.coq @$(MAKE) --no-print-directory -f Makefile.test.coq $@ Makefile.coq Makefile.coq.conf: _CoqProject @$(COQBIN)/coq_makefile -f _CoqProject -o Makefile.coq @$(MAKE) --no-print-directory -f Makefile.coq .merlin Makefile.test.coq Makefile.test.coq.conf: _CoqProject.test @$(COQBIN)/coq_makefile -f _CoqProject.test -o Makefile.test.coq clean: Makefile.coq Makefile.test.coq @$(MAKE) -f Makefile.coq $@ @$(MAKE) -f Makefile.test.coq $@ .PHONY: force all build test install: @$(MAKE) -f Makefile.coq $@ coq-elpi-2.1.0/apps/NES/Makefile.coq.local000066400000000000000000000002231460156013500201230ustar00rootroot00000000000000install-extra:: df="`$(COQMKFILE) -destination-of theories/NES.vo $(COQLIBS)`";\ install -m 0644 $(wildcard elpi/*.elpi) "$(COQLIBINSTALL)/$$df" coq-elpi-2.1.0/apps/NES/_CoqProject000066400000000000000000000002541460156013500167500ustar00rootroot00000000000000# Hack to see Coq-Elpi even if it is not installed yet -Q ../../theories elpi -I ../../src -docroot elpi.apps -R theories elpi.apps -Q elpi elpi.apps.NES theories/NES.v coq-elpi-2.1.0/apps/NES/_CoqProject.test000066400000000000000000000006111460156013500177230ustar00rootroot00000000000000# Hack to see Coq-Elpi even if it is not installed yet -Q ../../theories elpi -I ../../src -docroot elpi.apps -Q elpi elpi.apps.NES -R theories elpi.apps -R tests elpi.apps.NES.tests -R examples elpi.apps.NES.examples tests/test_NES.v tests/test_NES_resolve.v tests/test_NES_perf.v tests/test_NES_perf_optimal.v tests/test_module_namespace.v tests/test_NES_lib.v examples/usage_NES.vcoq-elpi-2.1.0/apps/NES/elpi/000077500000000000000000000000001460156013500155455ustar00rootroot00000000000000coq-elpi-2.1.0/apps/NES/elpi/nes_interp.elpi000066400000000000000000000056521460156013500205760ustar00rootroot00000000000000namespace nes { % Print a namespace pred print-path i:list string, i:(gref -> coq.pp -> prop). print-path Path PP :- std.do! [ std.map {std.findall (ns Path _)} (p\ mp\ p = ns _ mp) MPs, print.pp-list MPs (print.pp-module Path PP) Out, coq.say {coq.pp->string Out}, ]. pred begin-path. begin-path :- coq.replay-synterp-action-group "nes.begin-path". pred end-path. end-path :- coq.replay-synterp-action-group "nes.end-path". pred open-path. open-path :- coq.replay-synterp-action-group "nes.open-path". namespace print { pred pp-list i:list A, i:(A -> coq.pp -> prop), o:coq.pp. pp-list L F Out :- std.do! [ std.map-filter L F PPs, Out = coq.pp.box (coq.pp.v 0) {std.intersperse (coq.pp.brk 0 0) PPs}, ]. kind context type. type context list string -> % readable path int -> % length of full path (gref -> coq.pp -> prop) -> context. % Hides `aux` modules pred readable-path i:context, i:list string, o:list string. readable-path (context Prefix N _) FullPath Path :- std.do! [ std.drop N FullPath RelPath, std.append Prefix RelPath Path, ]. pred module-context i:list string, i:modpath, i:(gref -> coq.pp -> prop), o:context. module-context Prefix MP PP Ctx :- std.do! [ coq.modpath->path MP FullPath, Ctx = context Prefix {std.length FullPath} PP, ]. pred submodule-context i:context, i:modpath, o:context. submodule-context (context _ _ PP as Ctx) MP Ctx' :- std.do! [ coq.modpath->path MP FullPath, readable-path Ctx FullPath Path, Ctx' = context Path {std.length FullPath} PP, ]. pred pp-module i:list string, i:(gref -> coq.pp -> prop), i:modpath, o:coq.pp. pp-module Prefix PP MP Out :- std.do! [ pp-module-items {module-context Prefix MP PP} {coq.env.module MP} Out, ]. pred pp-module-items i:context i:list module-item, o:coq.pp. pp-module-items Ctx Items Out :- pp-list Items (pp-module-item Ctx) Out. pred pp-module-item i:context, i:module-item, o:coq.pp. pp-module-item (context _ _ PP) (gref GR) Out :- PP GR Out, !. pp-module-item Ctx (submodule MP Items) Out :- std.do! [ pp-module-items {submodule-context Ctx MP} Items Out, ]. pp-module-item Ctx (module-type MTP) Out :- pp-modtypath Ctx MTP Out. pp-module-item Ctx (module-type-functor MTP _) Out :- pp-modtypath Ctx MTP Out. pp-module-item Ctx (module-functor MP _) Out :- pp-modpath Ctx MP Out. pred pp-path i:context, i:string, i:list string, o:coq.pp. pp-path Ctx What FullPath Out :- std.do! [ readable-path Ctx FullPath Path, Out = coq.pp.box coq.pp.h [ coq.pp.str What, coq.pp.spc, coq.pp.str {std.string.concat "." Path}, ], ]. pred pp-modtypath i:context, i:modtypath, o:coq.pp. pp-modtypath Ctx MTP Out :- std.do! [ pp-path Ctx "Module Type" {coq.modtypath->path MTP} Out, ]. pred pp-modpath i:context, i:modpath, o:coq.pp. pp-modpath Ctx MP Out :- std.do! [ pp-path Ctx "Module" {coq.modpath->path MP} Out, ]. } } coq-elpi-2.1.0/apps/NES/elpi/nes_synterp.elpi000066400000000000000000000135041460156013500207740ustar00rootroot00000000000000namespace nes { pred ns->modpath i:prop, o:modpath. ns->modpath (ns _ M) M. pred open-ns->string i:prop, o:string. open-ns->string (open-ns S _) S. pred begin-ns i:string, i:list string, i:list prop, o:list prop. begin-ns NS Path In Out :- if (Path = []) (Fresh is NS ^ "_aux_" ^ {std.any->string {new_int} }, coq.env.begin-module Fresh none) true, coq.env.begin-module NS none, coq.env.current-path CP, Clause = open-ns NS CP, Out = [Clause | In], @local! => coq.elpi.accumulate current "NES.db" (clause _ (after "open-ns:begin") Clause). pred subpath i:list string, i:prop. subpath Path (ns Sub _) :- std.appendR _Prefix Path Sub. pred submod i:modpath, i:prop. submod Mod (ns _ SubMod) :- coq.modpath->path SubMod SubPath, coq.modpath->path Mod ModPath, std.appendR ModPath _Suffix SubPath. pred undup i:list A, i:list A, o:list A. undup [] _ []. undup [X|XS] Seen YS :- std.mem! Seen X, !, undup XS Seen YS. undup [X|XS] Seen [X|YS] :- undup XS [X|Seen] YS. % end-ns ID Stack ClauseIn ClauseOut pred end-ns i:string, i:list string, i:list prop, o:list prop. end-ns NS Stack In Out :- In => std.do! [ std.rev Stack Path, std.append Path [NS|END_] PathNoEnd, std.findall (ns PathNoEnd M_) AllNS, coq.env.end-module M, % stuff inside M std.filter AllNS (submod M) SubmodNS, % since the current program still sees the clauses that will be dropped % after closing M undup SubmodNS [] SubmodNSNodup, coq.locate-module NS M, if (Path = []) (std.do! [coq.env.end-module M_aux, coq.env.export-module M_aux, Local = @global!]) (Local = @local!), % NES.Open can put clauses in scope std.append Path [NS] NewPath, New = [ns NewPath M | SubmodNSNodup], std.append In New Out, std.forall New (c\ Local => coq.elpi.accumulate current "NES.db" (clause _ _ c)), ]. pred iter-> i:list A, i:list A, i:(A -> list A -> list prop -> list prop -> prop), i:list prop, o:list prop. iter-> _ [] _ O O :- coq.error "No elements". iter-> INIT [X] F In Out :- !, F X INIT In Out. iter-> INIT [X|XS] F In Out :- F X {std.append XS INIT} In Mid, iter-> INIT XS F Mid Out. pred iter<- i:list A, i:list A, i:(A -> list A -> list prop -> list prop -> prop), i:list prop, o:list prop. iter<- _ [] _ _ _ :- coq.error "No elements". iter<- INIT [X] F In Out :- !, F X INIT In Out. iter<- INIT [X|XS] F In Out :- iter<- INIT XS F In Mid, F X {std.append XS INIT} Mid Out. % Panics unless [S] well-formed. pred string->non-empty-ns i:string, o:list string. string->non-empty-ns S L :- std.do! [ Ident = "[a-zA-Z_][a-zA-Z_0-9']*", % non-unicode Coq identifiers Path is "^\\(" ^ Ident ^ "\\.\\)*" ^ Ident ^ "$", if (rex.match Path S) true (string->ns.err S), rex.split "\\." S L, if (std.mem L "_") (string->ns.err S) true, ]. pred string->ns.err i:string. string->ns.err S :- coq.error {calc ("NES: Bad : \"" ^ S ^ "\"")}. % Panics unless [S] empty, or well-formed. pred string->ns i:string, o:list string. string->ns "" [] :- !. string->ns S L :- string->non-empty-ns S L. pred ns->string i:list string, o:string. ns->string NS S :- std.string.concat "." NS S. pred begin-path i:list string, o:list prop. begin-path [] [] :- std.do! [ coq.begin-synterp-group "nes.begin-path" Group, coq.end-synterp-group Group, ]. begin-path ([_|_] as Path) Out :- std.do! [ coq.begin-synterp-group "nes.begin-path" Group, coq.env.current-path CP, if (open-ns _ NSCP) (std.assert! (NSCP = CP) "NS: cannot begin a namespace inside a module that is inside a namespace") true, std.map {std.findall (open-ns Y_ P_)} open-ns->string Stack, if (Stack = []) true (std.do! [ coq.locate-all {std.string.concat "." Path} L, if (std.do! [ std.mem L (loc-modpath M), coq.modpath->path M MP, MP = {std.append CP Path} ]) (iter-> [] Stack end-ns [] _, iter<- [] Stack begin-ns [] _) true, ]), iter<- Stack {std.rev Path} begin-ns [] Out, open-super-path Path [], coq.end-synterp-group Group, ]. pred std.time-do! i:list prop. std.time-do! []. std.time-do! [P|PS] :- std.time P T, coq.say P "\ntakes" T "\n", !, std.time-do! PS. pred end-path i:list string, o:list prop. end-path [] [] :- std.do! [ coq.begin-synterp-group "nes.end-path" Group, coq.end-synterp-group Group, ]. end-path ([_|_] as Path) Out :- std.do! [ coq.begin-synterp-group "nes.end-path" Group, std.map {std.findall (open-ns X_ P_)} nes.open-ns->string Stack, std.assert! (std.appendR {std.rev Path} Bottom Stack) "NES: Ending a namespace that is not begun", nes.iter-> Bottom {std.rev Path} nes.end-ns [] Out, coq.end-synterp-group Group, ]. pred open-path i:list string. open-path Path :- std.do! [ coq.begin-synterp-group "nes.open-path" Group, std.map {std.findall (ns Path M_)} nes.ns->modpath Mods, std.forall Mods coq.env.import-module, coq.end-synterp-group Group, ]. pred open-super-path i:list string, i:list string. open-super-path [] _. open-super-path [P|PS] ACC :- std.append ACC [P] Cur, open-path Cur, open-super-path PS Cur. % Currently open namespace, or []. pred current-path o:list string. current-path NS :- std.do! [ std.map {std.findall (open-ns X_ P_)} nes.open-ns->string Stack, std.rev Stack NS, ]. % Find an existing namespace, or panic. pred resolve i:string, o:list string. resolve S Path :- std.do! [ if (Top = "^_\\.", rex.match Top S) (std.do! [ rex.replace Top "" S S', string->non-empty-ns S' NS, if (ns NS _) (Path = NS) (resolve.err S'), ])( resolve.walk S {current-path} {string->non-empty-ns S} Path ), ]. pred resolve.walk i:string, i:list string, i:list string, o:list string. resolve.walk S Ctx SP Path :- std.do! [ std.append Ctx SP Candidate, ( ns Candidate _, Path = Candidate ; Ctx = [], resolve.err S ; resolve.walk S {std.drop-last 1 Ctx} SP Path ), ]. pred resolve.err i:string. resolve.err S :- coq.error "NES: Namespace not found:" S. } coq-elpi-2.1.0/apps/NES/examples/000077500000000000000000000000001460156013500164325ustar00rootroot00000000000000coq-elpi-2.1.0/apps/NES/examples/usage_NES.v000066400000000000000000000037201460156013500204340ustar00rootroot00000000000000From elpi.apps Require Import NES. (* Namespaces are like modules, since they let you organize your notions and avoid name collisions. Namespaces are unlinke modules, since you can always add a notion to a namespace, even if the namespace was ended before. *) NES.Begin This.Is.A.Long.Namespace. Definition stuff := 1. NES.End This.Is.A.Long.Namespace. NES.Begin This.Is.A.Long.Namespace. Definition more_stuff := stuff. (* stuff in the namespace is visible *) NES.End This.Is.A.Long.Namespace. Print This.Is.A.Long.Namespace.stuff. (* = 1 *) Eval compute in This.Is.A.Long.Namespace.more_stuff. (* = 1 *) (* Unlike a module, a namespace can contain two notions with the same name. The latter shadows the former. *) NES.Begin This.Is.A.Long.Namespace. Definition stuff := 2. NES.End This.Is.A.Long.Namespace. (* Binding is static, eg more_stuff still values 1 *) Print This.Is.A.Long.Namespace.stuff. (* = 2 *) Eval compute in This.Is.A.Long.Namespace.more_stuff. (* = 1 *) (* Listing and printing namespaces *) NES.List This. (* This_aux_1.This.Is.A.Long.Namespace.stuff (* <-- shadowed *) This.Is.A.Long.Namespace.more_stuff This.Is.A.Long.Namespace.stuff *) NES.Print This. (* This_aux_1.This.Is.A.Long.Namespace.stuff : nat This.Is.A.Long.Namespace.more_stuff : nat This.Is.A.Long.Namespace.stuff : nat *) (* For convenience one can open a namespace to write short names *) NES.Open This.Is.A.Long.Namespace. Print stuff. (* Not quite a name space yet *) Structure Default := { sort : Type; default : sort }. NES.Begin CS. Global Canonical Structure nat_def := {| sort := nat; default := 46 |}. Check @default _ : nat. NES.End CS. Fail Check nat_def. (* we want nat_def to live in the CS namespace, BUT we want the canonical structure declaration to live outside the namespace *) Fail Check @default _ : nat. (* This behavior requires Libobject to be aware of the role played by a module: if it is a namespace some "actions" have to be propagated upward *) coq-elpi-2.1.0/apps/NES/tests/000077500000000000000000000000001460156013500157565ustar00rootroot00000000000000coq-elpi-2.1.0/apps/NES/tests/test_NES.v000066400000000000000000000023021460156013500176260ustar00rootroot00000000000000From elpi.apps Require Import NES. (* Some invalid namespaces *) Fail NES.Begin. Fail NES.Begin "". Fail NES.Begin ".". Fail NES.Begin ".A". Fail NES.Begin "A.". Fail NES.Begin "A..B". Fail NES.Begin "A._.B". (* name space creation *) NES.Begin Foo. Definition x := 3. NES.End Foo. Print Foo.x. (* adding one name inside an existing name space *) NES.Begin Foo. Definition x2 := 4. NES.End Foo. Print Foo.x. Print Foo.x2. (* shadowing: adding the same name twice *) NES.Begin Foo. Definition x := 5. NES.End Foo. Check (refl_equal _ : Foo.x = 5). (* shadowing *) (* nesting *) NES.Begin A. NES.Begin B. Definition c := 1. NES.End B. NES.End A. About A.B.c. (* adding one name inside an existing, nested, name space *) NES.Begin A1. NES.Begin B1. Definition c := 1. NES.End B1. NES.Begin B1. Definition d := 1. NES.End B1. NES.End A1. About A1.B1.d. About A1.B1.c. (* all names in the Foo namespace must be visible *) NES.Open Foo. Print x. Print x2. NES.Open A1. Print B1.c. Print B1.d. NES.Open A1.B1. Print d. (* boh *) NES.Begin A2.B2. Definition e := 1. NES.End B2. NES.End A2. NES.Begin A2.B2. Definition f := 2. NES.End A2.B2. Print A2.B2.f. NES.Begin X. Module Y. Fail NES.Begin Z. End Y. NES.End X. coq-elpi-2.1.0/apps/NES/tests/test_NES_lib.v000066400000000000000000000014231460156013500204570ustar00rootroot00000000000000From elpi.apps.NES Extra Dependency "nes_synterp.elpi" as nes_synterp. From elpi.apps.NES Extra Dependency "nes_interp.elpi" as nes_interp. From elpi.apps Require Import NES. Elpi Command Make. #[phase="both"] Elpi Accumulate Db NES.db. #[synterp] Elpi Accumulate File nes_synterp. #[interp] Elpi Accumulate File nes_interp. #[synterp] Elpi Accumulate lp:{{ main [str Path] :- std.do! [ nes.string->ns Path NS, nes.begin-path NS OpenNS, OpenNS => nes.end-path NS _NewNS, ]. main _ :- coq.error "usage: Make ". }}. #[interp] Elpi Accumulate lp:{{ main _ :- std.do! [ nes.begin-path, coq.env.add-const "x" {{ 42 }} _ @transparent! _C, nes.end-path, ]. }}. Elpi Typecheck. Elpi Export Make. Make Cats.And.Dogs. Print Cats.And.Dogs.x. coq-elpi-2.1.0/apps/NES/tests/test_NES_perf.v000066400000000000000000000623321460156013500206530ustar00rootroot00000000000000From elpi.apps Require Import NES. NES.Begin NS1. Definition x := 0. NES.End NS1. NES.Begin NS2. Definition x := 0. NES.End NS2. NES.Begin NS3. Definition x := 0. NES.End NS3. NES.Begin NS4. Definition x := 0. NES.End NS4. NES.Begin NS5. Definition x := 0. NES.End NS5. NES.Begin NS6. Definition x := 0. NES.End NS6. NES.Begin NS7. Definition x := 0. NES.End NS7. NES.Begin NS8. Definition x := 0. NES.End NS8. NES.Begin NS9. Definition x := 0. NES.End NS9. NES.Begin NS10. Definition x := 0. NES.End NS10. NES.Begin NS11. Definition x := 0. NES.End NS11. NES.Begin NS12. Definition x := 0. NES.End NS12. NES.Begin NS13. Definition x := 0. NES.End NS13. NES.Begin NS14. Definition x := 0. NES.End NS14. NES.Begin NS15. Definition x := 0. NES.End NS15. NES.Begin NS16. Definition x := 0. NES.End NS16. NES.Begin NS17. Definition x := 0. NES.End NS17. NES.Begin NS18. Definition x := 0. NES.End NS18. NES.Begin NS19. Definition x := 0. NES.End NS19. NES.Begin NS20. Definition x := 0. NES.End NS20. NES.Begin NS21. Definition x := 0. NES.End NS21. NES.Begin NS22. Definition x := 0. NES.End NS22. NES.Begin NS23. Definition x := 0. NES.End NS23. NES.Begin NS24. Definition x := 0. NES.End NS24. NES.Begin NS25. Definition x := 0. NES.End NS25. NES.Begin NS26. Definition x := 0. NES.End NS26. NES.Begin NS27. Definition x := 0. NES.End NS27. NES.Begin NS28. Definition x := 0. NES.End NS28. NES.Begin NS29. Definition x := 0. NES.End NS29. NES.Begin NS30. Definition x := 0. NES.End NS30. NES.Begin NS31. Definition x := 0. NES.End NS31. NES.Begin NS32. Definition x := 0. NES.End NS32. NES.Begin NS33. Definition x := 0. NES.End NS33. NES.Begin NS34. Definition x := 0. NES.End NS34. NES.Begin NS35. Definition x := 0. NES.End NS35. NES.Begin NS36. Definition x := 0. NES.End NS36. NES.Begin NS37. Definition x := 0. NES.End NS37. NES.Begin NS38. Definition x := 0. NES.End NS38. NES.Begin NS39. Definition x := 0. NES.End NS39. NES.Begin NS40. Definition x := 0. NES.End NS40. NES.Begin NS41. Definition x := 0. NES.End NS41. NES.Begin NS42. Definition x := 0. NES.End NS42. NES.Begin NS43. Definition x := 0. NES.End NS43. NES.Begin NS44. Definition x := 0. NES.End NS44. NES.Begin NS45. Definition x := 0. NES.End NS45. NES.Begin NS46. Definition x := 0. NES.End NS46. NES.Begin NS47. Definition x := 0. NES.End NS47. NES.Begin NS48. Definition x := 0. NES.End NS48. NES.Begin NS49. Definition x := 0. NES.End NS49. NES.Begin NS50. Definition x := 0. NES.End NS50. NES.Begin NS51. Definition x := 0. NES.End NS51. NES.Begin NS52. Definition x := 0. NES.End NS52. NES.Begin NS53. Definition x := 0. NES.End NS53. NES.Begin NS54. Definition x := 0. NES.End NS54. NES.Begin NS55. Definition x := 0. NES.End NS55. NES.Begin NS56. Definition x := 0. NES.End NS56. NES.Begin NS57. Definition x := 0. NES.End NS57. NES.Begin NS58. Definition x := 0. NES.End NS58. NES.Begin NS59. Definition x := 0. NES.End NS59. NES.Begin NS60. Definition x := 0. NES.End NS60. NES.Begin NS61. Definition x := 0. NES.End NS61. NES.Begin NS62. Definition x := 0. NES.End NS62. NES.Begin NS63. Definition x := 0. NES.End NS63. NES.Begin NS64. Definition x := 0. NES.End NS64. NES.Begin NS65. Definition x := 0. NES.End NS65. NES.Begin NS66. Definition x := 0. NES.End NS66. NES.Begin NS67. Definition x := 0. NES.End NS67. NES.Begin NS68. Definition x := 0. NES.End NS68. NES.Begin NS69. Definition x := 0. NES.End NS69. NES.Begin NS70. Definition x := 0. NES.End NS70. NES.Begin NS71. Definition x := 0. NES.End NS71. NES.Begin NS72. Definition x := 0. NES.End NS72. NES.Begin NS73. Definition x := 0. NES.End NS73. NES.Begin NS74. Definition x := 0. NES.End NS74. NES.Begin NS75. Definition x := 0. NES.End NS75. NES.Begin NS76. Definition x := 0. NES.End NS76. NES.Begin NS77. Definition x := 0. NES.End NS77. NES.Begin NS78. Definition x := 0. NES.End NS78. NES.Begin NS79. Definition x := 0. NES.End NS79. NES.Begin NS80. Definition x := 0. NES.End NS80. NES.Begin NS81. Definition x := 0. NES.End NS81. NES.Begin NS82. Definition x := 0. NES.End NS82. NES.Begin NS83. Definition x := 0. NES.End NS83. NES.Begin NS84. Definition x := 0. NES.End NS84. NES.Begin NS85. Definition x := 0. NES.End NS85. NES.Begin NS86. Definition x := 0. NES.End NS86. NES.Begin NS87. Definition x := 0. NES.End NS87. NES.Begin NS88. Definition x := 0. NES.End NS88. NES.Begin NS89. Definition x := 0. NES.End NS89. NES.Begin NS90. Definition x := 0. NES.End NS90. NES.Begin NS91. Definition x := 0. NES.End NS91. NES.Begin NS92. Definition x := 0. NES.End NS92. NES.Begin NS93. Definition x := 0. NES.End NS93. NES.Begin NS94. Definition x := 0. NES.End NS94. NES.Begin NS95. Definition x := 0. NES.End NS95. NES.Begin NS96. Definition x := 0. NES.End NS96. NES.Begin NS97. Definition x := 0. NES.End NS97. NES.Begin NS98. Definition x := 0. NES.End NS98. NES.Begin NS99. Definition x := 0. NES.End NS99. NES.Begin NS100. Definition x := 0. NES.End NS100. NES.Begin NS101. Definition x := 0. NES.End NS101. NES.Begin NS102. Definition x := 0. NES.End NS102. NES.Begin NS103. Definition x := 0. NES.End NS103. NES.Begin NS104. Definition x := 0. NES.End NS104. NES.Begin NS105. Definition x := 0. NES.End NS105. NES.Begin NS106. Definition x := 0. NES.End NS106. NES.Begin NS107. Definition x := 0. NES.End NS107. NES.Begin NS108. Definition x := 0. NES.End NS108. NES.Begin NS109. Definition x := 0. NES.End NS109. NES.Begin NS110. Definition x := 0. NES.End NS110. NES.Begin NS111. Definition x := 0. NES.End NS111. NES.Begin NS112. Definition x := 0. NES.End NS112. NES.Begin NS113. Definition x := 0. NES.End NS113. NES.Begin NS114. Definition x := 0. NES.End NS114. NES.Begin NS115. Definition x := 0. NES.End NS115. NES.Begin NS116. Definition x := 0. NES.End NS116. NES.Begin NS117. Definition x := 0. NES.End NS117. NES.Begin NS118. Definition x := 0. NES.End NS118. NES.Begin NS119. Definition x := 0. NES.End NS119. NES.Begin NS120. Definition x := 0. NES.End NS120. NES.Begin NS121. Definition x := 0. NES.End NS121. NES.Begin NS122. Definition x := 0. NES.End NS122. NES.Begin NS123. Definition x := 0. NES.End NS123. NES.Begin NS124. Definition x := 0. NES.End NS124. NES.Begin NS125. Definition x := 0. NES.End NS125. NES.Begin NS126. Definition x := 0. NES.End NS126. NES.Begin NS127. Definition x := 0. NES.End NS127. NES.Begin NS128. Definition x := 0. NES.End NS128. NES.Begin NS129. Definition x := 0. NES.End NS129. NES.Begin NS130. Definition x := 0. NES.End NS130. NES.Begin NS131. Definition x := 0. NES.End NS131. NES.Begin NS132. Definition x := 0. NES.End NS132. NES.Begin NS133. Definition x := 0. NES.End NS133. NES.Begin NS134. Definition x := 0. NES.End NS134. NES.Begin NS135. Definition x := 0. NES.End NS135. NES.Begin NS136. Definition x := 0. NES.End NS136. NES.Begin NS137. Definition x := 0. NES.End NS137. NES.Begin NS138. Definition x := 0. NES.End NS138. NES.Begin NS139. Definition x := 0. NES.End NS139. NES.Begin NS140. Definition x := 0. NES.End NS140. NES.Begin NS141. Definition x := 0. NES.End NS141. NES.Begin NS142. Definition x := 0. NES.End NS142. NES.Begin NS143. Definition x := 0. NES.End NS143. NES.Begin NS144. Definition x := 0. NES.End NS144. NES.Begin NS145. Definition x := 0. NES.End NS145. NES.Begin NS146. Definition x := 0. NES.End NS146. NES.Begin NS147. Definition x := 0. NES.End NS147. NES.Begin NS148. Definition x := 0. NES.End NS148. NES.Begin NS149. Definition x := 0. NES.End NS149. NES.Begin NS150. Definition x := 0. NES.End NS150. NES.Begin NS151. Definition x := 0. NES.End NS151. NES.Begin NS152. Definition x := 0. NES.End NS152. NES.Begin NS153. Definition x := 0. NES.End NS153. NES.Begin NS154. Definition x := 0. NES.End NS154. NES.Begin NS155. Definition x := 0. NES.End NS155. NES.Begin NS156. Definition x := 0. NES.End NS156. NES.Begin NS157. Definition x := 0. NES.End NS157. NES.Begin NS158. Definition x := 0. NES.End NS158. NES.Begin NS159. Definition x := 0. NES.End NS159. NES.Begin NS160. Definition x := 0. NES.End NS160. NES.Begin NS161. Definition x := 0. NES.End NS161. NES.Begin NS162. Definition x := 0. NES.End NS162. NES.Begin NS163. Definition x := 0. NES.End NS163. NES.Begin NS164. Definition x := 0. NES.End NS164. NES.Begin NS165. Definition x := 0. NES.End NS165. NES.Begin NS166. Definition x := 0. NES.End NS166. NES.Begin NS167. Definition x := 0. NES.End NS167. NES.Begin NS168. Definition x := 0. NES.End NS168. NES.Begin NS169. Definition x := 0. NES.End NS169. NES.Begin NS170. Definition x := 0. NES.End NS170. NES.Begin NS171. Definition x := 0. NES.End NS171. NES.Begin NS172. Definition x := 0. NES.End NS172. NES.Begin NS173. Definition x := 0. NES.End NS173. NES.Begin NS174. Definition x := 0. NES.End NS174. NES.Begin NS175. Definition x := 0. NES.End NS175. NES.Begin NS176. Definition x := 0. NES.End NS176. NES.Begin NS177. Definition x := 0. NES.End NS177. NES.Begin NS178. Definition x := 0. NES.End NS178. NES.Begin NS179. Definition x := 0. NES.End NS179. NES.Begin NS180. Definition x := 0. NES.End NS180. NES.Begin NS181. Definition x := 0. NES.End NS181. NES.Begin NS182. Definition x := 0. NES.End NS182. NES.Begin NS183. Definition x := 0. NES.End NS183. NES.Begin NS184. Definition x := 0. NES.End NS184. NES.Begin NS185. Definition x := 0. NES.End NS185. NES.Begin NS186. Definition x := 0. NES.End NS186. NES.Begin NS187. Definition x := 0. NES.End NS187. NES.Begin NS188. Definition x := 0. NES.End NS188. NES.Begin NS189. Definition x := 0. NES.End NS189. NES.Begin NS190. Definition x := 0. NES.End NS190. NES.Begin NS191. Definition x := 0. NES.End NS191. NES.Begin NS192. Definition x := 0. NES.End NS192. NES.Begin NS193. Definition x := 0. NES.End NS193. NES.Begin NS194. Definition x := 0. NES.End NS194. NES.Begin NS195. Definition x := 0. NES.End NS195. NES.Begin NS196. Definition x := 0. NES.End NS196. NES.Begin NS197. Definition x := 0. NES.End NS197. NES.Begin NS198. Definition x := 0. NES.End NS198. NES.Begin NS199. Definition x := 0. NES.End NS199. NES.Begin NS200. Definition x := 0. NES.End NS200. NES.Begin NS201. Definition x := 0. NES.End NS201. NES.Begin NS202. Definition x := 0. NES.End NS202. NES.Begin NS203. Definition x := 0. NES.End NS203. NES.Begin NS204. Definition x := 0. NES.End NS204. NES.Begin NS205. Definition x := 0. NES.End NS205. NES.Begin NS206. Definition x := 0. NES.End NS206. NES.Begin NS207. Definition x := 0. NES.End NS207. NES.Begin NS208. Definition x := 0. NES.End NS208. NES.Begin NS209. Definition x := 0. NES.End NS209. NES.Begin NS210. Definition x := 0. NES.End NS210. NES.Begin NS211. Definition x := 0. NES.End NS211. NES.Begin NS212. Definition x := 0. NES.End NS212. NES.Begin NS213. Definition x := 0. NES.End NS213. NES.Begin NS214. Definition x := 0. NES.End NS214. NES.Begin NS215. Definition x := 0. NES.End NS215. NES.Begin NS216. Definition x := 0. NES.End NS216. NES.Begin NS217. Definition x := 0. NES.End NS217. NES.Begin NS218. Definition x := 0. NES.End NS218. NES.Begin NS219. Definition x := 0. NES.End NS219. NES.Begin NS220. Definition x := 0. NES.End NS220. NES.Begin NS221. Definition x := 0. NES.End NS221. NES.Begin NS222. Definition x := 0. NES.End NS222. NES.Begin NS223. Definition x := 0. NES.End NS223. NES.Begin NS224. Definition x := 0. NES.End NS224. NES.Begin NS225. Definition x := 0. NES.End NS225. NES.Begin NS226. Definition x := 0. NES.End NS226. NES.Begin NS227. Definition x := 0. NES.End NS227. NES.Begin NS228. Definition x := 0. NES.End NS228. NES.Begin NS229. Definition x := 0. NES.End NS229. NES.Begin NS230. Definition x := 0. NES.End NS230. NES.Begin NS231. Definition x := 0. NES.End NS231. NES.Begin NS232. Definition x := 0. NES.End NS232. NES.Begin NS233. Definition x := 0. NES.End NS233. NES.Begin NS234. Definition x := 0. NES.End NS234. NES.Begin NS235. Definition x := 0. NES.End NS235. NES.Begin NS236. Definition x := 0. NES.End NS236. NES.Begin NS237. Definition x := 0. NES.End NS237. NES.Begin NS238. Definition x := 0. NES.End NS238. NES.Begin NS239. Definition x := 0. NES.End NS239. NES.Begin NS240. Definition x := 0. NES.End NS240. NES.Begin NS241. Definition x := 0. NES.End NS241. NES.Begin NS242. Definition x := 0. NES.End NS242. NES.Begin NS243. Definition x := 0. NES.End NS243. NES.Begin NS244. Definition x := 0. NES.End NS244. NES.Begin NS245. Definition x := 0. NES.End NS245. NES.Begin NS246. Definition x := 0. NES.End NS246. NES.Begin NS247. Definition x := 0. NES.End NS247. NES.Begin NS248. Definition x := 0. NES.End NS248. NES.Begin NS249. Definition x := 0. NES.End NS249. NES.Begin NS250. Definition x := 0. NES.End NS250. NES.Begin NS251. Definition x := 0. NES.End NS251. NES.Begin NS252. Definition x := 0. NES.End NS252. NES.Begin NS253. Definition x := 0. NES.End NS253. NES.Begin NS254. Definition x := 0. NES.End NS254. NES.Begin NS255. Definition x := 0. NES.End NS255. NES.Begin NS256. Definition x := 0. NES.End NS256. NES.Begin NS257. Definition x := 0. NES.End NS257. NES.Begin NS258. Definition x := 0. NES.End NS258. NES.Begin NS259. Definition x := 0. NES.End NS259. NES.Begin NS260. Definition x := 0. NES.End NS260. NES.Begin NS261. Definition x := 0. NES.End NS261. NES.Begin NS262. Definition x := 0. NES.End NS262. NES.Begin NS263. Definition x := 0. NES.End NS263. NES.Begin NS264. Definition x := 0. NES.End NS264. NES.Begin NS265. Definition x := 0. NES.End NS265. NES.Begin NS266. Definition x := 0. NES.End NS266. NES.Begin NS267. Definition x := 0. NES.End NS267. NES.Begin NS268. Definition x := 0. NES.End NS268. NES.Begin NS269. Definition x := 0. NES.End NS269. NES.Begin NS270. Definition x := 0. NES.End NS270. NES.Begin NS271. Definition x := 0. NES.End NS271. NES.Begin NS272. Definition x := 0. NES.End NS272. NES.Begin NS273. Definition x := 0. NES.End NS273. NES.Begin NS274. Definition x := 0. NES.End NS274. NES.Begin NS275. Definition x := 0. NES.End NS275. NES.Begin NS276. Definition x := 0. NES.End NS276. NES.Begin NS277. Definition x := 0. NES.End NS277. NES.Begin NS278. Definition x := 0. NES.End NS278. NES.Begin NS279. Definition x := 0. NES.End NS279. NES.Begin NS280. Definition x := 0. NES.End NS280. NES.Begin NS281. Definition x := 0. NES.End NS281. NES.Begin NS282. Definition x := 0. NES.End NS282. NES.Begin NS283. Definition x := 0. NES.End NS283. NES.Begin NS284. Definition x := 0. NES.End NS284. NES.Begin NS285. Definition x := 0. NES.End NS285. NES.Begin NS286. Definition x := 0. NES.End NS286. NES.Begin NS287. Definition x := 0. NES.End NS287. NES.Begin NS288. Definition x := 0. NES.End NS288. NES.Begin NS289. Definition x := 0. NES.End NS289. NES.Begin NS290. Definition x := 0. NES.End NS290. NES.Begin NS291. Definition x := 0. NES.End NS291. NES.Begin NS292. Definition x := 0. NES.End NS292. NES.Begin NS293. Definition x := 0. NES.End NS293. NES.Begin NS294. Definition x := 0. NES.End NS294. NES.Begin NS295. Definition x := 0. NES.End NS295. NES.Begin NS296. Definition x := 0. NES.End NS296. NES.Begin NS297. Definition x := 0. NES.End NS297. NES.Begin NS298. Definition x := 0. NES.End NS298. NES.Begin NS299. Definition x := 0. NES.End NS299. NES.Begin NS300. Definition x := 0. NES.End NS300. NES.Begin NS301. Definition x := 0. NES.End NS301. NES.Begin NS302. Definition x := 0. NES.End NS302. NES.Begin NS303. Definition x := 0. NES.End NS303. NES.Begin NS304. Definition x := 0. NES.End NS304. NES.Begin NS305. Definition x := 0. NES.End NS305. NES.Begin NS306. Definition x := 0. NES.End NS306. NES.Begin NS307. Definition x := 0. NES.End NS307. NES.Begin NS308. Definition x := 0. NES.End NS308. NES.Begin NS309. Definition x := 0. NES.End NS309. NES.Begin NS310. Definition x := 0. NES.End NS310. NES.Begin NS311. Definition x := 0. NES.End NS311. NES.Begin NS312. Definition x := 0. NES.End NS312. NES.Begin NS313. Definition x := 0. NES.End NS313. NES.Begin NS314. Definition x := 0. NES.End NS314. NES.Begin NS315. Definition x := 0. NES.End NS315. NES.Begin NS316. Definition x := 0. NES.End NS316. NES.Begin NS317. Definition x := 0. NES.End NS317. NES.Begin NS318. Definition x := 0. NES.End NS318. NES.Begin NS319. Definition x := 0. NES.End NS319. NES.Begin NS320. Definition x := 0. NES.End NS320. NES.Begin NS321. Definition x := 0. NES.End NS321. NES.Begin NS322. Definition x := 0. NES.End NS322. NES.Begin NS323. Definition x := 0. NES.End NS323. NES.Begin NS324. Definition x := 0. NES.End NS324. NES.Begin NS325. Definition x := 0. NES.End NS325. NES.Begin NS326. Definition x := 0. NES.End NS326. NES.Begin NS327. Definition x := 0. NES.End NS327. NES.Begin NS328. Definition x := 0. NES.End NS328. NES.Begin NS329. Definition x := 0. NES.End NS329. NES.Begin NS330. Definition x := 0. NES.End NS330. NES.Begin NS331. Definition x := 0. NES.End NS331. NES.Begin NS332. Definition x := 0. NES.End NS332. NES.Begin NS333. Definition x := 0. NES.End NS333. NES.Begin NS334. Definition x := 0. NES.End NS334. NES.Begin NS335. Definition x := 0. NES.End NS335. NES.Begin NS336. Definition x := 0. NES.End NS336. NES.Begin NS337. Definition x := 0. NES.End NS337. NES.Begin NS338. Definition x := 0. NES.End NS338. NES.Begin NS339. Definition x := 0. NES.End NS339. NES.Begin NS340. Definition x := 0. NES.End NS340. NES.Begin NS341. Definition x := 0. NES.End NS341. NES.Begin NS342. Definition x := 0. NES.End NS342. NES.Begin NS343. Definition x := 0. NES.End NS343. NES.Begin NS344. Definition x := 0. NES.End NS344. NES.Begin NS345. Definition x := 0. NES.End NS345. NES.Begin NS346. Definition x := 0. NES.End NS346. NES.Begin NS347. Definition x := 0. NES.End NS347. NES.Begin NS348. Definition x := 0. NES.End NS348. NES.Begin NS349. Definition x := 0. NES.End NS349. NES.Begin NS350. Definition x := 0. NES.End NS350. NES.Begin NS351. Definition x := 0. NES.End NS351. NES.Begin NS352. Definition x := 0. NES.End NS352. NES.Begin NS353. Definition x := 0. NES.End NS353. NES.Begin NS354. Definition x := 0. NES.End NS354. NES.Begin NS355. Definition x := 0. NES.End NS355. NES.Begin NS356. Definition x := 0. NES.End NS356. NES.Begin NS357. Definition x := 0. NES.End NS357. NES.Begin NS358. Definition x := 0. NES.End NS358. NES.Begin NS359. Definition x := 0. NES.End NS359. NES.Begin NS360. Definition x := 0. NES.End NS360. NES.Begin NS361. Definition x := 0. NES.End NS361. NES.Begin NS362. Definition x := 0. NES.End NS362. NES.Begin NS363. Definition x := 0. NES.End NS363. NES.Begin NS364. Definition x := 0. NES.End NS364. NES.Begin NS365. Definition x := 0. NES.End NS365. NES.Begin NS366. Definition x := 0. NES.End NS366. NES.Begin NS367. Definition x := 0. NES.End NS367. NES.Begin NS368. Definition x := 0. NES.End NS368. NES.Begin NS369. Definition x := 0. NES.End NS369. NES.Begin NS370. Definition x := 0. NES.End NS370. NES.Begin NS371. Definition x := 0. NES.End NS371. NES.Begin NS372. Definition x := 0. NES.End NS372. NES.Begin NS373. Definition x := 0. NES.End NS373. NES.Begin NS374. Definition x := 0. NES.End NS374. NES.Begin NS375. Definition x := 0. NES.End NS375. NES.Begin NS376. Definition x := 0. NES.End NS376. NES.Begin NS377. Definition x := 0. NES.End NS377. NES.Begin NS378. Definition x := 0. NES.End NS378. NES.Begin NS379. Definition x := 0. NES.End NS379. NES.Begin NS380. Definition x := 0. NES.End NS380. NES.Begin NS381. Definition x := 0. NES.End NS381. NES.Begin NS382. Definition x := 0. NES.End NS382. NES.Begin NS383. Definition x := 0. NES.End NS383. NES.Begin NS384. Definition x := 0. NES.End NS384. NES.Begin NS385. Definition x := 0. NES.End NS385. NES.Begin NS386. Definition x := 0. NES.End NS386. NES.Begin NS387. Definition x := 0. NES.End NS387. NES.Begin NS388. Definition x := 0. NES.End NS388. NES.Begin NS389. Definition x := 0. NES.End NS389. NES.Begin NS390. Definition x := 0. NES.End NS390. NES.Begin NS391. Definition x := 0. NES.End NS391. NES.Begin NS392. Definition x := 0. NES.End NS392. NES.Begin NS393. Definition x := 0. NES.End NS393. NES.Begin NS394. Definition x := 0. NES.End NS394. NES.Begin NS395. Definition x := 0. NES.End NS395. NES.Begin NS396. Definition x := 0. NES.End NS396. NES.Begin NS397. Definition x := 0. NES.End NS397. NES.Begin NS398. Definition x := 0. NES.End NS398. NES.Begin NS399. Definition x := 0. NES.End NS399. NES.Begin NS400. Definition x := 0. NES.End NS400. NES.Begin NS401. Definition x := 0. NES.End NS401. NES.Begin NS402. Definition x := 0. NES.End NS402. NES.Begin NS403. Definition x := 0. NES.End NS403. NES.Begin NS404. Definition x := 0. NES.End NS404. NES.Begin NS405. Definition x := 0. NES.End NS405. NES.Begin NS406. Definition x := 0. NES.End NS406. NES.Begin NS407. Definition x := 0. NES.End NS407. NES.Begin NS408. Definition x := 0. NES.End NS408. NES.Begin NS409. Definition x := 0. NES.End NS409. NES.Begin NS410. Definition x := 0. NES.End NS410. NES.Begin NS411. Definition x := 0. NES.End NS411. NES.Begin NS412. Definition x := 0. NES.End NS412. NES.Begin NS413. Definition x := 0. NES.End NS413. NES.Begin NS414. Definition x := 0. NES.End NS414. NES.Begin NS415. Definition x := 0. NES.End NS415. NES.Begin NS416. Definition x := 0. NES.End NS416. NES.Begin NS417. Definition x := 0. NES.End NS417. NES.Begin NS418. Definition x := 0. NES.End NS418. NES.Begin NS419. Definition x := 0. NES.End NS419. NES.Begin NS420. Definition x := 0. NES.End NS420. NES.Begin NS421. Definition x := 0. NES.End NS421. NES.Begin NS422. Definition x := 0. NES.End NS422. NES.Begin NS423. Definition x := 0. NES.End NS423. NES.Begin NS424. Definition x := 0. NES.End NS424. NES.Begin NS425. Definition x := 0. NES.End NS425. NES.Begin NS426. Definition x := 0. NES.End NS426. NES.Begin NS427. Definition x := 0. NES.End NS427. NES.Begin NS428. Definition x := 0. NES.End NS428. NES.Begin NS429. Definition x := 0. NES.End NS429. NES.Begin NS430. Definition x := 0. NES.End NS430. NES.Begin NS431. Definition x := 0. NES.End NS431. NES.Begin NS432. Definition x := 0. NES.End NS432. NES.Begin NS433. Definition x := 0. NES.End NS433. NES.Begin NS434. Definition x := 0. NES.End NS434. NES.Begin NS435. Definition x := 0. NES.End NS435. NES.Begin NS436. Definition x := 0. NES.End NS436. NES.Begin NS437. Definition x := 0. NES.End NS437. NES.Begin NS438. Definition x := 0. NES.End NS438. NES.Begin NS439. Definition x := 0. NES.End NS439. NES.Begin NS440. Definition x := 0. NES.End NS440. NES.Begin NS441. Definition x := 0. NES.End NS441. NES.Begin NS442. Definition x := 0. NES.End NS442. NES.Begin NS443. Definition x := 0. NES.End NS443. NES.Begin NS444. Definition x := 0. NES.End NS444. NES.Begin NS445. Definition x := 0. NES.End NS445. NES.Begin NS446. Definition x := 0. NES.End NS446. NES.Begin NS447. Definition x := 0. NES.End NS447. NES.Begin NS448. Definition x := 0. NES.End NS448. NES.Begin NS449. Definition x := 0. NES.End NS449. NES.Begin NS450. Definition x := 0. NES.End NS450. NES.Begin NS451. Definition x := 0. NES.End NS451. NES.Begin NS452. Definition x := 0. NES.End NS452. NES.Begin NS453. Definition x := 0. NES.End NS453. NES.Begin NS454. Definition x := 0. NES.End NS454. NES.Begin NS455. Definition x := 0. NES.End NS455. NES.Begin NS456. Definition x := 0. NES.End NS456. NES.Begin NS457. Definition x := 0. NES.End NS457. NES.Begin NS458. Definition x := 0. NES.End NS458. NES.Begin NS459. Definition x := 0. NES.End NS459. NES.Begin NS460. Definition x := 0. NES.End NS460. NES.Begin NS461. Definition x := 0. NES.End NS461. NES.Begin NS462. Definition x := 0. NES.End NS462. NES.Begin NS463. Definition x := 0. NES.End NS463. NES.Begin NS464. Definition x := 0. NES.End NS464. NES.Begin NS465. Definition x := 0. NES.End NS465. NES.Begin NS466. Definition x := 0. NES.End NS466. NES.Begin NS467. Definition x := 0. NES.End NS467. NES.Begin NS468. Definition x := 0. NES.End NS468. NES.Begin NS469. Definition x := 0. NES.End NS469. NES.Begin NS470. Definition x := 0. NES.End NS470. NES.Begin NS471. Definition x := 0. NES.End NS471. NES.Begin NS472. Definition x := 0. NES.End NS472. NES.Begin NS473. Definition x := 0. NES.End NS473. NES.Begin NS474. Definition x := 0. NES.End NS474. NES.Begin NS475. Definition x := 0. NES.End NS475. NES.Begin NS476. Definition x := 0. NES.End NS476. NES.Begin NS477. Definition x := 0. NES.End NS477. NES.Begin NS478. Definition x := 0. NES.End NS478. NES.Begin NS479. Definition x := 0. NES.End NS479. NES.Begin NS480. Definition x := 0. NES.End NS480. NES.Begin NS481. Definition x := 0. NES.End NS481. NES.Begin NS482. Definition x := 0. NES.End NS482. NES.Begin NS483. Definition x := 0. NES.End NS483. NES.Begin NS484. Definition x := 0. NES.End NS484. NES.Begin NS485. Definition x := 0. NES.End NS485. NES.Begin NS486. Definition x := 0. NES.End NS486. NES.Begin NS487. Definition x := 0. NES.End NS487. NES.Begin NS488. Definition x := 0. NES.End NS488. NES.Begin NS489. Definition x := 0. NES.End NS489. NES.Begin NS490. Definition x := 0. NES.End NS490. NES.Begin NS491. Definition x := 0. NES.End NS491. NES.Begin NS492. Definition x := 0. NES.End NS492. NES.Begin NS493. Definition x := 0. NES.End NS493. NES.Begin NS494. Definition x := 0. NES.End NS494. NES.Begin NS495. Definition x := 0. NES.End NS495. NES.Begin NS496. Definition x := 0. NES.End NS496. NES.Begin NS497. Definition x := 0. NES.End NS497. NES.Begin NS498. Definition x := 0. NES.End NS498. NES.Begin NS499. Definition x := 0. NES.End NS499. NES.Begin NS500. Definition x := 0. NES.End NS500.coq-elpi-2.1.0/apps/NES/tests/test_NES_perf_optimal.v000066400000000000000000001210261460156013500223740ustar00rootroot00000000000000From elpi.apps Require Import NES. Module NS1. Module NS1. Definition x := 0. End NS1. End NS1. Export NS1. Module NS2. Module NS2. Definition x := 0. End NS2. End NS2. Export NS2. Module NS3. Module NS3. Definition x := 0. End NS3. End NS3. Export NS3. Module NS4. Module NS4. Definition x := 0. End NS4. End NS4. Export NS4. Module NS5. Module NS5. Definition x := 0. End NS5. End NS5. Export NS5. Module NS6. Module NS6. Definition x := 0. End NS6. End NS6. Export NS6. Module NS7. Module NS7. Definition x := 0. End NS7. End NS7. Export NS7. Module NS8. Module NS8. Definition x := 0. End NS8. End NS8. Export NS8. Module NS9. Module NS9. Definition x := 0. End NS9. End NS9. Export NS9. Module NS10. Module NS10. Definition x := 0. End NS10. End NS10. Export NS10. Module NS11. Module NS11. Definition x := 0. End NS11. End NS11. Export NS11. Module NS12. Module NS12. Definition x := 0. End NS12. End NS12. Export NS12. Module NS13. Module NS13. Definition x := 0. End NS13. End NS13. Export NS13. Module NS14. Module NS14. Definition x := 0. End NS14. End NS14. Export NS14. Module NS15. Module NS15. Definition x := 0. End NS15. End NS15. Export NS15. Module NS16. Module NS16. Definition x := 0. End NS16. End NS16. Export NS16. Module NS17. Module NS17. Definition x := 0. End NS17. End NS17. Export NS17. Module NS18. Module NS18. Definition x := 0. End NS18. End NS18. Export NS18. Module NS19. Module NS19. Definition x := 0. End NS19. End NS19. Export NS19. Module NS20. Module NS20. Definition x := 0. End NS20. End NS20. Export NS20. Module NS21. Module NS21. Definition x := 0. End NS21. End NS21. Export NS21. Module NS22. Module NS22. Definition x := 0. End NS22. End NS22. Export NS22. Module NS23. Module NS23. Definition x := 0. End NS23. End NS23. Export NS23. Module NS24. Module NS24. Definition x := 0. End NS24. End NS24. Export NS24. Module NS25. Module NS25. Definition x := 0. End NS25. End NS25. Export NS25. Module NS26. Module NS26. Definition x := 0. End NS26. End NS26. Export NS26. Module NS27. Module NS27. Definition x := 0. End NS27. End NS27. Export NS27. Module NS28. Module NS28. Definition x := 0. End NS28. End NS28. Export NS28. Module NS29. Module NS29. Definition x := 0. End NS29. End NS29. Export NS29. Module NS30. Module NS30. Definition x := 0. End NS30. End NS30. Export NS30. Module NS31. Module NS31. Definition x := 0. End NS31. End NS31. Export NS31. Module NS32. Module NS32. Definition x := 0. End NS32. End NS32. Export NS32. Module NS33. Module NS33. Definition x := 0. End NS33. End NS33. Export NS33. Module NS34. Module NS34. Definition x := 0. End NS34. End NS34. Export NS34. Module NS35. Module NS35. Definition x := 0. End NS35. End NS35. Export NS35. Module NS36. Module NS36. Definition x := 0. End NS36. End NS36. Export NS36. Module NS37. Module NS37. Definition x := 0. End NS37. End NS37. Export NS37. Module NS38. Module NS38. Definition x := 0. End NS38. End NS38. Export NS38. Module NS39. Module NS39. Definition x := 0. End NS39. End NS39. Export NS39. Module NS40. Module NS40. Definition x := 0. End NS40. End NS40. Export NS40. Module NS41. Module NS41. Definition x := 0. End NS41. End NS41. Export NS41. Module NS42. Module NS42. Definition x := 0. End NS42. End NS42. Export NS42. Module NS43. Module NS43. Definition x := 0. End NS43. End NS43. Export NS43. Module NS44. Module NS44. Definition x := 0. End NS44. End NS44. Export NS44. Module NS45. Module NS45. Definition x := 0. End NS45. End NS45. Export NS45. Module NS46. Module NS46. Definition x := 0. End NS46. End NS46. Export NS46. Module NS47. Module NS47. Definition x := 0. End NS47. End NS47. Export NS47. Module NS48. Module NS48. Definition x := 0. End NS48. End NS48. Export NS48. Module NS49. Module NS49. Definition x := 0. End NS49. End NS49. Export NS49. Module NS50. Module NS50. Definition x := 0. End NS50. End NS50. Export NS50. Module NS51. Module NS51. Definition x := 0. End NS51. End NS51. Export NS51. Module NS52. Module NS52. Definition x := 0. End NS52. End NS52. Export NS52. Module NS53. Module NS53. Definition x := 0. End NS53. End NS53. Export NS53. Module NS54. Module NS54. Definition x := 0. End NS54. End NS54. Export NS54. Module NS55. Module NS55. Definition x := 0. End NS55. End NS55. Export NS55. Module NS56. Module NS56. Definition x := 0. End NS56. End NS56. Export NS56. Module NS57. Module NS57. Definition x := 0. End NS57. End NS57. Export NS57. Module NS58. Module NS58. Definition x := 0. End NS58. End NS58. Export NS58. Module NS59. Module NS59. Definition x := 0. End NS59. End NS59. Export NS59. Module NS60. Module NS60. Definition x := 0. End NS60. End NS60. Export NS60. Module NS61. Module NS61. Definition x := 0. End NS61. End NS61. Export NS61. Module NS62. Module NS62. Definition x := 0. End NS62. End NS62. Export NS62. Module NS63. Module NS63. Definition x := 0. End NS63. End NS63. Export NS63. Module NS64. Module NS64. Definition x := 0. End NS64. End NS64. Export NS64. Module NS65. Module NS65. Definition x := 0. End NS65. End NS65. Export NS65. Module NS66. Module NS66. Definition x := 0. End NS66. End NS66. Export NS66. Module NS67. Module NS67. Definition x := 0. End NS67. End NS67. Export NS67. Module NS68. Module NS68. Definition x := 0. End NS68. End NS68. Export NS68. Module NS69. Module NS69. Definition x := 0. End NS69. End NS69. Export NS69. Module NS70. Module NS70. Definition x := 0. End NS70. End NS70. Export NS70. Module NS71. Module NS71. Definition x := 0. End NS71. End NS71. Export NS71. Module NS72. Module NS72. Definition x := 0. End NS72. End NS72. Export NS72. Module NS73. Module NS73. Definition x := 0. End NS73. End NS73. Export NS73. Module NS74. Module NS74. Definition x := 0. End NS74. End NS74. Export NS74. Module NS75. Module NS75. Definition x := 0. End NS75. End NS75. Export NS75. Module NS76. Module NS76. Definition x := 0. End NS76. End NS76. Export NS76. Module NS77. Module NS77. Definition x := 0. End NS77. End NS77. Export NS77. Module NS78. Module NS78. Definition x := 0. End NS78. End NS78. Export NS78. Module NS79. Module NS79. Definition x := 0. End NS79. End NS79. Export NS79. Module NS80. Module NS80. Definition x := 0. End NS80. End NS80. Export NS80. Module NS81. Module NS81. Definition x := 0. End NS81. End NS81. Export NS81. Module NS82. Module NS82. Definition x := 0. End NS82. End NS82. Export NS82. Module NS83. Module NS83. Definition x := 0. End NS83. End NS83. Export NS83. Module NS84. Module NS84. Definition x := 0. End NS84. End NS84. Export NS84. Module NS85. Module NS85. Definition x := 0. End NS85. End NS85. Export NS85. Module NS86. Module NS86. Definition x := 0. End NS86. End NS86. Export NS86. Module NS87. Module NS87. Definition x := 0. End NS87. End NS87. Export NS87. Module NS88. Module NS88. Definition x := 0. End NS88. End NS88. Export NS88. Module NS89. Module NS89. Definition x := 0. End NS89. End NS89. Export NS89. Module NS90. Module NS90. Definition x := 0. End NS90. End NS90. Export NS90. Module NS91. Module NS91. Definition x := 0. End NS91. End NS91. Export NS91. Module NS92. Module NS92. Definition x := 0. End NS92. End NS92. Export NS92. Module NS93. Module NS93. Definition x := 0. End NS93. End NS93. Export NS93. Module NS94. Module NS94. Definition x := 0. End NS94. End NS94. Export NS94. Module NS95. Module NS95. Definition x := 0. End NS95. End NS95. Export NS95. Module NS96. Module NS96. Definition x := 0. End NS96. End NS96. Export NS96. Module NS97. Module NS97. Definition x := 0. End NS97. End NS97. Export NS97. Module NS98. Module NS98. Definition x := 0. End NS98. End NS98. Export NS98. Module NS99. Module NS99. Definition x := 0. End NS99. End NS99. Export NS99. Module NS100. Module NS100. Definition x := 0. End NS100. End NS100. Export NS100. Module NS101. Module NS101. Definition x := 0. End NS101. End NS101. Export NS101. Module NS102. Module NS102. Definition x := 0. End NS102. End NS102. Export NS102. Module NS103. Module NS103. Definition x := 0. End NS103. End NS103. Export NS103. Module NS104. Module NS104. Definition x := 0. End NS104. End NS104. Export NS104. Module NS105. Module NS105. Definition x := 0. End NS105. End NS105. Export NS105. Module NS106. Module NS106. Definition x := 0. End NS106. End NS106. Export NS106. Module NS107. Module NS107. Definition x := 0. End NS107. End NS107. Export NS107. Module NS108. Module NS108. Definition x := 0. End NS108. End NS108. Export NS108. Module NS109. Module NS109. Definition x := 0. End NS109. End NS109. Export NS109. Module NS110. Module NS110. Definition x := 0. End NS110. End NS110. Export NS110. Module NS111. Module NS111. Definition x := 0. End NS111. End NS111. Export NS111. Module NS112. Module NS112. Definition x := 0. End NS112. End NS112. Export NS112. Module NS113. Module NS113. Definition x := 0. End NS113. End NS113. Export NS113. Module NS114. Module NS114. Definition x := 0. End NS114. End NS114. Export NS114. Module NS115. Module NS115. Definition x := 0. End NS115. End NS115. Export NS115. Module NS116. Module NS116. Definition x := 0. End NS116. End NS116. Export NS116. Module NS117. Module NS117. Definition x := 0. End NS117. End NS117. Export NS117. Module NS118. Module NS118. Definition x := 0. End NS118. End NS118. Export NS118. Module NS119. Module NS119. Definition x := 0. End NS119. End NS119. Export NS119. Module NS120. Module NS120. Definition x := 0. End NS120. End NS120. Export NS120. Module NS121. Module NS121. Definition x := 0. End NS121. End NS121. Export NS121. Module NS122. Module NS122. Definition x := 0. End NS122. End NS122. Export NS122. Module NS123. Module NS123. Definition x := 0. End NS123. End NS123. Export NS123. Module NS124. Module NS124. Definition x := 0. End NS124. End NS124. Export NS124. Module NS125. Module NS125. Definition x := 0. End NS125. End NS125. Export NS125. Module NS126. Module NS126. Definition x := 0. End NS126. End NS126. Export NS126. Module NS127. Module NS127. Definition x := 0. End NS127. End NS127. Export NS127. Module NS128. Module NS128. Definition x := 0. End NS128. End NS128. Export NS128. Module NS129. Module NS129. Definition x := 0. End NS129. End NS129. Export NS129. Module NS130. Module NS130. Definition x := 0. End NS130. End NS130. Export NS130. Module NS131. Module NS131. Definition x := 0. End NS131. End NS131. Export NS131. Module NS132. Module NS132. Definition x := 0. End NS132. End NS132. Export NS132. Module NS133. Module NS133. Definition x := 0. End NS133. End NS133. Export NS133. Module NS134. Module NS134. Definition x := 0. End NS134. End NS134. Export NS134. Module NS135. Module NS135. Definition x := 0. End NS135. End NS135. Export NS135. Module NS136. Module NS136. Definition x := 0. End NS136. End NS136. Export NS136. Module NS137. Module NS137. Definition x := 0. End NS137. End NS137. Export NS137. Module NS138. Module NS138. Definition x := 0. End NS138. End NS138. Export NS138. Module NS139. Module NS139. Definition x := 0. End NS139. End NS139. Export NS139. Module NS140. Module NS140. Definition x := 0. End NS140. End NS140. Export NS140. Module NS141. Module NS141. Definition x := 0. End NS141. End NS141. Export NS141. Module NS142. Module NS142. Definition x := 0. End NS142. End NS142. Export NS142. Module NS143. Module NS143. Definition x := 0. End NS143. End NS143. Export NS143. Module NS144. Module NS144. Definition x := 0. End NS144. End NS144. Export NS144. Module NS145. Module NS145. Definition x := 0. End NS145. End NS145. Export NS145. Module NS146. Module NS146. Definition x := 0. End NS146. End NS146. Export NS146. Module NS147. Module NS147. Definition x := 0. End NS147. End NS147. Export NS147. Module NS148. Module NS148. Definition x := 0. End NS148. End NS148. Export NS148. Module NS149. Module NS149. Definition x := 0. End NS149. End NS149. Export NS149. Module NS150. Module NS150. Definition x := 0. End NS150. End NS150. Export NS150. Module NS151. Module NS151. Definition x := 0. End NS151. End NS151. Export NS151. Module NS152. Module NS152. Definition x := 0. End NS152. End NS152. Export NS152. Module NS153. Module NS153. Definition x := 0. End NS153. End NS153. Export NS153. Module NS154. Module NS154. Definition x := 0. End NS154. End NS154. Export NS154. Module NS155. Module NS155. Definition x := 0. End NS155. End NS155. Export NS155. Module NS156. Module NS156. Definition x := 0. End NS156. End NS156. Export NS156. Module NS157. Module NS157. Definition x := 0. End NS157. End NS157. Export NS157. Module NS158. Module NS158. Definition x := 0. End NS158. End NS158. Export NS158. Module NS159. Module NS159. Definition x := 0. End NS159. End NS159. Export NS159. Module NS160. Module NS160. Definition x := 0. End NS160. End NS160. Export NS160. Module NS161. Module NS161. Definition x := 0. End NS161. End NS161. Export NS161. Module NS162. Module NS162. Definition x := 0. End NS162. End NS162. Export NS162. Module NS163. Module NS163. Definition x := 0. End NS163. End NS163. Export NS163. Module NS164. Module NS164. Definition x := 0. End NS164. End NS164. Export NS164. Module NS165. Module NS165. Definition x := 0. End NS165. End NS165. Export NS165. Module NS166. Module NS166. Definition x := 0. End NS166. End NS166. Export NS166. Module NS167. Module NS167. Definition x := 0. End NS167. End NS167. Export NS167. Module NS168. Module NS168. Definition x := 0. End NS168. End NS168. Export NS168. Module NS169. Module NS169. Definition x := 0. End NS169. End NS169. Export NS169. Module NS170. Module NS170. Definition x := 0. End NS170. End NS170. Export NS170. Module NS171. Module NS171. Definition x := 0. End NS171. End NS171. Export NS171. Module NS172. Module NS172. Definition x := 0. End NS172. End NS172. Export NS172. Module NS173. Module NS173. Definition x := 0. End NS173. End NS173. Export NS173. Module NS174. Module NS174. Definition x := 0. End NS174. End NS174. Export NS174. Module NS175. Module NS175. Definition x := 0. End NS175. End NS175. Export NS175. Module NS176. Module NS176. Definition x := 0. End NS176. End NS176. Export NS176. Module NS177. Module NS177. Definition x := 0. End NS177. End NS177. Export NS177. Module NS178. Module NS178. Definition x := 0. End NS178. End NS178. Export NS178. Module NS179. Module NS179. Definition x := 0. End NS179. End NS179. Export NS179. Module NS180. Module NS180. Definition x := 0. End NS180. End NS180. Export NS180. Module NS181. Module NS181. Definition x := 0. End NS181. End NS181. Export NS181. Module NS182. Module NS182. Definition x := 0. End NS182. End NS182. Export NS182. Module NS183. Module NS183. Definition x := 0. End NS183. End NS183. Export NS183. Module NS184. Module NS184. Definition x := 0. End NS184. End NS184. Export NS184. Module NS185. Module NS185. Definition x := 0. End NS185. End NS185. Export NS185. Module NS186. Module NS186. Definition x := 0. End NS186. End NS186. Export NS186. Module NS187. Module NS187. Definition x := 0. End NS187. End NS187. Export NS187. Module NS188. Module NS188. Definition x := 0. End NS188. End NS188. Export NS188. Module NS189. Module NS189. Definition x := 0. End NS189. End NS189. Export NS189. Module NS190. Module NS190. Definition x := 0. End NS190. End NS190. Export NS190. Module NS191. Module NS191. Definition x := 0. End NS191. End NS191. Export NS191. Module NS192. Module NS192. Definition x := 0. End NS192. End NS192. Export NS192. Module NS193. Module NS193. Definition x := 0. End NS193. End NS193. Export NS193. Module NS194. Module NS194. Definition x := 0. End NS194. End NS194. Export NS194. Module NS195. Module NS195. Definition x := 0. End NS195. End NS195. Export NS195. Module NS196. Module NS196. Definition x := 0. End NS196. End NS196. Export NS196. Module NS197. Module NS197. Definition x := 0. End NS197. End NS197. Export NS197. Module NS198. Module NS198. Definition x := 0. End NS198. End NS198. Export NS198. Module NS199. Module NS199. Definition x := 0. End NS199. End NS199. Export NS199. Module NS200. Module NS200. Definition x := 0. End NS200. End NS200. Export NS200. Module NS201. Module NS201. Definition x := 0. End NS201. End NS201. Export NS201. Module NS202. Module NS202. Definition x := 0. End NS202. End NS202. Export NS202. Module NS203. Module NS203. Definition x := 0. End NS203. End NS203. Export NS203. Module NS204. Module NS204. Definition x := 0. End NS204. End NS204. Export NS204. Module NS205. Module NS205. Definition x := 0. End NS205. End NS205. Export NS205. Module NS206. Module NS206. Definition x := 0. End NS206. End NS206. Export NS206. Module NS207. Module NS207. Definition x := 0. End NS207. End NS207. Export NS207. Module NS208. Module NS208. Definition x := 0. End NS208. End NS208. Export NS208. Module NS209. Module NS209. Definition x := 0. End NS209. End NS209. Export NS209. Module NS210. Module NS210. Definition x := 0. End NS210. End NS210. Export NS210. Module NS211. Module NS211. Definition x := 0. End NS211. End NS211. Export NS211. Module NS212. Module NS212. Definition x := 0. End NS212. End NS212. Export NS212. Module NS213. Module NS213. Definition x := 0. End NS213. End NS213. Export NS213. Module NS214. Module NS214. Definition x := 0. End NS214. End NS214. Export NS214. Module NS215. Module NS215. Definition x := 0. End NS215. End NS215. Export NS215. Module NS216. Module NS216. Definition x := 0. End NS216. End NS216. Export NS216. Module NS217. Module NS217. Definition x := 0. End NS217. End NS217. Export NS217. Module NS218. Module NS218. Definition x := 0. End NS218. End NS218. Export NS218. Module NS219. Module NS219. Definition x := 0. End NS219. End NS219. Export NS219. Module NS220. Module NS220. Definition x := 0. End NS220. End NS220. Export NS220. Module NS221. Module NS221. Definition x := 0. End NS221. End NS221. Export NS221. Module NS222. Module NS222. Definition x := 0. End NS222. End NS222. Export NS222. Module NS223. Module NS223. Definition x := 0. End NS223. End NS223. Export NS223. Module NS224. Module NS224. Definition x := 0. End NS224. End NS224. Export NS224. Module NS225. Module NS225. Definition x := 0. End NS225. End NS225. Export NS225. Module NS226. Module NS226. Definition x := 0. End NS226. End NS226. Export NS226. Module NS227. Module NS227. Definition x := 0. End NS227. End NS227. Export NS227. Module NS228. Module NS228. Definition x := 0. End NS228. End NS228. Export NS228. Module NS229. Module NS229. Definition x := 0. End NS229. End NS229. Export NS229. Module NS230. Module NS230. Definition x := 0. End NS230. End NS230. Export NS230. Module NS231. Module NS231. Definition x := 0. End NS231. End NS231. Export NS231. Module NS232. Module NS232. Definition x := 0. End NS232. End NS232. Export NS232. Module NS233. Module NS233. Definition x := 0. End NS233. End NS233. Export NS233. Module NS234. Module NS234. Definition x := 0. End NS234. End NS234. Export NS234. Module NS235. Module NS235. Definition x := 0. End NS235. End NS235. Export NS235. Module NS236. Module NS236. Definition x := 0. End NS236. End NS236. Export NS236. Module NS237. Module NS237. Definition x := 0. End NS237. End NS237. Export NS237. Module NS238. Module NS238. Definition x := 0. End NS238. End NS238. Export NS238. Module NS239. Module NS239. Definition x := 0. End NS239. End NS239. Export NS239. Module NS240. Module NS240. Definition x := 0. End NS240. End NS240. Export NS240. Module NS241. Module NS241. Definition x := 0. End NS241. End NS241. Export NS241. Module NS242. Module NS242. Definition x := 0. End NS242. End NS242. Export NS242. Module NS243. Module NS243. Definition x := 0. End NS243. End NS243. Export NS243. Module NS244. Module NS244. Definition x := 0. End NS244. End NS244. Export NS244. Module NS245. Module NS245. Definition x := 0. End NS245. End NS245. Export NS245. Module NS246. Module NS246. Definition x := 0. End NS246. End NS246. Export NS246. Module NS247. Module NS247. Definition x := 0. End NS247. End NS247. Export NS247. Module NS248. Module NS248. Definition x := 0. End NS248. End NS248. Export NS248. Module NS249. Module NS249. Definition x := 0. End NS249. End NS249. Export NS249. Module NS250. Module NS250. Definition x := 0. End NS250. End NS250. Export NS250. Module NS251. Module NS251. Definition x := 0. End NS251. End NS251. Export NS251. Module NS252. Module NS252. Definition x := 0. End NS252. End NS252. Export NS252. Module NS253. Module NS253. Definition x := 0. End NS253. End NS253. Export NS253. Module NS254. Module NS254. Definition x := 0. End NS254. End NS254. Export NS254. Module NS255. Module NS255. Definition x := 0. End NS255. End NS255. Export NS255. Module NS256. Module NS256. Definition x := 0. End NS256. End NS256. Export NS256. Module NS257. Module NS257. Definition x := 0. End NS257. End NS257. Export NS257. Module NS258. Module NS258. Definition x := 0. End NS258. End NS258. Export NS258. Module NS259. Module NS259. Definition x := 0. End NS259. End NS259. Export NS259. Module NS260. Module NS260. Definition x := 0. End NS260. End NS260. Export NS260. Module NS261. Module NS261. Definition x := 0. End NS261. End NS261. Export NS261. Module NS262. Module NS262. Definition x := 0. End NS262. End NS262. Export NS262. Module NS263. Module NS263. Definition x := 0. End NS263. End NS263. Export NS263. Module NS264. Module NS264. Definition x := 0. End NS264. End NS264. Export NS264. Module NS265. Module NS265. Definition x := 0. End NS265. End NS265. Export NS265. Module NS266. Module NS266. Definition x := 0. End NS266. End NS266. Export NS266. Module NS267. Module NS267. Definition x := 0. End NS267. End NS267. Export NS267. Module NS268. Module NS268. Definition x := 0. End NS268. End NS268. Export NS268. Module NS269. Module NS269. Definition x := 0. End NS269. End NS269. Export NS269. Module NS270. Module NS270. Definition x := 0. End NS270. End NS270. Export NS270. Module NS271. Module NS271. Definition x := 0. End NS271. End NS271. Export NS271. Module NS272. Module NS272. Definition x := 0. End NS272. End NS272. Export NS272. Module NS273. Module NS273. Definition x := 0. End NS273. End NS273. Export NS273. Module NS274. Module NS274. Definition x := 0. End NS274. End NS274. Export NS274. Module NS275. Module NS275. Definition x := 0. End NS275. End NS275. Export NS275. Module NS276. Module NS276. Definition x := 0. End NS276. End NS276. Export NS276. Module NS277. Module NS277. Definition x := 0. End NS277. End NS277. Export NS277. Module NS278. Module NS278. Definition x := 0. End NS278. End NS278. Export NS278. Module NS279. Module NS279. Definition x := 0. End NS279. End NS279. Export NS279. Module NS280. Module NS280. Definition x := 0. End NS280. End NS280. Export NS280. Module NS281. Module NS281. Definition x := 0. End NS281. End NS281. Export NS281. Module NS282. Module NS282. Definition x := 0. End NS282. End NS282. Export NS282. Module NS283. Module NS283. Definition x := 0. End NS283. End NS283. Export NS283. Module NS284. Module NS284. Definition x := 0. End NS284. End NS284. Export NS284. Module NS285. Module NS285. Definition x := 0. End NS285. End NS285. Export NS285. Module NS286. Module NS286. Definition x := 0. End NS286. End NS286. Export NS286. Module NS287. Module NS287. Definition x := 0. End NS287. End NS287. Export NS287. Module NS288. Module NS288. Definition x := 0. End NS288. End NS288. Export NS288. Module NS289. Module NS289. Definition x := 0. End NS289. End NS289. Export NS289. Module NS290. Module NS290. Definition x := 0. End NS290. End NS290. Export NS290. Module NS291. Module NS291. Definition x := 0. End NS291. End NS291. Export NS291. Module NS292. Module NS292. Definition x := 0. End NS292. End NS292. Export NS292. Module NS293. Module NS293. Definition x := 0. End NS293. End NS293. Export NS293. Module NS294. Module NS294. Definition x := 0. End NS294. End NS294. Export NS294. Module NS295. Module NS295. Definition x := 0. End NS295. End NS295. Export NS295. Module NS296. Module NS296. Definition x := 0. End NS296. End NS296. Export NS296. Module NS297. Module NS297. Definition x := 0. End NS297. End NS297. Export NS297. Module NS298. Module NS298. Definition x := 0. End NS298. End NS298. Export NS298. Module NS299. Module NS299. Definition x := 0. End NS299. End NS299. Export NS299. Module NS300. Module NS300. Definition x := 0. End NS300. End NS300. Export NS300. Module NS301. Module NS301. Definition x := 0. End NS301. End NS301. Export NS301. Module NS302. Module NS302. Definition x := 0. End NS302. End NS302. Export NS302. Module NS303. Module NS303. Definition x := 0. End NS303. End NS303. Export NS303. Module NS304. Module NS304. Definition x := 0. End NS304. End NS304. Export NS304. Module NS305. Module NS305. Definition x := 0. End NS305. End NS305. Export NS305. Module NS306. Module NS306. Definition x := 0. End NS306. End NS306. Export NS306. Module NS307. Module NS307. Definition x := 0. End NS307. End NS307. Export NS307. Module NS308. Module NS308. Definition x := 0. End NS308. End NS308. Export NS308. Module NS309. Module NS309. Definition x := 0. End NS309. End NS309. Export NS309. Module NS310. Module NS310. Definition x := 0. End NS310. End NS310. Export NS310. Module NS311. Module NS311. Definition x := 0. End NS311. End NS311. Export NS311. Module NS312. Module NS312. Definition x := 0. End NS312. End NS312. Export NS312. Module NS313. Module NS313. Definition x := 0. End NS313. End NS313. Export NS313. Module NS314. Module NS314. Definition x := 0. End NS314. End NS314. Export NS314. Module NS315. Module NS315. Definition x := 0. End NS315. End NS315. Export NS315. Module NS316. Module NS316. Definition x := 0. End NS316. End NS316. Export NS316. Module NS317. Module NS317. Definition x := 0. End NS317. End NS317. Export NS317. Module NS318. Module NS318. Definition x := 0. End NS318. End NS318. Export NS318. Module NS319. Module NS319. Definition x := 0. End NS319. End NS319. Export NS319. Module NS320. Module NS320. Definition x := 0. End NS320. End NS320. Export NS320. Module NS321. Module NS321. Definition x := 0. End NS321. End NS321. Export NS321. Module NS322. Module NS322. Definition x := 0. End NS322. End NS322. Export NS322. Module NS323. Module NS323. Definition x := 0. End NS323. End NS323. Export NS323. Module NS324. Module NS324. Definition x := 0. End NS324. End NS324. Export NS324. Module NS325. Module NS325. Definition x := 0. End NS325. End NS325. Export NS325. Module NS326. Module NS326. Definition x := 0. End NS326. End NS326. Export NS326. Module NS327. Module NS327. Definition x := 0. End NS327. End NS327. Export NS327. Module NS328. Module NS328. Definition x := 0. End NS328. End NS328. Export NS328. Module NS329. Module NS329. Definition x := 0. End NS329. End NS329. Export NS329. Module NS330. Module NS330. Definition x := 0. End NS330. End NS330. Export NS330. Module NS331. Module NS331. Definition x := 0. End NS331. End NS331. Export NS331. Module NS332. Module NS332. Definition x := 0. End NS332. End NS332. Export NS332. Module NS333. Module NS333. Definition x := 0. End NS333. End NS333. Export NS333. Module NS334. Module NS334. Definition x := 0. End NS334. End NS334. Export NS334. Module NS335. Module NS335. Definition x := 0. End NS335. End NS335. Export NS335. Module NS336. Module NS336. Definition x := 0. End NS336. End NS336. Export NS336. Module NS337. Module NS337. Definition x := 0. End NS337. End NS337. Export NS337. Module NS338. Module NS338. Definition x := 0. End NS338. End NS338. Export NS338. Module NS339. Module NS339. Definition x := 0. End NS339. End NS339. Export NS339. Module NS340. Module NS340. Definition x := 0. End NS340. End NS340. Export NS340. Module NS341. Module NS341. Definition x := 0. End NS341. End NS341. Export NS341. Module NS342. Module NS342. Definition x := 0. End NS342. End NS342. Export NS342. Module NS343. Module NS343. Definition x := 0. End NS343. End NS343. Export NS343. Module NS344. Module NS344. Definition x := 0. End NS344. End NS344. Export NS344. Module NS345. Module NS345. Definition x := 0. End NS345. End NS345. Export NS345. Module NS346. Module NS346. Definition x := 0. End NS346. End NS346. Export NS346. Module NS347. Module NS347. Definition x := 0. End NS347. End NS347. Export NS347. Module NS348. Module NS348. Definition x := 0. End NS348. End NS348. Export NS348. Module NS349. Module NS349. Definition x := 0. End NS349. End NS349. Export NS349. Module NS350. Module NS350. Definition x := 0. End NS350. End NS350. Export NS350. Module NS351. Module NS351. Definition x := 0. End NS351. End NS351. Export NS351. Module NS352. Module NS352. Definition x := 0. End NS352. End NS352. Export NS352. Module NS353. Module NS353. Definition x := 0. End NS353. End NS353. Export NS353. Module NS354. Module NS354. Definition x := 0. End NS354. End NS354. Export NS354. Module NS355. Module NS355. Definition x := 0. End NS355. End NS355. Export NS355. Module NS356. Module NS356. Definition x := 0. End NS356. End NS356. Export NS356. Module NS357. Module NS357. Definition x := 0. End NS357. End NS357. Export NS357. Module NS358. Module NS358. Definition x := 0. End NS358. End NS358. Export NS358. Module NS359. Module NS359. Definition x := 0. End NS359. End NS359. Export NS359. Module NS360. Module NS360. Definition x := 0. End NS360. End NS360. Export NS360. Module NS361. Module NS361. Definition x := 0. End NS361. End NS361. Export NS361. Module NS362. Module NS362. Definition x := 0. End NS362. End NS362. Export NS362. Module NS363. Module NS363. Definition x := 0. End NS363. End NS363. Export NS363. Module NS364. Module NS364. Definition x := 0. End NS364. End NS364. Export NS364. Module NS365. Module NS365. Definition x := 0. End NS365. End NS365. Export NS365. Module NS366. Module NS366. Definition x := 0. End NS366. End NS366. Export NS366. Module NS367. Module NS367. Definition x := 0. End NS367. End NS367. Export NS367. Module NS368. Module NS368. Definition x := 0. End NS368. End NS368. Export NS368. Module NS369. Module NS369. Definition x := 0. End NS369. End NS369. Export NS369. Module NS370. Module NS370. Definition x := 0. End NS370. End NS370. Export NS370. Module NS371. Module NS371. Definition x := 0. End NS371. End NS371. Export NS371. Module NS372. Module NS372. Definition x := 0. End NS372. End NS372. Export NS372. Module NS373. Module NS373. Definition x := 0. End NS373. End NS373. Export NS373. Module NS374. Module NS374. Definition x := 0. End NS374. End NS374. Export NS374. Module NS375. Module NS375. Definition x := 0. End NS375. End NS375. Export NS375. Module NS376. Module NS376. Definition x := 0. End NS376. End NS376. Export NS376. Module NS377. Module NS377. Definition x := 0. End NS377. End NS377. Export NS377. Module NS378. Module NS378. Definition x := 0. End NS378. End NS378. Export NS378. Module NS379. Module NS379. Definition x := 0. End NS379. End NS379. Export NS379. Module NS380. Module NS380. Definition x := 0. End NS380. End NS380. Export NS380. Module NS381. Module NS381. Definition x := 0. End NS381. End NS381. Export NS381. Module NS382. Module NS382. Definition x := 0. End NS382. End NS382. Export NS382. Module NS383. Module NS383. Definition x := 0. End NS383. End NS383. Export NS383. Module NS384. Module NS384. Definition x := 0. End NS384. End NS384. Export NS384. Module NS385. Module NS385. Definition x := 0. End NS385. End NS385. Export NS385. Module NS386. Module NS386. Definition x := 0. End NS386. End NS386. Export NS386. Module NS387. Module NS387. Definition x := 0. End NS387. End NS387. Export NS387. Module NS388. Module NS388. Definition x := 0. End NS388. End NS388. Export NS388. Module NS389. Module NS389. Definition x := 0. End NS389. End NS389. Export NS389. Module NS390. Module NS390. Definition x := 0. End NS390. End NS390. Export NS390. Module NS391. Module NS391. Definition x := 0. End NS391. End NS391. Export NS391. Module NS392. Module NS392. Definition x := 0. End NS392. End NS392. Export NS392. Module NS393. Module NS393. Definition x := 0. End NS393. End NS393. Export NS393. Module NS394. Module NS394. Definition x := 0. End NS394. End NS394. Export NS394. Module NS395. Module NS395. Definition x := 0. End NS395. End NS395. Export NS395. Module NS396. Module NS396. Definition x := 0. End NS396. End NS396. Export NS396. Module NS397. Module NS397. Definition x := 0. End NS397. End NS397. Export NS397. Module NS398. Module NS398. Definition x := 0. End NS398. End NS398. Export NS398. Module NS399. Module NS399. Definition x := 0. End NS399. End NS399. Export NS399. Module NS400. Module NS400. Definition x := 0. End NS400. End NS400. Export NS400. Module NS401. Module NS401. Definition x := 0. End NS401. End NS401. Export NS401. Module NS402. Module NS402. Definition x := 0. End NS402. End NS402. Export NS402. Module NS403. Module NS403. Definition x := 0. End NS403. End NS403. Export NS403. Module NS404. Module NS404. Definition x := 0. End NS404. End NS404. Export NS404. Module NS405. Module NS405. Definition x := 0. End NS405. End NS405. Export NS405. Module NS406. Module NS406. Definition x := 0. End NS406. End NS406. Export NS406. Module NS407. Module NS407. Definition x := 0. End NS407. End NS407. Export NS407. Module NS408. Module NS408. Definition x := 0. End NS408. End NS408. Export NS408. Module NS409. Module NS409. Definition x := 0. End NS409. End NS409. Export NS409. Module NS410. Module NS410. Definition x := 0. End NS410. End NS410. Export NS410. Module NS411. Module NS411. Definition x := 0. End NS411. End NS411. Export NS411. Module NS412. Module NS412. Definition x := 0. End NS412. End NS412. Export NS412. Module NS413. Module NS413. Definition x := 0. End NS413. End NS413. Export NS413. Module NS414. Module NS414. Definition x := 0. End NS414. End NS414. Export NS414. Module NS415. Module NS415. Definition x := 0. End NS415. End NS415. Export NS415. Module NS416. Module NS416. Definition x := 0. End NS416. End NS416. Export NS416. Module NS417. Module NS417. Definition x := 0. End NS417. End NS417. Export NS417. Module NS418. Module NS418. Definition x := 0. End NS418. End NS418. Export NS418. Module NS419. Module NS419. Definition x := 0. End NS419. End NS419. Export NS419. Module NS420. Module NS420. Definition x := 0. End NS420. End NS420. Export NS420. Module NS421. Module NS421. Definition x := 0. End NS421. End NS421. Export NS421. Module NS422. Module NS422. Definition x := 0. End NS422. End NS422. Export NS422. Module NS423. Module NS423. Definition x := 0. End NS423. End NS423. Export NS423. Module NS424. Module NS424. Definition x := 0. End NS424. End NS424. Export NS424. Module NS425. Module NS425. Definition x := 0. End NS425. End NS425. Export NS425. Module NS426. Module NS426. Definition x := 0. End NS426. End NS426. Export NS426. Module NS427. Module NS427. Definition x := 0. End NS427. End NS427. Export NS427. Module NS428. Module NS428. Definition x := 0. End NS428. End NS428. Export NS428. Module NS429. Module NS429. Definition x := 0. End NS429. End NS429. Export NS429. Module NS430. Module NS430. Definition x := 0. End NS430. End NS430. Export NS430. Module NS431. Module NS431. Definition x := 0. End NS431. End NS431. Export NS431. Module NS432. Module NS432. Definition x := 0. End NS432. End NS432. Export NS432. Module NS433. Module NS433. Definition x := 0. End NS433. End NS433. Export NS433. Module NS434. Module NS434. Definition x := 0. End NS434. End NS434. Export NS434. Module NS435. Module NS435. Definition x := 0. End NS435. End NS435. Export NS435. Module NS436. Module NS436. Definition x := 0. End NS436. End NS436. Export NS436. Module NS437. Module NS437. Definition x := 0. End NS437. End NS437. Export NS437. Module NS438. Module NS438. Definition x := 0. End NS438. End NS438. Export NS438. Module NS439. Module NS439. Definition x := 0. End NS439. End NS439. Export NS439. Module NS440. Module NS440. Definition x := 0. End NS440. End NS440. Export NS440. Module NS441. Module NS441. Definition x := 0. End NS441. End NS441. Export NS441. Module NS442. Module NS442. Definition x := 0. End NS442. End NS442. Export NS442. Module NS443. Module NS443. Definition x := 0. End NS443. End NS443. Export NS443. Module NS444. Module NS444. Definition x := 0. End NS444. End NS444. Export NS444. Module NS445. Module NS445. Definition x := 0. End NS445. End NS445. Export NS445. Module NS446. Module NS446. Definition x := 0. End NS446. End NS446. Export NS446. Module NS447. Module NS447. Definition x := 0. End NS447. End NS447. Export NS447. Module NS448. Module NS448. Definition x := 0. End NS448. End NS448. Export NS448. Module NS449. Module NS449. Definition x := 0. End NS449. End NS449. Export NS449. Module NS450. Module NS450. Definition x := 0. End NS450. End NS450. Export NS450. Module NS451. Module NS451. Definition x := 0. End NS451. End NS451. Export NS451. Module NS452. Module NS452. Definition x := 0. End NS452. End NS452. Export NS452. Module NS453. Module NS453. Definition x := 0. End NS453. End NS453. Export NS453. Module NS454. Module NS454. Definition x := 0. End NS454. End NS454. Export NS454. Module NS455. Module NS455. Definition x := 0. End NS455. End NS455. Export NS455. Module NS456. Module NS456. Definition x := 0. End NS456. End NS456. Export NS456. Module NS457. Module NS457. Definition x := 0. End NS457. End NS457. Export NS457. Module NS458. Module NS458. Definition x := 0. End NS458. End NS458. Export NS458. Module NS459. Module NS459. Definition x := 0. End NS459. End NS459. Export NS459. Module NS460. Module NS460. Definition x := 0. End NS460. End NS460. Export NS460. Module NS461. Module NS461. Definition x := 0. End NS461. End NS461. Export NS461. Module NS462. Module NS462. Definition x := 0. End NS462. End NS462. Export NS462. Module NS463. Module NS463. Definition x := 0. End NS463. End NS463. Export NS463. Module NS464. Module NS464. Definition x := 0. End NS464. End NS464. Export NS464. Module NS465. Module NS465. Definition x := 0. End NS465. End NS465. Export NS465. Module NS466. Module NS466. Definition x := 0. End NS466. End NS466. Export NS466. Module NS467. Module NS467. Definition x := 0. End NS467. End NS467. Export NS467. Module NS468. Module NS468. Definition x := 0. End NS468. End NS468. Export NS468. Module NS469. Module NS469. Definition x := 0. End NS469. End NS469. Export NS469. Module NS470. Module NS470. Definition x := 0. End NS470. End NS470. Export NS470. Module NS471. Module NS471. Definition x := 0. End NS471. End NS471. Export NS471. Module NS472. Module NS472. Definition x := 0. End NS472. End NS472. Export NS472. Module NS473. Module NS473. Definition x := 0. End NS473. End NS473. Export NS473. Module NS474. Module NS474. Definition x := 0. End NS474. End NS474. Export NS474. Module NS475. Module NS475. Definition x := 0. End NS475. End NS475. Export NS475. Module NS476. Module NS476. Definition x := 0. End NS476. End NS476. Export NS476. Module NS477. Module NS477. Definition x := 0. End NS477. End NS477. Export NS477. Module NS478. Module NS478. Definition x := 0. End NS478. End NS478. Export NS478. Module NS479. Module NS479. Definition x := 0. End NS479. End NS479. Export NS479. Module NS480. Module NS480. Definition x := 0. End NS480. End NS480. Export NS480. Module NS481. Module NS481. Definition x := 0. End NS481. End NS481. Export NS481. Module NS482. Module NS482. Definition x := 0. End NS482. End NS482. Export NS482. Module NS483. Module NS483. Definition x := 0. End NS483. End NS483. Export NS483. Module NS484. Module NS484. Definition x := 0. End NS484. End NS484. Export NS484. Module NS485. Module NS485. Definition x := 0. End NS485. End NS485. Export NS485. Module NS486. Module NS486. Definition x := 0. End NS486. End NS486. Export NS486. Module NS487. Module NS487. Definition x := 0. End NS487. End NS487. Export NS487. Module NS488. Module NS488. Definition x := 0. End NS488. End NS488. Export NS488. Module NS489. Module NS489. Definition x := 0. End NS489. End NS489. Export NS489. Module NS490. Module NS490. Definition x := 0. End NS490. End NS490. Export NS490. Module NS491. Module NS491. Definition x := 0. End NS491. End NS491. Export NS491. Module NS492. Module NS492. Definition x := 0. End NS492. End NS492. Export NS492. Module NS493. Module NS493. Definition x := 0. End NS493. End NS493. Export NS493. Module NS494. Module NS494. Definition x := 0. End NS494. End NS494. Export NS494. Module NS495. Module NS495. Definition x := 0. End NS495. End NS495. Export NS495. Module NS496. Module NS496. Definition x := 0. End NS496. End NS496. Export NS496. Module NS497. Module NS497. Definition x := 0. End NS497. End NS497. Export NS497. Module NS498. Module NS498. Definition x := 0. End NS498. End NS498. Export NS498. Module NS499. Module NS499. Definition x := 0. End NS499. End NS499. Export NS499. Module NS500. Module NS500. Definition x := 0. End NS500. End NS500. Export NS500.coq-elpi-2.1.0/apps/NES/tests/test_NES_resolve.v000066400000000000000000000011351460156013500213700ustar00rootroot00000000000000From elpi.apps Require Import NES. NES.Begin A. Definition cats := 3. NES.End A. NES.Begin B. Definition dogs := 4. NES.End B. NES.Begin C. NES.Begin A. Definition bunnies := 42. NES.End A. Section more_bunnies. NES.Open A. Definition more_bunnies := bunnies. End more_bunnies. Section more_cats. NES.Open _.A. Definition more_cats := cats. End more_cats. Section more_dogs. NES.Open B. Definition more_dogs := dogs. End more_dogs. Section even_more_dogs. NES.Open _.B. Definition even_more_dogs := dogs. End even_more_dogs. NES.End C. coq-elpi-2.1.0/apps/NES/tests/test_module_namespace.v000066400000000000000000000001371460156013500225060ustar00rootroot00000000000000From elpi.apps Require Import NES. Module MyModule. End MyModule. Succeed NES.Begin MyModule. coq-elpi-2.1.0/apps/NES/theories/000077500000000000000000000000001460156013500164365ustar00rootroot00000000000000coq-elpi-2.1.0/apps/NES/theories/NES.v000066400000000000000000000063741460156013500172640ustar00rootroot00000000000000From elpi.apps.NES Extra Dependency "nes_synterp.elpi" as nes_synterp. From elpi.apps.NES Extra Dependency "nes_interp.elpi" as nes_interp. From elpi Require Import elpi. #[phase="both"] Elpi Db NES.db lp:{{ typeabbrev path (list string). :index (2) pred ns o:path, o:modpath. }}. #[synterp] Elpi Accumulate NES.db lp:{{ pred open-ns o:string, o:list string. :name "open-ns:begin" open-ns _ _ :- fail. }}. Elpi Command NES.Status. #[synterp] Elpi Accumulate Db NES.db. #[synterp] Elpi Accumulate File nes_synterp. #[synterp] Elpi Accumulate lp:{{ main _ :- coq.say "NES: current namespace" {nes.current-path}, std.findall (ns Y_ Z_) NS, coq.say "NES: registered namespaces" NS. }}. Elpi Typecheck. Elpi Export NES.Status. Elpi Command NES.Begin. #[synterp] Elpi Accumulate File nes_synterp. #[interp] Elpi Accumulate File nes_interp. #[phase="both"] Elpi Accumulate Db NES.db. #[synterp] Elpi Accumulate lp:{{ main [str NS] :- !, nes.begin-path {nes.string->non-empty-ns NS} _. main _ :- coq.error "usage: NES.Begin ". }}. #[interp] Elpi Accumulate lp:{{ main _ :- nes.begin-path. }}. Elpi Typecheck. Elpi Export NES.Begin. Elpi Command NES.End. #[synterp] Elpi Accumulate File nes_synterp. #[interp] Elpi Accumulate File nes_interp. #[phase="both"] Elpi Accumulate Db NES.db. #[synterp] Elpi Accumulate lp:{{ main [str NS] :- nes.end-path {nes.string->non-empty-ns NS} _. main _ :- coq.error "usage: NES.End ". }}. #[interp] Elpi Accumulate lp:{{ main _ :- nes.end-path. }}. Elpi Typecheck. Elpi Export NES.End. Elpi Command NES.Open. #[synterp] Elpi Accumulate File nes_synterp. #[interp] Elpi Accumulate File nes_interp. #[phase="both"] Elpi Accumulate Db NES.db. #[synterp] Elpi Accumulate lp:{{ main [str NS] :- nes.open-path {nes.resolve NS}. main _ :- coq.error "usage: NES.Open ". }}. #[interp] Elpi Accumulate lp:{{ main _ :- nes.open-path. }}. Elpi Typecheck. Elpi Export NES.Open. (* List the contents a namespace *) Elpi Command NES.List. #[phase="both"] Elpi Accumulate Db NES.db. #[synterp] Elpi Accumulate File nes_synterp. #[interp] Elpi Accumulate File nes_interp. #[synterp] Elpi Accumulate lp:{{ main-synterp [str NS] (pr DB Path) :- nes.resolve NS Path, std.findall (ns O_ P_) DB. }}. #[interp] Elpi Accumulate lp:{{ pred pp-gref i:gref, o:coq.pp. pp-gref GR PP :- coq.term->pp (global GR) PP. main-interp [str _] (pr DB Path) :- DB => nes.print-path Path pp-gref. main _ :- coq.error "usage: NES.List ". }}. Elpi Typecheck. Elpi Export NES.List. (* NES.List with types *) Elpi Command NES.Print. #[phase="both"] Elpi Accumulate Db NES.db. #[synterp] Elpi Accumulate File nes_synterp. #[interp] Elpi Accumulate File nes_interp. #[synterp] Elpi Accumulate lp:{{ main-synterp [str NS] (pr DB Path) :- nes.resolve NS Path, std.findall (ns O_ P_) DB. }}. Elpi Accumulate lp:{{ pred pp-gref i:gref, o:coq.pp. pp-gref GR PP :- std.do! [ coq.env.typeof GR Ty, PP = coq.pp.box (coq.pp.hov 2) [ {coq.term->pp (global GR)}, coq.pp.str " :", coq.pp.spc, {coq.term->pp Ty}, ], ]. main-interp [str _] (pr DB Path) :- DB => nes.print-path Path pp-gref. main _ :- coq.error "usage: NES.Print ". }}. Elpi Typecheck. Elpi Export NES.Print. coq-elpi-2.1.0/apps/README.md000066400000000000000000000005141460156013500154460ustar00rootroot00000000000000## Applications written in Coq-Elpi ### Derive Given an inductive type declaration it synthesizes a bunch of useful stuff such as proved equality tests, projections, parametricity relations. ### Eltac A toy set of tactics implemented in Elpi. ### NES A Namespace Emulation System. ### Locker A kit to lock definitions hard. coq-elpi-2.1.0/apps/coercion/000077500000000000000000000000001460156013500157705ustar00rootroot00000000000000coq-elpi-2.1.0/apps/coercion/Makefile000066400000000000000000000022501460156013500174270ustar00rootroot00000000000000# detection of coq ifeq "$(COQBIN)" "" COQBIN := $(shell which coqc >/dev/null 2>&1 && dirname `which coqc`) endif ifeq "$(COQBIN)" "" $(error Coq not found, make sure it is installed in your PATH or set COQBIN) else $(info Using coq found in $(COQBIN), from COQBIN or PATH) endif export COQBIN := $(COQBIN)/ all: build test build: Makefile.coq @$(MAKE) --no-print-directory -f Makefile.coq test: Makefile.test.coq @$(MAKE) --no-print-directory -f Makefile.test.coq theories/%.vo: force @$(MAKE) --no-print-directory -f Makefile.coq $@ tests/%.vo: force build Makefile.test.coq @$(MAKE) --no-print-directory -f Makefile.test.coq $@ examples/%.vo: force build Makefile.test.coq @$(MAKE) --no-print-directory -f Makefile.test.coq $@ Makefile.coq Makefile.coq.conf: _CoqProject @$(COQBIN)/coq_makefile -f _CoqProject -o Makefile.coq @$(MAKE) --no-print-directory -f Makefile.coq .merlin Makefile.test.coq Makefile.test.coq.conf: _CoqProject.test @$(COQBIN)/coq_makefile -f _CoqProject.test -o Makefile.test.coq clean: Makefile.coq Makefile.test.coq @$(MAKE) -f Makefile.coq $@ @$(MAKE) -f Makefile.test.coq $@ .PHONY: force all build test install: @$(MAKE) -f Makefile.coq $@ coq-elpi-2.1.0/apps/coercion/Makefile.coq.local000066400000000000000000000002771460156013500213100ustar00rootroot00000000000000CAMLPKGS+= -package coq-elpi.elpi ifeq "$(shell which cygpath >/dev/null 2>&1)" "" OCAMLFINDSEP=: else OCAMLFINDSEP=; endif OCAMLPATH:=../../src/$(OCAMLFINDSEP)$(OCAMLPATH) export OCAMLPATHcoq-elpi-2.1.0/apps/coercion/README.md000066400000000000000000000037731460156013500172610ustar00rootroot00000000000000# Coercion The `coercion` app enables to program Coq coercions in Elpi. This app is experimental. ## The coercion predicate The `coercion` predicate lives in the database `coercion.db` ```elpi % [coercion Ctx V Inferred Expected Res] is queried to cast V to Res % - [Ctx] is the context % - [V] is the value to be coerced % - [Inferred] is the type of [V] % - [Expected] is the type [V] should be coerced to % - [Res] is the result (of type [Expected]) pred coercion i:goal-ctx, i:term, i:term, i:term, o:term. ``` By addings rules for this predicate one can recover from a type error, that is when `Inferred` and `Expected` are not unifiable. ## Simple example of coercion This example maps `True : Prop` to `true : bool`, which is a function you cannot express in type theory, hence in the standard Coercion system. ```coq From elpi.apps Require Import coercion. From Coq Require Import Bool. Elpi Accumulate coercion.db lp:{{ coercion _ {{ True }} {{ Prop }} {{ bool }} {{ true }}. coercion _ {{ False }} {{ Prop }} {{ bool }} {{ false }}. }}. Elpi Typecheck coercion. (* checks the elpi program is OK *) Check True && False. ``` ## Example of coercion with proof automation This coercion enriches `x : T` to a `{x : T | P x}` by using `my_solver` to prove `P x`. ```coq From elpi.apps Require Import coercion. From Coq Require Import Arith ssreflect. Ltac my_solver := trivial with arith. Elpi Accumulate coercion.db lp:{{ coercion _ X Ty {{ @sig lp:Ty lp:P }} Solution :- std.do! [ % we unfold letins since the solver is dumb and the `as` in the second % example introduces a letin (pi a b b1\ copy a b :- def a _ _ b, copy b b1) => copy X X1, % we build the solution Solution = {{ @exist lp:Ty lp:P lp:X1 _ }}, % we call the solver coq.ltac.collect-goals Solution [G] [], coq.ltac.open (coq.ltac.call-ltac1 "my_solver") G [], ]. }}. Elpi Typecheck coercion. Goal {x : nat | x > 0}. apply: 3. Qed. Definition ensure_pos n : {x : nat | x > 0} := match n with | O => 1 | S x as y => y end. ``` coq-elpi-2.1.0/apps/coercion/_CoqProject000066400000000000000000000004001460156013500201150ustar00rootroot00000000000000# Hack to see Coq-Elpi even if it is not installed yet -Q ../../theories elpi -I ../../src -docroot elpi.apps -R theories elpi.apps src/coq_elpi_coercion_hook.mlg src/elpi_coercion_plugin.mlpack -I src/ src/META.coq-elpi-coercion theories/coercion.v coq-elpi-2.1.0/apps/coercion/_CoqProject.test000066400000000000000000000003771460156013500211100ustar00rootroot00000000000000# Hack to see Coq-Elpi even if it is not installed yet -Q ../../theories elpi -I ../../src -docroot elpi.apps -R theories elpi.apps -R tests elpi.apps.coercion.tests tests/test_coercion.v tests/test_coercion_open.v tests/test_coercion_load.v -I src coq-elpi-2.1.0/apps/coercion/src/000077500000000000000000000000001460156013500165575ustar00rootroot00000000000000coq-elpi-2.1.0/apps/coercion/src/META.coq-elpi-coercion000066400000000000000000000004431460156013500225400ustar00rootroot00000000000000 package "plugin" ( directory = "." requires = "coq-core.plugins.ltac coq-elpi.elpi" archive(byte) = "elpi_coercion_plugin.cma" archive(native) = "elpi_coercion_plugin.cmxa" plugin(byte) = "elpi_coercion_plugin.cma" plugin(native) = "elpi_coercion_plugin.cmxs" ) directory = "." coq-elpi-2.1.0/apps/coercion/src/coq_elpi_coercion_hook.mlg000066400000000000000000000042461460156013500237620ustar00rootroot00000000000000DECLARE PLUGIN "coq-elpi-coercion.plugin" { open Elpi open Elpi_plugin open Coq_elpi_arg_syntax open Coq_elpi_vernacular let elpi_coercion_hook program env sigma ~flags v ~inferred ~expected = let loc = API.Ast.Loc.initial "(unknown)" in let atts = [] in let sigma, goal = Evarutil.new_evar env sigma expected in let goal_evar, _ = EConstr.destEvar sigma goal in let query ~depth state = let state, (loc, q), gls = Coq_elpi_HOAS.goals2query sigma [goal_evar] loc ~main:(Coq_elpi_HOAS.Solve [v; inferred]) ~in_elpi_tac_arg:Coq_elpi_arg_HOAS.in_elpi_tac_econstr ~depth state in let state, qatts = atts2impl loc Summary.Stage.Interp ~depth state atts q in let state = API.State.set Coq_elpi_builtins.tactic_mode state true in state, (loc, qatts), gls in match Interp.get_and_compile program with | None -> None | Some (cprogram, _) -> match Interp.run ~static_check:false cprogram (`Fun query) with | API.Execute.Success solution -> let gls = Evar.Set.singleton goal_evar in let sigma, _, _ = Coq_elpi_HOAS.solution2evd sigma solution gls in if Evd.is_defined sigma goal_evar then Some (sigma, goal) else None | API.Execute.NoMoreSteps | API.Execute.Failure -> None | exception (Coq_elpi_utils.LtacFail (level, msg)) -> None let add_coercion_hook = let coercion_hook_program = Summary.ref ~name:"elpi-coercion" None in let coercion_hook env sigma ~flags v ~inferred ~expected = match !coercion_hook_program with | None -> None | Some h -> elpi_coercion_hook h env sigma ~flags v ~inferred ~expected in let name = "elpi-coercion" in Coercion.register_hook ~name coercion_hook; let inCoercion = let cache program = coercion_hook_program := Some program; Coercion.activate_hook ~name in let open Libobject in declare_object @@ superglobal_object_nodischarge "ELPI-COERCION" ~cache ~subst:None in fun program -> Lib.add_leaf (inCoercion program) } VERNAC COMMAND EXTEND ElpiCoercion CLASSIFIED AS SIDEFF | #[ atts = any_attribute ] [ "Elpi" "CoercionFallbackTactic" qualified_name(p) ] -> { let () = ignore_unknown_attributes atts in add_coercion_hook (snd p) } ENDcoq-elpi-2.1.0/apps/coercion/src/elpi_coercion_plugin.mlpack000066400000000000000000000000261460156013500241360ustar00rootroot00000000000000Coq_elpi_coercion_hookcoq-elpi-2.1.0/apps/coercion/tests/000077500000000000000000000000001460156013500171325ustar00rootroot00000000000000coq-elpi-2.1.0/apps/coercion/tests/test_coercion.v000066400000000000000000000013401460156013500221570ustar00rootroot00000000000000From elpi.apps Require Import coercion. From Coq Require Import Bool. Elpi Accumulate coercion.db lp:{{ coercion _ {{ True }} {{ Prop }} {{ bool }} {{ true }}. coercion _ {{ False }} {{ Prop }} {{ bool }} {{ false }}. }}. Elpi Typecheck coercion. Check True && False. Parameter ringType : Type. Parameter ringType_sort : ringType -> Type. Parameter natmul : forall (R : ringType) (n : nat), (ringType_sort R). Elpi Accumulate coercion.db lp:{{ coercion _ N {{ nat }} {{ ringType_sort lp:R }} {{ natmul lp:R lp:N }} :- coq.typecheck R {{ ringType }} ok. }}. Elpi Typecheck coercion. Section TestNatMul. Variable R : ringType. Variable n : nat. Check natmul R n : ringType_sort R. Check n : ringType_sort R. End TestNatMul. coq-elpi-2.1.0/apps/coercion/tests/test_coercion_load.v000066400000000000000000000000621460156013500231560ustar00rootroot00000000000000Require Import test_coercion. Check True : bool. coq-elpi-2.1.0/apps/coercion/tests/test_coercion_open.v000066400000000000000000000012541460156013500232040ustar00rootroot00000000000000From elpi.apps Require Import coercion. From Coq Require Import Arith ssreflect. Ltac my_solver := trivial with arith. Elpi Accumulate coercion.db lp:{{ coercion _ X Ty {{ @sig lp:Ty lp:P }} Solution :- std.do! [ % we unfold letins since the solve is dumb (pi a b b1\ copy a b :- def a _ _ b, copy b b1) => copy X X1, % we build the solution Solution = {{ @exist lp:Ty lp:P lp:X1 _ }}, % we call the solver coq.ltac.collect-goals Solution [G] [], coq.ltac.open (coq.ltac.call-ltac1 "my_solver") G [], ]. }}. Elpi Typecheck coercion. Goal {x : nat | x > 0}. apply: 3. Qed. Definition add1 n : {x : nat | x > 0} := match n with | O => 1 | S x as y => y end. coq-elpi-2.1.0/apps/coercion/theories/000077500000000000000000000000001460156013500176125ustar00rootroot00000000000000coq-elpi-2.1.0/apps/coercion/theories/coercion.v000066400000000000000000000013041460156013500216000ustar00rootroot00000000000000Declare ML Module "coq-elpi-coercion.plugin". From elpi Require Import elpi. Elpi Db coercion.db lp:{{ % predicate [coercion Ctx V Inferred Expected Res] used to add new coercion, with % - [Ctx] is the context % - [V] is the value to be coerced % - [Inferred] is the type of [V] % - [Expected] is the type [V] should be coerced to % - [Res] is the result (of type [Expected]) % Be careful not to trigger coercion as this may loop. pred coercion i:goal-ctx, i:term, i:term, i:term, o:term. }}. Elpi Tactic coercion. Elpi Accumulate lp:{{ solve (goal Ctx _ Ty Sol [trm V, trm VTy]) _ :- coercion Ctx V VTy Ty Sol. }}. Elpi Accumulate Db coercion.db. Elpi Typecheck. Elpi CoercionFallbackTactic coercion. coq-elpi-2.1.0/apps/cs/000077500000000000000000000000001460156013500145745ustar00rootroot00000000000000coq-elpi-2.1.0/apps/cs/Makefile000066400000000000000000000022501460156013500162330ustar00rootroot00000000000000# detection of coq ifeq "$(COQBIN)" "" COQBIN := $(shell which coqc >/dev/null 2>&1 && dirname `which coqc`) endif ifeq "$(COQBIN)" "" $(error Coq not found, make sure it is installed in your PATH or set COQBIN) else $(info Using coq found in $(COQBIN), from COQBIN or PATH) endif export COQBIN := $(COQBIN)/ all: build test build: Makefile.coq @$(MAKE) --no-print-directory -f Makefile.coq test: Makefile.test.coq @$(MAKE) --no-print-directory -f Makefile.test.coq theories/%.vo: force @$(MAKE) --no-print-directory -f Makefile.coq $@ tests/%.vo: force build Makefile.test.coq @$(MAKE) --no-print-directory -f Makefile.test.coq $@ examples/%.vo: force build Makefile.test.coq @$(MAKE) --no-print-directory -f Makefile.test.coq $@ Makefile.coq Makefile.coq.conf: _CoqProject @$(COQBIN)/coq_makefile -f _CoqProject -o Makefile.coq @$(MAKE) --no-print-directory -f Makefile.coq .merlin Makefile.test.coq Makefile.test.coq.conf: _CoqProject.test @$(COQBIN)/coq_makefile -f _CoqProject.test -o Makefile.test.coq clean: Makefile.coq Makefile.test.coq @$(MAKE) -f Makefile.coq $@ @$(MAKE) -f Makefile.test.coq $@ .PHONY: force all build test install: @$(MAKE) -f Makefile.coq $@ coq-elpi-2.1.0/apps/cs/Makefile.coq.local000066400000000000000000000002771460156013500201140ustar00rootroot00000000000000CAMLPKGS+= -package coq-elpi.elpi ifeq "$(shell which cygpath >/dev/null 2>&1)" "" OCAMLFINDSEP=: else OCAMLFINDSEP=; endif OCAMLPATH:=../../src/$(OCAMLFINDSEP)$(OCAMLPATH) export OCAMLPATHcoq-elpi-2.1.0/apps/cs/README.md000066400000000000000000000020151460156013500160510ustar00rootroot00000000000000# Canonical solution The `canonical_solution` app enables to program Coq canonical structure solutions in Elpi. This app is experimental. ## The cs predicate The `cs` predicate lives in the database `cs.db` ```elpi % predicate [cs Ctx Lhs Rhs] used to unify Lhs with Rhs, with % - [Ctx] is the context % - [Lhs] and [Rhs] are the terms to unify :index (0 6 6) pred cs i:goal-ctx, o:term, o:term. ``` By addings rules for this predicate one can recover from a CS instance search failure error, that is when `Lhs` and `Rhs` are not unifiable using a canonical structure registered by Coq. ## Simple example of canonical solution This example declares a structure `S` with a projection `sort` and declares a canonical solution for `nat` in `S`. ```coq From elpi.apps Require Import cs. From Coq Require Import Bool. Structure S : Type := { sort :> Type }. Elpi Accumulate cs.db lp:{{ cs _ {{ sort lp:Sol }} {{ nat }} :- Sol = {{ Build_S nat }}. }}. Elpi Typecheck canonical_solution. Check eq_refl _ : (sort _) = nat. ``` coq-elpi-2.1.0/apps/cs/_CoqProject000066400000000000000000000003771460156013500167360ustar00rootroot00000000000000# Hack to see Coq-Elpi even if it is not installed yet -Q ../../theories elpi -I ../../src -docroot elpi.apps -R theories elpi.apps src/evarconv_hacked.ml src/coq_elpi_cs_hook.mlg src/elpi_cs_plugin.mlpack -I src/ src/META.coq-elpi-cs theories/cs.v coq-elpi-2.1.0/apps/cs/_CoqProject.test000066400000000000000000000002751460156013500177110ustar00rootroot00000000000000# Hack to see Coq-Elpi even if it is not installed yet -Q ../../theories elpi -I ../../src -docroot elpi.apps -R theories elpi.apps -R tests elpi.apps.cs.tests tests/test_cs.v -I src coq-elpi-2.1.0/apps/cs/src/000077500000000000000000000000001460156013500153635ustar00rootroot00000000000000coq-elpi-2.1.0/apps/cs/src/META.coq-elpi-cs000066400000000000000000000004131460156013500201450ustar00rootroot00000000000000 package "plugin" ( directory = "." requires = "coq-core.plugins.ltac coq-elpi.elpi" archive(byte) = "elpi_cs_plugin.cma" archive(native) = "elpi_cs_plugin.cmxa" plugin(byte) = "elpi_cs_plugin.cma" plugin(native) = "elpi_cs_plugin.cmxs" ) directory = "." coq-elpi-2.1.0/apps/cs/src/coq_elpi_cs_hook.mlg000066400000000000000000000121141460156013500213630ustar00rootroot00000000000000DECLARE PLUGIN "coq-elpi-cs.plugin" { open Elpi open Elpi_plugin open Coq_elpi_arg_syntax open Coq_elpi_vernacular module Evarconv = Evarconv module Evarconv_hacked = Evarconv_hacked let elpi_cs_hook program env sigma (t1, sk1) (t2, sk2) = let loc = API.Ast.Loc.initial "(unknown)" in let atts = [] in let () = Feedback.msg_info (Pp.str "cs hook start") in let (proji, u), arg = match Termops.global_app_of_constr sigma t1 with | (Names.GlobRef.ConstRef proji, u), arg -> (proji, u), arg | (proji, _), _ -> let () = Feedback.msg_info Pp.(str "proj is not const" ++ Names.GlobRef.print proji) in raise Not_found in let () = Feedback.msg_info (Pp.str "cs hook got proj") in let structure = Structures.Structure.find_from_projection proji in let () = Feedback.msg_info (Pp.str "cs hook got structure") in let params1, c1, extra_args1 = match arg with | Some c -> (* A primitive projection applied to c *) let ty = Retyping.get_type_of ~lax:true env sigma c in let (i,u), ind_args = (* Are we sure that ty is not an evar? *) Inductiveops.find_mrectype env sigma ty in ind_args, c, sk1 | None -> match Reductionops.Stack.strip_n_app structure.nparams sk1 with | Some (params1, c1, extra_args1) -> (Option.get @@ Reductionops.Stack.list_of_app_stack params1), c1, extra_args1 | _ -> raise Not_found in let () = Feedback.msg_info Pp.(str "cs hook got params & arg " ++ int (List.length sk2) ++ str " " ++ int (List.length extra_args1)) in let sk2, extra_args2 = if Reductionops.Stack.args_size sk2 = Reductionops.Stack.args_size extra_args1 then [], sk2 else match Reductionops.Stack.strip_n_app (Reductionops.Stack.args_size sk2 - Reductionops.Stack.args_size extra_args1 - 1) sk2 with | None -> raise Not_found | Some (l',el,s') -> ((Option.get @@ Reductionops.Stack.list_of_app_stack l') @ [el],s') in let rhs = Reductionops.Stack.zip sigma (t2, Reductionops.Stack.append_app_list sk2 Reductionops.Stack.empty) in let sigma, goal = Evarutil.new_evar env sigma (Retyping.get_type_of env sigma c1) in let goal_evar, _ = EConstr.destEvar sigma goal in let query ~depth state = let state, (loc, q), gls = Coq_elpi_HOAS.goals2query sigma [goal_evar] loc ~main:(Coq_elpi_HOAS.Solve [EConstr.mkApp (EConstr.mkConstU (proji, EConstr.EInstance.empty), Array.of_list params1); rhs]) ~in_elpi_tac_arg:Coq_elpi_arg_HOAS.in_elpi_tac_econstr ~depth state in let state, qatts = atts2impl loc Summary.Stage.Interp ~depth state atts q in let state = API.State.set Coq_elpi_builtins.tactic_mode state true in state, (loc, qatts), gls in let () = Feedback.msg_info Pp.(str "compile solver") in match Interp.get_and_compile program with | None -> None | Some (cprogram, _) -> let () = Feedback.msg_info Pp.(str "run solver\n") in begin try match Interp.run ~static_check:false cprogram (`Fun query) with | API.Execute.Success solution -> let () = Feedback.msg_info Pp.(str "found solution\n") in let gls = Evar.Set.singleton goal_evar in let sigma, _, _ = Coq_elpi_HOAS.solution2evd sigma solution gls in if Evd.is_defined sigma goal_evar then let lhs = Reductionops.Stack.zip sigma (EConstr.mkConstU (proji, EConstr.EInstance.empty), Reductionops.Stack.append_app_list (params1 @ [goal]) Reductionops.Stack.empty) in let lhs = Reductionops.whd_const proji env sigma lhs in let lhs = Reductionops.whd_betaiotazeta env sigma lhs in let hh, sk1 = EConstr.decompose_app sigma lhs in let () = Feedback.msg_info Pp.(str "aha" ++ Printer.pr_econstr_env env sigma lhs) in let h2, sk2 = EConstr.decompose_app sigma rhs in let _, params = EConstr.decompose_app sigma (Retyping.get_type_of env sigma goal) in Some (sigma, (hh, h2), goal, [], (Array.to_list params, params1), (Array.to_list sk1, Array.to_list sk2), (extra_args1, extra_args2), c1, (None, rhs)) else None | API.Execute.NoMoreSteps | API.Execute.Failure -> let () = Feedback.msg_info Pp.(str "solver failed\n") in None with e -> let () = Feedback.msg_info Pp.(str "solver crashed\n") in raise e end | exception e -> let () = Feedback.msg_info Pp.(str "compiler crashed\n") in raise e let add_cs_hook = let cs_hook_program = Summary.ref ~name:"elpi-cs" None in let cs_hook env sigma proj pat = match !cs_hook_program with | None -> None | Some h -> elpi_cs_hook h env sigma proj pat in let name = "elpi-cs" in Evarconv_hacked.register_hook ~name cs_hook; let inCs = let cache program = cs_hook_program := Some program; Evarconv_hacked.activate_hook ~name in let open Libobject in declare_object @@ superglobal_object_nodischarge "ELPI-CS" ~cache ~subst:None in fun program -> Lib.add_leaf (inCs program) } VERNAC COMMAND EXTEND ElpiCS CLASSIFIED AS SIDEFF | #[ atts = any_attribute ] [ "Elpi" "CSFallbackTactic" qualified_name(p) ] -> { let () = ignore_unknown_attributes atts in add_cs_hook (snd p) } | #[ atts = any_attribute ] [ "Elpi" "Override" "CS" qualified_name(p) ] -> { Evarconv.set_evar_conv Evarconv_hacked.evar_conv_x } END coq-elpi-2.1.0/apps/cs/src/elpi_cs_plugin.mlpack000066400000000000000000000000411460156013500215430ustar00rootroot00000000000000Evarconv_hacked Coq_elpi_cs_hook coq-elpi-2.1.0/apps/cs/src/evarconv_hacked.ml000066400000000000000000002525321460156013500210500ustar00rootroot00000000000000(************************************************************************) (* * The Coq Proof Assistant / The Coq Development Team *) (* v * Copyright INRIA, CNRS and contributors *) (* env -> evar_map -> conv_pb -> EConstr.constr -> EConstr.constr -> Evarsolve.unification_result let default_transparent_state env = TransparentState.full (* Conv_oracle.get_transp_state (Environ.oracle env) *) let default_flags_of ?(subterm_ts=TransparentState.empty) ts = { modulo_betaiota = true; open_ts = ts; closed_ts = ts; subterm_ts; allowed_evars = AllowedEvars.all; with_cs = true; } let default_flags env = let ts = default_transparent_state env in default_flags_of ts let debug_unification = CDebug.create ~name:"elpi-unification" () let debug_ho_unification = CDebug.create ~name:"elpi-ho-unification" () (*******************************************) (* Functions to deal with impossible cases *) (*******************************************) (* In case the constants id/ID are not defined *) let unit_judge_fallback = let na1 = make_annot (Name (Id.of_string "A")) Sorts.Relevant in let na2 = make_annot (Name (Id.of_string "H")) Sorts.Relevant in make_judge (mkLambda (na1,mkProp,mkLambda(na2,mkRel 1,mkRel 1))) (mkProd (na1,mkProp,mkArrow (mkRel 1) Sorts.Relevant (mkRel 2))) let coq_unit_judge env sigma = match Coqlib.lib_ref_opt "core.IDProp.idProp" with | Some c -> let sigma, c = Evd.fresh_global env sigma c in let t = Retyping.get_type_of env sigma c in sigma, make_judge c t | None -> sigma, unit_judge_fallback let unfold_projection env evd ts p r c = let cst = Projection.constant p in if TransparentState.is_transparent_constant ts cst then Some (mkProj (Projection.unfold p, r, c)) else None let eval_flexible_term ts env evd c = match EConstr.kind evd c with | Const (c, u) -> if TransparentState.is_transparent_constant ts c then Option.map EConstr.of_constr (constant_opt_value_in env (c, EInstance.kind evd u)) else None | Rel n -> (try match lookup_rel n env with | RelDecl.LocalAssum _ -> None | RelDecl.LocalDef (_,v,_) -> Some (lift n v) with Not_found -> None) | Var id -> (try if TransparentState.is_transparent_variable ts id then env |> lookup_named id |> NamedDecl.get_value else None with Not_found -> None) | LetIn (_,b,_,c) -> Some (subst1 b c) | Lambda _ -> Some c | Proj (p, r, c) -> if Projection.unfolded p then assert false else unfold_projection env evd ts p r c | _ -> assert false type flex_kind_of_term = | Rigid | MaybeFlexible of EConstr.t (* reducible but not necessarily reduced *) | Flexible of EConstr.existential let has_arg s = Option.has_some (Stack.strip_n_app 0 s) let flex_kind_of_term flags env evd c sk = match EConstr.kind evd c with | LetIn _ | Rel _ | Const _ | Var _ | Proj _ -> Option.cata (fun x -> MaybeFlexible x) Rigid (eval_flexible_term flags.open_ts env evd c) | Lambda _ when has_arg sk -> if flags.modulo_betaiota then MaybeFlexible c else Rigid | Evar ev -> if is_evar_allowed flags (fst ev) then Flexible ev else Rigid | Lambda _ | Prod _ | Sort _ | Ind _ | Int _ | Float _ | Array _ -> Rigid | Construct _ | CoFix _ (* Incorrect: should check only app in sk *) -> Rigid | Meta _ -> Rigid | Fix _ -> Rigid (* happens when the fixpoint is partially applied (should check it?) *) | Cast _ | App _ | Case _ -> assert false let apprec_nohdbeta flags env evd c = let (t,sk as appr) = Reductionops.whd_nored_state env evd (c, []) in if flags.modulo_betaiota && Stack.not_purely_applicative sk then Stack.zip evd (whd_betaiota_deltazeta_for_iota_state flags.open_ts env evd appr) else c let position_problem l2r = function | CONV -> None | CUMUL -> Some l2r (* [occur_rigidly ev evd t] tests if the evar ev occurs in a rigid context in t. Precondition: t has a rigid head and is not reducible. That function is an under approximation of occur-check, it can return false even if the occur-check would succeed on the normal form. This means we might postpone unsolvable constraints which will ultimately result in an occur-check after reductions. If it returns true, we know that the occur-check would also return true on the normal form. [t] is assumed to have a rigid head, which can appear under a elimination context (e.g. application, match or projection). In the inner recursive function, the result indicates if the term is rigid (irreducible), normal (succession of constructors) or potentially reducible. For applications, this means than an occurrence of the evar in arguments should be looked at to find an occur-check if the head is rigid or normal. For inductive eliminations, only an occurrence in a rigid context of the discriminee counts as a rigid occurrence overall, not a normal occurrence which might disappear after reduction. *) type result = Rigid of bool | Normal of bool | Reducible let rigid_normal_occ = function Rigid b -> b | Normal b -> b | _ -> false let occur_rigidly flags env evd (evk,_) t = let rec aux t = match EConstr.kind evd t with | App (f, c) -> (match aux f with | Rigid b -> Rigid (b || Array.exists (fun x -> rigid_normal_occ (aux x)) c) | Normal b -> Normal (b || Array.exists (fun x -> rigid_normal_occ (aux x)) c) | Reducible -> Reducible) | Construct _ -> Normal false | Ind _ | Sort _ -> Rigid false | Proj (p, _, c) -> let cst = Projection.constant p in let rigid = not (TransparentState.is_transparent_constant flags.open_ts cst) in if rigid then aux c else (* if the evar appears rigidly in c then this elimination cannot reduce and we have a rigid occurrence, otherwise we don't know. *) (match aux c with | Rigid _ as res -> res | Normal b -> Reducible | Reducible -> Reducible) | Evar (evk',l) -> if Evar.equal evk evk' then Rigid true else if is_evar_allowed flags evk' then Reducible else Rigid (SList.Skip.exists (fun x -> rigid_normal_occ (aux x)) l) | Cast (p, _, _) -> aux p | Lambda (na, t, b) -> aux b | LetIn (na, _, _, b) -> aux b | Const (c,_) -> if TransparentState.is_transparent_constant flags.open_ts c then Reducible else Rigid false | Prod (_, b, t) -> let b' = aux b and t' = aux t in if rigid_normal_occ b' || rigid_normal_occ t' then Rigid true else Reducible | Rel _ | Var _ -> Reducible | Case (_,_,_,_,_,c,_) -> (match aux c with | Rigid b -> Rigid b | _ -> Reducible) | Meta _ | Fix _ | CoFix _ | Int _ | Float _ | Array _ -> Reducible in match aux t with | Rigid b -> b | Normal b -> b | Reducible -> false (* [check_conv_record env sigma (t1,stack1) (t2,stack2)] tries to decompose the problem (t1 stack1) = (t2 stack2) into a problem stack1 = params1@[c1]@extra_args1 stack2 = us2@extra_args2 t1 params1 c1 = proji params (c xs) t2 us2 = head us extra_args1 = extra_args2 by finding a record R and an object c := [xs:bs](Build_R params v1..vn) with vi = (head us), for which we know that the i-th projection proji satisfies proji params (c xs) = head us Rem: such objects, usable for conversion, are defined in the objdef table; practically, it amounts to "canonically" equip t2 into a object c in structure R (since, if c1 were not an evar, the projection would have been reduced) *) let check_conv_record env sigma (t1,sk1) (t2,sk2) = let open ValuePattern in let (proji, u), arg = Termops.global_app_of_constr sigma t1 in let t2, sk2' = decompose_app sigma (shrink_eta sigma t2) in let sk2 = Stack.append_app sk2' sk2 in let (sigma, solution), sk2_effective = let t2 = let rec remove_lambda t2 = match EConstr.kind sigma t2 with | Lambda (_,_,t2) -> remove_lambda t2 | Cast (t2,_,_) -> remove_lambda t2 | App (t2,_) -> t2 | _ -> t2 in if Stack.is_empty sk2 then remove_lambda t2 else t2 in try match EConstr.kind sigma t2 with Prod (_,_,_) -> (* assert (l2=[]); *) CanonicalSolution.find env sigma (proji, Prod_cs), (Stack.append_app [|t2|] Stack.empty) | Sort s -> let s = ESorts.kind sigma s in CanonicalSolution.find env sigma (proji, Sort_cs (Sorts.family s)),[] | Proj (p, _, c) -> CanonicalSolution.find env sigma(proji, Proj_cs (Names.Projection.repr p)), Stack.append_app [|c|] sk2 | _ -> let (c2, _) = try destRef sigma t2 with DestKO -> raise Not_found in CanonicalSolution.find env sigma (proji, Const_cs c2),sk2 with Not_found -> CanonicalSolution.find env sigma (proji,Default_cs), [] in let open CanonicalSolution in let params1, c1, extra_args1 = match arg with | Some c -> (* A primitive projection applied to c *) let ty = Retyping.get_type_of ~lax:true env sigma c in let (i,u), ind_args = (* Are we sure that ty is not an evar? *) Inductiveops.find_mrectype env sigma ty in ind_args, c, sk1 | None -> match Stack.strip_n_app solution.nparams sk1 with | Some (params1, c1, extra_args1) -> (Option.get @@ Stack.list_of_app_stack params1), c1, extra_args1 | _ -> raise Not_found in let us2,extra_args2 = let l_us = List.length solution.cvalue_arguments in if Int.equal l_us 0 then [], sk2_effective else match (Stack.strip_n_app (l_us-1) sk2_effective) with | None -> raise Not_found | Some (l',el,s') -> ((Option.get @@ Stack.list_of_app_stack l') @ [el],s') in let h, _ = decompose_app sigma solution.body in let t2 = Stack.zip sigma (t2,sk2) in let h2, _ = decompose_app sigma t2 in sigma,(h, h2),solution.constant,solution.abstractions_ty,(solution.params,params1), (solution.cvalue_arguments,us2),(extra_args1,extra_args2),c1, (solution.cvalue_abstraction, t2) (* Precondition: one of the terms of the pb is an uninstantiated evar, * possibly applied to arguments. *) let join_failures evd1 evd2 e1 e2 = match e1, e2 with | _, CannotSolveConstraint (_,ProblemBeyondCapabilities) -> (evd1,e1) | _ -> (evd2,e2) let rec ise_try evd = function [] -> assert false | [f] -> f evd | f1::l -> match f1 evd with | Success _ as x -> x | UnifFailure (evd1,e1) -> match ise_try evd l with | Success _ as x -> x | UnifFailure (evd2,e2) -> let evd,e = join_failures evd1 evd2 e1 e2 in UnifFailure (evd,e) let ise_and evd l = let rec ise_and i = function [] -> assert false | [f] -> f i | f1::l -> match f1 i with | Success i' -> ise_and i' l | UnifFailure _ as x -> x in ise_and evd l let ise_list2 evd f l1 l2 = let rec allrec k l1 l2 = match l1, l2 with | [], [] -> k evd | x1 :: l1, x2 :: l2 -> let k evd = match k evd with | Success evd -> f evd x1 x2 | UnifFailure _ as x -> x in allrec k l1 l2 | ([], _ :: _) | (_ :: _, []) -> UnifFailure (evd, NotSameArgSize) in allrec (fun i -> Success i) l1 l2 let ise_array2 evd f v1 v2 = let rec allrec i = function | -1 -> Success i | n -> match f i v1.(n) v2.(n) with | Success i' -> allrec i' (n-1) | UnifFailure _ as x -> x in let lv1 = Array.length v1 in if Int.equal lv1 (Array.length v2) then allrec evd (pred lv1) else UnifFailure (evd,NotSameArgSize) let rec ise_inst2 evd f l1 l2 = match l1, l2 with | [], [] -> Success evd | [], (_ :: _) | (_ :: _), [] -> assert false | c1 :: l1, c2 :: l2 -> match ise_inst2 evd f l1 l2 with | Success evd' -> f evd' c1 c2 | UnifFailure _ as x -> x (* Applicative node of stack are read from the outermost to the innermost but are unified the other way. *) let rec ise_app_rev_stack2 env f evd revsk1 revsk2 = match Stack.decomp_rev revsk1, Stack.decomp_rev revsk2 with | Some (t1,revsk1), Some (t2,revsk2) -> begin match ise_app_rev_stack2 env f evd revsk1 revsk2 with | (_, UnifFailure _) as x -> x | x, Success i' -> x, f env i' CONV t1 t2 end | _, _ -> (revsk1,revsk2), Success evd (* Add equality constraints for covariant/invariant positions. For irrelevant positions, unify universes when flexible. *) let compare_cumulative_instances pbty evd variances u u' = match Evarutil.compare_cumulative_instances pbty variances u u' evd with | Inl evd -> Success evd | Inr p -> UnifFailure (evd, UnifUnivInconsistency p) let compare_constructor_instances evd u u' = match Evarutil.compare_constructor_instances evd u u' with | Inl evd -> Success evd | Inr p -> UnifFailure (evd, UnifUnivInconsistency p) type application = FullyApplied | NumArgs of int let is_applied o n = match o with FullyApplied -> true | NumArgs m -> Int.equal m n let compare_heads pbty env evd ~nargs term term' = let check_strict evd u u' = let cstrs = UVars.enforce_eq_instances u u' Sorts.QUConstraints.empty in try Success (Evd.add_quconstraints evd cstrs) with UGraph.UniverseInconsistency p -> UnifFailure (evd, UnifUnivInconsistency p) in match EConstr.kind evd term, EConstr.kind evd term' with | Const (c, u), Const (c', u') when QConstant.equal env c c' -> if is_applied nargs 1 && Environ.is_array_type env c then let u = EInstance.kind evd u and u' = EInstance.kind evd u' in compare_cumulative_instances pbty evd [|UVars.Variance.Irrelevant|] u u' else let u = EInstance.kind evd u and u' = EInstance.kind evd u' in check_strict evd u u' | Const _, Const _ -> UnifFailure (evd, NotSameHead) | Ind ((mi,i) as ind , u), Ind (ind', u') when QInd.equal env ind ind' -> if EInstance.is_empty u && EInstance.is_empty u' then Success evd else let u = EInstance.kind evd u and u' = EInstance.kind evd u' in let mind = Environ.lookup_mind mi env in let open Declarations in begin match mind.mind_variance with | None -> check_strict evd u u' | Some variances -> let needed = Conversion.inductive_cumulativity_arguments (mind,i) in if not (is_applied nargs needed) then check_strict evd u u' else compare_cumulative_instances pbty evd variances u u' end | Ind _, Ind _ -> UnifFailure (evd, NotSameHead) | Construct (((mi,ind),ctor as cons), u), Construct (cons', u') when QConstruct.equal env cons cons' -> if EInstance.is_empty u && EInstance.is_empty u' then Success evd else let u = EInstance.kind evd u and u' = EInstance.kind evd u' in let mind = Environ.lookup_mind mi env in let open Declarations in begin match mind.mind_variance with | None -> check_strict evd u u' | Some variances -> let needed = Conversion.constructor_cumulativity_arguments (mind,ind,ctor) in if not (is_applied nargs needed) then check_strict evd u u' else compare_constructor_instances evd u u' end | Construct _, Construct _ -> UnifFailure (evd, NotSameHead) | _, _ -> anomaly (Pp.str "") (* This function tries to unify 2 stacks element by element. It works from the end to the beginning. If it unifies a non empty suffix of stacks but not the entire stacks, the first part of the answer is Some(the remaining prefixes to tackle) If [no_app] is set, situations like [match head u1 u2 with ... end] will not try to match [u1] and [u2] (why?); but situations like [match head u1 u2 with ... end v] will try to match [v] (??) *) (* Input: E1[] =? E2[] where the E1, E2 are concatenations of n-ary-app/case/fix/proj elimination rules Output: - either None if E1 = E2 is solved, - or Some (E1'',E2'') such that there is a decomposition of E1[] = E1'[E1''[]] and E2[] = E2'[E2''[]] s.t. E1' = E2' and E1'' cannot be unified with E2'' - UnifFailure if no such non-empty E1' = E2' exists *) let rec ise_stack2 no_app env evd f sk1 sk2 = let rec ise_rev_stack2 deep i revsk1 revsk2 = let fail x = if deep then Some (List.rev revsk1, List.rev revsk2), Success i else None, x in match revsk1, revsk2 with | [], [] -> None, Success i | Stack.Case cse1 :: q1, Stack.Case cse2 :: q2 -> let (ci1, u1, pms1, (t1,_), br1) = Stack.expand_case env evd cse1 in let (ci2, u2, pms2, (t2,_), br2) = Stack.expand_case env evd cse2 in let hd1 = mkIndU (ci1.ci_ind, u1) in let hd2 = mkIndU (ci2.ci_ind, u2) in let fctx i (ctx1, t1) (_ctx2, t2) = f (push_rel_context ctx1 env) i CONV t1 t2 in begin match ise_and i [ (fun i -> compare_heads CONV env i ~nargs:FullyApplied hd1 hd2); (fun i -> ise_array2 i (fun ii -> f env ii CONV) pms1 pms2); (fun i -> fctx i t1 t2); (fun i -> ise_array2 i fctx br1 br2); ] with | Success i' -> ise_rev_stack2 true i' q1 q2 | UnifFailure _ as x -> fail x end | Stack.Proj (p1,_)::q1, Stack.Proj (p2,_)::q2 -> if QProjection.Repr.equal env (Projection.repr p1) (Projection.repr p2) then ise_rev_stack2 true i q1 q2 else fail (UnifFailure (i, NotSameHead)) | Stack.Fix (((li1, i1),(_,tys1,bds1 as recdef1)),a1)::q1, Stack.Fix (((li2, i2),(_,tys2,bds2)),a2)::q2 -> if Int.equal i1 i2 && Array.equal Int.equal li1 li2 then match ise_and i [ (fun i -> ise_array2 i (fun ii -> f env ii CONV) tys1 tys2); (fun i -> ise_array2 i (fun ii -> f (push_rec_types recdef1 env) ii CONV) bds1 bds2); (fun i -> snd (ise_stack2 no_app env i f a1 a2))] with | Success i' -> ise_rev_stack2 true i' q1 q2 | UnifFailure _ as x -> fail x else fail (UnifFailure (i,NotSameHead)) | Stack.App _ :: _, Stack.App _ :: _ -> if no_app && deep then fail ((*dummy*)UnifFailure(i,NotSameHead)) else begin match ise_app_rev_stack2 env f i revsk1 revsk2 with |_,(UnifFailure _ as x) -> fail x |(l1, l2), Success i' -> ise_rev_stack2 true i' l1 l2 end |_, _ -> fail (UnifFailure (i,(* Maybe improve: *) NotSameHead)) in ise_rev_stack2 false evd (List.rev sk1) (List.rev sk2) type hook = Environ.env -> Evd.evar_map -> (EConstr.t * Reductionops.Stack.t) -> (EConstr.t * Reductionops.Stack.t) -> (Evd.evar_map * (EConstr.t * EConstr.t) * EConstr.t * EConstr.t list * (EConstr.t list * EConstr.t list) * (EConstr.t list * EConstr.t list) * (Reductionops.Stack.t * Reductionops.Stack.t) * EConstr.constr * (int option * EConstr.constr)) option let all_hooks = ref (CString.Map.empty : hook CString.Map.t) let register_hook ~name ?(override=false) h = if not override && CString.Map.mem name !all_hooks then CErrors.anomaly ~label:"CanonicalSolution.register_hook" Pp.(str "Hook already registered: \"" ++ str name ++ str "\"."); all_hooks := CString.Map.add name h !all_hooks let active_hooks = Summary.ref ~name:"canonical_solution_hooks" ([] : string list) let deactivate_hook ~name = active_hooks := List.filter (fun s -> not (String.equal s name)) !active_hooks let activate_hook ~name = assert (CString.Map.mem name !all_hooks); deactivate_hook ~name; active_hooks := name :: !active_hooks let apply_hooks env sigma proj pat = List.find_map (fun name -> CString.Map.get name !all_hooks env sigma proj pat) !active_hooks (* Make sure that the matching suffix is the all stack *) let rec exact_ise_stack2 env evd f sk1 sk2 = let rec ise_rev_stack2 i revsk1 revsk2 = match revsk1, revsk2 with | [], [] -> Success i | Stack.Case cse1 :: q1, Stack.Case cse2 :: q2 -> let (ci1, u1, pms1, (t1,_), br1) = Stack.expand_case env evd cse1 in let (ci2, u2, pms2, (t2,_), br2) = Stack.expand_case env evd cse2 in let hd1 = mkIndU (ci1.ci_ind, u1) in let hd2 = mkIndU (ci2.ci_ind, u2) in let fctx i (ctx1, t1) (_ctx2, t2) = f (push_rel_context ctx1 env) i CONV t1 t2 in ise_and i [ (fun i -> ise_rev_stack2 i q1 q2); (fun i -> compare_heads CONV env i ~nargs:FullyApplied hd1 hd2); (fun i -> ise_array2 i (fun ii -> f env ii CONV) pms1 pms2); (fun i -> fctx i t1 t2); (fun i -> ise_array2 i fctx br1 br2); ] | Stack.Fix (((li1, i1),(_,tys1,bds1 as recdef1)),a1)::q1, Stack.Fix (((li2, i2),(_,tys2,bds2)),a2)::q2 -> if Int.equal i1 i2 && Array.equal Int.equal li1 li2 then ise_and i [ (fun i -> ise_rev_stack2 i q1 q2); (fun i -> ise_array2 i (fun ii -> f env ii CONV) tys1 tys2); (fun i -> ise_array2 i (fun ii -> f (push_rec_types recdef1 env) ii CONV) bds1 bds2); (fun i -> exact_ise_stack2 env i f a1 a2)] else UnifFailure (i,NotSameHead) | Stack.Proj (p1,_)::q1, Stack.Proj (p2,_)::q2 -> if QProjection.Repr.equal env (Projection.repr p1) (Projection.repr p2) then ise_rev_stack2 i q1 q2 else (UnifFailure (i, NotSameHead)) | Stack.App _ :: _, Stack.App _ :: _ -> begin match ise_app_rev_stack2 env f i revsk1 revsk2 with |_,(UnifFailure _ as x) -> x |(l1, l2), Success i' -> ise_rev_stack2 i' l1 l2 end |_, _ -> UnifFailure (i,(* Maybe improve: *) NotSameHead) in if Reductionops.Stack.compare_shape sk1 sk2 then ise_rev_stack2 evd (List.rev sk1) (List.rev sk2) else UnifFailure (evd, (* Dummy *) NotSameHead) let compare_heads pbty env evd ~nargs term term' = compare_heads pbty env evd ~nargs:(NumArgs nargs) term term' let conv_fun f flags on_types = let typefn env evd pbty term1 term2 = let flags = { (default_flags env) with with_cs = flags.with_cs; allowed_evars = flags.allowed_evars } in f flags env evd pbty term1 term2 in let termfn env evd pbty term1 term2 = f flags env evd pbty term1 term2 in match on_types with | TypeUnification -> typefn | TermUnification -> termfn let infer_conv_noticing_evars ~pb ~ts env sigma t1 t2 = let has_evar = ref false in let evar_expand ev = let v = existential_expand_value0 sigma ev in let () = match v with | CClosure.EvarUndefined _ -> has_evar := true | CClosure.EvarDefined _ -> () in v in let evar_handler = { (Evd.evar_handler sigma) with evar_expand } in let conv pb ~l2r sigma = Conversion.generic_conv pb ~l2r ~evars:evar_handler in match infer_conv_gen conv ~catch_incon:false ~pb ~ts env sigma t1 t2 with | Some sigma -> Some (Success sigma) | None -> if !has_evar then None else Some (UnifFailure (sigma, ConversionFailed (env,t1,t2))) | exception UGraph.UniverseInconsistency e -> if !has_evar then None else Some (UnifFailure (sigma, UnifUnivInconsistency e)) let pr_econstr = ref (fun _ _ _ -> Pp.str "unable to print econstr") (* TODO: move to a proper place *) let rec split_at n acc l = if n = 0 then (List.rev acc, l) else match l with | [] -> (List.rev acc, l) | h :: t -> split_at (n-1) (h :: acc) t let split_at n l = split_at n [] l let try_simplify_proj_construct flags env evd v k sk = match k with (* try unfolding an applied projection on the rhs *) | Proj (p, _, c) -> begin let c = whd_all env evd c in (* reduce argument *) try let (hd, args) = destApp evd c in if isConstruct evd hd then Some (whd_nored_state env evd (args.(Projection.npars p + Projection.arg p), sk)) else None with _ -> None end | Const (cn, _) when Structures.Structure.is_projection cn -> begin match split_at (Structures.Structure.projection_nparams cn) (Option.default [] (Stack.list_of_app_stack sk)) with | (_, []) -> None | (_, c :: _) -> begin let c = whd_all env evd c in try let (hd, _) = destApp evd c in if isConstruct evd hd then Some (whd_betaiota_deltazeta_for_iota_state flags.open_ts env evd (v,sk)) else None with _ -> None end end | _ -> None let rec evar_conv_x flags env evd pbty term1 term2 = let term1 = whd_head_evar evd term1 in let term2 = whd_head_evar evd term2 in (* Maybe convertible but since reducing can erase evars which [evar_apprec] could have found, we do it only if the terms are free of evar. Note: incomplete heuristic... *) let ground_test = if is_ground_term evd term1 && is_ground_term evd term2 then infer_conv_noticing_evars ~pb:pbty ~ts:flags.closed_ts env evd term1 term2 else None in match ground_test with | Some result -> result | None -> (* Until pattern-unification is used consistently, use nohdbeta to not destroy beta-redexes that can be used for 1st-order unification *) let term1 = apprec_nohdbeta flags env evd term1 in let term2 = apprec_nohdbeta flags env evd term2 in let default () = match evar_eqappr_x flags env evd pbty (whd_nored_state env evd (term1,Stack.empty)) (whd_nored_state env evd (term2,Stack.empty)) with | UnifFailure _ as x -> if Retyping.relevance_of_term env evd term1 == Sorts.Irrelevant || Retyping.relevance_of_term env evd term2 == Sorts.Irrelevant then Success evd else x | Success _ as x -> x in begin match EConstr.kind evd term1, EConstr.kind evd term2 with | Evar ev, _ when Evd.is_undefined evd (fst ev) && is_evar_allowed flags (fst ev) -> (match solve_simple_eqn (conv_fun evar_conv_x) flags env evd (position_problem true pbty,ev,term2) with | UnifFailure (_,(OccurCheck _ | NotClean _)) -> (* Eta-expansion might apply *) (* OccurCheck: eta-expansion could solve ?X = {| foo := ?X.(foo) |} NotClean: pruning in solve_simple_eqn is incomplete wrt Miller patterns *) default () | x -> x) | _, Evar ev when Evd.is_undefined evd (fst ev) && is_evar_allowed flags (fst ev) -> (match solve_simple_eqn (conv_fun evar_conv_x) flags env evd (position_problem false pbty,ev,term1) with | UnifFailure (_, (OccurCheck _ | NotClean _)) -> (* OccurCheck: eta-expansion could solve ?X = {| foo := ?X.(foo) |} NotClean: pruning in solve_simple_eqn is incomplete wrt Miller patterns *) default () | x -> x) | _ -> default () end and evar_eqappr_x ?(rhs_is_already_stuck = false) flags env evd pbty (term1, sk1 as appr1) (term2, sk2 as appr2) = let quick_fail i = (* not costly, loses info *) UnifFailure (i, NotSameHead) in let miller_pfenning l2r fallback ev lF tM evd = match is_unification_pattern_evar env evd ev lF tM with | None -> fallback () | Some l1' -> (* Miller-Pfenning's patterns unification *) let t2 = tM in let t2 = solve_pattern_eqn env evd l1' t2 in solve_simple_eqn (conv_fun evar_conv_x) flags env evd (position_problem l2r pbty,ev,t2) in let consume_stack l2r (termF,skF) (termO,skO) evd = let switch f a b = if l2r then f a b else f b a in let not_only_app = Stack.not_purely_applicative skO in match switch (ise_stack2 not_only_app env evd (evar_conv_x flags)) skF skO with | Some (l,r), Success i' when l2r && (not_only_app || List.is_empty l) -> (* E[?n]=E'[redex] reduces to either l[?n]=r[redex] with case/fix/proj in E' (why?) or ?n=r[redex] *) switch (evar_conv_x flags env i' pbty) (Stack.zip evd (termF,l)) (Stack.zip evd (termO,r)) | Some (r,l), Success i' when not l2r && (not_only_app || List.is_empty l) -> (* E'[redex]=E[?n] reduces to either r[redex]=l[?n] with case/fix/proj in E' (why?) or r[redex]=?n *) switch (evar_conv_x flags env i' pbty) (Stack.zip evd (termF,l)) (Stack.zip evd (termO,r)) | None, Success i' -> switch (evar_conv_x flags env i' pbty) termF termO | _, (UnifFailure _ as x) -> x | Some _, _ -> UnifFailure (evd,NotSameArgSize) in let eta_lambda env evd onleft term (term',sk') = (* Reduces an equation [env |- <(fun na:c1 => c'1)|empty> = ] to [env, na:c1 |- c'1 = sk'[term'] (with some additional reduction) *) let (na,c1,c'1) = destLambda evd term in let env' = push_rel (RelDecl.LocalAssum (na,c1)) env in let out1 = whd_betaiota_deltazeta_for_iota_state flags.open_ts env' evd (c'1, Stack.empty) in let out2 = whd_nored_state env' evd (lift 1 (Stack.zip evd (term', sk')), Stack.append_app [|EConstr.mkRel 1|] Stack.empty) in if onleft then evar_eqappr_x flags env' evd CONV out1 out2 else evar_eqappr_x flags env' evd CONV out2 out1 in let rigids env evd sk term sk' term' = let nargs = Stack.args_size sk in let nargs' = Stack.args_size sk' in if not (Int.equal nargs nargs') then UnifFailure (evd, NotSameArgSize) else ise_and evd [(fun i -> try compare_heads pbty env i ~nargs term term' with UGraph.UniverseInconsistency p -> UnifFailure (i, UnifUnivInconsistency p)); (fun i -> exact_ise_stack2 env i (evar_conv_x flags) sk sk')] in let consume l2r (_, skF as apprF) (_,skM as apprM) i = if not (Stack.is_empty skF && Stack.is_empty skM) then consume_stack l2r apprF apprM i else quick_fail i in let miller l2r ev (termF,skF as apprF) (termM, skM as apprM) i = let switch f a b = if l2r then f a b else f b a in let not_only_app = Stack.not_purely_applicative skM in match Stack.list_of_app_stack skF with | None -> quick_fail evd | Some lF -> let tM = Stack.zip evd apprM in miller_pfenning l2r (fun () -> if not_only_app then (* Postpone the use of an heuristic *) switch (fun x y -> Success (Evarutil.add_unification_pb (pbty,env,x,y) i)) (Stack.zip evd apprF) tM else quick_fail i) ev lF tM i in let flex_maybeflex l2r ev (termF,skF as apprF) (termM, skM as apprM) vM = (* Problem: E[?n[inst]] = E'[redex] Strategy, as far as I understand: 1. if E[]=[]u1..un and ?n[inst] u1..un = E'[redex] is a Miller pattern: solve it now 2a. if E'=E'1[E'2] and E=E'1 unifiable, recursively solve ?n[inst] = E'2[redex] 2b. if E'=E'1[E'2] and E=E1[E2] and E=E'1 unifiable and E' contient app/fix/proj, recursively solve E2[?n[inst]] = E'2[redex] 3. reduce the redex into M and recursively solve E[?n[inst]] =? E'[M] *) let switch f a b = if l2r then f a b else f b a in let delta i = switch (evar_eqappr_x flags env i pbty) apprF (whd_betaiota_deltazeta_for_iota_state flags.open_ts env i (vM,skM)) in let default i = ise_try i [miller l2r ev apprF apprM; consume l2r apprF apprM; delta] in match EConstr.kind evd termM with | Proj (p, _, c) when not (Stack.is_empty skF) -> (* Might be ?X args = p.c args', and we have to eta-expand the primitive projection if |args| >= |args'|+1. *) let nargsF = Stack.args_size skF and nargsM = Stack.args_size skM in begin (* ?X argsF' ~= (p.c ..) argsM' -> ?X ~= (p.c ..), no need to expand *) if nargsF <= nargsM then default evd else let f = try let termM' = Retyping.expand_projection env evd p c [] in let apprM' = whd_betaiota_deltazeta_for_iota_state flags.open_ts env evd (termM',skM) in let delta' i = switch (evar_eqappr_x flags env i pbty) apprF apprM' in fun i -> ise_try i [miller l2r ev apprF apprM'; consume l2r apprF apprM'; delta'] with Retyping.RetypeError _ -> (* Happens thanks to w_unify building ill-typed terms *) default in f evd end | _ -> default evd in let flex_rigid l2r ev (termF, skF as apprF) (termR, skR as apprR) = (* Problem: E[?n[inst]] = E'[M] with M blocking computation (in theory) Strategy, as far as I understand: 1. if E[]=[]u1..un and ?n[inst] u1..un = E'[M] is a Miller pattern: solve it now 2a. if E'=E'1[E'2] and E=E'1 unifiable and E' contient app/fix/proj, recursively solve ?n[inst] = E'2[M] 2b. if E'=E'1[E'2] and E=E1[E2] and E=E'1 unifiable and E' contient app/fix/proj, recursively solve E2[?n[inst]] = E'2[M] 3a. if M a lambda or a constructor: eta-expand and recursively solve 3b. if M a constructor C ..ui..: eta-expand and recursively solve proji[E[?n[inst]]]=ui 4. fail if E purely applicative and ?n occurs rigidly in E'[M] 5. absorb arguments if purely applicative and postpone *) let switch f a b = if l2r then f a b else f b a in let eta evd = match EConstr.kind evd termR with | Lambda _ when (* if ever problem is ill-typed: *) List.is_empty skR -> eta_lambda env evd false termR apprF | Construct u -> eta_constructor flags env evd u skR apprF | _ -> UnifFailure (evd,NotSameHead) in match Stack.list_of_app_stack skF with | None -> ise_try evd [consume_stack l2r apprF apprR; eta] | Some lF -> let tR = Stack.zip evd apprR in miller_pfenning l2r (fun () -> ise_try evd [eta;(* Postpone the use of an heuristic *) (fun i -> if not (occur_rigidly flags env i ev tR) then let i,tF = if isRel i tR || isVar i tR then (* Optimization so as to generate candidates *) let i,ev = evar_absorb_arguments env i ev lF in i,mkEvar ev else i,Stack.zip evd apprF in switch (fun x y -> Success (Evarutil.add_unification_pb (pbty,env,x,y) i)) tF tR else UnifFailure (evd,OccurCheck (fst ev,tR)))]) ev lF tR evd in let first_order env i t1 t2 sk1 sk2 = (* Try first-order unification *) match ise_stack2 false env i (evar_conv_x flags) sk1 sk2 with | None, Success i' -> (* We do have sk1[] = sk2[]: we now unify ?ev1 and ?ev2 *) (* Note that ?ev1 and ?ev2, may have been instantiated in the meantime *) let ev1' = whd_evar i' t1 in if isEvar i' ev1' then solve_simple_eqn (conv_fun evar_conv_x) flags env i' (position_problem true pbty,destEvar i' ev1',term2) else (* HH: Why not to drop sk1 and sk2 since they unified *) evar_eqappr_x flags env evd pbty (ev1', sk1) (term2, sk2) | Some (r,[]), Success i' -> (* We have sk1'[] = sk2[] for some sk1' s.t. sk1[]=sk1'[r[]] *) (* we now unify r[?ev1] and ?ev2 *) let ev2' = whd_evar i' t2 in if isEvar i' ev2' then solve_simple_eqn (conv_fun evar_conv_x) flags env i' (position_problem false pbty,destEvar i' ev2',Stack.zip i' (term1,r)) else evar_eqappr_x flags env evd pbty (ev2', sk1) (term2, sk2) | Some ([],r), Success i' -> (* Symmetrically *) (* We have sk1[] = sk2'[] for some sk2' s.t. sk2[]=sk2'[r[]] *) (* we now unify ?ev1 and r[?ev2] *) let ev1' = whd_evar i' t1 in if isEvar i' ev1' then solve_simple_eqn (conv_fun evar_conv_x) flags env i' (position_problem true pbty,destEvar i' ev1',Stack.zip i' (term2,r)) else (* HH: Why not to drop sk1 and sk2 since they unified *) evar_eqappr_x flags env evd pbty (ev1', sk1) (term2, sk2) | None, (UnifFailure _ as x) -> (* sk1 and sk2 have no common outer part *) if Stack.not_purely_applicative sk2 then (* Ad hoc compatibility with 8.4 which treated non-app as rigid *) flex_rigid true (destEvar evd t1) appr1 appr2 else if Stack.not_purely_applicative sk1 then (* Ad hoc compatibility with 8.4 which treated non-app as rigid *) flex_rigid false (destEvar evd t2) appr2 appr1 else (* We could instead try Miller unification, then postpone to see if other equations help, as in: [Check fun a b : unit => (eqáµ£efl : _ a = _ a b)] *) x | Some _, Success _ -> (* sk1 and sk2 have a common outer part *) if Stack.not_purely_applicative sk2 then (* Ad hoc compatibility with 8.4 which treated non-app as rigid *) flex_rigid true (destEvar evd t1) appr1 appr2 else if Stack.not_purely_applicative sk1 then (* Ad hoc compatibility with 8.4 which treated non-app as rigid *) flex_rigid false (destEvar evd t2) appr2 appr1 else (* We could instead try Miller unification, then postpone to see if other equations help, as in: [Check fun a b c : unit => (eq_refl : _ a b = _ c a b)] *) UnifFailure (i,NotSameArgSize) | _, _ -> anomaly (Pp.str "Unexpected result from ise_stack2.") in let app_empty = match sk1, sk2 with [], [] -> true | _ -> false in (* Evar must be undefined since we have flushed evars *) let () = debug_unification (fun () -> Pp.(v 0 (pr_state env evd appr1 ++ cut () ++ pr_state env evd appr2 ++ cut ()))) in match (flex_kind_of_term flags env evd term1 sk1, flex_kind_of_term flags env evd term2 sk2) with | Flexible (sp1,al1), Flexible (sp2,al2) -> (* Notations: - "sk" is a stack (or, more abstractly, an evaluation context, written E) - "ev" is an evar "?ev", more precisely an evar ?n with an instance inst - "al" is an evar instance Problem: Eâ‚[?nâ‚[instâ‚]] = Eâ‚‚[?nâ‚‚[instâ‚‚]] (i.e. sk1[?ev1] =? sk2[?ev2] Strategy is first-order unification 1a. if Eâ‚=Eâ‚‚ unifiable, solve ?nâ‚[instâ‚] = ?nâ‚‚[instâ‚‚] 1b. if Eâ‚‚=Eâ‚‚'[Eâ‚‚''] and Eâ‚=Eâ‚‚' unifiable, recursively solve ?nâ‚[instâ‚] = Eâ‚‚''[?nâ‚‚[instâ‚‚]] 1b'. if Eâ‚=Eâ‚'[Eâ‚''] and Eâ‚'=Eâ‚‚ unifiable, recursively solve Eâ‚''[?nâ‚[instâ‚]] = ?nâ‚‚[instâ‚‚] recursively solve E2[?n[inst]] = E'2[redex] 2. fails if neither Eâ‚ nor Eâ‚‚ is a prefix of the other *) let f1 i = first_order env i term1 term2 sk1 sk2 and f2 i = if Evar.equal sp1 sp2 then match ise_stack2 false env i (evar_conv_x flags) sk1 sk2 with |None, Success i' -> Success (solve_refl (fun flags p env i pbty a1 a2 -> let flags = match p with | TypeUnification -> default_flags env | TermUnification -> flags in is_success (evar_conv_x flags env i pbty a1 a2)) flags env i' (position_problem true pbty) sp1 al1 al2) |_, (UnifFailure _ as x) -> x |Some _, _ -> UnifFailure (i,NotSameArgSize) else UnifFailure (i,NotSameHead) and f3 i = miller true (sp1,al1) appr1 appr2 i and f4 i = miller false (sp2,al2) appr2 appr1 i and f5 i = (* We ensure failure of consuming the stacks does not propagate an error about unification of the stacks while the heads themselves cannot be unified, so we return NotSameHead. *) match consume true appr1 appr2 i with | Success _ as x -> x | UnifFailure _ -> quick_fail i in ise_try evd [f1; f2; f3; f4; f5] | Flexible ev1, MaybeFlexible v2 -> flex_maybeflex true ev1 appr1 appr2 v2 | MaybeFlexible v1, Flexible ev2 -> flex_maybeflex false ev2 appr2 appr1 v1 | MaybeFlexible v1, MaybeFlexible v2 -> begin let k1 = EConstr.kind evd term1 in let k2 = EConstr.kind evd term2 in begin match k1, k2 with | LetIn (na1,b1,t1,c'1), LetIn (na2,b2,t2,c'2) -> let f1 i = (* FO *) ise_and i [(fun i -> ise_try i [(fun i -> evar_conv_x flags env i CUMUL t1 t2); (fun i -> evar_conv_x flags env i CUMUL t2 t1)]); (fun i -> evar_conv_x flags env i CONV b1 b2); (fun i -> let b = nf_evar i b1 in let t = nf_evar i t1 in let na = Nameops.Name.pick_annot na1 na2 in evar_conv_x flags (push_rel (RelDecl.LocalDef (na,b,t)) env) i pbty c'1 c'2); (fun i -> exact_ise_stack2 env i (evar_conv_x flags) sk1 sk2)] and f2 i = let out1 = whd_betaiota_deltazeta_for_iota_state flags.open_ts env i (v1,sk1) and out2 = whd_betaiota_deltazeta_for_iota_state flags.open_ts env i (v2,sk2) in evar_eqappr_x flags env i pbty out1 out2 in ise_try evd [f1; f2] | Proj (p, _, c), Proj (p', _, c') when QProjection.Repr.equal env (Projection.repr p) (Projection.repr p') -> let f1 i = ise_and i [(fun i -> evar_conv_x flags env i CONV c c'); (fun i -> exact_ise_stack2 env i (evar_conv_x flags) sk1 sk2)] and f2 i = let out1 = whd_betaiota_deltazeta_for_iota_state flags.open_ts env i (v1,sk1) and out2 = whd_betaiota_deltazeta_for_iota_state flags.open_ts env i (v2,sk2) in evar_eqappr_x flags env i pbty out1 out2 in ise_try evd [f1; f2] (* Catch the p.c ~= p c' cases *) | Proj (p,_,c), Const (p',u) when QConstant.equal env (Projection.constant p) p' -> let res = try Some (destApp evd (Retyping.expand_projection env evd p c [])) with Retyping.RetypeError _ -> None in (match res with | Some (f1,args1) -> evar_eqappr_x flags env evd pbty (f1,Stack.append_app args1 sk1) appr2 | None -> UnifFailure (evd,NotSameHead)) | Const (p,u), Proj (p',_,c') when QConstant.equal env p (Projection.constant p') -> let res = try Some (destApp evd (Retyping.expand_projection env evd p' c' [])) with Retyping.RetypeError _ -> None in (match res with | Some (f2,args2) -> evar_eqappr_x flags env evd pbty appr1 (f2,Stack.append_app args2 sk2) | None -> UnifFailure (evd,NotSameHead)) | _, _ -> let f1 i = (* Gather the universe constraints that would make term1 and term2 equal. If these only involve unifications of flexible universes to other universes, allow this identification (first-order unification of universes). Otherwise fallback to unfolding. *) let univs = EConstr.eq_constr_universes env evd term1 term2 in match univs with | Some univs -> ise_and i [(fun i -> try Success (Evd.add_universe_constraints i univs) with UniversesDiffer -> UnifFailure (i,NotSameHead) | UGraph.UniverseInconsistency p -> UnifFailure (i, UnifUnivInconsistency p)); (fun i -> exact_ise_stack2 env i (evar_conv_x flags) sk1 sk2)] | None -> UnifFailure (i,NotSameHead) and f2 i = (match try_simplify_proj_construct flags env evd v1 k1 sk1, try_simplify_proj_construct flags env evd v2 k2 sk2 with | Some x1, Some x2 -> UnifFailure (i,NoCanonicalStructure) | Some x1, None -> UnifFailure (i,NoCanonicalStructure) | None, Some x2 -> UnifFailure (i,NoCanonicalStructure) | _, _ -> (try if not flags.with_cs then raise Not_found else conv_record flags env (try check_conv_record env i appr1 appr2 with Not_found -> begin match (apply_hooks env i appr1 appr2) with | Some r -> r | None -> begin try check_conv_record env i appr2 appr1 with Not_found -> begin match (apply_hooks env i appr2 appr1) with | Some r -> r | None -> raise Not_found end end end) with Not_found -> UnifFailure (i,NoCanonicalStructure))) and f3 i = (* heuristic: unfold second argument first, exception made if the first argument is a beta-redex (expand a constant only if necessary) or the second argument is potentially usable as a canonical projection or canonical value *) let rec is_unnamed (hd, args) = match EConstr.kind i hd with | (Var _|Construct _|Ind _|Const _|Prod _|Sort _|Int _ |Float _|Array _) -> Stack.not_purely_applicative args | (CoFix _|Meta _|Rel _)-> true | Evar _ -> Stack.not_purely_applicative args (* false (* immediate solution without Canon Struct *)*) | Lambda _ -> assert (match args with [] -> true | _ -> false); true | LetIn (_,b,_,c) -> is_unnamed (whd_betaiota_deltazeta_for_iota_state flags.open_ts env i (subst1 b c, args)) | Fix _ -> true (* Partially applied fix can be the result of a whd call *) | Proj (p, _, _) -> Projection.unfolded p || Stack.not_purely_applicative args | Case _ | App _| Cast _ -> assert false in let rhs_is_stuck_and_unnamed () = let applicative_stack = fst (Stack.strip_app sk2) in is_unnamed (whd_betaiota_deltazeta_for_iota_state flags.open_ts env i (v2, applicative_stack)) in let rhs_is_already_stuck = rhs_is_already_stuck || rhs_is_stuck_and_unnamed () in if (EConstr.isLambda i term1 || rhs_is_already_stuck) && (not (Stack.not_purely_applicative sk1)) then evar_eqappr_x ~rhs_is_already_stuck flags env i pbty (whd_betaiota_deltazeta_for_iota_state flags.open_ts env i(v1,sk1)) appr2 else evar_eqappr_x flags env i pbty appr1 (whd_betaiota_deltazeta_for_iota_state flags.open_ts env i (v2,sk2)) in ise_try evd [f1; f2; f3] end end | Rigid, Rigid when EConstr.isLambda evd term1 && EConstr.isLambda evd term2 -> let (na1,c1,c'1) = EConstr.destLambda evd term1 in let (na2,c2,c'2) = EConstr.destLambda evd term2 in ise_and evd [(fun i -> evar_conv_x flags env i CONV c1 c2); (fun i -> let c = nf_evar i c1 in let na = Nameops.Name.pick_annot na1 na2 in evar_conv_x flags (push_rel (RelDecl.LocalAssum (na,c)) env) i CONV c'1 c'2); (* When in modulo_betaiota = false case, lambda's are not reduced *) (fun i -> exact_ise_stack2 env i (evar_conv_x flags) sk1 sk2)] | Flexible ev1, Rigid -> flex_rigid true ev1 appr1 appr2 | Rigid, Flexible ev2 -> flex_rigid false ev2 appr2 appr1 | MaybeFlexible v1, Rigid -> let k1 = EConstr.kind evd term1 in begin let () = debug_unification (fun () -> Pp.(v 0 (str "v1 maybeflexible against rigid" ++ !pr_econstr env evd v1 ++ cut ()))) in match try_simplify_proj_construct flags env evd v1 k1 sk1 with | Some x1 -> evar_eqappr_x flags env evd pbty x1 appr2 | None -> let f3 i = (try if not flags.with_cs then raise Not_found else conv_record flags env ( try check_conv_record env i appr1 appr2 with | Not_found -> begin match apply_hooks env i appr1 appr2 with | Some r -> r | None -> raise Not_found end) with Not_found -> UnifFailure (i,NoCanonicalStructure)) and f4 i = evar_eqappr_x flags env i pbty (whd_betaiota_deltazeta_for_iota_state flags.open_ts env i (v1,sk1)) appr2 in ise_try evd [f3; f4] end | Rigid, MaybeFlexible v2 -> let k2 = EConstr.kind evd term2 in begin let () = debug_unification (fun () -> Pp.(v 0 (str "rigid against v2 maybeflexible" ++ !pr_econstr env evd v2 ++ cut ()))) in match try_simplify_proj_construct flags env evd v2 k2 sk2 with | Some x2 -> let () = debug_unification (fun () -> Pp.(v 0 (str "reduced to" ++ !pr_econstr env evd (let (x, _) = x2 in x)))) in evar_eqappr_x flags env evd pbty appr1 x2 | None -> let f3 i = (try if not flags.with_cs then raise Not_found else conv_record flags env ( try check_conv_record env i appr2 appr1 with | Not_found -> begin let () = debug_unification (fun () -> Pp.(v 0 (str "ask cs hook"))) in match apply_hooks env i appr2 appr1 with | Some r -> r | None -> raise Not_found end | e -> let () = Feedback.msg_info Pp.(str "cs hook crashed") in failwith "argh") with Not_found -> UnifFailure (i,NoCanonicalStructure)) and f4 i = evar_eqappr_x flags env i pbty appr1 (whd_betaiota_deltazeta_for_iota_state flags.open_ts env i (v2,sk2)) in ise_try evd [f3; f4] end (* Eta-expansion *) | Rigid, _ when isLambda evd term1 && (* if ever ill-typed: *) List.is_empty sk1 -> eta_lambda env evd true term1 (term2,sk2) | _, Rigid when isLambda evd term2 && (* if ever ill-typed: *) List.is_empty sk2 -> eta_lambda env evd false term2 (term1,sk1) | Rigid, Rigid -> begin match EConstr.kind evd term1, EConstr.kind evd term2 with | Sort s1, Sort s2 when app_empty -> (try let evd' = if pbty == CONV then Evd.set_eq_sort env evd s1 s2 else Evd.set_leq_sort env evd s1 s2 in Success evd' with UGraph.UniverseInconsistency p -> UnifFailure (evd,UnifUnivInconsistency p) | e when CErrors.noncritical e -> UnifFailure (evd,NotSameHead)) | Prod (n1,c1,c'1), Prod (n2,c2,c'2) when app_empty -> ise_and evd [(fun i -> evar_conv_x flags env i CONV c1 c2); (fun i -> let c = nf_evar i c1 in let na = Nameops.Name.pick_annot n1 n2 in evar_conv_x flags (push_rel (RelDecl.LocalAssum (na,c)) env) i pbty c'1 c'2)] | Rel x1, Rel x2 -> if Int.equal x1 x2 then exact_ise_stack2 env evd (evar_conv_x flags) sk1 sk2 else UnifFailure (evd,NotSameHead) | Var var1, Var var2 -> if Id.equal var1 var2 then exact_ise_stack2 env evd (evar_conv_x flags) sk1 sk2 else UnifFailure (evd,NotSameHead) | Const _, Const _ | Ind _, Ind _ | Construct _, Construct _ | Int _, Int _ | Float _, Float _ | Array _, Array _ -> rigids env evd sk1 term1 sk2 term2 | Evar (sp1,al1), Evar (sp2,al2) -> (* Frozen evars *) if Evar.equal sp1 sp2 then match ise_stack2 false env evd (evar_conv_x flags) sk1 sk2 with |None, Success i' -> let al1 = Evd.expand_existential i' (sp1, al1) in let al2 = Evd.expand_existential i' (sp2, al2) in ise_inst2 i' (fun i' -> evar_conv_x flags env i' CONV) al1 al2 |_, (UnifFailure _ as x) -> x |Some _, _ -> UnifFailure (evd,NotSameArgSize) else UnifFailure (evd,NotSameHead) | Construct u, _ -> eta_constructor flags env evd u sk1 (term2,sk2) | _, Construct u -> eta_constructor flags env evd u sk2 (term1,sk1) | Fix ((li1, i1),(_,tys1,bds1 as recdef1)), Fix ((li2, i2),(_,tys2,bds2)) -> (* Partially applied fixs *) if Int.equal i1 i2 && Array.equal Int.equal li1 li2 then ise_and evd [ (fun i -> ise_array2 i (fun i' -> evar_conv_x flags env i' CONV) tys1 tys2); (fun i -> ise_array2 i (fun i' -> evar_conv_x flags (push_rec_types recdef1 env) i' CONV) bds1 bds2); (fun i -> exact_ise_stack2 env i (evar_conv_x flags) sk1 sk2)] else UnifFailure (evd, NotSameHead) | CoFix (i1,(_,tys1,bds1 as recdef1)), CoFix (i2,(_,tys2,bds2)) -> if Int.equal i1 i2 then ise_and evd [(fun i -> ise_array2 i (fun i -> evar_conv_x flags env i CONV) tys1 tys2); (fun i -> ise_array2 i (fun i -> evar_conv_x flags (push_rec_types recdef1 env) i CONV) bds1 bds2); (fun i -> exact_ise_stack2 env i (evar_conv_x flags) sk1 sk2)] else UnifFailure (evd,NotSameHead) | (Meta _, _) | (_, Meta _) -> begin match ise_stack2 true env evd (evar_conv_x flags) sk1 sk2 with |_, (UnifFailure _ as x) -> x |None, Success i' -> evar_conv_x flags env i' CONV term1 term2 |Some (sk1',sk2'), Success i' -> evar_conv_x flags env i' CONV (Stack.zip i' (term1,sk1')) (Stack.zip i' (term2,sk2')) end | Proj (p1,_,c1), Proj(p2,_,c2) when QProjection.Repr.equal env (Projection.repr p1) (Projection.repr p2) -> begin match ise_stack2 true env evd (evar_conv_x flags) sk1 sk2 with |_, (UnifFailure _ as x) -> x |None, Success i' -> evar_conv_x flags env i' CONV c1 c2 |Some _, Success _ -> UnifFailure (evd,NotSameHead) end (* Catch the c.(p) ~= p c' cases *) | Proj (p1,_,c1), Const (p2,_) when QConstant.equal env (Projection.constant p1) p2 -> let c1 = try Some (destApp evd (Retyping.expand_projection env evd p1 c1 [])) with Retyping.RetypeError _ -> None in begin match c1 with | Some (c1,new_args) -> rigids env evd (Stack.append_app new_args sk1) c1 sk2 term2 | None -> UnifFailure (evd,NotSameHead) end | Const (p1,_), Proj (p2,_,c2) when QConstant.equal env p1 (Projection.constant p2) -> let c2 = try Some (destApp evd (Retyping.expand_projection env evd p2 c2 [])) with Retyping.RetypeError _ -> None in begin match c2 with | Some (c2,new_args) -> rigids env evd sk1 term1 (Stack.append_app new_args sk2) c2 | None -> UnifFailure (evd,NotSameHead) end | (Ind _ | Sort _ | Prod _ | CoFix _ | Fix _ | Rel _ | Var _ | Const _ | Int _ | Float _ | Array _ | Evar _ | Lambda _), _ -> UnifFailure (evd,NotSameHead) | _, (Ind _ | Sort _ | Prod _ | CoFix _ | Fix _ | Rel _ | Var _ | Const _ | Int _ | Array _ | Evar _ | Lambda _) -> UnifFailure (evd,NotSameHead) | Case _, _ -> UnifFailure (evd,NotSameHead) | Proj _, _ -> UnifFailure (evd,NotSameHead) | (App _ | Cast _), _ -> assert false | LetIn _, _ -> assert false end and conv_record flags env (evd,(h,h2),c,bs,(params,params1),(us,us2),(sk1,sk2),c1,(n,t2)) = (* Tries to unify the states (proji params1 c1 | sk1) = (proji params2 (c (?xs:bs)) | sk2) and the terms h us = h2 us2 where c = the constant for the canonical structure (i.e. some term of the form fun (xs:bs) => Build_R params v1 .. vi-1 (h us) vi+1 .. vn) bs = the types of the parameters of the canonical structure c1 = the main argument of the canonical projection sk1, sk2 = the surrounding stacks of the conversion problem params1, params2 = the params of the projection (empty if a primitive proj) knowing that (proji params1 c1 | sk1) = (h2 us2 | sk2) had to be initially resolved *) if Reductionops.Stack.compare_shape sk1 sk2 then let (evd',ks,_,test) = List.fold_left (fun (i,ks,m,test) b -> if match n with Some n -> Int.equal m n | None -> false then let ty = Retyping.get_type_of env i t2 in let test i = evar_conv_x flags env i CUMUL ty (substl ks b) in (i,t2::ks, m-1, test) else let dloc = Loc.tag Evar_kinds.InternalHole in let (i', ev) = Evarutil.new_evar env i ~src:dloc (substl ks b) in (i', ev :: ks, m - 1,test)) (evd,[],List.length bs,fun i -> Success i) bs in let app = mkApp (c, Array.rev_of_list ks) in ise_and evd' [(fun i -> ise_list2 i (fun i' x1 x -> evar_conv_x flags env i' CONV x1 (substl ks x)) params1 params); (fun i -> ise_list2 i (fun i' u1 u -> evar_conv_x flags env i' CONV u1 (substl ks u)) us2 us); (fun i -> evar_conv_x flags env i CONV c1 app); (fun i -> exact_ise_stack2 env i (evar_conv_x flags) sk1 sk2); test; (fun i -> evar_conv_x flags env i CONV h2 (fst (decompose_app i (substl ks h))))] else UnifFailure(evd,(*dummy*)NotSameHead) and eta_constructor flags env evd ((ind, i), u) sk1 (term2,sk2) = (* reduces an equation == to the equations [arg_i = Proj_i (sk2[term2])] where [sk1] is [params args] *) let open Declarations in let mib = lookup_mind (fst ind) env in match get_projections env ind with | Some projs when mib.mind_finite == BiFinite -> let pars = mib.mind_nparams in begin match Stack.list_of_app_stack sk1 with | None -> UnifFailure (evd,NotSameHead) | Some l1 -> (try let l1' = List.skipn pars l1 in let l2' = let term = Stack.zip evd (term2,sk2) in List.map (fun (p,r) -> let r = UVars.subst_instance_relevance (Unsafe.to_instance u) r in EConstr.mkProj (Projection.make p false, r, term)) (Array.to_list projs) in let f i t1 t2 = evar_conv_x { flags with with_cs = false } env i CONV t1 t2 in ise_list2 evd f l1' l2' with | Failure _ -> (* List.skipn: partially applied constructor *) UnifFailure(evd,NotSameHead)) end | _ -> UnifFailure (evd,NotSameHead) let evar_conv_x flags = evar_conv_x flags let evar_unify = conv_fun evar_conv_x let evar_conv_hook = ref evar_conv_x let evar_conv_x flags = !evar_conv_hook flags let set_evar_conv f = evar_conv_hook := f (* We assume here |l1| <= |l2| *) let first_order_unification flags env evd (ev1,l1) (term2,l2) = let (deb2,rest2) = Array.chop (Array.length l2-Array.length l1) l2 in ise_and evd (* First compare extra args for better failure message *) [(fun i -> ise_array2 i (fun i -> evar_conv_x flags env i CONV) rest2 l1); (fun i -> (* Then instantiate evar unless already done by unifying args *) let t2 = mkApp(term2,deb2) in if is_defined i (fst ev1) then evar_conv_x flags env i CONV t2 (mkEvar ev1) else solve_simple_eqn ~choose:true ~imitate_defs:false evar_unify flags env i (None,ev1,t2))] let choose_less_dependent_instance evd term (evk, args) = let evi = Evd.find_undefined evd evk in let rec get_subst accu decls args = match decls, SList.view args with | [], Some _ | _ :: _, None -> assert false | [], None -> accu | decl :: decls, Some (arg, args) -> let accu = get_subst accu decls args in let arg = match arg with None -> mkVar (NamedDecl.get_id decl) | Some a -> a in if EConstr.eq_constr evd arg term then NamedDecl.get_id decl :: accu else accu in let subst = get_subst [] (evar_filtered_context evi) args in match subst with | [] -> None | id :: _ -> Some (Evd.define evk (mkVar id) evd) type occurrence_match_test = env -> evar_map -> constr -> constr -> bool * evar_map type occurrence_selection = | AtOccurrences of Locus.occurrences | Unspecified of Abstraction.abstraction type occurrences_selection = occurrence_match_test * occurrence_selection list let default_occurrence_selection = Unspecified Abstraction.Imitate let default_occurrence_test ~allowed_evars ts env sigma c pat = let flags = { (default_flags_of ~subterm_ts:ts ts) with allowed_evars } in match evar_conv_x flags env sigma CONV c pat with | Success sigma -> true, sigma | UnifFailure _ -> false, sigma let default_occurrences_selection ?(allowed_evars=AllowedEvars.all) ts n = (default_occurrence_test ~allowed_evars ts, List.init n (fun _ -> default_occurrence_selection)) let occur_evars sigma evs c = if Evar.Set.is_empty evs then false else let rec occur_rec c = match EConstr.kind sigma c with | Evar (sp, args) -> if Evar.Set.mem sp evs then raise Occur else SList.Skip.iter occur_rec args | _ -> EConstr.iter sigma occur_rec c in try occur_rec c; false with Occur -> true let apply_on_subterm env evd fixed f test c t = let prc env evd = Termops.Internal.print_constr_env env evd in let evdref = ref evd in let fixedref = ref fixed in let rec applyrec (env,(k,c) as acc) t = if occur_evars !evdref !fixedref t then match EConstr.kind !evdref t with | Evar (evk, args) -> if Evar.Set.mem evk !fixedref then t else let args = Evd.expand_existential !evdref (evk, args) in let args = List.Smart.map (applyrec acc) args in EConstr.mkLEvar !evdref (evk, args) | _ -> map_constr_with_binders_left_to_right env !evdref (fun d (env,(k,c)) -> (push_rel d env, (k+1,lift 1 c))) applyrec acc t else (debug_ho_unification (fun () -> Pp.(str"Testing " ++ prc env !evdref c ++ str" against " ++ prc env !evdref t)); let b, evd = try test env !evdref c t with e when CErrors.noncritical e -> assert false in if b then (debug_ho_unification (fun () -> Pp.str "succeeded"); let evd', fixed, t' = f !evdref !fixedref k t in fixedref := fixed; evdref := evd'; t') else ( debug_ho_unification (fun () -> Pp.str "failed"); map_constr_with_binders_left_to_right env !evdref (fun d (env,(k,c)) -> (push_rel d env, (k+1,lift 1 c))) applyrec acc t)) in let t' = applyrec (env,(0,c)) t in !evdref, !fixedref, t' let filter_possible_projections evd c ty ctxt args = (* Since args in the types will be replaced by holes, we count the fv of args to have a well-typed filter; don't know how necessary it is however to have a well-typed filter here *) let args = Array.of_list args in let fv1 = free_rels evd (mkApp (c,args)) (* Hack: locally untyped *) in let fv2 = collect_vars evd (mkApp (c,args)) in let len = Array.length args in let tyvars = collect_vars evd ty in List.map_i (fun i decl -> let () = assert (i < len) in let a = Array.unsafe_get args i in (match decl with | NamedDecl.LocalAssum _ -> false | NamedDecl.LocalDef (_,c,_) -> not (isRel evd c || isVar evd c)) || a == c || (* Here we make an approximation, for instance, we could also be *) (* interested in finding a term u convertible to c such that a occurs *) (* in u *) isRel evd a && Int.Set.mem (destRel evd a) fv1 || isVar evd a && Id.Set.mem (destVar evd a) fv2 || Id.Set.mem (NamedDecl.get_id decl) tyvars) 0 ctxt let solve_evars = ref (fun _ -> failwith "solve_evars not installed") let set_solve_evars f = solve_evars := f (* We solve the problem env_rhs |- ?e[u1..un] = rhs knowing * x1:T1 .. xn:Tn |- ev : ty * by looking for a maximal well-typed abtraction over u1..un in rhs * * We first build C[e11..e1p1,..,en1..enpn] obtained from rhs by replacing * all occurrences of u1..un by evars eij of type Ti' where itself Ti' has * been obtained from the type of ui by also replacing all occurrences of * u1..ui-1 by evars. * * Then, we use typing to infer the relations between the different * occurrences. If some occurrence is still unconstrained after typing, * we instantiate successively the unresolved occurrences of un by xn, * of un-1 by xn-1, etc [the idea comes from Chung-Kil Hur, that he * used for his Heq plugin; extensions to several arguments based on a * proposition from Dan Grayson] *) let check_selected_occs env sigma c occ occs = let notfound = match occs with | AtOccurrences occs -> (match occs with | Locus.AtLeastOneOccurrence -> occ == 1 | Locus.AllOccurrences -> false | Locus.AllOccurrencesBut l -> List.last l > occ | Locus.OnlyOccurrences l -> List.last l > occ | Locus.NoOccurrences -> false) | Unspecified abstract -> false in if notfound then raise (PretypeError (env,sigma,NoOccurrenceFound (c,None))) else () (* Error local to the module *) exception TypingFailed of evar_map let set_of_evctx l = List.fold_left (fun s decl -> Id.Set.add (NamedDecl.get_id decl) s) Id.Set.empty l (** Weaken the existentials so that they can be typed in sign and raise an error if the term otherwise mentions variables not bound in sign. *) let thin_evars env sigma sign c = let sigma = ref sigma in let ctx = set_of_evctx sign in let rec applyrec (env,acc) t = match kind !sigma t with | Evar (ev, args) -> let evi = Evd.find_undefined !sigma ev in let args = Evd.expand_existential !sigma (ev, args) in let filter = List.map (fun c -> Id.Set.subset (collect_vars !sigma c) ctx) args in let filter = Filter.make filter in let candidates = evar_candidates evi in let evd, ev = restrict_evar !sigma ev filter candidates in sigma := evd; whd_evar !sigma t | Var id -> if not (Id.Set.mem id ctx) then raise (TypingFailed !sigma) else t | _ -> map_constr_with_binders_left_to_right env !sigma (fun d (env,acc) -> (push_rel d env, acc+1)) applyrec (env,acc) t in let c' = applyrec (env,0) c in (!sigma, c') let second_order_matching flags env_rhs evd (evk,args) (test,argoccs) rhs = try let evi = Evd.find_undefined evd evk in let evi = nf_evar_info evd evi in let env_evar_unf = evar_env env_rhs evi in let env_evar = evar_filtered_env env_rhs evi in let sign = named_context_val env_evar in let ctxt = evar_filtered_context evi in debug_ho_unification (fun () -> Pp.(str"env rhs: " ++ Termops.Internal.print_env env_rhs ++ fnl () ++ str"env evars: " ++ Termops.Internal.print_env env_evar)); let args = Evd.expand_existential evd (evk, args) in let args = List.map (nf_evar evd) args in let argsubst = List.map2 (fun decl c -> (NamedDecl.get_id decl, c)) ctxt args in let rhs = nf_evar evd rhs in if not (noccur_evar env_rhs evd evk rhs) then raise (TypingFailed evd); (* Ensure that any progress made by Typing.e_solve_evars will not contradict the solution we are trying to build here by adding the problem as a constraint. *) let evd = Evarutil.add_unification_pb (CONV,env_rhs,mkLEvar evd (evk, args),rhs) evd in let prc env evd c = Termops.Internal.print_constr_env env evd c in let rec make_subst = function | decl'::ctxt', c::l, occs::occsl when isVarId evd (NamedDecl.get_id decl') c -> begin match occs with | AtOccurrences loc when not (Locusops.is_all_occurrences loc) -> user_err Pp.(str "Cannot force abstraction on identity instance.") | _ -> make_subst (ctxt',l,occsl) end | decl'::ctxt', c::l, occs::occsl -> let id = NamedDecl.get_annot decl' in let t = NamedDecl.get_type decl' in let evs = ref [] in let c = nf_evar evd c in (* ty is in env_rhs now *) let ty = replace_vars evd argsubst t in let filter' = filter_possible_projections evd c (nf_evar evd ty) ctxt args in (id,t,c,ty,evs,Filter.make filter',occs) :: make_subst (ctxt',l,occsl) | _, _, [] -> [] | _ -> anomaly (Pp.str "Signature or instance are shorter than the occurrences list.") in let rec set_holes env_rhs evd fixed rhs = function | (id,idty,c,cty,evsref,filter,occs)::subst -> let c = nf_evar evd c in debug_ho_unification (fun () -> Pp.(str"set holes for: " ++ prc env_rhs evd (mkVar id.binder_name) ++ spc () ++ prc env_rhs evd c ++ str" in " ++ prc env_rhs evd rhs)); let occ = ref 1 in let set_var evd fixed k inst = let oc = !occ in debug_ho_unification (fun () -> Pp.(str"Found one occurrence" ++ fnl () ++ str"cty: " ++ prc env_rhs evd c)); incr occ; match occs with | AtOccurrences occs -> if Locusops.is_selected oc occs then evd, fixed, mkVar id.binder_name else evd, fixed, inst | Unspecified prefer_abstraction -> let evd, fixed, evty = set_holes env_rhs evd fixed cty subst in let evty = nf_evar evd evty in debug_ho_unification (fun () -> Pp.(str"abstracting one occurrence " ++ prc env_rhs evd inst ++ str" of type: " ++ prc env_evar evd evty ++ str " for " ++ prc env_rhs evd c)); (* Allow any type lower than the variable's type as the abstracted subterm might have a smaller type, which could be crucial to make the surrounding context typecheck. *) let evd, evty = if isArity evd evty then refresh_universes ~status:Evd.univ_flexible (Some true) env_evar_unf evd evty else evd, evty in let (evd, evk) = new_pure_evar sign evd evty ~filter in let EvarInfo evi = Evd.find evd evk in let instance = Evd.evar_identity_subst evi in let fixed = Evar.Set.add evk fixed in evsref := (evk,evty,inst,prefer_abstraction)::!evsref; evd, fixed, mkEvar (evk, instance) in let evd, fixed, rhs' = apply_on_subterm env_rhs evd fixed set_var test c rhs in debug_ho_unification (fun () -> Pp.(str"abstracted: " ++ prc env_rhs evd rhs')); let () = check_selected_occs env_rhs evd c !occ occs in let env_rhs' = push_named (NamedDecl.LocalAssum (id,idty)) env_rhs in set_holes env_rhs' evd fixed rhs' subst | [] -> evd, fixed, rhs in let subst = make_subst (ctxt,args,argoccs) in let evd, _, rhs' = set_holes env_rhs evd Evar.Set.empty rhs subst in let rhs' = nf_evar evd rhs' in (* Thin evars making the term typable in env_evar *) let evd, rhs' = thin_evars env_evar evd ctxt rhs' in (* We instantiate the evars of which the value is forced by typing *) debug_ho_unification (fun () -> Pp.(str"solve_evars on: " ++ prc env_evar evd rhs' ++ fnl () ++ str"evars: " ++ pr_evar_map (Some 0) env_evar evd)); let evd,rhs' = try !solve_evars env_evar evd rhs' with e when Pretype_errors.precatchable_exception e -> (* Could not revert all subterms *) raise (TypingFailed evd) in let rhs' = nf_evar evd rhs' in (* We instantiate the evars of which the value is forced by typing *) debug_ho_unification (fun () -> Pp.(str"after solve_evars: " ++ prc env_evar evd rhs' ++ fnl () ++ str"evars: " ++ pr_evar_map (Some 0) env_evar evd)); let rec abstract_free_holes evd = function | (id,idty,c,cty,evsref,_,_)::l -> let id = id.binder_name in let c = nf_evar evd c in debug_ho_unification (fun () -> Pp.(str"abstracting: " ++ prc env_rhs evd (mkVar id) ++ spc () ++ prc env_rhs evd c)); let rec force_instantiation evd = function | (evk,evty,inst,abstract)::evs -> let evk = Option.default evk (Evarutil.advance evd evk) in let evd = if is_undefined evd evk then (* We try abstraction or concretisation for *) (* this unconstrained occurrence *) (* and we use typing to propagate this instantiation *) (* We avoid making an arbitrary choice by leaving candidates *) (* if both can work *) let evi = Evd.find_undefined evd evk in let vid = mkVar id in let candidates = [inst; vid] in try let evd, ev = Evarutil.restrict_evar evd evk (Evd.evar_filter evi) (Some candidates) in let evi = Evd.find_undefined evd ev in (match evar_candidates evi with | Some [t] -> if not (noccur_evar env_rhs evd ev t) then raise (TypingFailed evd); instantiate_evar evar_unify flags env_rhs evd ev t | Some l when abstract = Abstraction.Abstract && List.exists (fun c -> isVarId evd id c) l -> instantiate_evar evar_unify flags env_rhs evd ev vid | _ -> evd) with IllTypedInstance _ (* from instantiate_evar *) | TypingFailed _ -> user_err (Pp.str "Cannot find an instance.") else ((debug_ho_unification (fun () -> let EvarInfo evi = Evd.find evd evk in let env = Evd.evar_env env_rhs evi in Pp.(str"evar is defined: " ++ int (Evar.repr evk) ++ spc () ++ prc env evd (match evar_body evi with Evar_defined c -> c | Evar_empty -> assert false))); evd)) in force_instantiation evd evs | [] -> abstract_free_holes evd l in force_instantiation evd !evsref | [] -> if Evd.is_defined evd evk then (* Can happen due to dependencies: instantiating evars in the arguments of evk might instantiate evk itself. *) (debug_ho_unification (fun () -> begin let EvarInfo evi = Evd.find evd evk in let evenv = evar_env env_rhs evi in let body = match evar_body evi with Evar_empty -> assert false | Evar_defined c -> c in Pp.(str"evar was defined already as: " ++ prc evenv evd body) end); evd) else try let evi = Evd.find_undefined evd evk in let evenv = evar_env env_rhs evi in let rhs' = nf_evar evd rhs' in debug_ho_unification (fun () -> Pp.(str"abstracted type before second solve_evars: " ++ prc evenv evd rhs')); (* solve_evars is not commuting with nf_evar, because restricting an evar might provide a more specific type. *) let evd, _ = !solve_evars evenv evd rhs' in debug_ho_unification (fun () -> Pp.(str"abstracted type: " ++ prc evenv evd (nf_evar evd rhs'))); let flags = default_flags_of TransparentState.full in Evarsolve.instantiate_evar evar_unify flags env_rhs evd evk rhs' with IllTypedInstance _ -> raise (TypingFailed evd) in let evd = abstract_free_holes evd subst in evd, true with TypingFailed evd -> evd, false let default_evar_selection flags evd (ev,args) = let evi = Evd.find_undefined evd ev in let args = Evd.expand_existential evd (ev, args) in let rec aux args abs = match args, abs with | _ :: args, a :: abs -> let spec = Unspecified a in spec :: aux args abs | l, [] -> List.map (fun _ -> default_occurrence_selection) l | [], _ :: _ -> assert false in aux args (Evd.evar_abstract_arguments evi) let second_order_matching_with_args flags env evd with_ho pbty ev l t = if with_ho then let evd,ev = evar_absorb_arguments env evd ev (Array.to_list l) in let argoccs = default_evar_selection flags evd ev in let test = default_occurrence_test ~allowed_evars:flags.allowed_evars flags.subterm_ts in let evd, b = try second_order_matching flags env evd ev (test,argoccs) t with PretypeError (_, _, NoOccurrenceFound _) -> evd, false in if b then Success evd else UnifFailure (evd, ConversionFailed (env,mkApp(mkEvar ev,l),t)) else let pb = (pbty,env,mkApp(mkEvar ev,l),t) in UnifFailure (evd, CannotSolveConstraint (pb,ProblemBeyondCapabilities)) let is_beyond_capabilities = function | CannotSolveConstraint (pb,ProblemBeyondCapabilities) -> true | _ -> false let is_constant_instance sigma (evk, args) alias = let args = Evd.expand_existential sigma (evk, args) in List.for_all (fun a -> EConstr.eq_constr sigma a alias || isEvar sigma a) (remove_instance_local_defs sigma evk args) let apply_conversion_problem_heuristic flags env evd with_ho pbty t1 t2 = let t1 = apprec_nohdbeta flags env evd (whd_head_evar evd t1) in let t2 = apprec_nohdbeta flags env evd (whd_head_evar evd t2) in let (term1,l1 as appr1) = try destApp evd t1 with DestKO -> (t1, [||]) in let (term2,l2 as appr2) = try destApp evd t2 with DestKO -> (t2, [||]) in let () = debug_unification (fun () -> Pp.(v 0 (str "Heuristic:" ++ spc () ++ Termops.Internal.print_constr_env env evd t1 ++ cut () ++ Termops.Internal.print_constr_env env evd t2 ++ cut ()))) in let app_empty = Array.is_empty l1 && Array.is_empty l2 in match EConstr.kind evd term1, EConstr.kind evd term2 with | Evar (evk1,args1), (Rel _|Var _) when app_empty && is_evar_allowed flags evk1 && is_constant_instance evd (evk1, args1) term2 -> (* The typical kind of constraint coming from pattern-matching return type inference *) (match choose_less_dependent_instance evd term2 (evk1, args1) with | Some evd -> Success evd | None -> let reason = ProblemBeyondCapabilities in UnifFailure (evd, CannotSolveConstraint ((pbty,env,t1,t2),reason))) | (Rel _|Var _), Evar (evk2,args2) when app_empty && is_evar_allowed flags evk2 && is_constant_instance evd (evk2, args2) term1 -> (* The typical kind of constraint coming from pattern-matching return type inference *) (match choose_less_dependent_instance evd term1 (evk2, args2) with | Some evd -> Success evd | None -> let reason = ProblemBeyondCapabilities in UnifFailure (evd, CannotSolveConstraint ((pbty,env,t1,t2),reason))) | Evar (evk1,args1), Evar (evk2,args2) when Evar.equal evk1 evk2 -> let f flags ontype env evd pbty x y = let reds = match ontype with | TypeUnification -> TransparentState.full | TermUnification -> flags.open_ts in is_fconv ~reds pbty env evd x y in Success (solve_refl ~can_drop:true f flags env evd (position_problem true pbty) evk1 args1 args2) | Evar (evk1,_ as ev1), Evar ev2 when app_empty -> (* solve_evar_evar handles the cases ev1 and/or ev2 are frozen *) (try Success (solve_evar_evar ~force:true (evar_define evar_unify flags ~choose:true) evar_unify flags env evd (position_problem true pbty) ev1 ev2) with IllTypedInstance (env,evd,t,u) -> UnifFailure (evd,InstanceNotSameType (evk1,env,t,u))) | Evar ev1,_ when is_evar_allowed flags (fst ev1) && Array.length l1 <= Array.length l2 -> (* On "?n t1 .. tn = u u1 .. u(n+p)", try first-order unification *) (* and otherwise second-order matching *) ise_try evd [(fun evd -> first_order_unification flags env evd (ev1,l1) appr2); (fun evd -> second_order_matching_with_args flags env evd with_ho pbty ev1 l1 t2)] | _,Evar ev2 when is_evar_allowed flags (fst ev2) && Array.length l2 <= Array.length l1 -> (* On "u u1 .. u(n+p) = ?n t1 .. tn", try first-order unification *) (* and otherwise second-order matching *) ise_try evd [(fun evd -> first_order_unification flags env evd (ev2,l2) appr1); (fun evd -> second_order_matching_with_args flags env evd with_ho pbty ev2 l2 t1)] | Evar ev1,_ when is_evar_allowed flags (fst ev1) -> (* Try second-order pattern-matching *) second_order_matching_with_args flags env evd with_ho pbty ev1 l1 t2 | _,Evar ev2 when is_evar_allowed flags (fst ev2) -> (* Try second-order pattern-matching *) second_order_matching_with_args flags env evd with_ho pbty ev2 l2 t1 | _ -> (* Some head evar have been instantiated, or unknown kind of problem *) evar_conv_x flags env evd pbty t1 t2 let error_cannot_unify env evd pb ?reason t1 t2 = Pretype_errors.error_cannot_unify ?loc:(loc_of_conv_pb evd pb) env evd ?reason (t1, t2) let check_problems_are_solved env evd = match snd (extract_all_conv_pbs evd) with | (pbty,env,t1,t2) as pb::_ -> error_cannot_unify env evd pb t1 t2 | _ -> () let rec solve_unconstrained_evars_with_candidates flags env evd = (* max_undefined is supposed to return the most recent, hence possibly most dependent evar *) match Evd.max_undefined_with_candidates evd with | None -> evd | Some evk -> let ev_info = Evd.find_undefined evd evk in let l = match evar_candidates ev_info with | None -> assert false | Some l -> l in let rec aux = function | [] -> user_err Pp.(str "Unsolvable existential variables.") | a::l -> (* In case of variables, most recent ones come first *) try let evd = instantiate_evar evar_unify flags env evd evk a in match reconsider_unif_constraints evar_unify flags evd with | Success evd -> solve_unconstrained_evars_with_candidates flags env evd | UnifFailure _ -> aux l with | IllTypedInstance _ -> aux l | e when Pretype_errors.precatchable_exception e -> aux l in (* Expected invariant: most dependent solutions come first *) (* so as to favor progress when used with the refine tactics *) let evd = aux l in solve_unconstrained_evars_with_candidates flags env evd let solve_unconstrained_impossible_cases env evd = Evar.Set.fold (fun evk evd' -> let evd', j = coq_unit_judge env evd' in let ty = j_type j in let flags = default_flags env in instantiate_evar evar_unify flags env evd' evk ty (* should we protect from raising IllTypedInstance? *) ) (Evd.get_impossible_case_evars evd) evd let solve_unif_constraints_with_heuristics env ?(flags=default_flags env) ?(with_ho=false) evd = let evd = solve_unconstrained_evars_with_candidates flags env evd in let rec aux evd pbs progress stuck = match pbs with | (pbty,env,t1,t2 as pb) :: pbs -> (match apply_conversion_problem_heuristic flags env evd with_ho pbty t1 t2 with | Success evd' -> let evd' = solve_unconstrained_evars_with_candidates flags env evd' in let (evd', rest) = extract_all_conv_pbs evd' in begin match rest with | [] -> aux evd' pbs true stuck | l -> (* Unification got actually stuck, postpone *) let reason = CannotSolveConstraint (pb,ProblemBeyondCapabilities) in aux evd pbs progress ((pb, reason):: stuck) end | UnifFailure (evd,reason) -> if is_beyond_capabilities reason then aux evd pbs progress ((pb,reason) :: stuck) else aux evd [] false ((pb,reason) :: stuck)) | _ -> if progress then aux evd (List.map fst stuck) false [] else match stuck with | [] -> (* We're finished *) evd | ((pbty,env,t1,t2 as pb), reason) :: _ -> (* There remains stuck problems *) Pretype_errors.error_cannot_unify ?loc:(loc_of_conv_pb evd pb) env evd ~reason (t1, t2) in let (evd,pbs) = extract_all_conv_pbs evd in let heuristic_solved_evd = aux evd pbs false [] in check_problems_are_solved env heuristic_solved_evd; solve_unconstrained_impossible_cases env heuristic_solved_evd (* Main entry points *) exception UnableToUnify of evar_map * unification_error let evar_conv_x flags env evd pb x1 x2 : unification_result = NewProfile.profile "unification" (fun () -> evar_conv_x flags env evd pb x1 x2) () let unify_delay ?flags env evd t1 t2 = let flags = match flags with | None -> default_flags_of (default_transparent_state env) | Some flags -> flags in match evar_conv_x flags env evd CONV t1 t2 with | Success evd' -> evd' | UnifFailure (evd',e) -> raise (UnableToUnify (evd',e)) let unify_leq_delay ?flags env evd t1 t2 = let flags = match flags with | None -> default_flags_of (default_transparent_state env) | Some flags -> flags in match evar_conv_x flags env evd CUMUL t1 t2 with | Success evd' -> evd' | UnifFailure (evd',e) -> raise (UnableToUnify (evd',e)) let unify ?flags ?(with_ho=true) env evd cv_pb ty1 ty2 = let flags = match flags with | None -> default_flags_of (default_transparent_state env) | Some flags -> flags in let res = evar_conv_x flags env evd cv_pb ty1 ty2 in match res with | Success evd -> solve_unif_constraints_with_heuristics ~flags ~with_ho env evd | UnifFailure (evd, reason) -> raise (PretypeError (env, evd, CannotUnify (ty1, ty2, Some reason))) let compare_heads = compare_heads CONV coq-elpi-2.1.0/apps/cs/tests/000077500000000000000000000000001460156013500157365ustar00rootroot00000000000000coq-elpi-2.1.0/apps/cs/tests/test_cs.v000066400000000000000000000011401460156013500175650ustar00rootroot00000000000000From elpi.apps Require Import cs. From Coq Require Import Bool. Elpi Override CS All. Structure S (T : Type) : Type := { sort :> T -> T }. Elpi Accumulate canonical_solution lp:{{ cs _ {{ sort lp:T }} {{ @id lp:T }} {{ Build_S lp:T (@id lp:T) }}. }}. Elpi Typecheck canonical_solution. Check 1. Check eq_refl _ : (sort nat _) = @id nat. Check 11. Check eq_refl _ : (sort nat _) 1 = @id nat 1. Definition id1 := id. Check 2. Check eq_refl _ : (sort nat _) = @id1 nat. Definition sort1 := sort. Check 3. Check eq_refl _ : (sort1 nat _) = @id nat. Check 4. Check eq_refl _ : (sort1 nat _) = @id1 nat. coq-elpi-2.1.0/apps/cs/theories/000077500000000000000000000000001460156013500164165ustar00rootroot00000000000000coq-elpi-2.1.0/apps/cs/theories/cs.v000066400000000000000000000013351460156013500172140ustar00rootroot00000000000000Declare ML Module "coq-elpi-cs.plugin". From elpi Require Import elpi. Elpi Db cs.db lp:{{ % predicate [cs Ctx Proj Rhs Sol] used to find Sol such that Proj Sol = Rhs, where % - [Ctx] is the context % - [Proj] is the projector of some structure, applied to the structure's parameters if any % - [Rhs] the term to find a structure on. :index (0 6 6) pred cs i:goal-ctx, i:term, i:term, o:term. }}. Elpi Tactic canonical_solution. Elpi Accumulate Db cs.db. Elpi Accumulate canonical_solution lp:{{ solve (goal Ctx _ _Ty Sol [trm Proj, trm Rhs]) _ :- cs Ctx Proj Rhs Sol, % std.assert! (P = {{ eq_refl lp:Lhs }}) "cs: wrong solution". true. }}. Elpi Typecheck canonical_solution. Elpi CSFallbackTactic canonical_solution. coq-elpi-2.1.0/apps/derive/000077500000000000000000000000001460156013500154455ustar00rootroot00000000000000coq-elpi-2.1.0/apps/derive/Makefile000066400000000000000000000023531460156013500171100ustar00rootroot00000000000000# detection of coq ifeq "$(COQBIN)" "" COQBIN := $(shell which coqc >/dev/null 2>&1 && dirname `which coqc`) endif ifeq "$(COQBIN)" "" $(error Coq not found, make sure it is installed in your PATH or set COQBIN) else $(info Using coq found in $(COQBIN), from COQBIN or PATH) endif export COQBIN := $(COQBIN)/ all: build test build: Makefile.coq @$(MAKE) --no-print-directory -f Makefile.coq test: Makefile.test.coq @$(MAKE) --no-print-directory -f Makefile.test.coq coverage: @$(MAKE) --no-print-directory -f Makefile.coq coverage theories/%.vo: force @$(MAKE) --no-print-directory -f Makefile.coq $@ tests/%.vo: force build Makefile.test.coq @$(MAKE) --no-print-directory -f Makefile.test.coq $@ examples/%.vo: force build Makefile.test.coq @$(MAKE) --no-print-directory -f Makefile.test.coq $@ Makefile.coq Makefile.coq.conf: _CoqProject @$(COQBIN)/coq_makefile -f _CoqProject -o Makefile.coq @$(MAKE) --no-print-directory -f Makefile.coq .merlin Makefile.test.coq Makefile.test.coq.conf: _CoqProject.test @$(COQBIN)/coq_makefile -f _CoqProject.test -o Makefile.test.coq clean: Makefile.coq Makefile.test.coq @$(MAKE) -f Makefile.coq $@ @$(MAKE) -f Makefile.test.coq $@ .PHONY: force all build test install: @$(MAKE) -f Makefile.coq $@ coq-elpi-2.1.0/apps/derive/Makefile.coq.local000066400000000000000000000021431460156013500207570ustar00rootroot00000000000000 coverage: @printf "====== %-10s\n" "test suite" @printf "inductives: %d\n" \ `grep -E "^ *(Inductive|Variant)" tests/test_derive_stdlib.v 2>/dev/null| wc -l` @printf "records: %d\n" \ `grep -E "^ *(Record|Structure)" tests/test_derive_stdlib.v 2>/dev/null| wc -l` @printf "definitions: %d\n" \ `grep -E "^ *(Fixpoint|Definition)" tests/test_derive_stdlib.v 2>/dev/null| wc -l` @for F in $(wildcard theories/derive/*.v); do\ D=`basename $$F .v`;\ D_=`echo $$D | sed 's/_/./'`;\ F=`mktemp`;\ if [ -e tests/test_$${D}.v ]; then\ (cat tests/test_$${D}.v | awk ' /Module Coverage/ { p = 1 } /End Coverage/ { p = 0 } { if(p == 1) { print }} ' ) > $$F ;\ N=`grep -E "^(Fail )?Elpi derive.$$D_" $$F 2>/dev/null| wc -l`;\ OK=`grep -E "^Elpi derive.$$D_" $$F 2>/dev/null| wc -l`;\ printf "====== %-10s (%2d/%-2d)\n" tests/test_$${D}.v $$OK $$N;\ grep -E "^Fail Elpi derive.$$D_" $$F | grep -vi expected 2>/dev/null;\ fi;\ done || true install-extra:: df="`$(COQMKFILE) -destination-of theories/derive/std.vo $(COQLIBS)`";\ install -m 0644 $(wildcard elpi/*.elpi) "$(COQLIBINSTALL)/$$df" coq-elpi-2.1.0/apps/derive/README.md000066400000000000000000000510731460156013500167320ustar00rootroot00000000000000# Derive The `derive` command automatically synthesizes a bunch of useful lemmas given an inductive type declaration. ## In a nutshell ```coq From elpi.apps Require Import derive.std. #[module] derive Inductive peano := Zero | Succ (p : peano). Print peano.peano. (* Inductive peano : Set := Zero : peano | Succ : peano -> peano. *) Eval compute in peano.eqb Zero (Succ Zero). (* = false : bool *) About peano.eqb_OK. (* peano.eqb_OK : forall x1 x2 : peano, reflect (x1 = x2) (peano.eqb x1 x2) peano.eqb_OK is not universe polymorphic Arguments peano.eqb_OK x1 x2 peano.eqb_OK is opaque Expands to: Constant elpi.apps.derive.examples.readme.peano.eqb_OK *) ``` See also [examples/usage.v](examples/usage.v) and [tests/test_readme.v](tests/test_readme.v). :warning: The line `From elpi.apps Require Import derive.std.` sets globally `Uniform Inductive Parameters`. See the [documentation of that option in the Coq reference manual](https://coq.inria.fr/refman/language/core/inductive.html#coq:flag.Uniform-Inductive-Parameters). ## Usage and attributes Using `derive Inductive ty := ...` produces the inductive `ty`, together with derivations, all in the current scope. The `#[module=]` attriute can be used to specify that the inductive and the derivations should be wrapped in a module of the given name (the name of the inductive is used if no name is specified). When a wrapper module is generated, an alias (i.e., a notation) is generated for the inductive to be accessible with its name, outside of the module scope. This behaviour can be disabled by using the `#[no_alias]` boolean attribute. The `#[prefix=]` attribute can be used to specify a prefix for all the derived definitions/lemmas. ## Documentation Elpi's `derive` app is a little framework to register derivations. Currently there are 3 groups: - `derive.std` contains well tested derivations including: + `eqb` and `eqbOK` generate sound boolean equality test in linear time/space, see [Practical and sound equality tests, automatically](https://hal.inria.fr/hal-03800154) + `eqbOK` generates its soundness proof in linear time/space + `induction` generates deep induction principles, see [Stronger Induction Principles for Containers](http://drops.dagstuhl.de/opus/volltexte/2019/11084/) + `param1` and `param2` generate the unary and binary parametricity translations + `map` map over a container + `param1_functor` functoriality lemmas (map over the param1 translation) + `lens` and `lens_laws` generate lenses focusing on record fields and some equations governing setter/setters - `derive.legacy` contains derivations superseded by `std`: + `eq` and `eqOK` generate sound equality tests in quadratic time/space, see [Deriving proved equality tests in Coq-elpi](http://drops.dagstuhl.de/opus/volltexte/2019/11084/) - `derive.experimental` contains derivations not suitable for mainstream use: + `idx2inv` generates an inductive type where indexes are replaced by non uniform parameters and equations The `elpi/` directory contains the elpi files implementing various automatic derivation of terms. The corresponding .v files, defining the Coq commands, are in `theories/derive/`. Single steps of the derivation are available as separate commands. Only the main entry point `derive` comes with an handy syntax; the other commands have to be invoked mentioning `Elpi` and only accept an already declared inductive as input. ## Derivations
std (click to expand)

### `map` Map a container over its parameters. ```coq Elpi derive.map list. Check list_map : forall A B, (A -> B) -> list A -> list B. ``` ### `lens` See also [theories/derive/lens.v](theories/derive/lens.v) for the `Lens` definition and the support constants `view`, `set` and `over`. ```coq Record pa_record A := { f3 : peano; f4 : A; }. Elpi derive.lens pa_record. Check _f3 : forall A, Lens (pa_record A) (pa_record A) peano peano. ``` ### `lens_laws` See also [theories/derive/lens_laws.v](theories/derive/lens_laws.v) for the statements of the 4 laws (set_set, view_set, set_view, exchange). ```coq Elpi derive.lens_laws pa_record. Check _f3_view_set : forall A (r : pa_record A) x, view _f3 (set _f3 x r) = x. ``` ### `param1` Unary parametricity translation. ```coq Elpi derive.param1 nat. Print is_nat. (* Inductive is_nat : nat -> Type := | is_O : is_nat 0 | is_S : forall n : nat, is_nat n -> is_nat (S n) *) ``` ### `param1_functor` ```coq Elpi derive.param1.functor is_list. Check is_list_functor : forall A PA QA, (forall x, PA x -> QA x) -> forall l, is_list A PA l -> list A QA l. ``` ### `param1_trivial` ```coq Elpi derive.param1.trivial is_nat. Check is_nat_trivial : forall x : nat, { p : is_nat x & forall q, p = q }. Check is_nat_inhab : forall x : nat, is_nat x. ``` ### `induction` Induction principle for `T` based on `is_T` ```coq Elpi derive.induction list. Check list_induction : forall (A : Type) (PA : A -> Type) P, P (nil A) -> (forall x : A, PA x -> forall xs, P xs -> P (cons A x xs)) -> forall l, is_list A PA l -> P l. ``` ### `tag` The "name" of the constructor ```coq Elpi derive.tag peano. Check peano_tag : peano -> positive. ``` ### `fields` The types of the fields and the fields of each constructor ```coq Elpi derive.fields peano. Check peano_fields_t : positive -> Type. Check peano_fields : forall (n:peano), peano_fields_t (peano_tag n). Check peano_construct : forall (p: positive), peano_fields_t p -> Datatypes.option peano. Check peano_constructP : forall (n:peano), peano_construct (peano_tag n) (peano_fields n) = Datatypes.Some n. ``` ### `eqb` Equality test ```coq Elpi derive.eqb peano. Check peano_eqb : peano -> peano -> bool. ``` ### `eqbcorrect` Two directions of the soundness proof ```coq Elpi derive.eqbcorrect peano. Check peano_eqb_correct : forall n m, peano_eqb n m = true -> n = m. Check peano_eqb_refl : forall n, peano_eqb n n = true. ``` ### `eqbOK` The soundness proof ```coq Elpi derive.eqbOK peano. Check peano_eqb_OK : forall n m, reflect (n = m) (peano_eqb n m). ``` ### `param1_congr` Used by `param1_trivial`, not interesting. ```coq Elpi derive.param1.congr is_nat. Check is_Succ congr : forall x (px qx : is_nat x), px = qx -> is_Succ x px = is_Succ x qx. ```

legacy (click to expand)

See [Deriving proved equality tests in Coq-elpi: Stronger Induction Principles for Containers](http://drops.dagstuhl.de/opus/volltexte/2019/11084/) for a description of most of these components. ### `isK` Given an inductive type it generates for each constructor a function that tests if a term is a specific constructor. Example: ```coq Elpi derive.isK list. Print list_is_nil. (* list_is_nil = fun (A : Type) (i : list A) => match i with | nil => true | _ => false end *) ``` ### `projK` Given an inductive type it generates for each constructor `K` and argument `i` of this constructor a function extracting that argument (provided enough default values). ```coq Elpi derive.projK Vector.t. Check projcons1. (* projcons1 : forall (A : Type) (H : nat), A -> forall n : nat, Vector.t A n -> Vector.t A H -> A ``` The intended use is to perform injection, i.e. one aleady has a term of the shape `K args` and can just use these args to provide the default values. If the projected argument's type depends on the value of other arguments, then it is boxed using `existT`. ```coq Check projcons3. (* projcons3 : forall (A : Type) (H : nat), A -> forall n : nat, Vector.t A n -> Vector.t A H -> {i1 : nat & Vector.t A i1} *) ``` ### injection `injection H EqAB PL` given an equation `H` of type `EqAB` returns a list of equations `PL`. `EqAB` is expected to be of the form `K .. = K ..` for a constructor `K`. coverage: does not do the smart thing when the obtained equations are like `{ i : nat & Vector.t A i } = ...` in which case, given that `nat` is `eqType` one could obtain systematically the two equalities. Note: this is not a real derivation, since it generates no constant, but it a piece of code used by derivations. ### discriminate `discriminate H EqAB G PG` given an equation `H` of type `EqAB` and a goal `G` it provides a proof `PG`. It asserts that `EqAB` is of the form `K1 .. = K2 ..` when `K1` is a constructor different from `K2`. Note: this is not a real derivation, since it generates no constant, but it a piece of code used by derivations. ### `bcongr` We call a boolean congruence lemma an instance of the `reflect` predicate on a proposition `K x1..xn = K y1..yn` and a boolean expression `b1 && .. bn`. ```coq Elpi derive.bcongr list. Check nil_congr : forall A, reflect (@nil A = @nil A) true. Check cons_congr : forall A, forall (x y : A) b1, reflect (x = y) b1 -> forall (xs ys : list A) b2, reflect (xs = ys) b2 -> reflect (cons x xs = cons y ys) (b1 && b2). ``` ### `eq` Generates a boolean comparison function. ```coq Elpi derive.eq list. Check list_eq. (* list_eq : forall A : Type, (A -> A -> bool) -> list A -> list A -> bool *) ``` ### `eqK` Generates, for each constructor, the correctness lemma for the comparison function. ```coq Elpi derive.eqK list. Check eq_axiom_nil : forall A fa, axiom (list A) (list_eq A fa) (@nil A). Check eq_axiom_cons : forall A fa, forall x, axiom A fa x -> forall xs, axiom (list A) (list_eq A fa) xs -> axiom (list A) (list_eq A fa) (cons x xs). ``` ### `eqcorrect` Correctness of equality test using reified type information. ```coq Elpi derive.eqcorrect list. Check list_eq_correct : forall A f l, is_list A (eq_axiom A f) l -> eq_axiom (list A) (list_eq A f) l. ``` ### `eqOK` Correctness of equality test. ```coq Elpi derive.eqOK list. Check list_eq_OK : forall A f, (forall a, axiom A f a) -> (forall l, eq_axiom (list A) (list_eq A f) l). ``` ## Coverage This is the list of inductive types we use for testing, and the table with the result of each derivation (:sunny: = OK, :bug: = does not work but might, :cloud: = looks like this can't possible work) ```coq Inductive empty := . Inductive unit := tt. Inductive peano := Zero | Succ (n : peano). Inductive option A := None | Some (_ : A). Inductive pair A B := Comma (a : A) (b : B). Inductive seq A := Nil | Cons (x : A) (xs : seq A). Inductive rose (A : Type) := Leaf | Node (sib : seq (rose A)). Inductive nest A := NilN | ConsN (x : A) (xs : nest (pair A A)). Fail Inductive bush A := BNil | BCons (x : A) (xs : bush (bush A)). Inductive w A := via (f : A -> w A). Inductive vect A : peano -> Type := VNil : vect A Zero | VCons (x : A) n (xs : vect A n) : vect A (Succ n). Inductive dyn := box (T : Type) (t : T). Inductive zeta Sender (Receiver := Sender) := Envelope (a : Sender) (ReplyTo := a) (c : Receiver). Inductive beta (A : (fun x : Type => x) Type) := Redex (a : (fun x : Type => x) A). Inductive iota := Why n (a : match n in peano return Type with Zero => peano | Succ _ => unit end). Inductive large := K1 (_ : unit) | K2 (_ : unit) (_ : unit) | ... Inductive prim_int := PI (i : Int63.int). Inductive prim_float := PF (f : PrimFloat.float). Record fo_record := { f1 : peano; f2 : unit; }. Record pa_record A := { f3 : peano; f4 : A; }. Record pr_record A := { pf3 : peano; pf4 : A; }. (* with primitive projections *) Record dep_record := { f5 : peano; f6 : vect unit f5; }. Variant enum := E1 | E2 | E3. ``` test | eq | param1 | map | induction | isK | projK | bcongr | eqK | eqcorrect | eqOK | lens_laws -----------|---------|---------|---------|-----------|---------|---------|---------|---------|-----------|---------|---------- empty | :sunny: | :sunny: | :sunny: | :sunny: | :sunny: | :sunny: | :sunny: | :sunny: | :sunny: | :sunny: | :cloud: unit | :sunny: | :sunny: | :sunny: | :sunny: | :sunny: | :sunny: | :sunny: | :sunny: | :sunny: | :sunny: | :cloud: peano | :sunny: | :sunny: | :sunny: | :sunny: | :sunny: | :sunny: | :sunny: | :sunny: | :sunny: | :sunny: | :cloud: option | :sunny: | :sunny: | :sunny: | :sunny: | :sunny: | :sunny: | :sunny: | :sunny: | :sunny: | :sunny: | :cloud: pair | :sunny: | :sunny: | :sunny: | :sunny: | :sunny: | :sunny: | :sunny: | :sunny: | :sunny: | :sunny: | :cloud: seq | :sunny: | :sunny: | :sunny: | :sunny: | :sunny: | :sunny: | :sunny: | :sunny: | :sunny: | :sunny: | :cloud: rose | :sunny: | :sunny: | :sunny: | :sunny: | :sunny: | :sunny: | :sunny: | :sunny: | :sunny: | :sunny: | :cloud: nest | :cloud: | :sunny: | :cloud: | :sunny: | :sunny: | :sunny: | :sunny: | :bug: | :bug: | :bug: | :cloud: w | :cloud: | :sunny: | :bug: | :sunny: | :sunny: | :sunny: | :sunny: | :bug: | :bug: | :bug: | :cloud: vect | :sunny: | :sunny: | :sunny: | :sunny: | :sunny: | :sunny: | :bug: | :bug: | :bug: | :bug: | :cloud: dyn | :cloud: | :sunny: | :sunny: | :sunny: | :sunny: | :sunny: | :bug: | :bug: | :bug: | :bug: | :cloud: zeta | :sunny: | :sunny: | :sunny: | :sunny: | :sunny: | :sunny: | :sunny: | :sunny: | :sunny: | :sunny: | :cloud: beta | :sunny: | :sunny: | :bug: | :sunny: | :sunny: | :sunny: | :sunny: | :sunny: | :bug: | :sunny: | :cloud: iota | :cloud: | :sunny: | :sunny: | :sunny: | :sunny: | :sunny: | :cloud: | :bug: | :cloud: | :cloud: | :cloud: large | :sunny: | :sunny: | :bug: | :sunny: | :sunny: | :sunny: | :sunny: | :sunny: | :sunny: | :sunny: | :cloud: prim_int | :sunny: | :sunny: | :sunny: | :sunny: | :sunny: | :sunny: | :sunny: | :sunny: | :sunny: | :sunny: | :cloud: prim_float | :sunny: | :sunny: | :sunny: | :sunny: | :sunny: | :sunny: | :sunny: | :sunny: | :cloud: | :cloud: | :cloud: fo_record | :sunny: | :sunny: | :sunny: | :sunny: | :sunny: | :sunny: | :sunny: | :sunny: | :sunny: | :sunny: | :sunny: pa_record | :sunny: | :sunny: | :sunny: | :sunny: | :sunny: | :sunny: | :sunny: | :sunny: | :sunny: | :sunny: | :sunny: pr_record | :sunny: | :sunny: | :sunny: | :sunny: | :sunny: | :sunny: | :sunny: | :sunny: | :sunny: | :sunny: | :sunny: dep_record | :bug: | :sunny: | :sunny: | :sunny: | :sunny: | :sunny: | :bug: | :bug: | :bug: | :bug: | :cloud: enum | :sunny: | :sunny: | :sunny: | :sunny: | :sunny: | :sunny: | :sunny: | :sunny: | :sunny: | :sunny: | :cloud: test | functor | inhab | congr | trivial | ----------|---------|---------|-----------|---------| is_empty | :sunny: | :sunny: | :sunny: | :sunny: | is_unit | :sunny: | :sunny: | :sunny: | :sunny: | is_peano | :sunny: | :sunny: | :sunny: | :sunny: | is_option | :sunny: | :sunny: | :sunny: | :sunny: | is_pair | :sunny: | :sunny: | :sunny: | :sunny: | is_seq | :sunny: | :sunny: | :sunny: | :sunny: | is_rose | :sunny: | :sunny: | :sunny: | :sunny: | is_nest | :bug: | :bug: | :cloud: | :cloud: | is_w | :bug: | :sunny: | :sunny: | :bug: | is_vect | :sunny: | :bug: | :cloud: | :bug: | is_dyn | :sunny: | :cloud: | :cloud: | :bug: | is_zeta | :sunny: | :sunny: | :sunny: | :sunny: | is_beta | :sunny: | :sunny: | :sunny: | :sunny: | is_iota | :sunny: | :bug: | :cloud: | :bug: | is_large | :sunny: | :sunny: | :bug: | :bug: | is_prim_int | :sunny: | :sunny: | :sunny: | :sunny: | is_is_prim_float| :sunny: | :sunny: | :sunny: | :sunny: | is_fo_record | :sunny: | :sunny: | :sunny: | :sunny: | is_pa_record | :sunny: | :sunny: | :sunny: | :sunny: | is_pr_record | :sunny: | :sunny: | :sunny: | :sunny: | is_dep_record| :sunny: | :bug: | :sunny: | :bug: | is_enum | :sunny: | :sunny: | :sunny: | :sunny: |

experimental (click to expand)

### `invert` ```coq Inductive is_list A PA : list A -> Type := | nilR : is_list (@nil A) | consR : forall a : A, PA a -> forall xs : list A, is_list xs -> is_list (cons a xs). Elpi derive.invert is_list. Print is_list_inv. (* Inductive is_list_inv (A : Type) (PA : A -> Type) (idx0 : list A) : Type := | nilR_inv : idx0 = nil -> is_list_inv A PA idx0 | consR_inv : forall a : A, PA a -> forall xs : list A, is_list_inv A PA xs -> idx0 = (cons a xs) -> is_list_inv A PA idx0. *) ``` ## `idx2inv` ```coq Elpi derive.idx2inv is_list. Check is_list_to_is_list_inv : forall A PA l, is_list A PA l -> is_list_inv A PA l. ```

## Writing a new derivation A derivation is made of: - a file implementing the derivation - a data base to carry some state - a stand alone command - a hook in the main derive procedure At the light of that, here a typical derivation file `myder.v`. The first section loads the standard derive code and declares the dependency the external file `myder.elpi`. The file `derive_hook.elpi` contains a few data types needed in order to register the derivation in the main derive loop. ```coq From elpi.apps.derive Extra Dependency "derive_hook.elpi" as derive_hook. From mypkg Extra Dependency "myder.elpi" as myder. From elpi Require Import elpi. From elpi.apps Require Import derive. ``` The database is typically a predicate `myder` linking a type name to some concept previously derived. We also need to know if we did already derive a type, hence we declare a second predicate `myder-done` (we could reuse the former, but sometimes this is not easy, so here we are pedantic). We like to prefix these data bases name with `derive.`. ```coq Elpi Db derive.mydb.db lp:{{ % [myder T D] links a type T to a derived concept D pred myder o:gref, o:gref. % [myder-done T] mean T was already derived pred myder-done o:gref. }}. ``` Then we build a standalone derivation accessible via the name `derive.myder` which accumulates the external files declared before, the data base and an entry point ```coq Elpi Command derive.myder. Elpi Accumulate File derive_hook. Elpi Accumulate File myder. Elpi Accumulate Db derive.mydb.db. Elpi Accumulate lp:{{ main [str I] :- !, coq.locate I GR, coq.gref->id GR Tname, Prefix is Tname ^ "_", derive.myder.main GR Prefix _. main _ :- usage. pred usage. usage :- coq.error "Usage: derive.myder ". }}. Elpi Typecheck. ``` This is enough to run the derivation via something like `Elpi derive.myder nat.`. In order to have `derive` run it one has to accumulate some code on top of `derive` itself. ```coq Elpi Accumulate derive Db derive.myder.db. Elpi Accumulate derive File myder. Elpi Accumulate derive lp:{{ dep1 "myder" "somedep". dep1 "myder" "someotherdep". derivation (indt T) Prefix % inputs (derive "myder" % name (for dep1) (derive.myder.main (indt T) Prefix) % code to run (myder-done (indt T)) % idempotency test ). }}. ``` First, one declares via `dep1` the derivations that should run before, here `somedep` and `someotherdep`. `derive` will compute a topological order and ensure dependencies are run first. Then one declares a derivation for a gref and a prefix. One can restrict which grefs can be derived, here for example we make `myder` only available on `indt` (inductive types, and not definitions or constructors). `Prefix` is a string, typically passed to the main code. The the `(derive ...)` tuple carrier the name of the derivation, already used in `dep1` and two predicates, one to run the derivation and one to test if the derivation was already run. The types for `dep1`, `derivation` and `derive` are declared in `derive_hook.elpi`. Finally, one is expected to `Import` the `myder.v` file in a derivation group, for example `better_std.v` would look like so: ```coq From elpi.apps Require Export derive. From elpi.apps Require Export derive.map derive.lens derive.lens_laws ... myder (* new derivation *) . Elpi Typecheck derive. ``` So when the user `Import`s `better_std` he gets a fully loaded `derive`. The code of the derivation must be put in a namespace. So `myder.elpi` should look like so ```elpi namespace derive.myder { pred main i:gref, i:string, o:list prop. main GR Prefix Clauses :- std.do! [ ... % synthesize Body and Type Name is Prefix ^ "myconcept", coq.ensure-fresh-global-id Name FName, coq.env.add-const FName Body Type _ C, Clauses = [myder-done GR, myder GR (const C)], std.forall Clauses (x\ coq.elpi.accumulate _ "derive.myder.db" (clause _ _ x) ), ]. } ``` It is important that all clauses added to the database are also returned (see the last argument of `main`). Derive runs all derivations at once and databases are updated only when the program ends. So derive will assume, with `=>`, the clauses generated by one derivation before running the nest one. coq-elpi-2.1.0/apps/derive/_CoqProject000066400000000000000000000017471460156013500176110ustar00rootroot00000000000000# Hack to see Coq-Elpi even if it is not installed yet -Q ../../theories elpi -I ../../src -docroot elpi.apps -R theories elpi.apps -Q elpi elpi.apps.derive -R tests elpi.apps.derive.tests -R examples elpi.apps.derive.examples theories/derive.v theories/derive/std.v theories/derive/legacy.v theories/derive/experimental.v theories/derive/bcongr.v theories/derive/cast.v theories/derive/eq.v theories/derive/eqcorrect.v theories/derive/eqK.v theories/derive/eqOK.v theories/derive/map.v theories/derive/isK.v theories/derive/idx2inv.v theories/derive/invert.v theories/derive/projK.v theories/derive/param1.v theories/derive/param1_functor.v theories/derive/param1_congr.v theories/derive/param1_trivial.v theories/derive/param2.v theories/derive/induction.v theories/derive/lens.v theories/derive/lens_laws.v theories/derive/eqb_core_defs.v theories/derive/tag.v theories/derive/fields.v theories/derive/eqb.v theories/derive/eqbcorrect.v theories/derive/eqbOK.v theories/derive/eqType_ast.v coq-elpi-2.1.0/apps/derive/_CoqProject.test000066400000000000000000000014211460156013500205540ustar00rootroot00000000000000# Hack to see Coq-Elpi even if it is not installed yet -Q ../../theories elpi -I ../../src -R theories elpi.apps -R tests elpi.apps.derive.tests -R examples elpi.apps.derive.examples tests/test_readme.v tests/test_derive_stdlib.v tests/test_bcongr.v tests/test_derive.v tests/test_eq.v tests/test_eqK.v tests/test_eqOK.v tests/test_map.v tests/test_isK.v tests/test_projK.v tests/test_param1.v tests/test_param1_functor.v tests/test_param1_congr.v tests/test_param1_trivial.v tests/test_param2.v tests/test_induction.v tests/test_invert.v tests/test_idx2inv.v tests/test_eqcorrect.v tests/test_lens.v tests/test_lens_laws.v tests/test_tag.v tests/test_fields.v tests/test_eqb.v tests/test_eqbcorrect.v tests/test_eqbOK.v tests/test_eqType_ast.v examples/usage.v examples/readme.vcoq-elpi-2.1.0/apps/derive/derive.svg000066400000000000000000001620751460156013500174570ustar00rootroot00000000000000 image/svg+xml eqOK induction eqK eq param1 projK bcongr injection isK discriminate eqcorrect param1functor param1congr param1inhab param1trivial coq-elpi-2.1.0/apps/derive/elpi/000077500000000000000000000000001460156013500163765ustar00rootroot00000000000000coq-elpi-2.1.0/apps/derive/elpi/bcongr.elpi000066400000000000000000000114021460156013500205210ustar00rootroot00000000000000 /* Boolean congruence lemmas */ /* license: GNU Lesser General Public License Version 2.1 or later */ /* ------------------------------------------------------------------------- */ shorten std.{nth, map2, assert!, rev, do!}. namespace derive.bcongr { %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % take in input all hyps % links an assumption to the two terms being compared and the boolean value % for them: forall x y b (H : reflext (x = y) b), ----> (arg H x y b) type arg term -> term -> term -> term -> arg. pred bo-args i:term, i:term, i:term, i:list arg, o:term. bo-args (prod N S T) K1 K2 Hs (fun `x` S x\ fun `y` S y\ fun `b` {{bool}} b\ R x y b) :- !, @pi-decl `x` S x\ @pi-decl `y` S y\ @pi-decl `b` {{ Coq.Init.Datatypes.bool }} b\ @pi-decl Hn (TH x y b) h\ do! [ TH x y b = {{ lib:elpi.reflect (lib:@elpi.eq lp:S lp:x lp:y) lp:b }}, R x y b = (fun `h` (TH x y b) h\ Body x y b h), coq.name-suffix `h` N Hn, bo-args (T x) {coq.mk-app K1 [x]} {coq.mk-app K2 [y]} [arg h x y b|Hs] (Body x y b h) ]. bo-args T K1 K2 HsRev Bo :- (T = global (indt _) ; T = app[global (indt _)|_]), !, rev HsRev Hs, mk-conj Hs Conj, Concl = {{ lib:elpi.reflect (lib:@elpi.eq lp:T lp:K1 lp:K2) lp:Conj }}, elim-all 0 Hs Concl Bo. bo-args T K1 K2 HsRev Bo :- whd1 T T1, !, bo-args T1 K1 K2 HsRev Bo. pred mk-conj i:list arg, o:term. mk-conj [] {{ lib:elpi.true }}. mk-conj [arg _ _ _ X] X :- !. mk-conj [arg _ _ _ X|XS] {{ lib:elpi.andb lp:X lp:C }} :- mk-conj XS C. %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % we case split on each and every assumption (arg H _ _ _) pred elim-all i:int, i:list arg, o:term, o:term. elim-all _ [] {{ lib:elpi.reflect lp:P lp:_}} {{ lib:elpi.ReflectT lp:P (lib:@elpi.erefl lp:T lp:LHS) }} :- coq.safe-dest-app P _ [T,LHS,_]. elim-all N [arg H X Y B|Hs] P R :- decl H _ TH, (pi x b\ copy Y x => copy B b => copy P (Pxb x b)), !, coq.build-match H TH (otyR Pxb Y) (branchR Pxb X Y N Hs) R. pred otyR i:(term -> term -> term), i:term, i:term, i:list term, i:list term, o:term. otyR F X _ [Idx,_] _ R :- R = F X Idx. %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Two branch per hyp: ReflectT or ReflectF % we continue pred branchR i:(term -> term -> term), i:term, i:term, i:int, i:list arg, i:term ,i:term, i:list term, i:list term, o:term. branchR Pxb X _ N Hs K _ [E] [ET] R :- coq.safe-dest-app K {{ lib:elpi.ReflectT }} _, !, coq.build-match E ET (otyE Pxb {{ lib:elpi.true}}) (branchE (Pxb X {{ lib:elpi.true }}) N Hs) R. % we stop, emit ReflectF and prove false via injection branchR Pxb _ Y N _ K _ [NE] [_] R :- coq.safe-dest-app K {{ lib:elpi.ReflectF }} _, !, Pxb Y {{ lib:elpi.false}} = {{ lib:elpi.reflect lp:P lp:_ }}, R = {{ lib:elpi.ReflectF lp:P lp:PNE }}, PNE = (fun `h` P h\ app[NE, Inj h]), @pi-decl `h` P h\ do! [ ltac.injection h P _ (PEs h), nth N (PEs h) (Inj h) ]. pred branchE i:term, i:int, i:list arg, i:term ,i:term, i:list term, i:list term, o:term. branchE P N Hs _ _ [] [] R :- M is N + 1, elim-all M Hs P R. pred otyE i:(term -> term -> term), i:term, i:term, i:list term, i:list term, o:term. otyE F B _ [X,_] _ R :- R = F X B. %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % we take in input all parameters pred bo-param i:int, i:term, i:term, o:term. bo-param 0 K T R :- !, bo-args T K K [] R. bo-param N K (prod Name Src T) (fun Name Src T1) :- N > 0, !, M is N - 1, @pi-decl Name Src x\ bo-param M {coq.mk-app K [x]} (T x) (T1 x). bo-param N K T R :- whd1 T T1, !, bo-param N K T1 R. %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % for each constructor we generate the congruence lemma pred main-constructor i:int, i:string, i:constructor, i:term, o:prop. main-constructor Lno Prefix K Kt Clause :- do! [ Kn = global (indc K), % we build the comparison function bo-param Lno Kn Kt R, std.assert-ok! (coq.typecheck R RT) "derive.bcongr generates illtyped term", Name is Prefix ^ "bcongr_" ^ {coq.gref->id (indc K)}, coq.ensure-fresh-global-id Name FName, coq.env.add-const FName R RT @opaque! Cong, % we register it as a clause Clause = (bcongr-db K (global (const Cong)) :- !), coq.elpi.accumulate _ "derive.bcongr.db" (clause _ (before "bcongr-db:fail") Clause) ]. %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% pred main i:inductive, i:string, o:list prop. main GR Prefix Clauses :- do! [ coq.env.indt GR Ind Lno _ _ Kns Ktys, assert! (Ind = tt) "derive.bcongr: Coinductive types are not supported", map2 Kns Ktys (main-constructor Lno Prefix) Clauses ]. } % vim: set spelllang=: coq-elpi-2.1.0/apps/derive/elpi/cast.elpi000066400000000000000000000035701460156013500202100ustar00rootroot00000000000000/* Type cast using an equation */ /* license: GNU Lesser General Public License Version 2.1 or later */ /* ------------------------------------------------------------------------- */ shorten std.{append, rev, any->string, last, take}. namespace derive.cast { namespace aux { arity [] _ (sort (typ U)) :- coq.univ.new U. arity [V|VS] Acc (prod `x` T R) :- coq.mk-app V {rev Acc} T, pi x\ arity VS [x|Acc] (R x). args [] [X|_] X. args [V|VS] Acc (fun `c` S R) :- coq.mk-app V {rev Acc} S, pi c\ args VS [c|Acc] (R c). arg _ _ _ _ _ [] _ []. arg I E X Y Ps [V|VS] Acc [R|RS] :- cast-db I T, take {calc (I )} Ps PsI, coq.mk-app T {append {append PsI [X,Y,E]} {append {rev Acc} [V]}} R, J is I + 1, arg J E X Y Ps VS [V|Acc] RS. args-ty E X Y Ps [] [_|Acc] R :- last Ps V, rev Acc [_|Vars], arg 2 E X Y Ps Vars [] CastedVars, coq.mk-app V [X|CastedVars] R. args-ty E X Y Ps [V|VS] Acc (prod `c` S R) :- coq.mk-app V {rev Acc} S, pi c\ args-ty E X Y Ps VS [c|Acc] (R c). body I J V (fun Name T R) :- I > 0, !, coq.name-suffix `A` {calc (J - I)} Name, I1 is I - 1, arity {rev V} [] T, pi x\ body I1 J [x|V] (R x). body 0 _ V R :- rev V [A|Rest], Ety = (x\y\ {{ @eq lp:A lp:x lp:y }}), R = {{ fun (x y : lp:A) (e : lp:(Ety x y)) => lp:(Bo x y e) }}, pi x y e\ coq.build-match e (Ety x y) (rty A Rest x) (body-branch Rest x) (Bo x y e). rty A Rest X _ [Y,E] _ R :- args-ty E X Y [A|Rest] Rest [Y] R. body-branch Rest Y _ _ _ _ R :- args Rest [Y] R. } pred main i:int. main N :- Name is "cast" ^ {any->string N}, aux.body N N [] Bo, std.assert-ok! (coq.typecheck Bo Ty) "derive.cast generates illtyped term", coq.env.add-const Name Bo Ty _ C, coq.elpi.accumulate _ "derive.cast.db" (clause _ _ (cast-db N (global (const C)))). } coq-elpi-2.1.0/apps/derive/elpi/derive.elpi000066400000000000000000000146121460156013500205330ustar00rootroot00000000000000/* Entry point for all derivations */ /* license: GNU Lesser General Public License Version 2.1 or later */ /* ------------------------------------------------------------------------- */ namespace derive { pred exists-indc i:inductive, i:(constructor -> prop). exists-indc I P :- coq.env.indt I _ _ _ _ KL _, std.exists KL P. pred if-verbose i:prop. if-verbose P :- (get-option "verbose" tt ; get-option "recursive" tt), !, P. if-verbose _. pred dep o:string, o:string. dep X Y :- dep1 X Y. dep X Y :- dep1 X Z, dep Z Y. pred selected i:string. selected Name :- get-option "only" Map, !, Map => (get-option Name _; (get-option X _, dep X Name)). selected _. pred validate-only i:gref, i:list derive. validate-only T LD :- get-option "only" Map, !, std.forall Map (known-option T LD). validate-only _ _. pred known-option i:gref, i:list derive, i:prop. known-option T L (get-option X _) :- if (std.mem! L (derive X _ _)) true (coq.error "Derivation" X "unknown or not applicable to input" T). pred chain i:gref, i:list derive, o:list prop. chain _ [] []. chain T [derive Name _ _|FS] CL :- not(selected Name), !, if-verbose (coq.say "Skipping derivation" Name "on" T "since the user did not select it"), chain T FS CL. chain T [derive Name _ AlreadyDone|FS] CL :- (pi x\ stop x :- !, fail) => AlreadyDone, !, if-verbose (coq.say "Skipping derivation" Name "on" T "since it has been already run"), chain T FS CL. chain T [derive Name F _|FS] CL :- get-option "only" _, !, % request this one if-verbose (coq.say "Derivation" Name "on" T), @dropunivs! => std.time (F C) Time, if-verbose (coq.say "Derivation" Name "on" T "took" Time), C => chain T FS CS, std.append C CS CL. chain T [derive Name F _|FS] CL :- % all are selected, we can fail if-verbose (coq.say "Derivation" Name "on" T), (pi x\ stop x :- !, fail) => @dropunivs! => std.time (F C) Time, !, if-verbose (coq.say "Derivation" Name "on" T "took" Time), C => chain T FS CS, std.append C CS CL. chain T [derive F _ _|FS] CL :- if-verbose (coq.say "Derivation" F "on" T "failed, continuing"), chain T FS CL. pred toposort i:list derive, o:list derive. toposort L SL :- std.findall (dep1 _ _) Deps, topo L Deps SL. pred std.partition i:list A, i:(A -> prop), o:list A, o:list A. std.partition [] _ [] []. std.partition [X|XS] P [X|R] L :- P X, !, std.partition XS P R L. std.partition [X|XS] P R [X|L] :- std.partition XS P R L. pred not-a-src i:list prop, i:derive. not-a-src Deps (derive A _ _) :- not(std.mem! Deps (dep1 A _)). pred tgt-is-not-in i:list derive, i:prop. tgt-is-not-in [] _. tgt-is-not-in [derive Tgt _ _|_] (dep1 _ Tgt) :- !, fail. tgt-is-not-in [_|L] D :- tgt-is-not-in L D. pred topo i:list derive, i:list prop, o:list derive. topo [] _ [] :- !. topo L Deps SL :- std.partition L (not-a-src Deps) LNoDeps Other, if (LNoDeps = []) (coq.error "derive: no topological order:" L Deps) true, std.filter Deps (tgt-is-not-in LNoDeps) NewDeps, topo Other NewDeps SOther, std.append LNoDeps SOther SL. pred export? i:prop, o:prop. export? (export M) (coq.env.export-module M). pred indt-or-const i:gref. indt-or-const (indt _). indt-or-const (const _). pred main i:gref, o:list prop. main GR CL :- get-option "module" M, !, if (M = "") (coq.gref->id GR Mod) (Mod = M), if-verbose (coq.say "Starting module" Mod), coq.env.begin-module Mod none, main-derive GR tt CL, coq.env.end-module _. main GR CL :- main-derive GR ff CL. pred main-derive i:gref, i:bool, o:list prop. main-derive GR InModule CL :- get-option "recursive" tt, !, coq.env.dependencies GR _ AllDeps, coq.gref.set.elements AllDeps AllDepsL, std.filter AllDepsL indt-or-const Deps, main.aux InModule Deps [] CL1, CL1 => main1 GR InModule CL2, std.append CL1 CL2 CL. main-derive GR InModule CL :- main1 GR InModule CL. pred main.aux i:bool, i:list gref, i:list prop, o:list prop. main.aux _ [] X X. main.aux InModule [GR|GRS] Acc CL :- (pi X\get-option "only" X :- !, fail) => Acc => main-derive GR InModule CL1, main.aux InModule GRS {std.append CL1 Acc} CL. pred validate-recursive i:prop, o:derive. validate-recursive (derivation _ _ tt _) _ :- get-option "recursive" tt, coq.error "Synterp actions not supported in recursive derive.". validate-recursive (derivation _ _ _ R) R. pred main1 i:gref, i:bool, o:list prop. main1 GR InModule CL :- if (get-option "prefix" PFX) (Prefix = PFX) (if (InModule is ff) (Prefix is {coq.gref->id GR} ^ "_") (Prefix = "")), std.findall (derivation GR Prefix _ _) L, if (L = []) (coq.error "no derivation found, did you Import derive.std?") true, std.map L validate-recursive DL, validate-only GR DL, toposort DL SortedDL, chain GR SortedDL CL. pred decl+main i:string, i:indt-decl. decl+main TypeName DS :- std.do! [ if (get-option "module" M) (if (M = "") (ModName = TypeName) (ModName = M), HasModule = tt) (HasModule = ff), if (HasModule = tt) (if-verbose (coq.say "Starting module" ModName), coq.env.begin-module ModName none) true, std.assert-ok! (coq.elaborate-indt-decl-skeleton DS D) "Inductive type declaration illtyped", if-verbose (coq.say "Declaring inductive" D), coq.env.add-indt D I, if-verbose (coq.say "Deriving"), main-derive (indt I) HasModule CL, if-verbose (coq.say "Done"), if (HasModule = tt) (coq.env.end-module _, decl+main.post TypeName I DS CL) check-no-no-alias ]. pred check-no-no-alias. check-no-no-alias :- get-option "no_alias" tt, !, coq.error "The no_alias attribute only has an effect when a wrapper module is generated.". check-no-no-alias. pred decl+main.post i:string, i:inductive, i:indt-decl, o:list prop. decl+main.post TypeName I DS CL :- std.do! [ coq.env.indt I _ _ _ _ KS _, std.map KS (k\r\ r = indc k) KGRS, std.map KGRS coq.gref->id KNS, std.map KGRS (gr\r\ r = global gr) KTS, std.forall2 [TypeName|KNS] [global (indt I)|KTS] short-alias, coq.indt-decl->implicits DS IndImpls KsImpls, if (coq.any-implicit? IndImpls) (@global! => coq.arguments.set-implicit (indt I) [IndImpls]) true, std.forall2 KsImpls KS (i\k\ if (coq.any-implicit? i) (@global! => coq.arguments.set-implicit (indc k) [i]) true ), std.map-filter CL export? P, std.do! P, ]. pred short-alias i:id, i:term. short-alias _ _ :- get-option "no_alias" tt, !, true. short-alias ID T :- @global! => coq.notation.add-abbreviation ID 0 T ff _. } coq-elpi-2.1.0/apps/derive/elpi/derive_hook.elpi000066400000000000000000000006511460156013500215510ustar00rootroot00000000000000/* Entry point for derive extensions */ /* license: GNU Lesser General Public License Version 2.1 or later */ /* ------------------------------------------------------------------------- */ pred derivation i:gref, i:string, o:bool, o:derive. pred export i:modpath. pred dep1 o:string, o:string. kind derive type. type derive string -> (list prop -> prop) -> prop -> derive. coq-elpi-2.1.0/apps/derive/elpi/derive_synterp.elpi000066400000000000000000000047321460156013500223210ustar00rootroot00000000000000/* Entry point for all derivations */ /* license: GNU Lesser General Public License Version 2.1 or later */ /* ------------------------------------------------------------------------- */ namespace derive { pred dep o:string, o:string. dep X Y :- dep1 X Y. dep X Y :- dep1 X Z, dep Z Y. pred selected i:string. selected Name :- get-option "only" Map, !, Map => (get-option Name _; (get-option X _, dep X Name)). selected _. pred chain i:string, i:list derive. chain _ []. chain T [derive Name _ _|FS] :- not(selected Name), !, chain T FS. chain T [derive _ _ AlreadyDone|FS] :- (pi x\ stop x :- !, fail) => AlreadyDone, !, chain T FS. chain T [derive _ F _|FS] :- get-option "only" _, !, % request this one F _, chain T FS. chain T [derive _ F _|FS] :- % all are selected, we can fail (pi x\ stop x :- !, fail) => F _, !, chain T FS. chain T [derive _ _ _|FS] :- chain T FS. pred toposort i:list derive, o:list derive. toposort L SL :- std.findall (dep1 _ _) Deps, topo L Deps SL. pred std.partition i:list A, i:(A -> prop), o:list A, o:list A. std.partition [] _ [] []. std.partition [X|XS] P [X|R] L :- P X, !, std.partition XS P R L. std.partition [X|XS] P R [X|L] :- std.partition XS P R L. pred not-a-src i:list prop, i:derive. not-a-src Deps (derive A _ _) :- not(std.mem! Deps (dep1 A _)). pred tgt-is-not-in i:list derive, i:prop. tgt-is-not-in [] _. tgt-is-not-in [derive Tgt _ _|_] (dep1 _ Tgt) :- !, fail. tgt-is-not-in [_|L] D :- tgt-is-not-in L D. pred topo i:list derive, i:list prop, o:list derive. topo [] _ [] :- !. topo L Deps SL :- std.partition L (not-a-src Deps) LNoDeps Other, if (LNoDeps = []) (coq.error "derive: no topological order:" L Deps) true, std.filter Deps (tgt-is-not-in LNoDeps) NewDeps, topo Other NewDeps SOther, std.append LNoDeps SOther SL. pred main i:string. main TypeName :- get-option "module" M, !, if (M = "") (Mod = TypeName) (Mod = M), coq.env.begin-module Mod none, main-derive TypeName tt, coq.env.end-module _. main TypeName :- main-derive TypeName ff. pred main-derive i:string, i:bool. main-derive TypeName InModule :- main1 TypeName InModule. pred main1 i:string, i:bool. main1 TypeName InModule :- if (get-option "prefix" PFX) (Prefix = PFX) (if (InModule is ff) (Prefix is TypeName ^ "_") (Prefix = "")), std.findall (derivation TypeName Prefix _) L, std.map L (x\r\ x = derivation _ _ r) DL, toposort DL SortedDL, chain TypeName SortedDL. } coq-elpi-2.1.0/apps/derive/elpi/derive_synterp_hook.elpi000066400000000000000000000006431460156013500233360ustar00rootroot00000000000000/* Entry point for derive extensions */ /* license: GNU Lesser General Public License Version 2.1 or later */ /* ------------------------------------------------------------------------- */ pred derivation i:string, i:string, o:derive. pred export i:modpath. pred dep1 o:string, o:string. kind derive type. type derive string -> (list prop -> prop) -> prop -> derive. coq-elpi-2.1.0/apps/derive/elpi/discriminate.elpi000066400000000000000000000024461460156013500217320ustar00rootroot00000000000000/* core of discriminate */ /* license: GNU Lesser General Public License Version 2.1 or later */ /* ------------------------------------------------------------------------- */ shorten std.{ do! }. namespace ltac { % Tests if the command can be applied pred discriminate? i:term, i:inductive, o:list term, o:constructor, o:term, o:term. discriminate? Ty GR Args GRA A B :- do! [ whd Ty [] {{lib:@elpi.eq}} [T,A,B], whd T [] (global (indt GR)) Args, whd A [] (global (indc GRA)) _, whd B [] (global (indc GRB)) _, not(GRA = GRB) ]. % Does the job pred discriminate! i:term, i:term, o:term, i:inductive, i:list term, i:constructor, i:term, i:term. discriminate! H G PG GR Args GRA A B :- do! [ isK-db GRA IsKA, coq.mk-app IsKA Args IsKAArgs, Eq_isKA_isKB = app[{{lib:elpi.derive.eq_f}},app[global (indt GR)|Args],{{lib:elpi.bool}},IsKAArgs,A,B,H], PG = app[{{lib:elpi.bool_discr}},Eq_isKA_isKB,G] ]. pred discriminate i:term, i:term, i:term, o:term. discriminate H EqAB G PG :- if (discriminate? EqAB GR Args GRA A B) (discriminate! H G PG GR Args GRA A B) (coq.error "discriminate: the equation" {coq.term->string H} "of type" {coq.term->string EqAB} "is trivial at the top level"). } % vim:set ft=lprolog spelllang=: coq-elpi-2.1.0/apps/derive/elpi/eq.elpi000066400000000000000000000155061460156013500176650ustar00rootroot00000000000000/* Boolean comparison functions */ /* license: GNU Lesser General Public License Version 2.1 or later */ /* ------------------------------------------------------------------------- */ shorten std.{assert!, do!, append}. namespace derive.eq { %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Fills in the matrix with the truth values pred body i:term, i:list term, i:list term, % constructor, arguments and their types i:term, i:list term, i:list term, % constructor, arguments and their types o:term. %result :name "derive.eq.body:begin" % Extension point (e.g. to skip a subterm) body K [] _ K [] _ R :- !, % no arguments, same constructor R = {{ true }}. body K [X] [T1] K [Y] [T2] R :- !, % special case to avoid ".. && true" eq-db T1 T2 F, coq.mk-app F [X,Y] R. body K [X|XS] [T1|TS1] K [Y|YS] [T2|TS2] R :- !, % compare X with Y eq-db T1 T2 F, coq.mk-app F [X,Y] RX, % compare XS with YS body K XS TS1 K YS TS2 RXS, R = {{ (lp:RX && lp:RXS)%bool }}. body _ _ _ _ _ _ R :- !, % outside the diagonal it is always false R = {{ false }}. %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Build the body pred bo-idx i:prop, % eq-db clause for the current type (applied to params) i:term, % inductive type (applied to params) for the first argument i:term, % arity left for the first argument i:term, % inductive type (applied to params) for the second argument i:term, % arity left for the second argument i:int, % accumulator to set Recno o:int, % Recno o:term, % Type of the term being built o:term. % Term buing built bo-idx C Ity1 (prod _ Src1 Tgt1) Ity2 (prod _ Src2 Tgt2) N M Rty R :- !, coq.name-suffix `i` 1 I1, coq.name-suffix `i` 2 I2, R = (fun I1 Src1 i\ fun I2 Src2 j\ Rrec i j), Rty = (prod I1 Src1 i\ prod I2 Src2 j\ Rtyrec i j), quantify-eq-db-idx C Crec, pi x y\ decl x `i` Src1 => decl y `j` Src2 => bo-idx Crec {coq.mk-app Ity1 [x]} (Tgt1 x) {coq.mk-app Ity2 [y]} (Tgt2 y) {calc (N + 2)} M (Rtyrec x y) (Rrec x y). bo-idx C Ity1 (sort _) Ity2 (sort _) N N Rty R :- !, Rty = {{ lp:Ity1 -> lp:Ity2 -> bool }}, R = {{ fun (x1 : lp:Ity1) (x2 : lp:Ity2) => lp:(Bo x1 x2) }}, pi x1 x2\ decl x1 `a` Ity1 => decl x2 `b` Ity2 => C => bo-matrix x1 Ity1 x2 Ity2 (Bo x1 x2). bo-idx C Ity1 X Ity2 Y N M Rty R :- whd1 X X1, whd1 Y Y1, !, bo-idx C Ity1 X1 Ity2 Y1 N M Rty R. pred bo-matrix i:term, i:term, i:term, i:term, o:term. bo-matrix X1 TyX1 X2 TyX2 R :- coq.build-match X1 TyX1 bo-ty (k1\ _\ a1\ ty1\ coq.build-match X2 TyX2 bo-ty (k2\ _\ a2\ ty2\ body k1 a1 ty1 k2 a2 ty2)) R. pred bo-ty i:term, i:list term, i:list term, o:term. bo-ty _ _ _ {{ bool }}. % Take in input all parameters and their comparison function %%%%%%%%%%%%%% pred bo-param i:int, % Number of parameters, recursion fuel i:term, % Inductive type (applied to all parameters taken in input) i:term, % Inductive type arity (parameters + indexes) o:term. % Comparison function bo-param 0 Ity Arity R :- coq.safe-dest-app Ity (global (indt GR)) _, coq.env.recursive? GR, !, Boidx = fix `f` Recno Rty Rbo, (pi f\ decl f `f` Rty => % We build the body (assuming the indexes are *not* the same) bo-idx (eq-db Ity Ity f :- []) Ity Arity Ity Arity 0 Recno Rty (Rbo f)), % We then pass to the body the terms with their indexes (that are the same) apply-idx Ity Arity Boidx R. bo-param 0 Ity Arity R :- !, bo-idx (pi f\eq-db Ity Ity f :- fail) Ity Arity Ity Arity 0 _ _ Boidx, apply-idx Ity Arity Boidx R. bo-param N Ity (prod _ Sty Rty) R :- !, M is N - 1, R = {{ fun (A : lp:Sty) (eqA : A -> A -> bool) => lp:(Bo A eqA) }}, pi a f\ sigma ItyA\ coq.mk-app Ity [a] ItyA, eq-db a a f => decl a `a` Sty => decl f `f` {{ lp:a -> lp:a -> bool }} => bo-param M ItyA (Rty a) (Bo a f). bo-param N Ity X R :- whd1 X X1, !, bo-param N Ity X1 R. pred apply-idx i:term, % Ity applied to parameters i:term, % Arity remaining after parameters i:term, % Bo comparison with potentially different indexes as per bo-idx o:term. % fun idx1 idx2 (x1 : Ity ixd1) (x2 : Ity idx2) => Bo idx1 x1 idx2 x2 apply-idx _ (sort _) Bo Bo :- !. % no indexes -> avoid eta expansion of Bo apply-idx Ity Arity Bo R :- apply-idx.aux Ity Arity Bo R. apply-idx.aux Ity (prod N S T) Bo (fun N S x\ R x) :- !, pi x\ apply-idx.aux {coq.mk-app Ity [x]} (T x) {coq.mk-app Bo [x,x]} (R x). apply-idx.aux Ity (sort _) Bo (fun `x1` Ity x1\ fun `x2` Ity x2\ Bo1 x1 x2) :- !, pi x1 x2\ coq.mk-app Bo [x1,x2] (Bo1 x1 x2). apply-idx.aux Ity X Bo R :- whd1 X X1, !, apply-idx.aux Ity X1 Bo R. %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Builds a clause for eq-db that fits the inductive arity: % - a premise per type parameter % - a simple argument for each index % Also used to load the context under the fix pred quantify-eq-db-idx i:prop, o:prop. quantify-eq-db-idx (pi x y\ C x y) (pi x y\ C1 x y) :- pi x y\ quantify-eq-db-idx (C x y) (C1 x y). quantify-eq-db-idx (eq-db A B C :- L) (pi x y\ eq-db (A1 x) (B1 y) (C1 x y) :- L) :- pi x y\ coq.mk-app A [x] (A1 x), coq.mk-app B [y] (B1 y), coq.mk-app C [x,y] (C1 x y). pred quantify-eq-db-param i:prop, o:prop. quantify-eq-db-param (pi x f\ C x f) (pi x f\ C1 x f) :- pi x f\ quantify-eq-db-param (C x f) (C1 x f). quantify-eq-db-param (eq-db A B C :- L) (pi x f\ eq-db (A1 x) (B1 x) (C1 x f) :- L1 x f) :- pi x f\ append [eq-db x x f] L (L1 x f), coq.mk-app A [x] (A1 x), coq.mk-app B [x] (B1 x), coq.mk-app C [x,f] (C1 x f). pred mk-clause i:int, i:term, i:prop, o:prop. mk-clause Lno (prod _ _ Tx) C R :- Lno > 0, !, Lno1 is Lno - 1, quantify-eq-db-param C C1, pi x\ mk-clause Lno1 (Tx x) C1 R. mk-clause 0 (prod _ _ Tx) C R :- !, quantify-eq-db-idx C C1, pi x\ mk-clause 0 (Tx x) C1 R. mk-clause 0 (sort _) C C :- !. mk-clause N T A B :- whd1 T T1, !, mk-clause N T1 A B. %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% pred main i:inductive, i:string, o:list prop. main GR Name [Clause1, Clause2] :- do! [ coq.env.indt GR Ind Lno Luno Arity _ _, assert! (Ind = tt) "derive.eq: Coinductive types are not supported", assert! (Lno = Luno) "derive.eq: Non-uniform parameters not supported", % we build the comparison function bo-param Lno (global (indt GR)) Arity RSkel, std.assert-ok! (coq.elaborate-skeleton RSkel RT R) "derive.eq generates illtyped term", coq.env.add-const Name R RT _ Cmp, % we register it as a clause mk-clause Lno Arity (eq-db (global (indt GR)) (global (indt GR)) (global (const Cmp)) :- [!]) Clause1, coq.elpi.accumulate _ "derive.eq.db" (clause _ (before "eq-db:fail") Clause1), Clause2 = eq-for GR Cmp, coq.elpi.accumulate _ "derive.eq.db" (clause _ _ Clause2), ]. } % vim: set spelllang=: coq-elpi-2.1.0/apps/derive/elpi/eqK.elpi000066400000000000000000000075061460156013500200010ustar00rootroot00000000000000/* eq.axiom for each constructor */ /* license: GNU Lesser General Public License Version 2.1 or later */ /* ------------------------------------------------------------------------- */ shorten std.{assert!, do!, last, map2}. namespace derive.eqK { % links a term x, a comparison cmp, and H : eq_axiom cmp x pred axiom-db i:term, o:term, o:term. %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % case split on the second constructor % same constructor, we use the bcongr lemma pred branch i:term, i:term, i:term, i:list term, i:list term, i:term. branch K1 K2 _ V _ R :- coq.safe-dest-app K1 (global (indc GR)) Args1, coq.safe-dest-app K2 (global (indc GR)) LArgs2, !, do! [ bcongr-db GR Lem, call Lem Args1 LArgs2 V R, ]. % different constructor, ReflectF + discriminate branch K1 K2 T V _ R :- coq.safe-dest-app K2 _ _, !, do! [ coq.mk-app K2 V K2A, Eq = {{ lib:@elpi.eq lp:T lp:K1 lp:K2A }}, R = {{ lib:@elpi.ReflectF lp:Eq (fun abs : lp:Eq => lp:(Bo abs)) }}, (pi abs\ ltac.discriminate abs Eq {{ lib:elpi.False }} (Bo abs)), ]. pred call i:term, i:list term, i:list term, i:list term, o:term. call X [] [] [] X. call X [P|P1] [_|Q1] V R :- coq.mk-app X [P] XP, call XP P1 Q1 V R. call X [A|AS] [] [B|BS] R :- if (axiom-db A F P) true (M is "derive.eqK: no proved comparison for " ^ {coq.term->string A}, stop M), coq.mk-app X [A,B,{coq.mk-app F [A,B]},{coq.mk-app P [B]}] XAB, call XAB AS [] BS R. %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % bind the arguments of the constructor pred args i:term, i:term, o:term. args (prod _ S T) K R :- !, std.assert! (eq-db S S F) "derive.eqK: cannot find an eq test for constructor argument", R = (fun `x` S x\ fun `h` {{ lib:elpi.derive.eq_axiom_at lp:S lp:F lp:x }} (Bo x)), @pi-decl `x` S x\ @pi-decl `h` {{ lib:elpi.derive.eq_axiom_at lp:S lp:F lp:x }} h\ axiom-db x F h => args (T x) {coq.mk-app K [x]} (Bo x h). args T K (fun `x` T R) :- (T = global (indt _) ; T = app[global (indt _)|_]), !, eq-db T T Cmp, @pi-decl `x` T x\ coq.build-match x T (oty Cmp K) (branch K) (R x). args T K R :- whd1 T T1, !, args T1 K R. args T _ _ :- M is "derive.eqK: cannot find an eq test for " ^ {coq.term->string T}, stop M. pred oty i:term, i:term, i:term, i:list term, i:list term, o:term. oty Cmp K _ V VT R :- last V X, last VT T, R = {{ lib:elpi.derive.eq_axiom_on lp:T lp:Cmp lp:K lp:X }}. %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % For each parameter take in input a comparison function pred param i:int, i:term, i:term, o:term. param 0 T K R :- args T K R. param L (prod N S T) K R :- L > 0, !, R = (fun N S a\ fun `f` {{ lp:a -> lp:a -> bool }} (Bo a)), M is L - 1, @pi-decl N S a\ @pi-decl `f` {{ lp:a -> lp:a -> bool }} f\ eq-db a a f => param M (T a) {coq.mk-app K [a]} (Bo a f). %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % for each constructor we generate the case split lemma pred main-constructor i:int, i:string, i:constructor, i:term, o:prop. main-constructor Lno Prefix K Kty C :- do! [ assert! (bcongr-db K _) "derive.eqK: run derive.bcongr first", % generate the K-split lemma param Lno Kty (global (indc K)) RSkel, % add to the environment std.assert-ok! (coq.elaborate-skeleton RSkel RT R) "derive.eqK generates illtyped term", coq.gref->id (indc K) Kname, Name is Prefix ^ Kname, coq.env.add-const Name R RT @opaque! EqK, % add the clause to the db C = (eqK-db K (global (const EqK)) :- !), coq.elpi.accumulate _ "derive.eqK.db" (clause _ (before "eqK-db:fail") C) ]. pred main i:inductive, i:string, o:list prop. main GR Prefix Clauses :- coq.env.indt GR _ Lno _ _ Kns Ktys, map2 Kns Ktys (main-constructor Lno Prefix) Clauses. } coq-elpi-2.1.0/apps/derive/elpi/eqOK.elpi000066400000000000000000000030671460156013500201160ustar00rootroot00000000000000/* constant elimination */ /* license: GNU Lesser General Public License Version 2.1 or later */ /* ------------------------------------------------------------------------- */ shorten std.{assert!, do!}. namespace derive.eqOK { pred body i:int, i:term, i:term, i:term, o:term. body N (prod NA A a\ prod NF (A_eq a) (B a)) E TisT (fun NA A a\ fun NF (A_eq a) f\ fun `p` (PA a f) (B1 a f)) :- N > 0, !, M is N - 1, @pi-decl NA A a\ @pi-decl NF (A_eq a) f\ (PA a f = {{ lib:elpi.derive.eq_axiom lp:a lp:f }}, @pi-decl `p` (PA a f) p\ body M (B a f) {coq.mk-app E [a,f]} {coq.mk-app TisT [a, {{lib:elpi.derive.eq_axiom_at lp:a lp:f}}, p]} (B1 a f p)). % done body 0 (prod N S x\ prod _ _ _) E TisT (fun N S R) :- @pi-decl N S x\ R x = {{ lp:E lp:x (lp:TisT lp:x) }}. pred main i:inductive, i:string, o:list prop. main GR O [eqOK-done GR] :- do! [ T = global (indt GR), coq.env.indt GR _ Lno _ _ _ _, assert! (eqcorrect-db (indt GR) E) "derive.eqOK: use derive.eqcorrect before", coq.env.typeof {coq.term->gref E} ETy, assert! (reali T IsT) "derive.eqOK: use derive.param1 before", assert! (param1-inhab-db IsT TisT) "derive.eqOK: use derive.param1.inhab before", body Lno ETy E TisT NewBo, %coq.say {coq.term->string NewBo}, std.assert-ok! (coq.typecheck NewBo NewTy) "derive.eqOK generates illtyped term", coq.env.add-const O NewBo NewTy @opaque! _, coq.elpi.accumulate _ "derive.eqOK.db" (clause _ _ (eqOK-done GR)), ]. } coq-elpi-2.1.0/apps/derive/elpi/eqType.elpi000066400000000000000000000150211460156013500205170ustar00rootroot00000000000000/* eqType representation and validation */ /* license: GNU Lesser General Public License Version 2.1 or later */ /* ------------------------------------------------------------------------- */ namespace derive.eqType.ast { pred translate-indt i:inductive, o:eqType, o:diagnostic. translate-indt I O D :- coq.env.indt-decl I Decl, coq.env.indt I _ _ _ _ KN _, translate-param Decl I KN O D. pred translate-param i:indt-decl, i:inductive, i:list constructor, o:eqType, o:diagnostic. translate-param (parameter ID _ Ty F) I KS (type-param F1) D :- whd Ty [] {{ Type }} _, !, @pi-parameter ID Ty x\ pi y\ term->trm x y ok => translate-param (F x) I KS (F1 y) D. translate-param (parameter ID _ Ty F) I KS (value-param Ty1 F1) D :- term->trm Ty Ty1 ok, !, @pi-parameter ID Ty x\ pi y\ term->trm x y ok => translate-param (F x) I KS (F1 y) D. translate-param (parameter ID _ _ _) _ _ _ (error S) :- S is "unsupported parameter " ^ ID. translate-param (inductive ID tt (arity (sort S)) F) I KS (inductive I F1) D :- @pi-inductive ID (arity (sort S)) x\ pi y\ term->trm x y ok => translate-constructors (F x) KS (F1 y) D. translate-param (record _ _ _ F) I [K] (inductive I (y\ [constructor K (F1 y)])) D :- !, pi y\ self y => translate-record-constructor F (F1 y) D. translate-param _ _ _ _ (error S) :- S is "unsupported inductive arity". pred translate-constructors i:list indc-decl, i:list constructor, o:list constructor, o:diagnostic. translate-constructors [] [] [] ok. translate-constructors [constructor _ A|KS] [K|KK] [constructor K Args|KS1] D :- std.do-ok! D [ translate-arguments {coq.arity->term A} Args, translate-constructors KS KK KS1, ]. pred translate-arguments i:term, o:arguments, o:diagnostic. translate-arguments T T2 D :- whd1 T T1, !, translate-arguments T1 T2 D. translate-arguments (prod N Ty F) (irrelevant Ty1 F1) D :- not(pi x\ occurs x (F x)), irrelevant? Ty Ty1 ok, !, @pi-decl N Ty x\ translate-arguments (F x) F1 D. translate-arguments (prod N Ty F) (regular Ty1 F1) D :- not(pi x\ occurs x (F x)), !, std.do-ok! D [ term->trm Ty Ty1, (d\ @pi-decl N Ty x\ translate-arguments (F x) F1 d), ]. translate-arguments (prod N Ty F) (dependent Ty1 F1) D :- !, std.do-ok! D [ term->trm Ty Ty1, (d\ @pi-decl N Ty x\ pi y\ term->trm x y ok => translate-arguments (F x) (F1 y) d), ]. translate-arguments Ty (stop Ty1) D :- name Ty, term->trm Ty Ty1 D. translate-arguments (app [N|_] as Ty) (stop Ty1) D :- name N, term->trm Ty Ty1 D. translate-arguments T _ (error S) :- S is "unsupported argument " ^ {coq.term->string T}. pred translate-record-constructor i:record-decl, o:arguments, o:diagnostic. translate-record-constructor end-record (stop X) ok :- self X. translate-record-constructor (field _ ID Ty F) (irrelevant Ty1 F1) D :- not(pi x\ occurs x (F x)), irrelevant? Ty Ty1 ok, !, @pi-parameter ID Ty x\ translate-record-constructor (F x) F1 D. translate-record-constructor (field _ ID Ty F) (regular Ty1 F1) D :- not(pi x\ occurs x (F x)), !, std.do-ok! D [ term->trm Ty Ty1, (d\ @pi-parameter ID Ty x\ translate-record-constructor (F x) F1 d), ]. translate-record-constructor (field _ ID Ty F) (dependent Ty1 F1) D :- !, std.do-ok! D [ term->trm Ty Ty1, (d\ @pi-parameter ID Ty x\ pi y\ term->trm x y ok => translate-record-constructor (F x) (F1 y) d), ]. translate-record-constructor (field _ ID _ _) _ (error S) :- S is "unsupported record field " ^ ID. pred self o:trm. pred valid i:trm, o:diagnostic. valid {{ PrimInt63.int }} ok :- !. valid (global (indt I)) ok :- eqType I _, !. valid (app (indt I) A Args) D :- eqType I EQT, !, valid-eqType EQT [A|Args] D. valid T (error S) :- S is "not an eqType: " ^ {std.any->string T}. pred valid-eqType i:eqType, i:list trm, o:diagnostic. valid-eqType (inductive _ _) [] ok. valid-eqType (type-param F) [T|TS] D :- std.do-ok! D [ valid T, (d\ pi x\ valid-eqType (F x) TS d), ]. valid-eqType (value-param _ F) [_|TS] D :- std.do-ok! D [ (d\ pi x\ valid-eqType (F x) TS d), ]. pred irrelevant? i:term, o:trm, o:diagnostic. irrelevant? (app [{{ @eq }}, global (indt EqType), A, B]) (app EQ EQTYPE [A1,B1]) D :- std.do-ok! D [ std.lift-ok (eqType EqType _) "Not an eqType", %eqb-for Bool Bool _, std.lift-ok ({{ @eq }} = global EQ) "", term->trm (global (indt EqType)) EQTYPE, term->trm A A1, term->trm B B1, ]. irrelevant? T R D :- whd1 T T1, coq.say "whd" T T1, irrelevant? T1 R D. pred term->trm i:term, o:trm, o:diagnostic. term->trm (global GR) (global GR) ok :- !. term->trm (app [global GRF,A|As]) (app GRF A1 As1) D :- !, std.do-ok! D [ term->trm A A1, map-ok! As term->trm As1, ]. term->trm {{ lp:A -> lp:B }} (app {{:gref lib:elpi.derive.arrow }} A1 [B1]) D :- std.do-ok! D [ term->trm A A1, term->trm B B1, ]. term->trm (app [N|As]) (app {{:gref lib:elpi.derive.apply }} N1 As1) D :- name N, !, std.do-ok! D [ term->trm N N1, map-ok! As term->trm As1, ]. term->trm X _ (error S) :- S is "not an applicative term: " ^ {coq.term->string X}. pred map-ok! i:list A, i:(A -> B -> diagnostic -> prop), o:list B, o:diagnostic. map-ok! [] _ [] ok. map-ok! [X|XS] F [Y|YS] D :- F X Y D1, if (D1 = ok) (map-ok! XS F YS D) (D = D1). pred validate-eqType i:eqType, o:diagnostic. validate-eqType (type-param F) D :- pi x\ valid x ok => validate-eqType (F x) D. validate-eqType (value-param _ F) D :- pi x\ validate-eqType (F x) D. validate-eqType (inductive _ F) D :- pi x\ valid x ok => validate-constructors (F x) D. pred validate-constructors i:list constructor, o:diagnostic. validate-constructors [] ok. validate-constructors [constructor _ Args|Ks] D :- std.do-ok! D [ validate-arguments Args, validate-constructors Ks ]. pred validate-arguments i:arguments, o:diagnostic. validate-arguments (stop _) ok. validate-arguments (regular T Args) D :- std.do-ok! D [ valid T, validate-arguments Args, ]. validate-arguments (irrelevant _ Args) D :- validate-arguments Args D. validate-arguments (dependent T Args) D :- std.do-ok! D [ valid T, (d\ pi x\ validate-arguments (Args x) d), ]. pred main i:inductive, o:list prop. main I [C] :- std.assert-ok! (translate-indt I EQT) "derive.eqType.ast: translate", std.assert-ok! (validate-eqType EQT) "derive.eqType.ast: validate", C = (eqType I EQT), coq.elpi.accumulate _ "derive.eqType.db" (clause _ _ C). } namespace feqb { pred trm->term i:trm, o:term. trm->term (global GR) (global GR) :- !. trm->term (app GR A AS) (app[global GR,A1|AS1]) :- !, trm->term A A1, std.map AS trm->term AS1. trm->term T _ :- coq.error "cannot translate trm" T "to term, did you forget to assume feqb.trm->term ?". } coq-elpi-2.1.0/apps/derive/elpi/eqb.elpi000066400000000000000000000242051460156013500200230ustar00rootroot00000000000000/* equality test generation */ /* license: GNU Lesser General Public License Version 2.1 or later */ /* ------------------------------------------------------------------------- */ macro @pi-trm N T F :- pi x xx\ decl x N T => (feqb.trm->term xx x :- !) => F xx x. pred derive.eqb.main i:gref, i:string, o:list prop. derive.eqb.main (indt I) Prefix CL :- std.do! [ std.assert! (eqType I FI) "this inductive is not supported", derive.eqb.eqbf.main FI FI [] [] R, std.assert-ok! (coq.typecheck R Rty) "derive.eqbf generates illtyped term", Name is Prefix ^ "eqb_fields", coq.ensure-fresh-global-id Name FName, coq.env.add-const FName R Rty ff C, EQBF = global (const C), derive.eqb.eqb.main FI FI [] [] EQBF R1Skel, std.assert-ok! (coq.elaborate-skeleton R1Skel R1ty R1) "derive.eqb generates illtyped term", % need elaborate for prim record Name1 is Prefix ^ "eqb", coq.ensure-fresh-global-id Name1 FName1, coq.env.add-const FName1 R1 R1ty ff C1, EQB = global (const C1), % populate dbs derive.eqb.eqbf.do-clause FI FI [] [] EQBF [] CL1, derive.eqb.eqb.do-clause FI FI [] [] EQB [] CL2, CL = [CL1,CL2,eqb-done (indt I)], std.forall CL (x\ coq.elpi.accumulate _ "derive.eqb.db" (clause _ _ x)), ]. derive.eqb.main (const C) Prefix CL :- std.do! [ coq.env.const C (some T) _, std.assert! (eqb-for T T EQB) "cannot derive eqb", Name is Prefix ^ "eqb", coq.ensure-fresh-global-id Name FName, X = global (const C), coq.env.add-const FName EQB {{ lp:X -> lp:X -> bool }} @transparent! EQBC, CL = [eqb-done (const C), eqb-for (global (const C)) (global (const C)) (global (const EQBC))], std.forall CL (x\ coq.elpi.accumulate _ "derive.eqb.db" (clause _ (before "eqb-for:whd") x)), ]. derive.eqb.main (indc _) _ _ :- stop "eqrive.eqb cannot be called on constructors". namespace derive.eqb.eqb { % ----------------------------------------------------------------------------- pred main i:eqType, i:eqType, i:list term, i:list term, i:term, o:term. main (type-param FI) (type-param FJ) PI PJ EF {{ fun (x : Type) (eqx : x -> x -> bool) => lp:(R x eqx) }} :- @pi-trm `x` {{ Type }} y\x\ @pi-decl `eqx` {{ lp:x -> lp:x -> bool }} eqx\ main (FI y) (FJ y) [x|PI] [x|PJ] {coq.mk-app EF [x,eqx]} (R x eqx). main (value-param TYI FI) (value-param TYJ FJ) PI PJ EF {{ fun (x : lp:TI) (y : lp:TJ) => lp:(R x y) }} :- feqb.trm->term TYI TI, feqb.trm->term TYJ TJ, @pi-trm `x` TI xx\x\ @pi-trm `y` TJ yy\y\ main (FI xx) (FJ yy) [x|PI] [y|PJ] {coq.mk-app EF [x,y]} (R x y). main (inductive Ind _) (inductive Ind _) PI PJ EF {{ fix rec (x1 : lp:I) (x2 : lp:J) {struct x1} : bool := lp:(R rec x1 x2) }} :- coq.env.recursive? Ind, !, coq.mk-app (global (indt Ind)) {std.rev PI} I, coq.mk-app (global (indt Ind)) {std.rev PJ} J, @pi-decl `rec` {{ lp:I -> lp:J -> bool }} rec\ @pi-decl `x1` I x1\ @pi-decl `x2` J x2\ do-match x1 I x2 J {coq.mk-app EF [rec]} (R rec x1 x2). main (inductive Ind _) (inductive Ind _) PI PJ EF {{ fun (x1 : lp:I) (x2 : lp:J) => lp:(R x1 x2) }} :- coq.mk-app (global (indt Ind)) {std.rev PI} I, coq.mk-app (global (indt Ind)) {std.rev PJ} J, @pi-decl `x1` I x1\ @pi-decl `x2` J x2\ do-match x1 I x2 J {coq.mk-app EF [{{fun (_ : lp:I) (_ : lp:J) => true}}]} (R x1 x2). % ----------------------------------------------------------------------------- pred do-match i:term, i:term, i:term, i:term, i:term, o:term. do-match X1 I X2 J F R :- coq.build-match X1 I (_\_\_\r\ r = {{ bool }}) (do-branch X2 J F) R. % ----------------------------------------------------------------------------- pred do-branch i:term, i:term, i:term, i:term, i:term, i:list term, i:list term, o:term. do-branch X2 J F K KTY Vars _ {{ @eqb_core_defs.eqb_body _ _ _ _ lp:FLDP lp:F lp:TAG lp:X lp:X2 }} :- std.do! [ coq.safe-dest-app KTY (global (indt I)) ParamsI, std.assert! (fields-for I _ FLD _ _) "derive.eqb: run derive.fields before", coq.safe-dest-app J _ ParamsJ, coq.mk-app (global (const FLD)) ParamsJ FLDP, std.assert! (tag-for I T) "derive.eqb: run derive.tag before", coq.mk-app (global (const T)) {std.append ParamsI [{coq.mk-app K Vars}]} TAG, coq.safe-dest-app K (global (indc KI)) _, std.assert! (box-for KI _ BK) "derive.eqb: run derive.fields before", coq.mk-app (global (indc BK)) {std.append ParamsI Vars} X, ]. % ----------------------------------------------------------------------------- % example: eqb-for {{ list lp:A }} {{ @list_eqb lp:A lp:F }} :- eqb-for A F. pred do-clause i:eqType, i:eqType, i:list term, i:list term, i:term, i:list prop, o:prop. do-clause (type-param AI) (type-param AJ) PI PJ F Todo (pi a ea\ C a ea) :- !, pi x a ea\ do-clause (AI x) (AJ x) [a|PI] [a|PJ] {coq.mk-app F [a,ea]} [eqb-for a a ea|Todo] (C a ea). do-clause (value-param _ AI) (value-param _ AJ) PI PJ F Todo (pi a b\ C a b) :- !, pi x a b\ do-clause (AI x) (AJ x) [a|PI] [b|PJ] {coq.mk-app F [a,b]} Todo (C a b). do-clause (inductive Ind _) (inductive Ind _) PI PJ F Todo (eqb-for I J F :- Todo) :- coq.mk-app (global (indt Ind)) {std.rev PI} I, coq.mk-app (global (indt Ind)) {std.rev PJ} J. } namespace derive.eqb.eqbf { % ----------------------------------------------------------------------------- pred main i:eqType, i:eqType, i:list term, i:list term, o:term. main (type-param FI) (type-param FJ) PI PJ {{ fun (p : Type) (eqp : p -> p -> bool) => lp:(R p eqp) }} :- @pi-trm `P` {{ Type }} x\p\ @pi-decl `eqP` {{ lp:p -> lp:p -> bool }} eqP\ eqb-for p p eqP => main (FI x) (FJ x) [p|PI] [p|PJ] (R p eqP). main (value-param TYI FI) (value-param TYJ FJ) PI PJ {{ fun (x y : lp:T) => lp:(R x y) }} :- feqb.trm->term TYI TI, feqb.trm->term TYJ TJ, @pi-trm `P` TI xx\x\ @pi-trm `P` TJ yy\y\ main (FI xx) (FJ yy) [x|PI] [y|PJ] (R x y). main (inductive Ind F) (inductive Ind G) PI PJ {{ fun (rec : lp:I -> lp:J -> bool) (x : positive) => lp:(R rec x) }} :- std.do! [ std.rev PI ParamsI, std.rev PJ ParamsJ, coq.mk-app (global (indt Ind)) ParamsI I, coq.mk-app (global (indt Ind)) ParamsJ J, std.assert! (fields-for Ind F_t _ _ _) "derive.eqb: run derive.fields before", coq.mk-app (global (const F_t)) ParamsI Fields_t_I, coq.mk-app (global (const F_t)) ParamsJ Fields_t_J, (@pi-decl `rec` {{ lp:I -> lp:J -> bool }} rec\ @pi-decl `x` {{ positive }} x\ eqb-for I J rec => pi i j\ (feqb.trm->term i I :- !) => (feqb.trm->term j J :- !) => derive.fields.splay-over-positive x {std.zip (F i) (G j)} (rty Fields_t_I Fields_t_J) {{ fun (_ : lib:elpi.derive.unit) (_ : lib:elpi.derive.unit) => true }} (fields ParamsI ParamsJ) (R rec x)), ]. pred rty i:term, i:term, i:term, o:term. rty Fields_t_I Fields_t_J X {{ lp:Fields_t_I lp:X -> lp:Fields_t_J lp:X -> bool }}. % ----------------------------------------------------------------------------- pred fields i:list term, i:list term, i:pair constructor constructor, o:term. fields ParamsI ParamsJ (pr (constructor K (stop _)) (constructor K (stop _))) {{ fun (a : lp:BoxTy1) (b : lp:BoxTy2) => true }} :- std.do! [ std.assert! (box-for K IB _) "derive.eqb: run derive.fields before", coq.mk-app (global (indt IB)) ParamsI BoxTy1, coq.mk-app (global (indt IB)) ParamsJ BoxTy2, ]. fields ParamsI ParamsJ (pr (constructor K Args) (constructor K Args2)) {{ fun (a : lp:BoxTy1) (b : lp:BoxTy2) => lp:(R a b) }} :- std.do! [ std.assert! (box-for K IB _) "derive.eqb: run derive.fields before", coq.mk-app (global (indt IB)) ParamsI BoxTy1, coq.mk-app (global (indt IB)) ParamsJ BoxTy2, @pi-decl `a` BoxTy a\ @pi-decl `b` BoxTy b\ coq.build-match a BoxTy1 fields.rty1 (fields.branch1 b BoxTy2 Args Args2) (R a b) ]. pred fields.rty1 i:term, i:list term, i:list term, o:term. fields.rty1 _ _ _ {{ bool }}. pred fields.branch1 i:term, i:term, i:arguments, i:arguments, i:term, i:term, i:list term, i:list term, o:term. fields.branch1 B BoxTy2 Args Args2 _ _ VarsA _ R :- coq.build-match B BoxTy2 fields.rty2 (fields.branch2 Args Args2 VarsA) R. pred fields.rty2 i:term, i:list term, i:list term, o:term. fields.rty2 _ _ _ {{ bool }}. pred fields.branch2 i:arguments, i:arguments, i:list term, i:term, i:term, i:list term, i:list term, o:term. fields.branch2 Args Args2 VarsA _ _ VarsB _ R :- fields.aux Args Args2 VarsA VarsB R. pred mk-eqb-for i:term, i:term, o:term. mk-eqb-for T1 T2 R :- eqb-for T1 T2 R, !. mk-eqb-for T1 _ _ :- Msg is "derive.eqb: missing boolean equality for " ^ {coq.term->string T1} ^ ", maybe use derive.eqb first", stop Msg. pred fields.aux i:arguments, i:arguments, i:list term, i:list term, o:term. fields.aux (dependent TYX FX) (dependent TYY FY) [X|XS] [Y|YS] {{ lib:elpi.andb (lp:EQB lp:X lp:Y) lp:R1 }} :- feqb.trm->term TYX TX, feqb.trm->term TYY TY, mk-eqb-for TX TY EQB, @pi-decl `p` TX n\ pi a\ (feqb.trm->term a n :- !) => @pi-decl `p` TY m\ pi b\ (feqb.trm->term b m :- !) => fields.aux (FX a) (FY b) XS YS (R n m), R1 = R X Y. fields.aux (regular TYX FX) (regular TYY FY) [X|XS] [Y|YS] {{ lib:elpi.andb (lp:EQB lp:X lp:Y) lp:R }} :- feqb.trm->term TYX TX, feqb.trm->term TYY TY, mk-eqb-for TX TY EQB, fields.aux FX FY XS YS R. fields.aux (irrelevant _ FX) (irrelevant _ FY) [_|XS] [_|YS] R :- fields.aux FX FY XS YS R. fields.aux (stop _) (stop _) [] [] {{ true }}. % ----------------------------------------------------------------------------- % example: % eqb-fields {{ list lp:A }} {{ @list_eqb_fields lp:A lp:EA lp:ELA }} :- % eqb-for A EA, eqb-for {{ list lp:A }} ELA. pred do-clause i:eqType, i:eqType, i:list term, i:list term, i:term, i:list prop, o:prop. do-clause (type-param AI) (type-param AJ) PI PJ F Todo (pi a ea\ C a ea) :- !, pi x a ea\ do-clause (AI x) (AJ x) [a|PI] [a|PJ] {coq.mk-app F [a,ea]} [eqb-for a a ea|Todo] (C a ea). do-clause (value-param _ AI) (value-param _ AJ) PI PJ F Todo (pi a b\ C a b) :- !, pi x a b\ do-clause (AI x) (AJ x) [a|PI] [b|PJ] {coq.mk-app F [a,b]} Todo (C a b). do-clause (inductive Ind _) (inductive Ind _) PI PJ F Todo (pi ela\ eqb-fields I J (F1 ela) :- [C ela|Todo]) :- !, coq.mk-app (global (indt Ind)) {std.rev PI} I, coq.mk-app (global (indt Ind)) {std.rev PJ} J, pi ela\ (coq.mk-app F [ela] (F1 ela), C ela = eqb-for I J ela). } coq-elpi-2.1.0/apps/derive/elpi/eqbOK.elpi000066400000000000000000000051471460156013500202610ustar00rootroot00000000000000/* equality test soundness proof */ /* license: GNU Lesser General Public License Version 2.1 or later */ /* ------------------------------------------------------------------------- */ macro @pi-trm N T F :- pi x xx\ decl x N T => (feqb.trm->term xx x :- !) => F xx x. namespace derive.eqbOK { pred add-reflect i:eqType, i:term, i:term, o:term. add-reflect (type-param F) Correct Refl {{ fun (a : lp:Type) (eqA: a -> a -> bool) (heqA : lp:(HeqA a eqA)) => lp:(R a eqA heqA) }} :- Type = sort (typ {coq.univ.new}), HeqA = (a\eqA\ {{ forall x1 x2 : lp:a, reflect (@eq lp:a x1 x2) (lp:eqA x1 x2) }}), @pi-trm `a` Type aa\a\ @pi-decl `eqA` {{ lp:a -> lp:a -> bool }} eqA\ @pi-decl `heqA` (HeqA a eqA) heqA\ add-reflect (F aa) {{lp:Correct lp:a lp:eqA (fun (a1 a2 : lp:a) => @elimT (@eq lp:a a1 a2) (lp:eqA a1 a2) (lp:heqA a1 a2))}} {{lp:Refl lp:a lp:eqA (fun (a1: lp:a) => @introT (@eq lp:a a1 a1) (lp:eqA a1 a1) (lp:heqA a1 a1) (@refl_equal lp:a a1))}} (R a eqA heqA). add-reflect (value-param TY F) Correct Refl {{ fun x : lp:Ty => lp:(R x) }} :- feqb.trm->term TY Ty, @pi-trm `x` Ty xx\x\ add-reflect (F xx) {{lp:Correct lp:x}} {{lp:Refl lp:x}} (R x). add-reflect (inductive _ _) Correct Refl {{iffP2 lp:Correct lp:Refl}}. pred main i:gref, i:string, o:list prop. main (indt I) Prefix [CL] :- std.do! [ std.assert! (eqType I FI) "this inductive is not supported", std.assert! (eqcorrect-for (indt I) Correct Refl) "run eqbcorrect before", add-reflect FI (global (const Correct)) (global (const Refl)) Breflect, std.assert-ok! (coq.typecheck Breflect Treflect) "eqbOK generates illtyped term", coq.ensure-fresh-global-id (Prefix ^ "eqb_OK") Namerf, coq.env.add-const Namerf Breflect Treflect @opaque! Reflect, CL = eqbok-for (indt I) Reflect, coq.elpi.accumulate _ "derive.eqbOK.db" (clause _ _ CL), ]. main (const C) Prefix [CL] :- std.do! [ std.assert! (eqb-for (global (const C)) (global (const C)) F) "run eqb before", std.assert! (eqcorrect-for (const C) Correct Refl) "run eqbcorrect before", add-reflect (inductive _ _) (global (const Correct)) (global (const Refl)) Breflect, std.assert-ok! (coq.typecheck Breflect _) "eqbOK generates illtyped term", coq.ensure-fresh-global-id (Prefix ^ "eqb_OK") Namerf, X = global (const C), coq.env.add-const Namerf Breflect {{ forall a b : lp:X, Bool.reflect (@eq lp:X a b) (lp:F a b) }} @opaque! Reflect, CL = eqbok-for (const C) Reflect, coq.elpi.accumulate _ "derive.eqbOK.db" (clause _ _ CL), ]. main (indc _) _ _ :- stop "cannot call eqbOK on a constructor". } coq-elpi-2.1.0/apps/derive/elpi/eqbcorrect.elpi000066400000000000000000000447361460156013500214200ustar00rootroot00000000000000/* equality test correctness and reflexivity proof */ /* license: GNU Lesser General Public License Version 2.1 or later */ /* ------------------------------------------------------------------------- */ macro @pi-trm N T F :- pi x xx\ decl x N T => (feqb.trm->term xx x :- !) => F xx x. namespace derive.eqbcorrect { pred has-params? i:eqType. has-params? (type-param _). has-params? (value-param _ _). % use: % config Pred Pred_on Pred_body Solver Db % to make the code agnostic on the proof of correctness or reflexivity % % eg: config {{ @eqb_correct }} {{ @eqb_correct_on }} {{ @eqb_body_correct }} "eqb_correct_on__solver" correct-lemma-for pred config o:term, o:term, o:term, o:string, o:(term -> term -> prop). pred main i:gref, i:string, o:list prop. main (indt I) Prefix CLs :- std.do! [ std.assert! (eqType I FI) "this inductive is not supported", std.assert! (induction-db I Indu) "call derive.induction before", /* Correctness */ config {{ @eqb_correct }} {{ @eqb_correct_on }} {{ @eqb_body_correct }} "eqb_correct_on__solver" correct-lemma-for => common FI [] Indu R, %std.assert! (ground_term R) "ww", std.assert-ok! (coq.typecheck R Ty) "derive.eqbcorrect: common/correct generates ill typed term", Name is Prefix ^ "eqb_correct", coq.ensure-fresh-global-id Name FName, coq.env.add-const FName R Ty @opaque! Correct, if (has-params? FI) ( config {{ @eqb_correct }} {{ @eqb_correct_on }} {{ @eqb_body_correct }} "eqb_correct_on__solver" correct-lemma-for => common-aux FI [] Indu Rx, std.assert-ok! (coq.typecheck Rx Tyx) "derive.eqbcorrect: common-aux/corect generates ill typed term", Namex is Prefix ^ "eqb_correct_aux", coq.ensure-fresh-global-id Namex FNamex, coq.env.add-const FNamex Rx Tyx @opaque! Correctx, CL_CORRECT = [correct-lemma-for (global (indt I)) (global (const Correctx))] ) (CL_CORRECT = [correct-lemma-for (global (indt I)) (global (const Correct))]), /* Reflexivity */ config {{ @eqb_reflexive }} {{ @eqb_refl_on }} {{ @eqb_body_refl }} "eqb_refl_on__solver" refl-lemma-for => common FI [] Indu Rr, std.assert-ok! (coq.typecheck Rr Tyr) "derive.eqbcorrect: common/refl generates ill typed term", Namer is Prefix ^ "eqb_refl", coq.ensure-fresh-global-id Namer FNamer, coq.env.add-const FNamer Rr Tyr @opaque! Refl, if (has-params? FI) ( config {{ @eqb_reflexive }} {{ @eqb_refl_on }} {{ @eqb_body_refl }} "eqb_refl_on__solver" refl-lemma-for => common-aux FI [] Indu Rrx, std.assert-ok! (coq.typecheck Rrx Tyrx) "derive.eqbcorrect: common-aux/refl generates ill typed term", Namerx is Prefix ^ "eqb_refl_aux", coq.ensure-fresh-global-id Namerx FNamerx, coq.env.add-const FNamerx Rrx Tyrx @opaque! Reflx, CL_REFL = [refl-lemma-for (global (indt I)) (global (const Reflx))] ) (CL_REFL = [refl-lemma-for (global (indt I)) (global (const Refl))]), /* Add the clauses in the database */ std.flatten [ [ eqcorrect-for (indt I) Correct Refl ] , CL_CORRECT , CL_REFL ] CLs , std.forall CLs (x\coq.elpi.accumulate _ "derive.eqbcorrect.db" (clause _ _ x)), ]. main (const C) Prefix [Clause] :- std.do! [ std.assert! (eqb-for (global (const C)) (global (const C)) F) "run eqb first", coq.env.const C (some T) _, search-eqcorrect-for T Correct Refl, std.assert-ok! (coq.typecheck Correct _) "eqbcorrect: illtyped correct", std.assert-ok! (coq.typecheck Refl _) "eqbcorrect: illtyped refl", NameR is Prefix ^ "eqb_refl", NameC is Prefix ^ "eqb_correct", X = global (const C), coq.ensure-fresh-global-id NameR FNameR, coq.ensure-fresh-global-id NameC FNameC, coq.env.add-const FNameC Correct {{ @eqb_correct lp:X lp:F }} @transparent! CC, coq.env.add-const FNameR Refl {{ @eqb_reflexive lp:X lp:F }} @transparent! CR, Clause = (eqcorrect-for (const C) CC CR), coq.elpi.accumulate _ "derive.eqbcorrect.db" (clause _ _ Clause), ]. main (indc _) _ _ :- stop "derive.eqbcorrect does not work on a constructor". %--------------------------------------------------------------------------- pred search-eqcorrect-for i:term, o:term, o:term. search-eqcorrect-for (global (indt I)) (global (const C)) (global (const R)) :- std.assert! (eqType I (inductive _ _)) "unknown or not applied enough type", eqcorrect-for (indt I) C R. search-eqcorrect-for (app[global (indt I)|Args]) CArgs RArgs :- std.assert! (eqType I F) "unknown", eqcorrect-for (indt I) C R, search-eqcorrect-apply F Args (global (const C)) (global (const R)) CArgs RArgs. pred search-eqcorrect-apply i:eqType, i:list term, i:term, i:term, o:term, o:term. search-eqcorrect-apply (type-param F) [T|Args] C R C1 R1 :- search-eqcorrect-for T CT RT, pi x\ search-eqcorrect-apply (F x) Args {coq.mk-app C [T,_,CT]} {coq.mk-app R [T,_,RT]} C1 R1. search-eqcorrect-apply (value-param _ F) [T|Args] C R C1 R1 :- pi x\ search-eqcorrect-apply (F x) Args {coq.mk-app C [T]} {coq.mk-app R [T]} C1 R1. search-eqcorrect-apply (inductive _ _) [] C R C R. %--------------------------------------------------------------------------- pred run-solver i:sealed-goal, i:string. run-solver G Name :- if (coq.ltac.open (coq.ltac.call Name []) G []) true (@holes! => coq.sealed-goal->string G SG, std.fatal-error {calc ( "solver " ^ Name ^ " fails on goal:\n" ^ SG )}). pred coq.sealed-goal->string i:sealed-goal, o:string. coq.sealed-goal->string (nabla G) R :- pi x\ coq.sealed-goal->string (G x) R. coq.sealed-goal->string (seal (goal Ctx _ Ty _ _)) R :- Ctx => (std.map {std.rev Ctx} coq.ctx->string L, coq.term->string Ty G, R is "Lemma foo " ^ {std.string.concat "\n" L} ^ "\n :\n" ^ G ^ "."). pred coq.ctx->string i:prop, o:string. coq.ctx->string (decl X _ Ty) R :- R is "(" ^ {coq.term->string X} ^ " : " ^ {coq.term->string Ty} ^ ")". coq.ctx->string (def X _ Ty B) R :- R is "(" ^ {coq.term->string X} ^ " : " ^ {coq.term->string Ty} ^ " := " ^ {coq.term->string B} ^ ")". pred common-body o:term. pred fields-t o:term, o:term, o:term, o:term. %--------------------------------------------------------------------------- pred common i:eqType, i:list term, i:term, o:term. common (type-param F) Params Ind O :- std.do! [ config Pred Pred_on _Pred_body _Solver Db, O = {{ fun (a : lp:Type) (eqA : a -> a -> bool) (eqAc : lp:Pred a eqA) => lp:(R a eqA eqAc) }}, Type = sort (typ {coq.univ.new}), @pi-trm `a` Type aa\a\ @pi-decl `eqA` {{ lp:a -> lp:a -> bool }} eqA\ @pi-decl `eqAc` {{ lp:Pred lp:a lp:eqA }} eqAc\ param1-inhab-db {{ lp:Pred_on lp:a lp:eqA }} eqAc => eqb-for a a eqA => reali a {{ lp:Pred_on lp:a lp:eqA }} => prove Db a {{ fun (x: lp:a) (Hx : lp:Pred_on lp:a lp:eqA x) => Hx }} => common (F aa) [a|Params] {coq.mk-app Ind [a, {{ lp:Pred_on lp:a lp:eqA }} ] } (R a eqA eqAc) ]. common (value-param TY F) Params Ind O :- std.do! [ feqb.trm->term TY T, O = {{ fun (a : lp:T) => lp:(R a) }}, mk-reali T TR, std.assert! (param1-inhab-db TR Is_full) "not trivially inhabited", @pi-trm `a` T aa\a\ reali a {{ lp:Is_full lp:a }} => common (F aa) [a|Params] {{ lp:Ind lp:a (lp:Is_full lp:a) }} (R a) ]. common (inductive I Ks) ParamsRev Ind O :- std.do! [ config _Pred Pred_on Pred_body _Solver Db, std.rev ParamsRev Params, coq.mk-app (global (indt I)) Params Ty, mk-eqb-for Ty Cmp, tag-for I TagC, fields-for I Fields_tC FieldsC ConstructC ConstructPC, coq.mk-app (global (const TagC)) Params Tag, coq.mk-app (global (const Fields_tC)) Params Fields_t, coq.mk-app (global (const FieldsC)) Params Fields, coq.mk-app (global (const ConstructC)) Params Construct, coq.mk-app (global (const ConstructPC)) Params ConstructP, eqb-fields Ty Ty EqbFields, Common = {{ lp:Pred_body lp:Ty lp:Tag lp:Fields_t lp:Fields lp:Construct lp:ConstructP lp:EqbFields }}, std.assert-ok! (coq.typecheck Common CommonTy) "WTF", mk-reali (global (indt I)) IR, % param1-db, really coq.safe-dest-app Ind _ RealiArgs, coq.mk-app IR RealiArgs TyR, std.assert! (param1-inhab-db TyR Is_full) "not trivially inhabited", mk-eqb-for Ty Cmp, (@pi-decl `x` Ty x\ @pi-def `common` CommonTy Common c\ common-body c => fields-t Tag Fields_t Fields Construct => prove Db Ty {{ fun (i : lp:Ty) (Hi : lp:Pred_on lp:Ty lp:Cmp i) => Hi }} => reali Ty {{ lp:Pred_on lp:Ty lp:Cmp }} => pi i\ (feqb.trm->term i Ty :- !) => std.do! [ std.map (Ks i) (branch Params) (LS c), std.append (LS c) [x, app[Is_full,x]] (Args x c), R x c = app [Ind, {{ lp:Pred_on lp:Ty lp:Cmp }} | Args x c], ]), O = {{ fun (x :lp:Ty) (common : lp:CommonTy := lp:Common) => lp:(R x common) }}, ]. %--------------------------------------------------------------------------- pred common-aux i:eqType, i:list term, i:term, o:term. common-aux (type-param F) Params Ind O :- std.do! [ config _Pred Pred_on _Pred_body _Solver Db, O = {{ fun (a : lp:Type) (eqA : a -> a -> bool) => lp:(R a eqA) }}, Type = sort (typ {coq.univ.new}), @pi-trm `a` Type aa\a\ @pi-decl `eqA` {{ lp:a -> lp:a -> bool }} eqA\ eqb-for a a eqA => reali a {{ lp:Pred_on lp:a lp:eqA }} => prove Db a {{ fun (x: lp:a) (Hx : lp:Pred_on lp:a lp:eqA x) => Hx }} => common-aux (F aa) [a|Params] {coq.mk-app Ind [a, {{ lp:Pred_on lp:a lp:eqA }} ] } (R a eqA) ]. common-aux (value-param TY F) Params Ind O :- std.do! [ feqb.trm->term TY T, O = {{ fun (a : lp:T) (pa : lp:TR a) => lp:(R a pa) }}, mk-reali T TR, @pi-trm `a` T aa\a\ @pi-decl `pa` {{ lp:TR lp:a }} pa\ reali a pa => common-aux (F aa) [a|Params] {{ lp:Ind lp:a lp:pa }} (R a pa) ]. common-aux (inductive I Ks) ParamsRev Ind O :- std.do! [ config _Pred Pred_on Pred_body _Solver Db, std.rev ParamsRev Params, coq.mk-app (global (indt I)) Params Ty, mk-eqb-for Ty Cmp, tag-for I TagC, fields-for I Fields_tC FieldsC ConstructC ConstructPC, coq.mk-app (global (const TagC)) Params Tag, coq.mk-app (global (const Fields_tC)) Params Fields_t, coq.mk-app (global (const FieldsC)) Params Fields, coq.mk-app (global (const ConstructC)) Params Construct, coq.mk-app (global (const ConstructPC)) Params ConstructP, eqb-fields Ty Ty EqbFields, Common = {{ lp:Pred_body lp:Ty lp:Tag lp:Fields_t lp:Fields lp:Construct lp:ConstructP lp:EqbFields }}, std.assert-ok! (coq.typecheck Common CommonTy) "WTF", prove Db Ty {{ fun (i : lp:Ty) (Hi : lp:Pred_on lp:Ty lp:Cmp i) => Hi }} => reali Ty {{ lp:Pred_on lp:Ty lp:Cmp }} => (pi i\ (feqb.trm->term i Ty :- !) => @pi-def `common` CommonTy Common c\ common-body c => fields-t Tag Fields_t Fields Construct => std.map (Ks i) (branch Params) (LS c)), O = (let `common` CommonTy Common c\ app [Ind, {{ lp:Pred_on lp:Ty lp:Cmp }} | LS c]), ]. %--------------------------------------------------------------------------- pred branch i:list term, i:constructor, o:term. branch Params (constructor K Args) R :- coq.mk-app (global (indc K)) Params KParams, args Args KParams [] [] [] 0 R. pred args i:arguments, i:term, i:list term,i:list term, i:list term, i:int, o:term. args (irrelevant TY Args) K As Hs Bs N O :- std.do! [ O = {{ fun (x : lp:T) (px : lp:EqbOn x) => lp:(R x px) }}, feqb.trm->term TY T, mk-reali T EqbOn, @pi-decl `x` T x\ @pi-decl `px` {{ lp:EqbOn lp:x }} px\ args Args {coq.mk-app K [x]} [x|As] Hs Bs {calc (N + 1)} (R x px) ]. args (regular TY Args) K As Hs Bs N O :- std.do! [ config _Pred Pred_on _Pred_body _Solver Db, O = {{ fun (x : lp:T) (px : lp:EqbOn x) (h : lp:EqbOn' x := lp:View x px) => lp:(R x px h) }}, feqb.trm->term TY T, mk-reali T EqbOn, mk-eqb-for T Cmp, EqbOn' = {{ lp:Pred_on lp:T lp:Cmp }}, if (same_term EqbOn EqbOn') (View = {{ fun (x : lp:T) (px : lp:EqbOn x) => px }}) (prove Db T View), @pi-decl `x` T x\ @pi-decl `px` {{ lp:EqbOn lp:x }} px\ % reali x px => @pi-def `h` {{ lp:EqbOn' lp:x }} {{ lp:View lp:x lp:px }} h\ args Args {coq.mk-app K [x]} [x|As] [h|Hs] [{{ lp:Cmp lp:x }}|Bs] N (R x px h) ]. args (dependent TY Args) K As Hs Bs N O :- std.do! [ config _Pred Pred_on _Pred_body _Solver Db, O = {{ fun (x : lp:T) (px : lp:EqbOn x) (h : lp:EqbOn' x := lp:View x px) => lp:(R x px h) }}, feqb.trm->term TY T, mk-reali T EqbOn, mk-eqb-for T Cmp, EqbOn' = {{ lp:Pred_on lp:T lp:Cmp }}, if (same_term EqbOn EqbOn') (View = {{ fun (x : lp:T) (px : lp:EqbOn x) => px }}) (prove Db T View), @pi-trm `x` T xx\x\ @pi-decl `px` {{ lp:EqbOn lp:x }} px\ reali x px => @pi-def `h` {{ lp:EqbOn' lp:x }} {{ lp:View lp:x lp:px }} h\ args (Args xx) {coq.mk-app K [x]} [x|As] [h|Hs] [{{ lp:Cmp lp:x }}|Bs] {calc (N + 1)} (R x px h) ]. args (stop TY) K As Hs Bs 0 {{ lp:B : lp:Pred_on lp:T lp:Cmp lp:K }} :- % no tricky arguments config {{ @eqb_correct }} Pred_on _Pred_body _Solver _Db, !, std.do! [ feqb.trm->term TY T, mk-eqb-for T Cmp, fields-t Tag Fields_t Fields Construct, eqb-fields T T EqbFields, std.assert! (common-body Common) "anomaly, no let for common body proof", coq.mk-app Common [K,{{ fun (x : lp:Fields_t (lp:Tag lp:K)) => lp:(Proof x) }}] B, @pi-decl `x` {{ lp:Fields_t (lp:Tag lp:K) }} x\ HYP = (x\ {{ @eq bool (lp:EqbFields (lp:Tag lp:K) (lp:Fields lp:K) lp:x) true }}), GOAL = (x\ {{ @eq (option lp:T) (@Some lp:T lp:K) (lp:Construct (lp:Tag lp:K) lp:x) }}), correct-proof x {{ lp:Fields_t (lp:Tag lp:K) }} HYP GOAL As Bs Hs (Proof x) ]. args (stop TY) K _As _Hs _Bs _ {{ lp:B : lp:Pred_on lp:T lp:Cmp lp:K }} :- config {{ @eqb_correct }} Pred_on _Pred_body Solver _Db, !, std.do! [ feqb.trm->term TY T, mk-eqb-for T Cmp, std.assert! (common-body Common) "anomaly, no let for common body proof", coq.mk-app Common [K,Fresh_] B, std.assert-ok! (coq.typecheck {{ lp:B : lp:Pred_on lp:T lp:Cmp lp:K }} _) "illtyped correctness proof", std.assert! (coq.ltac.collect-goals B [G] _) "wrong number of goals", run-solver G Solver, ]. pred correct-proof i:term, i:term, i:(term -> term), i:(term -> term) i:list term, i:list term, i:list term, o:term. correct-proof X TX H G As Bs Hs R :- coq.build-match X TX (cp.rty H G) (cp.bs As Bs Hs G) R. pred cp.rty i:(term -> term), i:(term -> term), i:term, i:list term, i:list term, o:term. cp.rty H G _ Vs _ {{ lp:{{ H X }} -> lp:{{ G X }} }} :- std.last Vs X. pred cp.bs i:list term, i:list term, i:list term, i:(term -> term), i:term, i:term, i:list term, i:list term, o:term. cp.bs As Bs Hs G K _ Vs Ts {{ @impliesP lp:Bools lp:P lp:Next }} :- std.rev Vs VsRev, mkblistcorrect Bs VsRev {{ bnil }} Bools, P = G {coq.mk-app K Vs }, cp.curry {std.rev Bs} As Vs Vs Ts Hs [] G K Next. pred cp.curry i:list term, i:list term, i:list term, i:list term, i:list term, i:list term, i:list term, i:(term -> term), i:term, o:term. cp.curry [B|Bs] As [V|Vs] OVs Ts Hs Hs2 G K W :- std.do! [ TyH = {{ @eq bool (lp:B lp:V) true }}, (@pi-decl `h` TyH h\ cp.curry Bs As Vs OVs Ts Hs [h|Hs2] G K (R h)), W = {{ fun h : lp:TyH => lp:(R h) }}, ]. cp.curry [] As [] Vs Ts Hs Hs2 G K R :- std.do! [ mktlistcorrect {std.rev Ts} {{ tnil }} Types, mkrewpred Ts K G P, (pi x\ sigma X\G x = {{ @eq lp:T lp:LHS lp:X }}), End = {{ @eq_refl lp:T lp:LHS }}, mkeqns {std.rev As} Vs {std.rev Hs} {std.rev Hs2} Eqns, coq.mk-app {{ @eq_ind_r_nP lp:Types lp:P }} {std.append Eqns [End]} R, ]. pred mkrewpred i:list term, i:term, i:(term -> term), o:term. mkrewpred [] K G (G K). mkrewpred [T|Ts] K G {{ fun w : lp:T => lp:(R w) }} :- @pi-decl `w` T w\ mkrewpred Ts {coq.mk-app K [w]} G (R w). pred mkeqns i:list term, i:list term, i:list term, i:list term, o:list term. mkeqns [] [] [] [] []. mkeqns [A|As] [V|Vs] [H|Hs] [H2|H2s] [A,V,{{ lp:H lp:V lp:H2 }}|R] :- mkeqns As Vs Hs H2s R. pred mktlistcorrect i:list term, i:term, o:term. mktlistcorrect [] ACC ACC. mktlistcorrect [X|XS] ACC R :- mktlistcorrect XS {{ tcons lp:X lp:ACC }} R. pred mkblistcorrect i:list term, i:list term, i:term, o:term. mkblistcorrect [] [] ACC ACC. mkblistcorrect [X|XS] [V|VS] ACC R :- coq.mk-app X [V] E, mkblistcorrect XS VS {{ bcons lp:E lp:ACC }} R. args (stop TY) K _As Hs Bs _ {{ lp:B : lp:Pred_on lp:T lp:Cmp lp:K }} :- config {{ @eqb_reflexive }} Pred_on _Pred_body _Solver _Db, !, std.do! [ feqb.trm->term TY T, mk-eqb-for T Cmp, std.assert! (common-body Common) "anomaly, no let for common body proof", mkblistrefl {std.rev Bs} {{ bnil }} Bools, Proof = app [ {{ @eqb_refl_statementP }} , Bools | Hs ], coq.mk-app Common [K,Proof] B, ]. pred mkblistrefl i:list term, i:term, o:term. mkblistrefl [] ACC ACC. mkblistrefl [X|XS] ACC R :- coq.safe-dest-app X _ Args, std.last Args A, coq.mk-app X [A] E, mkblistrefl XS {{ bcons lp:E lp:ACC }} R. %--------------------------------------------------------------------------- % prove {{ is_option (seq A) (is_seq A (eqb_correrct A eqA)) }} T % such that T has type {{ forall x (px : is_option ...), eqb_correrct (option (seq A)) x }} pred prove i:(term -> term -> prop), i:term, o:term. prove Lemma T R :- search Lemma (prove Lemma) T R. %prove T R :- whd1 T T', !, prove T' R. pred search i:(term -> term -> prop), i:(term -> term -> prop), i:term, o:term. search What Rec (app [GR|L] as GRL) R :- !, std.do! [ What GR Aux, mk-reali GR (global (indt ISGR)), param1-functor-for ISGR Funct BitMask, !, apply-functor (global Funct) BitMask L Rec TOTO, apply-aux Aux L Aux1, R = {{ fun (x : lp:GRL) H => lp:Aux1 x (lp:TOTO x H) }}, ]. % no params, no aux lemma (no reali argument) search What _Rec (global GR as GRL) {{ fun (x : lp:GRL) (_ : lp:IsGR x) => lp:R x }} :- What (global GR) R, mk-reali (global GR) IsGR, !. search What _ X _ :- coq.safe-dest-app X HD _, std.assert! (What HD _) "run eqbcorrect before". pred apply-aux i:term, i:list term, o:term. apply-aux Aux [] Aux. apply-aux Aux [T|L] Aux1 :- !, std.do![ std.assert! (eqb-for T T EQB ; reali T EQB) "WTF", apply-aux {coq.mk-app Aux [T, EQB]} L Aux1 ]. pred apply-functor i:term, i:list bool, i:list term, i:(term -> term -> prop), o:term. apply-functor X _ [] _ X. apply-functor X [ff,tt|Mask] [Y|YS] Rec R :- Rec Y Y1, apply-functor {coq.mk-app X [_,_,_,Y1]} Mask YS Rec R. apply-functor X [ff|Mask] [Y|YS] Rec R :- reali Y PY, apply-functor {coq.mk-app X [Y,PY]} Mask YS Rec R. %--------------------------------------------------------------------------- pred mk-reali i:term, o:term. mk-reali T R :- reali T R, !. mk-reali T _ :- Msg is "derive.eqbcorrect: no unary parametricity translation for " ^ {coq.term->string T} ^ ", use derive.param1 first", stop Msg. pred mk-eqb-for i:term, o:term. mk-eqb-for T R :- eqb-for T T R, !. mk-eqb-for T _ :- Msg is "derive.eqbcorrect: missing boolean equality for " ^ {coq.term->string T} ^ ", maybe use derive.eqb first", stop Msg. } coq-elpi-2.1.0/apps/derive/elpi/eqcorrect.elpi000066400000000000000000000114341460156013500212430ustar00rootroot00000000000000/* Correctness of comparison functions */ /* license: GNU Lesser General Public License Version 2.1 or later */ /* ------------------------------------------------------------------------- */ shorten std.{map, rev, assert!, do!, appendR}. %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % link param1-functor-db and eqcorrect-db pred pointfree i:(term -> term -> term -> prop), i:term, i:term, o:term. pointfree F A B R :- coq.safe-dest-app A HDA ARGSA, coq.safe-dest-app B HDB ARGSB, appendR AA [_] ARGSA, appendR BB [_] ARGSB, coq.mk-app HDA AA LEFT, coq.mk-app HDB BB RIGHT, !, if (LEFT = RIGHT) (R = {{ fun _ x => x }}) (F LEFT RIGHT R). param1-functor-db {{ lib:elpi.derive.eq_axiom_at lp:A lp:F }} {{ lib:elpi.derive.eq_axiom_at lp:_ lp:F }} {{ fun (x : lp:A) (px : lib:elpi.derive.eq_axiom_at lp:A lp:F x) => px }}. param1-functor-db HypTy {{ lib:elpi.derive.eq_axiom_at lp:A lp:_ }} {{ fun (x : lp:A) (px : lp:(PA x)) => lp:(R x px) }} :- (pi x\ coq.mk-app HypTy [x] (PA x)), coq.safe-dest-app HypTy (global (indt KR)) Args, realiR (global KGR) (global (indt KR)), !, Msg is "derive.eqcorrect: no eqcorrect for " ^ {coq.gref->string KGR}, assert! (eqcorrect-db KGR OK) Msg, (derive.eqcorrect.mk-app-eqfun OK Args OKLemma), coq.typecheck OKLemma OKLemmaTy ok, % we do the HO inference of P in elpi, since Coq is unable to do it OKLemmaTy = (prod _ _ x\ prod _ (P x) _), (pi x\ pointfree param1-functor-db {coq.mk-app HypTy [x]} (P x) Map), pi x px\ coq.mk-app OKLemma [x,{coq.mk-app Map [x,px]}] (R x px). namespace derive.eqcorrect { pred mk-app-eqfun i:term, i:list term, o:term. mk-app-eqfun X [] X. mk-app-eqfun X [Y] R :- coq.mk-app X [Y] R. mk-app-eqfun X [Y,_|YS] R :- eq-db Y Y F, !, coq.mk-app X [Y,F] X1, mk-app-eqfun X1 YS R. %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % pred branch i:term, i:term, i:term, o:term. branch (prod N T x\ prod M (P x) (B x)) (prod _ _ y\ prod _ (Q y) (Lty y)) L (fun N T x\ fun M (P x) (R x)) :- !, @pi-decl `x` T x\ @pi-decl `px` (P x) px\ sigma Proof ProofXPX\ (pointfree param1-functor-db (P x) (Q x) Proof, coq.mk-app Proof [x,px] ProofXPX, branch (B x px) (Lty x ProofXPX) {coq.mk-app L [x,ProofXPX]} (R x px)). branch _ _ X X. pred branches i:list term, i:term, o:list term. branches [] _ []. branches [Lemma | Lemmas] (prod _ S T) [P|PS] :- coq.typecheck Lemma LemmaTy ok, branch S LemmaTy Lemma P, branches Lemmas (T P) PS. %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % apply the induction principle to the P and the fill in all branches % using eqK lemmas pred eqK-lem i:list term, i:term, o:term. eqK-lem Args K Lemma :- coq.safe-dest-app K (global (indc Kname)) _, eqK-db Kname Lem, coq.mk-app Lem Args Lemma. pred idx i:term, i:term, i:list term, i:term, i:list term, o:term. idx (sort _) IT K IndP A R :- !, eq-db IT IT Cmp, !, coq.mk-app IndP [ {{ lib:elpi.derive.eq_axiom_at lp:IT lp:Cmp }} ] Induction, coq.typecheck Induction Inductionty ok, branches {map K (eqK-lem A)} Inductionty KArgs, coq.mk-app Induction KArgs R. idx Arity IT K IndP A R :- whd1 Arity Arity1, !, idx Arity1 IT K IndP A R. idx _ _ _ _ _ _ :- assert! false "derive.eqcorrect: indexed data not supported". %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Input paremeters and their equality tests pred params i:int, i:term, i:term, i:list term, i:term, i:list term, o:term. params L (prod N S T) I K IndP A R :- L > 0, !, M is L - 1, R = {{ fun (a : lp:S) (fa : a -> a -> bool) => lp:(Bo a fa) }}, @pi-decl N S a\ @pi-decl `fa` {{ lp:a -> lp:a -> bool }} fa\ (eq-db a a fa :- !) => params M (T a) {coq.mk-app I [a]} {map K (x\ coq.mk-app x [a])} {coq.mk-app IndP [a, {{ lib:elpi.derive.eq_axiom_at lp:a lp:fa }}]} [fa,a|A] (Bo a fa). params 0 Arity T K IndP A R :- idx Arity T K IndP {rev A} R. %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% pred main i:inductive, i:string, o:list prop. main GR Name [C] :- do! [ T = global (indt GR), assert! (induction-db GR IndP) "derive.eqcorrect: use derive.induction first", coq.env.indt GR Ind Lno _ Arity K _KT, assert! (Ind = tt) "derive.eqcorrect: co-inductive types not supported", % derive and define the lemma params Lno Arity T {std.map K (k\r\ r = global (indc k))} IndP [] CmpOK, std.assert-ok! (coq.typecheck CmpOK CmpTy) "derive.eqcorrect generates illtyped term", coq.env.add-const Name CmpOK CmpTy @opaque! Thm, % add a clause to the db C = (eqcorrect-db (indt GR) (global (const Thm)) :- !), coq.elpi.accumulate _ "derive.eqcorrect.db" (clause _ (before "eqcorrect-db:fail") C) ]. } coq-elpi-2.1.0/apps/derive/elpi/fields.elpi000066400000000000000000000304111460156013500205160ustar00rootroot00000000000000/* fields type description and accessor */ /* license: GNU Lesser General Public License Version 2.1 or later */ /* ------------------------------------------------------------------------- */ macro @pi-trm N T F :- pi x xx\ decl x N T => (feqb.trm->term xx x :- !) => F xx x. namespace derive.fields { pred fields_t. % chose between fields_t and construct pred self o:term. pred std.stop-do! i:list prop. std.stop-do! []. std.stop-do! [P|PS] :- coq.say P, (pi x\ stop x :- !, fail) => P, !, std.stop-do! PS. std.stop-do! [P|_] :- coq.say "STOP" P. pred main i:inductive, i:string, o:list prop. main I Prefix AllCL :- std.do! [ std.assert! (tag-for I Tag) "no tag for this inductive, run that derivation first", std.assert! (eqType I FI) "this inductive is not supported", coq.env.indt I _ _ _ Arity KS _, box (global (indt I)) KS FI CLB, CLB => fields_t.main FI (global (indt I)) Body_t, std.assert-ok! (coq.typecheck Body_t Ty_t) "derive.fields generates illtyped fields_t", Name_t is Prefix ^ "fields_t", coq.ensure-fresh-global-id Name_t FName_t, coq.env.add-const FName_t Body_t Ty_t ff Fields_t, CLB => fields.main FI (global (indt I)) (global (const Fields_t)) (global (const Tag)) BodySkel, % we elaborate only for primitive records... std.assert-ok! (coq.elaborate-skeleton BodySkel Ty Body) "derive.fields generates illtyped fields", Name is Prefix ^ "fields", coq.ensure-fresh-global-id Name FName, coq.env.add-const FName Body Ty ff Fields, CLB => construct.main FI (global (indt I)) Fields_t Body_c, std.assert-ok! (coq.typecheck Body_c Ty_c) "derive.fields generates illtyped construct", Name_c is Prefix ^ "construct", coq.ensure-fresh-global-id Name_c FName_c, coq.env.add-const FName_c Body_c Ty_c ff Construct, coq.bind-ind-arity (global (indt I)) Arity (case-refl Tag Fields Construct) Body_PSkel, std.assert-ok! (coq.elaborate-skeleton Body_PSkel Ty_P Body_P) "derive.fields generates illtyped constructP", Name_P is Prefix ^ "constructP", coq.ensure-fresh-global-id Name_P FName_P, coq.env.add-const FName_P Body_P Ty_P @opaque! ConstructP, AllCL = [fields-for I Fields_t Fields Construct ConstructP|CLB], std.forall AllCL (x\ coq.elpi.accumulate _ "derive.fields.db" (clause _ _ x)), ]. % ---------------------------------------------------------------------- pred fields_t.main i:eqType, i:term, o:term. fields_t.main (type-param F) I {{ fun p : Type => lp:(R p) }} :- !, @pi-trm `p` {{ Type }} x\p\ fields_t.main (F x) {coq.mk-app I [p]} (R p). fields_t.main (value-param TY F) I {{ fun p : lp:Ty => lp:(R p) }} :- !, feqb.trm->term TY Ty, @pi-trm `p` Ty x\p\ fields_t.main (F x) {coq.mk-app I [p]} (R p). fields_t.main (inductive _ F) I {{ fun p : lib:elpi.derive.positive => lp:(R p) }} :- coq.safe-dest-app I _ Params, @pi-decl `p` {{ lib:elpi.derive.positive }} p\ pi i\ splay-over-positive p (F i) fields_t.rty {{ unit }} (fields_t.k Params) (R p). pred fields_t.rty i:term, o:term. fields_t.rty _ {{ Type }}. pred fields_t.k i:list term, i:constructor, o:term. fields_t.k Params (constructor K _) T :- box-for K I _, coq.mk-app (global (indt I)) Params T. % ---------------------------------------------------------------------- pred fields.main i:eqType, i:term, i:term, i:term, o:term. fields.main (type-param F) I F_t Tag {{ fun p : Type => lp:(R p) }} :- !, @pi-trm `p` {{ Type }} x\p\ fields.main (F x) {coq.mk-app I [p]} {coq.mk-app F_t [p]} {coq.mk-app Tag [p]} (R p). fields.main (value-param TY F) I F_t Tag {{ fun p : lp:Ty => lp:(R p) }} :- !, feqb.trm->term TY Ty, @pi-trm `p` Ty x\p\ fields.main (F x) {coq.mk-app I [p]} {coq.mk-app F_t [p]} {coq.mk-app Tag [p]} (R p). fields.main (inductive _ _) I F_t Tag {{ fun i : lp:I => lp:(R i) }} :- @pi-trm `i` I _\i\ coq.build-match i I (fields.rty F_t Tag) fields.branch (R i). pred fields.rty i:term, i:term, i:term, i:list term, i:list term, o:term. fields.rty F_t Tag _ Vars _ {{ lp:F_t (lp:Tag lp:X) }} :- std.last Vars X. pred fields.branch i:term, i:term, i:list term, i:list term, o:term. fields.branch K _ Vars _ R :- coq.safe-dest-app K (global (indc C)) Params, box-for C _ B, coq.mk-app (global (indc B)) {std.append Params Vars} R. % ------------------------------------------------------------------------ pred box i:term, i:list constructor, i:eqType, o:list prop. box I KL Decl CL :- std.do! [ box.aux Decl I ILDr, box.declare KL ILDr CL, ]. pred box.declare i:list constructor, i:list box-spec, o:list prop. box.declare [] [] []. box.declare [K|Ks] [real-box I|Bs] [C|Cs] :- std.assert-ok! (coq.elaborate-indt-decl-skeleton I D) "ILD", coq.env.add-indt D IB, coq.env.indt IB _ _ _ _ [KB] _, C = box-for K IB KB, C => box.declare Ks Bs Cs. box.declare [K|Ks] [same-box K1|Bs] [box-for K IB KB|Cs] :- box-for K1 IB KB, box.declare Ks Bs Cs. kind box-spec type. type real-box indt-decl -> box-spec. type same-box constructor -> box-spec. pred box.aux i:eqType, i:term, o:list box-spec. box.aux (type-param F) I L :- (@pi-trm `p` {{ Type }} x\y\ box.aux (F x) {coq.mk-app I [y]} (L1 y)), distribute L1 (f\r\ sigma U\ r = parameter "A" explicit (sort (typ U)) f) L. box.aux (value-param TY F) I L :- feqb.trm->term TY Ty, (@pi-trm `p` Ty x\y\ box.aux (F x) {coq.mk-app I [y]} (L1 y)), distribute L1 (f\r\ r = parameter "v" explicit Ty f) L. box.aux (inductive Ind F) I L :- pi x\ box.aux2 I Ind x (F x) L. pred args-of o:constructor, o:arguments. box.aux2 _ _ _ [] []. box.aux2 I Ind X [constructor _ Args|MoreKs] [same-box K|MoreBoxes] :- args-of K Args, !, box.aux2 I Ind X MoreKs MoreBoxes. box.aux2 I Ind X [constructor K Args|MoreKs] [real-box (record ID1 S ID2 Fields)|MoreBoxes] :- if (coq.env.informative? Ind) (S = {{ Type }}) (S = {{ Prop }}), ID1 is "box_" ^ {coq.gref->id (indt Ind)} ^ "_" ^ {coq.gref->id (indc K)}, ID2 is "Box_" ^ {coq.gref->id (indt Ind)} ^ "_" ^ {coq.gref->id (indc K)}, (feqb.trm->term X I :- !) => box.box-argument ID2 0 Args Fields, args-of K Args => box.aux2 I Ind X MoreKs MoreBoxes. pred box.box-argument i:string, i:int, i:arguments, o:record-decl. box.box-argument _ _ (stop _) end-record. box.box-argument S M (regular T Args) (field [] N TY _\A) :- N is S ^ "_" ^ {std.any->string M}, feqb.trm->term T TY, box.box-argument S {calc (M + 1)} Args A. box.box-argument S M (irrelevant T Args) (field [] N TY _\A) :- N is S ^ "_" ^ {std.any->string M}, feqb.trm->term T TY, box.box-argument S {calc (M + 1)} Args A. box.box-argument S M (dependent T Args) (field [] N TY A) :- N is S ^ "_" ^ {std.any->string M}, feqb.trm->term T TY, pi x y\ (feqb.trm->term x y :- !) => box.box-argument S {calc (M + 1)} (Args x) (A y). pred distribute i:(A -> list box-spec), i:((A -> indt-decl) -> indt-decl -> prop), o:list box-spec. distribute (_\ []) _ []. distribute (x\ [real-box (X x)| XS x]) F [real-box F_X|R] :- F X F_X, distribute XS F R. distribute (x\ [same-box K| XS x]) F [same-box K|R] :- distribute XS F R. % ---------------------------------------------------------------------- pred construct.main i:eqType, i:term, i:constant, o:term. construct.main (type-param F) I F_t {{ fun p : Type => lp:(R p) }} :- @pi-trm `p` {{ Type }} x\p\ construct.main (F x) {coq.mk-app I [p]} F_t (R p). construct.main (value-param TY F) I F_t {{ fun p : lp:Ty => lp:(R p) }} :- feqb.trm->term TY Ty, @pi-trm `p` Ty x\p\ construct.main (F x) {coq.mk-app I [p]} F_t (R p). construct.main (inductive _ F) I F_t {{ fun p : lib:elpi.derive.positive => lp:(R p) }} :- coq.safe-dest-app I _ Params, coq.mk-app (global (const F_t)) Params Fields_t, @pi-decl `p` {{ lib:elpi.derive.positive }} p\ pi i\ splay-over-positive p (F i) (construct.rty1 Fields_t I) {{ fun (_:lib:elpi.derive.unit) => @None lp:I }} (construct.k I Params) (R p). pred construct.rty1 i:term, i:term, i:term, o:term. construct.rty1 Fields_t I X {{ lp:Fields_t lp:X -> option lp:I }}. pred construct.k i:term, i:list term, i:constructor, o:term. construct.k _ Params (constructor K (stop _)) {{ fun b : lp:BoxTy => Some lp:B }} :- !, box-for K BT _, coq.mk-app (global (indt BT)) Params BoxTy, coq.mk-app (global (indc K)) Params B. construct.k I Params (constructor K _) {{ fun b : lp:BoxTy => lp:(R b) }} :- box-for K BT _, coq.mk-app (global (indt BT)) Params BoxTy, @pi-decl `b` BoxTy b\ coq.build-match b BoxTy (construct.rty I) (construct.branch {coq.mk-app (global (indc K)) Params}) (R b). pred construct.rty i:term, i:term, i:list term, i:list term, o:term. construct.rty I _ _ _ {{ option lp:I }}. pred construct.branch i:term, i:term, i:term, i:list term, i:list term, o:term. construct.branch B _ _ Vars _ {{ Some lp:BVars }} :- coq.mk-app B Vars BVars. % ------------------------------------------------------------------------- % match x return construct (fields x) = Some x with _ => erefl pred case-refl i:constant, i:constant, i:constant, i:term, i:list term, i:list term, o:term. case-refl Tag Fields Construct _ ParamsX Tys R :- std.appendR Params [X] ParamsX, coq.mk-app (global (const Tag)) Params TP, coq.mk-app (global (const Fields)) Params FP, coq.mk-app (global (const Construct)) Params CP, coq.build-match X {std.last Tys} (case-refl-rty TP FP CP) case-refl-branch R. pred case-refl-rty i:term, i:term, i:term, i:term, i:list term,i:list term, o:term. case-refl-rty Tag Fields Construct _ Vs _ {{ lp:Construct (lp:Tag lp:X) (lp:Fields lp:X) = Some lp:X }} :- std.last Vs X. pred case-refl-branch i:term, i:term, i:list term,i:list term, o:term. case-refl-branch _ _ _ _ {{ refl_equal }}. pred splay-over-positive i:term, i:list A, i:(term -> term -> prop), i:term, i:(A -> term -> prop), o:term. splay-over-positive X L DoRty Def DoBranch R :- splay-over-positive.aux X (x\x) L DoRty DoBranch Def R. pred splay-over-positive.aux i:term, i:(term -> term), i:list A, i:(term -> term -> prop), i:(A -> term -> prop), i:term, o:term. splay-over-positive.aux _ _ [] _ _ Def Def :- !. splay-over-positive.aux _ _ [X] _ DoBranch _ R :- DoBranch X R, !. splay-over-positive.aux X XCtx KL DoRty DoBranch Def R :- coq.build-match X {{ lib:elpi.derive.positive }} (do-rty XCtx DoRty) (do-branch XCtx DoRty DoBranch Def KL) R. pred do-rty i:(term -> term), i:(term -> term -> prop), i:term, i:list term,i:list term, o:term. do-rty Ctx DoRty _ Vs _ R :- P = Ctx {std.last Vs}, DoRty P R. pred list-bitmask i:list A, o:list A, o:list A. list-bitmask [] [] []. list-bitmask [X] [X] []. list-bitmask [X,Y|L] [X|A] [Y|B] :- list-bitmask L A B. pred do-branch i:(term -> term), i:(term -> term -> prop), i:(A -> term -> prop), i:term, i:list A, i:term, i:term, i:list term, i:list term, o:term. do-branch PCtx DoRty DoBranch Def [_|KS] {{ xO }} _ [P] _ R :- !, list-bitmask KS KODD _, splay-over-positive.aux P (x\ PCtx {{ xO lp:x }}) KODD DoRty DoBranch Def R. do-branch PCtx DoRty DoBranch Def [_|KS] {{ xI }} _ [P] _ R :- !, list-bitmask KS _ KEVEN, splay-over-positive.aux P (x\ PCtx {{ xI lp:x }}) KEVEN DoRty DoBranch Def R. do-branch _ _ DoBranch _ [X|_] {{ xH }} _ _ _ R :- DoBranch X R, !. pred prod->tuple i:term, o:term. prod->tuple (prod N Ty F) {{ { x:lp:Ty & lp:(X x)}%type }} :- /*(F = x\prod _ _ _),*/ (pi x\ occurs x (F x)), !, % not the last one and dependent @pi-decl N Ty x\ prod->tuple (F x) (X x). prod->tuple (prod N Ty F) {{ (lp:Ty * lp:X)%type }} :- /*(F = x\prod _ _ _),*/ !, % not the last one @pi-decl N Ty x\ prod->tuple (F x) X. prod->tuple (prod _ Ty _) Ty. prod->tuple _ {{ unit }}. % other branches pred repack-as-tuple i:constant, i:constant, i:term, i:list term, i:list term, o:term. repack-as-tuple C_t Tag _ Vars Tys R :- std.appendR Params [X] Vars, std.last Tys XTy, coq.mk-app (global (const C_t)) Params C_tp, coq.mk-app (global (const Tag)) Params Tagp, coq.build-match X XTy (do-rty_t C_tp Tagp) args->tuple R. pred do-rty_t i:term, i:term, i:term, i:list term,i:list term, o:term. do-rty_t C_t Tag _ Vars _ {{ lp:C_t (lp:Tag lp:X) }} :- std.last Vars X. pred args->tuple i:term, i:term, i:list term, i:list term, o:term. args->tuple _ _ [] _ {{ tt }}. /*args->tuple _ _ [X] _ X.*/ args->tuple A B [X|XS] [T|TS] {{ @existT lp:T _ lp:X lp:R }} :- occurs X TS, !, args->tuple A B XS TS R. args->tuple A B [X|XS] [_T|TS] {{ ( lp:X , lp:R ) }} :- args->tuple A B XS TS R. }coq-elpi-2.1.0/apps/derive/elpi/idx2inv.elpi000066400000000000000000000064361460156013500206450ustar00rootroot00000000000000/* Links an inductive an its inverted form */ /* license: GNU Lesser General Public License Version 2.1 or later */ /* ------------------------------------------------------------------------- */ shorten std.{last, assert!, do!}. namespace derive.idx2inv { pred params i:indt-decl, i:term, i:term, o:term. params (parameter ID _ Ty In) T Ti (fun Name Ty Out) :- coq.id->name ID Name, @pi-decl Name Ty p\ params (In p) {coq.mk-app T [p]} {coq.mk-app Ti [p]} (Out p). params (inductive _ _ Arity _) T Ti (fix `rec` N FixTy FixBo) :- coq.safe-dest-app T (global (indt GR)) _, coq.env.recursive? GR, !, coq.arity->term Arity Ty, compute-fix-ty Ty T Ti N FixTy, compute-fix-clause Ty T Ti N Prove, compute-fix-clause Ty T Ti {calc (N + 1)} Prove1, @pi-decl `rec` Ty f\ Prove f => Prove1 f => compute-fix-bo Ty T Ti (FixBo f). params (inductive _ _ Arity _) T Ti Bo :- coq.arity->term Arity Ty, compute-fix-bo Ty T Ti Bo. pred compute-fix-ty i:term, i:term, i:term, o:int, o:term. compute-fix-ty (prod N S Tgt) T Ti M (prod N S T1) :- !, @pi-decl N S x\ compute-fix-ty (Tgt x) {coq.mk-app T [x]} {coq.mk-app Ti [x]} J (T1 x), M is J + 1. compute-fix-ty _ S T 0 {{ lp:S -> lp:T }}. pred compute-fix-clause i:term, i:term, i:term, i:int, o:(term -> prop). compute-fix-clause _ S T 1 (ih\ param1-functor-db S T ih). compute-fix-clause (prod N S Tgt) T Ti M (ih\ pi x\ C ih x) :- !, J is M - 1, @pi-decl N S x\ compute-fix-clause (Tgt x) {coq.mk-app T [x]} {coq.mk-app Ti [x]} J (ih\ C ih x). pred compute-fix-bo i:term, i:term, i:term, o:term. compute-fix-bo (prod N S Tgt) T Ti (fun N S T1) :- !, @pi-decl N S x\ compute-fix-bo (Tgt x) {coq.mk-app T [x]} Ti (T1 x). compute-fix-bo _ T Ti (fun `x` T B) :- @pi-decl `x` T x\ coq.build-match x T (mk-rty Ti) (mk-branch) (B x). pred mk-rty i:term, i:term, i:list term, i:list term, o:term. mk-rty Ti _ Vars _ R :- std.appendR Idxs [_] Vars, coq.mk-app Ti Idxs R. pred mk-branch i:term, i:term, i:list term, i:list term, o:term. mk-branch K KTy Vars VarsTy R :- std.do! [ coq.safe-dest-app K (global (indc GR)) _, coq.safe-dest-app KTy (global (indt I)) IArgs, coq.env.indt I _ _ NP _ _ _, std.split-at NP IArgs Params IDX, Vars = RealArgs, VarsTy = RealArgsTy, assert! (invert-db (indc GR) InvK) "derive.idx2inv: No inverted constructor", coq.mk-app {coq.mk-app (global InvK) Params} IDX K1, (pi H G P\ paramX.prove H G P :- param1-functor-db H G P) => (pi X T\ paramX.cross T :- (pi M\stop M :- !, fail) => realiR X T) => paramX.prove-args RealArgs RealArgsTy Args, coq.mk-app K1 Args K2, std.map IDX mk-refl ArgsEq, coq.mk-app K2 ArgsEq R, ]. pred mk-refl i:term, o:term. mk-refl E {{ @refl_equal _ lp:E }}. pred main i:inductive, i:string, o:list prop. main GR Infix [Clause] :- do! [ T = global (indt GR), assert! (invert-db (indt GR) (indt GRinv)) "derive.idx2inv: No inverted inductive", Tinv = global (indt GRinv), Name is {coq.gref->id (indt GR)} ^ Infix ^ {coq.gref->id (indt GRinv)}, coq.env.indt-decl GR D, copy T Tinv => params D T Tinv R, std.assert-ok! (coq.typecheck R RT) "derive.idx2inv: illtyped term", coq.env.add-const Name R RT _ C, Clause = idx2inv-db GR GRinv C C, coq.elpi.accumulate _ "derive.idx2inv.db" (clause _ _ Clause) ]. } % vim: set spelllang=: coq-elpi-2.1.0/apps/derive/elpi/induction.elpi000066400000000000000000000123431460156013500212500ustar00rootroot00000000000000/* induction principles */ /* license: GNU Lesser General Public License Version 2.1 or later */ /* ------------------------------------------------------------------------- */ shorten std.{do!, assert!, last, appendR, rev, map}. namespace derive.induction { % local db associating to each constructor the hypothesis to be used type induction-hyp-db term -> term -> prop. pred informative. % loaded in the context if we can elim to Type % create (paramX.prove (is_T params) P IH) pred mk-paramX.prove-clause i:list term, i:term, i:term, i:term, o:prop. mk-paramX.prove-clause [_] T P IH (param1-functor-db T P IH). mk-paramX.prove-clause [_,_|Args] T P IH (pi x y\ C x y) :- pi x y\ mk-paramX.prove-clause Args {coq.mk-app T [x,y]} {coq.mk-app P [x,y]} {coq.mk-app IH [x,y]} (C x y). % branch for constructor k is (hyp-k ...) where ... are the terms % generated by prove-args pred branch i:term, i:term, i:list term, i:list term, o:term. branch K _ V VT R :- induction-hyp-db K IH, (pi H G P\ paramX.prove H G P :- param1-functor-db H G P) => (pi X\ paramX.cross X) => paramX.prove-args V VT Args, coq.mk-app IH Args R. pred oty i:term, i:list term, i:list term, o:term. oty _ _ VT P :- last VT XT, copy XT P. pred branches i:term, i:term, i:list term, i:term, i:int, o:int, o:term, o:term. branches (prod Name S T) Ity Args IH N M (prod Name S F1) (fun Name S R1) :- !, @pi-decl Name S x\ branches (T x) Ity [x|Args] IH {calc (N + 1)} M (F1 x) (R1 x). branches (sort _) Ity Args IH Rno Rno Fty (fun `x` ItyArgs Bo) :- do! [ coq.mk-app Ity {rev Args} ItyArgs, copy ItyArgs PArgs, Fty = prod `x` ItyArgs (_\ PArgs), copy Ity P, mk-paramX.prove-clause Args Ity P IH C, @pi-decl `x` ItyArgs x\ C => coq.build-match x ItyArgs oty branch (Bo x) ]. %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Synthesize the type of each hypothesis starting from the type % of the constructor of is_T pred hyp i:term, o:term. hyp (prod N S T) (prod N Q R) :- !, copy S Q, @pi-decl N Q x\ hyp (T x) (R x). hyp S Q :- copy S Q. pred hyps i:list term, i:list term, i:term, i:term, o:term. hyps [K|KS] [KT|KTS] Ity Arity (fun Name Ind Bo) :- coq.term->gref K GRK, coq.name-suffix `H` {coq.gref->id GRK} Name, hyp KT Ind, !, % we cut since copy generates many solutions @pi-decl `Name` Ind x\ induction-hyp-db K x => % This is the hyp to be used for branch K hyps KS KTS Ity Arity (Bo x). hyps [] [] Ity Arity (fix `IH` Recno Fty Bo) :- @pi-decl `IH` Fty f\ sigma C\ branches Arity Ity [] f 0 Recno Fty (Bo f). %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Parameters and the P of the induction predicate (truncated wrt the type % of the unary parametricity translation, eg P takes only the indexes) pred truncated-predicate-ty i:term, o:term. truncated-predicate-ty (sort _) T :- informative, !, T = sort (typ U), coq.univ.new U. truncated-predicate-ty (sort _) (sort prop). truncated-predicate-ty (prod N S T) (prod N S R) :- @pi-decl N S x\ truncated-predicate-ty (T x) (R x). % loads the context with the substitution "is_T params -> P" pred mk-subst-clause i:term, i:term, o:list prop. mk-subst-clause Ity P C :- coq.safe-dest-app Ity IT ITArgs, C = [(copy IT P :- !), (pi Args Rest O\ copy (app[IT|Args]) O :- !, appendR ITArgs Rest Args, coq.mk-app P Rest O)]. pred params i:int, i:term, i:list term, i:list term, i:term, o:term. params N Ity K KT (prod Nx Sx x\ prod NP (SP x) (T x)) (fun Nx Sx x\ fun NP (SP x) (R1 x)) :- N > 0, !, M is N - 2, @pi-decl Nx Sx x\ @pi-decl NP (SP x) px\ % useless, the identity map is already there % paramX.prove px px (fun `x` x a\ fun `pa` (app[px,a]) pa\ pa) => params M {coq.mk-app Ity [x,px]} {map K (k\ coq.mk-app k [x,px])} {map KT (coq.subst-prod [x,px])} (T x px) (R1 x px). params 0 Ity K KT Arity (fun `P` Pty p\ Bo p) :- % P only takes the indexes of Arity truncated-predicate-ty Arity Pty, @pi-decl `P` Pty p\ sigma Subst\ (mk-subst-clause Ity p Subst, % replace (is_T params) with P Subst => hyps K KT Ity Arity (Bo p)). %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% pred main i:inductive, i:string, o:list prop. main GR Prefix [Clause] :- do! [ T = global (indt GR), if (coq.env.informative? GR) (Informative = [informative]) (Informative = []), assert! (reali T TR) {calc ( "derive.induction: no unary parametricity translation for" ^ {coq.term->string T} ^ ", use derive.param1 first")}, TR = global (indt GRR), coq.env.indt GRR Ind Lno _ Arity K KT, assert! (Ind = tt) "derive.induction: Coinductive types are not supported", % we build the induction principle Informative => params Lno TR {std.map K (k\r\ r = global (indc k))} KT Arity R, % coq.say {coq.term->string R}, std.assert-ok! (coq.typecheck R RT) "derive.induction generates illtyped term", Name is Prefix ^ "induction", coq.ensure-fresh-global-id Name FName, coq.env.add-const FName R RT _ I, % we register it as a clause Clause = (induction-db GR (global (const I)) :- !), coq.elpi.accumulate _ "derive.induction.db" (clause _ (before "induction-db:fail") Clause) ]. } coq-elpi-2.1.0/apps/derive/elpi/injection.elpi000066400000000000000000000040071460156013500212340ustar00rootroot00000000000000/* core of injection */ /* license: GNU Lesser General Public License Version 2.1 or later */ /* ------------------------------------------------------------------------- */ shorten std.{append, drop, length, do!}. namespace ltac.injection { pred arg-i i:int, i:int, i:term, i:inductive, i:list term, i:int, i:constructor, i:list term, i:term, i:term, i:term, o:list term. arg-i MAX MAX _ _ _ _ _ _ _ _ _ [] :- !. arg-i J MAX EQF GR TyArgs Pno GRK KArgs A B H R :- J < MAX, I is J + 1, if (projK-db GRK I Proj) (do! [ drop Pno KArgs Defaults, coq.mk-app Proj {append TyArgs Defaults} Projector, coq.mk-app (global (indt GR)) TyArgs Ty, coq.typecheck Projector (prod _ _ _\Ty2) ok, % FIXME whd coq.mk-app EQF [Ty,Ty2,Projector,A,B,H] P, R = [P|RS] ]) (R = RS), arg-i I MAX EQF GR TyArgs Pno GRK KArgs A B H RS. } namespace ltac { % Tests if the command can be applied pred injection? i:term, o:inductive, o:list term, o:constructor, o:list term, o:term, o:term. injection? Ty GR TyArgs GRK KArgs A B :- do! [ whd Ty [] {{lib:@elpi.eq}} [T,A,B], whd T [] (global (indt GR)) TyArgs, whd A [] (global (indc GRK)) KArgs, whd B [] (global (indc GRB)) _, GRK = GRB ]. % Does the job pred injection! i:term, o:list term, i:inductive, i:list term, i:constructor, i:list term, i:term, i:term. injection! H PL GR TyArgs GRK KArgs A B :- do! [ coq.env.indt GR _ Pno _ _ _ _, length KArgs Argsno, Eqno is Argsno - Pno, ltac.injection.arg-i 0 Eqno {{lib:@elpi.derive.eq_f}} GR TyArgs Pno GRK KArgs A B H PL ]. % Main entry point with assertion that H can be injected pred injection i:term, i:term, i:term, o:list term. injection H EqAB _ PL :- if (injection? EqAB GR TyArgs GRK KArgs A B) (injection! H PL GR TyArgs GRK KArgs A B) (coq.error "injection:" {coq.term->string H} "of type" {coq.term->string EqAB} "does not equate equal constructors"). } % vim:set ft=lprolog spelllang=: coq-elpi-2.1.0/apps/derive/elpi/invert.elpi000066400000000000000000000071061460156013500205640ustar00rootroot00000000000000/* Hide indexes using non-uniform parameters */ /* license: GNU Lesser General Public License Version 2.1 or later */ /* ------------------------------------------------------------------------- */ shorten std.{assert!, do!, map-i, map}. namespace derive.invert { pred the-inductive i:term, o:int. pred the-nup-for-idx i:int, o:term. pred the-suffix o:string. pred invert i:indt-decl, o:indt-decl. invert (parameter ID Imp Ty In) (parameter ID Imp Ty Out) :- @pi-parameter ID Ty p\ invert (In p) (Out p). invert (inductive ID IsInd Arity Ks) (inductive ID1 IsInd Arity1 Ks1) :- ID1 is ID ^ {the-suffix}, coq.arity->nparams Arity Nup, trivial-arity Arity 0 Arity1, coq.arity->term Arity ITy, @pi-parameter ID ITy i\ the-inductive i Nup => std.map (Ks i) (invert-c Nup Arity1) (Ks1 i). pred invert-c i:int, i:arity, i:indc-decl, o:indc-decl. invert-c Nup ArityI (constructor ID ArityK) (constructor ID1 ArityK1) :- ID1 is ID ^ {the-suffix}, invert-c-params Nup ArityI ArityK ArityK1. pred invert-c-params i:int, i:arity, i:arity, o:arity. invert-c-params Nup (parameter ID Imp Ty In) (parameter _ _ _ In1) (parameter ID Imp Ty Out):- Nup > 0, Nup1 is Nup - 1, @pi-parameter ID Ty p\ invert-c-params Nup1 (In p) (In1 p) (Out p). invert-c-params 0 Arity KArity Out :- invert-c-params-idx 0 Arity KArity Out. pred invert-c-params-idx i:int, i:arity, i:arity, o:arity. invert-c-params-idx Idx (parameter ID Imp Ty In) KArity (parameter ID Imp Ty Out) :- Idx1 is Idx + 1, @pi-parameter ID Ty p\ the-nup-for-idx Idx p => invert-c-params-idx Idx1 (In p) KArity (Out p). invert-c-params-idx _ (arity _) KArity KArity1 :- invert-c-arity KArity KArity1. pred invert-c-arity i:arity, o:arity. invert-c-arity (parameter ID Imp Ty In) (parameter ID Imp Ty Out) :- @pi-parameter ID Ty p\ invert-c-arity (In p) (Out p). invert-c-arity (arity T) (arity T1) :- invert-c-ty T T1. pred invert-c-ty i:term, o:term. invert-c-ty (prod N S T) (prod N S T1) :- !, @pi-decl N S x\ invert-c-ty (T x) (T1 x). invert-c-ty I I :- the-inductive I _, !. invert-c-ty (app[I|Args]) Out :- the-inductive I Nup, !, std.split-at Nup Args NUArgs Indexes, invert-c-ty-eq Indexes 0 (app[I|NUArgs]) Out. pred invert-c-ty-eq i:list term, i:int, i:term, o:term. invert-c-ty-eq [] _ X X. invert-c-ty-eq [I|Idxs] N Acc {{ lp:V = lp:I -> lp:Out }} :- std.assert! (the-nup-for-idx N V) "no variable to equate to index expression", M is N + 1, invert-c-ty-eq Idxs M {coq.mk-app Acc [V]} Out. pred trivial-arity i:arity, i:int, o:arity. trivial-arity (parameter ID Imp Ty In) Ni (parameter ID Imp Ty Out) :- @pi-parameter ID Ty p\ trivial-arity (In p) Ni (Out p). trivial-arity (arity (prod Name Ty In)) Ni (parameter ID explicit Ty Out) :- ID is "idx" ^ {term_to_string Ni}, Ni1 is Ni + 1, @pi-decl Name Ty p\ trivial-arity (arity (In p)) Ni1 (Out p). trivial-arity (arity T) _ (arity T). %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% pred main i:inductive, i:string, o:list prop. main GR Suffix Clauses :- do! [ coq.env.indt-decl GR Decl, the-suffix Suffix => invert Decl Decl1, std.assert-ok! (coq.typecheck-indt-decl Decl1) "derive.invert generates illtyped term", coq.env.add-indt Decl1 Inv, coq.env.indt GR _ _ _ _ Ks _, coq.env.indt Inv _ _ _ _ KIs _, Clauses = [invert-db (indt GR) (indt Inv) | {std.map2 Ks KIs mk-k-clause}], std.forall Clauses (c\coq.elpi.accumulate _ "derive.invert.db" (clause _ _ c)) ]. pred mk-k-clause i:constructor, i:constructor, o:prop. mk-k-clause K1 K2 (invert-db (indc K1) (indc K2)). } % vim: set spelllang=: coq-elpi-2.1.0/apps/derive/elpi/isK.elpi000066400000000000000000000030371460156013500200020ustar00rootroot00000000000000/* Derive a function "isK t -> true" iif t is "K .." for K constructor */ /* license: GNU Lesser General Public License Version 2.1 or later */ /* ------------------------------------------------------------------------- */ shorten std.{assert!, last, forall, map}. namespace derive.isK { pred ty i:term, i:list term, i:list term, o:term. ty _ _ _ {{ bool }}. % if the branch of the match (corresponding to KParams) is the one % for K (the constructor we are generating the isK function for) we say % true, else we say false. pred branch i:term, i:term, i:term, i:list term, i:list term, o:term. branch K KParams _ _ _ {{ true }} :- coq.safe-dest-app KParams K _, !. branch _ _ _ _ _ {{ false }}. pred body i:term, i:term, i:list term, i:list term, o:term. body K _ Vars Tys R :- last Vars X, last Tys TX, coq.build-match X TX ty (branch K) R. pred main-K i:string, i:term, i:term, i:constructor, o:prop. main-K Prefix Ity Arity GRK Clause :- K = (global (indc GRK)), coq.bind-ind-arity Ity Arity (body K) TSek, std.assert-ok! (coq.elaborate-skeleton TSek Ty T) "derive.isK generates illtyped term", Name is Prefix ^ {coq.gref->id (indc GRK)}, coq.env.add-const Name T Ty _ IsK, Clause = (isK-db GRK (global (const IsK)) :- !). pred main i:inductive, i:string, i:list prop. main GR Prefix Clauses :- T = global (indt GR), coq.env.indt GR _ _ _ Arity Kn _, map Kn (main-K Prefix T Arity) Clauses, forall Clauses (c\ coq.elpi.accumulate _ "derive.isK.db" (clause _ (before "isK-db:fail") c)). } % vim: set spelllang=: coq-elpi-2.1.0/apps/derive/elpi/lens.elpi000066400000000000000000000071171460156013500202200ustar00rootroot00000000000000/* A lens, to see better */ /* license: GNU Lesser General Public License Version 2.1 or later */ /* ------------------------------------------------------------------------- */ namespace derive.lens { pred build-lens i:record-decl, i:int, i:term, o:list id, o:list term. build-lens end-record _ _ [] []. build-lens (field _ ID Ty Fields) N RTy [ID|IDL] [Lens|BOL] :- if (pi x\ occurs x (Fields x)) (stop "derive.lens: dependent records not supported") true, View = {{ fun (r : lp:RTy) => lp:{{ % Coq term {coq.build-match {{r}} RTy (constant-rty Ty) (build-view N)} % Elpi "function" to build a match, see coq-lib.elpi }} }}, % we let Coq infer the type of f at type checking time Over = {{ fun f (r : lp:RTy) => lp:{{ {coq.build-match {{r}} RTy (constant-rty RTy) (build-over N {{f}})} }} }}, Lens = {{ lib:@elpi.derive.lens.make _ _ _ _ lp:View lp:Over }}, M is N + 1, Dummy = sort prop, build-lens (Fields Dummy) M RTy IDL BOL. % builds the return type of the match pred constant-rty i:term, i:term, i:list term, i:list term, o:term. constant-rty X _ _ _ X. % builds the match branch for view, L is the list of arguments to % the record constructor pred build-view i:int, i:term, i:term, i:list term, i:list term, o:term. build-view N _ _ L _ R :- std.nth N L R. % builds the match branch for over, K is the record constructor (already % applied) to the record parameters pred build-over i:int, i:term, i:term, i:term, i:list term, i:list term, o:term. build-over N F K _ L _ R :- std.split-at N L Before [X|After], coq.mk-app K {std.append Before [{{ lp:F lp:X }}|After]} R. % moves under the paramters of the inductive type type and binds them back % as a lambd abstraction over all the lenses that were built pred params i:indt-decl, i:term, o:list id, o:list term. params (parameter ID _ Ty Decl) RTy IL TL :- coq.id->name ID Name, (@pi-decl Name Ty x\ params (Decl x) {coq.mk-app RTy [x]} IL (BL x)), distribute-abstraction Name Ty BL TL. params (record _ _ _ RD) RTy IL TL :- build-lens RD 0 RTy IL TL. params (inductive ID _ _ _) _ _ _ :- M is "derive.lens: " ^ ID ^ " is not a record", stop M. % distributes a lambda abstraction to all items in the list pred distribute-abstraction i:name, i:term, i:(term -> list term), o:list term. distribute-abstraction _ _ (_\[]) []. distribute-abstraction Name Ty (x\[T x|L x]) [fun Name Ty T|L1] :- distribute-abstraction Name Ty L L1. % typechecks and declares the lens pred declare-lens i:string, i:inductive, i:id, i:term, o:prop. declare-lens Prefix I FieldName RawBody (lens-db I FieldName C):- Name is Prefix ^ FieldName, coq.env.indt I _ Nparams _ _ _ _, % In order to support primitive records we call the elaborator, which % eventually compiles the match into primitive projections std.assert-ok! (coq.elaborate-skeleton RawBody Ty Body) "derive.lens generates illtyped term", (pi P P1 N\ copy (primitive (proj P N)) (primitive (proj P1 N)) :- coq.primitive.projection-unfolded P1 P) => copy Body Body1, coq.env.add-const Name Body1 Ty @transparent! C, std.map {std.iota Nparams} (_\r\ r = maximal) Implicits, if (Nparams > 0) (@global! => coq.arguments.set-implicit (const C) [Implicits, []]) true. pred main i:inductive, i:string, o:list prop. main I Prefix Clauses :- std.do! [ coq.env.indt-decl I Decl, % easy to recurse on params Decl (global (indt I)) Names Defs, std.map2 Names Defs (declare-lens Prefix I) Clauses, std.forall Clauses (c\coq.elpi.accumulate _ "derive.lens.db" (clause _ _ c)), ]. } coq-elpi-2.1.0/apps/derive/elpi/lens_laws.elpi000066400000000000000000000112071460156013500212410ustar00rootroot00000000000000/* Equations on lenses */ /* license: GNU Lesser General Public License Version 2.1 or later */ /* ------------------------------------------------------------------------- */ namespace derive.lens-laws { pred declare-law1 i:string, i:prop. declare-law1 Prefix (lens-db I F C) :- std.do! [ coq.env.indt-decl I Decl, law1 Decl (global (const C)) (global (indt I)) Bo, Name is Prefix ^ F ^ "_view_set", coq.env.add-const Name Bo _ @opaque! _, ]. pred law1 i:indt-decl, i:term, i:term, o:term. law1 (parameter ID _ Ty Rest) Lens Ind {{ fun p : lp:Ty => lp:(Bo p) }} :- !, @pi-parameter ID Ty p\ law1 (Rest p) {coq.mk-app Lens [p]} {coq.mk-app Ind [p]} (Bo p). law1 _ Lens IT Bo :- BoS = {{ fun r => lp:{{ {coq.build-match {{r}} IT (law1-rty.aux Lens) law1-bo.aux } }} }}, TyS = {{ lib:elpi.derive.lens.view_set lp:Lens }}, std.assert-ok! (coq.elaborate-ty-skeleton TyS _ Ty) "derive.lens_laws: law1 statement illtyped", std.assert-ok! (coq.elaborate-skeleton BoS Ty Bo) "derive.lens_laws: law1 proof illtyped". law1-rty.aux L _ Vs _ {{ lib:elpi.derive.lens.view_set_on lp:L lp:R }} :- std.last Vs R. law1-bo.aux _ _ _ _ {{ fun x => lib:@elpi.erefl _ _ }}. pred declare-law2 i:string, i:prop. declare-law2 Prefix (lens-db I F C) :- std.do! [ coq.env.indt-decl I Decl, law2 Decl (global (const C)) (global (indt I)) Bo, Name is Prefix ^ F ^ "_set_set", coq.env.add-const Name Bo _ @opaque! _, ]. pred law2 i:indt-decl, i:term, i:term, o:term. law2 (parameter ID _ Ty Rest) Lens Ind {{ fun p : lp:Ty => lp:(Bo p) }} :- !, @pi-parameter ID Ty p\ law2 (Rest p) {coq.mk-app Lens [p]} {coq.mk-app Ind [p]} (Bo p). law2 _ Lens IT Bo :- BoS = {{ fun r => lp:{{ {coq.build-match {{r}} IT (law2-rty.aux Lens) law2-bo.aux } }} }}, TyS = {{ lib:elpi.derive.lens.set_set lp:Lens }}, std.assert-ok! (coq.elaborate-ty-skeleton TyS _ Ty) "derive.lens_laws: law2 statement illtyped", std.assert-ok! (coq.elaborate-skeleton BoS Ty Bo) "derive.lens_laws: law2 proof illtyped". law2-rty.aux L _ Vs _ {{ lib:elpi.derive.lens.set_set_on lp:L lp:R }} :- std.last Vs R. law2-bo.aux _ _ _ _ {{ fun x y => lib:@elpi.erefl _ _ }}. pred declare-law3 i:string, i:prop. declare-law3 Prefix (lens-db I F C) :- std.do! [ coq.env.indt-decl I Decl, law3 Decl (global (const C)) (global (indt I)) Bo, Name is Prefix ^ F ^ "_set_view", coq.env.add-const Name Bo _ @opaque! _, ]. pred law3 i:indt-decl, i:term, i:term, o:term. law3 (parameter ID _ Ty Rest) Lens Ind {{ fun p : lp:Ty => lp:(Bo p) }} :- !, @pi-parameter ID Ty p\ law3 (Rest p) {coq.mk-app Lens [p]} {coq.mk-app Ind [p]} (Bo p). law3 _ Lens IT Bo :- BoS = {{ fun r => lp:{{ {coq.build-match {{r}} IT (law3-rty.aux Lens) law3-bo.aux } }} }}, TyS = {{ lib:elpi.derive.lens.set_view lp:Lens }}, std.assert-ok! (coq.elaborate-ty-skeleton TyS _ Ty) "derive.lens_laws: law3 statement illtyped", std.assert-ok! (coq.elaborate-skeleton BoS Ty Bo) "derive.lens_laws: law3 proof illtyped". law3-rty.aux L _ Vs _ {{ lib:elpi.derive.lens.set_view_on lp:L lp:R }} :- std.last Vs R. law3-bo.aux _ _ _ _ {{ lib:@elpi.erefl _ _ }}. pred declare-law4 i:string, i:prop, i:prop. declare-law4 _ (lens-db I F C) (lens-db I F C) :- !. declare-law4 Prefix (lens-db I F1 C1) (lens-db I F2 C2) :- std.do! [ coq.env.indt-decl I Decl, law4 Decl (global (const C1)) (global (const C2)) (global (indt I)) Bo, Name is Prefix ^ F1 ^ "_" ^ F2 ^ "_exchange", coq.env.add-const Name Bo _ @opaque! _, ]. pred law4 i:indt-decl, i:term, i:term, i:term, o:term. law4 (parameter ID _ Ty Rest) Lens1 Lens2 Ind {{ fun p : lp:Ty => lp:(Bo p) }} :- !, @pi-parameter ID Ty p\ law4 (Rest p) {coq.mk-app Lens1 [p]} {coq.mk-app Lens2 [p]} {coq.mk-app Ind [p]} (Bo p). law4 _ Lens1 Lens2 IT Bo :- BoS = {{ fun r => lp:{{ {coq.build-match {{r}} IT (law4-rty.aux Lens1 Lens2) law4-bo.aux } }} }}, TyS = {{ lib:elpi.derive.lens.exchange lp:Lens1 lp:Lens2 }}, std.assert-ok! (coq.elaborate-ty-skeleton TyS _ Ty) "derive.lens_laws: law4 statement illtyped", std.assert-ok! (coq.elaborate-skeleton BoS Ty Bo) "derive.lens_laws: law4 proof illtyped". law4-rty.aux L1 L2 _ Vs _ {{ lib:elpi.derive.lens.exchange_on lp:L1 lp:L2 lp:R }} :- std.last Vs R. law4-bo.aux _ _ _ _ {{ fun x y => lib:@elpi.erefl _ _ }}. pred main i:inductive, i:string, o:list prop. main I Prefix [lens-laws-done I] :- std.do! [ std.findall (lens-db I F_ L_) Lenses, std.forall Lenses (declare-law1 Prefix), std.forall Lenses (declare-law2 Prefix), std.forall Lenses (declare-law3 Prefix), std.forall Lenses (l1\ std.forall Lenses (l2\ declare-law4 Prefix l1 l2)), coq.elpi.accumulate _ "derive.lens_laws.db" (clause _ _ (lens-laws-done I)), ]. } coq-elpi-2.1.0/apps/derive/elpi/map.elpi000066400000000000000000000156121460156013500200330ustar00rootroot00000000000000/* map over a container */ /* license: GNU Lesser General Public License Version 2.1 or later */ /* ------------------------------------------------------------------------- */ shorten std.{split-at, length, rev, append, do!, drop-last, assert!}. map-db (app[global (indt GR1)|A1]) (app[global (indt GR2)|A2]) R :- coq.env.indt GR1 _ Lno1 _ _ _ _, coq.env.indt GR2 _ Lno2 _ _ _ _, {length A1} > Lno1, {length A2} > Lno2, split-at Lno1 A1 Args1 Points1, split-at Lno2 A2 Args2 Points2, Points1 = Points2, !, map-db {coq.mk-app (global (indt GR1)) Args1} {coq.mk-app (global (indt GR2)) Args2} F, coq.mk-app F Points1 R. namespace derive.map { % Building the body %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% pred bo-idx i:term, % inductive arity (input) i:term, % inductive type (input) applied to params & idx handled so far i:term, % inductive type (output) applied to params & idx handled so far i:int, % current index no o:int, % Recno i:list term, % rev list of (output) parameters o:term, % body o:term. % type bo-idx (prod _ S1 T1) Ity1 Ity2 N M Ps (fun `x` S1 Bo) (prod `x` S1 Ty) :- !, pi x\ sigma Ity1x Ity2x\ coq.mk-app Ity1 [x] Ity1x, coq.mk-app Ity2 [x] Ity2x, N1 is N + 1, decl x `x` S1 => bo-idx (T1 x) Ity1x Ity2x N1 M Ps (Bo x) (Ty x). bo-idx (sort _) Ity1 Ity2 N N Ps (fun `x` Ity1 Bo) (prod `_` Ity1 _\ Ity2) :- !, @pi-decl `x` Ity1 x\ coq.build-match x Ity1 (bo-idx-rty Ps Ity2) (bo-k-args Ps) (Bo x). bo-idx X Ity1 Ity2 N M Ps R1 R2 :- whd1 X X1, !, bo-idx X1 Ity1 Ity2 N M Ps R1 R2. pred bo-idx-rty i:list term, i:term, i:term, i:list term, i:list term, o:term. bo-idx-rty Ps ItyArgs _ Vs _ R :- rev Vs [_|IdxsRev], rev IdxsRev Idxs, coq.safe-dest-app ItyArgs HD _, coq.mk-app HD {append {rev Ps} Idxs} R. pred bo-k-args i:list term, i:term, i:term, i:list term, i:list term, o:term. bo-k-args ParamsRev K _ Args Tys R :- rev ParamsRev Params, coq.safe-dest-app K (global (indc GR)) _, coq.env.typeof (indc GR) T, coq.subst-prod Params T KT, (bo-k-args.aux {coq.mk-app (global (indc GR)) Params} Args Tys KT R), !. % the first combination that typechecks bo-k-args.aux R [] [] _ R :- coq.typecheck R _ ok. bo-k-args.aux K [A|As] [T|Ts] (prod _ S Ty) R :- map-db T S F, coq.mk-app F [A] FA, bo-k-args.aux {coq.mk-app K [FA]} As Ts (Ty FA) R. bo-k-args.aux K [A|As] [_|Ts] (prod _ _ Ty) R :- !, bo-k-args.aux {coq.mk-app K [A]} As Ts (Ty A) R. bo-k-args.aux K As Ts X R :- whd1 X X1, !, bo-k-args.aux K As Ts X1 R. % Take in input a mapping function for each parameter % and then do the fixpoint pred bo-params i:int, % current parameter i:int, % number of parameters i:term, % inductive type (input) applied to parameters handled so far i:term, % inductive type (output) applied to parameters handled so far i:term, % inductive arity (input) i:term, % inductive arity (output) i:list term, % output parameters so far o:term. % map function bo-params Lno Lno Ity1 Ity2 A1 _ Ps (fix `f` Recno Fty Bo) :- coq.safe-dest-app Ity1 (global (indt I)) _, coq.env.recursive? I, !, @pi-decl `rec` Fty f\ map-db Ity1 Ity2 f => bo-idx A1 Ity1 Ity2 0 Recno Ps (Bo f) Fty. bo-params Lno Lno Ity1 Ity2 A1 _ Ps Bo :- bo-idx A1 Ity1 Ity2 0 _ Ps Bo _. bo-params N Lno Ity1 Ity2 (prod A Sty1 Rty1) (prod _ Sty2 Rty2) Ps R :- coq.name-suffix A 1 A1, coq.name-suffix A 2 A2, coq.name-suffix A "f" Af, N1 is N + 1, (pi a b f \ mk-map-ty a Sty1 b Sty2 (FAB a b) f _ (Clause a b f)), R = (fun A1 Sty1 a\ fun A2 Sty2 b\ fun Af (FAB a b) f\ Bo a b f), pi a b f\ sigma Ity1A Ity2A \ coq.mk-app Ity1 [a] Ity1A, coq.mk-app Ity2 [b] Ity2A, Clause a b f => decl a A1 Sty1 => decl b A2 Sty2 => decl f Af (FAB a b) => bo-params N1 Lno Ity1A Ity2A (Rty1 a) (Rty2 b) [b|Ps] (Bo a b f). bo-params N Lno Ity1 Ity2 T OT Ps R :- whd1 T T1, whd1 OT OT1, !, bo-params N Lno Ity1 Ity2 T1 OT1 Ps R. bo-params _ _ _ _ _ _ _ _ :- stop "derive.map: Indexed data types not supported". pred map-pi i:A, o:list prop. map-pi (x\ []) []. map-pi (x\ [X x| XS x]) [pi x\ X x | YS] :- map-pi XS YS. pred mk-map-ty i:term, % input variable i:term, % and its type i:term, % output variable i:term, % an its type o:term, % type of a mapping function from input to output i:term, % map function (having the type above) o:int, % arity of the predicate o:list prop. % map-db clause for map function mk-map-ty A (prod _ SA T1) B (prod _ SB T2) (prod `x` SA x\ R x) F N C1 :- map-db SA SB Fa, !, (pi x\ sigma Ax Fx BFx \ coq.mk-app A [x] Ax, coq.mk-app Fa [x] Fx, coq.mk-app B [Fx] BFx, mk-map-ty Ax (T1 x) BFx (T2 BFx) (R x) {coq.mk-app F [x]} M (C x), N is M + 1), map-pi C C1. mk-map-ty A (prod _ S1 T1) B (prod _ _ T2) (prod `x` S1 x\ R x) F N C1 :- (pi x\ sigma Ax Bx \ coq.mk-app A [x] Ax, coq.mk-app B [x] Bx, mk-map-ty Ax (T1 x) Bx (T2 x) (R x) {coq.mk-app F [x]} M (C x), N is M + 1), map-pi C C1. mk-map-ty (app[X|XS] as A) _ (app[Y|YS] as B) _ (prod `x` A _\ B) (app [G|GS] as F) 0 [map-db PLA PLB PLF,map-db A B F] :- drop-last 1 XS LA, drop-last 1 YS LB, drop-last 1 GS LF, coq.mk-app X LA PLA, coq.mk-app Y LB PLB, coq.mk-app G LF PLF. mk-map-ty A _ B _ (prod `x` A _\ B) F 0 [map-db A B F]. % Build a clause %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% pred mk-clause i:int, % current parameter i:int, % number of parameters i:term, % inductive type (input) i:term, % inductive type (output) i:term, % arity of the inductive i:list prop, % premises of the clause i:term, % map function o:prop. % clause for map-db mk-clause N N Ity1 Ity2 _ Todo Map (map-db Ity1 Ity2 Map :- Todo). mk-clause N Lno Ity1 Ity2 (prod _ _ T) Todo Map (pi x y f\ C x y f) :- !, N1 is N + 1, pi x y f\ sigma Ity1x Ity2y Mapf\ coq.mk-app Ity1 [x] Ity1x, coq.mk-app Ity2 [y] Ity2y, coq.mk-app Map [x,y,f] Mapf, mk-clause N1 Lno Ity1x Ity2y (T x) [map-db x y f|Todo] Mapf (C x y f). mk-clause N Lno Ity1 Ity2 X Todo Map C :- whd1 X X1, !, mk-clause N Lno Ity1 Ity2 X1 Todo Map C. %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% pred main i:inductive, i:string, o:list prop. main GR Prefix C :- do! [ T = global (indt GR), coq.env.indt GR _Ind Lno Luno Arity _ _, assert! (Lno = Luno) "derive.map: Non-uniform parameters not supported", % generate map and add to the env bo-params 0 Lno T T Arity Arity [] RSkel, std.assert-ok! (coq.elaborate-skeleton RSkel Rty R) "derive.map generates illtyped term", Name is Prefix ^ "map", coq.ensure-fresh-global-id Name FName, coq.env.add-const FName R Rty @transparent! Funct, % generate clause and add to the db mk-clause 0 Lno T T Arity [] (global (const Funct)) Clause, coq.elpi.accumulate _ "derive.map.db" (clause _ _ Clause), coq.elpi.accumulate _ "derive.map.db" (clause _ _ (map-done GR)), C = [map-done GR,Clause] ]. } coq-elpi-2.1.0/apps/derive/elpi/param1.elpi000066400000000000000000000163451460156013500204430ustar00rootroot00000000000000/* Unary parametricity translation (Realizability) */ /* license: GNU Lesser General Public License Version 2.1 or later */ /* ------------------------------------------------------------------------- */ % Author: Cyril Cohen shorten std.{forall, forall2, do!, rev, map2, map}. :before "subst-fun:fail" coq.subst-fun XS T TXS :- !, coq.mk-app T XS TXS. % this is outside the namespace since the predicate is also the db-one reali (sort prop as P) (fun `s` P x\ prod `s1` x _\ P) :- !. reali (sort _) (fun `s` (sort (typ U)) x\ prod `s1` x _\ (sort (typ V))) :- !, coq.univ.new U, coq.univ.new V. reali (fun N T B) (fun N T x\ fun N1 (TRsubst x) xR\ BR x xR) :- !, do! [ coq.name-suffix `P` N N1, reali T TR, (pi x xR\ reali x xR => reali (B x) (BR x xR)), (TRsubst = x\ {coq.subst-fun [x] TR}) ]. reali (prod N T P as Prod) ProdR :- !, do! [ coq.name-suffix `P` N N1, reali T TR, (pi x xR\ reali x xR => reali (P x) (PR x xR)), ProdR = fun `f` Prod f\ prod N T x\ prod N1 {coq.subst-fun [x] TR} xR\ {coq.subst-fun [{coq.mk-app f [x]}] (PR x xR)} ]. reali (app [A|Bs]) ARBsR :- !, do! [ reali A AR, derive.param1.reali-args Bs BsR, coq.mk-app AR BsR ARBsR ]. reali (let N T V B) LetR :- !, std.do! [ coq.name-suffix `P` N N1, reali T TR, reali V VR, (pi x xR\ reali x xR => reali (B x) (BR x xR)), LetR = let N T V x\ let N1 {coq.mk-app TR [x]} VR xR\ BR x xR ]. reali (match T P Bs) MR :- !, do! [ reali T TR, derive.param1.reali-match P PRM, reali T TR => derive.param1.reali-map Bs BsR, MR = match TR (PRM (x\ match x P Bs)) BsR ]. reali (fix N Rno T F as Fix) FixR :- !, std.do! [ RnoR is 2 * Rno + 1, RnoR1 is RnoR + 1, reali T TR, (pi x xR\ reali x xR => reali (F x) (FR x xR)), (TRsubst = f\ {coq.subst-fun [f] TR}), (pi f xR\ FixBody f xR = let N (TRsubst (F f)) (FR f xR) fr\ {paramX.mk-trivial-match RnoR (TRsubst f) [] fr}), (pi f xR\ coq.mk-eta RnoR1 (TRsubst f) (FixBody f xR) (EtaFixBody f xR)), coq.name-suffix N 1 N1, FixR = (let N T Fix f\ fix N1 RnoR (TRsubst f) xR\ EtaFixBody f xR), ]. namespace derive.param1 { pred reali-args o:list term, o:list term. reali-args [] []. reali-args [X|Xs] [X,XR|XsR] :- do! [ reali X XR, reali-args Xs XsR ]. pred reali-map o:list term, o:list term. reali-map [] []. reali-map [X|Xs] [XR|XsR] :- do! [ reali X XR, reali-map Xs XsR ]. % helpers for match return type pred reali-match i:term, o:((term -> term) -> term). reali-match (fun N T B) PRM :- pi x\ not (B x = fun _ _ _), !, do! [ reali T TR, (pi x xR\ reali x xR => reali (B x) (BR x xR)), coq.name-suffix `P` N N1, (pi z z1\ PRM z = fun N T x\ fun N1 {coq.subst-fun [x] TR} xR\ {coq.mk-app (BR x xR) [z x]}) ]. reali-match (fun N T B) PRM :- do! [ reali T TR, (pi x xR\ reali x xR => reali-match (B x) (BR x xR)), coq.name-suffix N 1 N1, (pi z \ PRM z = fun N T x\ fun N1 {coq.subst-fun [x] TR} xR\ BR x xR z) ]. % Storage: %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% pred reali-store i:string, % Name suffix for the type class i:term, % Term i:term. % Translation reali-store N X XR :- !, Nreali is "reali_" ^ N, Args = [_, _, X, XR], T1 = app [{{ lib:@param1.store_reali }}|Args], std.assert-ok! (coq.typecheck T1 T2) "reali-store: T1 illtyped", coq.ensure-fresh-global-id Nreali FNreali, coq.env.add-const FNreali T1 T2 _ GR, @global! => coq.TC.declare-instance (const GR) 0. pred reali-store-indc i:string, i:constructor, i:constructor. reali-store-indc Prefix K XR :- reali-store {calc (Prefix ^ {coq.gref->id (indc K)})} (global (indc K)) (global (indc XR)). % toplevel predicates %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% pred dispatch i:gref, % input of the translation i:string, % the name o:list prop. % the clause dispatch (const GR) Prefix Clauses :- !, do! [ Term = global (const GR), Name is Prefix ^ {coq.gref->id (const GR)}, std.assert! (coq.env.const GR (some V) Ty) "param1: cannot handle axioms", reali V VR, reali Ty TyR, coq.mk-app TyR [Term] TyRV, % apparently calling the type checker with the expected type is weaker in this case std.assert-ok! (coq.typecheck VR VRTy) "param1: illtyped constant", std.assert-ok! (coq.unify-leq VRTy TyRV) "param1: constant does not have the right type", coq.ensure-fresh-global-id Name FName, coq.env.add-const FName VR TyRV _ TermR, reali-store Name Term (global (const TermR)), C1 = (reali Term (global (const TermR)) :- !), coq.elpi.accumulate _ "derive.param1.db" (clause _ (before "reali:fail") C1), C2 = (realiR Term (global (const TermR)) :- !), coq.elpi.accumulate _ "derive.param1.db" (clause _ (before "realiR:fail") C2), coq.elpi.accumulate _ "derive.param1.db" (clause _ _ (reali-done (const GR))), Clauses = [C1, C2, reali-done (const GR)] ]. pred prefix-indc i:string, i:constructor, o:pair constructor id. prefix-indc Prefix K (pr K NewName) :- coq.gref->id (indc K) Name, NewName is Prefix ^ Name. dispatch (indt GR) Prefix Clauses :- !, do! [ Ind = global (indt GR), coq.env.indt GR _ _ Lno Ty Knames Ktypes, LnoR is 2 * Lno, pi new_name\ sigma KnamesR KtypesR TyR\ ( reali Ind (global (indt new_name)) => reali Ty TyR, reali Ind (global (indt new_name)) => map2 Knames Ktypes (k\ ty\ r\ sigma tyr\ reali ty tyr, coq.subst-fun [global (indc k)] tyr r) KtypesR, map Knames (prefix-indc Prefix) KnamesR, NewName is Prefix ^ {coq.gref->id (indt GR)}, coq.ensure-fresh-global-id NewName FNewName, coq.build-indt-decl (pr new_name FNewName) tt LnoR LnoR {coq.subst-fun [Ind] TyR} KnamesR KtypesR DeclR ), std.assert-ok! (coq.typecheck-indt-decl DeclR) "derive.param1 generates illtyped inductive", coq.env.add-indt DeclR GRR, reali-store NewName Ind (global (indt GRR)), coq.env.indt GRR _ _ _ _ RealNamesR _, Prefix1 is NewName ^ "_", forall2 Knames RealNamesR (reali-store-indc Prefix1), C1 = (reali Ind (global (indt GRR)) :- !), coq.elpi.accumulate _ "derive.param1.db" (clause _ (before "reali:fail") C1), C2 = (realiR Ind (global (indt GRR)) :- !), coq.elpi.accumulate _ "derive.param1.db" (clause _ (before "realiR:fail") C2), map2 Knames RealNamesR (a\ b\ r\ r = reali (global (indc a)) (global (indc b))) CK, forall CK (c\ coq.elpi.accumulate _ "derive.param1.db" (clause _ (before "reali:fail") c)), coq.elpi.accumulate _ "derive.param1.db" (clause _ _ (reali-done (indt GR))), Clauses = [reali-done (indt GR), C1,C2|CK] ]. dispatch (indc _) _ _ :- coq.error "derive.param1: cannot translate a constructor". pred main i:gref, i:string, o:list prop. main T _ Clauses :- dispatch T "is_" Clauses. } /* %%%%%%%%%%%%%%%%%%%%% % Tactic entrypoint % %%%%%%%%%%%%%%%%%%%%% % We disable coq-refiner :before "refiner-assign-evar" evar _ _ _ :- !. pred ctx->TC i:(list prop), o:(list (pair term term)). ctx->TC [] [] :- !. ctx->TC [decl X _ Ty |Xs] [pr X Ty|Is] :- !, ctx->TC Xs Is. ctx->TC [def X _ _ _ Ty |Xs] [pr X Ty|Is] :- !, ctx->TC Xs Is. solve _ [goal Ctx Ev (app[{{@reali}}, T, TR, X, XR]) _] _ :- !, coq.sigma.print, coq.say "goal->TC" {ctx->TC Ctx}, coq.say "searching reali for" X, reali T TR, reali X XR, Ev = app [{{@Reali}}, T, TR, X, XR], coq.typecheck Ev Ty ok, coq.say "Ty=" Ty. */ coq-elpi-2.1.0/apps/derive/elpi/param1_congr.elpi000066400000000000000000000045561460156013500216340ustar00rootroot00000000000000/* param1 holds on the full type */ /* license: GNU Lesser General Public License Version 2.1 or later */ /* ------------------------------------------------------------------------- */ shorten std.{forall, map2-filter, do!}. namespace derive.param1.congr { pred body-params i:int, i:term, i:term, i:term, i:term, o:term. body-params 0 (prod X TX x\ prod P (PX x) (Ty x)) KArgs1 KArgs2 R RT :- !, R = {{ fun (x : lp:TX) (p1 p2 : lp:(PX x)) (e : lib:@elpi.eq lp:(PX x) p1 p2) => lp:(Bo x p1 p2 e) }}, RT = {{ forall (x : lp:TX) (p1 p2 : lp:(PX x)) (e : lib:@elpi.eq lp:(PX x) p1 p2), lp:(BoTy x p1 p2 e) }}, @pi-decl X TX x\ @pi-decl P (PX x) p1\ sigma OTy\ @pi-decl P (PX x) p2\ @pi-decl `e` {{ lib:@elpi.eq lp:{{PX x}} lp:p1 lp:p2 }} e\ Bo x p1 p2 e = match e (OT x p1) [B x p1], body-params 0 (Ty x p1) {coq.mk-app KArgs1 [x,p1]} {coq.mk-app KArgs2 [x,p2]} (B1 x p1 p2 e) (RTB x p1 p2 e), OT x p1 = {{ fun (i : lp:{{PX x}}) (eq : lib:@elpi.eq lp:{{PX x}} lp:p1 i) => lp:(OTy i eq) }}, (pi i eq \ copy p2 i => copy e eq => copy (RTB x p1 p2 e) (OTy i eq)), !, (copy p2 p1 => copy (B1 x p1 p2 e) (B x p1)), !, BoTy x p1 p2 e = OTy p2 e. body-params 0 Ty KArgs1 KArgs2 R RT :- !, R = {{ lib:@elpi.erefl lp:Ty lp:KArgs1 }}, RT = {{ lib:@elpi.eq lp:Ty lp:KArgs1 lp:KArgs2 }}. body-params N (prod X TX x\ prod P (PX x) (Ty x)) K1 K2 R RT :- N > 0, M is N - 2, R = {{ fun (x : lp:TX) (p : lp:(PX x)) => lp:(Bo x p) }}, RT = {{ forall (x : lp:TX) (p : lp:(PX x)), lp:(BT x p) }}, @pi-decl X TX x\ @pi-decl P (PX x) p\ body-params M (Ty x p) {coq.mk-app K1 [x,p]} {coq.mk-app K2 [x,p]} (Bo x p) (BT x p). pred main-k i:string, i:int, i:constructor, i:term, o:prop. main-k Prefix Lno K KT Clause :- do! [ Name is Prefix ^ {coq.gref->id (indc K)}, body-params Lno KT (global (indc K)) (global (indc K)) R RT_, % coq.say {coq.term->string R}, coq.typecheck R RT ok, coq.env.add-const Name R RT @transparent! Cst, Clause = param1-congr-db K (global (const Cst)) ]. pred main i:inductive, i:string, o:list prop. main GR Prefix Clauses :- coq.env.indt GR _ Lno _ _ K KT, map2-filter K KT (main-k Prefix Lno) Clauses, forall Clauses (x\ coq.elpi.accumulate _ "derive.param1.congr.db" (clause _ _ x)). } % vim:set ft=lprolog spelllang=: coq-elpi-2.1.0/apps/derive/elpi/param1_functor.elpi000066400000000000000000000212211460156013500221700ustar00rootroot00000000000000/* map over a container */ /* license: GNU Lesser General Public License Version 2.1 or later */ /* ------------------------------------------------------------------------- */ shorten std.{assert!, do!, length, split-at, drop-last, rev, append}. param1-functor-db (app[global (indt GR1)|A1]) (app[global (indt GR2)|A2]) R :- coq.env.indt GR1 _ Lno1 _ _ _ _, coq.env.indt GR2 _ Lno2 _ _ _ _, {length A1} > Lno1, {length A2} > Lno2, split-at Lno1 A1 Args1 Points1, split-at Lno2 A2 Args2 Points2, Points1 = Points2, !, param1-functor-db {coq.mk-app (global (indt GR1)) Args1} {coq.mk-app (global (indt GR2)) Args2} F, coq.mk-app F Points1 R. namespace derive.param1.functor { pred skip i:int. % position of a parameter that has to be skipped % Building the body %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% pred self o:term. pred bo-idx i:term, % inductive arity (input) i:term, % inductive type (input) applied to params & idx handled so far i:term, % inductive type (output) applied to params & idx handled so far i:int, % current index no o:int, % Recno i:list term, % rev list of (output) parameters o:term, % body o:term. % type bo-idx (prod _ S1 T1) Ity1 Ity2 N M Ps (fun `x` S1 Bo) (prod `x` S1 Ty) :- !, pi x\ sigma Ity1x Ity2x\ coq.mk-app Ity1 [x] Ity1x, coq.mk-app Ity2 [x] Ity2x, N1 is N + 1, decl x `x` S1 => bo-idx (T1 x) Ity1x Ity2x N1 M Ps (Bo x) (Ty x). bo-idx (sort _) Ity1 Ity2 N N Ps (fun `x` Ity1 Bo) (prod `_` Ity1 _\ Ity2) :- !, @pi-decl `x` Ity1 x\ coq.build-match x Ity1 (bo-idx-rty Ps Ity2) (bo-k-args Ps) (Bo x). bo-idx X Ity1 Ity2 N M Ps R1 R2 :- whd1 X X1, !, bo-idx X1 Ity1 Ity2 N M Ps R1 R2. pred bo-idx-rty i:list term, i:term, i:term, i:list term, i:list term, o:term. bo-idx-rty Ps ItyArgs _ Vs _ R :- rev Vs [_|IdxsRev], rev IdxsRev Idxs, coq.safe-dest-app ItyArgs HD _, coq.mk-app HD {append {rev Ps} Idxs} R. pred bo-k-args i:list term, i:term, i:term, i:list term, i:list term, o:term. bo-k-args ParamsRev K _ Args Tys R :- rev ParamsRev Params, coq.safe-dest-app K (global (indc GR)) _, coq.env.typeof (indc GR) T, coq.subst-prod Params T KT, (bo-k-args.aux {coq.mk-app (global (indc GR)) Params} Args Tys KT R). bo-k-args.aux K [A,PA|Args] [_,TPA|Types] {{ forall x (px : lp:(TPB x)), lp:(Ty x px) }} R :- not(same_term TPA (TPB A)), param1-functor-db TPA (TPB A) F, !, coq.mk-app K [A, {{ lp:F lp:PA }}] KAPFA, bo-k-args.aux KAPFA Args Types (Ty A KAPFA) R. bo-k-args.aux K [A,PA|Args] [_,_|Types] {{ forall x px, lp:(Ty x px) }} R :- coq.mk-app K [A,PA] KAPA, bo-k-args.aux KAPA Args Types (Ty A KAPA) R. bo-k-args.aux R [] [] _ R. % Take in input a mapping function for each parameter (not to be skipped) % and then do the fixpoint pred bo-params i:int, % current parameter i:int, % number of parameters i:term, % inductive type (input) applied to parameters handled so far i:term, % inductive type (output) applied to parameters handled so far i:term, % inductive arity (input) i:term, % inductive arity (output) i:list term, % output parameters so far o:term. % map function pred mk-rec-clause i:term, i:term, i:term, i:term, o:prop. mk-rec-clause (prod _ _ x\prod _ _ (P x)) T1 T2 F (pi x px\C x px) :- pi x px\ mk-rec-clause (P x px) {coq.mk-app T1 [x,px]} {coq.mk-app T2 [x,px]} {coq.mk-app F [x,px]} (C x px). mk-rec-clause (prod _ _ _\sort _) T1 T2 F (param1-functor-db T1 T2 F). pred mk-rec-clause-app i:term, i:term, i:term, i:term, o:prop. mk-rec-clause-app (prod _ _ x\prod _ _ (P x)) T1 T2 F (pi x px py\C x px py) :- pi x px py\ mk-rec-clause-app (P x px) {coq.mk-app T1 [x,px]} {coq.mk-app T2 [x,py]} {coq.mk-app F [x,px]} (C x px py). mk-rec-clause-app (prod _ _ _\sort S) T1 T2 F (pi x\C x) :- pi x \ mk-rec-clause-app (sort S) {coq.mk-app T1 [x]} {coq.mk-app T2 [x]} {coq.mk-app F [x]} (C x). mk-rec-clause-app (sort _) T1 T2 F (param1-functor-db T1 T2 F). bo-params Lno Lno Ity1 Ity2 A1 _ Ps (fix `f` Recno Fty Bo) :- !, @pi-decl `rec` Fty f\ mk-rec-clause A1 Ity1 Ity2 f (C f), mk-rec-clause-app A1 Ity1 Ity2 f (D f), (D f) => (C f) => bo-idx A1 Ity1 Ity2 0 Recno Ps (Bo f) Fty. bo-params N Lno Ity1 Ity2 {{ forall (a : lp:T1) (p : a -> Type), lp:(Rty1 a p) }} {{ forall (a : _) (p : a -> Type), lp:(Rty2 a p) }} Ps R :- whd T1 [] {{ Type }} [], !, N1 is N + 2, (pi a b f \ mk-map-ty a {{ lp:a -> Type }} b {{ lp:b -> Type }} (FAB a b) f _ (Clause a b f)), R = {{ fun (a : Type) (pa pb : a -> Type) (f : forall x : a, pa x -> pb x) => lp:(Bo a pa pb f) }}, pi a pa pb f\ sigma Ity1A Ity2A \ coq.mk-app Ity1 [a,pa] Ity1A, coq.mk-app Ity2 [a,pb] Ity2A, Clause pa pb f => decl a `a` {{ Type }} => decl pa `pa` {{ lp:a -> Type }} => decl pb `pb` {{ lp:a -> Type }} => decl f `f` (FAB pa pb) => bo-params N1 Lno Ity1A Ity2A (Rty1 a pa) (Rty2 a pb) [pb,a|Ps] (Bo a pa pb f). bo-params N Lno Ity1 Ity2 (prod A Sty1 Rty1) (prod _ _ Rty2) Ps R :- N1 is N + 1, R = (fun A Sty1 a\ Bo a), pi a\ sigma Ity1A Ity2A \ coq.mk-app Ity1 [a] Ity1A, coq.mk-app Ity2 [a] Ity2A, decl a A Sty1 => bo-params N1 Lno Ity1A Ity2A (Rty1 a) (Rty2 a) [a|Ps] (Bo a). pred map-pi i:A, o:list B. map-pi (x\ []) []. map-pi (x\ [X x| XS x]) [pi x\ X x | YS] :- map-pi XS YS. pred mk-map-ty i:term, % input variable i:term, % and its type i:term, % output variable i:term, % an its type o:term, % type of a mapping function from input to output i:term, % map function (having the type above) o:int, % arity of the predicate o:list prop. % param1-functor-db clause for map function mk-map-ty A (prod _ SA T1) B (prod _ SB T2) (prod `x` SA x\ R x) F N C1 :- param1-functor-db SA SB Fa, !, (pi x\ sigma Ax Fx BFx \ coq.mk-app A [x] Ax, coq.mk-app Fa [x] Fx, coq.mk-app B [Fx] BFx, mk-map-ty Ax (T1 x) BFx (T2 BFx) (R x) {coq.mk-app F [x]} M (C x), N is M + 1), map-pi C C1. mk-map-ty A (prod _ S1 T1) B (prod _ _ T2) (prod `x` S1 x\ R x) F N C1 :- (pi x\ sigma Ax Bx \ coq.mk-app A [x] Ax, coq.mk-app B [x] Bx, mk-map-ty Ax (T1 x) Bx (T2 x) (R x) {coq.mk-app F [x]} M (C x), N is M + 1), map-pi C C1. mk-map-ty (app[X|XS] as A) _ (app[Y|YS] as B) _ (prod `x` A _\ B) (app [G|GS] as F) 0 [param1-functor-db PLA PLB PLF,param1-functor-db A B F] :- drop-last 1 XS LA, drop-last 1 YS LB, drop-last 1 GS LF, coq.mk-app X LA PLA, coq.mk-app Y LB PLB, coq.mk-app G LF PLF. mk-map-ty A _ B _ (prod `x` A _\ B) F 0 [param1-functor-db A B F]. % Build a clause %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% pred mk-clause i:int, % current parameter i:int, % number of parameters i:term, % inductive type (input) i:term, % inductive type (output) i:term, % arity of the inductive i:list prop, % premises of the clause i:term, % map function o:prop, i:inductive, i:list bool, o:prop. % clause for param1-functor-db mk-clause N N Ity1 Ity2 _ Todo Map (param1-functor-db Ity1 Ity2 Map :- Todo) I Mask (param1-functor-for I F MaskRev) :- coq.safe-dest-app Map (global F) _, std.rev Mask MaskRev. mk-clause N Lno Ity1 Ity2 {{ forall (a : lp:Ty) (pa : a -> Type), lp:(T a pa) }} Todo Map (pi x px py f\ C x px py f) I M CF :- whd Ty [] {{ Type }} [], !, N1 is N + 2, pi x px py f\ sigma Ity1x Ity2y Mapf\ coq.mk-app Ity1 [x,px] Ity1x, coq.mk-app Ity2 [x,py] Ity2y, coq.mk-app Map [x,px,py,f] Mapf, mk-clause N1 Lno Ity1x Ity2y (T x px) [param1-functor-db px py f|Todo] Mapf (C x px py f) I [tt,ff|M] CF. mk-clause N Lno Ity1 Ity2 (prod _ _ T) Todo Map (pi x\ C x) I M CF :- !, N1 is N + 1, pi x\ sigma Ity1x Ity2x Mapf\ coq.mk-app Ity1 [x] Ity1x, coq.mk-app Ity2 [x] Ity2x, coq.mk-app Map [x] Mapf, mk-clause N1 Lno Ity1x Ity2x (T x) Todo Mapf (C x) I [ff|M] CF. mk-clause N Lno Ity1 Ity2 X Todo Map C I M CF :- whd1 X X1, !, mk-clause N Lno Ity1 Ity2 X1 Todo Map C I M CF. %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% pred main i:inductive, i:string, o:list prop. main GR Suffix C :- do! [ coq.env.indt GR _Ind Lno Luno Arity _ _, assert! (Lno = Luno) "derive.param1.functor: Non-uniform parameters not supported", % generate map and add to the env T = global (indt GR), bo-params 0 Lno T T Arity Arity [] R, std.assert-ok! (coq.typecheck R Rty) "derive.param1_functor generates illtyped term", Name is {coq.gref->id (indt GR)} ^ Suffix, coq.env.add-const Name R Rty @transparent! Funct, % generate clause and add to the db mk-clause 0 Lno T T Arity [] (global (const Funct)) Clause1 GR [] Clause2, C = [Clause1, Clause2], std.forall C (x\coq.elpi.accumulate _ "derive.param1.functor.db" (clause _ _ x)), ]. } coq-elpi-2.1.0/apps/derive/elpi/param1_inhab.elpi000066400000000000000000000117071460156013500216010ustar00rootroot00000000000000/* param1 holds on the full type */ /* license: GNU Lesser General Public License Version 2.1 or later */ /* ------------------------------------------------------------------------- */ shorten std.{zip, assert!, do!, map, map2, rev}. namespace derive.param1.inhab { % local data base to map a constructor K of T (applied to params) to % the pair isK and its type, eg ({{Zero}} `-> pr {{isZero}} {{isNat Zero}})) type (`->) term -> pair term term -> prop. %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% pred search i:term, i:term, o:term. % given T and isT it builds a proof forall x:T, isT x search _ Goal P :- std.assert! (param1-inhab-db Goal P) "derive.param1_inhab: cannot prove inhabitation". %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% pred prove-args % for each (K x ..) we must produce (isK x x_isX ..) i:list term, % the variables (x in the example above) i:term, % the type of isK o:list term. % x and x_isX prove-args [] _ []. prove-args [V|VS] (prod _ T x\ prod _ _ (px\ F x px)) [V,PV | RS] :- reali T TR, !, % out of the type of x we get isX search T TR PT, % PT is a proof that forall x, isX x PV = app[PT,V], % PV is the x_isX above reali V PV => prove-args VS (F V PV) RS. pred oty i:(term -> term), i:term, i:list term, i:list term, o:term. oty F _ V _ R :- rev V [X|_], R = F X. pred body i:term, i:term, i:list term, i:list term, o:term. body K _ V _ R :- coq.safe-dest-app K Kname _, Kname `-> (pr KR KRT), prove-args V KRT Args, coq.mk-app KR Args R. %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% pred body-params i:int, % number of params left i:term, % inductive type applied to parameters treated so far i:term, % inductive type arity to process i:list term, % construcors applied to parameters treated so far i:list term, % construcor's types instantiated to parameters treated so far o:term. body-params 0 IsT (prod _ T _\ sort _) K KT R :- coq.safe-dest-app T (global (indt GR)) _, coq.env.recursive? GR, !, RT = (x\ {coq.mk-app IsT [x]}), R = {{ fix IH (x : lp:T) {struct x} : lp:(RT x) := lp:(Bo IH x) }}, coq.env.indt GR _ _ _ _ KX _, map2 KX {zip K KT} (a\b\r\ r = (global (indc a)) `-> b) K2KR, K2KR => % K `-> (pr isK isKtype) @pi-decl `IH` (prod `x` T x\ RT x) f\ @pi-decl `x` T x\ param1-inhab-db IsT f => coq.build-match x T (oty RT) body (Bo f x). body-params 0 IsT (prod _ T _\ sort _) K KT R :- !, RT = (x\ {coq.mk-app IsT [x]}), R = {{ fun (x : lp:T) => lp:(Bo x) }}, coq.safe-dest-app T (global (indt GR)) _, coq.env.indt GR _ _ _ _ KX _, map2 KX {zip K KT} (a\b\r\ r = (global (indc a)) `-> b) K2KR, K2KR => % K `-> (pr isK isKtype) @pi-decl `x` T x\ coq.build-match x T (oty RT) body (Bo x). % param1 have the form : isT A (P : A -> Type) .. , so we process two % binders at a time and we assume (H : trivial P) for each A and P body-params N IsT (prod A TA a\ prod P (TP a) (F a)) K KT R :- N > 0, coq.sort? TA, !, M is N - 2, R = (fun A TA a\ fun P (TP a) p\ fun _ {{ lib:elpi.derive.full lp:a lp:p }} pf\ Bo a p pf), @pi-decl A TA a\ @pi-decl P (TP a) p\ @pi-decl _ {{ lib:elpi.derive.full lp:a lp:p }} pf\ sigma KAP KTAP\ map K (k\ coq.mk-app k [a,p]) KAP, map KT (coq.subst-prod [a,p]) KTAP, reali a p => param1-inhab-db p pf => % to prove (P x) use (H x) body-params M {coq.mk-app IsT [a,p]} (F a p) KAP KTAP (Bo a p pf). body-params N IsT (prod A TA a\ prod P (TP a) (F a)) K KT R :- N > 0, !, M is N - 2, R = (fun A TA a\ fun P (TP a) p\ Bo a p), @pi-decl A TA a\ @pi-decl P (TP a) p\ sigma KAP KTAP\ map K (k\ coq.mk-app k [a,p]) KAP, map KT (coq.subst-prod [a,p]) KTAP, reali a p => body-params M {coq.mk-app IsT [a,p]} (F a p) KAP KTAP (Bo a p). body-params _ IsT _ _ _ _ :- M is "derive.param1_inhab: wrong shape " ^ {coq.term->string IsT} ^ ". It does not look like a unary parametricity translation of an inductive with no indexes.", stop M. pred main i:inductive, i:string, o:list prop. main GR Suffix [ClauseW, param1-inhab-done GR] :- do! [ coq.env.indt GR Ind Lno Luno Arity K KT, assert! (Ind = tt) "derive.param1_inhab: Coinductive types are not supported", assert! (Lno = Luno) "derive.param1_inhab: Non-uniform parameters not supported", body-params Lno (global (indt GR)) Arity {std.map K (k\r\ r = global (indc k))} KT RSkel, % coq.say {coq.term->string R}, std.assert-ok! (coq.elaborate-skeleton RSkel RT R) "derive.param1_inhab generates illtyped term", Name is {coq.gref->id (indt GR)} ^ Suffix, coq.env.add-const Name R RT @transparent! Witness, ClauseW = (param1-inhab-db (global (indt GR)) (global (const Witness))), coq.elpi.accumulate _ "derive.param1.trivial.db" (clause _ _ ClauseW), coq.elpi.accumulate _ "derive.param1.trivial.db" (clause _ _ (param1-inhab-done GR)), ]. } coq-elpi-2.1.0/apps/derive/elpi/param1_trivial.elpi000066400000000000000000000117261460156013500221730ustar00rootroot00000000000000/* param1 holds on the full type */ /* license: GNU Lesser General Public License Version 2.1 or later */ /* ------------------------------------------------------------------------- */ shorten std.{assert!, do!, drop-last}. namespace derive.param1.trivial { pred prove-args i:list term, i:list term, o:list term. prove-args [] [] []. prove-args [X,PX|Rest] [TX,TPX_X|TRest] [X,P1,PX,P2|PRest] :- coq.safe-dest-app TPX_X HD ARGS, drop-last 1 ARGS ARG, coq.mk-app HD ARG TPX, param1-trivial-db TPX P, !, P1 = {{ lib:elpi.derive.trivial_full lp:TX lp:TPX lp:P lp:X }}, P2 = {{ lib:elpi.derive.trivial_uniq lp:TX lp:TPX lp:P lp:X lp:PX }}, prove-args Rest TRest PRest. pred oty i:term, i:term, i:term, i:list term, i:list term, o:term. oty IsT W _ [Idx,V] _ {{ lib:@elpi.eq lp:Ty lp:Wx lp:V }} :- Ty = app[IsT,Idx], Wx = app[W,Idx]. pred body i:term, i:term, i:term, i:term, i:list term, i:list term, o:term. body _ _ K (app _) V VT R :- std.do! [ /* coq.safe-dest-app K (global (indc Kname)) Params, prove-args V VT P, assert! (param1-congr-db Kname CongrK) "run derive.param1.congr first", coq.mk-app CongrK Params Rhd, coq.mk-app Rhd P R,*/ trivialize-param1 V VT Triv, do-args {std.rev V} {std.rev VT} {std.rev Triv} [] K R, ]. pred trivialize-param1 i:list term, i:list term, o:list term. trivialize-param1 [] [] []. trivialize-param1 [_,_|XS] [_,TPX|PS] [TPX1,T|TS] :- std.do! [ coq.safe-dest-app TPX HD ARGS, drop-last 1 ARGS ARG, coq.mk-app HD ARG TPX1, param1-trivial-db TPX1 T, trivialize-param1 XS PS TS, ]. pred do-args i:list term, i:list term, i:list term, i:list term, i:term, o:term. do-args [] [] [] _ _ {{ lib:@elpi.erefl _ _ }}. do-args [PX,X|XS] [_,TX|PS] [Triv,P|Trivs] Old K R :- std.do! [ Q = {{ lib:elpi.derive.trivial_uniq lp:TX lp:P lp:Triv lp:X lp:PX }}, F = {{ lib:elpi.derive.trivial_full lp:TX lp:P lp:Triv lp:X }}, std.assert-ok! (coq.typecheck Q TQ) "wtf", (pi v\ coq.mk-app K {std.rev {std.append {std.append Old [v,X]} XS}} (K1 v)), std.append Old [F,X] Old1, coq.build-match Q TQ (do-oty K1 PX) (do-body XS PS Trivs Old1 K) R, ]. pred do-oty i:(term -> term), i:term, i:term, i:list term, i:list term, o:term. do-oty K E _ [V,_] _ {{ lib:@elpi.eq _ _ lp:KV }} :- copy E V => copy (K V) KV. pred do-body i:list term, i:list term, i:list term, i:list term, i:term, i:term, i:term, i:list term, i:list term, o:term. do-body XS PS Trivs Old K _ _ _ _ R :- do-args XS PS Trivs Old K R. %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% pred body-params i:int, % number of params left i:term, % inductive type applied to parameters treated so far i:term, % inductive type arity to process o:term. body-params 0 IsT (prod _ T _\ sort _) R :- !, std.do! [ std.assert! (param1-inhab-db IsT W) "www", R = {{ fun x : lp:T => lib:elpi.derive.contracts lp:T lp:IsT x (lp:W x) ((fix IH (x : lp:T) (y : lp:IsT x) {struct y} : lib:@elpi.eq (lp:IsT x) (lp:W x) y := lp:{{ { param1-trivial-db IsT {{ fun x : lp:T => lib:elpi.derive.contracts lp:T lp:IsT x (lp:W x) (IH x) }} => coq.build-match {{y}} {{lp:IsT x}} (oty IsT W) (body IsT W) } }} ) x) }}, ]. % param1 have the form : isT A (P : A -> Type) .. , so we process two % binders at a time and we assume (H : trivial P) for each A and P body-params N T (prod A TA a\ prod P (TP a) (F a)) R :- N > 0, coq.sort? TA, !, M is N - 2, R = (fun A TA a\ fun P (TP a) p\ fun _ {{ lib:elpi.derive.trivial lp:a lp:p }} pf\ { decl a A TA => decl p P (TP a) => decl pf `_` {{ lib:elpi.derive.trivial lp:a lp:p }} => reali a p => param1-trivial-db p pf => % to prove (P x) use (H x) param1-inhab-db p {{ lib:elpi.derive.trivial_full lp:a lp:p lp:pf }} => % to prove (P x) use (H x) body-params M {coq.mk-app T [a,p]} (F a p)}). body-params N T (prod A TA a\ prod P (TP a) (F a)) R :- N > 0, !, M is N - 2, R = (fun A TA a\ fun P (TP a) p\ { decl a A TA => decl p P (TP a) => reali a p => body-params M {coq.mk-app T [a,p]} (F a p)}). body-params _ T _ _ :- coq.say "derive.param1_trivial: wrong shape " {coq.term->string T} ". It does not look like a unary parametricity translation of an inductive with no indexes.", fail. pred main i:inductive, i:string, o:list prop. main GR Suffix [Clause,param1-trivial-done GR] :- do! [ coq.env.indt GR _ Lno _ Arity _ _, body-params Lno (global (indt GR)) Arity R, % coq.say {coq.term->string R}, std.assert-ok! (coq.typecheck R RT) "derive.param1_trivial generates illtyped term", Name is {coq.gref->id (indt GR)} ^ Suffix, coq.env.add-const Name R RT @transparent! Cst, Clause = (param1-trivial-db (global (indt GR)) (global (const Cst))), coq.elpi.accumulate _ "derive.param1.trivial.db" (clause _ _ Clause), coq.elpi.accumulate _ "derive.param1.trivial.db" (clause _ _ (param1-trivial-done GR)), ]. } coq-elpi-2.1.0/apps/derive/elpi/param2.elpi000066400000000000000000000204111460156013500204310ustar00rootroot00000000000000/* Binary parametricity translation */ /* license: GNU Lesser General Public License Version 2.1 or later */ /* ------------------------------------------------------------------------- */ % Author: Cyril Cohen shorten std.{forall, forall2, do!, rev, map2, map}. :before "subst-fun:fail" coq.subst-fun XS T TXS :- !, coq.mk-app T XS TXS. % this is outside the namespace since the predicate is also the db-one param (sort prop as P) P (fun `s` P x\ fun `s` P y\ prod `s1` x _\ prod `s2` y _\ P) :- !. param (sort _ as P) P (fun `u` (sort (typ U)) x\ fun `v` (sort (typ V)) y\ prod `s1` x _\ prod `s2` y _\ P) :- !, coq.univ.new U, coq.univ.new V. param (fun N T B) (fun N T1 B1) (fun N T x\ fun N T1 x1\ fun N (TRsubst x x1) xR\ BR x x1 xR) :- !, do! [ param T T1 TR, (pi x x1 xR\ param x x1 xR => param (B x) (B1 x1) (BR x x1 xR)), (TRsubst = x\ x1\ {coq.subst-fun [x,x1] TR}) ]. param (prod N T P as Prod) Prod1 ProdR :- !, do! [ param T T1 TR, (pi x x1 xR\ param x x1 xR => param (P x) (P1 x1) (PR x x1 xR)), Prod1 = prod N T1 P1, ProdR = fun `f` Prod f\ fun `g` Prod1 g\ prod N T x\ prod N T1 x1\ prod N {coq.subst-fun [x,x1] TR} xR\ {coq.subst-fun [{coq.mk-app f [x]}, {coq.mk-app g [x1]}] (PR x x1 xR)} ]. param (app [A|Bs]) (app [A1|Bs1]) ARBsR :- !, do! [ param A A1 AR, derive.param2.param-args Bs Bs1 BsR, coq.mk-app AR BsR ARBsR ]. param (let N T V B) Let1 LetR :- !, do! [ param T T1 TR, param V V1 VR, (pi x x1 xR\ param x x1 xR => param (B x) (B1 x1) (BR x x1 xR)), Let1 = let N T1 V1 B1, LetR = let N T V x\ let N T1 V1 x1\ let N {coq.mk-app TR [x,x1]} VR xR\ BR x x1 xR ]. param (match T P Bs) M1 MR :- !, do! [ param T T1 TR, derive.param2.param-match P P1 PRM, param T T1 TR => derive.param2.map-param Bs Bs1 BsR, M1 = match T1 P1 Bs1, MR = match TR (PRM (x\ match x P Bs) (x\ match x P1 Bs1)) BsR ]. param (fix N Rno T F as Fix) Fix1 FixR :- !, do! [ RnoR is 3 * Rno + 2, RnoR1 is RnoR + 1, param T T1 TR, (pi x x1 xR\ param x x1 xR => param (F x) (F1 x1) (FR x x1 xR)), Fix1 = fix N Rno T1 F1, (TRsubst = f\ f1\ {coq.subst-fun [f, f1] TR}), (pi f f1 xR\ FixBody f f1 xR = let N (TRsubst (F f) (F1 f1)) (FR f f1 xR) fr\ {paramX.mk-trivial-match RnoR (TRsubst f f1) [] fr}), (pi f f1 xR\ coq.mk-eta RnoR1 (TRsubst f f1) (FixBody f f1 xR) (EtaFixBody f f1 xR)), FixR = (let N T Fix f\ let N T1 Fix1 f1\ fix N RnoR (TRsubst f f1) xR\ EtaFixBody f f1 xR) ]. namespace derive.param2 { pred param-args o:list term, o:list term, o:list term. param-args [] [] [] :- !. param-args [X|Xs] [X1|Xs1] [X,X1,XR|XsR] :- !, param X X1 XR, !, param-args Xs Xs1 XsR, !. pred map-param o:list term, o:list term, o:list term. map-param [] [] [] :- !. map-param [X|Xs] [X1|Xs1] [XR|XsR]:- !, param X X1 XR, !, map-param Xs Xs1 XsR, !. % helpers for match return type pred param-match i:term, o:term, o:((term -> term) -> (term -> term) -> term). param-match (fun N T B) P1 PRM :- pi x\ not (B x = fun _ _ _), !, param T T1 TR, !, (pi x x1 xR\ param x x1 xR => param (B x) (B1 x1) (BR x x1 xR)), !, P1 = fun N T1 B1, (pi z z1\ PRM z z1 = fun N T x\ fun N T1 x1\ fun N {coq.subst-fun [x,x1] TR} xR\ {coq.mk-app (BR x x1 xR) [z x, z1 x1]}). param-match (fun N T B) P1 PRM :- param T T1 TR, !, (pi x x1 xR\ param x x1 xR => param-match (B x) (B1 x1) (BR x x1 xR)), !, P1 = fun N T1 B1, (pi z z1\ PRM z z1 = fun N T x\ fun N T1 x1\ fun N {coq.subst-fun [x,x1] TR} xR\ BR x x1 xR z z1). %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % translation of inductive types % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% pred param-indt i:inductive, i:bool, i:int, i:int, i:term, i:list term, i:list term, i:inductive, o:bool, o:int, o:int, o:term, o:list term. param-indt GR IsInd Lno _ Ty Knames Ktypes NameR IsInd LnoR LunoR TyR KtypesR :- do! [ LnoR is 3 * Lno, LunoR = LnoR, param (global (indt GR)) (global (indt GR)) (global (indt NameR)) => do! [ param Ty _ TyR, map2 Knames Ktypes param-indc KtypesR ] ]. pred rename-indc i:string, i:constructor, o:pair constructor id. rename-indc Suffix GR (pr GR NameR) :- coq.gref->id (indc GR) Name, NameR is Name ^ Suffix. pred param-indc i:term, i:term, o:term. param-indc K T TRK :- !, param T _ TR, coq.subst-fun [K, K] TR TRK. %%%%%%%%%%%%%%%%%%%%%%%%%%%% % Class storage functions: % %%%%%%%%%%%%%%%%%%%%%%%%%%%% pred store-param i:string, i:term, i:term, i:term. store-param N X X1 XR :- !, Nparam is "param_" ^ N, Args = [_, _, _, X, X1, XR], T1 = app [{{ lib:@param2.store_param }}|Args], std.assert-ok! (coq.typecheck T1 T2) "store-param: T1 illtyped", coq.ensure-fresh-global-id Nparam FNparam, coq.env.add-const FNparam T1 T2 _ C, @global! => coq.TC.declare-instance (const C) 0. pred store-param-indc i:string, i:constructor, i:constructor. store-param-indc Suffix K KR :- store-param {calc ({coq.gref->id (indc K)} ^ Suffix)} (global (indc K)) (global (indc K)) (global (indc KR)). %%%%%%%%%%%%%%%%%%%%%%% % toplevel predicates % %%%%%%%%%%%%%%%%%%%%%%% pred dispatch i:gref, i:string, o:list prop. dispatch (const GR as C) Suffix Clauses :- do! [ Term = global C, NameR is {coq.gref->id C} ^ Suffix, coq.env.const GR (some X) Ty, param Ty _ TyR, coq.mk-app TyR [Term, Term] TyRTermTerm, param X _ XR, % apparently calling the type checker with the expected type is weaker in this case std.assert-ok! (coq.typecheck XR XRTy) "param2: illtyped constant", std.assert-ok! (coq.unify-leq XRTy TyRTermTerm) "param2: constant does not have the right type", coq.ensure-fresh-global-id NameR FNameR, coq.env.add-const FNameR XR TyRTermTerm _ TermR, store-param NameR Term Term (global (const TermR)), C1 = (param Term Term (global (const TermR)) :- !), coq.elpi.accumulate _ "derive.param2.db" (clause _ (before "param:fail") C1), C2 = (paramR Term Term (global (const TermR)) :- !), coq.elpi.accumulate _ "derive.param2.db" (clause _ (before "paramR:fail") C1), coq.elpi.accumulate _ "derive.param2.db" (clause _ _ (param-done C)), Clauses = [param-done C, C1, C2] ]. dispatch (indt I as GR) Suffix Clauses :- do! [ Ind = global GR, coq.env.indt I IsInd Lno Luno Ty Knames Ktypes, NameR is {coq.gref->id GR} ^ Suffix, coq.ensure-fresh-global-id NameR FNameR, map Knames (rename-indc Suffix) KnamesR, std.map Knames (k\r\ r = global (indc k)) Ks, pi new_name\ sigma KtypesR TyR\ ( (param-indt I IsInd Lno Luno Ty Ks Ktypes new_name IsIndR LnoR LunoR TyR KtypesR), coq.build-indt-decl (pr new_name FNameR) IsIndR LnoR LunoR {coq.subst-fun [Ind, Ind] TyR} KnamesR KtypesR DeclR ), std.assert-ok! (coq.typecheck-indt-decl DeclR) "derive.param2 generates illtyped term", coq.env.add-indt DeclR GRR, store-param NameR Ind Ind (global (indt GRR)), coq.env.indt GRR _ _ _ _ RealNamesR _, forall2 Knames RealNamesR (store-param-indc Suffix), C1 = (param Ind Ind (global (indt GRR)) :- !), coq.elpi.accumulate _ "derive.param2.db" (clause _ (before "param:fail") C1), C2 = (paramR Ind Ind (global (indt GRR)) :- !), coq.elpi.accumulate _ "derive.param2.db" (clause _ (before "paramR:fail") C2), map2 Knames RealNamesR (a\ b\ r\ r = param (global (indc a)) (global (indc a)) (global (indc b))) CK, forall CK (c\ coq.elpi.accumulate _ "derive.param2.db" (clause _ (before "param:fail") c)), coq.elpi.accumulate _ "derive.param2.db" (clause _ _ (param-done GR)), Clauses = [param-done GR,C1,C2|CK] ]. dispatch (indc _) _ _ :- coq.error "derive.param2: cannot translate a constructor". pred main i:gref, i:string, o:list prop. main T _ Clauses :- dispatch T "_R" Clauses. } /* %%%%%%%%%%%%%%%%%%%%% % Tactic entrypoint % %%%%%%%%%%%%%%%%%%%%% % We disable coq-refiner :before "refiner-assign-evar" evar _ _ _ :- !. pred ctx->TC i:(list prop), o:(list (pair term term)). ctx->TC [] [] :- !. ctx->TC [decl X _ Ty |Xs] [pr X Ty|Is] :- !, ctx->TC Xs Is. ctx->TC [def X _ _ _ Ty |Xs] [pr X Ty|Is] :- !, ctx->TC Xs Is. solve _ [goal Ctx Ev (app[{{@param}}, T, TR, X, XR]) _] _ :- !, coq.sigma.print, coq.say "goal->TC" {ctx->TC Ctx}, coq.say "searching param for" X, (param T _ TR), (param X _ XR), Ev = app [{{@Param}}, T, TR, X, XR], coq.typecheck Ev Ty ok, coq.say "Ty=" Ty. */ coq-elpi-2.1.0/apps/derive/elpi/paramX_lib.elpi000066400000000000000000000055011460156013500213300ustar00rootroot00000000000000/* coq-elpi: Coq terms as the object language of elpi */ /* license: GNU Lesser General Public License Version 2.1 or later */ /* ------------------------------------------------------------------------- */ namespace paramX { pred mk-trivial-match i:int, i:term, i:list term, i:term, o:term. mk-trivial-match Rno (prod N T P) Args F (fun N T B) :- Rno >= 0, !, std.do! [ Rno' is Rno - 1, (pi x\ decl x N T => mk-trivial-match Rno' (P x) [x|Args] F (B x)), ]. mk-trivial-match Rno Prod Args F R :- Rno >= 0, whd1 Prod Prod1, !, mk-trivial-match Rno Prod1 Args F R. mk-trivial-match -1 P RArgs F Match :- std.do! [ RArgs = [RecArg|ROtherArgs], (decl RecArg _ T, unwind {whd T []} Twhd), % unneeded with elpi 1.13.7 coq.safe-dest-app Twhd (global (indt I)) IndArgs, coq.env.indt I _ Lno _ _ _ _, std.drop Lno IndArgs RIndArgs, coq.build-match RecArg T (mk-trivial-match.rty {std.append RIndArgs [RecArg]} P) (mk-trivial-match.branch Lno RIndArgs {std.rev ROtherArgs} F) Match, ]. pred mk-trivial-match.rty i:list term, i:term, i:term, i:list term, i:list term, o:term. mk-trivial-match.rty Args P _ Vars _ R :- std.do! [ std.map2 Args Vars (x\y\r\ r = copy x y) Subst, Subst => copy P R, ]. pred mk-trivial-match.branch i:int, i:list term, i:list term, i:term, i:term, i:term, i:list term, i:list term, o:term. mk-trivial-match.branch Lno Args OtherArgs F K KTy Vars _ R1 :- std.do! [ coq.mk-app K Vars KArgs, coq.safe-dest-app KTy _ KTyArgs, std.drop Lno KTyArgs IdxVals, std.map2 Args IdxVals (x\y\r\ r = copy x y) Subst, (R = let `K` KTy KArgs x\ {coq.mk-app F {std.append OtherArgs [x]}}), Subst => copy R R1, ]. % prove H G P finds a P : H => G pred prove i:term, i:term, o:term. pred cross i:term. % prove-arg AppliedHyp AppliedGoal Argument ProofAppliedHyp Proof. pred prove-arg i:term, i:term, i:term, i:term, o:term. prove-arg X X _ P P :- !. prove-arg (app [H|Hs]) (app[G|Gs]) X PHX PGX :- std.appendR HArgs [X] Hs, coq.mk-app H HArgs Hyp, std.appendR GArgs [X] Gs, coq.mk-app G GArgs Goal, prove Hyp Goal Proof, coq.mk-app Proof [X,PHX] PGX. prove-arg (prod _ X x\ prod _ (PX x) (H x)) (prod _ _ y\ prod _ (PX y) (G y)) A PA (fun `x` X x\ fun `px` (PX x) (Proof x)) :- pi x px\ prove-arg (H x px) (G x px) {coq.mk-app A [x]} {coq.mk-app PA [x,px]} (Proof x px). pred prove-args i:list term, i:list term, o:list term. prove-args [] [] []. prove-args [X,Pr|Args] [_,PX|ArgsT] [X,Proof|QArgs] :- coq.safe-dest-app PX HD _, cross HD, !, copy PX Goal, (prove-arg PX Goal X Pr Proof ; Proof = Pr), !, prove-args Args ArgsT QArgs. prove-args [X|Args] [PX|ArgsT] [ProofX|QArgs] :- copy PX Goal, prove PX Goal Proof, !, coq.mk-app Proof [X] ProofX, prove-args Args ArgsT QArgs. prove-args [X|Args] [_|ArgsT] [X|QArgs] :- prove-args Args ArgsT QArgs. }coq-elpi-2.1.0/apps/derive/elpi/projK.elpi000066400000000000000000000126571460156013500203510ustar00rootroot00000000000000/* Derive a function "projnK t -> x" iif t is "K ..x.." */ /* license: GNU Lesser General Public License Version 2.1 or later */ /* ------------------------------------------------------------------------- */ shorten std.{append, any->string, zip, map, map2, nth, do!, assert!, flatten}. % TODO: instead of using a context and integers one could % generate the product for the projected argument and use via subst-prod % rather than using copy like crazy namespace derive.projK { pred exT-close i:list int, i:list (pair term term), i:list term, i:term, i:term, o:term, o:term. exT-close [] _ _ T Ty T Ty1 :- copy Ty Ty1. exT-close [N|Mask] Ctx Args T Ty {{ @existT lp:S lp:P lp:A lp:R1 }} {{ @sigT lp:S lp:P }} :- nth N Ctx (pr X TX), copy TX S, P = fun {coq.name-suffix `i` N} S B, nth N Args A, (pi x\ copy X x => exT-close Mask Ctx Args T Ty (R x) (B x)), R1 = R A. pred sigT-close i:list int, i:list (pair term term), i:term, o:term. sigT-close [] _ Ty Ty1 :- copy Ty Ty1. sigT-close [N|Mask] Ctx Ty {{ @sigT lp:S lp:P }} :- nth N Ctx (pr X TX), copy TX S, P = fun {coq.name-suffix `i` N} S B, pi x\ copy X x => sigT-close Mask Ctx Ty (B x). pred body-branch i:int, i:constructor, i:term, i:term, i:list term, i:list term, o:term. body-branch J K K1 _ VS TS R :- default-output J Mask DfltCtx Dflt DfltTy, if (coq.safe-dest-app K1 (global (indc K)) _) (nth J VS X, nth J TS XT, zip VS TS Ctx, Args = VS) (X = Dflt, XT = DfltTy, Ctx = DfltCtx, map DfltCtx fst Args), exT-close Mask Ctx Args X XT R _RT. pred body-ty i:int, i:term, i:list term, i:list term, o:term. body-ty J _ _ _ SigT :- default-output J Mask Args _ T, sigT-close Mask Args T SigT. pred occurs-list i:list (pair term term), i:int, i:term, o:list int. occurs-list [] _ _ []. occurs-list [pr X _|XS] I T [I|IS] :- occurs X T, !, J is I + 1, occurs-list XS J T IS. occurs-list [_|XS] I T IS :- J is I + 1, occurs-list XS J T IS. pred mask-for i:term, i:list (pair term term), o:list int. mask-for T Args Mask :- occurs-list Args 0 T Mask. pred default-output i:int, % gather infos to generate the match o:list int, % mask: the position of the arguments that occur in the type % of the projected one o:list (pair term term), % a context (term,type) of default values o:term, % the default value for the projected argument o:term. % its type pred body-default % makes lambdas for all default arguments + the projected i:term, % constructor type (begin processed) i:int, % current argument i:int, % argument to project i:term, % inductive type applied to parameters and indexes i:list (pair term term), % variables for default arguments i:constructor, % constructor to project o:term. body-default (prod N T F) J OJ IT Args K (fun N T B) :- !, mask-for T Args Mask, J1 is J + 1, pi x\ sigma Def\ if (J = OJ) (Def = [default-output J Mask Args x T]) (Def = []), Def => body-default (F x) J1 OJ IT {append Args [pr x T]} K (B x). body-default X J OJ IT Args K F :- whd1 X X1, !, body-default X1 J OJ IT Args K F. body-default _ _ J IT _ K (fun `i` IT B) :- !, pi i\ coq.build-match i IT (body-ty J) (body-branch J K) (B i). pred body-param % makes lambdas for all parameters and indexes i:term, % arity of the inductive type i:term, % type of the constructor to project i:term, % inductive type applied to the arity processed so far i:int, % number of Parameters left to process i:int, % argument to project i:constructor, % constructor to project o:term. body-param (sort _) KTy IT 0 J K R :- !, body-default KTy 0 J IT [] K R. body-param (prod N T F) KTy IT 0 J K (fun N T B) :- !, pi x\ body-param (F x) KTy {coq.mk-app IT [x]} 0 J K (B x). body-param (prod N T F) (prod _ _ FK) IT Pno J K (fun N T B) :- !, Pno1 is Pno - 1, pi x\ body-param (F x) (FK x) {coq.mk-app IT [x]} Pno1 J K (B x). body-param (prod _ _ _ as X) KTy IT N J K R :- whd1 KTy KTy1, !, body-param X KTy1 IT N J K R. body-param X (prod _ _ _ as KTy) IT N J K R :- whd1 X X1, !, body-param X1 KTy IT N J K R. body-param X KTy IT N J K R :- whd1 X X1, whd1 KTy KTy1, !, body-param X1 KTy1 IT N J K R. % --------------------------------------------------------------------- pred allK-projs i:string, i:int, i:int, i:int, i:term, i:term, i:constructor, i:term, o:list prop. allK-projs _ J J _ _ _ _ _ [] :- !. allK-projs Prefix J JN Paramsno Arity IT K KTy Clauses :- do! [ body-param Arity KTy IT Paramsno J K RSkel, J1 is J + 1, Name is Prefix ^ {coq.gref->id (indc K)} ^ {any->string J1}, if (coq.elaborate-skeleton RSkel TyR R ok) (@dropunivs! => coq.env.add-const Name R TyR _ P, Clause = (projK-db K J1 (global (const P)) :- !), coq.elpi.accumulate _ "derive.projK.db" (clause _ (before "projK-db:fail") Clause), Clauses = [Clause|ClausesRest]) (coq.say "skip" Name R, Clauses = ClausesRest), allK-projs Prefix J1 JN Paramsno Arity IT K KTy ClausesRest ]. pred for-K i:string, i:int, i:term, i:term, i:constructor, i:term, o:list prop. for-K Prefix Paramsno Arity IT K KT Clauses :- do! [ coq.count-prods KT N, Argsno is N - Paramsno, allK-projs Prefix 0 Argsno Paramsno Arity IT K KT Clauses ]. pred main i:inductive, i:string, o:list prop. main GR Prefix Clauses :- do! [ T = global (indt GR), coq.env.indt GR _ Paramsno _ Arity Kn Kt, map2 Kn Kt (for-K Prefix Paramsno Arity T) ClausesList, flatten ClausesList Clauses ]. } coq-elpi-2.1.0/apps/derive/elpi/tag.elpi000066400000000000000000000045111460156013500200250ustar00rootroot00000000000000/* constructor name first class representation */ /* license: GNU Lesser General Public License Version 2.1 or later */ /* ------------------------------------------------------------------------- */ % not necessary, but gives pointers to relevant files shorten std.{ fold-map , do! , last }. % from elpi-builtin.elpi shorten coq.{ build-match , bind-ind-arity }. % from coq-lib.elpi shorten coq.{ elaborate-skeleton }. % from coq-builtin.elpi % if we load this file together with others files, we avoid chlashes namespace derive.tag { % we return the clauses for the tag.db since we may need them right away % if we run other derivations immediately pred main i:inductive, i:string, o:list prop. main I Prefix CL :- do! [ % build fun params (x : I params) => ... do-match ... coq.env.indt I _ _ _ Arity _ _, bind-ind-arity (global (indt I)) Arity do-match BodyR, % typecheck (and infer univ constraints) std.assert-ok! (elaborate-skeleton BodyR Ty Body) "derive.tag generates illtyped code", % save constant coq.ensure-fresh-global-id (Prefix ^ "tag") Name, coq.env.add-const Name Body Ty ff C, % store in the DB the tag function, so that other Elpi commands can find it CL = [tag-for I C], std.forall CL (x\ coq.elpi.accumulate _ "derive.tag.db" (clause _ _ x)), ]. % We build the match with dummy branches (you get the lambdas for the % arguments of constructors, then Prop). Then we put the right number in place. pred do-match i:term, i:list term, i:list term, o:term. do-match _ Vars Tys (match X Rty BL1) :- do! [ last Vars X, % the last variable is the one for the inductive type last Tys XTy, build-match X XTy do-rty do-dummy-branch (match X Rty BL), fold-map BL {{ 1 }} do-branch BL1 _, ]. % builds the return clause of the match pred do-rty i:term, i:list term,i:list term, o:term. do-rty _ _ _ {{ lib:elpi.derive.positive }}. % build each branch pred do-dummy-branch i:term, i:term, i:list term, i:list term, o:term. do-dummy-branch _ _ _ _ {{ Prop }}. % dummy % [do-branch InTerm Acc NewTem NewAcc] descends into a branch and puts Acc % in place of the dummy pred do-branch i:term, i:term, o:term, o:term. do-branch {{ Prop }} X X Y :- coq.reduction.lazy.norm {{ lp:X + 1 }} Y. do-branch (fun N T F) X (fun N T R) Y :- @pi-decl N T x\ do-branch (F x) X (R x) Y. }coq-elpi-2.1.0/apps/derive/examples/000077500000000000000000000000001460156013500172635ustar00rootroot00000000000000coq-elpi-2.1.0/apps/derive/examples/readme.v000066400000000000000000000012251460156013500207070ustar00rootroot00000000000000(* README *) From elpi.apps Require Import derive.std. #[module] derive Inductive peano := Zero | Succ (p : peano). Print peano.peano. (* Inductive peano : Set := Zero : peano | Succ : peano -> peano. *) Eval compute in peano.eqb Zero (Succ Zero). (* = false : bool *) About peano.eqb_OK. (* peano.eqb_OK : forall x1 x2 : peano, reflect (x1 = x2) (peano.eqb x1 x2) peano.eqb_OK is not universe polymorphic Arguments peano.eqb_OK x1 x2 peano.eqb_OK is opaque Expands to: Constant elpi.apps.derive.examples.readme.peano.eqb_OK *) #[verbose] derive Nat.add. Check is_add. (* : forall n : nat, is_nat n -> forall m : nat, is_nat m -> is_nat (n + m) *) coq-elpi-2.1.0/apps/derive/examples/usage.v000066400000000000000000000054621460156013500205650ustar00rootroot00000000000000(** This example shows how to use derive *) From Coq Require Import Bool. From elpi.apps Require Import derive.std. Set Uniform Inductive Parameters. (** The best way to call derive is to prefix an Inductive declaration. *) #[module] derive Inductive tickle A := stop | more : A -> tickle -> tickle. (** The command is elaborated to something like: Module tickle. Inductive tickle A := stop | more : A -> tickle -> tickle. derive tickle. End tickle. Notation tickle := tickle.tickle. Notation stop := tickle.stop. Notation more := tickle.more. *) Check more : forall A, A -> tickle A -> tickle A. (** Some goodies *) Check tickle.eqb : (* eq test *) forall A, (A -> A -> bool) -> tickle A -> tickle A -> bool. Check tickle.eqb_OK : (* eq test correctness proof *) forall A f, (forall x y, reflect (x = y) (f x y)) -> forall x y, reflect (x = y) (tickle.eqb A f x y). Check tickle.map : (* map the container *) forall A B, (A -> B) -> tickle A -> tickle B. Check tickle.tickle_R : (* relator (binary parametricity translation) *) forall A B, (A -> B -> Type) -> tickle A -> tickle B -> Type. (** This is a tricky case, since you need a good induction principle for the nested occurrence of tickle. #[verbose] prints all the derivations being run *) #[verbose,module] derive Inductive rtree A := Leaf (a : A) | Node (l : tickle rtree). Check rtree.induction : (* this is the key *) forall A PA P, (forall a, PA a -> P (Leaf A a)) -> (forall l, tickle.is_tickle (rtree A) P l -> P (Node A l)) -> forall x, rtree.is_rtree A PA x -> P x. (** You can also select which derivations you like *) #[verbose, only(lens_laws, eqb), module] derive Record Box A := { contents : A; tag : nat }. Check Box.eqb : forall A, (A -> A -> bool) -> Box A -> Box A -> bool. Import lens. Check @Box._tag : (* the Lens for the second field (A is implicit) *) forall A, Lens (Box A) (Box A) nat nat. Check Box._tag_set_set : (* a Lens law *) forall A (r : Box A) y x, set Box._tag x (set Box._tag y r) = set Box._tag x r. Check Box._tag_contents_exchange : (* another one *) forall A (r : Box A) x y, set Box._tag x (set Box._contents y r) = set Box._contents y (set Box._tag x r). (** Finally, one can derive an existing inductive type. Generated constants are prefixed with nat_ but won't be in the right place, which is where the type is defined. This means that two users may run derive for the same type in different files, leading to duplication. *) derive nat. Check nat_eqb_OK : forall x y, reflect (x = y) (nat_eqb x y). (** Once can also run derive recursively, but this has the same bad effect, all generated concepts will be out of place *) Inductive a := A. Inductive b := B : a -> b. #[recursive, only(eqbOK)] derive b. Check a_eqb. Check b_eqb. coq-elpi-2.1.0/apps/derive/tests/000077500000000000000000000000001460156013500166075ustar00rootroot00000000000000coq-elpi-2.1.0/apps/derive/tests/test_bcongr.v000066400000000000000000000071511460156013500213130ustar00rootroot00000000000000From elpi.apps Require Import derive.bcongr. From elpi.apps Require Import test_derive_stdlib test_projK. Import test_derive_stdlib.Coverage. Import test_projK.Coverage. Module Coverage. Elpi derive.bcongr empty. Elpi derive.bcongr unit. Elpi derive.bcongr peano. Elpi derive.bcongr option. Elpi derive.bcongr pair. Elpi derive.bcongr seq. Elpi derive.bcongr box_peano. Elpi derive.bcongr rose. Elpi derive.bcongr rose_p. Elpi derive.bcongr rose_o. Elpi derive.bcongr nest. Elpi derive.bcongr w. Fail Elpi derive.bcongr vect. Fail Elpi derive.bcongr dyn. Elpi derive.bcongr zeta. Elpi derive.bcongr beta. Fail Elpi derive.bcongr iota. (* Elpi derive.bcongr large. *) Elpi derive.bcongr prim_int. Elpi derive.bcongr prim_float. Elpi derive.bcongr fo_record. Elpi derive.bcongr pa_record. Elpi derive.bcongr pr_record. Fail Elpi derive.bcongr dep_record. Elpi derive.bcongr enum. Elpi derive.bcongr eq. Elpi derive.bcongr bool. Fail Elpi derive.bcongr sigma_bool. Fail Elpi derive.bcongr val. Fail Elpi derive.bcongr ord. End Coverage. Import Coverage. Check unit_bcongr_tt : reflect (tt = tt) true. Check peano_bcongr_Zero : reflect (Zero = Zero) true. Check peano_bcongr_Succ : forall x y b, reflect (x = y) b -> reflect (Succ x = Succ y) b. Check option_bcongr_None : forall A, reflect (None A = None A) true. Check option_bcongr_Some : forall A x y b, reflect (x = y) b -> reflect (Some A x = Some A y) b. Check pair_bcongr_Comma : forall A B x1 x2 b1, reflect (x1 = x2) b1 -> forall y1 y2 b2, reflect (y1 = y2) b2 -> reflect (Comma A B x1 y1 = Comma A B x2 y2) (b1 && b2). Check seq_bcongr_Nil : forall A, reflect (Nil A = Nil A) true. Check seq_bcongr_Cons : forall A x y b1, reflect (x = y) b1 -> forall xs ys b2, reflect (xs = ys) b2 -> reflect (Cons A x xs = Cons A y ys) (b1 && b2). Check rose_bcongr_Leaf : forall A x y b, reflect (x = y) b -> reflect (Leaf A x = Leaf A y) b. Check rose_bcongr_Node : forall A l1 l2 b, reflect (l1 = l2) b -> reflect (Node A l1 = Node A l2) b. Check nest_bcongr_NilN : forall A, reflect (NilN A = NilN A) true. Check nest_bcongr_ConsN : forall A x y b1, reflect (x = y) b1 -> forall xs ys b2, reflect (xs = ys) b2 -> reflect (ConsN A x xs = ConsN A y ys) (b1 && b2). Check w_bcongr_via : forall A f g b, reflect (f = g) b -> reflect (via A f = via A g) b. Fail Check vect_bcongr_VNil. Fail Check vect_bcongr_VCons. Fail Check dyn_bcongr_box. Check zeta_bcongr_Envelope : forall A x1 x2 b1, reflect (x1 = x2) b1 -> forall y1 y2 b2, reflect (y1 = y2) b2 -> reflect (Envelope A x1 y1 = Envelope A x2 y2) (b1 && b2). Check beta_bcongr_Redex : forall A x y b, reflect (x = y) b -> reflect (Redex A x = Redex A y) b. Fail Check iota_bcongr_Why. Check prim_int_bcongr_PI : forall x y b, reflect (x = y) b -> reflect (PI x = PI y) b. Check prim_float_bcongr_PF : forall x y b, reflect (x = y) b -> reflect (PF x = PF y) b. (* Check large_bcongr_K1. *) Check fo_record_bcongr_Build_fo_record : forall x1 x2 b1, reflect (x1 = x2) b1 -> forall y1 y2 b2, reflect (y1 = y2) b2 -> reflect (Build_fo_record x1 y1 = Build_fo_record x2 y2) (b1 && b2). Check pa_record_bcongr_Build_pa_record : forall A, forall x1 x2 b1, reflect (x1 = x2) b1 -> forall y1 y2 b2, reflect (y1 = y2) b2 -> reflect (Build_pa_record A x1 y1 = Build_pa_record A x2 y2) (b1 && b2). Check pr_record_bcongr_Build_pr_record : forall A, forall x1 x2 b1, reflect (x1 = x2) b1 -> forall y1 y2 b2, reflect (y1 = y2) b2 -> reflect (Build_pr_record A x1 y1 = Build_pr_record A x2 y2) (b1 && b2). Check enum_bcongr_E1 : reflect (E1 = E1) true. Check enum_bcongr_E2 : reflect (E2 = E2) true. Check enum_bcongr_E3 : reflect (E3 = E3) true. coq-elpi-2.1.0/apps/derive/tests/test_derive.v000066400000000000000000000167341460156013500213260ustar00rootroot00000000000000From elpi.apps Require Import derive.std derive.legacy derive.experimental. From elpi.apps Require Import test_derive_stdlib. Elpi derive Coverage.empty. Elpi derive Coverage.unit. Elpi derive Coverage.peano. Elpi derive Coverage.option. Elpi derive Coverage.pair. Elpi derive Coverage.seq. Elpi derive Coverage.box_peano. Elpi derive Coverage.rose. Elpi derive Coverage.rose_p. Elpi derive Coverage.rose_o. Elpi derive Coverage.nest. Elpi derive Coverage.w. Elpi derive Coverage.vect. Elpi derive Coverage.dyn. Fail Elpi derive Coverage.zeta. Elpi derive Coverage.beta. Elpi derive Coverage.iota. (* Elpi derive Coverage.large. search slow *) Elpi derive Coverage.prim_int. Elpi derive Coverage.fo_record. Elpi derive Coverage.pa_record. Elpi derive Coverage.pr_record. Elpi derive Coverage.dep_record. Elpi derive Coverage.enum. (* ---------------------------------------------------- *) Elpi derive bool. #[verbose] Elpi derive nat. Check nat_eqb : nat -> nat -> bool. Check is_nat : nat -> Type. Check is_nat_inhab : forall x, is_nat x. Check is_nat_functor : forall x, is_nat x -> is_nat x. Check nat_induction : forall P, P 0 -> (forall n, P n -> P (S n)) -> forall x, is_nat x -> P x. Check nat_tag : nat -> Numbers.BinNums.positive. Check nat_fields_t : Numbers.BinNums.positive -> Type. Check nat_fields : forall (n:nat), nat_fields_t (nat_tag n). Check nat_construct : forall (p: Numbers.BinNums.positive), nat_fields_t p -> option nat. Check nat_constructP : forall (n:nat), nat_construct (nat_tag n) (nat_fields n) = Some n. Check nat_eqb : nat -> nat -> bool. Check nat_eqb_correct. Check nat_eqb_refl. (* ---------------------------------------------------- *) Elpi derive.param1 andb. (* Prelude: Elpi derive list. *) Check list_map : forall A B, (A -> B) -> list A -> list B. Check is_nil : forall A P, is_list A P (@nil A). Check is_cons : forall A P x (Px : P x) tl (Ptl : is_list A P tl), is_list A P (cons x tl). Check is_list_functor : forall A P Q, (forall x, P x -> Q x) -> forall l, is_list A P l -> is_list A Q l. Check list_induction : forall A PA P, P nil -> (forall x, PA x -> forall xs, P xs -> P (cons x xs)) -> forall l, is_list A PA l -> P l. Check list_tag : forall A, list A -> Numbers.BinNums.positive. Check list_fields_t : (Type -> Numbers.BinNums.positive -> Type). Check list_fields : forall (A:Type) (l:list A), list_fields_t A (list_tag A l). Check list_construct : forall (A:Type) (p: Numbers.BinNums.positive), list_fields_t A p -> option (list A). Check list_constructP : forall (A:Type) (l:list A), list_construct A (list_tag A l) (list_fields A l) = Some l. Check list_eqb : forall A, (A -> A -> bool) -> list A -> list A -> bool. Check list_eqb_correct. Check list_eqb_refl. (* ---------------------------------------------------- *) Require Vector. Elpi Print derive. #[only(eqOK), verbose] derive nat. Module Vector. derive Vector.t. End Vector. Check Vector.t_eq : forall A, (A -> A -> bool) -> forall n, Vector.t A n -> Vector.t A n -> bool. Check Vector.t_isk_nil : forall A n, Vector.t A n -> bool. Check Vector.t_isk_cons : forall A n, Vector.t A n -> bool. Check Vector.t_map : forall A B, (A -> B) -> forall n, Vector.t A n -> Vector.t B n. Check Vector.t_getk_cons1 : forall A n, A -> forall m, Vector.t A m -> Vector.t A n -> A. Check Vector.t_getk_cons2 : forall A n, A -> forall m, Vector.t A m -> Vector.t A n -> nat. Check Vector.t_getk_cons3 : forall A n, A -> forall m, Vector.t A m -> Vector.t A n -> { k : nat & Vector.t A k}. Check Vector.is_t : forall A, (A -> Type) -> forall n, is_nat n -> Vector.t A n -> Type. Check Vector.is_nil : forall A (PA : A -> Type), Vector.is_t A PA 0 is_O (Vector.nil A). Check Vector.is_cons : forall A (PA : A -> Type) (a : A), PA a -> forall n (Pn : is_nat n) (H : Vector.t A n), Vector.is_t A PA n Pn H -> Vector.is_t A PA (S n) (is_S n Pn) (Vector.cons A a n H). Check Vector.is_t_functor : forall A PA QA (H : forall x, PA x -> QA x), forall n nR v, Vector.is_t A PA n nR v -> Vector.is_t A QA n nR v. Check Vector.t_induction : forall A PA (P : forall n, is_nat n -> Vector.t A n -> Type), P 0 is_O (Vector.nil A) -> (forall a, PA a -> forall m mR, forall (v : Vector.t A m), P m mR v -> P (S m) (is_S m mR) (Vector.cons A a m v)) -> forall n nR v, Vector.is_t A PA n nR v -> P n nR v. Check Vector.t_tag : forall A i, Vector.t A i -> Numbers.BinNums.positive. Fail Check Vector.t_fields_t : (Type -> Numbers.BinNums.positive -> Type). Fail Check Vector.t_fields : forall (A:Type) (n:nat) (l:Vector.t A n), Vector.t_fields_t A (Vector.t_tag A l). Fail Check Vector.t_construct : forall (A:Type) (p: Numbers.BinNums.positive), Vector.t_fields_t A p -> option (Vector.t A). Fail Check Vector.t_constructP : forall (A:Type) (l:Vector.t A), Vector.t_construct A (Vector.t_tag A l) (Vector.t_fields A l) = Some l. Fail Check Vector.t_eqb : forall A, (A -> A -> bool) -> forall n, Vector.t A n -> Vector.t A n -> bool. (* ---------------------------------------------------- *) Inductive W A := B (f : A -> W). Elpi derive W. (* Not implemented yet :-/ *) Fail Check W_induction : forall A (P : W A -> Type), (forall f, (forall x, UnitPred A x -> P (f x)) -> P (B A f)) -> forall x, P x. Check W_tag : forall A, W A -> Numbers.BinNums.positive. Fail Check W_fields_t : (Type -> Numbers.BinNums.positive -> Type). Fail Check W_fields : forall (A:Type) (l:W A), W_fields_t A (W_tag A l). Fail Check W_construct : forall (A:Type) (p: Numbers.BinNums.positive), W_fields_t A p -> option (W A). Fail Check W_constructP : forall (A:Type) (l:W A), W_construct A (W_tag A l) (W_fields A l) = Some l. (* ---------------------------------------------------- *) Inductive horror A (a : A) : forall T, T -> Type := K W w (k : horror W w) : horror W w. Fail #[only(eqbOK)] derive horror. (* TODO add test for fields? *) (* ---------------------------------------------------- *) Inductive rtree A : Type := Leaf (n : A) | Node (l : list rtree). Module XXX. Elpi derive rtree. End XXX. Fail Check XXX.rtree_is_rtree_map. Check XXX.rtree_tag : forall A, rtree A -> Numbers.BinNums.positive. Check XXX.rtree_fields_t : (Type -> Numbers.BinNums.positive -> Type). Check XXX.rtree_fields : forall (A:Type) (l:rtree A), XXX.rtree_fields_t A (XXX.rtree_tag A l). Check XXX.rtree_construct : forall (A:Type) (p: Numbers.BinNums.positive), XXX.rtree_fields_t A p -> option (rtree A). Check XXX.rtree_constructP : forall (A:Type) (l:rtree A), XXX.rtree_construct A (XXX.rtree_tag A l) (XXX.rtree_fields A l) = Some l. Check XXX.rtree_eqb : forall (A:Type), (A -> A -> bool) -> rtree A -> rtree A -> bool. (* bug #270 *) #[module] derive Inductive triv : Coverage.unit -> Prop := | one t : triv t | more x : triv x. Check triv.induction : forall P : (forall H : Coverage.unit, is_unit H -> triv H -> Prop), (forall t (Pt : is_unit t), P t Pt (one t)) -> (forall x (Px : is_unit x), P x Px (more x)) -> forall u (p : is_unit u) (s : triv u), triv.is_triv u p s -> P u p s. (* #271 *) derive Inductive RoseTree : Type := | RT_ctr (branches : list RoseTree). Elpi derive.param1 is_list. #[module] derive Inductive Pred : RoseTree -> Type := | Pred_ctr branches : is_list _ Pred branches -> Pred (RT_ctr branches). Check Pred.Pred_to_Predinv : forall T, Pred T -> Pred.Predinv T. (* #286 *) Module Import derive_container. Unset Implicit Arguments. derive Inductive wimpls {A} `{rtree A} := Kwi (x:A) (y : x = x) : wimpls | Kwa. End derive_container. About wimpls.wimpls. About wimpls.Kwi. Check Kwi _ (refl_equal 3). From Coq Require Ascii. #[only(param2)] derive Ascii.ascii. coq-elpi-2.1.0/apps/derive/tests/test_derive_stdlib.v000066400000000000000000000143621460156013500226620ustar00rootroot00000000000000(* Some standard data types using different features *) From Coq Require Uint63. From Coq Require Floats. Module Coverage. Inductive empty := . Inductive unit := tt. Inductive peano := Zero | Succ (n : peano). Inductive option A := None | Some (_ : A). Inductive pair A B := Comma (a : A) (b : B). Inductive seq A := Nil | Cons (x : A) (xs : seq A). Inductive box_peano := Box (n:peano). Inductive rose (A : Type) := Leaf (a : A) | Node (sib : seq (rose A)). Inductive rose_p (A B : Type) := Leafp (p : pair A B) | Nodep (sib : pair (rose_p A B) (rose_p A B)). Inductive rose_o (A : Type) := Leafo (a : A) | Nodeo (x: pair (rose A) (rose A)) (sib : option (seq (rose A))). Inductive nest A := NilN | ConsN (x : A) (xs : nest (pair A A)). Fail Inductive bush A := BNil | BCons (x : A) (xs : bush (bush A)). Inductive w A := via (f : A -> w A). Inductive vect A : peano -> Type := VNil : vect A Zero | VCons (x : A) n (xs : vect A n) : vect A (Succ n). Inductive dyn := box (T : Type) (t : T). Inductive zeta Sender (Receiver := Sender) := Envelope (a : Sender) (ReplyTo := a) (c : Receiver). Inductive beta (A : (fun x : Type => x) Type) := Redex (a : (fun x : Type => x) A). Inductive iota := Why n (a : match n in peano return Type with Zero => peano | Succ _ => unit end). Inductive large := | K1 (_ : unit) | K2 (_ : unit) (_ : unit) | K3 (_ : unit) (_ : unit) (_ : unit) | K4 (_ : unit) (_ : unit) (_ : unit) (_ : unit) | K5 (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) | K6 (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) | K7 (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) | K8 (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) | K9 (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) | K10(_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) | K11(_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) | K12(_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) | K13(_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) | K14(_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) | K15(_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) | K16(_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) | K17(_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) | K18(_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) | K19(_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) | K20(_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) | K21(_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) | K22(_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) | K23(_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) | K24(_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) | K25(_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) | K26(_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit). Inductive prim_int := PI (i : Uint63.int). Inductive prim_float := PF (f : PrimFloat.float). Record fo_record := { f1 : peano; f2 : unit; }. Record pa_record A := { f3 : peano; f4 : A; }. Set Primitive Projections. Record pr_record A := { pf3 : peano; pf4 : A; }. Unset Primitive Projections. Record dep_record := { f5 : peano; f6 : vect unit f5; }. Variant enum := E1 | E2 | E3. Definition is_zero (n:peano) : bool := match n with | Zero => true | _ => false end. Record sigma_bool := { depn : peano; depeq : is_zero depn = true }. Fixpoint is_leq (n m:peano) : bool := match n, m with | Zero, _ => true | Succ n, Succ m => is_leq n m | _, _ => false end. Inductive ord (p : peano) := mkOrd (n : peano) (l : is_leq n p = true). Inductive ord2 (p : peano) := mkOrd2 (o1 o2 : ord p). Inductive val := V (p : peano) (o : ord p). (* to make the coverage cound correct Inductive eq := ... Inductive bool := ... we don't have a copy here because some DBs have special rules*) Definition alias := seq peano. End Coverage. coq-elpi-2.1.0/apps/derive/tests/test_derive_vector.v000066400000000000000000000105561460156013500227040ustar00rootroot00000000000000From elpi.apps Require Import derive. From elpi.apps Require Import test_derive_stdlib. Elpi derive.projK Coverage.vect. Check projVCons3 : forall A n, A -> forall m, Coverage.vect A m -> Coverage.vect A n -> {i1 : Coverage.peano & Coverage.vect A i1}. (* Elpi derive.bcongr Coverage.vect (* FIXME partial *). *) From mathcomp Require Import all_ssreflect. Elpi derive.eq Coverage.peano. Axiom peano_eqP : forall a b : Coverage.peano, reflect (a = b) (peano_eq a b). Print Equality.mixin_of. Canonical peano_eqMixin := Equality.Mixin peano_eqP. Canonical peano_eqType := Equality.Pack peano_eqMixin Coverage.peano. Lemma bcongr_VNil A : reflect (existT _ _ (Coverage.VNil A) = existT _ _ (Coverage.VNil A)) true. Proof. by constructor. Qed. Lemma bcongr_VCons : forall A, forall (a1 a2 : A) b1, reflect (a1 = a2) b1 -> forall (n1 n2 : Coverage.peano) b2, reflect (n1 = n2) b2 -> forall (v1 : Coverage.vect A n1) (v2 : Coverage.vect A n2) b3, reflect (existT _ n1 v1 = existT _ n2 v2) b3 -> reflect (existT _ _ (Coverage.VCons A a1 n1 v1) = existT _ _ (Coverage.VCons A a2 n2 v2)) [&& b1 , b2 & b3]. Proof. move=> A a1 a2 b1 [->|abs1] n1 n2 b2 [E2|abs2]; try case: _ / E2 => v1 v2 b3 [E3|abs3]; constructor. by have /= <- := (projT2_eq E3); rewrite [projT1_eq _]eq_axiomK /=. by move=> abs; apply: abs3; have /= := (projT2_eq abs); rewrite [projT1_eq _]eq_axiomK /= => [= -> ]. by move=> abs; apply: abs2; have [= -> ] := (projT1_eq abs). by move=> abs; apply: abs1; have /= := (projT2_eq abs); rewrite [projT1_eq _]eq_axiomK /= => [= -> ]. by move=> abs; apply: abs1; have /= := (projT2_eq abs); rewrite [projT1_eq _]eq_axiomK /= => [= -> ]. by move=> abs; apply: abs2; have [= -> ] := (projT1_eq abs). Qed. Elpi derive.eq Coverage.vect. Fixpoint vect_eq_sig A f (v1 v2 : {n & Coverage.vect A n}) : bool := let: existT n1 v1 := v1 in let: existT n2 v2 := v2 in if (peano_eqP n1 n2) is ReflectT e then vect_eq A f n2 (match e with erefl => v1 end) v2 else false. Elpi derive.param1 Coverage.peano. Elpi derive.param1 Coverage.vect. Elpi derive.induction Coverage.peano. Elpi derive.induction Coverage.vect. Elpi derive.projK sigT. Lemma bridge A f n v : axiom {n & Coverage.vect A n} (vect_eq_sig A f) (existT _ n v) -> axiom (Coverage.vect A n) (vect_eq A f n) v. Proof. move=> E y; move: (E (existT _ n y)) => /= {E}. case: peano_eqP => // p. rewrite [p]eq_axiomK /=. case=> [H|abs]; constructor. by move: (projT2_eq H); rewrite [projT1_eq _]eq_axiomK /= => <-. by move=> E; apply: abs; rewrite E. Qed. Lemma bridge2 A f n v : axiom (Coverage.vect A n) (vect_eq A f n) v -> axiom {n & Coverage.vect A n} (vect_eq_sig A f) (existT _ n v). Proof. move=> E [m w]; rewrite /vect_eq_sig /=. case: peano_eqP => //= e. case: _ / e w => /= w. case: (E w) => [->|abs]; constructor => // H. by apply: abs; move: (projT2_eq H); rewrite [projT1_eq _]eq_axiomK /= => <-. constructor=> abs; apply: e. apply: projT1_eq abs. Qed. Lemma axiom_VNil : forall (A : Type) (f : A -> A -> bool) x, axiom_at {n & Coverage.vect A n} (vect_eq_sig A f) (existT _ Coverage.Zero (Coverage.VNil A)) x. Proof. move=> A f [n1 [|*]]; rewrite /axiom_at /vect_eq_sig /=; case: peano_eqP => //= e. rewrite [e]eq_axiomK /=; constructor; exact: bcongr_VNil. by constructor=> abs; move: (projT1_eq abs) => /=. Qed. Lemma axiom_VCons : forall A f a n xs, axiom A f a -> axiom {n : Coverage.peano & Coverage.vect A n} (vect_eq_sig A f) (existT [eta Coverage.vect A] n xs) -> axiom {n0 : Coverage.peano & Coverage.vect A n0} (vect_eq_sig A f) (existT [eta Coverage.vect A] (Coverage.Succ n) (Coverage.VCons A a n xs)). Proof. move=> A f a n v Hf H [m [|b w]]; rewrite /vect_eq_sig; case: peano_eqP => //= e. by constructor=> abs; apply: e; move: (projT1_eq abs). move: {-}(e) => [= e1 ]. case: _ / e1 in e *. rewrite [e]eq_axiomK /= => ys. apply: bcongr_VCons. apply: Hf. apply: eqP. by have /= := H (existT _ n ys); case: peano_eqP => // p; rewrite [p]eq_axiomK /=. by move=> tl; constructor=> abs; apply: e; apply: projT1_eq abs. Qed. Lemma ok : forall (a : Type) (fa : a -> a -> bool) n pn (s1 : Coverage.vect a n), vectR a (axiom a fa) n pn s1 -> axiom (Coverage.vect a n) (vect_eq a fa n) s1. Proof. move=> A f; apply: vect_induction. apply: bridge; exact: axiom_VNil. move=> a Hf n nR xs /bridge2 IH; apply/bridge; exact: axiom_VCons. Qed. coq-elpi-2.1.0/apps/derive/tests/test_eq.v000066400000000000000000000035601460156013500204460ustar00rootroot00000000000000From elpi.apps Require Import test_derive_stdlib derive.eq. Import test_derive_stdlib.Coverage. Module Coverage. Elpi derive.eq empty. Elpi derive.eq unit. Elpi derive.eq peano. Elpi derive.eq option. Elpi derive.eq pair. Elpi derive.eq seq. Elpi derive.eq box_peano. Elpi derive.eq rose. Elpi derive.eq rose_p. Elpi derive.eq rose_o. Fail Elpi derive.eq nest. Fail Elpi derive.eq w. (* expected *) Elpi derive.eq vect. Fail Elpi derive.eq dyn. (* expected *) Elpi derive.eq zeta. Elpi derive.eq beta. Fail Elpi derive.eq iota. Elpi derive.eq large. Elpi derive.eq prim_int. Elpi derive.eq prim_float. Elpi derive.eq fo_record. Elpi derive.eq pa_record. Elpi derive.eq pr_record. Fail Elpi derive.eq dep_record. Elpi derive.eq enum. Fail Elpi derive.eq eq. Elpi derive.eq bool. Fail Elpi derive.eq sigma_bool. Fail Elpi derive.eq ord. Fail Elpi derive.eq val. End Coverage. Import Coverage. Notation eq_test T := (T -> T -> bool). Check empty_eq : eq_test empty. Check unit_eq : eq_test unit. Check peano_eq : eq_test peano. Check option_eq : forall A, eq_test A -> eq_test (option A). Check pair_eq : forall A, eq_test A -> forall B, eq_test B -> eq_test (pair A B). Check seq_eq : forall A, eq_test A -> eq_test (seq A). Check rose_eq : forall A, eq_test A -> eq_test (rose A). Fail Check nest_eq. Fail Check w_eq. Check vect_eq : forall A, eq_test A -> forall i, eq_test (vect A i). Fail Check dyn_eq. Check zeta_eq : forall A, eq_test A -> eq_test (zeta A). Check beta_eq : forall A, eq_test A -> eq_test (beta A). Fail Check iota_eq : eq_test iota. Check large_eq : eq_test large. Check prim_int_eq : eq_test prim_int. Check prim_float_eq : eq_test prim_float. Check fo_record_eq : eq_test fo_record. Check pa_record_eq : forall A, eq_test A -> eq_test (pa_record A). Check pr_record_eq : forall A, eq_test A -> eq_test (pr_record A). Check enum_eq : eq_test enum. coq-elpi-2.1.0/apps/derive/tests/test_eqK.v000066400000000000000000000057061460156013500205650ustar00rootroot00000000000000From elpi Require Import elpi. From elpi.apps Require Import derive.eqK. From elpi.apps.derive.tests Require Import test_derive_stdlib test_isK test_projK test_bcongr test_eq. Import test_derive_stdlib.Coverage. Import test_isK.Coverage. Import test_projK.Coverage. Import test_bcongr.Coverage. Import test_eq.Coverage. Module Coverage. Elpi derive.eqK empty. Elpi derive.eqK unit. Elpi derive.eqK peano. Elpi derive.eqK option. Elpi derive.eqK pair. Elpi derive.eqK seq. Elpi derive.eqK box_peano. Elpi derive.eqK rose. Elpi derive.eqK rose_p. Elpi derive.eqK rose_o. Fail Elpi derive.eqK nest. Fail Elpi derive.eqK w. Fail Elpi derive.eqK vect. Fail Elpi derive.eqK dyn. Elpi derive.eqK zeta. Elpi derive.eqK beta. Fail Elpi derive.eqK iota. (* Elpi derive.eqK large. *) Elpi derive.eqK prim_int. Elpi derive.eqK prim_float. Elpi derive.eqK fo_record. Elpi derive.eqK pa_record. Elpi derive.eqK pr_record. Fail Elpi derive.eqK dep_record. Elpi derive.eqK enum. Fail Elpi derive.eqK sigma_bool. Fail Elpi derive.eqK eq. Elpi derive.eqK bool. Fail Elpi derive.eqK val. Fail Elpi derive.eqK ord. End Coverage. Import Coverage. Import test_eq.Coverage. Check eq_axiom_tt : eq_axiom_at unit unit_eq tt. Check eq_axiom_Zero : eq_axiom_at peano peano_eq Zero. Check eq_axiom_Succ : forall y, eq_axiom_at peano peano_eq y -> eq_axiom_at peano peano_eq (Succ y). Check eq_axiom_None : forall A f, eq_axiom_at (option A) (option_eq A f) (None A). Check eq_axiom_Some : forall A f x, eq_axiom_at A f x -> eq_axiom_at (option A) (option_eq A f) (Some A x). Check eq_axiom_Comma: forall A f B g, forall x, eq_axiom_at A f x -> forall y, eq_axiom_at B g y -> eq_axiom_at (pair A B) (pair_eq A f B g) (Comma A B x y). Check eq_axiom_Nil: forall A f, eq_axiom_at (seq A) (seq_eq A f) (Nil A). Check eq_axiom_Cons : forall A f x, eq_axiom_at A f x -> forall xs, eq_axiom_at (seq A) (seq_eq A f) xs -> eq_axiom_at (seq A) (seq_eq A f) (Cons A x xs). Check eq_axiom_Leaf: forall A f a, eq_axiom_at A f a -> eq_axiom_at (rose A) (rose_eq A f) (Leaf A a). Check eq_axiom_Node: forall A f l, eq_axiom_at (seq (rose A)) (seq_eq (rose A) (rose_eq A f)) l -> eq_axiom_at (rose A) (rose_eq A f) (Node A l). Check eq_axiom_Envelope. Check eq_axiom_Redex. (*Check eq_axiom_K1.*) Check eq_axiom_PI. Check eq_axiom_PF. Check eq_axiom_Build_fo_record : forall x, eq_axiom_at peano peano_eq x -> forall y, eq_axiom_at unit unit_eq y -> eq_axiom_at fo_record fo_record_eq (Build_fo_record x y). Check eq_axiom_Build_pa_record : forall A f, forall x, eq_axiom_at peano peano_eq x -> forall y, eq_axiom_at A f y -> eq_axiom_at (pa_record A) (pa_record_eq A f) (Build_pa_record A x y). Check eq_axiom_Build_pr_record : forall A f, forall x, eq_axiom_at peano peano_eq x -> forall y, eq_axiom_at A f y -> eq_axiom_at (pr_record A) (pr_record_eq A f) (Build_pr_record A x y). Check eq_axiom_E1 : eq_axiom_at enum enum_eq E1. Check eq_axiom_E2 : eq_axiom_at enum enum_eq E2. Check eq_axiom_E3 : eq_axiom_at enum enum_eq E3. coq-elpi-2.1.0/apps/derive/tests/test_eqOK.v000066400000000000000000000056131460156013500207010ustar00rootroot00000000000000From elpi.apps Require Import derive.eqOK. From elpi.apps Require Import test_derive_stdlib test_eqcorrect test_param1 test_param1_trivial. Import test_derive_stdlib.Coverage. Import tests.test_eq.Coverage. Import test_eqcorrect.Coverage. Import test_param1.Coverage. Import test_param1_trivial.Coverage. Module Coverage. Elpi derive.eqOK empty. Elpi derive.eqOK unit. Elpi derive.eqOK peano. Elpi derive.eqOK option. Elpi derive.eqOK pair. Elpi derive.eqOK seq. Elpi derive.eqOK box_peano. Elpi derive.eqOK rose. Elpi derive.eqOK rose_p. Elpi derive.eqOK rose_o. Fail Elpi derive.eqOK nest. Fail Elpi derive.eqOK w. Fail Elpi derive.eqOK vect. Fail Elpi derive.eqOK dyn. Elpi derive.eqOK zeta. Elpi derive.eqOK beta. Fail Elpi derive.eqOK iota. (* Elpi derive.eqOK large. *) Elpi derive.eqOK prim_int. Fail Elpi derive.eqOK prim_float. Elpi derive.eqOK fo_record. Elpi derive.eqOK pa_record. Elpi derive.eqOK pr_record. Fail Elpi derive.eqOK dep_record. Elpi derive.eqOK enum. Elpi derive.eqOK bool. Fail Elpi derive.eqOK eq. Fail Elpi derive.eqOK sigma_bool. Fail Elpi derive.eqOK val. Fail Elpi derive.eqOK ord. End Coverage. Import Coverage eqK. Local Notation ok T F := (forall x, eq_axiom_at T F x). Check empty_eq_OK : ok empty empty_eq. Check unit_eq_OK : ok unit unit_eq. Check peano_eq_OK : ok peano peano_eq. Check option_eq_OK : forall A f, ok A f -> ok (option A) (option_eq A f). Check pair_eq_OK : forall A f, ok A f -> forall B g, ok B g -> ok (pair A B) (pair_eq A f B g). Check seq_eq_OK : forall A f, ok A f -> ok (seq A) (seq_eq A f). Check rose_eq_OK : forall A f, ok A f -> ok (rose A) (rose_eq A f). Fail Check nest_eq_OK. Fail Check w_eq_OK. Fail Check vect_eq_OK. Fail Check dyn_eq_OK. Check zeta_eq_OK : forall A f, ok A f -> ok (zeta A) (zeta_eq A f). Check beta_eq_OK : forall A f, ok A f -> ok (beta A) (beta_eq A f). Fail Check iota_eq_OK. (* Check large_eq_OK : ok large large_eq. *) Check prim_int_eq_OK. Fail Check prim_float_eq_OK. Check fo_record_eq_OK : ok fo_record fo_record_eq. Check pa_record_eq_OK : forall A f, ok A f -> ok (pa_record A) (pa_record_eq A f). Check pr_record_eq_OK : forall A f, ok A f -> ok (pr_record A) (pr_record_eq A f). Check enum_eq_OK : ok enum enum_eq. From elpi.apps Require Import test_param1_functor. Import test_param1_functor.Coverage. Set Uniform Inductive Parameters. Module OtherTests. Import test_param1_functor.Coverage. Inductive dlist A := dnil | dcons (a : pair A peano) (l : dlist). Elpi derive.param1 dlist. Elpi derive.param1.congr is_dlist. Elpi derive.param1.trivial is_dlist. Elpi derive.induction dlist. Elpi derive.projK dlist. Elpi derive.bcongr dlist. Elpi derive.isK dlist. Elpi derive.param1.functor is_dlist. Elpi derive.eq dlist. Elpi derive.eqK dlist. Elpi derive.eqcorrect dlist. Elpi derive.eqOK dlist dlist_eqOK. Check dlist_eqOK : forall A f (h : forall l, eq_axiom_at A f l) l, eq_axiom_at (dlist A) (dlist_eq A f) l. End OtherTests. coq-elpi-2.1.0/apps/derive/tests/test_eqType_ast.v000066400000000000000000000030231460156013500221510ustar00rootroot00000000000000From elpi.apps Require Import derive.eqType_ast. From elpi.apps.derive.tests Require Import test_derive_stdlib. Import test_derive_stdlib.Coverage. Module Coverage. Elpi derive.eqType.ast empty. Elpi derive.eqType.ast unit. Elpi derive.eqType.ast peano. Elpi derive.eqType.ast option. Elpi derive.eqType.ast pair. Elpi derive.eqType.ast seq. Elpi derive.eqType.ast box_peano. Elpi derive.eqType.ast rose. Elpi derive.eqType.ast rose_p. Elpi derive.eqType.ast rose_o. Fail Elpi derive.eqType.ast nest. Fail Elpi derive.eqType.ast w. Fail Elpi derive.eqType.ast vect. Fail Elpi derive.eqType.ast dyn. Fail Elpi derive.eqType.ast zeta. Elpi derive.eqType.ast beta. Fail Elpi derive.eqType.ast iota. Elpi derive.eqType.ast large. Elpi derive.eqType.ast prim_int. Fail Elpi derive.eqType.ast prim_float. Elpi derive.eqType.ast fo_record. Elpi derive.eqType.ast pa_record. Elpi derive.eqType.ast pr_record. Fail Elpi derive.eqType.ast dep_record. Elpi derive.eqType.ast enum. Elpi derive.eqType.ast bool. Fail Elpi derive.eqType.ast eq. Elpi derive.eqType.ast sigma_bool. Elpi derive.eqType.ast ord. Elpi derive.eqType.ast ord2. Elpi derive.eqType.ast val. End Coverage. Import Coverage. Inductive F1 := | K1 : (peano -> peano) -> F1. Fail Elpi derive.eqType.ast F1. Inductive F2 := | K2 : F1 -> F2. Fail Elpi derive.eqType.ast F2. Inductive S1 (x : F1) := | D1. Elpi derive.eqType.ast S1. Inductive S2 (x : F1) := | D2 : S1 x -> S2. Elpi derive.eqType.ast S2. Inductive S3 (f : peano -> peano) := | D3 x : f x = x -> S3. Elpi derive.eqType.ast S3. coq-elpi-2.1.0/apps/derive/tests/test_eqb.v000066400000000000000000000047421460156013500206130ustar00rootroot00000000000000From elpi.apps Require Import derive.eqb. From elpi.apps.derive.tests Require Import test_derive_stdlib test_eqType_ast test_tag test_fields. Import test_derive_stdlib.Coverage test_eqType_ast.Coverage test_tag.Coverage test_fields.Coverage. Module Coverage. Elpi derive.eqb empty. Elpi derive.eqb unit. Elpi derive.eqb peano. Elpi derive.eqb option. Elpi derive.eqb pair. Elpi derive.eqb seq. Elpi derive.eqb box_peano. Elpi derive.eqb rose. Elpi derive.eqb rose_p. Elpi derive.eqb rose_o. Fail Elpi derive.eqb nest. Fail Elpi derive.eqb w. Fail Elpi derive.eqb vect. Fail Elpi derive.eqb dyn. Fail Elpi derive.eqb zeta. Elpi derive.eqb beta. Fail Elpi derive.eqb iota. (* slow Elpi derive.eqb large. *) Elpi derive.eqb prim_int. Fail Elpi derive.eqb prim_float. Elpi derive.eqb fo_record. Elpi derive.eqb pa_record. Elpi derive.eqb pr_record. Fail Elpi derive.eqb dep_record. Elpi derive.eqb enum. Fail Elpi derive.eqb eq. Elpi derive.eqb bool. Elpi derive.eqb sigma_bool. Elpi derive.eqb ord. Elpi derive.eqb ord2. Elpi derive.eqb val. Elpi derive.eqb alias. End Coverage. Import Coverage. Import PArith. Notation eq_test T := (T -> T -> bool). Notation eq_test2 T1 T2 := (T1 -> T2 -> bool). Check empty_eqb : eq_test empty. Check unit_eqb : eq_test unit. Check peano_eqb : eq_test peano. Check option_eqb : forall A, eq_test A -> eq_test (option A). Check pair_eqb : forall A, eq_test A -> forall B, eq_test B -> eq_test (pair A B). Check seq_eqb : forall A, eq_test A -> eq_test (seq A). Check rose_eqb : forall A, eq_test A -> eq_test (rose A). Fail Check nest_eqb. (* Check w_eqb. (* Do something but it is stupide*) *) Fail Check vect_eqb : forall A, eq_test A -> forall i, eq_test (vect A i). Fail Check dyn_eqb. Fail Check zeta_eqb : forall A, eq_test A -> eq_test (zeta A). Check beta_eqb : forall A, eq_test A -> eq_test (beta A). Fail Check iota_eqb : eq_test iota. (* Check large_eqb : eq_test large. *) (* FIXME : the definition of prim_int_eqb_fields*) Check prim_int_eqb : eq_test prim_int. Fail Check prim_float_eqb : eq_test prim_float. Check fo_record_eqb : eq_test fo_record. Check pa_record_eqb : forall A, eq_test A -> eq_test (pa_record A). Check pr_record_eqb : forall A, eq_test A -> eq_test (pr_record A). Check enum_eqb : eq_test enum. Check sigma_bool_eqb : eq_test sigma_bool. Check ord_eqb : forall p1 p2, eq_test2 (ord p1) (ord p2). Check ord2_eqb : forall p1 p2, eq_test2 (ord2 p1) (ord2 p2). Check val_eqb : eq_test val. Check alias_eqb : eq_test alias. coq-elpi-2.1.0/apps/derive/tests/test_eqbOK.v000066400000000000000000000030261460156013500210370ustar00rootroot00000000000000From elpi.apps Require Import derive.eqbOK. From elpi.apps.derive.tests Require Import test_derive_stdlib test_eqb test_eqbcorrect. Import test_derive_stdlib.Coverage test_eqType_ast.Coverage test_eqb.Coverage test_eqbcorrect.Coverage. Module Coverage. Elpi derive.eqbOK empty. Elpi derive.eqbOK unit. Elpi derive.eqbOK peano. Elpi derive.eqbOK option. Elpi derive.eqbOK pair. Elpi derive.eqbOK seq. Elpi derive.eqbOK box_peano. Elpi derive.eqbOK rose. Elpi derive.eqbOK rose_p. Elpi derive.eqbOK rose_o. Fail Elpi derive.eqbOK nest. Fail Elpi derive.eqbOK w. Fail Elpi derive.eqbOK vect. Fail Elpi derive.eqbOK dyn. Fail Elpi derive.eqbOK zeta. Elpi derive.eqbOK beta. Fail Elpi derive.eqbOK iota. (* Elpi derive.eqbOK large. *) Elpi derive.eqbOK prim_int. Fail Elpi derive.eqbOK prim_float. Elpi derive.eqbOK fo_record. Elpi derive.eqbOK pa_record. Elpi derive.eqbOK pr_record. Fail Elpi derive.eqbOK dep_record. Elpi derive.eqbOK enum. Fail Elpi derive.eqbOK eq. Elpi derive.eqbOK bool. Elpi derive.eqbOK sigma_bool. Elpi derive.eqbOK ord. Elpi derive.eqbOK ord2. Elpi derive.eqbOK val. Elpi derive.eqbOK alias. End Coverage. Import Coverage. Check peano_eqb_OK : forall n m, Bool.reflect (n = m) (peano_eqb n m). Check seq_eqb_OK : forall A eqA (h : forall a1 a2 : A, Bool.reflect (a1 = a2) (eqA a1 a2)) l1 l2, Bool.reflect (l1 = l2) (seq_eqb A eqA l1 l2). Check ord_eqb_OK : forall n (o1 o2 : ord n), Bool.reflect (o1 = o2) (ord_eqb n n o1 o2). Check alias_eqb_OK : forall x y : alias, Bool.reflect (x = y) (alias_eqb x y). coq-elpi-2.1.0/apps/derive/tests/test_eqbcorrect.v000066400000000000000000000047451460156013500222000ustar00rootroot00000000000000From elpi.apps Require Import derive.eqbcorrect. From elpi.apps.derive Require Import param1. (* FIXME, the clause is in param1 *) From elpi.apps.derive.tests Require Import test_derive_stdlib test_eqType_ast test_tag test_fields test_eqb test_induction test_param1 test_param1_trivial test_param1_functor. Import test_derive_stdlib.Coverage test_eqType_ast.Coverage test_tag.Coverage test_fields.Coverage test_eqb.Coverage test_induction.Coverage test_param1.Coverage test_param1_trivial.Coverage test_param1_functor.Coverage. Module Coverage. (* Elpi Trace (* "derive.eqbcorrect.*" "derive.param1.functor.*" "correct-lemma-for" *) "param1-functor-for". *) Elpi derive.eqbcorrect empty. Elpi derive.eqbcorrect unit. Elpi derive.eqbcorrect peano. Elpi derive.eqbcorrect option. Elpi derive.eqbcorrect pair. Elpi derive.eqbcorrect seq. Elpi derive.eqbcorrect box_peano. Elpi derive.eqbcorrect rose. Elpi derive.eqbcorrect rose_p. Elpi derive.eqbcorrect rose_o. Fail Elpi derive.eqbcorrect nest. (* Maybe fixable *) Fail Elpi derive.eqbcorrect w. (* Not fixable *) Fail Elpi derive.eqbcorrect vect. (* Can be done *) Fail Elpi derive.eqbcorrect dyn. (* Not Fixable *) Fail Elpi derive.eqbcorrect zeta. (* FIXME *) Elpi derive.eqbcorrect beta. Fail Elpi derive.eqbcorrect iota. (* Elpi derive.eqbcorrect large. *) Elpi derive.eqbcorrect prim_int. Fail Elpi derive.eqbcorrect prim_float. (* Can not work, we don't have a syntaxtic test *) Elpi derive.eqbcorrect fo_record. Elpi derive.eqbcorrect pa_record. Elpi derive.eqbcorrect pr_record. Fail Elpi derive.eqbcorrect dep_record. Elpi derive.eqbcorrect enum. Fail Elpi derive.eqbcorrect eq. Elpi derive.eqbcorrect bool. Elpi derive.eqbcorrect sigma_bool. Elpi derive.eqbcorrect ord. Elpi derive.eqbcorrect ord2. Elpi derive.eqbcorrect val. Elpi derive.eqbcorrect alias. End Coverage. Import Coverage. Check peano_eqb_correct : forall n m, peano_eqb n m = true -> n = m. Check peano_eqb_refl : forall n, peano_eqb n n = true. Check ord_eqb_correct : forall n, eqb_correct (ord_eqb n n). Check ord_eqb_refl : forall n, eqb_reflexive (ord_eqb n n). Check ord2_eqb_correct : forall n, eqb_correct (ord2_eqb n n). Check ord2_eqb_refl : forall n, eqb_reflexive (ord2_eqb n n). Check val_eqb_correct : eqb_correct val_eqb. Check val_eqb_refl : eqb_reflexive val_eqb. Check alias_eqb_correct : eqb_correct alias_eqb. Check alias_eqb_refl : eqb_reflexive alias_eqb. coq-elpi-2.1.0/apps/derive/tests/test_eqcorrect.v000066400000000000000000000054531460156013500220330ustar00rootroot00000000000000From elpi.apps Require Import derive.eqcorrect. From elpi.apps Require Import test_derive_stdlib derive.tests.test_eq test_param1 test_param1_functor test_induction test_eqK. Import test_derive_stdlib.Coverage. Import tests.test_eq.Coverage. Import test_param1.Coverage. Import test_param1_functor.Coverage. Import test_induction.Coverage. Import test_eqK.Coverage. Module Coverage. Elpi derive.eqcorrect empty. Elpi derive.eqcorrect unit. Elpi derive.eqcorrect peano. Elpi derive.eqcorrect option. Elpi derive.eqcorrect pair. Elpi derive.eqcorrect seq. Elpi derive.eqcorrect box_peano. Elpi derive.eqcorrect rose. Elpi derive.eqcorrect rose_p. Elpi derive.eqcorrect rose_o. Fail Elpi derive.eqcorrect nest. Fail Elpi derive.eqcorrect w. Fail Elpi derive.eqcorrect vect. Fail Elpi derive.eqcorrect dyn. Elpi derive.eqcorrect zeta. Elpi derive.eqcorrect beta. Fail Elpi derive.eqcorrect iota. (* Elpi derive.eqcorrect large. *) Elpi derive.eqcorrect prim_int. Fail Elpi derive.eqcorrect prim_float. Elpi derive.eqcorrect fo_record. Elpi derive.eqcorrect pa_record. Elpi derive.eqcorrect pr_record. Fail Elpi derive.eqcorrect dep_record. Elpi derive.eqcorrect enum. Fail Elpi derive.eqcorrect eq. Elpi derive.eqcorrect bool. Fail Elpi derive.eqcorrect sigma_bool. Fail Elpi derive.eqcorrect ord. Fail Elpi derive.eqcorrect val. End Coverage. Import Coverage eqK. Local Notation correct X isX F := (forall x, isX x -> eq_axiom_at X F x). Check empty_eq_correct : correct empty is_empty empty_eq. Check unit_eq_correct : correct unit is_unit unit_eq. Check peano_eq_correct : correct peano is_peano peano_eq. Check option_eq_correct : forall A f, correct (option A) (is_option A (eq_axiom_at A f)) (option_eq A f). Check pair_eq_correct : forall A f B g, correct (pair A B) (is_pair A (eq_axiom_at A f) B (eq_axiom_at B g)) (pair_eq A f B g). Check seq_eq_correct : forall A f, correct (seq A) (is_seq A (eq_axiom_at A f)) (seq_eq A f). Check rose_eq_correct : forall A f, correct (rose A) (is_rose A (eq_axiom_at A f)) (rose_eq A f). Fail Check nest_eq_correct. Fail Check w_eq_correct. Fail Check vect_eq_correct. Fail Check dyn_eq_correct. Check zeta_eq_correct : forall A f, correct (zeta A) (is_zeta A (eq_axiom_at A f)) (zeta_eq A f). Check beta_eq_correct : forall A f, correct (beta A) (is_beta A (eq_axiom_at A f)) (beta_eq A f). Fail Check iota_eq_correct. (* Check large_eq_correct : correct large is_large large_eq. *) Check prim_int_eq_correct. Fail Check prim_float_eq_correct. Check fo_record_eq_correct : correct fo_record is_fo_record fo_record_eq. Check pa_record_eq_correct : forall A f, correct (pa_record A) (is_pa_record A (eq_axiom_at A f)) (pa_record_eq A f). Check pr_record_eq_correct : forall A f, correct (pr_record A) (is_pr_record A (eq_axiom_at A f)) (pr_record_eq A f). Check enum_eq_correct : correct enum is_enum enum_eq. coq-elpi-2.1.0/apps/derive/tests/test_fields.v000066400000000000000000000227731460156013500213160ustar00rootroot00000000000000From elpi.apps Require Import derive.fields. From elpi.apps.derive.tests Require Import test_derive_stdlib test_eqType_ast test_tag. Import test_derive_stdlib.Coverage test_eqType_ast.Coverage test_tag.Coverage. Module Coverage. Elpi derive.fields empty. Elpi derive.fields unit. Elpi derive.fields peano. Elpi derive.fields option. Elpi derive.fields pair. Elpi derive.fields seq. Elpi derive.fields box_peano. Elpi derive.fields rose. Elpi derive.fields rose_p. Elpi derive.fields rose_o. Fail Elpi derive.fields nest. Fail Elpi derive.fields w. Fail Elpi derive.fields vect. Fail Elpi derive.fields dyn. Fail Elpi derive.fields zeta. Elpi derive.fields beta. Fail Elpi derive.fields iota. Elpi derive.fields large. Elpi derive.fields prim_int. Fail Elpi derive.fields prim_float. Elpi derive.fields fo_record. Elpi derive.fields pa_record. Elpi derive.fields pr_record. Fail Elpi derive.fields dep_record. Elpi derive.fields enum. Elpi derive.fields bool. Fail Elpi derive.fields eq. Elpi derive.fields sigma_bool. Elpi derive.fields ord. Elpi derive.fields ord2. Elpi derive.fields val. End Coverage. Import Coverage. Import PArith. Check empty_fields_t : positive -> Type. Check empty_fields : forall (n:empty), empty_fields_t (empty_tag n). Check empty_construct : forall (p: positive), empty_fields_t p -> Datatypes.option empty. Check empty_constructP : forall (n:empty), empty_construct (empty_tag n) (empty_fields n) = Datatypes.Some n. Check unit_fields_t : positive -> Type. Check unit_fields : forall (n:unit), unit_fields_t (unit_tag n). Check unit_construct : forall (p: positive), unit_fields_t p -> Datatypes.option unit. Check unit_constructP : forall (n:unit), unit_construct (unit_tag n) (unit_fields n) = Datatypes.Some n. Check peano_fields_t : positive -> Type. Check peano_fields : forall (n:peano), peano_fields_t (peano_tag n). Check peano_construct : forall (p: positive), peano_fields_t p -> Datatypes.option peano. Check peano_constructP : forall (n:peano), peano_construct (peano_tag n) (peano_fields n) = Datatypes.Some n. Check option_fields_t : Type -> Numbers.BinNums.positive -> Type. Check option_fields : forall (A:Type) (l:option A), option_fields_t A (option_tag A l). Check option_construct : forall (A:Type) (p: Numbers.BinNums.positive), option_fields_t A p -> Datatypes.option (option A). Check option_constructP : forall (A:Type) (l:option A), option_construct A (option_tag A l) (option_fields A l) = Datatypes.Some l. Check pair_fields_t : Type -> Type -> Numbers.BinNums.positive -> Type. Check pair_fields : forall (A B :Type) (l:pair A B), pair_fields_t A B (pair_tag A B l). Check pair_construct : forall (A B:Type) (p: Numbers.BinNums.positive), pair_fields_t A B p -> Datatypes.option (pair A B). Check pair_constructP : forall (A B:Type) (l:pair A B), pair_construct A B (pair_tag A B l) (pair_fields A B l) = Datatypes.Some l. Check seq_fields_t : Type -> Numbers.BinNums.positive -> Type. Check seq_fields : forall (A:Type) (l:seq A), seq_fields_t A (seq_tag A l). Check seq_construct : forall (A:Type) (p: Numbers.BinNums.positive), seq_fields_t A p -> Datatypes.option (seq A). Check seq_constructP : forall (A:Type) (l:seq A), seq_construct A (seq_tag A l) (seq_fields A l) = Datatypes.Some l. Check rose_fields_t : Type -> Numbers.BinNums.positive -> Type. Check rose_fields : forall (A:Type) (l:rose A), rose_fields_t A (rose_tag A l). Check rose_construct : forall (A:Type) (p: Numbers.BinNums.positive), rose_fields_t A p -> Datatypes.option (rose A). Check rose_constructP : forall (A:Type) (l:rose A), rose_construct A (rose_tag A l) (rose_fields A l) = Datatypes.Some l. Fail Check nest_fields_t : Type -> Numbers.BinNums.positive -> Type. Fail Check nest_fields : forall (A:Type) (l:nest A), nest_fields_t A (nest_tag A l). Fail Check nest_construct : forall (A:Type) (p: Numbers.BinNums.positive), nest_fields_t A p -> Datatypes.option (nest A). Fail Check nest_constructP : forall (A:Type) (l:nest A), nest_construct A (nest_tag A l) (nest_fields A l) = Datatypes.Some l. Fail Check w_fields_t : Type -> Numbers.BinNums.positive -> Type. Fail Check w_fields : forall (A:Type) (l:w A), w_fields_t A (w_tag A l). Fail Check w_construct : forall (A:Type) (p: Numbers.BinNums.positive), w_fields_t A p -> Datatypes.option (w A). Fail Check w_constructP : forall (A:Type) (l:w A), w_construct A (w_tag A l) (w_fields A l) = Datatypes.Some l. Fail Check vect_fields_t : Type -> Numbers.BinNums.positive -> Type. Fail Check vect_fields : forall (A:Type) (l:vect A), vect_fields_t A (vect_tag A l). Fail Check vect_construct : forall (A:Type) (p: Numbers.BinNums.positive), vect_fields_t A p -> Datatypes.option (vect A). Fail Check vect_constructP : forall (A:Type) (l:vect A), vect_construct A (vect_tag A l) (vect_fields A l) = Datatypes.Some l. Fail Check dyn_fields_t : positive -> Type. Fail Check dyn_fields : forall (n:dyn), dyn_fields_t (dyn_tag n). Fail Check dyn_construct : forall (p: positive), dyn_fields_t p -> Datatypes.option dyn. Fail Check dyn_constructP : forall (n:dyn), dyn_construct (dyn_tag n) (dyn_fields n) = Datatypes.Some n. Fail Check zeta_fields_t : Type -> Numbers.BinNums.positive -> Type. Fail Check zeta_fields : forall (A:Type) (l:zeta A), zeta_fields_t A (zeta_tag A l). Fail Check zeta_construct : forall (A:Type) (p: Numbers.BinNums.positive), zeta_fields_t A p -> option (zeta A). Fail Check zeta_constructP : forall (A:Type) (l:zeta A), zeta_construct A (zeta_tag A l) (zeta_fields A l) = Some l. Check beta_fields_t : Type -> Numbers.BinNums.positive -> Type. Check beta_fields : forall (A:Type) (l:beta A), beta_fields_t A (beta_tag A l). Check beta_construct : forall (A:Type) (p: Numbers.BinNums.positive), beta_fields_t A p -> Datatypes.option (beta A). Check beta_constructP : forall (A:Type) (l:beta A), beta_construct A (beta_tag A l) (beta_fields A l) = Datatypes.Some l. Fail Check iota_fields_t : positive -> Type. Fail Check iota_fields : forall (n:iota), iota_fields_t (iota_tag n). Fail Check iota_construct : forall (p: positive), iota_fields_t p -> Datatypes.option iota. Fail Check iota_constructP : forall (n:iota), iota_construct (iota_tag n) (iota_fields n) = Datatypes.Some n. Check large_fields_t : positive -> Type. Check large_fields : forall (n:large), large_fields_t (large_tag n). Check large_construct : forall (p: positive), large_fields_t p -> Datatypes.option large. Check large_constructP : forall (n:large), large_construct (large_tag n) (large_fields n) = Datatypes.Some n. Check prim_int_fields_t : positive -> Type. Check prim_int_fields : forall (n:prim_int), prim_int_fields_t (prim_int_tag n). Check prim_int_construct : forall (p: positive), prim_int_fields_t p -> Datatypes.option prim_int. Check prim_int_constructP : forall (n:prim_int), prim_int_construct (prim_int_tag n) (prim_int_fields n) = Datatypes.Some n. Fail Check prim_float_fields_t : positive -> Type. Fail Check prim_float_fields : forall (n:prim_float), prim_float_fields_t (prim_float_tag n). Fail Check prim_float_construct : forall (p: positive), prim_float_fields_t p -> Datatypes.option prim_float. Fail Check prim_float_constructP : forall (n:prim_float), prim_float_construct (prim_float_tag n) (prim_float_fields n) = Datatypes.Some n. Check pa_record_fields_t : Type -> Numbers.BinNums.positive -> Type. Check pa_record_fields : forall (A:Type) (l:pa_record A), pa_record_fields_t A (pa_record_tag A l). Check pa_record_construct : forall (A:Type) (p: Numbers.BinNums.positive), pa_record_fields_t A p -> Datatypes.option (pa_record A). Check pa_record_constructP : forall (A:Type) (l:pa_record A), pa_record_construct A (pa_record_tag A l) (pa_record_fields A l) = Datatypes.Some l. Check pr_record_fields_t : Type -> Numbers.BinNums.positive -> Type. Check pr_record_fields : forall (A:Type) (l:pr_record A), pr_record_fields_t A (pr_record_tag A l). Check pr_record_construct : forall (A:Type) (p: Numbers.BinNums.positive), pr_record_fields_t A p -> Datatypes.option (pr_record A). Check pr_record_constructP : forall (A:Type) (l:pr_record A), pr_record_construct A (pr_record_tag A l) (pr_record_fields A l) = Datatypes.Some l. Check sigma_bool_fields_t : Numbers.BinNums.positive -> Type. Check sigma_bool_fields : forall (l:sigma_bool), sigma_bool_fields_t (sigma_bool_tag l). Check sigma_bool_construct : forall (p: Numbers.BinNums.positive), sigma_bool_fields_t p -> Datatypes.option sigma_bool. Check sigma_bool_constructP : forall (l:sigma_bool), sigma_bool_construct (sigma_bool_tag l) (sigma_bool_fields l) = Datatypes.Some l. Check ord_fields_t : peano -> Numbers.BinNums.positive -> Type. Check ord_fields : forall (p:peano) (o:ord p), ord_fields_t p (ord_tag p o). Check ord_construct : forall (n:peano) (p:Numbers.BinNums.positive), ord_fields_t n p -> Datatypes.option (ord n). Check ord_constructP : forall (p:peano) (o:ord p), ord_construct p (ord_tag p o) (ord_fields p o) = Datatypes.Some o. Check ord2_fields_t : peano -> Numbers.BinNums.positive -> Type. Check ord2_fields : forall (p:peano) (o:ord2 p), ord2_fields_t p (ord2_tag p o). Check ord2_construct : forall (n:peano) (p:Numbers.BinNums.positive), ord2_fields_t n p -> Datatypes.option (ord2 n). Check ord2_constructP : forall (p:peano) (o:ord2 p), ord2_construct p (ord2_tag p o) (ord2_fields p o) = Datatypes.Some o. Check val_fields_t : Numbers.BinNums.positive -> Type. Check val_fields : forall i : val, val_fields_t (val_tag i). Check val_construct : forall (p: Numbers.BinNums.positive), val_fields_t p -> Datatypes.option val. Check val_constructP : forall (v:val), val_construct (val_tag v) (val_fields v) = Datatypes.Some v. coq-elpi-2.1.0/apps/derive/tests/test_idx2inv.v000066400000000000000000000004041460156013500214160ustar00rootroot00000000000000From elpi.apps Require Import derive.param1 derive.invert derive.induction derive.idx2inv. Elpi derive.param1 list. Elpi derive.invert is_list. Elpi derive.idx2inv is_list. Check is_list_to_is_list_inv : forall A PA l, is_list A PA l -> is_list_inv A PA l.coq-elpi-2.1.0/apps/derive/tests/test_induction.v000066400000000000000000000101461460156013500220330ustar00rootroot00000000000000From elpi.apps Require Import derive.induction. From elpi.apps Require Import test_derive_stdlib test_param1 test_param1_functor. Import test_derive_stdlib.Coverage. Import derive.param1. (* for is_eq *) Import test_param1.Coverage. Import test_param1_functor.Coverage. Module Coverage. Elpi derive.induction empty. Elpi derive.induction unit. Elpi derive.induction peano. Elpi derive.induction option. Elpi derive.induction pair. Elpi derive.induction seq. Elpi derive.induction box_peano. Elpi derive.induction rose. Elpi derive.induction rose_p. Elpi derive.induction rose_o. Elpi derive.induction nest. Elpi derive.induction w. Elpi derive.induction vect. Elpi derive.induction dyn. Elpi derive.induction zeta. Elpi derive.induction beta. Elpi derive.induction iota. Elpi derive.induction large. Elpi derive.induction prim_int. Elpi derive.induction prim_float. Elpi derive.induction fo_record. Elpi derive.induction pa_record. Elpi derive.induction pr_record. Elpi derive.induction dep_record. Elpi derive.induction enum. Elpi derive.induction eq. Elpi derive.induction bool. Elpi derive.induction sigma_bool. Elpi derive.induction ord. Elpi derive.induction ord2. Elpi derive.induction val. End Coverage. Import Coverage. Locate is_unit. Check empty_induction : forall P : empty -> Prop, forall x, is_empty x -> P x. Check unit_induction : forall P : unit -> Prop, P tt -> forall x, is_unit x -> P x. Check peano_induction : forall P, P Zero -> (forall n, P n -> P (Succ n)) -> forall x, is_peano x -> P x. Check option_induction : forall A PA P, (P (None A)) -> (forall a, PA a -> P (Some A a)) -> forall x, is_option A PA x -> P x. Check pair_induction : forall A PA B PB P, (forall a, PA a -> forall b, PB b -> P (Comma A B a b)) -> forall x, is_pair A PA B PB x -> P x. Check seq_induction : forall A PA P, P (Nil A) -> (forall x, PA x -> forall xs, P xs -> P (Cons A x xs)) -> forall l, is_seq A PA l -> P l. Check rose_induction : forall A PA P, (forall x, PA x -> P (Leaf A x)) -> (forall l, is_seq (rose A) P l -> P (Node A l)) -> forall x, is_rose A PA x -> P x. Check nest_induction : forall P : forall A : Type, (A -> Type) -> nest A -> Type, (forall A PA, P A PA (NilN A)) -> (forall A PA x, PA x -> forall xs, P (pair A A) (is_pair A PA A PA) xs -> P A PA (ConsN A x xs)) -> forall A PA n, is_nest A PA n -> P A PA n. Check w_induction : forall A PA P, (forall f, (forall a, PA a -> P (f a)) -> P (via A f)) -> forall x, is_w A PA x -> P x. Check vect_induction : forall A PA (P : forall n, is_peano n -> vect A n -> Type), P Zero is_Zero (VNil A) -> (forall a, PA a -> forall n, forall nR: is_peano n, forall v : vect A n, P n nR v -> P (Succ n) (is_Succ n nR) (VCons A a n v)) -> forall l lR x, is_vect A PA l lR x -> P l lR x. Check dyn_induction : forall P, (forall T PT (t : T), PT t -> P (box T t)) -> forall x, is_dyn x -> P x. Check zeta_induction : forall A PA P, (forall a, PA a -> forall c, PA c -> P (Envelope A a c)) -> forall x, is_zeta A PA x -> P x. Check iota_induction. Check large_induction. Check prim_int_induction. Check prim_float_induction. Check fo_record_induction : forall P, (forall x, is_peano x -> forall y, is_unit y -> P (Build_fo_record x y)) -> forall x, is_fo_record x -> P x. Check pa_record_induction : forall A PA P, (forall x, is_peano x -> forall y, PA y -> P (Build_pa_record A x y)) -> forall x, is_pa_record A PA x -> P x. Check pr_record_induction : forall A pr P, (forall x, is_peano x -> forall y, pr y -> P (Build_pr_record A x y)) -> forall x, is_pr_record A pr x -> P x. Check dep_record_induction : forall P, (forall x (px : is_peano x) y, is_vect unit is_unit x px y -> P (Build_dep_record x y)) -> forall x, is_dep_record x -> P x. Check enum_induction : forall P, (P E1) -> (P E2) -> (P E3) -> forall x, is_enum x -> P x. Check sigma_bool_induction. Check ord_induction : forall p Pp P, (forall n Pn l, is_eq bool is_bool (is_leq n p) (is_is_leq n Pn p Pp) true is_true l -> P (mkOrd p n l)) -> forall (o : ord p), is_ord p Pp o -> P o. Check ord2_induction : forall p Pp P, (forall (o1 : ord p), is_ord p Pp o1 -> forall (o2 : ord p), is_ord p Pp o2 -> P (mkOrd2 p o1 o2)) -> forall (o : ord2 p), is_ord2 p Pp o -> P o. coq-elpi-2.1.0/apps/derive/tests/test_invert.v000066400000000000000000000010761460156013500213500ustar00rootroot00000000000000From elpi.apps Require Import derive.invert. Inductive test A : bool -> Type := K1 : test true | K2 : forall x, A -> test (negb x) -> test (negb (negb x)). Elpi derive.invert test. Check test_inv : Type -> bool -> Type. Check K1_inv : forall A b, b = true -> test_inv A b. Check K2_inv : forall A b, forall x, A -> test_inv A (negb x) -> b = negb (negb x) -> test_inv A b. Inductive listR A PA : list A -> Type := | nilR : listR (@nil A) | consR : forall a : A, PA a -> forall xs : list A, listR xs -> listR (cons a xs). Elpi derive.invert listR. Print listR_inv.coq-elpi-2.1.0/apps/derive/tests/test_isK.v000066400000000000000000000037671460156013500206000ustar00rootroot00000000000000From elpi.apps Require Import test_derive_stdlib derive.isK. Import test_derive_stdlib.Coverage. (* coverage *) Module Coverage. Elpi derive.isK empty. Elpi derive.isK unit. Elpi derive.isK peano. Elpi derive.isK option. Elpi derive.isK pair. Elpi derive.isK seq. Elpi derive.isK box_peano. Elpi derive.isK rose. Elpi derive.isK rose_p. Elpi derive.isK rose_o. Elpi derive.isK nest. Elpi derive.isK w. Elpi derive.isK vect. Elpi derive.isK dyn. Elpi derive.isK zeta. Elpi derive.isK beta. Elpi derive.isK iota. Elpi derive.isK large. Elpi derive.isK prim_int. Elpi derive.isK prim_float. Elpi derive.isK fo_record. Elpi derive.isK pa_record. Elpi derive.isK pr_record. Elpi derive.isK dep_record. Elpi derive.isK enum. Elpi derive.isK bool. Elpi derive.isK eq. Elpi derive.isK sigma_bool. Elpi derive.isK ord. Elpi derive.isK val. End Coverage. Import Coverage. Check unit_is_tt : unit -> bool. Check peano_is_Zero : peano -> bool. Check peano_is_Succ : peano -> bool. Check option_is_None : forall A, option A -> bool. Check option_is_Some : forall A, option A -> bool. Check pair_is_Comma : forall A B, pair A B -> bool. Check seq_is_Nil : forall A, seq A -> bool. Check seq_is_Cons : forall A, seq A -> bool. Check rose_is_Leaf : forall A, rose A -> bool. Check rose_is_Node : forall A, rose A -> bool. Check nest_is_NilN : forall A, nest A -> bool. Check nest_is_ConsN : forall A, nest A -> bool. Check w_is_via : forall A, w A -> bool. Check vect_is_VNil : forall A i, vect A i -> bool. Check vect_is_VCons : forall A i, vect A i -> bool. Check dyn_is_box : dyn -> bool. Check zeta_is_Envelope : forall A, zeta A -> bool. Check beta_is_Redex : forall A, beta A -> bool. Check iota_is_Why : iota -> bool. Check large_is_K1. Check large_is_K2. Check prim_int_is_PI. Check prim_float_is_PF. Check fo_record_is_Build_fo_record : fo_record -> bool. Check pa_record_is_Build_pa_record : forall A, pa_record A -> bool. Check pr_record_is_Build_pr_record : forall A, pr_record A -> bool. Check enum_is_E1 : enum -> bool. coq-elpi-2.1.0/apps/derive/tests/test_lens.v000066400000000000000000000025211460156013500207760ustar00rootroot00000000000000From elpi.apps Require Import test_derive_stdlib derive.lens. Import test_derive_stdlib.Coverage. (* coverage *) Module Coverage. Elpi derive.lens fo_record. Elpi derive.lens pa_record. Elpi derive.lens pr_record. Fail Elpi derive.lens dep_record. Fail Elpi derive.lens sigma_bool. End Coverage. Import Coverage. Check _f1 : Lens fo_record fo_record peano peano. Check _f2 : Lens fo_record fo_record unit unit. Check @_f3 : forall A, Lens (pa_record A) (pa_record A) peano peano. Check @_f4 : forall A, Lens (pa_record A) (pa_record A) A A. Check @_pf3 : forall A, Lens (pr_record A) (pr_record A) peano peano. Check @_pf4 : forall A, Lens (pr_record A) (pr_record A) A A. Goal forall A x, x = @_pf3 A. intros; unfold _pf3. match goal with | |- x = {| over := fun f r => {| pf3 := f (_ r); pf4 := _ r |} ; view := _ |} => idtac "ok" | |- _ => fail "not primitive" end. Abort. #[projections(primitive=yes)] Record R := MkR { proj : nat; }. Elpi derive.lens R "R__". Lemma failing r : r.(proj) = 0 -> view R__proj r = r.(proj). Proof. simpl. intros Hpr. rewrite Hpr. reflexivity. Abort. Lemma working r : match r with MkR r_proj => r_proj end = 0 -> view R__proj r = match r with MkR r_proj => r_proj end. Proof. simpl. intros Hpr. rewrite Hpr. Fail reflexivity. unfold proj. rewrite Hpr. reflexivity. Qed. coq-elpi-2.1.0/apps/derive/tests/test_lens_laws.v000066400000000000000000000030051460156013500220220ustar00rootroot00000000000000 From elpi.apps Require Import derive.lens_laws. From elpi.apps Require Import test_derive_stdlib test_lens. Import test_derive_stdlib.Coverage. Import test_lens.Coverage. (* coverage *) Module Coverage. Elpi derive.lens_laws fo_record. Elpi derive.lens_laws pa_record. Elpi derive.lens_laws pr_record. Elpi derive.lens_laws dep_record. Elpi derive.lens_laws sigma_bool. End Coverage. Import Coverage. Check _f1_view_set : view_set _f1. Check _f2_view_set : view_set _f2. Check _f3_view_set : forall A, view_set (_f3 A). Check _f4_view_set : forall A, view_set (_f4 A). Check _pf3_view_set : forall A, view_set (_pf3 A). Check _pf4_view_set : forall A, view_set (_pf4 A). Check _f1_set_set : set_set _f1. Check _f2_set_set : set_set _f2. Check _f3_set_set : forall A, set_set (_f3 A). Check _f4_set_set : forall A, set_set (_f4 A). Check _pf3_set_set : forall A, set_set (_pf3 A). Check _pf4_set_set : forall A, set_set (_pf4 A). Check _f1_set_view : set_view _f1. Check _f2_set_view : set_view _f2. Check _f3_set_view : forall A, set_view (_f3 A). Check _f4_set_view : forall A, set_view (_f4 A). Check _pf3_set_view : forall A, set_view (_pf3 A). Check _pf4_set_view : forall A, set_view (_pf4 A). Check _f1_f2_exchange : exchange _f1 _f2. Check _f2_f1_exchange : exchange _f2 _f1. Check _f3_f4_exchange : forall A, exchange (_f3 A) (_f4 A). Check _f4_f3_exchange : forall A, exchange (_f4 A) (_f3 A). Check _pf3_pf4_exchange : forall A, exchange (_pf3 A) (_pf4 A). Check _pf4_pf3_exchange : forall A, exchange (_pf4 A) (_pf3 A). coq-elpi-2.1.0/apps/derive/tests/test_map.v000066400000000000000000000032461460156013500206170ustar00rootroot00000000000000From elpi.apps Require Import derive.map. From elpi.apps.derive.tests Require Import test_derive_stdlib. Import test_derive_stdlib.Coverage. Module Coverage. Elpi derive.map empty. Elpi derive.map unit. Elpi derive.map peano. Elpi derive.map option. Elpi derive.map pair. Elpi derive.map seq. Elpi derive.map box_peano. Elpi derive.map rose. Elpi derive.map rose_p. Elpi derive.map rose_o. Fail Elpi derive.map nest. Fail Elpi derive.map w. Elpi derive.map vect. Elpi derive.map dyn. Elpi derive.map zeta. Fail Elpi derive.map beta. Elpi derive.map iota. Elpi derive.map large. Elpi derive.map prim_int. Elpi derive.map prim_float. Elpi derive.map fo_record. Elpi derive.map pa_record. Elpi derive.map pr_record. Elpi derive.map dep_record. Elpi derive.map enum. Fail Elpi derive.map eq. Elpi derive.map bool. Elpi derive.map sigma_bool. Fail Elpi derive.map ord. Elpi derive.map val. End Coverage. Import Coverage. Local Notation map T := (T -> T). Local Notation map1 T := (forall X Y, (X -> Y) -> T X%type -> T Y%type). Check empty_map : map empty. Check unit_map : map unit. Check peano_map : map peano. Check option_map : map1 option. Check pair_map : forall A B (f : A -> B) C D (g : C -> D), (pair A C) -> (pair B D). Check seq_map : map1 seq. Check rose_map : map1 rose. Fail Check nest_map. Fail Check w_map. Check vect_map : forall A B (f : A -> B) i, vect A i -> vect B i. Check dyn_map : map dyn. Check zeta_map : forall A B (f : A -> B), zeta A -> zeta B. Fail Check beta_map. Check iota_map : map iota. Check large_map : map large. Check prim_int_map : map prim_int. Check prim_float_map : map prim_float. Check pa_record_map : map1 pa_record. Check pr_record_map : map1 pr_record. coq-elpi-2.1.0/apps/derive/tests/test_param1.v000066400000000000000000000121011460156013500212110ustar00rootroot00000000000000From elpi.apps Require Import derive.param1. From elpi.apps.derive.tests Require Import test_derive_stdlib. Import test_derive_stdlib.Coverage. Module Coverage. Elpi derive.param1 empty. Elpi derive.param1 unit. Elpi derive.param1 peano. Elpi derive.param1 option. Elpi derive.param1 pair. Elpi derive.param1 seq. Elpi derive.param1 box_peano. Elpi derive.param1 rose. Elpi derive.param1 rose_p. Elpi derive.param1 rose_o. Elpi derive.param1 nest. Elpi derive.param1 w. Elpi derive.param1 vect. Elpi derive.param1 dyn. Elpi derive.param1 zeta. Elpi derive.param1 beta. Elpi derive.param1 iota. Elpi derive.param1 large. Elpi derive.param1 prim_int. Elpi derive.param1 prim_float. Elpi derive.param1 fo_record. Elpi derive.param1 pa_record. Elpi derive.param1 pr_record. Elpi derive.param1 dep_record. Elpi derive.param1 enum. (* Elpi derive.param1 eq. (* done in param1.v *) *) Elpi derive.param1 bool. Elpi derive.param1 is_zero. Elpi derive.param1 sigma_bool. Elpi derive.param1 is_leq. Elpi derive.param1 ord. Elpi derive.param1 ord2. Elpi derive.param1 val. End Coverage. Import Coverage. Section Test. Local Notation pred X := (X -> Type). Check is_empty : pred empty. Check is_unit : pred unit. Check is_peano : pred peano. Check is_option : forall A, pred A -> pred (option A). Check is_pair : forall A, pred A -> forall B, pred B -> pred (pair A B). Check is_seq : forall A, pred A -> pred (seq A). Check is_rose : forall A, pred A -> pred (rose A). Check is_nest : forall A, pred A -> pred (nest A). Check is_w : forall A, pred A -> pred (w A). Check is_vect : forall A, pred A -> forall i, is_peano i -> pred (vect A i). Check is_dyn : pred dyn. Check is_zeta : forall A, pred A -> pred (zeta A). Check is_beta : forall A, pred A -> pred (beta A). Check is_iota : pred iota. Check is_large : pred large. Check is_prim_int : pred prim_int. Check is_prim_float : pred prim_float. Check is_fo_record : pred fo_record. Check is_pa_record : forall A, pred A -> pred (pa_record A). Check is_pr_record : forall A, pred A -> pred (pr_record A). Check is_enum : pred enum. Check is_ord : forall (p : peano) (pa : is_peano p), pred (ord p). Check is_ord2 : forall (p : peano) (pa : is_peano p), pred (ord2 p). Check is_val : pred val. End Test. (* other tests by Cyril *) Set Uniform Inductive Parameters. Module OtherTests. Elpi derive.param1 unit. Elpi derive.param1 nat. Inductive fin : nat -> Type := FO : fin 0 | FS : forall n : nat, fin n -> fin (S n). Elpi derive.param1 fin. Fixpoint fin_length n (v : fin n) := match v with FO => 0 | FS _ w => S (fin_length _ w) end. Elpi derive.param1 fin_length. Inductive vec (A : Type) : nat -> Type := vnil : vec 0 | vcons : A -> forall n : nat, vec n -> vec (S n). Elpi derive.param1 vec. Fixpoint vec_length (A : Type) n (v : vec A n) := match v with vnil _ => 0 | vcons _ _ _ w => S (vec_length _ _ w) end. Elpi derive.param1 vec_length. Elpi derive.param1 list. Elpi derive.param1 is_list. Elpi derive.param1 eq. Fixpoint plus' m n := match n with 0 => m | S n => S (plus' m n) end. Elpi derive.param1 plus'. Elpi derive.param1 plus. Elpi derive.param1 prod. Elpi derive.param1 fst. Elpi derive.param1 snd. Elpi derive.param1 bool. Elpi derive.param1 Nat.divmod. Elpi derive.param1 Nat.div. Definition test m n p q r := m + n + p + q + r. Elpi derive.param1 test. Definition vec_length_type := forall (A : Type) (n : nat), vec A n -> nat. Elpi derive.param1 vec_length_type. Definition vec_length_rec (vec_length : vec_length_type) (A : Type) n (v : vec A n) := match v with vnil _ => 0 | vcons _ _ _ w => S (vec_length _ _ w) end. Elpi derive.param1 vec_length_rec. Elpi Query derive.param1 lp:{{ reali {{O}} Y }}. Elpi Query derive.param1 lp:{{ reali {{S (S 0)}} Y }}. Definition nat2nat := nat -> nat. Definition nat2nat2nat := nat -> nat -> nat. Elpi derive.param1 nat2nat. Elpi derive.param1 nat2nat2nat. Elpi derive.param1 pred. Print is_pred. Check (is_pred : is_nat2nat pred). Fixpoint predn n := match n with 0 => 0 | S n => S (predn n) end. Elpi derive.param1 predn. Check (is_predn : is_nat2nat predn). Check (is_add : is_nat2nat2nat plus). Fixpoint quasidn n m := S (match n with 0 => m | S n => S (quasidn n m) end). Elpi derive.param1 quasidn. Fixpoint weirdn n := match n with S (S n) => S (weirdn n) | _ => 0 end. Elpi derive.param1 weirdn. Inductive bla : nat -> Type := Bla : nat -> bla 0 | Blu n : bla n -> bla 1. Elpi derive.param1 bla. Print is_bla. Elpi Query derive.param1 lp:{{ coq.TC.db-for {coq.term->gref {{@reali_db}}} PDb }}. Fixpoint silly (n : nat) := n. Elpi derive.param1 silly. (* issue #262 *) Definition foo (a : unit) : unit := let b := a in a. Elpi derive.param1 foo. (* issue #266 *) Elpi derive.param1 option. Definition upair : Set := unit * unit. Elpi derive.param1 upair. Definition uplist := list upair. Elpi derive.param1 uplist. Elpi Print derive.param1. Fixpoint bar (pl : uplist) (id : unit) : option unit := None unit. Elpi derive.param1 bar. Fixpoint nat_eq (n m : nat) {struct n} : bool := match n, m with | O, O => true | S a, S b => nat_eq a b | _, _ => false end. Elpi derive.param1 nat_eq. End OtherTests. coq-elpi-2.1.0/apps/derive/tests/test_param1_congr.v000066400000000000000000000062671460156013500224210ustar00rootroot00000000000000From elpi.apps Require Import derive.param1_congr. From elpi.apps Require Import test_derive_stdlib test_param1. Import test_derive_stdlib.Coverage. Import test_param1.Coverage. Module Coverage. Elpi derive.param1.congr is_empty. Elpi derive.param1.congr is_unit. Elpi derive.param1.congr is_peano. Elpi derive.param1.congr is_option. Elpi derive.param1.congr is_pair. Elpi derive.param1.congr is_seq. Elpi derive.param1.congr is_box_peano. Elpi derive.param1.congr is_nest. Elpi derive.param1.congr is_rose. Elpi derive.param1.congr is_rose_p. Elpi derive.param1.congr is_rose_o. Elpi derive.param1.congr is_w. Elpi derive.param1.congr is_vect. Elpi derive.param1.congr is_dyn. Elpi derive.param1.congr is_zeta. Elpi derive.param1.congr is_beta. Elpi derive.param1.congr is_iota. (* Elpi derive.param1.congr is_large. (* slow *) *) Elpi derive.param1.congr is_prim_int. Elpi derive.param1.congr is_prim_float. Elpi derive.param1.congr is_fo_record. Elpi derive.param1.congr is_pa_record. Elpi derive.param1.congr is_pr_record. Elpi derive.param1.congr is_dep_record. Elpi derive.param1.congr is_enum. Elpi derive.param1.congr is_bool. Elpi derive.param1.congr is_eq. Elpi derive.param1.congr is_sigma_bool. Elpi derive.param1.congr is_ord. Elpi derive.param1.congr is_val. End Coverage. Import Coverage. Check congr_is_tt : is_tt = is_tt. Check congr_is_Zero : is_Zero = is_Zero. Check congr_is_Succ : forall x p1 p2, p1 = p2 -> is_Succ x p1 = is_Succ x p2. Check congr_is_None : forall A PA, is_None A PA = is_None A PA. Check congr_is_Some : forall A PA x p1 p2, p1 = p2 -> is_Some A PA x p1 = is_Some A PA x p2. Check congr_is_Comma : forall A PA B PB x p1 p2, p1 = p2 -> forall y q1 q2, q1 = q2 -> is_Comma A PA B PB x p1 y q1 = is_Comma A PA B PB x p2 y q2. Check congr_is_Nil : forall A PA, is_Nil A PA = is_Nil A PA. Check congr_is_Cons : forall A PA x p1 p2, p1 = p2 -> forall y q1 q2, q1 = q2 -> is_Cons A PA x p1 y q1 = is_Cons A PA x p2 y q2. Check congr_is_Leaf : forall A PA x p1 p2, p1 = p2 -> is_Leaf A PA x p1 = is_Leaf A PA x p2. Check congr_is_Node : forall A PA x p1 p2, p1 = p2 -> is_Node A PA x p1 = is_Node A PA x p2. Fail Check congr_is_NilN. Fail Check congr_is_ConsN. Check congr_is_via : forall A PA x p1 p2, p1 = p2 -> is_via A PA x p1 = is_via A PA x p2. Check congr_is_VNil : forall A PA, is_VNil A PA = is_VNil A PA. Fail Check congr_is_VCons. Fail Check congr_is_box. Check congr_is_Envelope : forall A PA x p1 p2, p1 = p2 -> forall y q1 q2, q1 = q2 -> is_Envelope A PA x p1 y q1 = is_Envelope A PA x p2 y q2. Check congr_is_Redex : forall A PA x p1 p2, p1 = p2 -> is_Redex A PA x p1 = is_Redex A PA x p2. Fail Check congr_is_Why. (* Check congr_is_K1 . *) Check congr_is_PI. Check congr_is_PF. Check congr_is_Build_fo_record : forall n p1 p2, p1 = p2 -> forall b q1 q2, q1 = q2 -> is_Build_fo_record n p1 b q1= is_Build_fo_record n p2 b q2. Check congr_is_Build_pa_record : forall A PA n p1 p2, p1 = p2 -> forall b q1 q2, q1 = q2 -> is_Build_pa_record A PA n p1 b q1= is_Build_pa_record A PA n p2 b q2. Check congr_is_Build_pr_record : forall A pr n p1 p2, p1 = p2 -> forall b q1 q2, q1 = q2 -> is_Build_pr_record A pr n p1 b q1= is_Build_pr_record A pr n p2 b q2. Check congr_is_E1 : is_E1 = is_E1. coq-elpi-2.1.0/apps/derive/tests/test_param1_functor.v000066400000000000000000000054541460156013500227660ustar00rootroot00000000000000From elpi.apps Require Import derive.param1_functor. From elpi.apps.derive.tests Require Import test_derive_stdlib test_param1. Import test_derive_stdlib.Coverage. Import test_param1.Coverage. Module Coverage. Elpi derive.param1.functor is_empty. Elpi derive.param1.functor is_unit. Elpi derive.param1.functor is_peano. Elpi derive.param1.functor is_option. Elpi derive.param1.functor is_pair. Elpi derive.param1.functor is_seq. Elpi derive.param1.functor is_box_peano. Elpi derive.param1.functor is_rose. Elpi derive.param1.functor is_rose_p. Elpi derive.param1.functor is_rose_o. Elpi derive.param1.functor is_nest. Fail Elpi derive.param1.functor is_w. Elpi derive.param1.functor is_vect. Elpi derive.param1.functor is_dyn. Elpi derive.param1.functor is_zeta. Elpi derive.param1.functor is_beta. Elpi derive.param1.functor is_iota. Elpi derive.param1.functor is_large. Elpi derive.param1.functor is_prim_int. Elpi derive.param1.functor is_prim_float. Elpi derive.param1.functor is_fo_record. Elpi derive.param1.functor is_pa_record. Elpi derive.param1.functor is_pr_record. Elpi derive.param1.functor is_dep_record. Elpi derive.param1.functor is_enum. Fail Elpi derive.param1.functor param1.is_eq. Elpi derive.param1.functor is_bool. Elpi derive.param1.functor is_sigma_bool. Elpi derive.param1.functor is_ord. Elpi derive.param1.functor is_ord2. Elpi derive.param1.functor is_val. End Coverage. Local Notation func isT := (forall x, isT x -> isT x). Local Notation func1 isT := (forall A P Q, (forall y : A, P y -> Q y) -> forall x, isT A P x -> isT A Q x). Local Notation func2 isT := (forall A P Q, (forall y : A, P y -> Q y) -> forall A1 P1 Q1, (forall y : A1, P1 y -> Q1 y) -> forall x, isT A P A1 P1 x -> isT A Q A1 Q1 x). Import Coverage. Check is_empty_functor : func is_empty. Check is_unit_functor : func is_unit. Check is_peano_functor : func is_peano. Check is_option_functor : func1 is_option. Check is_pair_functor : func2 is_pair. Check is_seq_functor : func1 is_seq. Check is_rose_functor : func1 is_rose. Fail Check is_nest_functor : func1 is_nest. Fail Check is_w_functor. Check is_vect_functor : forall A P Q, (forall y : A, P y -> Q y) -> forall i p (v : vect A i), is_vect A P i p v -> is_vect A Q i p v. Check is_dyn_functor : func is_dyn. Check is_zeta_functor : func1 is_zeta. Check is_beta_functor : func1 is_beta. Check is_iota_functor : func is_iota. Check is_large_functor : func is_large. Check is_prim_int_functor : func is_prim_int. Check is_prim_float_functor : func is_prim_float. Check is_fo_record_functor : func is_fo_record. Check is_pa_record_functor : func1 is_pa_record. Check is_pr_record_functor : func1 is_pr_record. Check is_enum_functor : func is_enum. Check is_ord_functor : forall n pn, func (is_ord n pn). Check is_ord2_functor : forall n pn, func (is_ord2 n pn). Check is_val_functor : func is_val. coq-elpi-2.1.0/apps/derive/tests/test_param1_trivial.v000066400000000000000000000111631460156013500227520ustar00rootroot00000000000000From elpi.apps Require Import derive.param1_trivial. From elpi.apps Require Import test_derive_stdlib test_param1 test_param1_congr. Import derive.param1. (* for is_eq *) Import test_derive_stdlib.Coverage. Import test_param1.Coverage. Import test_param1_congr.Coverage. Module Coverage. Elpi derive.param1.trivial is_empty. Elpi derive.param1.trivial is_unit. Elpi derive.param1.trivial is_peano. Elpi derive.param1.trivial is_option. Elpi derive.param1.trivial is_pair. Elpi derive.param1.trivial is_seq. Elpi derive.param1.trivial is_box_peano. Fail Elpi derive.param1.trivial is_nest. Elpi derive.param1.trivial is_rose. Elpi derive.param1.trivial is_rose_p. Elpi derive.param1.trivial is_rose_o. Fail Elpi derive.param1.trivial is_w. Fail Elpi derive.param1.trivial is_vect. Fail Elpi derive.param1.trivial is_dyn. Elpi derive.param1.trivial is_zeta. Elpi derive.param1.trivial is_beta. Fail Elpi derive.param1.trivial is_iota. Elpi derive.param1.trivial is_large. Elpi derive.param1.trivial is_prim_int. Elpi derive.param1.trivial is_prim_float. Elpi derive.param1.trivial is_fo_record. Elpi derive.param1.trivial is_pa_record. Elpi derive.param1.trivial is_pr_record. Fail Elpi derive.param1.trivial is_dep_record. Elpi derive.param1.trivial is_enum. Elpi derive.param1.trivial is_bool. (* Elpi derive.param1.trivial is_eq. (* ad-hoc *) *) Elpi derive.param1.trivial is_sigma_bool. Elpi derive.param1.trivial is_ord. Elpi derive.param1.trivial is_ord2. Elpi derive.param1.trivial is_val. End Coverage. Import Coverage. Check is_empty_trivial : trivial empty is_empty. Check is_unit_trivial : trivial unit is_unit. Check is_peano_trivial : trivial peano is_peano. Check is_option_trivial : forall A P, trivial A P -> trivial (option A) (is_option A P). Check is_pair_trivial : forall A P, trivial A P -> forall B Q, trivial B Q -> trivial (pair A B) (is_pair A P B Q). Check is_seq_trivial : forall A P, trivial A P -> trivial (seq A) (is_seq A P). Check is_rose_trivial : forall A P, trivial A P -> trivial (rose A) (is_rose A P). Fail Check is_nest_trivial. Fail Check is_w_trivial : forall A P, trivial A P -> trivial (w A) (is_w A P). Fail Check is_vect_trivial : forall A P, trivial A P -> forall i pi, trivial (vect A i) (is_vect A P i pi). Fail Check is_dyn_trivial. Check is_zeta_trivial : forall A P, trivial A P -> trivial (zeta A) (is_zeta A P). Check is_beta_trivial : forall A P, trivial A P -> trivial (beta A) (is_beta A P). Fail Check is_iota_trivial. Check is_large_trivial : trivial large is_large. Check is_prim_int_trivial : trivial prim_int is_prim_int. Check is_prim_float_trivial : trivial prim_float is_prim_float. Check is_fo_record_trivial : trivial fo_record is_fo_record. Check is_pa_record_trivial : forall A P, trivial A P -> trivial (pa_record A) (is_pa_record A P). Check is_pr_record_trivial : forall A P, trivial A P -> trivial (pr_record A) (is_pr_record A P). Check is_enum_trivial : trivial enum is_enum. Check is_sigma_bool_trivial : trivial sigma_bool is_sigma_bool. Check is_ord_trivial : forall p px, trivial (ord p) (is_ord p px). Check is_ord2_trivial : forall p px, trivial (ord2 p) (is_ord2 p px). Check is_val_trivial : trivial val is_val. Check is_empty_inhab : full empty is_empty. Check is_unit_inhab : full unit is_unit. Check is_peano_inhab : full peano is_peano. Check is_option_inhab : forall A P, full A P -> full (option A) (is_option A P). Check is_pair_inhab : forall A P, full A P -> forall B Q, full B Q -> full (pair A B) (is_pair A P B Q). Check is_seq_inhab : forall A P, full A P -> full (seq A) (is_seq A P). Check is_rose_inhab : forall A P, full A P -> full (rose A) (is_rose A P). Fail Check is_nest_inhab. Fail Check is_w_inhab : forall A P, full A P -> full (w A) (is_w A P). Fail Check is_vect_inhab : forall A P, full A P -> forall i pi, full (vect A i) (is_vect A P i pi). Fail Check is_dyn_inhab. Check is_zeta_inhab : forall A P, full A P -> full (zeta A) (is_zeta A P). Check is_beta_inhab : forall A P, full A P -> full (beta A) (is_beta A P). Fail Check is_iota_inhab. Check is_large_inhab : full large is_large. Check is_prim_int_inhab : full prim_int is_prim_int. Check is_prim_float_inhab : full prim_float is_prim_float. Check is_fo_record_inhab : full fo_record is_fo_record. Check is_pa_record_inhab : forall A P, full A P -> full (pa_record A) (is_pa_record A P). Check is_pr_record_inhab : forall A P, full A P -> full (pr_record A) (is_pr_record A P). Check is_enum_inhab : full enum is_enum. Check is_sigma_bool_inhab : full sigma_bool is_sigma_bool. Check is_ord_inhab : forall p px, full (ord p) (is_ord p px). Check is_ord2_inhab : forall p px, full (ord2 p) (is_ord2 p px). Check is_val_inhab : full val is_val. coq-elpi-2.1.0/apps/derive/tests/test_param2.v000066400000000000000000000047051460156013500212250ustar00rootroot00000000000000From elpi.apps Require Import derive.param2. Set Uniform Inductive Parameters. Elpi derive.param2 unit. Elpi derive.param2 nat. Elpi derive.param2 list. (* The Parametricty plugin of K & L asks for an interactive proof here (the proof to be produced is the match over n in the nil branch) *) Definition nth T (x0 : T) := fix rec (n : nat) (l : list T) {struct n} : T := match l, n with | nil, _ => x0 | cons x _, 0 => x | cons _ xs, S m => rec m xs end. Elpi derive.param2 nth. Print nth_R. Inductive fin : nat -> Type := FO : fin 0 | FS : forall n : nat, fin n -> fin (S n). Elpi derive.param2 fin. Fixpoint fin_length n (v : fin n) := match v with FO => 0 | FS _ w => S (fin_length _ w) end. Elpi derive.param2 fin_length. Inductive vec (A : Type) : nat -> Type := vnil : vec 0 | vcons : A -> forall n : nat, vec n -> vec (S n). Elpi derive.param2 vec. Fixpoint vec_length (A : Type) n (v : vec A n) := match v with vnil _ => 0 | vcons _ _ _ w => S (vec_length _ _ w) end. Elpi derive.param2 vec_length. Elpi derive.param2 eq. Elpi derive.param2 list_R. Fixpoint plus' m n := match n with 0 => m | S n => S (plus' m n) end. Elpi derive.param2 plus'. Elpi derive.param2 plus. Elpi derive.param2 prod. Elpi derive.param2 fst. Elpi derive.param2 snd. Elpi derive.param2 Nat.divmod. Elpi derive.param2 Nat.div. Definition test m n p q r := m + n + p + q + r. Elpi derive.param2 test. Definition vec_length_type := forall (A : Type) (n : nat), vec A n -> nat. Elpi derive.param2 vec_length_type. Definition vec_length_rec (vec_length : vec_length_type) (A : Type) n (v : vec A n) := match v with vnil _ => 0 | vcons _ _ _ w => S (vec_length _ _ w) end. Elpi derive.param2 vec_length_rec. Definition nat2nat := nat -> nat. Definition nat2nat2nat := nat -> nat -> nat. Elpi derive.param2 nat2nat. Elpi derive.param2 nat2nat2nat. Elpi derive.param2 pred. Print pred_R. Check (pred_R : nat2nat_R pred pred). Fixpoint predn n := match n with 0 => 0 | S n => S (predn n) end. Elpi derive.param2 predn. Check (predn_R : nat2nat_R predn predn). Check (add_R : nat2nat2nat_R plus plus). Fixpoint quasidn n m := S (match n with 0 => m | S n => S (quasidn n m) end). Elpi derive.param2 quasidn. Fixpoint weirdn n := match n with S (S n) => S (weirdn n) | _ => 0 end. Elpi derive.param2 weirdn. Inductive bla : nat -> Type := Bla : nat -> bla 0 | Blu n : bla n -> bla 1. Elpi derive.param2 bla. Fixpoint silly (n : nat) := n. Elpi derive.param2 silly. coq-elpi-2.1.0/apps/derive/tests/test_projK.v000066400000000000000000000055631460156013500211330ustar00rootroot00000000000000From elpi.apps Require Import derive.projK. From elpi.apps.derive.tests Require Import test_derive_stdlib. Import test_derive_stdlib.Coverage. Module Coverage. Elpi derive.projK empty. Elpi derive.projK unit. Elpi derive.projK peano. Elpi derive.projK option. Elpi derive.projK pair. Elpi derive.projK seq. Elpi derive.projK box_peano. Elpi derive.projK rose. Elpi derive.projK rose_p. Elpi derive.projK rose_o. Elpi derive.projK nest. Elpi derive.projK w. Elpi derive.projK vect. Elpi derive.projK dyn. Elpi derive.projK zeta. Elpi derive.projK beta. Elpi derive.projK iota. Elpi derive.projK large. Elpi derive.projK prim_int. Elpi derive.projK prim_float. Elpi derive.projK fo_record. Elpi derive.projK pa_record. Elpi derive.projK pr_record. Elpi derive.projK dep_record. Elpi derive.projK enum. Elpi derive.projK eq. Elpi derive.projK bool. Elpi derive.projK sigma_bool. Elpi derive.projK ord. Elpi derive.projK val. End Coverage. Import Coverage. Check projSucc1 : peano -> peano -> peano. Check projSome1 : forall A, A -> option A -> A. Check projComma1 : forall A B, A -> B -> pair A B -> A. Check projComma2 : forall A B, A -> B -> pair A B -> B. Check projCons1 : forall A, A -> seq A -> seq A -> A. Check projCons2 : forall A, A -> seq A -> seq A -> seq A. Check projLeaf1 : forall A, A -> rose A -> A. Check projNode1 : forall A, seq (rose A) -> rose A -> seq (rose A). Check projConsN1 : forall A, A -> nest (pair A A) -> nest A -> A. Check projConsN2 : forall A, A -> nest (pair A A) -> nest A -> nest (pair A A). Check projvia1 : forall A, (A -> w A) -> w A -> (A -> w A). Check projVCons1 : forall A i, A -> forall j, vect A j -> vect A i -> A. Check projVCons2 : forall A i, A -> forall j, vect A j -> vect A i -> peano. Check projVCons3 : forall A i, A -> forall j, vect A j -> vect A i -> { w & vect A w }. Check projbox1 : forall T, T -> dyn -> Type. Check projbox2 : forall T, T -> dyn -> { T : Type & T }. Check projEnvelope1 : forall A, A -> A -> zeta A -> A. Check eq_refl 0 : projEnvelope1 nat 1 1 (Envelope nat 0 1) = 0. Check projEnvelope2 : forall A, A -> A -> zeta A -> A. Check eq_refl 0 : projEnvelope2 nat 1 1 (Envelope nat 1 0) = 0. Check projRedex1 : forall A, A -> beta A -> A. Check projWhy1 : forall n : peano, match n return Type with | Zero => peano | Succ _ => unit end -> iota -> peano. Check projWhy2 : forall n : peano, match n return Type with | Zero => peano | Succ _ => unit end -> iota -> { i : peano & match i with Zero => peano | Succ _ => unit end }. Check projPI1. Check projPF1. Check projBuild_fo_record1 : peano -> unit -> fo_record -> peano. Check projBuild_fo_record2 : peano -> unit -> fo_record -> unit. Check projBuild_pa_record2 : forall A, peano -> A -> pa_record A -> A. Check projBuild_pr_record2 : forall A, peano -> A -> pr_record A -> A. coq-elpi-2.1.0/apps/derive/tests/test_readme.v000066400000000000000000000047321460156013500213000ustar00rootroot00000000000000From elpi.apps Require Import derive.std. Module example1. derive Inductive peano := Zero | Succ (p : peano). Print peano. (* Inductive peano : Set := Zero : peano | Succ : peano -> peano *) Eval compute in peano_eqb Zero (Succ Zero). (* = false : bool *) Check peano_eqb_OK. (* peano_eqb_OK : forall x1 x2 : peano, reflect (x1 = x2) (eqb x1 x2) *) End example1. Module example2. #[module] derive Inductive peano := Zero | Succ (p : peano). Print peano. (* Notation peano := peano.peano *) Print peano.peano. (* Inductive peano : Set := Zero : peano | Succ : peano -> peano *) Eval compute in peano.eqb Zero (Succ Zero). (* = false : bool *) Check peano.eqb_OK. (* peano.eqb_OK : forall x1 x2 : peano, reflect (x1 = x2) (eqb x1 x2) *) End example2. Module example3. #[module="Peano"] derive Inductive peano := Zero | Succ (p : peano). Print peano. (* Notation peano := Peano.peano *) Print Peano.peano. (* Inductive peano : Set := Zero : peano | Succ : peano -> peano *) Eval compute in Peano.eqb Zero (Succ Zero). (* = false : bool *) Check Peano.eqb_OK. (* Peano.eqb_OK : forall x1 x2 : peano, reflect (x1 = x2) (eqb x1 x2) *) End example3. Module example4. #[module="Peano",prefix="Peano_"] derive Inductive peano := Zero | Succ (p : peano). Print peano. (* Notation Peano := Peano.peano *) Print Peano.peano. (* Inductive peano : Set := Zero : peano | Succ : peano -> peano *) Print Module Peano. Eval compute in Peano.Peano_eqb Zero (Succ Zero). (* = false : bool *) Check Peano.Peano_eqb_OK. (* Peano.Peano_eqb_OK : forall x1 x2 : peano, reflect (x1 = x2) (eqb x1 x2) *) End example4. Module example5. #[prefix=""] derive Inductive peano := Zero | Succ (p : peano). Print peano. (* Inductive peano : Set := Zero : peano | Succ : peano -> peano *) Eval compute in eqb Zero (Succ Zero). (* = false : bool *) Check eqb_OK. (* eqb_OK : forall x1 x2 : peano, reflect (x1 = x2) (eqb x1 x2) *) End example5. Module example6. #[module=Peano,no_alias] derive Inductive peano := Zero | Succ (p : peano). Fail Print peano. Print Peano.peano. (* Inductive peano : Set := Peano.Zero : peano | Peano.Succ : peano -> peano *) Eval compute in Peano.eqb Peano.Zero (Peano.Succ Peano.Zero). (* = false : bool *) Check Peano.eqb_OK. (* Peano.eqb_OK : forall x1 x2 : peano, reflect (x1 = x2) (eqb x1 x2) *) End example6. Fail #[no_alias] derive Inductive peano := Zero | Succ (p : peano). coq-elpi-2.1.0/apps/derive/tests/test_tag.v000066400000000000000000000034351460156013500206150ustar00rootroot00000000000000From elpi.apps Require Import derive.tag. From elpi.apps.derive.tests Require Import test_derive_stdlib. Import test_derive_stdlib.Coverage. Module Coverage. Elpi derive.tag empty. Elpi derive.tag unit. Elpi derive.tag peano. Elpi derive.tag option. Elpi derive.tag pair. Elpi derive.tag seq. Elpi derive.tag box_peano. Elpi derive.tag rose. Elpi derive.tag rose_p. Elpi derive.tag rose_o. Elpi derive.tag nest. Elpi derive.tag w. Elpi derive.tag vect. Elpi derive.tag dyn. Fail Elpi derive.tag zeta. Elpi derive.tag beta. Elpi derive.tag iota. Elpi derive.tag large. Elpi derive.tag prim_int. Elpi derive.tag prim_float. Elpi derive.tag fo_record. Elpi derive.tag pa_record. Elpi derive.tag pr_record. Elpi derive.tag dep_record. Elpi derive.tag enum. Elpi derive.tag eq. Elpi derive.tag bool. Elpi derive.tag sigma_bool. Elpi derive.tag ord. Elpi derive.tag ord2. Elpi derive.tag val. End Coverage. Import Coverage. Import PArith. Local Notation tag X := (X -> positive). Check empty_tag : tag empty. Check unit_tag : tag unit. Check peano_tag : tag peano. Check option_tag : forall A, tag (option A). Check pair_tag : forall A B, tag (pair A B). Check seq_tag : forall A, tag (seq A). Check rose_tag : forall A, tag (rose A). Check nest_tag : forall A, tag (nest A). Check w_tag : forall A, tag (w A). Check vect_tag : forall A i, tag (vect A i). Check dyn_tag : tag dyn. Fail Check zeta_tag : forall A, tag (zeta A). Check beta_tag : forall A, tag (beta A). Check iota_tag : tag iota. Check large_tag : tag large. Check prim_int_tag : tag prim_int. Check prim_float_tag : tag prim_float. Check pa_record_tag : forall A, tag (pa_record A). Check pr_record_tag : forall A, tag (pr_record A). Check ord_tag : forall p : peano, tag (ord p). Check ord2_tag : forall p : peano, tag (ord2 p). Check val_tag : tag val. coq-elpi-2.1.0/apps/derive/theories/000077500000000000000000000000001460156013500172675ustar00rootroot00000000000000coq-elpi-2.1.0/apps/derive/theories/derive.v000066400000000000000000000067031460156013500207420ustar00rootroot00000000000000(* Generates a module containing all the derived constants. license: GNU Lesser General Public License Version 2.1 or later ------------------------------------------------------------------------- *) (* since non-uniform inductive parameters are rarely used and the inference code from the kernel is not easily accessible, we require the user to be explicit about them, eg Inductive foo U1 U2 | NU1 NU2 := ... *) #[global] Set Uniform Inductive Parameters. (** The derive command The derive command can be invoked in two ways. - [derive ] - [derive Inductive ] [derive Record ] The first command runs all the derivations on an alerady declared inductive type named [] and all generated constants are named after the prefix [] (by default the inductive type name followed by [_]). Example: << derive nat. (* default prefix nat_ *) derive nat my_nat_stuff_. >> The second command takes as argument an inductive type declaration, it creates a module named after the inductive type and puts inside id both the inductive types and the output of the derivations. Example: << derive Inductive tickle A := stop | more : A -> tickle-> tickle. >> is equivalent to << Module tickle. Inductive tickle A := stop | more : A -> tickle-> tickle. derive tickle "". End tickle. Notation tickle := tickle.tickle. Notation stop := tickle.stop. Notation more := tickle.more. >> Both commands honor the [#[verbose]] attribute. If set they print all the derivations that are run, and if they fail or succeed. A derivation d can be skipped by using the [#[skip(d)]] attribute. A derivation different from d can be skipped [#[only(d)]] attribute. *) From elpi.apps.derive Extra Dependency "derive_hook.elpi" as derive_hook. From elpi.apps.derive Extra Dependency "derive_synterp_hook.elpi" as derive_synterp_hook. From elpi.apps.derive Extra Dependency "derive.elpi" as derive. From elpi.apps.derive Extra Dependency "derive_synterp.elpi" as derive_synterp. From elpi Require Import elpi. Elpi Command derive. #[phase="both"] Elpi Accumulate lp:{{ % runs P in a context where Coq #[attributes] are parsed pred with-attributes i:prop. with-attributes P :- attributes A, coq.parse-attributes A [ att "verbose" bool, att "only" attmap, att "recursive" bool, att "prefix" string, att "module" string, att "no_alias" bool, ] Opts, !, Opts => P. pred get_name i:indt-decl, o:string. get_name (parameter _ _ _ F) N :- pi p\ get_name (F p) N. get_name (inductive N _ _ _) N. get_name (record N _ _ _) N. }}. #[synterp] Elpi Accumulate File derive_synterp_hook. #[synterp] Elpi Accumulate File derive_synterp. #[synterp] Elpi Accumulate lp:{{ main [str TypeName] :- !, with-attributes (derive.main TypeName). main [indt-decl D] :- !, get_name D TypeName, with-attributes (derive.main TypeName). main _. }}. Elpi Accumulate File derive_hook. Elpi Accumulate File derive. Elpi Accumulate lp:{{ main [str I] :- !, coq.locate I GR, with-attributes (derive.main GR _). main [indt-decl D] :- !, get_name D TypeName, with-attributes (derive.decl+main TypeName D). main _ :- usage. usage :- coq.error "Usage: derive \n\tderive Inductive name Params : Arity := Constructors.". }}. Elpi Typecheck. Elpi Export derive. coq-elpi-2.1.0/apps/derive/theories/derive/000077500000000000000000000000001460156013500205455ustar00rootroot00000000000000coq-elpi-2.1.0/apps/derive/theories/derive/bcongr.v000066400000000000000000000040061460156013500222060ustar00rootroot00000000000000(* Generates congruence lemmas using reflect license: GNU Lesser General Public License Version 2.1 or later ------------------------------------------------------------------------- *) From elpi.apps.derive Extra Dependency "injection.elpi" as injection. From elpi.apps.derive Extra Dependency "bcongr.elpi" as bcongr. From elpi.apps.derive Extra Dependency "derive_hook.elpi" as derive_hook. From elpi.apps.derive Extra Dependency "derive_synterp_hook.elpi" as derive_synterp_hook. From Coq Require Export Bool. From elpi Require Export elpi. From elpi.apps Require Export derive. From elpi.apps Require Export derive.projK. Lemma eq_f (T1 : Type) (T2 : Type) (f : T1 -> T2) a b : a = b -> f a = f b. Proof. exact (fun h => eq_rect a (fun x => f a = f x) (eq_refl (f a)) b h). Defined. Register eq_f as elpi.derive.eq_f. Elpi Db derive.bcongr.db lp:{{ type bcongr-db constructor -> term -> prop. :name "bcongr-db:fail" bcongr-db K _ :- M is "derive.bcongr: can't find the boolean congruence for constructor " ^ {std.any->string K}, stop M. }}. (* standalone *) Elpi Command derive.bcongr. Elpi Accumulate File derive_hook. Elpi Accumulate Db derive.bcongr.db. Elpi Accumulate Db derive.projK.db. Elpi Accumulate File injection. Elpi Accumulate File bcongr. Elpi Accumulate lp:{{ main [str I] :- !, coq.locate I (indt GR), coq.gref->id (indt GR) Tname, Prefix is Tname ^ "_", derive.bcongr.main GR Prefix _. main _ :- usage. usage :- coq.error "Usage: derive.bcongr ". }}. Elpi Typecheck. Elpi Typecheck. (* hook into derive *) Elpi Accumulate derive Db derive.bcongr.db. Elpi Accumulate derive File injection. Elpi Accumulate derive File bcongr. #[phases=both] Elpi Accumulate derive lp:{{ dep1 "bcongr" "projK". }}. #[synterp] Elpi Accumulate derive lp:{{ derivation _ _ (derive "bcongr" (cl\ cl = []) true). }}. Elpi Accumulate derive lp:{{ derivation (indt T) N ff (derive "bcongr" (derive.bcongr.main T N) (derive.exists-indc T (K\bcongr-db K _))). }}. coq-elpi-2.1.0/apps/derive/theories/derive/cast.v000066400000000000000000000012441460156013500216670ustar00rootroot00000000000000(* Generates (once and forall) cast operators (trasport). license: GNU Lesser General Public License Version 2.1 or later ------------------------------------------------------------------------- *) From elpi.apps.derive Extra Dependency "cast.elpi" as cast. From elpi Require Export elpi. Elpi Db derive.cast.db lp:{{ type cast-db int -> term -> prop. }}. Elpi Command derive.cast. Elpi Accumulate Db derive.cast.db. Elpi Accumulate File cast. Elpi Accumulate lp:{{ main [int N] :- derive.cast.main N. }}. Elpi Typecheck. Elpi derive.cast 2. Elpi derive.cast 3. Elpi derive.cast 4. Elpi derive.cast 5. Elpi derive.cast 6. Elpi derive.cast 7. coq-elpi-2.1.0/apps/derive/theories/derive/eq.v000066400000000000000000000041421460156013500213420ustar00rootroot00000000000000(* Generates equality tests. license: GNU Lesser General Public License Version 2.1 or later ------------------------------------------------------------------------- *) From elpi.apps.derive Extra Dependency "eq.elpi" as eq. From elpi.apps.derive Extra Dependency "derive_hook.elpi" as derive_hook. From elpi.apps.derive Extra Dependency "derive_synterp_hook.elpi" as derive_synterp_hook. From Coq Require Import Bool. From elpi Require Import elpi. From elpi.apps Require Import derive. From Coq Require Import PrimInt63 PrimFloat. Register Coq.Numbers.Cyclic.Int63.PrimInt63.eqb as elpi.derive.eq_unit63. Register Coq.Floats.PrimFloat.eqb as elpi.derive.eq_float64. Elpi Db derive.eq.db lp:{{ % full resolution (composes with eq functions for parameters) type eq-db term -> term -> term -> prop. eq-db {{ lib:num.int63.type }} {{ lib:num.int63.type }} {{ lib:elpi.derive.eq_unit63 }} :- !. eq-db {{ lib:num.float.type }} {{ lib:num.float.type }} {{ lib:elpi.derive.eq_float64 }} :- !. :name "eq-db:fail" eq-db A B F :- ((whd1 A A1, B1 = B); (whd1 B B1, A1 = A)), !, eq-db A1 B1 F. eq-db A B _ :- M is "derive.eq: can't find the comparison function for terms of type " ^ {coq.term->string A} ^ " and " ^ {coq.term->string B} ^ " respectively", stop M. % quick access type eq-for inductive -> constant -> prop. }}. Elpi Command derive.eq. Elpi Accumulate File derive_hook. Elpi Accumulate Db derive.eq.db. Elpi Accumulate File eq. Elpi Accumulate lp:{{ main [str I, str O] :- !, coq.locate I (indt GR), derive.eq.main GR O _. main [str I] :- !, coq.locate I (indt GR), coq.gref->id (indt GR) Id, O is Id ^ "_eq", derive.eq.main GR O _. main _ :- usage. usage :- coq.error "Usage: derive.eq []". }}. Elpi Typecheck. (* hook into derive *) Elpi Accumulate derive Db derive.eq.db. Elpi Accumulate derive File eq. #[synterp] Elpi Accumulate derive lp:{{ derivation _ _ (derive "eq" (cl\ cl = []) true). }}. Elpi Accumulate derive lp:{{ derivation (indt T) Prefix ff (derive "eq" (derive.eq.main T N) (eq-for T _)) :- N is Prefix ^ "eq". }}. coq-elpi-2.1.0/apps/derive/theories/derive/eqK.v000066400000000000000000000050261460156013500214570ustar00rootroot00000000000000(* Generates a branch of the correctness proof for comparison functions generated by derive.eq. license: GNU Lesser General Public License Version 2.1 or later ------------------------------------------------------------------------- *) From elpi.apps.derive Extra Dependency "discriminate.elpi" as discriminate. From elpi.apps.derive Extra Dependency "eqK.elpi" as eqK. From elpi.apps.derive Extra Dependency "derive_hook.elpi" as derive_hook. From elpi.apps.derive Extra Dependency "derive_synterp_hook.elpi" as derive_synterp_hook. From elpi Require Import elpi. From elpi.apps Require Import derive. From elpi.apps Require Import derive.bcongr derive.eq derive.isK. Definition eq_axiom T eqb := forall (x y : T), Bool.Bool.reflect (x = y) (eqb x y). Definition eq_axiom_at T eqb (x : T) := forall y, Bool.Bool.reflect (x = y) (eqb x y). Definition eq_axiom_on T eqb (x y : T) := Bool.Bool.reflect (x = y) (eqb x y). Register eq_axiom as elpi.derive.eq_axiom. Register eq_axiom_at as elpi.derive.eq_axiom_at. Register eq_axiom_on as elpi.derive.eq_axiom_on. Lemma bool_discr : true = false -> forall T : Type, T. Proof. exact (fun h T => eq_rect true (fun x => match x with false => T | _ => True end) I false h). Qed. Register bool_discr as elpi.bool_discr. Elpi Db derive.eqK.db lp:{{ type eqK-db constructor -> term -> prop. :name "eqK-db:fail" eqK-db K _ :- M is "derive.eqK: can't find the eq.axiom for constructor " ^ {std.any->string K}, stop M. }}. (* standalone *) Elpi Command derive.eqK. Elpi Accumulate File derive_hook. Elpi Accumulate Db derive.isK.db. Elpi Accumulate File discriminate. Elpi Accumulate Db derive.bcongr.db. Elpi Accumulate Db derive.eq.db. Elpi Accumulate Db derive.eqK.db. Elpi Accumulate File eqK. Elpi Accumulate lp:{{ main [str I, str Prefix] :- !, coq.locate I (indt GR), derive.eqK.main GR Prefix _. main [str I] :- !, coq.locate I (indt GR), derive.eqK.main GR "eq_axiom_" _. main _ :- usage. usage :- coq.error "Usage: derive.eqK []". }}. Elpi Typecheck. (* hook into derive *) Elpi Accumulate derive Db derive.eqK.db. Elpi Accumulate derive File discriminate. Elpi Accumulate derive File eqK. #[phases=both] Elpi Accumulate derive lp:{{ dep1 "eqK" "bcongr". dep1 "eqK" "isK". }}. #[synterp] Elpi Accumulate derive lp:{{ derivation _ _ (derive "eqK" (cl\ cl = []) true). }}. Elpi Accumulate derive lp:{{ derivation (indt T) Prefix ff (derive "eqK" (derive.eqK.main T N) (derive.exists-indc T (K\ eqK-db K _))) :- N is Prefix ^ "eq_axiom_". }}. coq-elpi-2.1.0/apps/derive/theories/derive/eqOK.v000066400000000000000000000036761460156013500216070ustar00rootroot00000000000000(* Generates the final, correctness lemma, for equality tests by combinig the output of eqcorrect and param1_inhab. license: GNU Lesser General Public License Version 2.1 or later ------------------------------------------------------------------------- *) From elpi.apps.derive Extra Dependency "paramX_lib.elpi" as paramX. From elpi.apps.derive Extra Dependency "param1.elpi" as param1. From elpi.apps.derive Extra Dependency "eqOK.elpi" as eqOK. From elpi.apps.derive Extra Dependency "derive_hook.elpi" as derive_hook. From elpi.apps.derive Extra Dependency "derive_synterp_hook.elpi" as derive_synterp_hook. From elpi Require Import elpi. From elpi.apps Require Import derive. From elpi.apps Require Import derive.param1 derive.param1_trivial derive.eqK derive.eqcorrect. Elpi Db derive.eqOK.db lp:{{ pred eqOK-done i:inductive. }}. (* standalone *) Elpi Command derive.eqOK. Elpi Accumulate File derive_hook. Elpi Accumulate File paramX. Elpi Accumulate File param1. Elpi Accumulate Db derive.param1.db. Elpi Accumulate Db derive.param1.trivial.db. Elpi Accumulate Db derive.eqcorrect.db. Elpi Accumulate Db derive.eqOK.db. Elpi Accumulate File eqOK. Elpi Accumulate lp:{{ main [str I, str O] :- !, coq.locate I (indt GR), derive.eqOK.main GR O _. main [str I] :- !, coq.locate I (indt GR), Name is {coq.gref->id (indt GR)} ^ "_eq_OK", derive.eqOK.main GR Name _. main _ :- usage. usage :- coq.error "Usage: derive.eqOK []". }}. Elpi Typecheck. (* hook into derive *) Elpi Accumulate derive File eqOK. Elpi Accumulate derive Db derive.eqOK.db. #[phases=both] Elpi Accumulate derive lp:{{ dep1 "eqOK" "eqcorrect". dep1 "eqOK" "param1_trivial". }}. #[synterp] Elpi Accumulate derive lp:{{ derivation _ _ (derive "eqOK" (cl\ cl = []) true). }}. Elpi Accumulate derive lp:{{ derivation (indt T) Prefix ff (derive "eqOK" (derive.eqOK.main T N) (eqOK-done T)) :- N is Prefix ^ "eq_OK". }}. coq-elpi-2.1.0/apps/derive/theories/derive/eqOK_trivial.v000066400000000000000000000030471460156013500233310ustar00rootroot00000000000000(* Draft: trivil eq_axiom (needed for indexes) license: GNU Lesser General Public License Version 2.1 or later ------------------------------------------------------------------------- *) From mathcomp Require Import all_ssreflect. From elpi.apps Require Import elpi. Definition transp {T} (Ctx : T -> Type) {t1 t2} (e : t2 = t1) : Ctx t1 -> Ctx t2. Proof. by case: _/e. Defined. Axiom dep_fun_ext : forall T (P : T -> Type) (f g: forall t:T, P t), (forall x, f x = g x) -> f = g. Lemma reflect_irrelevance (T : eqType) (x y : T) b (p1 p2 : reflect (x = y) b) : p1 = p2. Proof. case: p2 p1 => {b} [e| ne] r. refine (match r as r in reflect _ t return forall p : t = true, r = transp (reflect (x = y)) p (ReflectT (x = y) e) with | ReflectT e' => _ | ReflectF ne' => _ end (erefl true)) => // p {r}. rewrite (eq_irrelevance p (erefl true)) {p}. congr (ReflectT (x = y)). by apply: eq_irrelevance. refine (match r as r in reflect _ t return forall p : t = false, r = transp (reflect (x = y)) p (ReflectF (x = y) ne) with | ReflectT e' => _ | ReflectF ne' => _ end (erefl false)) => // p {r}. rewrite (eq_irrelevance p (erefl false)) {p}. congr (ReflectF (x = y)). apply: dep_fun_ext. by case/ne. Qed. Lemma eq_axiom_trivial (a : eqType) fa : full a (eq_axiom a fa) -> trivial a (eq_axiom a fa). Proof. rewrite /eq_axiom /full. move=> p1 x; exists (p1 x) => p2. apply: dep_fun_ext => w. apply: reflect_irrelevance. Qed. coq-elpi-2.1.0/apps/derive/theories/derive/eqType_ast.v000066400000000000000000000033761460156013500230630ustar00rootroot00000000000000From elpi Require Import elpi. From Coq Require Import PrimInt63 PrimFloat. From elpi.apps Require Import derive. From elpi.apps.derive Extra Dependency "eqType.elpi" as eqType. From elpi.apps.derive Extra Dependency "derive_hook.elpi" as derive_hook. From elpi.apps.derive Extra Dependency "derive_synterp_hook.elpi" as derive_synterp_hook. Elpi Db derive.eqType.db lp:{{ kind arguments type. kind trm type. kind eqType type. kind constructor type. type app gref -> trm -> list trm -> trm. type global gref -> trm. type regular trm -> arguments -> arguments. type irrelevant trm -> arguments -> arguments. type dependent trm -> (trm -> arguments) -> arguments. type stop trm -> arguments. type type-param (trm -> eqType) -> eqType. type value-param trm -> (trm -> eqType) -> eqType. type inductive inductive -> (trm -> list constructor) -> eqType. type constructor constructor -> arguments -> constructor. pred eqType i:inductive, o:eqType. }}. Definition arrow T1 T2 := T1 -> T2. Register arrow as elpi.derive.arrow. Definition apply {T1 T2} (f : T1 -> T2) x := f x. Register apply as elpi.derive.apply. (* standalone *) Elpi Command derive.eqType.ast. Elpi Accumulate File derive_hook. Elpi Accumulate Db derive.eqType.db. Elpi Accumulate File eqType. Elpi Accumulate lp:{{ main [str S] :- std.assert! (coq.locate S (indt I)) "derive.eqType.ast: not an inductive", derive.eqType.ast.main I _. }}. Elpi Typecheck. (* hook into derive *) Elpi Accumulate derive Db derive.eqType.db. Elpi Accumulate derive File eqType. #[synterp] Elpi Accumulate derive lp:{{ derivation _ _ (derive "eqType_ast" (cl\ cl = []) true). }}. Elpi Accumulate derive lp:{{ derivation (indt T) _ ff (derive "eqType_ast" (derive.eqType.ast.main T) (eqType T _)). }}. coq-elpi-2.1.0/apps/derive/theories/derive/eqb.v000066400000000000000000000043031460156013500215030ustar00rootroot00000000000000From elpi Require Import elpi. From elpi.apps Require Import derive derive.param1. From Coq Require Import ssrbool ssreflect Uint63. From Coq Require Import PArith. From elpi.apps.derive Extra Dependency "fields.elpi" as fields. From elpi.apps.derive Extra Dependency "eqb.elpi" as eqb. From elpi.apps.derive Extra Dependency "eqType.elpi" as eqType. From elpi.apps.derive Extra Dependency "derive_hook.elpi" as derive_hook. From elpi.apps.derive Extra Dependency "derive_synterp_hook.elpi" as derive_synterp_hook. Require Import eqb_core_defs. Require Import eqType_ast tag fields. Register eqb_body as elpi.derive.eqb_body. Elpi Db derive.eqb.db lp:{{ pred eqb-done o:gref. pred eqb-for o:term, % type1 o:term, % type2 o:term. % comparison function pred eqb-fields o:term, % type1 o:term, % type2 o:term. % eq_fields_type eqb-for {{ PrimFloat.float }} {{ PrimFloat.float }} {{ PrimFloat.eqb }}. eqb-for {{ PrimInt63.int }} {{ PrimInt63.int }} {{ PrimInt63.eqb }}. :name "eqb-for:whd" eqb-for T1 T2 X :- whd1 T1 T1', !, eqb-for T1' T2 X. eqb-for T1 T2 X :- whd1 T2 T2', !, eqb-for T1 T2' X. }}. (* standalone *) Elpi Command derive.eqb. Elpi Accumulate File derive_hook. Elpi Accumulate Db derive.tag.db. Elpi Accumulate Db derive.eqType.db. Elpi Accumulate Db derive.fields.db. Elpi Accumulate Db derive.eqb.db. Elpi Accumulate File fields. Elpi Accumulate File eqb. Elpi Accumulate File eqType. Elpi Accumulate lp:{{ main [str I] :- !, coq.locate I GR, coq.gref->id GR Tname, Prefix is Tname ^ "_", derive.eqb.main GR Prefix _. main _ :- usage. usage :- coq.error "Usage: derive.eqb ". }}. Elpi Typecheck. (* hook into derive *) Elpi Accumulate derive Db derive.eqb.db. Elpi Accumulate derive File eqb. #[phases=both] Elpi Accumulate derive lp:{{ dep1 "eqb" "fields". }}. #[synterp] Elpi Accumulate derive lp:{{ derivation _ _ (derive "eqb" (cl\ cl = []) true). }}. Elpi Accumulate derive lp:{{ derivation (indt T) Prefix ff (derive "eqb" (derive.eqb.main (indt T) Prefix) (eqb-done (indt T))). derivation (const C) Prefix ff (derive "eqb-alias" (derive.eqb.main (const C) Prefix) (eqb-done (const C))). }}. coq-elpi-2.1.0/apps/derive/theories/derive/eqbOK.v000066400000000000000000000034151460156013500217400ustar00rootroot00000000000000(* Generates soudness proofs given correctness and reflexivity. license: GNU Lesser General Public License Version 2.1 or later ------------------------------------------------------------------------- *) Require Import eqb_core_defs. Require Import tag eqType_ast fields eqb eqbcorrect derive. From elpi.apps.derive Extra Dependency "eqbOK.elpi" as eqbOK. From elpi.apps.derive Extra Dependency "eqType.elpi" as eqType. From elpi.apps.derive Extra Dependency "derive_hook.elpi" as derive_hook. From elpi.apps.derive Extra Dependency "derive_synterp_hook.elpi" as derive_synterp_hook. Elpi Db derive.eqbOK.db lp:{{ pred eqbok-for o:gref, o:constant. }}. (* standalone *) Elpi Command derive.eqbOK. Elpi Accumulate File derive_hook. Elpi Accumulate Db derive.eqb.db. Elpi Accumulate Db derive.eqbcorrect.db. Elpi Accumulate Db derive.eqType.db. Elpi Accumulate Db derive.eqbOK.db. Elpi Accumulate File eqbOK. Elpi Accumulate File eqType. Elpi Accumulate lp:{{ main [str I] :- !, coq.locate I GR, coq.gref->id GR Tname, Prefix is Tname ^ "_", derive.eqbOK.main GR Prefix _. main _ :- usage. usage :- coq.error "Usage: derive.eqbOK ". }}. Elpi Typecheck. (* hook into derive *) Elpi Accumulate derive File eqbOK. Elpi Accumulate derive Db derive.eqbOK.db. #[phases=both] Elpi Accumulate derive lp:{{ dep1 "eqbOK" "eqbcorrect". dep1 "eqbOK-alias" "eqbcorrect-alias". }}. #[synterp] Elpi Accumulate derive lp:{{ derivation _ _ (derive "eqbOK" (cl\ cl = []) true). }}. Elpi Accumulate derive lp:{{ derivation (indt T) Prefix ff (derive "eqbOK" (derive.eqbOK.main (indt T) Prefix) (eqbok-for (indt T) _)). derivation (const T) Prefix ff (derive "eqbOK-alias" (derive.eqbOK.main (const T) Prefix) (eqbok-for (const T) _)). }}. coq-elpi-2.1.0/apps/derive/theories/derive/eqb_core_defs.v000066400000000000000000000103311460156013500235120ustar00rootroot00000000000000Require Import Eqdep_dec. Require Import PArith. Require Import ssreflect ssrbool. Set Implicit Arguments. Unset Strict Implicit. Unset Printing Implicit Defensive. Open Scope positive_scope. Section Section. Context {A:Type}. Definition eqb_correct_on (eqb : A -> A -> bool) (a1:A) := forall a2, eqb a1 a2 -> a1 = a2. Definition eqb_refl_on (eqb : A -> A -> bool) (a:A) := is_true (eqb a a). Definition eqb_correct (eqb : A -> A -> bool) := forall (a1:A), eqb_correct_on eqb a1. Definition eqb_reflexive (eqb : A -> A -> bool) := forall (a:A), eqb_refl_on eqb a. Lemma iffP2 (f : A -> A -> bool) (H1 : eqb_correct f) (H2 : eqb_reflexive f) (x1 x2 : A) : reflect (x1 = x2) (f x1 x2). Proof. apply (iffP idP);[ apply H1 | move->; apply H2 ]. Qed. Definition eqax_on (eqb : A -> A -> bool) (a1:A) := forall a2, reflect (a1 = a2) (eqb a1 a2). End Section. Section Section. Context {A B:Type}. Variable tagA : A -> positive. Variable tagB : B -> positive. Variable fields_tA : positive -> Type. Variable fields_tB : positive -> Type. Variable fieldsA : forall a, fields_tA (tagA a). Variable fieldsB : forall a, fields_tB (tagB a). Variable constructA : forall t, fields_tA t -> option A. Variable constructB : forall t, fields_tB t -> option B. Variable constructPA : forall a, constructA (fieldsA a) = Some a. Variable constructPB : forall a, constructB (fieldsB a) = Some a. Variable eqb_fields : forall t, fields_tA t -> fields_tB t -> bool. Definition eqb_body (t1:positive) (f1:fields_tA t1) (x2:B) := let t2 := tagB x2 in match Pos.eq_dec t2 t1 with | left heq => let f2 : fields_tB t2 := fieldsB x2 in @eqb_fields t1 f1 (match heq with eq_refl => f2 end) | right _ => false end. #[global] Arguments eqb_body _ _ _ /. End Section. Section Section. Context {A:Type}. Variable tag : A -> positive. Variable fields_t : positive -> Type. Variable fields : forall a, fields_t (tag a). Variable construct : forall t, fields_t t -> option A. Variable constructP : forall a, construct (fields a) = Some a. Variable eqb_fields : forall t, fields_t t -> fields_t t -> bool. Definition eqb_fields_correct_on (a:A) := forall f : fields_t (tag a), eqb_fields (fields a) f -> Some a = construct f. Lemma eqb_body_correct a1 : eqb_fields_correct_on a1 -> forall a2, eqb_body fields eqb_fields (fields a1) a2 -> a1 = a2. Proof. move=> hf a2 hb. suff : Some a1 = Some a2 by move=> [->]. rewrite -(constructP a2); move: hb; rewrite /eqb_body. case: Pos.eq_dec => // heq. move: (tag a2) heq (fields a2) => t2 ?; subst t2 => f2 /=; apply hf. Qed. Definition eqb_fields_refl_on (a:A) := eqb_fields (fields a) (fields a). Lemma eqb_body_refl a : eqb_fields_refl_on a -> eqb_body fields eqb_fields (fields a) a. Proof. pose h := constructP. (* dummy dependence to have the same type as eqb_body_correct *) rewrite /eqb_body => hf. case: Pos.eq_dec => // heq. have -> /= := Eqdep_dec.UIP_dec Pos.eq_dec heq eq_refl; apply hf. Qed. Inductive blist := bnil | bcons (b : bool) (bs : blist). Fixpoint eqb_refl_statement (acc : bool) (l : blist) {struct l} := match l with | bnil => acc = true | bcons b bs => b = true -> eqb_refl_statement (b && acc) bs end. Lemma eqb_refl_statementP l : eqb_refl_statement true l. Proof. elim: l => //= b l hrec ->; apply hrec. Qed. Fixpoint implies (l : blist) (P : Prop) : Prop := match l with | bnil => P | bcons b bs => b = true -> implies bs P end. Fixpoint allr (l : blist) := match l with | bnil => true | bcons b bs => b && allr bs end. Lemma impliesP (l:blist) (P:Prop) : implies l P -> allr l = true -> P. Proof. by elim: l => //= b l hrec hall /andP[/hall]. Qed. Inductive tlist := tnil | tcons (T : Type) (TS : tlist). Fixpoint p_type (T : tlist) := match T with | tnil => Prop | tcons T Ts => T -> p_type Ts end. Fixpoint eq_ind_r_n (T : tlist) : p_type T -> p_type T -> Prop := match T return p_type T -> p_type T -> Prop with | tnil => fun p q => p -> q | tcons T Ts => fun p q => forall (x y : T), x = y -> @eq_ind_r_n Ts (p x) (q y) end. Lemma eq_ind_r_nP (T : tlist) (p : p_type T) : @eq_ind_r_n T p p. Proof. elim: T p => //= T Ts hrec f a1 a2 ->; apply hrec. Qed. End Section. coq-elpi-2.1.0/apps/derive/theories/derive/eqbcorrect.v000066400000000000000000000071561460156013500230760ustar00rootroot00000000000000From Coq Require Import ssreflect ssrfun ssrbool Eqdep_dec. From elpi Require Import elpi. From elpi.apps Require Import derive. From elpi.apps.derive Require Import induction param1_functor param1_trivial eqb_core_defs tag fields eqb. From elpi.apps.derive Extra Dependency "paramX_lib.elpi" as paramX. From elpi.apps.derive Extra Dependency "param1.elpi" as param1. From elpi.apps.derive Extra Dependency "eqType.elpi" as eqType. From elpi.apps.derive Extra Dependency "eqbcorrect.elpi" as eqbcorrect. From elpi.apps.derive Extra Dependency "derive_hook.elpi" as derive_hook. From elpi.apps.derive Extra Dependency "derive_synterp_hook.elpi" as derive_synterp_hook. Module Export exports. Export ssreflect ssrbool eqb_core_defs. (* go ask the ltac gurus... *) Ltac solver_regular_or_dependent := match reverse goal with | View : @eqb_correct_on _ ?f ?y |- is_true (?f ?y ?x && _) -> _ => case/andP => /View => ? {View}; subst x end. Ltac solver_irrelevant := match goal with | p1 : ?x = true , p2 : ?x = true |- _ => let top := fresh "x" in have top := @Eqdep_dec.UIP_dec bool Bool.bool_dec _ _ p1 p2; subst p1 end. Ltac eqb_correct_on__solver := let x := fresh "x" in case=> [^ x] /=; by repeat (solver_regular_or_dependent || solver_irrelevant). Ltac eqb_refl_on__solver := by rewrite /eqb_fields_refl_on /=; repeat ((apply /andP; split) || reflexivity || assumption). End exports. Lemma uint63_eqb_correct i : eqb_correct_on PrimInt63.eqb i. Proof. by move=> j; case: (Uint63.eqb_spec i j); case: PrimInt63.eqb. Qed. Lemma uint63_eqb_refl i : eqb_refl_on PrimInt63.eqb i. Proof. by case: (Uint63.eqb_spec i i) => _ H; exact: H. Qed. Elpi Db derive.eqbcorrect.db lp:{{ pred eqcorrect-for o:gref, o:constant, % correct o:constant. % reflexive eqcorrect-for {{:gref PrimInt63.int }} C R :- {{:gref uint63_eqb_correct}} = const C, {{:gref uint63_eqb_refl}} = const R. :index(2) pred correct-lemma-for i:term, o:term. correct-lemma-for {{ PrimInt63.int }} {{ @uint63_eqb_correct }}. :index(2) pred refl-lemma-for i:term, o:term. refl-lemma-for {{ PrimInt63.int }} {{ @uint63_eqb_refl }}. }}. (* standalone *) Elpi Command derive.eqbcorrect. Elpi Accumulate File derive_hook. Elpi Accumulate Db derive.eqType.db. Elpi Accumulate Db derive.tag.db. Elpi Accumulate Db derive.eqb.db. Elpi Accumulate Db derive.fields.db. Elpi Accumulate Db derive.eqbcorrect.db. Elpi Accumulate Db derive.induction.db. Elpi Accumulate Db derive.param1.trivial.db. Elpi Accumulate Db derive.param1.functor.db. Elpi Accumulate File eqbcorrect. Elpi Accumulate File paramX. Elpi Accumulate File param1. Elpi Accumulate File eqType. Elpi Accumulate Db derive.param1.db. Elpi Accumulate lp:{{ main [str I] :- !, coq.locate I GR, coq.gref->id GR Tname, Prefix is Tname ^ "_", derive.eqbcorrect.main GR Prefix _. main _ :- usage. usage :- coq.error "Usage: derive.eqbcorrect ". }}. Elpi Typecheck. (* hook into derive *) Elpi Accumulate derive File eqbcorrect. Elpi Accumulate derive Db derive.eqbcorrect.db. #[phases=both] Elpi Accumulate derive lp:{{ dep1 "eqbcorrect" "eqb". dep1 "eqbcorrect" "induction". dep1 "eqbcorrect" "param1_inhab". dep1 "eqbcorrect-alias" "eqb-alias". }}. #[synterp] Elpi Accumulate derive lp:{{ derivation _ _ (derive "eqbcorrect" (cl\ cl = []) true). }}. Elpi Accumulate derive lp:{{ derivation (indt T) Prefix ff (derive "eqbcorrect" (derive.eqbcorrect.main (indt T) Prefix) (eqcorrect-for (indt T) _ _)). derivation (const C) Prefix ff (derive "eqbcorrect-alias" (derive.eqbcorrect.main (const C) Prefix) (eqcorrect-for (const C) _ _)). }}. coq-elpi-2.1.0/apps/derive/theories/derive/eqcorrect.v000066400000000000000000000052061460156013500227260ustar00rootroot00000000000000(* Generates correctness proofs for comparison functions generated by derive.eq. license: GNU Lesser General Public License Version 2.1 or later ------------------------------------------------------------------------- *) From elpi.apps.derive Extra Dependency "eqcorrect.elpi" as eqcorrect. From elpi.apps.derive Extra Dependency "derive_hook.elpi" as derive_hook. From elpi.apps.derive Extra Dependency "derive_synterp_hook.elpi" as derive_synterp_hook. From elpi Require Import elpi. From elpi.apps Require Import derive. From elpi.apps Require Import derive.eq derive.induction derive.eqK derive.param1. From Coq Require Import ssreflect Uint63. Lemma uint63_eq_correct i : is_uint63 i -> eq_axiom_at PrimInt63.int PrimInt63.eqb i. Proof. move=> _ j; case: (Uint63.eqb_spec i j); case: PrimInt63.eqb => [-> // _|_ abs]; [ by constructor | by constructor=> /abs ]. Qed. Register uint63_eq_correct as elpi.derive.uint63_eq_correct. Elpi Db derive.eqcorrect.db lp:{{ type eqcorrect-db gref -> term -> prop. eqcorrect-db X {{ lib:elpi.derive.uint63_eq_correct }} :- {{ lib:num.int63.type }} = global X, !. eqcorrect-db X _ :- {{ lib:num.float.type }} = global X, !, stop "float64 comparison is not syntactic". :name "eqcorrect-db:fail" eqcorrect-db T _ :- M is "derive.eqcorrect: can't find the correctness proof for the comparison function on " ^ {coq.gref->string T}, stop M. }}. (* standalone *) Elpi Command derive.eqcorrect. Elpi Accumulate Db derive.param1.db. (* TODO: understand which other db needs this *) Elpi Accumulate Db derive.induction.db. Elpi Accumulate Db derive.param1.functor.db. Elpi Accumulate Db derive.eq.db. Elpi Accumulate Db derive.eqK.db. Elpi Accumulate Db derive.eqcorrect.db. Elpi Accumulate File eqcorrect. Elpi Accumulate lp:{{ main [str I, str Name] :- !, coq.locate I (indt GR), derive.eqcorrect.main GR Name _. main [str I] :- !, coq.locate I (indt GR), coq.gref->id (indt GR) ID, Name is ID ^ "_eq_correct", derive.eqcorrect.main GR Name _. main _ :- usage. usage :- coq.error "Usage: derive.eqcorrect []". }}. Elpi Typecheck. (* hook into derive *) Elpi Accumulate derive File derive_hook. Elpi Accumulate derive File eqcorrect. Elpi Accumulate derive Db derive.eqcorrect.db. #[phases=both] Elpi Accumulate derive lp:{{ dep1 "eqcorrect" "induction". dep1 "eqcorrect" "eq". dep1 "eqcorrect" "eqK". }}. #[synterp] Elpi Accumulate derive lp:{{ derivation _ _ (derive "eqcorrect" (cl\ cl = []) true). }}. Elpi Accumulate derive lp:{{ derivation (indt T) Prefix ff (derive "eqcorrect" (derive.eqcorrect.main T N) (eqcorrect-db (indt T) _)) :- N is Prefix ^ "eq_correct". }}. coq-elpi-2.1.0/apps/derive/theories/derive/experimental.v000066400000000000000000000004661460156013500234370ustar00rootroot00000000000000(* Experimental set of derivations license: GNU Lesser General Public License Version 2.1 or later ------------------------------------------------------------------------- *) From elpi.apps Require Export derive. From elpi.apps Require Export derive.invert derive.idx2inv . Elpi Typecheck derive. coq-elpi-2.1.0/apps/derive/theories/derive/fields.v000066400000000000000000000035151460156013500222060ustar00rootroot00000000000000From elpi Require Import elpi. From elpi.apps Require Import derive. From Coq Require Import PArith. From elpi.apps Require Export derive.eqType_ast derive.tag. From elpi.apps.derive Extra Dependency "fields.elpi" as fields. From elpi.apps.derive Extra Dependency "eqType.elpi" as eqType. From elpi.apps.derive Extra Dependency "derive_hook.elpi" as derive_hook. From elpi.apps.derive Extra Dependency "derive_synterp_hook.elpi" as derive_synterp_hook. Register unit as elpi.derive.unit. Local Open Scope positive_scope. Elpi Db derive.fields.db lp:{{ % this is how one registers the fields_t, fields and construct[P] % constants to an inductive and let other elpi commands use that piece of info pred fields-for o:inductive, o:constant, % fields_t o:constant, % fields o:constant, % construct o:constant. % constructP pred box-for o:constructor, o:inductive, o:constructor. }}. (* standalone *) Elpi Command derive.fields. Elpi Accumulate File derive_hook. Elpi Accumulate File fields. Elpi Accumulate File eqType. Elpi Accumulate Db derive.eqType.db. Elpi Accumulate Db derive.tag.db. Elpi Accumulate Db derive.fields.db. Elpi Accumulate lp:{{ main [str I] :- !, coq.locate I (indt GR), coq.gref->id (indt GR) Tname, Prefix is Tname ^ "_", derive.fields.main GR Prefix _. main _ :- usage. usage :- coq.error "Usage: derive.fields []". }}. Elpi Typecheck. (* hook into derive *) Elpi Accumulate derive File fields. Elpi Accumulate derive Db derive.fields.db. #[phases=both] Elpi Accumulate derive lp:{{ dep1 "fields" "tag". dep1 "fields" "eqType_ast". }}. #[synterp] Elpi Accumulate derive lp:{{ derivation _ _ (derive "fields" (cl\ cl = []) true). }}. Elpi Accumulate derive lp:{{ derivation (indt T) Prefix ff (derive "fields" (derive.fields.main T Prefix) (fields-for T _ _ _ _)). }}. coq-elpi-2.1.0/apps/derive/theories/derive/idx2inv.v000066400000000000000000000037161460156013500223260ustar00rootroot00000000000000(* Generates lemmas linking an inductive with indexes and its structural copy without indexes but equations instead. license: GNU Lesser General Public License Version 2.1 or later ------------------------------------------------------------------------- *) From elpi.apps.derive Extra Dependency "paramX_lib.elpi" as paramX. From elpi.apps.derive Extra Dependency "param1_functor.elpi" as param1_functor. From elpi.apps.derive Extra Dependency "idx2inv.elpi" as idx2inv. From elpi.apps.derive Extra Dependency "derive_hook.elpi" as derive_hook. From elpi.apps.derive Extra Dependency "derive_synterp_hook.elpi" as derive_synterp_hook. From elpi Require Export elpi. From elpi.apps Require Export derive. From elpi.apps Require Export derive.param1 derive.param1_functor derive.invert. Elpi Db derive.idx2inv.db lp:{{ type idx2inv-db inductive -> inductive -> constant -> constant -> prop. }}. (* standalone *) Elpi Command derive.idx2inv. Elpi Accumulate File derive_hook. Elpi Accumulate File paramX. Elpi Accumulate Db derive.param1.db. Elpi Accumulate Db derive.param1.functor.db. Elpi Accumulate File param1_functor. Elpi Accumulate Db derive.invert.db. Elpi Accumulate Db derive.idx2inv.db. Elpi Accumulate File idx2inv. Elpi Accumulate lp:{{ main [str I, str O] :- !, coq.locate I (indt GR), derive.idx2inv.main GR O _. main [str I] :- !, coq.locate I (indt GR), derive.idx2inv.main GR "_to_" _. main _ :- usage. usage :- coq.error "Usage: derive.idx2inv []". }}. Elpi Typecheck. (* hook into derive *) Elpi Accumulate derive Db derive.idx2inv.db. Elpi Accumulate derive File idx2inv. Elpi Accumulate File paramX. #[phases=both] Elpi Accumulate derive lp:{{ dep1 "idx2inv" "invert". }}. #[synterp] Elpi Accumulate derive lp:{{ derivation _ _ (derive "idx2inv" (cl\ cl = []) true). }}. Elpi Accumulate derive lp:{{ derivation (indt T) _ ff (derive "idx2inv" (derive.idx2inv.main T "_to_") (idx2inv-db T _ _ _)). }}. coq-elpi-2.1.0/apps/derive/theories/derive/induction.v000066400000000000000000000035321460156013500227330ustar00rootroot00000000000000(* Generates the induction principle. license: GNU Lesser General Public License Version 2.1 or later ------------------------------------------------------------------------- *) From elpi.apps.derive Extra Dependency "paramX_lib.elpi" as paramX. From elpi.apps.derive Extra Dependency "param1.elpi" as param1. From elpi.apps.derive Extra Dependency "induction.elpi" as induction. From elpi.apps.derive Extra Dependency "derive_hook.elpi" as derive_hook. From elpi.apps.derive Extra Dependency "derive_synterp_hook.elpi" as derive_synterp_hook. From elpi Require Import elpi. From elpi.apps Require Import derive derive.param1 derive.param1_functor. Elpi Db derive.induction.db lp:{{ pred induction-db i:inductive, o:term. :name "induction-db:fail" induction-db T _ :- M is "derive.induction: can't find the induction principle for " ^ {std.any->string T}, stop M. }}. (* standalone *) Elpi Command derive.induction. Elpi Accumulate File derive_hook. Elpi Accumulate File paramX. Elpi Accumulate File param1. Elpi Accumulate Db derive.param1.db. Elpi Accumulate Db derive.param1.functor.db. Elpi Accumulate Db derive.induction.db. Elpi Accumulate File induction. Elpi Accumulate lp:{{ main [str I] :- !, coq.locate I (indt GR), Name is {coq.gref->id (indt GR)} ^ "_", derive.induction.main GR Name _. main _ :- usage. usage :- coq.error "Usage: derive.induction ". }}. Elpi Typecheck. (* hook into derive *) Elpi Accumulate derive File induction. Elpi Accumulate derive Db derive.induction.db. #[phases=both] Elpi Accumulate derive lp:{{ dep1 "induction" "param1_functor". }}. #[synterp] Elpi Accumulate derive lp:{{ derivation _ _ (derive "induction" (cl\ cl = []) true). }}. Elpi Accumulate derive lp:{{ derivation (indt T) N ff (derive "induction" (derive.induction.main T N) (induction-db T _)). }}. coq-elpi-2.1.0/apps/derive/theories/derive/invert.v000066400000000000000000000025501460156013500222450ustar00rootroot00000000000000(* Generates inversion lemmas by encoding indexes with equations and non uniform parameters. license: GNU Lesser General Public License Version 2.1 or later ------------------------------------------------------------------------- *) From elpi.apps.derive Extra Dependency "invert.elpi" as invert. From elpi.apps.derive Extra Dependency "derive_hook.elpi" as derive_hook. From elpi.apps.derive Extra Dependency "derive_synterp_hook.elpi" as derive_synterp_hook. From elpi Require Export elpi. From elpi.apps Require Export derive. Elpi Db derive.invert.db lp:{{ type invert-db gref -> gref -> prop. }}. Elpi Command derive.invert. Elpi Accumulate Db derive.invert.db. Elpi Accumulate File invert. Elpi Accumulate lp:{{ main [str I, str O] :- !, coq.locate I (indt GR), derive.invert.main GR O _. main [str I] :- !, coq.locate I (indt GR), derive.invert.main GR "_inv" _. main _ :- usage. usage :- coq.error "Usage: derive.invert []". }}. Elpi Typecheck. (* hook into derive *) Elpi Accumulate derive File invert. Elpi Accumulate derive Db derive.invert.db. #[synterp] Elpi Accumulate derive lp:{{ derivation _ _ (derive "invert" (cl\ cl = []) true). }}. Elpi Accumulate derive lp:{{ derivation (indt T) Prefix ff (derive "invert" (derive.invert.main T N) (invert-db (indt T) _)) :- N is Prefix ^ "inv". }}. coq-elpi-2.1.0/apps/derive/theories/derive/isK.v000066400000000000000000000032541460156013500214660ustar00rootroot00000000000000(* For each constructor K the function isK returns true iff it is applied to K. These helpers are use to implement "discriminate". license: GNU Lesser General Public License Version 2.1 or later ------------------------------------------------------------------------- *) From elpi.apps.derive Extra Dependency "isK.elpi" as isK. From elpi.apps.derive Extra Dependency "derive_hook.elpi" as derive_hook. From elpi.apps.derive Extra Dependency "derive_synterp_hook.elpi" as derive_synterp_hook. From elpi Require Import elpi. From elpi.apps Require Import derive. (* Links the @gref of the constructor K to the isK constant *) Elpi Db derive.isK.db lp:{{ type isK-db constructor -> term -> prop. :name "isK-db:fail" isK-db K _ :- M is "No isK entry for constructor " ^ {std.any->string K} ^ ". Did you run derive.isK?", stop M. }}. Elpi Command derive.isK. Elpi Accumulate File derive_hook. Elpi Accumulate Db derive.isK.db. Elpi Accumulate File isK. Elpi Accumulate lp:{{ main [str I,str O] :- !, coq.locate I (indt GR), derive.isK.main GR O _. main [str I] :- !, coq.locate I (indt GR), Prefix is {coq.gref->id (indt GR)} ^ "_is_", derive.isK.main GR Prefix _. main _ :- usage. usage :- coq.error "Usage: derive.isK []". }}. Elpi Typecheck. (* hook into derive *) Elpi Accumulate derive Db derive.isK.db. Elpi Accumulate derive File isK. #[synterp] Elpi Accumulate derive lp:{{ derivation _ _ (derive "isK" (cl\ cl = []) true). }}. Elpi Accumulate derive lp:{{ derivation (indt T) Prefix ff (derive "isK" (derive.isK.main T N) (derive.exists-indc T (K\ isK-db K _))) :- N is Prefix ^ "isk_". }}. coq-elpi-2.1.0/apps/derive/theories/derive/legacy.v000066400000000000000000000005421460156013500222010ustar00rootroot00000000000000(* Legacy set of derivations license: GNU Lesser General Public License Version 2.1 or later ------------------------------------------------------------------------- *) From elpi.apps Require Export derive. From elpi.apps Require Export derive.projK derive.isK derive.eq derive.eqK derive.bcongr derive.eqOK . Elpi Typecheck derive. coq-elpi-2.1.0/apps/derive/theories/derive/lens.v000066400000000000000000000036041460156013500217000ustar00rootroot00000000000000(* A lens, to see better. license: GNU Lesser General Public License Version 2.1 or later ------------------------------------------------------------------------- *) From elpi.apps.derive Extra Dependency "lens.elpi" as lens. From elpi.apps.derive Extra Dependency "derive_hook.elpi" as derive_hook. From elpi.apps.derive Extra Dependency "derive_synterp_hook.elpi" as derive_synterp_hook. From elpi Require Import elpi. From elpi.apps Require Import derive. (* Coq stdlib has no lens data type so we declare one here. To override with your own "copy", use Register as below *) Local Set Primitive Projections. Record Lens (a b c d : Type) : Type := mkLens { view : a -> c ; over : (c -> d) -> a -> b }. Register mkLens as elpi.derive.lens.make. Arguments view {_ _ _ _} _ _. Arguments over {_ _ _ _} _ _ _. Definition set {a b c d} (l : Lens a b c d) new := over l (fun _ => new). Register set as elpi.derive.lens.set. Register view as elpi.derive.lens.view. (* Links the record, a field name and the lens focusing on that field *) Elpi Db derive.lens.db lp:{{ pred lens-db o:inductive, o:string, o:constant. }}. (* standalone command *) Elpi Command derive.lens. Elpi Accumulate File derive_hook. Elpi Accumulate File lens. Elpi Accumulate Db derive.lens.db. Elpi Accumulate lp:{{ main [str I, str O] :- !, coq.locate I (indt GR), derive.lens.main GR O _. main [str I] :- !, coq.locate I (indt GR), derive.lens.main GR "_" _. main _ :- usage. usage :- coq.error "Usage: derive.lens []". }}. Elpi Typecheck. (* hook into derive *) Elpi Accumulate derive Db derive.lens.db. Elpi Accumulate derive File lens. #[synterp] Elpi Accumulate derive lp:{{ derivation _ _ (derive "lens" (cl\ cl = []) true). }}. Elpi Accumulate derive lp:{{ derivation (indt T) Prefix ff (derive "lens" (derive.lens.main T N) (lens-db T _ _)) :- N is Prefix ^ "_". }}. coq-elpi-2.1.0/apps/derive/theories/derive/lens_laws.v000066400000000000000000000051371460156013500227310ustar00rootroot00000000000000(* Equations for lenses license: GNU Lesser General Public License Version 2.1 or later ------------------------------------------------------------------------- *) From elpi.apps.derive Extra Dependency "lens_laws.elpi" as lens_laws. From elpi.apps.derive Extra Dependency "derive_hook.elpi" as derive_hook. From elpi.apps.derive Extra Dependency "derive_synterp_hook.elpi" as derive_synterp_hook. From elpi Require Import elpi. From elpi.apps Require Import derive.lens. Definition view_set_on {a c} (l : Lens a a c c) r := forall x, view l (set l x r) = x. Definition view_set {a c} (l : Lens a a c c) := forall r, view_set_on l r. Definition set_set_on {a c d} (l : Lens a a c d) r := forall x y, set l y (set l x r) = set l y r. Definition set_set {a c d} (l : Lens a a c d) := forall r, set_set_on l r. Definition set_view_on {a c} (l : Lens a a c c) r := set l (view l r) r = r. Definition set_view {a c} (l : Lens a a c c) := forall r, set_view_on l r. Definition exchange_on {a b d e f} (l1 : Lens a a b d) (l2 : Lens a a e f) r := forall x y, set l1 x (set l2 y r) = set l2 y (set l1 x r). Definition exchange {a b d e f} (l1 : Lens a a b d) (l2 : Lens a a e f) := forall r, exchange_on l1 l2 r. Register view_set as elpi.derive.lens.view_set. Register view_set_on as elpi.derive.lens.view_set_on. Register set_set as elpi.derive.lens.set_set. Register set_set_on as elpi.derive.lens.set_set_on. Register set_view as elpi.derive.lens.set_view. Register set_view_on as elpi.derive.lens.set_view_on. Register exchange as elpi.derive.lens.exchange. Register exchange_on as elpi.derive.lens.exchange_on. Elpi Db derive.lens_laws.db lp:{{ pred lens-laws-done i:inductive. }}. (* standalone *) Elpi Command derive.lens_laws. Elpi Accumulate File derive_hook. Elpi Accumulate File lens_laws. Elpi Accumulate Db derive.lens.db. Elpi Accumulate Db derive.lens_laws.db. Elpi Accumulate lp:{{ main [str I, str O] :- !, coq.locate I (indt GR), derive.lens-laws.main GR O _. main [str I] :- !, coq.locate I (indt GR), derive.lens-laws.main GR "_" _. main _ :- usage. usage :- coq.error "Usage: derive.lens_laws []". }}. Elpi Typecheck. (* hook into derive *) Elpi Accumulate derive File lens_laws. Elpi Accumulate derive Db derive.lens_laws.db. #[phases=both] Elpi Accumulate derive lp:{{ dep1 "lens_laws" "lens". }}. #[synterp] Elpi Accumulate derive lp:{{ derivation _ _ (derive "lens_laws" (cl\ cl = []) true). }}. Elpi Accumulate derive lp:{{ derivation (indt T) Prefix ff (derive "lens_laws" (derive.lens-laws.main T N) (lens-laws-done T)) :- N is Prefix ^ "_". }}. coq-elpi-2.1.0/apps/derive/theories/derive/map.v000066400000000000000000000026501460156013500215140ustar00rootroot00000000000000(* A map over a container. For non containers it produces the copy function. license: GNU Lesser General Public License Version 2.1 or later ------------------------------------------------------------------------- *) From elpi.apps.derive Extra Dependency "map.elpi" as map. From elpi.apps.derive Extra Dependency "derive_hook.elpi" as derive_hook. From elpi.apps.derive Extra Dependency "derive_synterp_hook.elpi" as derive_synterp_hook. From elpi Require Import elpi. From elpi.apps Require Import derive. (* Links the source and target type with the corresponding map function, eg. "map-db (list A) (list B) (list_map f_A_B)" *) Elpi Db derive.map.db lp:{{ pred map-done i:inductive. pred map-db i:term, i:term, o:term. }}. (* standalone command *) Elpi Command derive.map. Elpi Accumulate File derive_hook. Elpi Accumulate Db derive.map.db. Elpi Accumulate File map. Elpi Accumulate lp:{{ main [str I] :- !, coq.locate I (indt GR), O is {coq.gref->id (indt GR)} ^ "_", derive.map.main GR O _. main _ :- usage. usage :- coq.error "Usage: derive.map ". }}. Elpi Typecheck. (* hook into derive *) Elpi Accumulate derive Db derive.map.db. Elpi Accumulate derive File map. #[synterp] Elpi Accumulate derive lp:{{ derivation _ _ (derive "map" (cl\ cl = []) true). }}. Elpi Accumulate derive lp:{{ derivation (indt T) N ff (derive "map" (derive.map.main T N) (map-done T)). }}. coq-elpi-2.1.0/apps/derive/theories/derive/param1.v000066400000000000000000000072171460156013500221240ustar00rootroot00000000000000(* Unary parametricity translation. license: GNU Lesser General Public License Version 2.1 or later ------------------------------------------------------------------------- *) From elpi.apps.derive Extra Dependency "paramX_lib.elpi" as paramX. From elpi.apps.derive Extra Dependency "param1.elpi" as param1. From elpi.apps.derive Extra Dependency "derive_hook.elpi" as derive_hook. From elpi.apps.derive Extra Dependency "derive_synterp_hook.elpi" as derive_synterp_hook. From elpi Require Import elpi. From elpi.apps Require Import derive. Definition contractible T := { x : T & forall y, @eq T x y }. Register contractible as elpi.derive.contractible. Definition contracts T P (x : T) w u := (@existT (P x) (fun u : P x => forall v : P x,@eq (P x) u v) w u). Register contracts as elpi.derive.contracts. Definition full T P := forall x : T, P x. Register full as elpi.derive.full. Definition trivial T P := forall x : T, contractible (P x). Register trivial as elpi.derive.trivial. Definition trivial_full T P (e : trivial T P) (x : T) : P x := projT1 (e x). Register trivial_full as elpi.derive.trivial_full. Definition trivial_uniq T P (e : trivial T P) (x : T) (p : P x) : trivial_full T P e x = p := projT2 (e x) p. Register trivial_uniq as elpi.derive.trivial_uniq. (* To be removed. Like the param1-db below, but readable from Coq *) Class reali_db {X XR : Type} (x : X) (xR : XR) := store_reali {}. Class reali {X : Type} {XR : X -> Type} (x : X) (xR : XR x) := Reali {}. Register store_reali as param1.store_reali. From Coq Require Import PrimInt63 PrimFloat. Inductive is_uint63 : PrimInt63.int -> Type := uint63 (i : PrimInt63.int) : is_uint63 i. Register is_uint63 as elpi.derive.is_uint63. Inductive is_float64 : PrimFloat.float -> Type := float64 (f : PrimFloat.float ) : is_float64 f. Register is_float64 as elpi.derive.is_float64. (* Links a term (constant, inductive type, inductive constructor) with its parametricity translation *) Elpi Db derive.param1.db lp:{{ pred reali-done i:gref. :index(3) pred reali i:term, o:term. reali {{ lib:num.int63.type }} {{ lib:elpi.derive.is_uint63 }} :- !. reali {{ lib:num.float.type }} {{ lib:elpi.derive.is_float64 }} :- !. :name "reali:fail" reali X _ :- M is "derive.param1: No unary parametricity translation for " ^ {coq.term->string X}, stop M. type realiR term -> term -> prop. realiR {{ lib:num.int63.type }} {{ lib:elpi.derive.is_uint63 }} :- !. realiR {{ lib:num.float.type }} {{ lib:elpi.derive.is_float64 }} :- !. :name "realiR:fail" realiR T TR :- M is "derive.param1: No unary parametricity translation linking " ^ {coq.term->string T} ^ " and " ^ {coq.term->string TR}, stop M. }}. (* standalone *) Elpi Command derive.param1. Elpi Accumulate File derive_hook. Elpi Accumulate File paramX. Elpi Accumulate File param1. Elpi Accumulate Db derive.param1.db. Elpi Accumulate lp:{{ main [str I] :- !, coq.locate I GR, derive.param1.main GR "" _. main _ :- usage. usage :- coq.error "Usage: derive.param1 ". }}. Elpi Typecheck. Module Export exports. Elpi derive.param1 eq. End exports. Register is_eq as elpi.derive.is_eq. (* hook into derive *) Elpi Accumulate derive File paramX. Elpi Accumulate derive File param1. Elpi Accumulate derive Db derive.param1.db. #[synterp] Elpi Accumulate derive lp:{{ derivation _ _ (derive "param1" (cl\ cl = []) true). }}. Elpi Accumulate derive lp:{{ pred derive.on_param1 i:inductive, i:(inductive -> string -> list prop -> prop), i:string, o:list prop. derive.on_param1 T F N C :- reali (global (indt T)) (global (indt P)), !, F P N C. derivation T N ff (derive "param1" (derive.param1.main T N ) (reali-done T)). }}. coq-elpi-2.1.0/apps/derive/theories/derive/param1_congr.v000066400000000000000000000035461460156013500233150ustar00rootroot00000000000000(* Given an inductive type I and its unary parametricity translation is_I it generates for is constructor is_K a lemma like px = qx -> is_K x px .. = is_K x qx .. where px is the extra argument (about x) introduces by the parametricity translation. license: GNU Lesser General Public License Version 2.1 or later ------------------------------------------------------------------------- *) From elpi.apps.derive Extra Dependency "paramX_lib.elpi" as paramX. From elpi.apps.derive Extra Dependency "param1_congr.elpi" as param1_congr. From elpi.apps.derive Extra Dependency "derive_hook.elpi" as derive_hook. From elpi.apps.derive Extra Dependency "derive_synterp_hook.elpi" as derive_synterp_hook. From elpi Require Export elpi. From elpi.apps Require Export derive.param1. Elpi Db derive.param1.congr.db lp:{{ type param1-congr-db constructor -> term -> prop. }}. Elpi Command derive.param1.congr. Elpi Accumulate File paramX. Elpi Accumulate Db derive.param1.congr.db. Elpi Accumulate File param1_congr. Elpi Accumulate lp:{{ main [str I, str O] :- !, coq.locate I (indt GR), derive.param1.congr.main GR O _. main [str I] :- !, coq.locate I (indt GR), derive.param1.congr.main GR "congr_" _. main _ :- usage. usage :- coq.error "Usage: derive.param1.congr []". }}. Elpi Typecheck. (* hook into derive *) Elpi Accumulate derive File param1_congr. Elpi Accumulate derive Db derive.param1.congr.db. #[phases=both] Elpi Accumulate derive lp:{{ dep1 "param1_congr" "param1". }}. #[synterp] Elpi Accumulate derive lp:{{ derivation _ _ (derive "param1_congr" (cl\ cl = []) true). }}. Elpi Accumulate derive lp:{{ derivation (indt T) _ ff (derive "param1_congr" (derive.on_param1 T derive.param1.congr.main "congr_") (derive.on_param1 T (T\_\_\derive.exists-indc T (K\ param1-congr-db K _)) _ _)). }}. coq-elpi-2.1.0/apps/derive/theories/derive/param1_functor.v000066400000000000000000000035361460156013500236640ustar00rootroot00000000000000(* Functorial property of params in param1 translation. Inductive I A PA : A -> Type := K : forall a b, I A PA a. Elpi derive.param1.functor is_I. Definition is_I_functor A PA PB (f : forall x, PA x -> PB x) a : I A PA a -> I A PB a. license: GNU Lesser General Public License Version 2.1 or later ------------------------------------------------------------------------- *) From elpi.apps.derive Extra Dependency "param1_functor.elpi" as param1_functor. From elpi.apps.derive Extra Dependency "derive_hook.elpi" as derive_hook. From elpi.apps.derive Extra Dependency "derive_synterp_hook.elpi" as derive_synterp_hook. From elpi Require Import elpi. From elpi.apps Require Import derive. Elpi Db derive.param1.functor.db lp:{{ pred param1-functor-db i:term, i:term, o:term. pred param1-functor-for i:inductive, o:gref, o:list bool. }}. Elpi Command derive.param1.functor. Elpi Accumulate File derive_hook. Elpi Accumulate Db derive.param1.functor.db. Elpi Accumulate File param1_functor. Elpi Accumulate lp:{{ main [str I, str O] :- !, coq.locate I (indt GR), derive.param1.functor.main GR O _. main [str I] :- !, coq.locate I (indt GR), derive.param1.functor.main GR "_functor" _. main _ :- usage. usage :- coq.error "Usage: derive.param1.functor []". }}. Elpi Typecheck. (* hook into derive *) Elpi Accumulate derive File param1_functor. Elpi Accumulate derive Db derive.param1.functor.db. #[phases=both] Elpi Accumulate derive lp:{{ dep1 "param1_functor" "param1". }}. #[synterp] Elpi Accumulate derive lp:{{ derivation _ _ (derive "param1_functor" (cl\ cl = []) true). }}. Elpi Accumulate derive lp:{{ derivation (indt T) _ ff (derive "param1_functor" (derive.on_param1 T derive.param1.functor.main "_functor") (derive.on_param1 T (T\_\_\param1-functor-for T _ _) _ _)). }}. coq-elpi-2.1.0/apps/derive/theories/derive/param1_trivial.v000066400000000000000000000163531460156013500236570ustar00rootroot00000000000000(* Given an inductive type I and its unary parametricity translation is_ it generates a proof of forall i : I, is_U i and then a proof of forall i : I, { p : is_I i & forall q, p = q }. license: GNU Lesser General Public License Version 2.1 or later ------------------------------------------------------------------------- *) From elpi.apps.derive Extra Dependency "paramX_lib.elpi" as paramX. From elpi.apps.derive Extra Dependency "param1.elpi" as param1. From elpi.apps.derive Extra Dependency "param1_inhab.elpi" as param1_inhab. From elpi.apps.derive Extra Dependency "param1_trivial.elpi" as param1_trivial. From elpi.apps.derive Extra Dependency "derive_hook.elpi" as derive_hook. From elpi.apps.derive Extra Dependency "derive_synterp_hook.elpi" as derive_synterp_hook. From elpi Require Import elpi. From elpi.apps Require Import derive.param1 derive.param1_congr. Definition is_uint63_inhab x : is_uint63 x. Proof. constructor. Defined. Register is_uint63_inhab as elpi.derive.is_uint63_inhab. Definition is_float64_inhab x : is_float64 x. Proof. constructor. Defined. Register is_float64_inhab as elpi.derive.is_float64_inhab. Definition is_eq_inhab A (PA : A -> Type) (HA : trivial A PA) (x : A) (px: PA x) y (py : PA y) (eq_xy : x = y) : is_eq A PA x px y py eq_xy. Proof. revert py. case eq_xy; clear eq_xy y. intro py. rewrite <- (trivial_uniq A PA HA x px); clear px. rewrite <- (trivial_uniq A PA HA x py); clear py. apply (is_eq_refl A PA x (trivial_full A PA HA x)). Defined. Register is_eq_inhab as elpi.derive.is_eq_inhab. Definition is_uint63_trivial : trivial PrimInt63.int is_uint63 := fun x => contracts _ is_uint63 x (is_uint63_inhab x) (fun y => match y with uint63 i => eq_refl end). Register is_uint63_trivial as elpi.derive.is_uint63_trivial. Definition is_float64_trivial : trivial PrimFloat.float is_float64 := fun x => contracts _ is_float64 x (is_float64_inhab x) (fun y => match y with float64 i => eq_refl end). Register is_float64_trivial as elpi.derive.is_float64_trivial. Lemma is_eq_trivial A (PA : A -> Type) (HA : trivial A PA) (x : A) (px: PA x) y (py : PA y) : trivial (x = y) (is_eq A PA x px y py). Proof. intro p. apply (contracts (x = y) (is_eq A PA x px y py) p (is_eq_inhab A PA HA x px y py p)). revert py. case p; clear p y. rewrite <- (trivial_uniq _ _ HA x px). clear px. intros py. rewrite <- (trivial_uniq _ _ HA x py). clear py. intro v; case v; clear v. unfold is_eq_inhab. unfold trivial_full. unfold trivial_uniq. case (HA x); intros it def_it; compute. case (def_it it). reflexivity. Defined. Register is_eq_trivial as elpi.derive.is_eq_trivial. Elpi Db derive.param1.trivial.db lp:{{ pred param1-trivial-done i:inductive. pred param1-inhab-done i:inductive. type param1-inhab-db term -> term -> prop. param1-inhab-db {{ lib:elpi.derive.is_uint63 }} {{ lib:elpi.derive.is_uint63_inhab }}. param1-inhab-db {{ lib:elpi.derive.is_float64 }} {{ lib:elpi.derive.is_float64_inhab }}. param1-inhab-db {{ lib:elpi.derive.is_eq }} {{ lib:elpi.derive.is_eq_inhab }}. param1-inhab-db (fun `f` (prod `_` S _\ T) f\ prod `x` S x\ prod `px` (RS x) _) (fun `f` (prod `_` S _\ T) f\ fun `x` S x\ fun `px` (RS x) _\ P f x) :- pi f x\ reali T R, param1-inhab-db R PT, coq.mk-app PT [{coq.mk-app f [x]}] (P f x). param1-inhab-db {{ lib:elpi.derive.is_eq lp:A lp:PA lp:X lp:PX lp:Y lp:PY }} {{ lib:elpi.derive.is_eq_inhab lp:A lp:PA lp:QA lp:X lp:PX lp:Y lp:PY }} :- !, param1-trivial-db PA QA. param1-inhab-db (app [Hd|Args]) (app[P|PArgs]) :- param1-inhab-db Hd P, !, param1-inhab-db-args Args PArgs. type param1-inhab-db-args list term -> list term -> prop. param1-inhab-db-args [] []. param1-inhab-db-args [T,P|Args] R :- std.assert-ok! (coq.typecheck T Ty) "param1-inhab-db: cannot work illtyped term", if (coq.sort? Ty) (param1-inhab-db P Q, R = [T,P,Q|PArgs], param1-inhab-db-args Args PArgs) (R = [T,P|PArgs], param1-inhab-db-args Args PArgs). type param1-trivial-db term -> term -> prop. param1-trivial-db {{ lib:elpi.derive.is_uint63 }} {{ lib:elpi.derive.is_uint63_trivial }}. param1-trivial-db {{ lib:elpi.derive.is_float64 }} {{ lib:elpi.derive.is_float64_trivial }}. param1-trivial-db (fun `f` (prod `_` S _\ T) f\ prod `x` S x\ prod `px` (RS x) _) (fun `f` (prod `_` S _\ T) f\ fun `x` S x\ fun `px` (RS x) _\ P f x) :- pi f x\ reali T R, param1-trivial-db R PT, coq.mk-app PT [{coq.mk-app f [x]}] (P f x). param1-trivial-db {{ lib:elpi.derive.is_eq lp:A lp:PA lp:X lp:PX lp:Y lp:PY }} {{ lib:elpi.derive.is_eq_trivial lp:A lp:PA lp:QA lp:X lp:PX lp:Y lp:PY }} :- param1-trivial-db PA QA. param1-trivial-db (app [Hd|Args]) (app[P|PArgs]) :- param1-trivial-db Hd P, !, param1-trivial-db-args Args PArgs. type param1-trivial-db-args list term -> list term -> prop. param1-trivial-db-args [] []. param1-trivial-db-args [T,P|Args] R :- std.assert-ok! (coq.typecheck T Ty) "param1-trivial-db: cannot work on illtyped term", if (coq.sort? Ty) (param1-trivial-db P Q, R = [T,P,Q|PArgs], param1-trivial-db-args Args PArgs) (R = [T,P|PArgs], param1-trivial-db-args Args PArgs). }}. (* standalone *) Elpi Command derive.param1.trivial. Elpi Accumulate File derive_hook. Elpi Accumulate File paramX. Elpi Accumulate File param1. Elpi Accumulate Db derive.param1.db. Elpi Accumulate Db derive.param1.congr.db. Elpi Accumulate Db derive.param1.trivial.db. Elpi Accumulate File param1_inhab. Elpi Accumulate File param1_trivial. Elpi Accumulate lp:{{ main [str I] :- !, coq.locate I (indt GR), derive.param1.inhab.main GR "_inhab" CL, CL => derive.param1.trivial.main GR "_trivial" _. main _ :- usage. usage :- coq.error "Usage: derive.param1.trivial ". }}. Elpi Typecheck. Elpi Command derive.param1.inhab. Elpi Accumulate File derive_hook. Elpi Accumulate File paramX. Elpi Accumulate File param1. Elpi Accumulate Db derive.param1.db. Elpi Accumulate Db derive.param1.congr.db. Elpi Accumulate Db derive.param1.trivial.db. Elpi Accumulate File param1_inhab. Elpi Accumulate lp:{{ main [str I] :- !, coq.locate I (indt GR), derive.param1.inhab.main GR "_inhab" _. main _ :- usage. usage :- coq.error "Usage: derive.param1.inhab ". }}. Elpi Typecheck. (* hook into derive *) Elpi Accumulate derive Db derive.param1.trivial.db. Elpi Accumulate derive File param1_inhab. Elpi Accumulate derive File param1_trivial. #[phases=both] Elpi Accumulate derive lp:{{ dep1 "param1_trivial" "param1_inhab". dep1 "param1_trivial" "param1_congr". dep1 "param1_inhab" "param1". }}. #[synterp] Elpi Accumulate derive lp:{{ derivation _ _ (derive "param1_inhab" (cl\ cl = []) true). }}. Elpi Accumulate derive lp:{{ derivation (indt T) _ ff (derive "param1_inhab" (derive.on_param1 T derive.param1.inhab.main "_inhab") (derive.on_param1 T (T\_\_\param1-inhab-done T) _ _)). derivation (indt T) _ ff (derive "param1_trivial" (derive.on_param1 T derive.param1.trivial.main "_trivial") (derive.on_param1 T (T\_\_\param1-trivial-done T) _ _)). }}. coq-elpi-2.1.0/apps/derive/theories/derive/param2.v000066400000000000000000000041441460156013500221210ustar00rootroot00000000000000(* Binary parametricity translation. license: GNU Lesser General Public License Version 2.1 or later ------------------------------------------------------------------------- *) From elpi.apps.derive Extra Dependency "paramX_lib.elpi" as paramX. From elpi.apps.derive Extra Dependency "param2.elpi" as param2. From elpi.apps.derive Extra Dependency "derive_hook.elpi" as derive_hook. From elpi.apps.derive Extra Dependency "derive_synterp_hook.elpi" as derive_synterp_hook. From elpi Require Import elpi. From elpi.apps Require Import derive. (* To be removed *) Class param_db {X X1 XR : Type} (x : X) (x : X1) (xR : XR) := store_param {}. Class param {X : Type} {XR : X -> X -> Type} (x : X) (xR : XR x x) := Param {}. Register store_param as param2.store_param. (* Links a term (constant, inductive type, inductive constructor) with its parametricity translation *) Elpi Db derive.param2.db lp:{{ pred param-done i:gref. :index(3) pred param i:term, o:term, o:term. :name "param:fail" param X _ _ :- M is "derive.param2: No binary parametricity translation for " ^ {coq.term->string X}, stop M. type paramR term -> term -> term -> prop. :name "paramR:fail" paramR T T1 TR :- M is "derive.param2: No binary parametricity translation linking " ^ {coq.term->string T} ^ " and " ^ {coq.term->string T1} ^ " and " ^ {coq.term->string TR}, stop M. }}. Elpi Command derive.param2. Elpi Accumulate File derive_hook. Elpi Accumulate File paramX. Elpi Accumulate File param2. Elpi Accumulate Db derive.param2.db. Elpi Accumulate lp:{{ main [str I] :- !, coq.locate I GR, derive.param2.main GR "" _. main _ :- usage. usage :- coq.error "Usage: derive.param2 ". }}. Elpi Typecheck. (* hook into derive *) Elpi Accumulate derive File param2. Elpi Accumulate derive Db derive.param2.db. #[synterp] Elpi Accumulate derive lp:{{ derivation _ _ (derive "param2" (cl\ cl = []) true). }}. Elpi Accumulate derive lp:{{ derivation T N ff (derive "param2" (derive.param2.main T N) (param-done T)). }}. coq-elpi-2.1.0/apps/derive/theories/derive/projK.v000066400000000000000000000032711460156013500220240ustar00rootroot00000000000000(* Generates a projection for each argument of each constructor. The projection is expected to be applied to an explicit construcor and all its arguments. It is used to implement "injection". license: GNU Lesser General Public License Version 2.1 or later ------------------------------------------------------------------------- *) From elpi.apps.derive Extra Dependency "projK.elpi" as projK. From elpi.apps.derive Extra Dependency "derive_hook.elpi" as derive_hook. From elpi.apps.derive Extra Dependency "derive_synterp_hook.elpi" as derive_synterp_hook. From elpi Require Import elpi. From elpi.apps Require Import derive. Elpi Db derive.projK.db lp:{{ type projK-db constructor -> int -> term -> prop. :name "projK-db:fail" projK-db GR N _ :- M is "derive.projK: can't find the projection " ^ {std.any->string N} ^ " for constructor " ^ {std.any->string GR}, stop M. }}. Elpi Command derive.projK. Elpi Accumulate File derive_hook. Elpi Accumulate Db derive.projK.db. Elpi Accumulate File projK. Elpi Accumulate lp:{{ main [str I, str O] :- !, coq.locate I (indt GR), derive.projK.main GR O _. main [str I] :- !, coq.locate I (indt GR), derive.projK.main GR "proj" _. main _ :- usage. usage :- coq.error "Usage: derive.projK []". }}. Elpi Typecheck. (* hook into derive *) Elpi Accumulate derive File projK. Elpi Accumulate derive Db derive.projK.db. #[synterp] Elpi Accumulate derive lp:{{ derivation _ _ (derive "projK" (cl\ cl = []) true). }}. Elpi Accumulate derive lp:{{ derivation (indt T) Prefix ff (derive "projK" (derive.projK.main T N) (derive.exists-indc T (K\ projK-db K _ _))) :- N is Prefix ^ "getk_". }}. coq-elpi-2.1.0/apps/derive/theories/derive/std.v000066400000000000000000000015351460156013500215320ustar00rootroot00000000000000(* Standard set of derivations license: GNU Lesser General Public License Version 2.1 or later ------------------------------------------------------------------------- *) From elpi.apps Require Export derive. From elpi.apps Require Export derive.map derive.lens derive.lens_laws derive.param1 derive.param1_congr derive.param1_trivial derive.param1_functor derive.param2 derive.induction derive.tag derive.fields derive.eqb derive.eqbcorrect derive.eqbOK . Elpi Typecheck derive. (* we derive the Coq prelude *) Module Prelude. derive Init.Datatypes.Empty_set. derive Init.Datatypes.unit. derive Init.Datatypes.bool. derive Init.Datatypes.nat. derive Init.Datatypes.option. derive Init.Datatypes.sum. derive Init.Datatypes.prod. derive Init.Datatypes.list. derive Init.Datatypes.comparison. End Prelude. Export Prelude. coq-elpi-2.1.0/apps/derive/theories/derive/tag.v000066400000000000000000000024441460156013500215130ustar00rootroot00000000000000From elpi Require Import elpi. From elpi.apps Require Import derive. From Coq Require Import PArith. From elpi.apps.derive Extra Dependency "tag.elpi" as tag. From elpi.apps.derive Extra Dependency "derive_hook.elpi" as derive_hook. From elpi.apps.derive Extra Dependency "derive_synterp_hook.elpi" as derive_synterp_hook. Register positive as elpi.derive.positive. Local Open Scope positive_scope. Elpi Db derive.tag.db lp:{{ % this is how one registers the tag function to an inductive and let other % elpi commands use that piece of info pred tag-for o:inductive, o:constant. }}. (* standalone *) Elpi Command derive.tag. Elpi Accumulate File derive_hook. Elpi Accumulate File tag. Elpi Accumulate Db derive.tag.db. Elpi Accumulate lp:{{ main [str I] :- !, coq.locate I (indt GR), coq.gref->id (indt GR) Tname, Prefix is Tname ^ "_", derive.tag.main GR Prefix _. main _ :- usage. usage :- coq.error "Usage: derive.tag ". }}. Elpi Typecheck. (* hook into derive *) Elpi Accumulate derive Db derive.tag.db. Elpi Accumulate derive File tag. #[synterp] Elpi Accumulate derive lp:{{ derivation _ _ (derive "tag" (cl\ cl = []) true). }}. Elpi Accumulate derive lp:{{ derivation (indt T) Prefix ff (derive "tag" (derive.tag.main T Prefix) (tag-for T _)). }}. coq-elpi-2.1.0/apps/eltac/000077500000000000000000000000001460156013500152575ustar00rootroot00000000000000coq-elpi-2.1.0/apps/eltac/Makefile000066400000000000000000000022501460156013500167160ustar00rootroot00000000000000# detection of coq ifeq "$(COQBIN)" "" COQBIN := $(shell which coqc >/dev/null 2>&1 && dirname `which coqc`) endif ifeq "$(COQBIN)" "" $(error Coq not found, make sure it is installed in your PATH or set COQBIN) else $(info Using coq found in $(COQBIN), from COQBIN or PATH) endif export COQBIN := $(COQBIN)/ all: build test build: Makefile.coq @$(MAKE) --no-print-directory -f Makefile.coq test: Makefile.test.coq @$(MAKE) --no-print-directory -f Makefile.test.coq theories/%.vo: force @$(MAKE) --no-print-directory -f Makefile.coq $@ tests/%.vo: force build Makefile.test.coq @$(MAKE) --no-print-directory -f Makefile.test.coq $@ examples/%.vo: force build Makefile.test.coq @$(MAKE) --no-print-directory -f Makefile.test.coq $@ Makefile.coq Makefile.coq.conf: _CoqProject @$(COQBIN)/coq_makefile -f _CoqProject -o Makefile.coq @$(MAKE) --no-print-directory -f Makefile.coq .merlin Makefile.test.coq Makefile.test.coq.conf: _CoqProject.test @$(COQBIN)/coq_makefile -f _CoqProject.test -o Makefile.test.coq clean: Makefile.coq Makefile.test.coq @$(MAKE) -f Makefile.coq $@ @$(MAKE) -f Makefile.test.coq $@ .PHONY: force all build test install: @$(MAKE) -f Makefile.coq $@ coq-elpi-2.1.0/apps/eltac/_CoqProject000066400000000000000000000007331460156013500174150ustar00rootroot00000000000000# Hack to see Coq-Elpi even if it is not installed yet -Q ../../theories elpi -I ../../src -docroot elpi.apps # Hack to see derive even if it is not installed yet -Q ../derive/theories elpi.apps -Q ../derive/elpi elpi.apps.derive -R theories elpi.apps.eltac theories/assumption.v theories/constructor.v theories/intro.v theories/clear.v theories/fail.v theories/discriminate.v theories/injection.v theories/case.v theories/generalize.v theories/cycle.v theories/tactics.v coq-elpi-2.1.0/apps/eltac/_CoqProject.test000066400000000000000000000010301460156013500203620ustar00rootroot00000000000000# Hack to see Coq-Elpi even if it is not installed yet -Q ../../theories elpi -I ../../src -docroot elpi.apps # Hack to see derive even if it is not installed yet -Q ../derive/theories elpi.apps -R theories elpi.apps.eltac -R tests elpi.apps.eltac.tests -R examples elpi.apps.eltac.examples tests/test_assumption.v tests/test_constructor.v tests/test_intro.v tests/test_clear.v tests/test_fail.v tests/test_discriminate.v tests/test_injection.v tests/test_case.v tests/test_generalize.v tests/test_cycle.v examples/usage_eltac.v coq-elpi-2.1.0/apps/eltac/examples/000077500000000000000000000000001460156013500170755ustar00rootroot00000000000000coq-elpi-2.1.0/apps/eltac/examples/usage_eltac.v000066400000000000000000000004701460156013500215410ustar00rootroot00000000000000From elpi.apps Require Import derive. From elpi.apps Require Import eltac.tactics. derive nat. Lemma example : forall x y : nat, S x = S y -> 0 = 1 -> False. Proof. eltac.intro "x". eltac.intro "y". eltac.intro "I". eltac.intro "D". eltac.injection I. eltac.intro "E". eltac.clear E. eltac.discriminate D. Qed.coq-elpi-2.1.0/apps/eltac/tests/000077500000000000000000000000001460156013500164215ustar00rootroot00000000000000coq-elpi-2.1.0/apps/eltac/tests/test_assumption.v000066400000000000000000000003041460156013500220460ustar00rootroot00000000000000From elpi.apps Require Import eltac.assumption. Lemma test1 x (H : x = 0) : x = 0. Proof. eltac.assumption. Qed. Example test_assumption : True -> True. Proof. intro x. eltac.assumption. Qed. coq-elpi-2.1.0/apps/eltac/tests/test_case.v000066400000000000000000000012661460156013500205670ustar00rootroot00000000000000From elpi.apps Require Import eltac.case. Lemma test1 (n : nat) : n = n. Proof. eltac.case n. exact (refl_equal 0). exact (refl_equal (S _)). Qed. Inductive is_even : nat -> Prop := | even0 : is_even 0 | evenS : forall x, is_even x -> is_even (S (S x)). Lemma test2 (n : nat) (H : is_even n) : n = n. Proof. eltac.case H. exact (refl_equal 0). exact (refl_equal (S (S _))). Qed. Axiom q : nat -> Prop. Axiom p0 : q 0. (* The last 0 must not be abstracted or the goal is illtyped *) Lemma test3 (H : is_even 0) : 0 = 0 /\ (@eq (q 0) p0 p0). Proof. eltac.case H. split. exact (refl_equal 0). exact (refl_equal p0). split; [ exact (refl_equal (S (S _))) | exact (refl_equal p0) ]. Qed. coq-elpi-2.1.0/apps/eltac/tests/test_clear.v000066400000000000000000000005221460156013500207340ustar00rootroot00000000000000From elpi.apps Require Import eltac.clear. Example test_generalize_dependent x y (H : x = y) (H1 : 0 <= x) (d := x + 1) (H2 : y = 1) (w := 3): x + d + y = 2. Proof. generalize dependent x. Fail eltac.clear x. eltac.clear H2. Fail match goal with Hyp : y = 1 |- _ => idtac end. intros. eltac.clearbody d w. Fail unfold d. Check d. Abort. coq-elpi-2.1.0/apps/eltac/tests/test_constructor.v000066400000000000000000000003741460156013500222400ustar00rootroot00000000000000From elpi.apps Require Import eltac.constructor. Lemma test1 : 1 = 1. Proof. eltac.constructor. Qed. Example test_constructor : Type -> True * Type. Proof. intro x. eltac.constructor. - eltac.constructor. - try eltac.constructor. assumption. Qed. coq-elpi-2.1.0/apps/eltac/tests/test_cycle.v000066400000000000000000000004771460156013500207560ustar00rootroot00000000000000From elpi.apps Require Import eltac.cycle. Goal True /\ False /\ 1=1. split;[|split]. all: eltac.cycle 1. admit. reflexivity. exact I. Abort. Goal True /\ False /\ 1=1. split;[|split]. all: eltac.cycle -1. reflexivity. exact I. admit. Abort. Goal True /\ False /\ 1=1. split;[|split]. Fail all: eltac.cycle 3. Abort.coq-elpi-2.1.0/apps/eltac/tests/test_discriminate.v000066400000000000000000000012301460156013500223160ustar00rootroot00000000000000From elpi.apps Require Import eltac.discriminate. Set Implicit Arguments. Inductive foo (A : Type) | (B : Type) : nat -> Type := | K : foo B 0 | K1 : forall n, foo B n -> foo B (S n) | K2 : forall n, (A -> foo (B*B) n) -> foo B (n+n). Elpi derive.isK foo. (* Let's test a little that we are not too syntactic *) Definition AliasK2 A B n (f : A -> foo A (B*B) n) := K2 f. Definition AliasEQ := @eq. Example test_discriminate (k : foo nat nat 0) (f : nat -> foo nat (nat*nat) 1) : AliasEQ (AliasK2 f) (K1 (K1 k)) -> K nat nat = K nat nat -> { Type = Prop } + { True = False }. Proof. intros H F. Fail eltac.discriminate (F). eltac.discriminate (H). Qed. coq-elpi-2.1.0/apps/eltac/tests/test_fail.v000066400000000000000000000001531460156013500205610ustar00rootroot00000000000000From elpi.apps Require Import eltac.fail. Goal False. try (eltac.fail 0). Fail try (eltac.fail 1). Abort. coq-elpi-2.1.0/apps/eltac/tests/test_generalize.v000066400000000000000000000003101460156013500217660ustar00rootroot00000000000000From elpi.apps Require Import eltac.generalize. Example test_generalize x y (H : x = y) (H1 : 0 <= x) (d := x + 1) (H2 : y = 1) : x + d + y = 2. Proof. eltac.generalize (x). intros x0 T0 T1. Abort. coq-elpi-2.1.0/apps/eltac/tests/test_injection.v000066400000000000000000000011111460156013500216230ustar00rootroot00000000000000From elpi.apps Require Import eltac.injection. Set Implicit Arguments. Elpi derive.projK nat. Lemma test_nat (a b :nat) : S a = S b -> a = b. Proof. intro H. eltac.injection (H). intro E. assumption. Qed. Require Vector. Require Import ssreflect Arith. Elpi derive.projK Vector.t. Lemma test_vect A a b n (v1 v2 : Vector.t A n) : Vector.cons A a n v1 = Vector.cons A b n v2 -> a = b /\ v1 = v2. Proof. intro H. eltac.injection (H). move=> /= Eab _ Esigv12. split. exact Eab. rewrite -[v2](projT2_eq Esigv12) /=. by rewrite (UIP_nat _ _ (projT1_eq Esigv12) (eq_refl n)). Qed.coq-elpi-2.1.0/apps/eltac/tests/test_intro.v000066400000000000000000000002631460156013500210030ustar00rootroot00000000000000From elpi.apps Require Import eltac.intro. Lemma test1 : forall x, x = 1. Proof. eltac.intro "a". Abort. Example test_intro : True -> True. Proof. eltac.intro x. exact x. Qed. coq-elpi-2.1.0/apps/eltac/theories/000077500000000000000000000000001460156013500171015ustar00rootroot00000000000000coq-elpi-2.1.0/apps/eltac/theories/assumption.v000066400000000000000000000005021460156013500214670ustar00rootroot00000000000000From elpi Require Export elpi. Elpi Tactic assumption. Elpi Accumulate lp:{{ solve (goal Ctx Ev _ _ _) [] :- std.exists Ctx (x\ x = decl Ev _ _ ; x = def Ev _ _ _). solve _ _ :- coq.ltac.fail _ "No assumption unifies with the goal". }}. Elpi Typecheck. Tactic Notation "eltac.assumption" := elpi assumption. coq-elpi-2.1.0/apps/eltac/theories/case.v000066400000000000000000000022331460156013500202030ustar00rootroot00000000000000From elpi Require Export elpi. Elpi Tactic case. Elpi Accumulate lp:{{ pred mk-abstracted-goal i:list term, i:term, i:term, i:list term, i:list term, o:term. mk-abstracted-goal ToAbstract Goal _IndSort Vars _VarsTys Out :- std.map2 ToAbstract Vars (t\v\r\ r = copy t v) Subst, % Non deterministically we abstract until we obtain a well typed term Subst => copy Goal Out, coq.say "trying" {coq.term->string Out}, coq.typecheck Out _ ok. pred mk-empty-branches i:term, i:term, i:list term, i:list term, o:term. mk-empty-branches _K _KTy _Vars _VarsTys HOLE_. solve (goal _ _ GTy _ [trm T] as G) NG :- !, std.do! [ std.assert-ok! (coq.typecheck T Ty) "input term illtyped", std.assert! (coq.safe-dest-app Ty (global (indt I)) Args) "the type is not inductive", coq.env.indt I _ ParamsNo _ _ _ _, std.drop ParamsNo Args Idxs, std.append Idxs [T] ToAbstract, coq.build-match T Ty (mk-abstracted-goal ToAbstract GTy) mk-empty-branches M, refine M G NG ]. solve _ _ :- usage. usage :- coq.error "Usage: eltac.case ". }}. Elpi Typecheck. Tactic Notation "eltac.case" constr(T) := elpi case ltac_term:(T). coq-elpi-2.1.0/apps/eltac/theories/clear.v000066400000000000000000000036101460156013500203560ustar00rootroot00000000000000From elpi Require Export elpi. Elpi Tactic clear. Elpi Accumulate lp:{{ pred not-hyp i:term, i:prop, o:term. not-hyp X (decl Y _ Ty) Y :- not (occurs X Ty), not (X = Y). not-hyp X (def Y _ Ty Bo) Y :- not (occurs X Ty ; occurs X Bo), not (X = Y). solve (goal Ctx R T E [trm X]) [seal (goal Ctx R T E [])] :- name X, !, std.do! [ std.map-filter Ctx (not-hyp X) VisibleRev, prune E1 {std.rev VisibleRev}, % preserve the order std.assert-ok! (coq.typecheck E1 T) "cannot clear", E = E1 ]. solve (goal _ _ _ _ Args) _ :- coq.error "clear expects 1 name, you passed:" Args. }}. Elpi Typecheck. Tactic Notation "eltac.clear" hyp(V) := elpi clear ltac_term:(V). Elpi Tactic clearbody. Elpi Accumulate lp:{{ pred drop-body i:list argument, i:prop, o:prop. drop-body ToBeCleared (def V Name Ty _Bo) (decl V Name Ty) :- std.mem ToBeCleared (trm V), !. drop-body _ (decl _ _ _ as X) X. drop-body _ (def _ _ _ _ as X) X. msolve [nabla G] [nabla G1] :- pi x\ msolve [G x] [G1 x]. msolve [seal (goal Ctx _ T E ToBeCleared)] [seal (goal Ctx1 _ T E1 [])] :- std.map Ctx (drop-body ToBeCleared) Ctx1, @ltacfail! 0 => % this failure can be catch by ltac Ctx1 => % in the new context, do... std.assert-ok! (coq.typecheck-ty T _) "cannot clear since the goal does not typecheck in the new context", Ctx1 => std.assert-ok! (coq.typecheck E1 T) "should not happen", % E1 see all the proof variables (the pi x in the nabla case) and T is OK in Ctx1 E = {{ lp:E1 : lp:T }}. % we make progress by saying that the old goal/evar is solved by the new one (which has the same type thanks to the line above) % note that E = E1 would be "unstable" since elpi could decide to % actually do E1 := E, while E = (let `x` T E1 x\x) forces elpi % to go the other way around }}. Elpi Typecheck. Tactic Notation "eltac.clearbody" hyp_list(V) := elpi clearbody ltac_term_list:(V). coq-elpi-2.1.0/apps/eltac/theories/constructor.v000066400000000000000000000010171460156013500216540ustar00rootroot00000000000000From elpi Require Export elpi. Elpi Tactic constructor. Elpi Accumulate lp:{{ solve (goal _ _ Ty _ _ as G) GS :- std.do! [ @ltacfail! _ => std.assert! (whd Ty [] (global (indt GR)) _) "The goal is not an inductive type", coq.env.indt GR _ _ _ _ Ks Kt, std.exists2 Ks Kt (k\ t\ sigma P\ coq.saturate t (global (indc k)) P, refine P G GS) ]. solve _ _ :- coq.error "eltac.constructor: this should never happen". }}. Elpi Typecheck. Tactic Notation "eltac.constructor" := elpi constructor. coq-elpi-2.1.0/apps/eltac/theories/cycle.v000066400000000000000000000012471460156013500203730ustar00rootroot00000000000000From elpi Require Export elpi. Elpi Tactic cycle. Elpi Accumulate lp:{{ pred read-arg i:sealed-goal, o:list argument. read-arg (nabla G) X :- pi x\ read-arg (G x) X. read-arg (seal (goal _ _ _ _ A)) A. pred cycle i:int, i:list sealed-goal, o:list sealed-goal. cycle N L PL :- N > 0, std.length L M, std.assert! (N < M) "not enough goals", std.split-at N L B A, std.append A B PL. cycle N L PL :- N < 0, std.length L M, N' is M + N, cycle N' L PL. msolve GL GS :- GL = [G|_], read-arg G [int N], if (N = 0) (GS = GL) (cycle N GL GS). }}. Elpi Typecheck. Tactic Notation "eltac.cycle" int(n) := elpi cycle ltac_int:(n). coq-elpi-2.1.0/apps/eltac/theories/discriminate.v000066400000000000000000000011421460156013500217410ustar00rootroot00000000000000From elpi.apps.derive Extra Dependency "discriminate.elpi" as discriminate. From elpi.apps Require Export derive.isK derive.bcongr derive.eqK. (** A tactic proving the current goal out of a false equation *) Elpi Tactic discriminate. Elpi Accumulate Db derive.isK.db. Elpi Accumulate File discriminate. Elpi Accumulate lp:{{ solve (goal _ Ev Ty _ [trm E] ) [] :- !, of E Eq ER, !, ltac.discriminate ER Eq Ty Ev. solve _ _ :- usage. usage :- coq.error "Usage: eltac.discriminate ". }}. Elpi Typecheck. Tactic Notation "eltac.discriminate" constr(T) := elpi discriminate ltac_term:(T). coq-elpi-2.1.0/apps/eltac/theories/fail.v000066400000000000000000000004571460156013500202110ustar00rootroot00000000000000From elpi Require Export elpi. Elpi Tactic fail. Elpi Accumulate lp:{{ solve (goal _ _ _ _ [int N]) _ :- coq.ltac.fail N. solve (goal _ _ _ _ Args) _ :- coq.error "eltac.fail expects 1 integer, you passed:" Args. }}. Elpi Typecheck. Tactic Notation "eltac.fail" int(n) := elpi fail ltac_int:(n). coq-elpi-2.1.0/apps/eltac/theories/generalize.v000066400000000000000000000011141460156013500214120ustar00rootroot00000000000000From elpi Require Export elpi. Elpi Tactic generalize. Elpi Accumulate lp:{{ pred occurs-hyp i:term, i:prop, o:term. occurs-hyp X (decl Y _ Ty) Y :- occurs X Ty. occurs-hyp X (def Y _ Ty Bo) Y :- occurs X Ty ; occurs X Bo. solve (goal Ctx _ _ _ [trm X] as G) GS :- name X, !, std.do! [ std.map-filter Ctx (occurs-hyp X) Generalize, refine (app[NEW_,X|Generalize]) G GS, ]. solve (goal _ _ _ _ Args) _ :- coq.error "eltac.generalize expects 1 name, you passed:" Args. }}. Elpi Typecheck. Tactic Notation "eltac.generalize" constr(V) := elpi generalize ltac_term:(V). coq-elpi-2.1.0/apps/eltac/theories/injection.v000066400000000000000000000012341460156013500212520ustar00rootroot00000000000000From elpi.apps.derive Extra Dependency "injection.elpi" as injection. From elpi.apps Require Export derive.projK derive.bcongr. (** A tactic pushing an equation under a constructor *) Elpi Tactic injection. Elpi Accumulate Db derive.projK.db. Elpi Accumulate File injection. Elpi Accumulate lp:{{ solve (goal _ _ _ _ [trm E] as G) NG :- !, of E Eq ER, !, ltac.injection ER Eq _ P, if (P = []) (coq.error "Could not generate new equations") (refine (app[New_|P]) G NG). solve _ _ :- usage. usage :- coq.error "Usage: eltac.injection ". }}. Elpi Typecheck. Tactic Notation "eltac.injection" constr(T) := elpi injection ltac_term:(T).coq-elpi-2.1.0/apps/eltac/theories/intro.v000066400000000000000000000007301460156013500204230ustar00rootroot00000000000000From elpi Require Export elpi. Elpi Tactic intro. Elpi Accumulate lp:{{ solve (goal _ _ _ _ [str ID] as G) GS :- !, std.assert! (coq.ltac.id-free? ID G) "name already taken", coq.id->name ID N, refine (fun N _ _) G GS. solve _ _ :- usage. usage :- coq.error "Usage: eltac.intro". }}. Elpi Typecheck. Tactic Notation "eltac.intro" string(ID) := elpi intro ltac_string:(ID). Tactic Notation "eltac.intro" ident(ID) := elpi intro ltac_string:(ID). coq-elpi-2.1.0/apps/eltac/theories/tactics.v000066400000000000000000000002161460156013500207210ustar00rootroot00000000000000From elpi.apps.eltac Require Export intro constructor assumption discriminate injection case generalize fail clear cycle .coq-elpi-2.1.0/apps/locker/000077500000000000000000000000001460156013500154465ustar00rootroot00000000000000coq-elpi-2.1.0/apps/locker/Makefile000066400000000000000000000022501460156013500171050ustar00rootroot00000000000000# detection of coq ifeq "$(COQBIN)" "" COQBIN := $(shell which coqc >/dev/null 2>&1 && dirname `which coqc`) endif ifeq "$(COQBIN)" "" $(error Coq not found, make sure it is installed in your PATH or set COQBIN) else $(info Using coq found in $(COQBIN), from COQBIN or PATH) endif export COQBIN := $(COQBIN)/ all: build test build: Makefile.coq @$(MAKE) --no-print-directory -f Makefile.coq test: Makefile.test.coq @$(MAKE) --no-print-directory -f Makefile.test.coq theories/%.vo: force @$(MAKE) --no-print-directory -f Makefile.coq $@ tests/%.vo: force build Makefile.test.coq @$(MAKE) --no-print-directory -f Makefile.test.coq $@ examples/%.vo: force build Makefile.test.coq @$(MAKE) --no-print-directory -f Makefile.test.coq $@ Makefile.coq Makefile.coq.conf: _CoqProject @$(COQBIN)/coq_makefile -f _CoqProject -o Makefile.coq @$(MAKE) --no-print-directory -f Makefile.coq .merlin Makefile.test.coq Makefile.test.coq.conf: _CoqProject.test @$(COQBIN)/coq_makefile -f _CoqProject.test -o Makefile.test.coq clean: Makefile.coq Makefile.test.coq @$(MAKE) -f Makefile.coq $@ @$(MAKE) -f Makefile.test.coq $@ .PHONY: force all build test install: @$(MAKE) -f Makefile.coq $@ coq-elpi-2.1.0/apps/locker/README.md000066400000000000000000000027751460156013500167400ustar00rootroot00000000000000# Locker The `lock` and `mlock` commands let you lock definitions. ## Example of `lock` ```coq lock Definition x := 3. ``` is elaborated to ```coq Lemma x_key_subproof : unit. Proof. exact: tt. Qed. Definition x := locked_with x_key_subproof 3. Canonical x_unlock_subterm := Unlockable ... ``` Here `locked_with` comes from `ssreflect.v` and protects the body of `x` under a match on `x_key_subproof` which is `Qed` opaque. Hence `x` is provably equal to 3, but not computationally equal to it. Given the canonical structure registration, `rewrite unlock` will replace `x` by `3`. ## Example of `mlock` ```coq mlock Definition x := 3. ``` is elaborated to ```coq Module Type x_Locked. Axiom body : nat. Axiom unlock : body = 3. End x_Locked. Module x : x_Locked. ... End x. Notation x := x.body. Canonical x_unlock_subterm := Unlockable x.unlock. ``` Hence `x` (actually `x.body`) is a new symbol and `x.unlock` is its defining equation. Given the canonical structure registration, `rewrite unlock` will replace `x` by `3`. ## Limitations `mlock` uses a module based locking. The body is really sealed but this command cannot be used inside sections (since modules cannot be declared inside sections). `lock` uses opaque key based locking. It can be used everywhere, even inside sections, but conversion (term comparison) may cross the lock (by congruence) and hence compare possibly large terms. See also the section about locking in [ssereflect.v](https://github.com/coq/coq/blob/master/theories/ssr/ssreflect.v). coq-elpi-2.1.0/apps/locker/_CoqProject000066400000000000000000000002611460156013500176000ustar00rootroot00000000000000# Hack to see Coq-Elpi even if it is not installed yet -Q ../../theories elpi -I ../../src -docroot elpi.apps -R theories elpi.apps -Q elpi elpi.apps.locker theories/locker.v coq-elpi-2.1.0/apps/locker/_CoqProject.test000066400000000000000000000002751460156013500205630ustar00rootroot00000000000000# Hack to see Coq-Elpi even if it is not installed yet -Q ../../theories elpi -I ../../src -docroot elpi.apps -R theories elpi.apps -R tests elpi.apps.locker.tests tests/test_locker.v coq-elpi-2.1.0/apps/locker/elpi/000077500000000000000000000000001460156013500163775ustar00rootroot00000000000000coq-elpi-2.1.0/apps/locker/elpi/locker.elpi000066400000000000000000000113661460156013500205400ustar00rootroot00000000000000/* Locker */ /* license: GNU Lesser General Public License Version 2.1 or later */ /* ------------------------------------------------------------------------- */ namespace locker { pred key-lock i:id, i:term, i:arity, i:option upoly-decl. key-lock ID Bo Arity UnivDecl :- std.do! [ make-key ID Key, coq.arity->term Arity Ty, Def = {{ @locked_with lp:Key lp:Ty lp:Bo }}, std.assert-ok! (coq.typecheck Def _) "locker: illtyped definition", if (UnivDecl = some UD) (coq.upoly-decl->attribute UD Poly!) (Poly! = true), Poly! => coq.env.add-const ID Def Ty @transparent! C, coq.arity->implicits Arity CImpls, if (coq.any-implicit? CImpls) (@global! => coq.arguments.set-implicit (const C) [CImpls]) true, make-key-unlockable ID Def Ty {coq.env.global (const C)} Key, ]. pred make-key i:id, o:term. make-key ID (global (const C)) :- std.do! [ if (get-option "key" KID) true (KID is ID ^ "_key_subproof"), coq.env.add-const KID {{ tt }} {{ unit }} @opaque! C, ]. % ------------------------------------------------------------------------- pred module-lock i:id, i:term, i:arity, i:option upoly-decl. module-lock ID Bo Arity UnivDecl :- std.do! [ coq.arity->term Arity Ty, std.assert-ok! (coq.typecheck-ty Ty _) "locker: definition type illtyped", std.assert-ok! (coq.typecheck Bo Ty) "locker: definition body illtyped", % we craft all constants now since we need to put *in the interface* the % extra universe constraints (if upoly) which are necessary for the body! if (UnivDecl = some UD) (std.do![ PTY = {{ lp:Bo = lp:Bo }}, std.assert-ok! (coq.typecheck-ty PTY _) "lock: unlock statement illtyped", P = {{ @refl_equal lp:Ty lp:Bo }}, std.assert-ok! (coq.typecheck P PTY) "locker: unlock proof illtyped", coq.upoly-decl.complete-constraints UD UD1, UnivDecl1 = some UD1]) (UnivDecl1 = none), lock-module-type ID Ty Bo UnivDecl1 Signature, lock-module-body Signature ID Ty Bo UnivDecl1 Symbol Module, @global! => coq.notation.add-abbreviation ID 0 Symbol ff _, coq.arity->implicits Arity CImpls, if (coq.any-implicit? CImpls) (Symbol = global GR, @global! => coq.arguments.set-implicit GR [CImpls]) true, make-module-unlockable ID Module, ]. pred lock-module-type i:id, i:term, i:term, i:option upoly-decl, o:modtypath. lock-module-type ID Ty Bo UnivDecl M :- std.do! [ Module is ID ^ "_Locked", coq.env.begin-module-type Module, if (UnivDecl = some UD) (coq.upoly-decl->attribute UD Poly!) (Poly! = true), Poly! => coq.env.add-axiom "body" Ty C, coq.env.global (const C) B, PTY = {{ lp:B = lp:Bo }}, std.assert-ok! (coq.typecheck-ty PTY _) "lock: unlock statement illtyped", if (UnivDecl = some UD) (coq.upoly-decl.complete-constraints UD UD1, coq.upoly-decl->attribute UD1 Poly1!) (Poly1! = true), Poly1! => coq.env.add-axiom "unlock" PTY _, coq.env.end-module-type M, ]. pred lock-module-body o:modtypath, i:id, i:term, i:term, i:option upoly-decl, o:term, o:modpath. lock-module-body Signature ID Ty Bo UnivDecl B M :- std.do! [ coq.env.begin-module ID (some Signature), if (UnivDecl = some UD) (coq.upoly-decl->attribute UD Poly!) (Poly! = true), Poly! => coq.env.add-const "body" Bo Ty @transparent! C, coq.env.global (const C) B, P = {{ @refl_equal lp:Ty lp:B }}, std.assert-ok! (coq.typecheck P _) "locker: unlock proof illtyped", PTY = {{ lp:B = lp:Bo }}, std.assert-ok! (coq.typecheck-ty PTY _) "locker: unlock statement illtyped", if (UnivDecl = some UD) (coq.upoly-decl.complete-constraints UD UD1, coq.upoly-decl->attribute UD1 Poly1!) (Poly1! = true), Poly1! => coq.env.add-const "unlock" P PTY @opaque! _, coq.env.end-module M, ]. % ------------------------------------------------------------------------- % Unlocking via the ssreflect Unlockable interface (CS instance) pred make-key-unlockable i:string, i:term, i:term, i:term, i:term. make-key-unlockable ID DefBo Ty LockedDef Key :- std.do! [ % we extract the real body in order to be precise in the unlocking equation DefBo = {{ @locked_with _ _ lp:Bo }}, UnlockEQ = {{ @locked_withE lp:Ty lp:Key lp:Bo }}, Unlock = {{ @Unlockable _ _ lp:LockedDef lp:UnlockEQ }}, make-unlockable ID Unlock, ]. pred make-module-unlockable i:id, i:modpath. make-module-unlockable ID Module :- std.do! [ coq.env.module Module [_,gref UnlockEQ], coq.env.global UnlockEQ UnlockEQT, Unlock = {{ Unlockable lp:UnlockEQT }}, make-unlockable ID Unlock, ]. pred make-unlockable i:id, i:term. make-unlockable ID Unlock :- std.do! [ std.assert-ok! (coq.typecheck Unlock UnlockTy) "locker: unlocking instance illtyped", UID is ID ^ "_unlock_subterm", coq.env.add-const UID Unlock UnlockTy _ U, coq.CS.declare-instance (const U), ]. } coq-elpi-2.1.0/apps/locker/tests/000077500000000000000000000000001460156013500166105ustar00rootroot00000000000000coq-elpi-2.1.0/apps/locker/tests/test_locker.v000066400000000000000000000062011460156013500213140ustar00rootroot00000000000000From Coq Require Import ssreflect. From elpi.apps Require Import locker. (* ----------------------- *) lock Definition d1 := 3. Lemma test_1_0 : d1 = 3. Proof. rewrite unlock. match goal with |- 3 = 3 => by [] end. Qed. Lemma test_1_1 : d1 = 3. Proof. unfold d1. match goal with |- locked_with d1_key_subproof 3 = 3 => by rewrite unlock end. Qed. (* ----------------------- *) Fail lock Axiom d2 : nat. (* ----------------------- *) Section S1. Variable T : Type. #[key="foo"] lock Definition d2 (x : T) := x. End S1. Lemma test_2_0 : d2 nat 3 = 3. Proof. unfold d2. match goal with |- locked_with foo (fun x => x) 3 = 3 => by rewrite unlock end. Qed. (* ----------------------- *) mlock Definition d3 := 3. Print Module d3. Print Module Type d3_Locked. Lemma test_3_0 : d3 = 3. Proof. rewrite unlock. match goal with |- 3 = 3 => by [] end. Qed. Lemma test_3_1 : d3 = 3. Proof. Fail unfold d3. rewrite d3.unlock. by []. Qed. (* ----------------------- *) Section S2. Fail mlock Definition d4 := 3. End S2. (* #286 ----------------------- *) Module Bug_286. Module Import lock_container. Unset Implicit Arguments. lock Definition cons2 {A} x xs := @cons A x xs. End lock_container. About cons2. Definition foo := cons2 0 nil. Class EqDecision (A : Type) := { f : A -> A -> bool }. #[local] Instance xx : EqDecision nat := {| f := (fun _ _ => true) |}. Module Import lock_container2. lock Definition cons3 [A] `{EqDecision A} x xs := @cons A x xs. End lock_container2. Definition foo3 := cons3 0 nil. About cons3. End Bug_286. Module test_286_global_implicits. Unset Implicit Arguments. Module mlock_container. mlock Definition def {A} (a : A) := a. End mlock_container. Fail Definition user1 {A} (a : A) := mlock_container.def _ a. Definition user1 {A} (a : A) := mlock_container.def a. Import mlock_container. Fail Definition user2 {A} (a : A) := def _ a. Definition user2 {A} (a : A) := def a. End test_286_global_implicits. (* https://coq.zulipchat.com/#narrow/stream/253928-Elpi-users-.26-devs/topic/Reifying.20terms.20with.20ltac.20.2F.20if-then-else.20.2F.20complex.20match *) Module elab. mlock Definition y (z : nat) := ltac:(exact z). mlock Definition q (b : bool) := if b then 1 else 0. End elab. (* ----------------------- *) Elpi Command test. (* for queries *) Set Printing Universes. lock #[universes(polymorphic)] Definition id1@{u} (T : Type@{u}) (x : T) := x. About id1. Elpi Query lp:{{ coq.locate "id1" GR, coq.env.univpoly? GR 1 }}. mlock #[universes(polymorphic)] Definition id2@{u} (T : Type@{u}) (x : T) := x. About id2.body. Elpi Query lp:{{ coq.locate "id2" GR, coq.env.univpoly? GR 1 }}. Set Universe Polymorphism. mlock Definition up1 (T : Type) (x : T) := x. About up1.body. Elpi Query lp:{{ coq.locate "up1" GR, coq.env.univpoly? GR 1 }}. mlock #[universes(polymorphic=no)] Definition nup1 (T : Type) (x : T) := x. About nup1.body. Elpi Query lp:{{ coq.locate "nup1" GR, not(coq.env.univpoly? GR _) }}. mlock Definition up2@{u +} (T : Type@{u}) (W : Type) (x : T) := x. About up2.body. Elpi Query lp:{{ coq.locate "up2" GR, coq.env.univpoly? GR 2 }}. Fail mlock Definition up3@{u} (T : Type@{u}) (W : Type) (x : T) := x. coq-elpi-2.1.0/apps/locker/theories/000077500000000000000000000000001460156013500172705ustar00rootroot00000000000000coq-elpi-2.1.0/apps/locker/theories/locker.v000066400000000000000000000047171460156013500207470ustar00rootroot00000000000000(* Locking mechanisms. license: GNU Lesser General Public License Version 2.1 or later ------------------------------------------------------------------------- *) From elpi.apps.locker Extra Dependency "locker.elpi" as locker. From Coq Require Import ssreflect. From elpi Require Import elpi. (** [lock] locks a definition on an opaque key + can be used everywhere - conversion may cross the lock (by congruence), while reduction will not Example: [[ lock Definition foo : T := bo. ]] Synthesizes: - [foo_key_subproof] an opaque term of type unit - [foo] unfolds to [locked_with foo_key_subproof bo] - [Canonical foo_unlock_subterm := Unlockable ...] so that [rewrite unlock] exposes the real body Supported attributes: - [#[key]] lets one override the name of the key *) Elpi Command lock. Elpi Accumulate File locker. Elpi Accumulate lp:{{ main [const-decl ID (some Bo) Ty] :- !, attributes A, coq.parse-attributes A [ att "key" string, ] Opts, !, Opts => locker.key-lock ID Bo Ty none. main [upoly-const-decl ID (some Bo) Ty UnivDecl] :- !, attributes A, coq.parse-attributes A [ att "key" string, ] Opts, !, Opts => locker.key-lock ID Bo Ty (some UnivDecl). main _ :- coq.error "Usage: lock Definition ...". }}. Elpi Typecheck. Elpi Export lock. (** [mlock] locks a definition behind a module type + hard locking (the body is really sealed) - cannot be used inside sections Example: [[ mlock Definition foo : T := bo. ]] Synthesizes: - [Module Type foo_Locked] with fields [body] and [unlock] where [body : T] and [unlock : body = bo] - [Module foo : foo_Locked] - [foo] a notation for [foo.body] - [Canonical foo_unlock_subterm := Unlockable ...] so that [rewrite unlock] exposes the real body *) Elpi Command mlock. Elpi Accumulate File locker. #[synterp] Elpi Accumulate lp:{{ pred synterp-action i:id. synterp-action ID :- Module is ID ^ "_Locked", coq.env.begin-module-type Module, coq.env.end-module-type TY, coq.env.begin-module ID (some TY), coq.env.end-module _. main [const-decl ID _ _] :- synterp-action ID. main [upoly-const-decl ID _ _ _] :- synterp-action ID. }}. Elpi Accumulate lp:{{ main [const-decl ID (some Bo) Ty] :- !, locker.module-lock ID Bo Ty none. main [upoly-const-decl ID (some Bo) Ty UD] :- !, locker.module-lock ID Bo Ty (some UD). main _ :- coq.error "Usage: mlock Definition ...". }}. Elpi Typecheck. Elpi Export mlock. coq-elpi-2.1.0/apps/tc/000077500000000000000000000000001460156013500145755ustar00rootroot00000000000000coq-elpi-2.1.0/apps/tc/Makefile000066400000000000000000000022501460156013500162340ustar00rootroot00000000000000# detection of coq ifeq "$(COQBIN)" "" COQBIN := $(shell which coqc >/dev/null 2>&1 && dirname `which coqc`) endif ifeq "$(COQBIN)" "" $(error Coq not found, make sure it is installed in your PATH or set COQBIN) else $(info Using coq found in $(COQBIN), from COQBIN or PATH) endif export COQBIN := $(COQBIN)/ all: build test build: Makefile.coq @$(MAKE) --no-print-directory -f Makefile.coq test: Makefile.test.coq @$(MAKE) --no-print-directory -f Makefile.test.coq theories/%.vo: force @$(MAKE) --no-print-directory -f Makefile.coq $@ tests/%.vo: force build Makefile.test.coq @$(MAKE) --no-print-directory -f Makefile.test.coq $@ examples/%.vo: force build Makefile.test.coq @$(MAKE) --no-print-directory -f Makefile.test.coq $@ Makefile.coq Makefile.coq.conf: _CoqProject @$(COQBIN)/coq_makefile -f _CoqProject -o Makefile.coq @$(MAKE) --no-print-directory -f Makefile.coq .merlin Makefile.test.coq Makefile.test.coq.conf: _CoqProject.test @$(COQBIN)/coq_makefile -f _CoqProject.test -o Makefile.test.coq clean: Makefile.coq Makefile.test.coq @$(MAKE) -f Makefile.coq $@ @$(MAKE) -f Makefile.test.coq $@ .PHONY: force all build test install: @$(MAKE) -f Makefile.coq $@ coq-elpi-2.1.0/apps/tc/Makefile.coq.local000066400000000000000000000005231460156013500201070ustar00rootroot00000000000000CAMLPKGS+= -package coq-elpi.elpi ifeq "$(shell which cygpath >/dev/null 2>&1)" "" OCAMLFINDSEP=: else OCAMLFINDSEP=; endif OCAMLPATH:=../../src/$(OCAMLFINDSEP)$(OCAMLPATH) export OCAMLPATH install-extra:: df="`$(COQMKFILE) -destination-of theories/tc.vo $(COQLIBS)`";\ install -m 0644 $(wildcard elpi/*.elpi) "$(COQLIBINSTALL)/$$df" coq-elpi-2.1.0/apps/tc/README.md000066400000000000000000000541151460156013500160620ustar00rootroot00000000000000# Type class solver This folder contains an alternative implementation of a type class solver for coq written in elpi. This solver is composed by two main parts, the **compiler** and the **solver**. The former takes coq classes and instances and "translates" them into the elpi representation, whereas the latter is the elpi tactic aiming to make instance search on coq goals. - [The compiler](#the-compiler) - [Class compilation](#class-compilation) - [Deterministic search](#deterministic-search) - [Hint modes](#hint-modes) - [Instance compilation](#instance-compilation) - [Instance priorities](#instance-priorities) - [Technical details](#technical-details) - [Instance locality](#instance-locality) - [Goal resolution](#goal-resolution) - [Commands](#commands) - [Flags](#flags) - [WIP](#wip) ## The compiler In our implementation by compiler we mean the set of rules abstracting coq terms, *1.* classes and *2* instances, in the elpi world. In the next two paragraphs, we briefly explain these two phases of the compilation, where, intuitively, a type class can be seen as a prolog predicate and the instances of a type class $C$ as rule (clause or fact) of the elpi predicate for $C$. For instance, if ```coq Class Eqb (T: Type) := { eqb : T -> T -> bool; eq_leibniz : forall (A B: T), eqb A B = true -> A = B }. ``` is the type class representing the leibniz equality between two objects of type $T$, and ```coq Program Instance eqBool : Eqb bool := { eqb A B := if A then B else negb B }. Next Obligation. now intros [] []. Qed. ``` is an implementation of `Eqb` for the type `bool`, their corresponding elpi representation will be: ```prolog pred tc-Eqb i:term, o:term. tc-Eqb {{bool}} {{eqBool}}. ``` ### Class compilation The compilation of a type class creates dynamically (thanks to the `coq.elpi.add-predicate` API) a new predicate called `tc-Path.tc-ClassName` with $N + 1$ terms where: - `Path` is the is the logical path in which the type class `ClassName` is located - $N$ is the number of parameter of the `ClassName`. In particular, if a type class $C$ as the parameters $P_1,\dots, P_n$ then the corresponding predicate will have $N$ parameters of type `term` ($1$ per parameter) and a last parameter in output mode containing the result of the instance search. By default, all the first $P_1,\dots,P_n$ parameters are in output mode. The set of rules allowing to add new type-class predicates in elpi are grouped in [create_tc_predicate.elpi](elpi/create_tc_predicate.elpi). #### Deterministic search Sometimes, it could be interesting to disable the backtracking search for some type classes, for performances issues or design choices. In coq the flag *Typeclasses Unique Instances* (see [here](https://coq.inria.fr/refman/addendum/type-classes.html#coq:flag.Typeclasses-Unique-Instances)) allows to block any kind of a backtrack on instance search: in this case type classes are supposed to be canonical. In the example below, we want the `NoBacktrack` type class not to backtrack if a solution is found. ```coq #[deterministic] TC.declare Class NoBacktrack (n: nat). Class A (n: nat). Instance a0 : A 0. Qed. Instance nb0 : NoBacktrack 0. Qed. Instance nb1 : NoBacktrack 1. Qed. Instance a3 n : NoBacktrack n -> A n -> A 3. Qed. Goal A 3. Fail apply _. Abort. ``` The goal `A 3` fails since the only instance matching it is `a3`, but we are not able to satisfy both its premises. In particular, the instance `nb1` is applied first, which fixes the parameter `n` of `a3` to `1`. Then the algorithm tries to find a solution for `A 1` (the second premise), but no implementation of `A` can solve it. In the classic approach, the type class solver would backtrack on the premise `NoBacktrack n` and try to apply `nb0` (this would find a solution), but since the type class `NoBacktrack` is deterministic, then `nb0` is discarded. In this implementation, the elpi rule for the instance `a3` is: ```elpi tc-A {{3}} {{a3 lp:A lp:B lp:C}} :- do-once (tc-NoBacktrack A B), tc-A A C. ``` The predicate `do-once i:prop` has ```prolog do-once P :- P, !. ``` as implementation. The cut (`!`) operator is in charge to avoid backtracking on the query `tc-NoBacktrack A B` #### Hint modes Instance search is done looking to the arguments passed to the class. If there is an instance $I$ unifying to it, the premises of $I$ are tried to be solved to commit $I$ as the solution of the current goal (modulo backtracking). Concerning the parameters of a type class, coq type class solver allows to constrain the argument to be ground, in input or output modes (see [here](https://coq.inria.fr/refman/proofs/automatic-tactics/auto.html#coq:cmd.Hint-Mode)). We provide a similar behavior in elpi: classes represent elpi predicates where the parameters can be in input `i` or output `o` mode (see [here](https://github.com/LPCIC/elpi/blob/master/ELPI.md#modes)). We translate coq modes in the following way: `+` and `!` become `i` in elpi and `-` becomes `o` (see [here](https://github.com/FissoreD/coq-elpi/blob/c3cce183c3b2727ef82178454f0c583196ee2c21/apps/tc/elpi/create_tc_predicate.elpi#L12)). In elpi we allow type classes to have at most one mode, if that mode is not defined, all parameters are considered in `o` mode. The command to be used to let elpi compile classes with modes is done via the command `TC.Declare`. ```coq #[mode(i, o, i)] TC.Declare Class (T1: Type) (T2: Type) (N : nat). ``` The pragma `mode` is taken into account to make `T1` and `N` in input mode and `T2` in output mode. The command `TC.Declare` both create the class in elpi and in coq. Note that the accepted list arguments for the attribute `mode` are `i, o, +, -` and `!` with their respective meaning. ### Instance compilation Instances are compiled in elpi from their type. In particular, since the $\forall$-quantification and the left hand side of implications of coq are both represented with the `prod` type in elpi, we can say that the type of an instance $I$ is essentially a tower of
prod N_1 T_1 (x_1\ 
  prod N_2 T_2 (x_2\ 
    ... 
      prod N_n T_n (x_n\ 
        app [global GR, A_1, A_2, ... A_M])))
where $\forall i \in [1, N],\ T_i$ is the type of the quantified variable $x_i$. Each $x_1$ represents a premise $P$ of the current instance and, if its type $T_i$ is a type class, then $P$ is recursively compiled and added to the final clause as a premise. The last `prod` contains `app [global GR, A_1, ..., A_M]` where `GR` is the gref of the type class implemented by $I$ and each $A_j$ is an argument applied to `GR` which sees every $x_i$. Note that during the compilation of the instance the binders $x_i$ are recursively replaced by fresh `pi` elpi variables. For example, the instance `eqBool` showed before, has type `Eqb bool`, it has no quantified variable and it is directly compiled in the clause `tc-Eqb {{bool}} {{eqBool}}`. On the other hand, if we take the instance below, ```coq Instance eqProd (A B: Type) : Eqb A -> Eqb B -> Eqb (A * B) := { ... } ``` we see that its type is ``` prod `A` (sort (typ eqProd.u0»)) c0 \ prod `B` (sort (typ eqProd.u1»)) c1 \ prod `H0` (app [global (indt «Eqb»), c0]) c2 \ prod `H1` (app [global (indt «Eqb»), c1]) c3 \ app [global (indt «Eqb»), app [global (indt «prod»), c0, c1]] ``` there are in fact four variables that produce the elpi clause: ``` pi x0 x1 x2 x3\ tc-Eqb {{prod lp:A lp:B}} Sol :- tc-Eqb A S1, tc-Eqb B S2, Sol = {{eqProd lp:A lp:B lp:S1 lp:S2}}. ``` the four variable $c_0,...,c_3$ are quantified with `pi`, the two premises `H0` and `H1` are compiled as premises of the current goal (we need to find a proof that there exists an implementation of the class `Eqb` for the types of $c_0$ and $c_1$). Then the application of `«Eqb»` is used to create the head of the clause with its arguments and `eqProd`, the gref of the current instance, is used as the solution of the current goal applied to all of the quantified variables. The set of rules allowing to compile instances in elpi are grouped in [compiler.elpi](elpi/compiler.elpi). **** #### Instance priorities To reproduce coq behavior, instances need to respect a notion of priority: sometime multiple instances can be applied on a goal, but, for sake of performances, the order in which they are tried is essential. In the previous example, the goal `Eqb ?V` where `?V` is a meta-variable, it is important to first use the rules `eqBool` and then `eqProd`, the latter causing an infinite loop. In elpi, we have the possibility to create rules with names and, then, new rules can be added with respect to a particular grafting (see [here](https://github.com/FissoreD/coq-elpi/blob/a11558758de0a1283bd9224b618cc75e40f118fb/coq-builtin.elpi#L1679)). Our strategy of instance insertion in the elpi database reposes on a predicate `pred hook o:string` having, by default, $1.001$ implementations each of them having a name going from `"0"` to `"1000"` (bounds included). Roughly what we have is the following: ```prolog :name "0" hook "0". :name "1" hook "1". ... :name "999" hook "999". :name "1000" hook "1000". ``` In this way an instance can be added at the wanting position to respect its priority. In particular, the priority of an instance can be defined in two different ways by the user by coq and we retrieve this piece of information via the `Event` listener from `coq` (see [here](https://github.com/coq/coq/blob/f022d5d194cb42c2321ea91cecbcce703a9bcad3/vernac/classes.mli#L81)). This event contains either a class or an instance and in the latter case we can get its priority (see [here](https://github.com/FissoreD/coq-elpi/blob/a11558758de0a1283bd9224b618cc75e40f118fb/apps/tc/src/coq_elpi_tc_register.ml#L57)). #### Technical details 1. If the instance has no user defined priority, the attribute containing the priority of the instance is set to `None`. In this case, the priority is computed as the number of premises the instance has. For example, `eqBool` has priority $2$, since it has two hypothesis triggering recursive instance search. 2. If $P$ is the priority of both the instance $I_1$ and the instance $I_2$ of a class $C$, then the instance that should be tried before is the one which has been defined later (this is coq default behavior). To respect this order, the grafting we use is `after P` for both instances, in this way, elpi will put the second-defined instance before the first one. 3. The number of hook in elpi is bounded to $1.000$, it is however possible to extend it via the command `Elpi TC.AddHook G OldName NewName` where `G` is either after or before and `NewName` is the new hook that will be grafted after\before the hook called `OldName`. For instance, `Elpi TC.AddHook after 1000 1002` creates a hook named `1002` after `1000` and `Elpi TC.AddHook before 1002 1001` insert the hook `1001` before `1002`. Note that `OldName` should be an existing name, otherwise, a blocking error will be thrown at the next invocation of an elpi code. 4. The event listener for instance/class creation can be extended with new elpi programs via the command `Elpi Register TC Compiler PROG`, where `PROG` is the name of the new elpi program called by the `Event` listener of coq. Note that in the case of the creation of a - Type class $C$, `PROG` is called with `[str C]` as argument where `C` is the name of the class - Instance $I$, `PROG` is called with `[str I, str C, str Loc, int Prio]` where `I` is the name of the instance, `C` the name of the class it implements, `Loc` is its `Locality` (one among `Local`, `Global`, `Export`) and `Prio` is its priority. The default elpi program for instance and class insertion is called `auto_compiler` (see [here](https://github.com/FissoreD/coq-elpi/blob/a11558758de0a1283bd9224b618cc75e40f118fb/apps/tc/theories/tc.v#L61)) 5. A registered event listener for instance/class can be deactivated, activated respectively with 1. `Elpi TC Activate Observer PROG.` 2. `Elpi TC Deactivate Observer PROG.` by default, once registered, the elpi program `PROG` is activated #### Instance locality The instances in the elpi database respect the locality given by the user. This is possible thanks to the attributes from [here](https://github.com/FissoreD/coq-elpi/blob/ac036a71f359bc1c1ee3893949d3371df10b0aef/coq-builtin.elpi#L355). When an instance is created the `Event` listener transfer the locality of the instance to the elpi program in charge to make the insertion (see [here](https://github.com/FissoreD/coq-elpi/blob/ac036a71f359bc1c1ee3893949d3371df10b0aef/apps/tc/elpi/compiler.elpi#L154) and [here](https://github.com/FissoreD/coq-elpi/blob/ac036a71f359bc1c1ee3893949d3371df10b0aef/apps/tc/src/coq_elpi_tc_register.ml#L37)). As a small remark, we should consider that instances depending on section variables should be *recompiled* on section end in order to abstract them. In the example below ```coq Section Foo. Variable (A B: Type) (HA : Eqb A) (HB : Eqb B). Global Instance eqProd' : Eqb (A * B) := {...}. Elpi TC.Print_instances eqb. (* Here the elpi database has the instances HA, HB and eqProd' *) (* And the rules for eqProd' is tc-Eqb {{prod A B}} {{eqProd'}}. Remark: Here A and B are not elpi variables, but the coq variables from the context *) End Foo. Elpi TC.Print_instances eqb. (* Here HA and HB are removed since local to Foo and eqProd' has been recompiled abstracting and A, B, HA and HB. They are now arguments of this instance *) (* The new rules for eqProd' is now tc-Eqb {{prod lp:A lp:B}} {{eqProd' lp:A lp:B lp:HA lp:HB}} :- tc-Eqb A HA, tc-Eqb B HB. Remark: Here A and B are elpi variables and HA, PB are the proof that we can prove {{Eqb lp:A}} and {{Eqb lp:B}} *) ``` Concretely, in a section, we consider all instances as **local** in elpi. On section end, the `Event` listener for instance creation triggers a new call to the elpi program for instance compilation. This trigger contains the same event as the one for the instance creation, but now elpi is capable to compile the instance abstracting the section variable. Finally, if we are not in a section, instance locality will depend on the "real" locality of that instance: 1. If the instance is *local*, then we accumulate the attribute *@local! =>* 2. If the instance is *global*, then we accumulate the attribute *@global! =>* 3. If the instance is in *export* mode, then we pass no attribute, since by default, elpi rules have this particular locality ## Goal resolution The resolution of type class goals is done via the `TC_solver` tactic (see [here](https://github.com/FissoreD/coq-elpi/blob/d674089e5f5773d5d922f185e2ff058e595fa8b8/apps/tc/theories/tc.v#L29) and [here](elpi/solver.elpi)). This tactic take the goal and start by introducing the quantified variables if any, then it compiles the hypotheses whose type is a type class and finally start by solving the goal by looking for the instances in the elpi database. Note that the tactic, per se, is not complicated since the search of instances is based on a DFS backtracking on failure which is the builtin search mode of query resolution in elpi. The elpi tactic can be called by the classic `elpi TC_solver` on the current goal, however, this can be done implicitly done using the classic tactics of coq doing type class resolution. In particular, we want to make our solver and coq one coexist. The user may whish the elpi solver to solve `Only` goals concerning particular type classes (for example, those defined in its library) and leave coq to solve the other otherwise. To do so we can call the command `Elpi Override TC TC_solver Only Eqb` which activates the resolution of goal of goal concerning `Eqb` which the solver `TC_solver`. Note that multiple solvers can be created and activated to solve different tasks. To do so, we take advantage of the `Typeclasses.set_solve_all_instances` function from coq (see [here](https://github.com/coq/coq/blob/f022d5d194cb42c2321ea91cecbcce703a9bcad3/pretyping/typeclasses.mli#L141)) which allows to set a solver to be called on type class goals. We have taken the file [`classes.ml`] from [here](https://github.com/coq/coq/blob/f022d5d194cb42c2321ea91cecbcce703a9bcad3/vernac/classes.ml#L1) and slightly modified the function [`resolve_all_evars`](https://github.com/FissoreD/coq-elpi/blob/17d1f20d3d4f37abfeee7edcf31f3757fd515ff3/apps/tc/src/coq_elpi_class_tactics_hacked.ml#L1165). Now that function, before solving a goal verifies if the current goal contains only type classes overriden by the user and if so, it uses the elpi solver for its resolution, otherwise, it calls the default coq solver. Note that the choice of using elpi or coq solver is done [here](src/coq_elpi_class_tactics_takeover.ml). Moreover, we provide different commands to 1. Override all type class goals and solve them by the solver of elpi, that command is `Elpi Override TC TC_solver All`. 2. Override only some type classes, that command is `Elpi Override TC TC_solver Only ClassQualid+` where `ClassQualid+` is a non empty list of type class names. A valid call to this command is, for example, `Elpi Override TC TC_solver Only Eqb Decidable`. 3. Override no type class, *i.e.* solve all goals with coq solver with the command `Elpi Override TC TC_solver None`. 4. Blacklist some type classes from elpi solver, `Elpi Override TC - ClassQualid+`. For instance `Elpi Override TC TC_solver Only Eqb Decidable. Elpi Override TC - Decidable` in equivalent to `Elpi Override TC TC_solver Only Eqb`. 5. Add type classes to be solved by the solver of elpi `Elpi Override TC + ClassQualid+`. For instance, `Elpi Override TC TC_solver Only Eqb. Elpi Override TC + Decidable` is equivalent to `Elpi Override TC TC_solver Only Eqb Decidable`. All of these commands are meant to dynamically change the resolution of type classes goal in `.v` files. ## Commands A small recap of the available elpi commands:
TC.Print_instances (click to expand) This commands prints the list of instances inside the elpi database grouped by type class and in order of priority. Note that custom rules will not appear in this list. This command can also be called with the name of a type class to print only the implementation of that type class in elpi. An example of the result for the command `Elpi print_instance Eqb.` ``` Instances list for const «Eqb» is: const «eqBool» const «eqProd» ```
TC.Set_deterministic (click to expand) Take the name of a type class in parameter and sets the search mode of that class to deterministic (see [here](#deterministic-search))
TC.Get_class_info ClassName (click to expand) Prints the name of the predicate associated to the class `ClassName` and its search mode (`deterministic|classic`). This command is useful especially when you want to add a new custom rule for a goal resolution and want to know the name of the predicate of the targeted class. Example: ```coq Elpi TC.Get_class_info Eqb. (* Output: The predicate of indt «Eqb» is tc-Eqb and search mode is classic *) ```
TC.AddHook G OldName NewName (click to expand) See [here](#technical-details)
TC.Declare ClassDef (click to expand) See [here](#deterministic-search) and [here](#hint-modes) for respectively deterministic type class and mode declaration
**Note:** in a new library you may wish to automatically compile into your elpi database the existing classes and instances on which you library depends. To do so, the $4$ following commands may be useful: - `TC.AddAllClasses`: look for all the defined classes and creates their predicate - `TC.AddClasses ClassName+`: compile the predicate for the classes in argument - `TC.AddAllInstances`: look for all the defined instances and compile them - `TC.AddInstances InstName+`: compiles al the instances passed in argument **Note:** it is important to create the predicate of type classes (if not already done) before the insertion of instances otherwise this would throw an exception. ## Flags Here the list of the flags available (all of them are `off` by default):
TC IgnoreEtaReduction (click to expand) Solves the goal ignoring eta-reduction, in that case it will no longer possible to unify `fun x => F x` with `F`
TC ResolutionTime (click to expand) Print the time taken to solve a goal by looking into the set of rules in the database of elpi
TC NameShortPath (click to expand) Experimental and discouraged, it can be used to compile the predicate of type classes without putting the `tc-Path.` prefix before `tc-ClassName` (see [here](#class-compilation)). For example, the type class `Decidable` from `Coq.Classes` is compiled into the predicate `tc-Coq.Classes.DecidableClass.tc-Decidable`. For small tests, if you want a predicate called simply `tc-Decidable` you can either use the namespace of elpi (see [here](https://github.com/LPCIC/elpi/blob/master/ELPI.md#namespaces)) or activate the option `NameShortPat` which creates the predicate with the short name `tc-Decidable`
TC TimeRefine (click to expand) Prints the time taken by coq to refine the elpi solution in to the coq term
Experimental: TC CompilerWithPatternFragment (click to expand) Compile instances using the pattern fragment unification of elpi: the coq term applications (`app [HD | TL]`) are replaced with the elpi application `(HDe TLe)` where `HDe` is the elpi representation of `HD` (similarly for `TLe`)
## WIP 1. Mode management: - Classes with multiple modes 2. Clarify pattern fragment unification 3. Topological sort of premises in modes are activated coq-elpi-2.1.0/apps/tc/_CoqProject000066400000000000000000000007041460156013500167310ustar00rootroot00000000000000# Hack to see Coq-Elpi even if it is not installed yet -Q ../../theories elpi -I ../../src -docroot elpi.apps -R theories elpi.apps.tc -R elpi elpi.apps.tc -R tests elpi.apps.tc.tests src/coq_elpi_tc_register.ml src/coq_elpi_tc_hook.mlg src/coq_elpi_class_tactics_takeover.ml src/coq_elpi_class_tactics_hacked.ml src/elpi_tc_plugin.mlpack -I src/ src/META.coq-elpi-tc theories/db.v theories/add_commands.v theories/tc.v theories/wip.v coq-elpi-2.1.0/apps/tc/_CoqProject.test000066400000000000000000000017571460156013500177200ustar00rootroot00000000000000-arg -w -arg -Not-added -arg -w -arg -TC.hints # Hack to see Coq-Elpi even if it is not installed yet -Q ../../theories elpi -I ../../src -Q elpi elpi.apps.tc -R theories elpi.apps.tc -R tests elpi.apps.tc.tests -I src tests/classes_declare.v # Register (de-)activation tests/register/f1.v tests/register/f2.v tests/register/f3.v tests/hook_test.v tests/auto_compile.v # Import order of instances tests/importOrder/sameOrderCommand.v tests/importOrder/f1.v tests/importOrder/f2a.v tests/importOrder/f2b.v tests/importOrder/f3a.v tests/importOrder/f3b.v tests/importOrder/f3c.v tests/importOrder/f3d.v tests/importOrder/f3e.v tests/importOrder/f3f.v tests/importOrder/f3g.v tests/nobacktrack.v tests/patternFragment.v tests/contextDeepHierarchy.v # tests/test_commands_API.v tests/section_in_out.v tests/eqSimplDef.v tests/injTest.v # Test with light version of base.v of stdpp tests/stdppInj.v tests/stdppInjClassic.v tests/test.v tests/indt_to_inst.v tests/bigTest.v examples/tutorial.v coq-elpi-2.1.0/apps/tc/elpi/000077500000000000000000000000001460156013500155265ustar00rootroot00000000000000coq-elpi-2.1.0/apps/tc/elpi/WIP/000077500000000000000000000000001460156013500161655ustar00rootroot00000000000000coq-elpi-2.1.0/apps/tc/elpi/WIP/modes.elpi000066400000000000000000000036111460156013500201500ustar00rootroot00000000000000/* license: GNU Lesser General Public License Version 2.1 or later */ /* ------------------------------------------------------------------------- */ % pred make-modes-cl i:gref, i:list term, i:term, i:list (list hint-mode), i:list (list term), o:prop. % make-modes-cl T V (prod _ _ X) HintModes L (pi x\ C x):- % std.map HintModes (x\r\ [r|_] = x) FST, % std.map HintModes (x\r\ [_|r] = x) LAST, % pi x\ sigma NewL\ % std.map2 L FST (l\m\r\ if (m = mode-input) (r = [x | l]) (r = l)) NewL, % make-modes-cl T [x | V] (X x) LAST NewL (C x). % make-modes-cl T V _ _ L Clause :- % Ty = {coq.mk-app (global T) {std.rev V}}, % Clause = (pi s\ tc T Ty s :- std.forall L (x\ std.exists x var), !, coq.error "Invalid mode for" Ty). % takes the type of a class and build a list % of hint mode where the last element is mandatory pred make-last-hint-mode-input i:term, o:list hint-mode. make-last-hint-mode-input (prod _ _ (x\ (prod _ _ _) as T)) [mode-output | L] :- pi x\ make-last-hint-mode-input (T x) L. make-last-hint-mode-input (prod _ _ _) [mode-input]. make-last-hint-mode-input (sort _) []. % build a list of the seme langht as the the passed one % where all the elements are [] pred build-empty-list i:list B, o:list (list A). build-empty-list [] []. build-empty-list [_ | TL] [[] | L] :- build-empty-list TL L. % add the hint modes of a Class to the database. % note that if the Class has not specified hint mode % then we assume the hint mode to be - - - ... ! pred add-modes i:gref. :if "add-modes" add-modes GR :- % the hint mode is added only if not exists if (not (class GR _ _)) ( coq.env.typeof GR Ty, coq.hints.modes GR "typeclass_instances" ModesProv, if (ModesProv = []) (Modes = [{make-last-hint-mode-input Ty}]) (Modes = ModesProv), % make-modes-cl GR [] Ty Modes {build-empty-list Modes} Cl, % add-tc-db _ (after "firstHook") Cl, ) true. add-modes _.coq-elpi-2.1.0/apps/tc/elpi/alias.elpi000066400000000000000000000013561460156013500174770ustar00rootroot00000000000000/* license: GNU Lesser General Public License Version 2.1 or later */ /* ------------------------------------------------------------------------- */ accumulate base. pred alias i:term, o:term. pred replace-with-alias.aux i:list term, o:list term, o:bool. replace-with-alias.aux [] [] ff. replace-with-alias.aux [X | Xs] [Y | Ys] B :- replace-with-alias X Y B', replace-with-alias.aux Xs Ys B'', or B' B'' B. % [replace-with-alias T T1 Changed] T1 is T where aliases are replaced pred replace-with-alias i:term, o:term, o:bool. replace-with-alias A Sol tt :- alias A Sol', replace-with-alias Sol' Sol _. replace-with-alias (app ToReplace) (app Sol) A :- replace-with-alias.aux ToReplace Sol A. replace-with-alias A A ff.coq-elpi-2.1.0/apps/tc/elpi/base.elpi000066400000000000000000000031571460156013500173210ustar00rootroot00000000000000/* license: GNU Lesser General Public License Version 2.1 or later */ /* ------------------------------------------------------------------------- */ % [count L X R] counts the occurrences of X in L pred count i:list A, i:A, o:int. count [] _ 0. count [A | TL] A R :- count TL A X, R is (X + 1). count [_ | TL] A R :- count TL A R. pred expected-found i:A, i:A. expected-found Expected Found :- Expected = Found; halt "Assertion error" "\nExpected :" Expected "\nFound :" Found. pred last-no-error i:list A, o:A. last-no-error A B :- (std.last [] _ :- !, fail) => std.last A B. % [find L F R] returns the first R in L such that (F R) is valid pred find i:list A, i:(A -> prop), o:A. find [] _ _ :- std.fatal-error "find element not found". find [R | _] F R :- F R. find [_ | L] F R :- find L F R. pred find-opt i:list A, i:(A -> prop), o:(option A). find-opt [] _ none. find-opt [R | _] F (some R) :- F R. find-opt [_ | L] F R :- find-opt L F R. pred list-init i:int, i:(int -> A -> prop), o:list A. list-init N _ _ :- N < 0, std.fatal-error "list-init negative length". list-init 0 _ [] :- !. list-init N F [A | TL] :- F N A, N1 is N - 1, list-init N1 F TL. pred args->str-list i:list argument, o: list string. args->str-list L Res :- std.map L (x\r\ str r = x) Res. pred or i:bool, i:bool, o:bool. or ff ff ff :- !. or _ _ tt. pred neg i:bool, o:bool. neg tt ff. neg ff tt. pred fail->bool i:prop, o:bool. fail->bool P ff :- P, !. fail->bool _ tt. pred sep. sep :- coq.say "---------------------------------". pred do i:list prop. do []. do [P|PS] :- P, do PS. pred do-once i:prop. do-once A :- A, !.coq-elpi-2.1.0/apps/tc/elpi/compiler.elpi000066400000000000000000000252361460156013500202230ustar00rootroot00000000000000/* license: GNU Lesser General Public License Version 2.1 or later */ /* ------------------------------------------------------------------------- */ accumulate base. accumulate tc_aux. % returns the classes on which the current gref depends pred get-class-dependencies i:gref, o:list gref. get-class-dependencies GR Res :- coq.env.dependencies GR _ DepSet, coq.gref.set.elements DepSet DepList, std.filter DepList coq.TC.class? Res. pred unify-fo i:list name, i:list term, i:list (term -> term), o:term, i:list term, o:term. unify-fo [Name | Names] [Ty | Tys] [Fun | Funs] (fun Name Ty Fun) [X|Xs] R :- var R, !, unify-fo Names Tys Funs (Fun X) Xs R. unify-fo _ _ _ F L R :- var R, !, coq.mk-app F L R. unify-fo _ _ _ F L (app R) :- std.appendR H L R, if (H = [X]) (F = X) (F = app H). unify-fo _ _ _ F [] F. pred remove-ho-unification i:prop, i:bool, i:int, i:term, i:term, i:list prop, i:list term, i:list name, i:list term, i:list (term -> term), i:list term, i:list prop, o:prop. :name "remove-ho-unification:start" remove-ho-unification IsHead IsPositive 0 Ty AppInst Premises [] _ _ _ _ Fixes Clause :- !, copy Ty Ty1, copy AppInst AppInst1, if (IsPositive = tt) (make-tc IsHead Ty1 AppInst1 {std.append Fixes Premises} Clause) (make-tc IsHead Ty1 AppInst1 Premises Clause1, std.append Fixes [Clause1] L, Clause = do L). remove-ho-unification IsHead IsPositive 0 Ty AppInst Premises [(app [X | Y] as G) | TL] Names Types Funs [Gen | GensTL] Fixes P2 :- !, std.length Y Arity, std.split-at Arity Types SubTypes TypesTL, std.split-at Arity Names SubNames NamesTL, std.split-at Arity Funs SubFuns FunsTL, P1 = (unify-fo SubNames SubTypes SubFuns X Y Gen), copy G Gen => remove-ho-unification IsHead IsPositive 0 Ty AppInst Premises TL NamesTL TypesTL FunsTL GensTL [P1 | Fixes] P2. remove-ho-unification IsHead tt N Ty AppInst Premises LT NameL TypeL FunL GenL Fixes (pi ty f name gen\ Clause ty f name gen) :- N > 0, N1 is N - 1, pi name ty f gen\ remove-ho-unification IsHead tt N1 Ty AppInst Premises LT [name | NameL] [ty | TypeL] [f | FunL] [gen | GenL] Fixes (Clause ty f name gen). remove-ho-unification IsHead ff N Ty AppInst Premises LT NameL TypeL FunL GenL Fixes (sigma ty f name gen\ Clause ty f name gen) :- N > 0, N1 is N - 1, pi name ty f gen\ remove-ho-unification IsHead ff N1 Ty AppInst Premises LT [name | NameL] [ty | TypeL] [f | FunL] [gen | GenL] Fixes (Clause ty f name gen). pred pattern-fragment? i:term. pattern-fragment? (app [HD|TL]) :- not (HD = global _), distinct_names [HD | TL]. pred get-pattern-fragment i:term, o:list term. get-pattern-fragment T1 TL :- !, (pi L G GL\ fold-map (app L as G) GL G [G | GL] :- distinct_names L) => % (pi G GL\ fold-map (app _ as G) GL G GL) => (pi G GL\ fold-map (prod _ _ _ as G) GL G GL) => fold-map T1 [] _ TL. /* compile-aux [Ty Inst Premises PiAccRev UnivL IsPositive Clause No-Premises] Ty : the type of the instance Inst : the instance term on the form (global InstGref) Premises : list of constraints/premises of an instances found from its type PiAccRev : the list of pi variables accumulated from the (prod _ _ Bo) of the type of Inst. The will be used on the solution of the clause coq.mk-app Inst {std.rev PiAccRev} Sol UnivL : the list of universes of types inside Ty that are replaced with a fresh variable to simplify unification IsPositive : bring the information about the positivity of the current sub-term e.g. if T = A -> (B -> C) -> D, then: D is positive in T, (B -> C) is negative, A is positive in T C is positivie in (B -> C), B is negative in (B -> C) IsPositive is used to know how to accumulate sigma Xi\ and pi x\ in the current clause IsHead : a prop [true|false] to know if we are compiling the head of the instance or one hypothesis of its premises Clause : the solution to be returned No-Premises : a boolean saying if the returned clause as no premises that is an instance with no hypothesis */ pred compile-aux i:term, i:term, i:list prop, i:list term, i:list univ, i:bool, i:prop, o:prop, o:bool. :name "compiler-aux:start" compile-aux Ty I [] [] [X | XS] IsPositive IsHead (pi x\ C x) IsLeaf :- !, pi x\ copy (sort (typ X)) (sort (typ x)) => copy Ty (Ty1 x), compile-aux (Ty1 x) I [] [] XS IsPositive IsHead (C x) IsLeaf. compile-aux (prod N T F) I RevPremises ListVar [] IsPositive IsHead Clause ff :- !, (if (IsPositive = tt) (Clause = pi x\ C x) (Clause = (pi x\ decl x N T => C x))), pi p\ sigma NewPremise TC L\ if (get-TC-of-inst-type T TC, coq.TC.class? TC /*, not (occurs p (F p))*/) (compile-aux T p [] [] [] {neg IsPositive} false NewPremise _, if (class TC _ deterministic) (L = [do-once NewPremise | RevPremises]) (L = [NewPremise | RevPremises])) (L = RevPremises), compile-aux (F p) I L [p | ListVar] [] IsPositive IsHead (C p) _. compile-aux Ty I RevPremises ListVar [] _ IsHead Clause tt :- not (is-option-active oTC-use-pattern-fragment-compiler), !, std.rev RevPremises Premises, coq.mk-app I {std.rev ListVar} AppInst, make-tc IsHead Ty AppInst Premises Clause. compile-aux Ty I RevPremises ListVar [] IsPositive IsHead Clause tt :- !, std.rev RevPremises Premises, coq.mk-app I {std.rev ListVar} AppInst, std.append {get-pattern-fragment Ty} {get-pattern-fragment AppInst} Term-to-be-fixed, std.fold Term-to-be-fixed 0 (e\acc\r\ sigma L X\ e = app X, std.length X L, r is acc + L - 1) Len, remove-ho-unification IsHead IsPositive Len Ty AppInst Premises Term-to-be-fixed [] [] [] [] [] Clause. % build a list of Clauses of type tc to be temporarly added to the % database, used in theorems having assumptions. pred compile-ctx i:goal-ctx, o:list prop. compile-ctx [] []. compile-ctx [X | Xs] [Clause | ResTl] :- (decl Var _ Ty = X; def Var _ Ty _ = X), is-instance-term Ty, compile-ty Ty Var _ _ Clause, compile-ctx Xs ResTl. compile-ctx [_ | Tl] L :- compile-ctx Tl L. pred compile-ty i:term, i:term, o:bool, o:gref, o:prop. compile-ty Ty Inst IsLeaf TC-of-Inst Clause:- if (get-TC-of-inst-type Ty TC-of-Inst)( @redflags! coq.redflags.beta => coq.reduction.lazy.norm Ty Ty1, coq.univ.variable.set.elements {coq.univ.variable.of-term Ty1} L, std.map L (x\r\ coq.univ.variable r x) L1, compile-aux Ty1 Inst [] [] L1 tt true Clause IsLeaf) % (coq.warning "" "" "Adding polymorphic Instance" Inst). true. pred compile i:gref, o:bool, o:gref, o:prop. compile InstGR IsLeaf TC-of-Inst Clause:- coq.env.typeof InstGR Ty, compile-ty Ty (global InstGR) IsLeaf TC-of-Inst Clause. % if an instance depends on multiple TC then a warning is raised. pred warn-multiple-deps i:gref, i:list gref. warn-multiple-deps Inst Dep :- if (fail, {std.length Dep} > 1) ( coq.warning "add-inst-with-multiple-deps" "TC-warning" "Adding" Inst "which dependes on mulitple class dependencies:" Dep) true. pred has-context-deps i:gref. has-context-deps GR :- coq.env.section SectionVars, coq.env.dependencies GR _ Deps, std.exists SectionVars (x\ coq.gref.set.mem (const x) Deps). pred is-local. is-local :- std.mem {attributes} (attribute "local" _). pred get-locality i:string, o:list prop. get-locality "Local" [@local!]. get-locality _ [@local!] :- coq.env.current-section-path [_ | _]. get-locality "Global" [@global!]. get-locality "Export" []. pred add-inst i:gref, i:gref, i:string, i:int. add-inst Inst TC Locality Prio :- coq.env.current-section-path SectionPath, compile Inst _ TC Clause, % TODO: a clause is flexible if an instance is polimorphic (pglobal) not (var Clause), if (Prio = -1) (get-inst-prio Inst Prio1) (Prio1 = Prio), Graft is after (int_to_string Prio1), get-full-path Inst ClauseName, get-locality Locality LocalityProp, LocalityProp => (add-tc-db ClauseName Graft Clause, add-tc-db _ Graft (instance SectionPath Inst TC)). add-inst Inst _ _ _ :- coq.warning "Not-added" "TC_solver" "Warning : Cannot compile " Inst "since it is pglobal". % [add-inst->db IgnoreClassDepL ForceAdd Inst] add the Inst to % the database except those depending on at least one % inside IgnoreClassDepL pred add-inst->db i:list gref, i:bool, i:gref. :name "add-inst->db:start" add-inst->db IgnoreClassDepL ForceAdd Inst :- coq.env.current-section-path SectionPath, get-class-dependencies Inst Dep, warn-multiple-deps Inst Dep, if ((ForceAdd = tt; not (instance _ Inst _)), not (std.exists Dep (std.mem IgnoreClassDepL)), not (banned Inst)) ( compile Inst _IsLeaf TC-of-Inst Clause, % TODO: a clause is flexible if an instance is polimorphic (pglobal) not (var Clause), Graft is after (int_to_string {get-inst-prio Inst}), get-full-path Inst ClauseName, if (is-local) (Visibility = [@local!]) (if (has-context-deps Inst) (@local! => add-tc-db _ Graft (instance SectionPath Inst TC-of-Inst)) (@global! => add-tc-db _ Graft (instance [] Inst TC-of-Inst)), Visibility = [@global!]), Visibility => add-tc-db ClauseName Graft Clause ) true; @global! => add-tc-db _ _ (banned Inst), coq.warning "Not-added" "TC_solver" "Warning : Cannot compile " Inst "since it is pglobal". % add all the instances of a TC pred add-inst-of-tc i:list gref, i:list gref, i:gref. add-inst-of-tc IgnoreDepClassGR IgnoreInstsGR GR:- get-inst-by-tc-name GR InstL, std.filter InstL (x\ not (std.mem IgnoreInstsGR x)) InstLF, std.forall InstLF (add-inst->db IgnoreDepClassGR ff). pred add-tc-or-inst-gr i:list string, i:list string, i:list gref. add-tc-or-inst-gr IgnoreDepClass IgnoreInsts Names :- std.map IgnoreDepClass coq.locate IgnoreDepClassGR, std.map IgnoreInsts coq.locate IgnoreInstsGR, std.forall Names (GR\ if2 (coq.TC.class? GR)(add-inst-of-tc IgnoreDepClassGR IgnoreInstsGR GR) (is-instance-gr GR)(add-inst->db IgnoreDepClassGR ff GR) (coq.warning "not-inst-nor-tc" "TC-warning" GR "is neither a TC nor a instance") ). % [add-tc-or-inst IgnoreDepClass ClassName] look % for all the instances of ClassName and call the pred % add-inst->db pred add-tc-or-inst i:list string, i:list string, i:list string. add-tc-or-inst IgnoreDepClass IgnoreInsts Names :- std.map Names coq.locate L, add-tc-or-inst-gr IgnoreDepClass IgnoreInsts L. % takes a Path and a GR and returns if % the GR is located in Path pred is-in-path i:string, i:gref. is-in-path Path GR :- std.mem {coq.gref->path GR} Path. % Look for the instances of ClassName % that are located in Path. pred add-path i:string, i:string. add-path ClassName Path :- coq.locate ClassName GR, std.filter {get-inst-by-tc-name GR} (is-in-path Path) InstInPath, std.forall InstInPath (add-inst->db [] ff).coq-elpi-2.1.0/apps/tc/elpi/create_tc_predicate.elpi000066400000000000000000000073161460156013500223610ustar00rootroot00000000000000/* license: GNU Lesser General Public License Version 2.1 or later */ /* ------------------------------------------------------------------------- */ accumulate base. accumulate tc_aux. pred string->coq-mode i:string, o:hint-mode. string->coq-mode "bang" mode-ground :- !. string->coq-mode "plus" mode-input :- !. string->coq-mode "minus" mode-output :- !. string->coq-mode "i" mode-input :- !. string->coq-mode "o" mode-output :- !. string->coq-mode A _ :- coq.error A "is not a valid mode". pred coq-mode->elpi i:hint-mode, o:pair argument_mode string. :name "coq-mode->elpi" coq-mode->elpi mode-ground (pr in "term"). % approximation coq-mode->elpi mode-input (pr in "term"). coq-mode->elpi mode-output (pr out "term"). % Here we build the elpi modes a class CL. If CL has either zero or more than % one mode, then we consider all its parameter to be in output mode. If the % class has exactly one mode, then it is considered for the signature of the % predicate for CL pred modes-of-class i:gref, o:list (pair argument_mode string). modes-of-class ClassGR Modes :- coq.hints.modes ClassGR "typeclass_instances" CoqModesList, not (CoqModesList = []), not (CoqModesList = [_,_|_], coq.warning "TC.Modes" "At the moment we only allow TC with at most 1 hint Mode (caused by class" {coq.gref->string ClassGR} ")"), CoqModesList = [HintModesFst], std.append {std.map HintModesFst coq-mode->elpi} [pr out "term"] Modes. modes-of-class ClassGR Modes :- coq.env.typeof ClassGR ClassTy, N is {coq.count-prods ClassTy} + 1, % + 1 for the solution list-init N (x\r\ r = (pr out "term")) Modes. pred get-class-locality o:list prop. get-class-locality [@local!] :- coq.env.current-section-path [_ | _], !. get-class-locality [@global!]. pred add-class-gr i:search-mode, i:gref. add-class-gr SearchMode ClassGR :- std.assert! (coq.TC.class? ClassGR) "Only gref of type classes can be added as new predicates", if (class ClassGR _ _) true (modes-of-class ClassGR Modes, gref->pred-name ClassGR PredName, get-class-locality Locality, Locality => ( add-tc-db _ _ (tc-mode ClassGR Modes), coq.elpi.add-predicate "tc.db" _ PredName Modes, add-tc-db _ _ (class ClassGR PredName SearchMode))). pred add-class-str i:search-mode, i:string. add-class-str SearchMode ClassStr :- coq.locate ClassStr ClassGR, add-class-gr SearchMode ClassGR. % Following are predicates for TC.declare pred attr->search-mode o:search-mode. attr->search-mode deterministic :- get-option "deterministic" tt, !. attr->search-mode classic. pred attr->modes o:list hint-mode. attr->modes CoqModes :- get-option "mode" L, std.map L get-key-from-option RawModes, std.map RawModes string->coq-mode CoqModes, !. attr->modes []. pred get-key-from-option i:prop, o:string. get-key-from-option (get-option A tt) A :- !. get-key-from-option (get-option "i" ff) "o" :- !. get-key-from-option (get-option "o" ff) "i" :- !. get-key-from-option A _ :- coq.error A "should be an option". pred declare-class-in-coq i:gref. declare-class-in-coq ClassGR :- attr->modes CoqModes, if (CoqModes = []) true (coq.hints.add-mode ClassGR "typeclass_instances" CoqModes), % CAVEAT: this triggers the observer coq.TC.declare-class ClassGR, attr->search-mode SearchMode, gref->pred-name ClassGR PredName, % HACK: we override the clauses added by the observer, since it does not know % the SearchMode. get-class-locality Locality, Locality => add-tc-db _ (after "0") (class ClassGR PredName SearchMode :- !). pred declare-class i:indt-decl. declare-class D :- !, coq.env.add-indt D I, coq.parse-attributes {attributes} [ att "mode" attlist, att "deterministic" bool ] Opts, Opts => declare-class-in-coq (indt I).coq-elpi-2.1.0/apps/tc/elpi/parser_addInstances.elpi000066400000000000000000000026531460156013500223630ustar00rootroot00000000000000/* license: GNU Lesser General Public License Version 2.1 or later */ /* ------------------------------------------------------------------------- */ accumulate base. accumulate tc_aux. accumulate compiler. kind enum type. type path string -> string -> enum. type addInstPrio int -> string -> enum. type tcOrInst list string -> enum. type ignoreInstances, ignoreClasses string -> list string -> enum. pred parse i:list argument, o:enum. parse [str ClassName, str "path", str Path] (path ClassName Path). parse [str ClassName, str "ignoreInstances" | InstNames] (ignoreInstances ClassName Res) :- args->str-list InstNames Res. parse [str ClassName, str "ignoreClasses" | ClassNames] (ignoreClasses ClassName Res) :- args->str-list ClassNames Res. parse ClassNames (tcOrInst Res) :- args->str-list ClassNames Res. parse [int N, str Instance] (addInstPrio N Instance). pred run-command i:enum. :if "debug" run-command A :- coq.say A, fail. run-command (ignoreClasses ClassName IgnoreClasses) :- add-tc-or-inst IgnoreClasses [] [ClassName]. run-command (tcOrInst InstNames) :- add-tc-or-inst [] [] InstNames. run-command (path ClassName Path):- add-path ClassName Path. run-command (ignoreInstances ClassName InstNames):- add-tc-or-inst [] InstNames [ClassName]. run-command (addInstPrio Prio InstanceName) :- coq.locate InstanceName InstGr, compile InstGr _ _ C, S is int_to_string Prio, add-tc-db _ (before S) C.coq-elpi-2.1.0/apps/tc/elpi/rewrite_forward.elpi000066400000000000000000000057021460156013500216120ustar00rootroot00000000000000/* license: GNU Lesser General Public License Version 2.1 or later */ /* ------------------------------------------------------------------------- */ accumulate base. pred forward i:term, o:term, o:list (pair (list term) term). % Auxiliary function for rewrite-forward pred rewrite-forward->list i:term, i:name, i:prop, o:list prop. rewrite-forward->list P N (forward _ Lemma RewL) L :- coq.mk-app Lemma [P] LemmaApp, % coq.typecheck LemmaApp T ok, % coq.say T, std.map RewL (x\r\ sigma ProjL Ty Pr\ pr ProjL Ty = x, make-proj-app ProjL LemmaApp Pr, r = decl Pr N Ty) L. % Takes a decl from the context and returns the list of its atomic % representations by looking in the forward clauses pred rewrite-forward i:prop, o:list prop. rewrite-forward (decl P N Ty) L :- std.findall (forward Ty _ _) FwdL, std.map FwdL (rewrite-forward->list P N) RewFdw, std.flatten RewFdw L. rewrite-forward _ []. % Takes a list of projections ([proj1|proj2]*) and a term T % and returns the coq's term (projX (projY (... (projZ T)))) % Note that app [Proj, _, _, Rest] has two holes for the types % of the left and right side of Rest pred make-proj-app i:list term, i:term, o:term. make-proj-app [Proj | Projs] T (app [Proj, L, R, Rest]) :- make-proj-app Projs T Rest, % TODO: here we do a naive typecheck to get the types L and R of Rest, % it can be done in a faster way coq.typecheck Rest {{and lp:L lp:R}} ok. make-proj-app [] T T. % Takes a conjunction C of terms and []. It returns a list of pair: % The paths to the conjunct c in C and the path to reach it in C pred rec-split-and i:term, i:(list term), o:list (pair (list term) term). rec-split-and {{lp:A /\ lp:B}} DL L :- LEFT = [{{proj1}} | DL], RIGHT = [{{proj2}} | DL], rec-split-and A LEFT AL, rec-split-and B RIGHT BL, std.append AL BL L. rec-split-and A P [pr P A]. % It takes a rewriting-lemma and abstract it into elpi in a forward % clause of type forward. The base case wants a ∀(x : T).f x, since % we want to keep trace of the type T of x. pred compile-rewrite i:term, i:term, i:list term, o:prop. compile-rewrite (prod _ Ty ((x\ app _) as Bo)) Lemma L (pi x\ forward Ty LemmaApp (TL x)) :- pi x\ coq.mk-app Lemma {std.rev L} LemmaApp, rec-split-and (Bo x) [] (TL x). compile-rewrite (prod _ _ Bo) Lemma L (pi x\ C x) :- pi x\ compile-rewrite (Bo x) Lemma [x | L] (C x). % Takes a string (the name of a rewriting-lemma), % compiles and adds it as a forward clause in tc.db pred add-lemma->forward i:string. add-lemma->forward Lemma :- coq.locate Lemma Gr, coq.env.typeof Gr Type, compile-rewrite Type (global Gr) [] Cl, coq.elpi.accumulate _ "tc.db" (clause Lemma _ Cl). % TODO: @FissoreD @gares should make a set in output? pred rewrite-dep i:list prop, o:list prop. rewrite-dep [] []. rewrite-dep [A | B] L :- rewrite-forward A NewA, not (NewA = []), std.append NewA B ToTreat, rewrite-dep ToTreat L. rewrite-dep [A | TL] [A | L] :- rewrite-dep TL L.coq-elpi-2.1.0/apps/tc/elpi/solver.elpi000066400000000000000000000072761460156013500177270ustar00rootroot00000000000000/* license: GNU Lesser General Public License Version 2.1 or later */ /* ------------------------------------------------------------------------- */ accumulate base. pred time-solve i:prop. time-solve P :- std.time P Time, if (is-option-active oTC-time) (coq.say "[TC] Total resolution time is:" Time) true. msolve L N :- !, time-solve (coq.ltac.all (coq.ltac.open solve-aux) {std.rev L} N). solve A L :- time-solve (solve-aux A L). pred build-context-clauses i:list prop, o:list prop. % Add the section's definition to the given context % and atomize context hypothesis if needed :name "build-context-clauses" build-context-clauses Ctx Clauses :- std.map {coq.env.section} (x\r\ sigma F\ coq.env.typeof (const x) F, r = (decl (global (const x)) _ F)) SectionCtx, std.append Ctx SectionCtx CtxAndSection, compile-ctx CtxAndSection Clauses. pred tc-recursive-search i:term, o:term. tc-recursive-search Ty Sol :- std.time (coq.safe-dest-app Ty (global TC) TL', std.append TL' [Sol] TL, coq.elpi.predicate {gref->pred-name TC} TL Q, Q) Time, if (is-option-active oTC-time-instance-search) (coq.say "[TC] Instance search time is:" Time) true. :if "solve-print-goal" solve (goal Ctx _ Ty _ _) _ :- coq.say "Ctx" Ctx "Ty" Ty, fail. pred solve-aux i:goal, o:list sealed-goal. % solve-aux (goal C _ (prod N Ty F) S _ as _G) _L GL :- !, % @pi-decl N Ty x\ % declare-evar [decl x N Ty|C] (Raw x) (F x) (Sol x), % solve-aux (goal [decl x N Ty|C] (Raw x) (F x) (Sol x) []) _L GL, % if (Sol x = app [HD, x]) (S = HD) (S = fun N Ty Sol). % solve-aux (goal C _ (prod N Ty F) XX _ as G) _L GL :- !, % % intros_if_needed Prod C [] % (@pi-decl N Ty x\ % declare-evar [decl x N Ty|C] (Raw x) (F x) (Sol x), % solve-aux (goal [decl x N Ty|C] (Raw x) (F x) (Sol x) []) _L _, % coq.safe-dest-app (Sol x) Hd (Args x)), % if (pi x\ last-no-error (Args x) x, std.drop-last 1 (Args x) NewArgs) % (coq.mk-app Hd NewArgs Out, refine Out G GL) ( % % coq.say "Not eta" (Sol x) x (fun N Ty Sol), % XX = (fun N Ty Sol)). % solve-aux (goal C _ (prod N _ _ as P) _ A as G) _L GL :- !, % declare-evar C T P S', % G' = (goal C T P S' A), % refine (fun N _ _) G' GL1, % coq.ltac.all (coq.ltac.open solve-aux) GL1 _, % refine S' G GL. solve-aux (goal C _ (prod N Ty F) _ _ as G) GL :- !, (@pi-decl N Ty x\ declare-evar [decl x N Ty|C] (Raw x) (F x) (Sol x), solve-aux (goal [decl x N Ty|C] (Raw x) (F x) (Sol x) []) _), if (pi x\ % also check the head does not contain x coq.safe-dest-app (Sol x) Hd (Args x), last-no-error (Args x) x, std.drop-last 1 (Args x) NewArgs) (coq.mk-app Hd NewArgs Out, refine Out G GL1) (refine (fun N _ _) G GL1), coq.ltac.all (coq.ltac.open solve-aux) GL1 GL. % solve-aux (goal _ _ (prod N _ _) _ _ as G) GL :- !, % refine (fun N _ _) G GL1, % coq.ltac.all (coq.ltac.open solve-aux) GL1 GL. solve-aux (goal Ctx _ Ty Sol _ as G) GL :- var Sol, build-context-clauses Ctx Clauses, % @redflags! coq.redflags.beta => coq.reduction.lazy.norm Ty Ty1, Clauses => if (tc-recursive-search Ty Proof) ( % @no-tc! => coq.elaborate-skeleton X _ X' ok, % coq.say "Solution " X "end" X' "caio", % std.assert! (ground_term X') "solution not complete", % (pi F\ (copy (fun _ _ x\ (app [F, x])) F :- !)) => copy X X', if (is-option-active oTC-ignore-eta-reduction) (Proof' = Proof) (coq.reduction.eta-contract Proof Proof'), std.time (refine Proof' G GL) Refine-Time, if (is-option-active oTC-time-refine) (coq.say "[TC] Refine time is:" Refine-Time) true; coq.error "illtyped solution:" {coq.term->string Proof} ) (GL = [seal G]). main _.coq-elpi-2.1.0/apps/tc/elpi/tc_aux.elpi000066400000000000000000000073301460156013500176670ustar00rootroot00000000000000/* license: GNU Lesser General Public License Version 2.1 or later */ /* ------------------------------------------------------------------------- */ accumulate base. % Contains the list of classes that % cannot be compiled % returns the TC from the type of an instance % TODO: This gould be replaced with an api % coq.TC.get-class-of-inst i:gref, o:gref pred get-TC-of-inst-type i:term, o:gref. get-TC-of-inst-type (prod _ _ A) GR:- pi x\ get-TC-of-inst-type (A x) GR. get-TC-of-inst-type (app [global TC | _]) TC. get-TC-of-inst-type (global TC) TC. pred drop-last i:list A, i:list A, o:list A. drop-last [X | XS] [Y | YS] L :- same_term X Y, !, drop-last XS YS L. drop-last L [] L' :- std.rev L L'. pred instances-of-current-section o:list gref. :name "MySectionEndHook" instances-of-current-section InstsFiltered :- coq.env.current-section-path SectionPath, std.findall (instance SectionPath _ _) Insts, coq.env.section SectionVars, std.map-filter Insts (x\r\ sigma X\ instance _ r _ = x, const X = r, not(std.mem SectionVars X)) InstsFiltered. pred is-instance-gr i:gref. is-instance-gr GR :- coq.env.typeof GR Ty, is-instance-term Ty. pred is-instance-term i:term. is-instance-term T :- get-TC-of-inst-type T TC, coq.TC.class? TC. % adds a clause to the tc.db DB at the passed grafting pred add-tc-db o:id, o:grafting, i:prop. add-tc-db ClauseName Graft PR :- coq.elpi.accumulate _ "tc.db" (clause ClauseName Graft PR); coq.error "cannot add " PR " to tc.db". % takes a tc-instance and return the gref of the inst pred inst->gref i:tc-instance, o:gref. inst->gref (tc-instance Res _) Res. % returns all the instances of the passed ClassName pred get-inst-by-tc-name i:gref, o:list gref. get-inst-by-tc-name TC GRL:- coq.TC.db-for TC Inst, std.map Inst inst->gref GRL', std.rev GRL' GRL. pred app-has-class i:term. app-has-class T :- get-TC-of-inst-type T Hd, coq.TC.class? Hd. % input (∀ a, b, c ... => app [A, B, ..., Last]) % returns Last pred get-last i:term, o:term. get-last (prod _ _ Bo) R :- pi x\ get-last (Bo x) R. get-last (app L) R :- std.last L R. % TC preds are on the form tc-[PATH_TO_TC].tc-[TC-Name] pred gref->pred-name i:gref, o:string. gref->pred-name Gr S :- if (is-option-active oTC-clauseNameShortName) (Path = "") (coq.gref->path Gr [Hd | Tl], std.fold Tl Hd (x\acc\r\ r is acc ^ "." ^ x) Path', Path is Path' ^ ".tc-"), % CAVEAT : Non-ascii caractars can't be part of a pred % name, we replace ö with o rex.replace "ö" "o" {coq.gref->id Gr} GrStr, S is "tc-" ^ Path ^ GrStr. pred no-backtrack i:list prop, o:list prop. no-backtrack [] []. no-backtrack [do X | XS] [std.do! [(std.do! X') | XS']] :- !, no-backtrack X X', no-backtrack XS XS'. no-backtrack [X | XS] [std.do! [X | XS']] :- !, no-backtrack XS XS'. pred make-tc i:prop, i:term, i:term, i:list prop, o:prop. make-tc _IsHead Ty Inst Hyp Clause :- coq.safe-dest-app Ty (global TC) TL, gref->pred-name TC TC_Str, std.append TL [Inst] Args, coq.elpi.predicate TC_Str Args Q, if2 (Hyp = []) (Clause = Q) (Hyp = [Hd]) (Clause = (Q :- Hd)) (Clause = (Q :- Hyp)). pred unwrap-prio i:tc-priority, o:int. unwrap-prio (tc-priority-given Prio) Prio. unwrap-prio (tc-priority-computed Prio) Prio. % returns the priority of an instance from the gref of an instance pred get-inst-prio i:gref, o:int. get-inst-prio InstGR Prio :- coq.env.typeof InstGR InstTy, get-TC-of-inst-type InstTy ClassGR, unwrap-prio {coq.TC.get-inst-prio ClassGR InstGR} Prio. pred get-full-path i:gref, o:string. get-full-path Gr Res' :- coq.gref->string Gr Path, coq.env.current-section-path SectionPath, std.fold SectionPath "" (e\acc\r\ r is acc ^ "." ^ e) Res, Res' is Res ^ Path. coq-elpi-2.1.0/apps/tc/examples/000077500000000000000000000000001460156013500164135ustar00rootroot00000000000000coq-elpi-2.1.0/apps/tc/examples/tutorial.v000066400000000000000000000050371460156013500204520ustar00rootroot00000000000000Require Import Bool. From elpi.apps Require Import tc. Class Eqb (T: Type) := { eqb : T -> T -> bool; eqb_leibniz A B: eqb A B = true <-> A = B }. #[refine] Instance eqBool : Eqb bool := { eqb x y := if x then y else negb y }. Proof. intros [] []; intuition. Qed. #[refine] Instance eqProd (A B : Type) : Eqb A -> Eqb B -> Eqb (A * B) := { eqb x y := eqb (fst x) (fst y) && eqb (snd x) (snd y) }. Proof. intros [] []. split. intros; simpl in H. * case (eqb a a0) eqn:aB, (eqb b b0) eqn:bB; try easy. apply pair_equal_spec; destruct e, e0; split. apply eqb_leibniz0; auto. apply eqb_leibniz1; auto. * intros. apply pair_equal_spec in H; destruct H; subst. simpl. apply andb_true_intro; destruct e, e0; split. apply eqb_leibniz0; auto. apply eqb_leibniz1; auto. Qed. TC.Print_instances. TC.Get_class_info Eqb. (* Abstraction of elpi context variable *) Section Foo. Variable (A B: Type) (HA : Eqb A) (HB : Eqb B). #[refine] Global Instance eqProd' : Eqb (A * B) := { eqb x y := eqb (fst x) (fst y) && eqb (snd x) (snd y) }. Proof. intros [] []; simpl; split; intros. apply eqb_leibniz. destruct H. replace (eqb (a, b) (a0, b0)) with (eqb a a0 && eqb b b0); auto. admit. apply andb_true_intro; apply pair_equal_spec in H; split; apply eqb_leibniz; easy. Admitted. (* Here we see that HA and HB are compiled in elpi since their type is a class *) TC.Print_instances Eqb. (* The rules for eqProd' is as follows shorten tc-tutorial.{tc-Eqb}. tc-Eqb {{prod A B}} {{eqProd'}}. Remark: Here A and B are not elpi variables, but the coq variables from the context *) Elpi Print TC.Solver. End Foo. (* On section end the local instances are removed (i.e. HA and HB disappears) and eqProd' is recompiled *) TC.Print_instances Eqb. (* the rules for eqProd' is as follows shorten tc-tutorial.{tc-Eqb}. tc-Eqb {{prod lp:A lp:B}} {{eqProd' lp:A lp:B lp:PA lp:PB}} :- tc-Eqb A PA, tc-Eqb B PB. Remark: Here A and B are elpi variables and PA, PB are the proof that we can prove {{Eqb lp:A}} and {{Eqb lp:B}} *) TC.Get_class_info Eqb. Module Backtrack. Elpi Override TC TC.Solver All. Class NoBacktrack (n: nat). TC.Set_deterministic NoBacktrack. Class A (n: nat). Instance a0 : A 0. Qed. Instance nb0 : NoBacktrack 0. Qed. Instance nb1 : NoBacktrack 1. Qed. Instance a3 n : NoBacktrack n -> A n -> A 3. Qed. Goal A 3. Fail apply _. Abort. Elpi Print TC.Solver. End Backtrack. TC.Print_instances. TC.Get_class_info DecidableClass.Decidable. coq-elpi-2.1.0/apps/tc/src/000077500000000000000000000000001460156013500153645ustar00rootroot00000000000000coq-elpi-2.1.0/apps/tc/src/META.coq-elpi-tc000066400000000000000000000004131460156013500201470ustar00rootroot00000000000000 package "plugin" ( directory = "." requires = "coq-core.plugins.ltac coq-elpi.elpi" archive(byte) = "elpi_tc_plugin.cma" archive(native) = "elpi_tc_plugin.cmxa" plugin(byte) = "elpi_tc_plugin.cma" plugin(native) = "elpi_tc_plugin.cmxs" ) directory = "." coq-elpi-2.1.0/apps/tc/src/coq_elpi_class_tactics_hacked.ml000066400000000000000000001452041460156013500237150ustar00rootroot00000000000000(************************************************************************) (* * The Coq Proof Assistant / The Coq Development Team *) (* v * Copyright INRIA, CNRS and contributors *) (* (unit -> Pp.t) -> unit val get_debug : unit -> int val set_typeclasses_debug : bool -> unit end = struct let typeclasses_debug = ref 0 let set_typeclasses_debug d = (:=) typeclasses_debug (if d then 1 else 0) let get_typeclasses_debug () = if !typeclasses_debug > 0 then true else false let set_typeclasses_verbose = function | None -> typeclasses_debug := 0 | Some n -> typeclasses_debug := n let get_typeclasses_verbose () = if !typeclasses_debug = 0 then None else Some !typeclasses_debug let () = let open Goptions in declare_bool_option { optstage = Summary.Stage.Interp; optdepr = None; optkey = ["Typeclassess";"Debug"]; optread = get_typeclasses_debug; optwrite = set_typeclasses_debug; } let () = let open Goptions in declare_int_option { optstage = Summary.Stage.Interp; optdepr = None; optkey = ["Typeclassess";"Debug";"Verbosity"]; optread = get_typeclasses_verbose; optwrite = set_typeclasses_verbose; } let ppdebug lvl pp = if !typeclasses_debug > lvl then Feedback.msg_debug (pp()) let get_debug () = !typeclasses_debug end open Debug let set_typeclasses_debug = set_typeclasses_debug type search_strategy = Dfs | Bfs let set_typeclasses_strategy = function | Dfs -> Goptions.set_bool_option_value iterative_deepening_opt_name false | Bfs -> Goptions.set_bool_option_value iterative_deepening_opt_name true let pr_ev evs ev = let evi = Evd.find_undefined evs ev in let env = Evd.evar_filtered_env (Global.env ()) evi in Printer.pr_econstr_env env evs (Evd.evar_concl evi) let pr_ev_with_id evs ev = Evar.print ev ++ str " : " ++ pr_ev evs ev (** Typeclasses instance search tactic / eauto *) open Auto open Unification let auto_core_unif_flags st allowed_evars = { modulo_conv_on_closed_terms = Some st; use_metas_eagerly_in_conv_on_closed_terms = true; use_evars_eagerly_in_conv_on_closed_terms = false; modulo_delta = st; modulo_delta_types = st; check_applied_meta_types = false; use_pattern_unification = true; use_meta_bound_pattern_unification = true; allowed_evars; restrict_conv_on_strict_subterms = false; (* ? *) modulo_betaiota = true; modulo_eta = false; } let auto_unif_flags ?(allowed_evars = Evarsolve.AllowedEvars.all) st = let fl = auto_core_unif_flags st allowed_evars in { core_unify_flags = fl; merge_unify_flags = fl; subterm_unify_flags = fl; allow_K_in_toplevel_higher_order_unification = false; resolve_evars = false } let e_give_exact flags h = let open Tacmach in Proofview.Goal.enter begin fun gl -> let env = Proofview.Goal.env gl in let sigma = project gl in let sigma, c = Hints.fresh_hint env sigma h in let (sigma, t1) = Typing.type_of (pf_env gl) sigma c in Proofview.Unsafe.tclEVARS sigma <*> Clenv.unify ~flags ~cv_pb:CUMUL t1 <*> exact_no_check c end let unify_resolve ~with_evars flags h diff = match diff with | None -> Hints.hint_res_pf ~with_evars ~with_classes:false ~flags h | Some (diff, ty) -> let () = assert (Option.is_empty (fst @@ hint_as_term @@ h)) in Proofview.Goal.enter begin fun gl -> let env = Proofview.Goal.env gl in let sigma = Tacmach.project gl in let sigma, c = Hints.fresh_hint env sigma h in let clenv = Clenv.mk_clenv_from_n env sigma diff (c, ty) in Clenv.res_pf ~with_evars ~with_classes:false ~flags clenv end (** Dealing with goals of the form A -> B and hints of the form C -> A -> B. *) let with_prods nprods h f = if get_typeclasses_limit_intros () then Proofview.Goal.enter begin fun gl -> if Option.has_some (fst @@ hint_as_term h) || Int.equal nprods 0 then f None else let sigma = Tacmach.project gl in let ty = Retyping.get_type_of (Proofview.Goal.env gl) sigma (snd @@ hint_as_term h) in let diff = nb_prod sigma ty - nprods in if (>=) diff 0 then f (Some (diff, ty)) else Tacticals.tclZEROMSG (str"Not enough premisses") end else Proofview.Goal.enter begin fun gl -> if Int.equal nprods 0 then f None else Tacticals.tclZEROMSG (str"Not enough premisses") end (** Semantics of type class resolution lemma application: - Use unification to find a well-typed substitution. There might be evars in the goal and the lemma. Evars in the goal can get refined. - Independent evars are turned into goals, whatever their kind is. - Dependent evars of the lemma corresponding to arguments which appear in independent goals or the conclusion are turned into subgoals iff they are of typeclass kind. - The remaining dependent evars not of typeclass type are shelved, and resolution must fill them for it to succeed, otherwise we backtrack. *) let pr_gls sigma gls = prlist_with_sep spc (fun ev -> int (Evar.repr ev) ++ spc () ++ pr_ev sigma ev) gls (** Ensure the dependent subgoals are shelved after an apply/eapply. *) let shelve_dependencies gls = let open Proofview in if CList.is_empty gls then tclUNIT () else tclEVARMAP >>= fun sigma -> ppdebug 1 (fun () -> str" shelving dependent subgoals: " ++ pr_gls sigma gls); shelve_goals gls let hintmap_of env sigma hdc secvars concl = match hdc with | None -> fun db -> ModeMatch (NoMode, Hint_db.map_none ~secvars db) | Some hdc -> fun db -> Hint_db.map_eauto env sigma ~secvars hdc concl db (** Hack to properly solve dependent evars that are typeclasses *) let rec e_trivial_fail_db only_classes db_list local_db secvars = let open Tacticals in let open Tacmach in let trivial_fail = Proofview.Goal.enter begin fun gl -> let env = Proofview.Goal.env gl in let sigma = Tacmach.project gl in let d = NamedDecl.get_id @@ pf_last_hyp gl in let hints = push_resolve_hyp env sigma d local_db in e_trivial_fail_db only_classes db_list hints secvars end in let trivial_resolve = Proofview.Goal.enter begin fun gl -> let tacs = e_trivial_resolve db_list local_db secvars only_classes (pf_env gl) (project gl) (pf_concl gl) in tclFIRST (List.map (fun (x,_,_,_,_) -> x) tacs) end in let tacl = Eauto.e_assumption :: (tclTHEN Tactics.intro trivial_fail :: [trivial_resolve]) in tclSOLVE tacl and e_my_find_search db_list local_db secvars hdc complete only_classes env sigma concl0 = let prods, concl = EConstr.decompose_prod_decls sigma concl0 in let nprods = List.length prods in let allowed_evars = let all = Evarsolve.AllowedEvars.all in match hdc with | Some (hd,_) when only_classes -> begin match Typeclasses.class_info hd with | Some cl -> if cl.cl_strict then let undefined = lazy (Evarutil.undefined_evars_of_term sigma concl) in let allowed evk = not (Evar.Set.mem evk (Lazy.force undefined)) in Evarsolve.AllowedEvars.from_pred allowed else all | None -> all end | _ -> all in let tac_of_hint = fun (flags, h) -> let name = FullHint.name h in let tac = function | Res_pf h -> let tac = with_prods nprods h (unify_resolve ~with_evars:false flags h) in Proofview.tclBIND (Proofview.with_shelf tac) (fun (gls, ()) -> shelve_dependencies gls) | ERes_pf h -> let tac = with_prods nprods h (unify_resolve ~with_evars:true flags h) in Proofview.tclBIND (Proofview.with_shelf tac) (fun (gls, ()) -> shelve_dependencies gls) | Give_exact h -> e_give_exact flags h | Res_pf_THEN_trivial_fail h -> let fst = with_prods nprods h (unify_resolve ~with_evars:true flags h) in let snd = if complete then Tacticals.tclIDTAC else e_trivial_fail_db only_classes db_list local_db secvars in Tacticals.tclTHEN fst snd | Unfold_nth c -> Proofview.tclPROGRESS (unfold_in_concl [AllOccurrences,c]) | Extern (p, tacast) -> conclPattern concl0 p tacast in let tac = FullHint.run h tac in let tac = if complete then Tacticals.tclCOMPLETE tac else tac in let extern = match FullHint.repr h with | Extern _ -> true | _ -> false in (tac, FullHint.priority h, extern, name, lazy (FullHint.print env sigma h)) in let hint_of_db = hintmap_of env sigma hdc secvars concl in let hintl = List.map_filter (fun db -> match hint_of_db db with | ModeMatch (m, l) -> Some (db, m, l) | ModeMismatch -> None) (local_db :: db_list) in (* In case there is a mode mismatch in all the databases we get stuck. Otherwise we consider the hints that match. Recall the local database uses the union of all the modes in the other databases. *) if List.is_empty hintl then None else let hintl = CList.map (fun (db, m, tacs) -> let flags = auto_unif_flags ~allowed_evars (Hint_db.transparent_state db) in m, List.map (fun x -> tac_of_hint (flags, x)) tacs) hintl in let modes, hintl = List.split hintl in let all_mode_match = List.for_all (fun m -> m != NoMode) modes in let hintl = match hintl with (* Optim: only sort if multiple hint sources were involved *) | [hintl] -> hintl | _ -> let hintl = List.flatten hintl in let hintl = List.stable_sort (fun (_, pri1, _, _, _) (_, pri2, _, _, _) -> Int.compare pri1 pri2) hintl in hintl in Some (all_mode_match, hintl) and e_trivial_resolve db_list local_db secvars only_classes env sigma concl = let hd = try Some (decompose_app_bound sigma concl) with Bound -> None in try (match e_my_find_search db_list local_db secvars hd true only_classes env sigma concl with | Some (_,l) -> l | None -> []) with Not_found -> [] let e_possible_resolve db_list local_db secvars only_classes env sigma concl = let hd = try Some (decompose_app_bound sigma concl) with Bound -> None in try e_my_find_search db_list local_db secvars hd false only_classes env sigma concl with Not_found -> Some (true, []) let cut_of_hints h = List.fold_left (fun cut db -> PathOr (Hint_db.cut db, cut)) PathEmpty h let pr_depth l = let rec fmt elts = match elts with | [] -> [] | [n] -> [string_of_int n] | n1::n2::rest -> (string_of_int n1 ^ "." ^ string_of_int n2) :: fmt rest in prlist_with_sep (fun () -> str "-") str (fmt (List.rev l)) let is_Prop env sigma concl = let ty = Retyping.get_type_of env sigma concl in match EConstr.kind sigma ty with | Sort s -> begin match ESorts.kind sigma s with | Prop -> true | _ -> false end | _ -> false let is_unique env sigma concl = try let (cl,u), args = dest_class_app env sigma concl in cl.cl_unique with e when CErrors.noncritical e -> false (** Sort the undefined variables from the least-dependent to most dependent. *) let top_sort evm undefs = let l' = ref [] in let tosee = ref undefs in let cache = Evarutil.create_undefined_evars_cache () in let rec visit ev evi = let evs = Evarutil.filtered_undefined_evars_of_evar_info ~cache evm evi in tosee := Evar.Set.remove ev !tosee; Evar.Set.iter (fun ev -> if Evar.Set.mem ev !tosee then visit ev (Evd.find_undefined evm ev)) evs; l' := ev :: !l'; in while not (Evar.Set.is_empty !tosee) do let ev = Evar.Set.choose !tosee in visit ev (Evd.find_undefined evm ev) done; List.rev !l' (** We transform the evars that are concerned by this resolution (according to predicate p) into goals. Invariant: function p only manipulates and returns undefined evars *) let evars_to_goals p evm = let goals, nongoals = Evar.Set.partition (p evm) (Evd.get_typeclass_evars evm) in if Evar.Set.is_empty goals then None else Some (goals, nongoals) (** Making local hints *) let make_resolve_hyp env sigma st only_classes decl db = let id = NamedDecl.get_id decl in let cty = Evarutil.nf_evar sigma (NamedDecl.get_type decl) in let iscl env ty = let ctx, ar = decompose_prod_decls sigma ty in match EConstr.kind sigma (fst (decompose_app sigma ar)) with | Const (c,_) -> is_class (GlobRef.ConstRef c) | Ind (i,_) -> is_class (GlobRef.IndRef i) | _ -> false in let is_class = iscl env cty in let keep = not only_classes || is_class in if keep then let id = GlobRef.VarRef id in push_resolves env sigma id db else db let make_hints env sigma (modes,st) only_classes sign = let db = Hint_db.add_modes modes @@ Hint_db.empty st true in List.fold_right (fun hyp hints -> let consider = not only_classes || try let t = hyp |> NamedDecl.get_id |> Global.lookup_named |> NamedDecl.get_type in (* Section variable, reindex only if the type changed *) not (EConstr.eq_constr sigma (EConstr.of_constr t) (NamedDecl.get_type hyp)) with Not_found -> true in if consider then make_resolve_hyp env sigma st only_classes hyp hints else hints) sign db module Search = struct type autoinfo = { search_depth : int list; last_tac : Pp.t Lazy.t; search_dep : bool; search_only_classes : bool; search_cut : hints_path; search_hints : hint_db; search_best_effort : bool; } (** Local hints *) let autogoal_cache = Summary.ref ~name:"autogoal_cachee" (DirPath.empty, true, Context.Named.empty, GlobRef.Map.empty, Hint_db.empty TransparentState.full true) let make_autogoal_hints only_classes (modes,st as mst) gl = let env = Proofview.Goal.env gl in let sigma = Proofview.Goal.sigma gl in let sign = EConstr.named_context env in let (dir, onlyc, sign', cached_modes, cached_hints) = !autogoal_cache in let cwd = Lib.cwd () in let eq c1 c2 = EConstr.eq_constr sigma c1 c2 in if DirPath.equal cwd dir && (onlyc == only_classes) && Context.Named.equal eq sign sign' && cached_modes == modes then cached_hints else let hints = make_hints env sigma mst only_classes sign in autogoal_cache := (cwd, only_classes, sign, modes, hints); hints let make_autogoal mst only_classes dep cut best_effort i g = let hints = make_autogoal_hints only_classes mst g in { search_hints = hints; search_depth = [i]; last_tac = lazy (str"none"); search_dep = dep; search_only_classes = only_classes; search_cut = cut; search_best_effort = best_effort } (** In the proof engine failures are represented as exceptions *) exception ReachedLimit exception NoApplicableHint exception StuckGoal (** ReachedLimit has priority over NoApplicableHint to handle iterative deepening: it should fail when no hints are applicable, but go to a deeper depth otherwise. *) let merge_exceptions e e' = match fst e, fst e' with | ReachedLimit, _ -> e | _, ReachedLimit -> e' | _, _ -> e (** Determine if backtracking is needed for this goal. We generally backtrack except in the following (possibly overlapping) cases: - [unique_instances] is [true]. This is the case when the goal's class has [Unique Instances]. - [indep] is [true] and the current goal has no evars. [indep] is generally [true] and only gets set to [false] if the current goal's evar is mentioned in other goals. ([indep] is the negation of [search_dep].) - The current goal is a [Prop] and has no evars. *) let needs_backtrack env evd ~unique_instances ~indep concl = if unique_instances then false else if indep || is_Prop env evd concl then occur_existential evd concl else true exception NonStuckFailure (* exception Backtrack *) let pr_goals s = let open Proofview in if get_debug() > 1 then tclEVARMAP >>= fun sigma -> Unsafe.tclGETGOALS >>= fun gls -> let gls = CList.map Proofview.drop_state gls in let j = List.length gls in let pr_goal gl = pr_ev_with_id sigma gl in Feedback.msg_debug (s ++ int j ++ str" goals:" ++ spc () ++ prlist_with_sep Pp.fnl pr_goal gls); tclUNIT () else tclUNIT () let pr_internal_exception ie = match fst ie with | ReachedLimit -> str "Proof-search reached its limit." | NoApplicableHint -> str "Proof-search failed." | StuckGoal | NonStuckFailure -> str "Proof-search got stuck." | e -> CErrors.iprint ie (* XXX Is this handler needed for something? *) let () = CErrors.register_handler begin function | NonStuckFailure -> Some (str "NonStuckFailure") | NoApplicableHint -> Some (str "NoApplicableHint") | _ -> None end (** For each success of tac1 try tac2. If tac2 raises NonStuckFailure, try the next success of tac1 until depleted. If tac1 finally fails, returns the result of the first tac1 success, if any. *) type goal_status = | IsInitial | IsStuckGoal | IsNonStuckFailure let pr_goal_status = function | IsInitial -> str "initial" | IsStuckGoal -> str "stuck" | IsNonStuckFailure -> str "stuck failure" let pr_search_goal sigma (glid, ev, status, _) = str"Goal " ++ int glid ++ str" evar: " ++ Evar.print ev ++ str " status: " ++ pr_goal_status status let pr_search_goals sigma = prlist_with_sep fnl (pr_search_goal sigma) let search_fixpoint ~best_effort ~allow_out_of_order tacs = let open Pp in let open Proofview in let open Proofview.Notations in let rec fixpoint progress tacs stuck fk = let next (glid, ev, status, tac) tacs stuck = let () = ppdebug 1 (fun () -> str "considering goal " ++ int glid ++ str " of status " ++ pr_goal_status status) in let rec kont = function | Fail ((NonStuckFailure | StuckGoal as exn), info) when allow_out_of_order -> let () = ppdebug 1 (fun () -> str "Goal " ++ int glid ++ str" is stuck or failed without being stuck, trying other tactics.") in let status = match exn with | NonStuckFailure -> IsNonStuckFailure | StuckGoal -> IsStuckGoal | _ -> assert false in cycle 1 (* Puts the first goal last *) <*> fixpoint progress tacs ((glid, ev, status, tac) :: stuck) fk (* Launches the search on the rest of the goals *) | Fail ie -> let () = ppdebug 1 (fun () -> str "Goal " ++ int glid ++ str" has no more solutions, returning exception: " ++ pr_internal_exception ie) in fk ie | Next (res, fk') -> let () = ppdebug 1 (fun () -> str "Goal " ++ int glid ++ str" has a success, continuing resolution") in (* We try to solve the rest of the constraints, and if that fails we backtrack to the next result of tac, etc.... Ultimately if none of the solutions for tac work, we will come back to the failure continuation fk in one of the above cases *) fixpoint true tacs stuck (fun e -> tclCASE (fk' e) >>= kont) in tclCASE tac >>= kont in tclEVARMAP >>= fun sigma -> let () = ppdebug 1 (fun () -> let stuck, failed = List.partition (fun (_, _, status, _) -> status = IsStuckGoal) stuck in str"Calling fixpoint on : " ++ int (List.length tacs) ++ str" initial goals" ++ str", " ++ int (List.length stuck) ++ str" stuck goals" ++ str" and " ++ int (List.length failed) ++ str" non-stuck failures kept" ++ str" with " ++ str(if progress then "" else "no ") ++ str"progress made in this run." ++ fnl () ++ str "Stuck: " ++ pr_search_goals sigma stuck ++ fnl () ++ str "Failed: " ++ pr_search_goals sigma failed ++ fnl () ++ str "Initial: " ++ pr_search_goals sigma tacs) in tclCHECKINTERRUPT <*> match tacs with | tac :: tacs -> next tac tacs stuck | [] -> (* All remaining goals are stuck *) match stuck with | [] -> (* We found a solution! Great, but in case it's not good for the rest of the proof search, we might have other solutions available through fk. *) tclOR (tclUNIT ()) fk | stuck -> if progress then fixpoint false stuck [] fk else (* No progress can be made on the stuck goals arising from this resolution, try a different solution on the non-stuck goals, if any. *) begin tclORELSE (fk (NoApplicableHint, Exninfo.null)) (fun (e, info) -> let () = ppdebug 1 (fun () -> int (List.length stuck) ++ str " remaining goals left, no progress, calling continuation failed") in (* We keep the stuck goals to display to the user *) if best_effort then let stuckgls, failedgls = List.partition (fun (_, _, status, _) -> match status with | IsStuckGoal -> true | IsNonStuckFailure -> false (* There should remain no initial goals at this point *) | IsInitial -> assert false) stuck in pr_goals (str "best_effort is on and remaining goals are: ") <*> (* We shelve the stuck goals but we keep the non-stuck failures in the goal list. This is for compat with Coq 8.12 but might not be the wisest choice in the long run. *) let to_shelve = List.map (fun (glid, ev, _, _) -> ev) stuckgls in let () = ppdebug 1 (fun () -> str "Shelving subgoals: " ++ prlist_with_sep spc Evar.print to_shelve) in Unsafe.tclNEWSHELVED to_shelve else tclZERO ~info e) end in pr_goals (str"Launching resolution fixpoint on ") <*> Unsafe.tclGETGOALS >>= fun gls -> (* We wrap all goals with their associated tactic. It might happen that an initial goal is solved during the resolution of another goal, hence the `tclUNIT` in case there is no goal for the tactic to apply anymore. *) let tacs = List.map2_i (fun i gls tac -> (succ i, Proofview.drop_state gls, IsInitial, tclFOCUS ~nosuchgoal:(tclUNIT ()) 1 1 tac)) 0 gls tacs in fixpoint false tacs [] (fun (e, info) -> tclZERO ~info e) <*> pr_goals (str "Result goals after fixpoint: ") (** The general hint application tactic. tac1 + tac2 .... The choice of OR or ORELSE is determined depending on the dependencies of the goal and the unique/Prop status *) let hints_tac_gl hints info kont gl : unit Proofview.tactic = let open Proofview in let open Proofview.Notations in let env = Goal.env gl in let concl = Goal.concl gl in let sigma = Goal.sigma gl in let unique_instances = is_unique env sigma concl in let indep = not info.search_dep in let backtrack = needs_backtrack env sigma ~unique_instances ~indep concl in let () = ppdebug 0 (fun () -> pr_depth info.search_depth ++ str": looking for " ++ Printer.pr_econstr_env (Goal.env gl) sigma concl ++ (if backtrack then str" with backtracking" else str" without backtracking")) in let secvars = compute_secvars gl in match e_possible_resolve hints info.search_hints secvars info.search_only_classes env sigma concl with | None -> Proofview.tclZERO StuckGoal | Some (all_mode_match, poss) -> (* If no goal depends on the solution of this one or the instances are irrelevant/assumed to be unique, then we don't need to backtrack, as long as no evar appears in the goal This is an overapproximation. Evars could appear in this goal only and not any other *) let ortac = if backtrack then Proofview.tclOR else Proofview.tclORELSE in let idx = ref 1 in let foundone = ref false in let rec onetac e (tac, pat, b, name, pp) tl = let path = match name with | None -> PathAny | Some gr -> PathHints [gr] in let derivs = path_derivate info.search_cut path in let pr_error ie = ppdebug 1 (fun () -> let idx = if fst ie == NoApplicableHint then pred !idx else !idx in let header = pr_depth (idx :: info.search_depth) ++ str": " ++ Lazy.force pp ++ (if !foundone != true then str" on" ++ spc () ++ pr_ev sigma (Proofview.Goal.goal gl) else mt ()) in (header ++ str " failed with: " ++ pr_internal_exception ie)) in let tac_of gls i j = Goal.enter begin fun gl' -> let sigma' = Goal.sigma gl' in let () = ppdebug 0 (fun () -> pr_depth (succ j :: i :: info.search_depth) ++ str" : " ++ pr_ev sigma' (Proofview.Goal.goal gl')) in let eq c1 c2 = EConstr.eq_constr sigma' c1 c2 in let hints' = if b && not (Context.Named.equal eq (Goal.hyps gl') (Goal.hyps gl)) then let st = Hint_db.transparent_state info.search_hints in let modes = Hint_db.modes info.search_hints in make_autogoal_hints info.search_only_classes (modes,st) gl' else info.search_hints in let dep' = info.search_dep || Proofview.unifiable sigma' (Goal.goal gl') gls in let info' = { search_depth = succ j :: i :: info.search_depth; last_tac = pp; search_dep = dep'; search_only_classes = info.search_only_classes; search_hints = hints'; search_cut = derivs; search_best_effort = info.search_best_effort } in kont info' end in let rec result (shelf, ()) i k = foundone := true; Proofview.Unsafe.tclGETGOALS >>= fun gls -> let gls = CList.map Proofview.drop_state gls in let j = List.length gls in let () = ppdebug 0 (fun () -> pr_depth (i :: info.search_depth) ++ str": " ++ Lazy.force pp ++ str" on" ++ spc () ++ pr_ev sigma (Proofview.Goal.goal gl) ++ str", " ++ int j ++ str" subgoal(s)" ++ (Option.cata (fun k -> str " in addition to the first " ++ int k) (mt()) k)) in let res = if j = 0 then tclUNIT () else search_fixpoint ~best_effort:false ~allow_out_of_order:false (List.init j (fun j' -> (tac_of gls i (Option.default 0 k + j')))) in let finish nestedshelf sigma = let filter ev = try let evi = Evd.find_undefined sigma ev in if info.search_only_classes then Some (ev, not (is_class_evar sigma evi)) else Some (ev, true) with Not_found -> None in let remaining = CList.map_filter filter shelf in let () = ppdebug 1 (fun () -> let prunsolved (ev, _) = int (Evar.repr ev) ++ spc () ++ pr_ev sigma ev in let unsolved = prlist_with_sep spc prunsolved remaining in pr_depth (i :: info.search_depth) ++ str": after " ++ Lazy.force pp ++ str" finished, " ++ int (List.length remaining) ++ str " goals are shelved and unsolved ( " ++ unsolved ++ str")") in begin (* Some existentials produced by the original tactic were not solved in the subgoals, turn them into subgoals now. *) let shelved, goals = List.partition (fun (ev, s) -> s) remaining in let shelved = List.map fst shelved @ nestedshelf and goals = List.map fst goals in let () = if not (List.is_empty shelved && List.is_empty goals) then ppdebug 1 (fun () -> str"Adding shelved subgoals to the search: " ++ prlist_with_sep spc (pr_ev sigma) goals ++ str" while shelving " ++ prlist_with_sep spc (pr_ev sigma) shelved) in shelve_goals shelved <*> if List.is_empty goals then tclUNIT () else let make_unresolvables = tclEVARMAP >>= fun sigma -> let sigma = make_unresolvables (fun x -> List.mem_f Evar.equal x goals) sigma in Unsafe.tclEVARS sigma in let goals = CList.map Proofview.with_empty_state goals in with_shelf (make_unresolvables <*> Unsafe.tclNEWGOALS goals) >>= fun s -> result s i (Some (Option.default 0 k + j)) end in with_shelf res >>= fun (sh, ()) -> tclEVARMAP >>= finish sh in if path_matches derivs [] then aux e tl else ortac (with_shelf tac >>= fun s -> let i = !idx in incr idx; result s i None) (fun e' -> (pr_error e'; aux (merge_exceptions e e') tl)) and aux e = function | tac :: tacs -> onetac e tac tacs | [] -> let () = if !foundone == false then ppdebug 0 (fun () -> pr_depth info.search_depth ++ str": no match for " ++ Printer.pr_econstr_env (Goal.env gl) sigma concl ++ str ", " ++ int (List.length poss) ++ str" possibilities") in match e with | (ReachedLimit,ie) -> Proofview.tclZERO ~info:ie ReachedLimit | (StuckGoal,ie) -> Proofview.tclZERO ~info:ie StuckGoal | (NoApplicableHint,ie) -> (* If the constraint abides by the (non-trivial) modes but no solution could be found, we consider it a failed goal, and let proof search proceed on the rest of the constraints, thus giving a more precise error message. *) if all_mode_match && info.search_best_effort then Proofview.tclZERO ~info:ie NonStuckFailure else Proofview.tclZERO ~info:ie NoApplicableHint | (_,ie) -> Proofview.tclZERO ~info:ie NoApplicableHint in if backtrack then aux (NoApplicableHint,Exninfo.null) poss else tclONCE (aux (NoApplicableHint,Exninfo.null) poss) let hints_tac hints info kont : unit Proofview.tactic = Proofview.Goal.enter (fun gl -> hints_tac_gl hints info kont gl) let intro_tac info kont gl = let open Proofview in let env = Goal.env gl in let sigma = Goal.sigma gl in let decl = Tacmach.pf_last_hyp gl in let ldb = make_resolve_hyp env sigma (Hint_db.transparent_state info.search_hints) info.search_only_classes decl info.search_hints in let info' = { info with search_hints = ldb; last_tac = lazy (str"intro"); search_depth = 1 :: 1 :: info.search_depth } in kont info' let intro info kont = Proofview.tclBIND Tactics.intro (fun _ -> Proofview.Goal.enter (fun gl -> intro_tac info kont gl)) let rec search_tac hints limit depth = let kont info = Proofview.numgoals >>= fun i -> let () = ppdebug 1 (fun () -> str "calling eauto recursively at depth " ++ int (succ depth) ++ str " on " ++ int i ++ str " subgoals") in search_tac hints limit (succ depth) info in fun info -> if Int.equal depth (succ limit) then let info = Exninfo.reify () in Proofview.tclZERO ~info ReachedLimit else Proofview.tclOR (hints_tac hints info kont) (fun e -> Proofview.tclOR (intro info kont) (fun e' -> let (e, info) = merge_exceptions e e' in Proofview.tclZERO ~info e)) let search_tac_gl mst only_classes dep hints best_effort depth i sigma gls gl : unit Proofview.tactic = let open Proofview in let dep = dep || Proofview.unifiable sigma (Goal.goal gl) gls in let info = make_autogoal mst only_classes dep (cut_of_hints hints) best_effort i gl in search_tac hints depth 1 info let search_tac mst only_classes best_effort dep hints depth = let open Proofview in let tac sigma gls i = Goal.enter begin fun gl -> search_tac_gl mst only_classes dep hints best_effort depth (succ i) sigma gls gl end in Proofview.Unsafe.tclGETGOALS >>= fun gls -> let gls = CList.map Proofview.drop_state gls in Proofview.tclEVARMAP >>= fun sigma -> let j = List.length gls in search_fixpoint ~best_effort ~allow_out_of_order:true (List.init j (fun i -> tac sigma gls i)) let fix_iterative t = let rec aux depth = Proofview.tclOR (t depth) (function | (ReachedLimit,_) -> aux (succ depth) | (e,ie) -> Proofview.tclZERO ~info:ie e) in aux 1 let fix_iterative_limit limit t = let open Proofview in let rec aux depth = if Int.equal depth (succ limit) then let info = Exninfo.reify () in tclZERO ~info ReachedLimit else tclOR (t depth) (function | (ReachedLimit, _) -> aux (succ depth) | (e,ie) -> Proofview.tclZERO ~info:ie e) in aux 1 let eauto_tac_stuck mst ?(unique=false) ~only_classes ~best_effort ?strategy ~depth ~dep hints = let open Proofview in let tac = let search = search_tac mst only_classes best_effort dep hints in let dfs = match strategy with | None -> not (get_typeclasses_iterative_deepening ()) | Some Dfs -> true | Some Bfs -> false in if dfs then let depth = match depth with None -> -1 | Some d -> d in search depth else match depth with | None -> fix_iterative search | Some l -> fix_iterative_limit l search in let error (e, info) = match e with | ReachedLimit -> Tacticals.tclFAIL ~info (str"Proof search reached its limit") | NoApplicableHint -> Tacticals.tclFAIL ~info (str"Proof search failed" ++ (if Option.is_empty depth then mt() else str" without reaching its limit")) | Proofview.MoreThanOneSuccess -> Tacticals.tclFAIL ~info (str"Proof search failed: " ++ str"more than one success found") | e -> Proofview.tclZERO ~info e in let tac = Proofview.tclOR tac error in let tac = if unique then Proofview.tclEXACTLY_ONCE Proofview.MoreThanOneSuccess tac else tac in with_shelf numgoals >>= fun (initshelf, i) -> let () = ppdebug 1 (fun () -> str"Starting resolution with " ++ int i ++ str" goal(s) under focus and " ++ int (List.length initshelf) ++ str " shelved goal(s)" ++ (if only_classes then str " in only_classes mode" else str " in regular mode") ++ match depth with | None -> str ", unbounded" | Some i -> str ", with depth limit " ++ int i) in tac <*> pr_goals (str "after eauto_tac_stuck: ") let eauto_tac mst ?unique ~only_classes ~best_effort ?strategy ~depth ~dep hints = Hints.wrap_hint_warning @@ (eauto_tac_stuck mst ?unique ~only_classes ~best_effort ?strategy ~depth ~dep hints) let run_on_goals env evm p tac goals nongoals = let goalsl = if get_typeclasses_dependency_order () then top_sort evm goals else Evar.Set.elements goals in let goalsl = List.map Proofview.with_empty_state goalsl in let tac = Proofview.Unsafe.tclNEWGOALS goalsl <*> tac in let evm = Evd.set_typeclass_evars evm Evar.Set.empty in let evm = Evd.push_future_goals evm in let _, pv = Proofview.init evm [] in (* Instance may try to call this before a proof is set up! Thus, give_me_the_proof will fail. Beware! *) let name, poly = (* try * let Proof.{ name; poly } = Proof.data Proof_global.(give_me_the_proof ()) in * name, poly * with | Proof_global.NoCurrentProof -> *) Id.of_string "instance", false in let tac = if get_debug () > 1 then Proofview.Trace.record_info_trace tac else tac in let (), pv', unsafe, info = try Proofview.apply ~name ~poly env tac pv with Logic_monad.TacticFailure _ -> raise Not_found in let () = ppdebug 1 (fun () -> str"The tactic trace is: " ++ hov 0 (Proofview.Trace.pr_info env evm ~lvl:1 info)) in let finished = Proofview.finished pv' in let evm' = Proofview.return pv' in let _, evm' = Evd.pop_future_goals evm' in let () = ppdebug 1 (fun () -> str"Finished resolution with " ++ str(if finished then "a complete" else "an incomplete") ++ str" solution." ++ fnl() ++ str"Old typeclass evars not concerned by this resolution = " ++ hov 0 (prlist_with_sep spc (pr_ev_with_id evm') (Evar.Set.elements (Evd.get_typeclass_evars evm'))) ++ fnl() ++ str"Shelf = " ++ hov 0 (prlist_with_sep spc (pr_ev_with_id evm') (Evar.Set.elements (Evd.get_typeclass_evars evm')))) in let nongoals' = Evar.Set.fold (fun ev acc -> match Evarutil.advance evm' ev with | Some ev -> Evar.Set.add ev acc | None -> acc) (Evar.Set.union goals nongoals) (Evd.get_typeclass_evars evm') in (* FIXME: the need to merge metas seems to come from this being called internally from Unification. It should be handled there instead. *) let evm' = Evd.meta_merge (Evd.meta_list evm) (Evd.clear_metas evm') in let evm' = Evd.set_typeclass_evars evm' nongoals' in let () = ppdebug 1 (fun () -> str"New typeclass evars are: " ++ hov 0 (prlist_with_sep spc (pr_ev_with_id evm') (Evar.Set.elements nongoals'))) in Some (finished, evm') let run_on_evars env evm p tac = match evars_to_goals p evm with | None -> None (* This happens only because there's no evar having p *) | Some (goals, nongoals) -> run_on_goals env evm p tac goals nongoals let evars_eauto env evd depth only_classes ~best_effort unique dep mst hints p = let eauto_tac = eauto_tac_stuck mst ~unique ~only_classes ~best_effort ~depth ~dep:(unique || dep) hints in run_on_evars env evd p eauto_tac (** Typeclasses eauto is an eauto which tries to resolve only goals of typeclass type, and assumes that the initially selected evars in evd are independent of the rest of the evars *) let typeclasses_eauto env evd ?depth unique ~best_effort st hints p = NewProfile.profile "typeclass search" (fun () -> evars_eauto env evd depth true ~best_effort unique false st hints p) () let typeclasses_resolve env evd depth unique ~best_effort p = let db = searchtable_map typeclasses_db in let st = Hint_db.transparent_state db in let modes = Hint_db.modes db in typeclasses_eauto env evd ?depth ~best_effort unique (modes,st) [db] p end let typeclasses_eauto ?(only_classes=false) ?(best_effort=false) ?(st=TransparentState.full) ?strategy ~depth dbs = let dbs = List.map_filter (fun db -> try Some (searchtable_map db) with e when CErrors.noncritical e -> None) dbs in let st = match dbs with x :: _ -> Hint_db.transparent_state x | _ -> st in let modes = List.map Hint_db.modes dbs in let modes = List.fold_left (GlobRef.Map.union (fun _ m1 m2 -> Some (m1@m2))) GlobRef.Map.empty modes in let depth = match depth with None -> get_typeclasses_depth () | Some l -> Some l in Proofview.tclIGNORE (Search.eauto_tac (modes,st) ~only_classes ?strategy ~best_effort ~depth ~dep:true dbs) (* Stuck goals can remain here, we could shelve them, but this way the user can use `solve [typeclasses eauto]` to check there are no stuck goals remaining, or use [typeclasses eauto; shelve] himself. *) (** We compute dependencies via a union-find algorithm. Beware of the imperative effects on the partition structure, it should not be shared, but only used locally. *) module Intpart = Unionfind.Make(Evar.Set)(Evar.Map) let deps_of_constraints cstrs evm p = List.iter (fun (_, _, x, y) -> let evx = Evarutil.undefined_evars_of_term evm x in let evy = Evarutil.undefined_evars_of_term evm y in Intpart.union_set (Evar.Set.union evx evy) p) cstrs let evar_dependencies pred evm p = let cache = Evarutil.create_undefined_evars_cache () in Evd.fold_undefined (fun ev evi _ -> if Evd.is_typeclass_evar evm ev && pred evm ev evi then let evars = Evar.Set.add ev (Evarutil.filtered_undefined_evars_of_evar_info ~cache evm evi) in Intpart.union_set evars p else ()) evm () (** [split_evars] returns groups of undefined evars according to dependencies *) let split_evars pred evm = let p = Intpart.create () in evar_dependencies pred evm p; deps_of_constraints (snd (extract_all_conv_pbs evm)) evm p; Intpart.partition p let is_inference_forced p evd ev = try if Evar.Set.mem ev (Evd.get_typeclass_evars evd) && p ev then let (loc, k) = evar_source (Evd.find_undefined evd ev) in match k with | Evar_kinds.ImplicitArg (_, _, b) -> b | Evar_kinds.QuestionMark _ -> false | _ -> true else true with Not_found -> assert false let is_mandatory p comp evd = Evar.Set.exists (is_inference_forced p evd) comp (** Check if an evar is concerned by the current resolution attempt, (and in particular is in the current component). Invariant : this should only be applied to undefined evars. *) let select_and_update_evars p oevd in_comp evd ev = try if Evd.is_typeclass_evar oevd ev then (in_comp ev && p evd ev (Evd.find_undefined evd ev)) else false with Not_found -> false (** Do we still have unresolved evars that should be resolved ? *) let has_undefined p oevd evd = let check ev evi = p oevd ev in Evar.Map.exists check (Evd.undefined_map evd) let find_undefined p oevd evd = let check ev evi = p oevd ev in Evar.Map.domain (Evar.Map.filter check (Evd.undefined_map evd)) exception Unresolved of evar_map type solver_type = Environ.env -> evar_map -> metavariable option -> prefix_of_inductive_support_flag -> best_effort:prefix_of_inductive_support_flag -> (evar_map -> Evar.t -> prefix_of_inductive_support_flag) -> (prefix_of_inductive_support_flag * evar_map) option (** If [do_split] is [true], we try to separate the problem in several components and then solve them separately *) let resolve_all_evars depth unique env p oevd fail = let () = ppdebug 0 (fun () -> str"Calling typeclass resolution with flags: "++ str"depth = " ++ (match depth with None -> str "∞" | Some d -> int d) ++ str"," ++ str"unique = " ++ bool unique ++ str"," ++ str"fail = " ++ bool fail); ppdebug 2 (fun () -> str"Initial evar map: " ++ Termops.pr_evar_map ~with_univs:!Detyping.print_universes None env oevd) in let split = split_evars p oevd in let split_solver = List.map (Coq_elpi_class_tactics_takeover.handle_takeover Search.typeclasses_resolve env oevd) split in let in_comp comp ev = Evar.Set.mem ev comp in let rec docomp evd = function | [] -> let () = ppdebug 2 (fun () -> str"Final evar map: " ++ Termops.pr_evar_map ~with_univs:!Detyping.print_universes None env evd) in evd | ((solver: solver_type), comp) :: comps -> let p = select_and_update_evars p oevd (in_comp comp) in try (try let res = solver env evd depth ~best_effort:true unique p in match res with | Some (finished, evd') -> if has_undefined p oevd evd' then let () = if finished then ppdebug 1 (fun () -> str"Proof is finished but there remain undefined evars: " ++ prlist_with_sep spc (pr_ev evd') (Evar.Set.elements (find_undefined p oevd evd'))) in raise (Unresolved evd') else docomp evd' comps | None -> docomp evd comps (* No typeclass evars left in this component *) with Not_found -> (* Typeclass resolution failed *) raise (Unresolved evd)) with Unresolved evd' -> if fail && is_mandatory (p evd') comp evd' then (* Unable to satisfy the constraints. *) error_unresolvable env evd' comp else (* Best effort: use the best found solution on this component *) docomp evd' comps in docomp oevd split_solver let initial_select_evars filter = fun evd ev evi -> filter ev (Lazy.from_val (snd (Evd.evar_source evi))) && (* Typeclass evars can contain evars whose conclusion is not yet determined to be a class or not. *) Typeclasses.is_class_evar evd evi let classes_transparent_state () = try Hint_db.transparent_state (searchtable_map typeclasses_db) with Not_found -> TransparentState.empty let resolve_typeclass_evars depth unique env evd filter fail = let evd = try Evarconv.solve_unif_constraints_with_heuristics ~flags:(Evarconv.default_flags_of (classes_transparent_state())) env evd with e when CErrors.noncritical e -> evd in resolve_all_evars depth unique env (initial_select_evars filter) evd fail let solve_inst env evd filter unique fail = let ((), sigma) = Hints.wrap_hint_warning_fun env evd begin fun evd -> (), resolve_typeclass_evars (get_typeclasses_depth ()) unique env evd filter fail end in sigma let () = Typeclasses.set_solve_all_instances solve_inst let resolve_one_typeclass env ?(sigma=Evd.from_env env) concl unique = let (term, sigma) = Hints.wrap_hint_warning_fun env sigma begin fun sigma -> let hints = searchtable_map typeclasses_db in let st = Hint_db.transparent_state hints in let modes = Hint_db.modes hints in let depth = get_typeclasses_depth () in let tac = Tacticals.tclCOMPLETE (Search.eauto_tac (modes,st) ~only_classes:true ~best_effort:false ~depth [hints] ~dep:true) in let entry, pv = Proofview.init sigma [env, concl] in let pv = let name = Names.Id.of_string "legacy_pe" in match Proofview.apply ~name ~poly:false (Global.env ()) tac pv with | (_, final, _, _) -> final | exception (Logic_monad.TacticFailure (Tacticals.FailError _)) -> raise Not_found in let evd = Proofview.return pv in let term = match Proofview.partial_proof entry pv with [t] -> t | _ -> assert false in term, evd end in (sigma, term) let () = Typeclasses.set_solve_one_instance (fun x y z w -> resolve_one_typeclass x ~sigma:y z w) (** Take the head of the arity of a constr. Used in the partial application tactic. *) let rec head_of_constr sigma t = let t = strip_outer_cast sigma t in match EConstr.kind sigma t with | Prod (_,_,c2) -> head_of_constr sigma c2 | LetIn (_,_,_,c2) -> head_of_constr sigma c2 | App (f,args) -> head_of_constr sigma f | _ -> t let head_of_constr h c = Proofview.tclEVARMAP >>= fun sigma -> let c = head_of_constr sigma c in letin_tac None (Name h) c None Locusops.allHyps let not_evar c = Proofview.tclEVARMAP >>= fun sigma -> match EConstr.kind sigma c with | Evar _ -> Tacticals.tclFAIL (str"Evar") | _ -> Proofview.tclUNIT () let is_ground c = let open Tacticals in Proofview.tclEVARMAP >>= fun sigma -> if Evarutil.is_ground_term sigma c then tclIDTAC else tclFAIL (str"Not ground") let autoapply c i = let open Proofview.Notations in Hints.wrap_hint_warning @@ Proofview.Goal.enter begin fun gl -> let hintdb = try Hints.searchtable_map i with Not_found -> CErrors.user_err (Pp.str ("Unknown hint database " ^ i ^ ".")) in let flags = auto_unif_flags (Hints.Hint_db.transparent_state hintdb) in let cty = Tacmach.pf_get_type_of gl c in let env = Proofview.Goal.env gl in let sigma = Proofview.Goal.sigma gl in let ce = Clenv.mk_clenv_from env sigma (c,cty) in Clenv.res_pf ~with_evars:true ~with_classes:false ~flags ce <*> Proofview.tclEVARMAP >>= (fun sigma -> let sigma = Typeclasses.make_unresolvables (fun ev -> Typeclasses.all_goals ev (Lazy.from_val (snd (Evd.evar_source (Evd.find_undefined sigma ev))))) sigma in Proofview.Unsafe.tclEVARS sigma) end let resolve_tc c = let open Proofview.Notations in Proofview.tclENV >>= fun env -> Proofview.tclEVARMAP >>= fun sigma -> let depth = get_typeclasses_depth () in let unique = get_typeclasses_unique_solutions () in let evars = Evarutil.undefined_evars_of_term sigma c in let filter = (fun ev _ -> Evar.Set.mem ev evars) in let fail = true in let sigma = resolve_all_evars depth unique env (initial_select_evars filter) sigma fail in Proofview.Unsafe.tclEVARS sigma coq-elpi-2.1.0/apps/tc/src/coq_elpi_class_tactics_takeover.ml000066400000000000000000000161011460156013500243070ustar00rootroot00000000000000(* license: GNU Lesser General Public License Version 2.1 or later *) (* ------------------------------------------------------------------------- *) open Util open Names open Typeclasses open Elpi module Intpart = Unionfind.Make(Evar.Set)(Evar.Map) open Elpi_plugin open Coq_elpi_utils type override = | AllButFor of Names.GlobRef.Set.t | Only of Names.GlobRef.Set.t type action = | Set of Coq_elpi_utils.qualified_name * override | Add of GlobRef.t list | Rm of GlobRef.t list let elpi_solver = Summary.ref ~name:"tc_takeover" None let takeover action = let open Names.GlobRef in match !elpi_solver, action with | _, Set(solver,mode) -> elpi_solver := Some (mode,solver) | None, (Add _ | Rm _) -> CErrors.user_err Pp.(str "Set the override program first") | Some(AllButFor s,solver), Add grl -> let s' = List.fold_right Set.add grl Set.empty in elpi_solver := Some (AllButFor (Set.diff s s'),solver) | Some(AllButFor s,solver), Rm grl -> let s' = List.fold_right Set.add grl Set.empty in elpi_solver := Some (AllButFor (Set.union s s'),solver) | Some(Only s,solver), Add grl -> let s' = List.fold_right Set.add grl Set.empty in elpi_solver := Some (Only (Set.union s s'),solver) | Some(Only s,solver), Rm grl -> let s' = List.fold_right Set.add grl Set.empty in elpi_solver := Some (Only (Set.diff s s'),solver) let inTakeover = let cache x = takeover x in Libobject.(declare_object (superglobal_object_nodischarge "TC_HACK_OVERRIDE" ~cache ~subst:None)) let takeover isNone l solver = let open Names.GlobRef in let l = List.map Coq_elpi_utils.locate_simple_qualid l in let s = List.fold_right Set.add l Set.empty in let mode = if isNone then Only Set.empty else if Set.is_empty s then AllButFor s else Only s in Lib.add_leaf (inTakeover (Set(solver,mode))) let takeover_add l = let l = List.map Coq_elpi_utils.locate_simple_qualid l in Lib.add_leaf (inTakeover (Add l)) let takeover_rm l = let l = List.map Coq_elpi_utils.locate_simple_qualid l in Lib.add_leaf (inTakeover (Rm l)) let path2str = List.fold_left (fun acc e -> Printf.sprintf "%s/%s" acc e) "" let debug_covered_gref = CDebug.create ~name:"tc_current_gref" () let covered1 env sigma classes i default= let ei = Evd.find_undefined sigma i in let ty = Evd.evar_concl ei in match Typeclasses.class_of_constr env sigma ty with | Some (_,(((cl: typeclass),_),_)) -> let cl_impl = cl.Typeclasses.cl_impl in debug_covered_gref (fun () -> Pp.(str "The current gref is: " ++ Printer.pr_global cl_impl ++ str ", with path: " ++ str (path2str (gr2path cl_impl)))); Names.GlobRef.Set.mem cl_impl classes | None -> default let covered env sigma omode s = match omode with | AllButFor blacklist -> Evar.Set.for_all (fun x -> not (covered1 env sigma blacklist x false)) s | Only whitelist -> Evar.Set.for_all (fun x -> covered1 env sigma whitelist x true) s let debug_handle_takeover = CDebug.create ~name:"handle_takeover" () let elpi_fails program_name = let open Pp in let kind = "tactic/command" in let name = show_qualified_name program_name in CErrors.user_err (strbrk (String.concat " " [ "The elpi"; kind; name ; "failed without giving a specific error message."; "Please report this inconvenience to the authors of the program." ])) let solve_TC program env sigma depth unique ~best_effort filter = let loc = API.Ast.Loc.initial "(unknown)" in let atts = [] in let glss, _ = Evar.Set.partition (filter sigma) (Evd.get_typeclass_evars sigma) in let gls = Evar.Set.elements glss in (* TODO: activate following row to compute new gls this row to make goal sort in msolve *) (* let evar_deps = List.map (fun e -> let evar_info = Evd.find_undefined sigma e in let evar_deps = Evarutil.filtered_undefined_evars_of_evar_info sigma evar_info in e, Evar.Set.elements evar_deps ) gls in *) (* let g = Graph.build_graph evar_deps in *) (* let gls = List.map (fun (e: 'a Graph.node) -> e.name ) (Graph.topo_sort g) in *) let query ~depth state = let state, (loc, q), gls = Coq_elpi_HOAS.goals2query sigma gls loc ~main:(Coq_elpi_HOAS.Solve []) ~in_elpi_tac_arg:Coq_elpi_arg_HOAS.in_elpi_tac ~depth state in let state, qatts = Coq_elpi_vernacular.atts2impl loc Summary.Stage.Interp ~depth state atts q in let state = API.State.set Coq_elpi_builtins.tactic_mode state true in state, (loc, qatts), gls in match Coq_elpi_vernacular.Interp.get_and_compile program with | None -> assert false | Some (cprogram,_) -> match Coq_elpi_vernacular.Interp.run ~static_check:false cprogram (`Fun query) with | API.Execute.Success solution -> let sigma, _, _ = Coq_elpi_HOAS.solution2evd sigma solution glss in Some(false,sigma) | API.Execute.NoMoreSteps -> CErrors.user_err Pp.(str "elpi run out of steps") | API.Execute.Failure -> elpi_fails program | exception (Coq_elpi_utils.LtacFail (level, msg)) -> elpi_fails program let handle_takeover coq_solver env sigma (cl: Intpart.set) = let t = Unix.gettimeofday () in let is_elpi, res = match !elpi_solver with | Some(omode,solver) when covered env sigma omode cl -> true, solve_TC solver | _ -> false, coq_solver in let is_elpi_text = if is_elpi then "Elpi" else "Coq" in debug_handle_takeover (fun () -> let len = (Evar.Set.cardinal cl) in Pp.str @@ Printf.sprintf "handle_takeover for %s - Class : %d - Time : %f" is_elpi_text len (Unix.gettimeofday () -. t)); res, cl let assert_same_generated_TC = Goptions.declare_bool_option_and_ref ~depr:(Deprecation.make ()) ~key:["assert_same_generated_TC"] ~value:false (* let same_solution evd1 evd2 i = let print_discrepancy a b = CErrors.anomaly Pp.(str "Discrepancy in same solution: \n" ++ str"Expected : " ++ a ++ str"\n" ++ str"Found : " ++ b) in let get_types evd t = EConstr.to_constr ~abort_on_undefined_evars:false evd t in try ( let t1 = Evd.find evd1 i in let t2 = Evd.find evd2 i |> Evd.evar_body in match t1, t2 with | Evd.Evar_defined t1, Evd.Evar_defined t2 -> let t1, t2 = get_types evd1 t1, get_types evd2 t2 in let b = try Constr.eq_constr_nounivs t1 t2 with Not_found -> CErrors.anomaly Pp.(str "Discrepancy in same solution: problem with universes") in if (not b) then print_discrepancy (Printer.pr_constr_env (Global.env ()) evd1 t1) (Printer.pr_constr_env (Global.env ()) evd2 t2) else b | Evd.Evar_empty, Evd.Evar_empty -> true | Evd.Evar_defined t1, Evar_empty -> let t1 = get_types evd1 t1 in print_discrepancy (Printer.pr_constr_env (Global.env ()) evd1 t1) (Pp.str "Nothing") | Evd.Evar_empty, Evd.Evar_defined t2 -> let t2 = get_types evd2 t2 in print_discrepancy (Pp.str "Nothing") (Printer.pr_constr_env (Global.env ()) evd2 t2) ) with Not_found -> CErrors.anomaly Pp.(str "Discrepancy in same solution: Not found All") *) (* let same_solution comp evd1 evd2 = Evar.Set.for_all (same_solution evd1 evd2) comp *) coq-elpi-2.1.0/apps/tc/src/coq_elpi_tc_hook.mlg000066400000000000000000000033151460156013500213700ustar00rootroot00000000000000(* license: GNU Lesser General Public License Version 2.1 or later *) (* ------------------------------------------------------------------------- *) DECLARE PLUGIN "coq-elpi-tc.plugin" { open Stdarg open Elpi_plugin open Coq_elpi_arg_syntax open Coq_elpi_tc_register open Coq_elpi_class_tactics_takeover } VERNAC COMMAND EXTEND ElpiTypeclasses CLASSIFIED AS SIDEFF | #[ atts = any_attribute ] [ "Elpi" "Register" "TC" "Compiler" qualified_name(p) ] -> { let () = ignore_unknown_attributes atts in register_observer (fst p, snd p, atts) } | #[ atts = any_attribute ] [ "Elpi" "TC" "Activate" "Observer" qualified_name(p) ] -> { let () = ignore_unknown_attributes atts in activate_observer (snd p) } | #[ atts = any_attribute ] [ "Elpi" "TC" "Deactivate" "Observer" qualified_name(p) ] -> { let () = ignore_unknown_attributes atts in deactivate_observer (snd p) } | #[ atts = any_attribute ] [ "Elpi" "Override" "TC" qualified_name(p) "All" ] -> { let () = ignore_unknown_attributes atts in takeover false [] (snd p) } | #[ atts = any_attribute ] [ "Elpi" "Override" "TC" qualified_name(p) "None" ] -> { let () = ignore_unknown_attributes atts in takeover true [] (snd p) } | #[ atts = any_attribute ] [ "Elpi" "Override" "TC" qualified_name(p) "Only" ne_reference_list(cs) ] -> { let () = ignore_unknown_attributes atts in takeover false cs (snd p) } | #[ atts = any_attribute ] [ "Elpi" "Override" "TC" "+" reference_list(cs) ] -> { let () = ignore_unknown_attributes atts in takeover_add cs } | #[ atts = any_attribute ] [ "Elpi" "Override" "TC" "-" reference_list(cs) ] -> { let () = ignore_unknown_attributes atts in takeover_rm cs } ENDcoq-elpi-2.1.0/apps/tc/src/coq_elpi_tc_register.ml000066400000000000000000000104521460156013500221050ustar00rootroot00000000000000(* license: GNU Lesser General Public License Version 2.1 or later *) (* ------------------------------------------------------------------------- *) open Elpi_plugin open Classes open Coq_elpi_arg_HOAS open Names type qualified_name = Coq_elpi_utils.qualified_name type loc_name_atts = (Loc.t * qualified_name * Attributes.vernac_flags) (* Hack to convert a Coq GlobRef into an elpi string *) let gref2elpi_term (gref: GlobRef.t) : Cmd.raw = let gref_2_string gref = Pp.string_of_ppcmds (Printer.pr_global gref) in Cmd.String (gref_2_string gref) (* TODO: maybe returning an elpi term is cleaner, but this creates a loop in stdppInj test *) (* Cmd.Term (CAst.make @@ Constrexpr.CRef( Libnames.qualid_of_string @@ gref_2_string gref,None)) *) (* Returns the elpi term representing the type class received in argument *) let observer_class (x : Typeclasses.typeclass) : Coq_elpi_arg_HOAS.Cmd.raw list = [gref2elpi_term x.cl_impl] (** Returns the list of Cmd.raw arguments to be passed to the elpi program in charge to compile instances. The arguments are [Inst, TC, Locality, Prio] where: - Inst : is the elpi Term for the current instance - TC : is the elpi Term for the type class implemented by Inst - Locality : is the elpi String [Local|Global|Export] for the locality of Inst - Prio : is the elpi Int N representing the priority of the instance. N is: | -1 if the instance has no user-defined priority | N if the instance has the user-defined priority N *) let observer_instance ({locality; instance; info; class_name} : instance) : Coq_elpi_arg_HOAS.Cmd.raw list = let locality2elpi_string loc = let hint2string = function | Hints.Local -> "Local" | Export -> "Export" | SuperGlobal -> "Global" in Cmd.String (hint2string loc) in let prio2elpi_int (prio: Typeclasses.hint_info) = Cmd.Int (Option.default (-1) prio.hint_priority) in [ gref2elpi_term instance; gref2elpi_term class_name; locality2elpi_string locality; prio2elpi_int info ] let inObservation = Libobject.declare_object @@ Libobject.local_object "TC_HACK_OBSERVER_CLASSES" ~cache:(fun (run,cl) -> run @@ observer_class cl) ~discharge:(fun x -> Some x) let inObservation1 = Libobject.declare_object @@ Libobject.local_object "TC_HACK_OBSERVER_INSTANCE" ~cache:(fun (run,inst) -> run @@ observer_instance inst) ~discharge:(fun (_,inst as x) -> if inst.locality = Local then None else Some x) let observer_evt ((loc, name, atts) : loc_name_atts) (x : Event.t) = let open Coq_elpi_vernacular in let run_program e = Interp.run_program loc name ~syndata:None ~atts e in match x with | Event.NewClass cl -> Lib.add_leaf (inObservation (run_program,cl)) | Event.NewInstance inst -> Lib.add_leaf (inObservation1 (run_program,inst)) module StringMap = Map.Make(String) type observers = observer StringMap.t let observers : observers ref = Summary.ref StringMap.empty ~name:"tc_observers" let build_observer_name (observer : qualified_name) = String.concat "." observer type action = | Create of string * loc_name_atts | Activate of qualified_name | Deactivate of qualified_name let action_manager = function | Create (name, loc_name_atts) -> let observer = Classes.register_observer ~name (observer_evt loc_name_atts) in observers := StringMap.add name observer !observers; Classes.activate_observer observer | Activate observer -> Classes.activate_observer (StringMap.find (build_observer_name observer) !observers) | Deactivate observer -> Classes.deactivate_observer (StringMap.find (build_observer_name observer) !observers) (* Take an action and execute it with the action manager *) let inTakeover = let cache = action_manager in Libobject.(declare_object (superglobal_object_nodischarge "TC_HACK_OBSERVER" ~cache ~subst:None)) (* Adds a new observer in coq and activate it *) let register_observer ((_, name, _) as lna : loc_name_atts) = let obs_name = build_observer_name name in Lib.add_leaf (inTakeover (Create (obs_name, lna))) let activate_observer (observer : qualified_name) = Lib.add_leaf (inTakeover (Activate observer)) let deactivate_observer (observer : qualified_name) = Lib.add_leaf (inTakeover (Deactivate observer))coq-elpi-2.1.0/apps/tc/src/elpi_tc_plugin.mlpack000066400000000000000000000001431460156013500215500ustar00rootroot00000000000000Coq_elpi_tc_register Coq_elpi_class_tactics_takeover Coq_elpi_class_tactics_hacked Coq_elpi_tc_hookcoq-elpi-2.1.0/apps/tc/tests/000077500000000000000000000000001460156013500157375ustar00rootroot00000000000000coq-elpi-2.1.0/apps/tc/tests/WIP/000077500000000000000000000000001460156013500163765ustar00rootroot00000000000000coq-elpi-2.1.0/apps/tc/tests/WIP/add_alias.v000066400000000000000000000011231460156013500204630ustar00rootroot00000000000000From elpi.apps Require Import tc. Elpi Override TC TC.Solver All. Elpi Debug "use-alias". Class foo (A : Type) := f : Type. Global Instance fooNat : foo nat := {f := nat}. Global Instance fooBool : foo bool := {f := bool}. Elpi AddClasses foo. Elpi AddInstances foo. Definition nat' := nat. Goal foo nat. apply _. Qed. Goal foo bool. apply _. Qed. Goal foo nat'. Fail apply _. Abort. Module A. Elpi Accumulate TC.Solver lp:{{ alias {{nat'}} {{nat}}. }}. Goal foo nat'. apply _. Qed. End A. Definition nat'' := nat'. Elpi AddAlias (nat'') (nat'). Goal foo nat''. apply _. Qed. coq-elpi-2.1.0/apps/tc/tests/WIP/cyclicTC_jarl.v000066400000000000000000000035341460156013500212770ustar00rootroot00000000000000From elpi.apps Require Import tc. Elpi Debug "simple-compiler". Set TC NameShortPath. Elpi Override TC TC.Solver All. Class A (T1 : Type). Class B (T1 : Type). Global Instance instA' (T1 : Type) (T2 : Type) : A bool. Qed. Global Instance instA (T1 : Type) `(B T1) : A T1. Qed. Global Instance instB (T1 : Type) `(A T1) : B T1. Qed. Global Instance instB' : B nat . Qed. Elpi Accumulate tc.db lp:{{ pred explored_gref o:gref. pred should_fail i:list gref, i:gref, i:gref. should_fail [] _ _. should_fail [Current | Tl] Current BlackElt :- !, if (std.mem Tl BlackElt) fail true. should_fail [_ | Tl] Current BlackElt :- !, should_fail Tl Current BlackElt. pred already_explored i:gref, i:gref. already_explored Current BlackElt :- std.findall (explored_gref _) As, std.map As (x\r\ x = explored_gref r) As', should_fail As' Current BlackElt. pred get_other i:gref, o:gref. pred under_extra i:gref, i:list prop, o:list prop. under_extra A B C :- std.map B (x\r\ (explored_gref A => x) = r) C1, C = [sigma x\ get_other A x, already_explored A x | C1]. :after "firstHook" make-tc IsHead Ty Inst Hyp Clause :- !, app [global TC | TL] = Ty, gref->pred-name TC TC_Str, std.append TL [Inst] Args, coq.elpi.predicate TC_Str Args Q, if (not IsHead) (Hyp = Hyp') (under_extra TC Hyp Hyp'), Clause = (Q :- Hyp'). }}. Elpi Typecheck TC.Solver. Elpi AddAllClasses. Elpi AddAllInstances. Elpi Command AddRecursivelyDependantTC. Elpi Accumulate Db tc.db. Elpi Accumulate lp:{{ main [trm (global A), trm (global B)] :- coq.elpi.accumulate _ "tc.db" (clause _ _ (get_other A B)), coq.elpi.accumulate _ "tc.db" (clause _ _ (get_other B A)). main L :- coq.say L. }}. Elpi Typecheck. Elpi AddRecursivelyDependantTC (A) (B). Elpi Bound Steps 10000. Check (_ : B bool). Check (_ : A nat). coq-elpi-2.1.0/apps/tc/tests/WIP/eqSimpl.v000066400000000000000000000013201460156013500201730ustar00rootroot00000000000000(* TODO: modes don't work, since, when compiled, instance does not already know them *) Require Import Bool. From elpi.apps Require Import tc. Elpi Debug "simple-compiler". Set TC AddModes. Class MyEqb A : Type := eqb : A -> A -> bool. Global Hint Mode MyEqb + : typeclass_instances. Notation " x == y " := (eqb x y) (no associativity, at level 70). Global Instance eqU : MyEqb unit := { eqb x y := true }. Global Instance eqB : MyEqb bool := { eqb x y := if x then y else negb y }. Global Instance eqP {A B} `{MyEqb A} `{MyEqb B} : MyEqb (A * B) := { eqb x y := (fst x == fst y) && (snd x == snd y) }. Fail Check (fun n m : _ => eqb n m). Goal (tt, (tt, true)) == (tt, (tt, true)) = true. easy. Qed. coq-elpi-2.1.0/apps/tc/tests/WIP/included_proof.v000066400000000000000000000013241460156013500215610ustar00rootroot00000000000000From elpi.apps Require Import tc. Class EqDec (A : Type) := { eqb : A -> A -> bool ; eqb_leibniz : forall x y, eqb x y = true -> x = y }. Generalizable Variables A. Class Ord `(E : EqDec A) := { le : A -> A -> bool }. Class C (A : Set). Elpi Override TC TC.Solver All. Global Instance cInst `{e: EqDec nat} : Ord e -> C nat. Admitted. (* We want to be sure that cInst when compiled has only one hypothesis: (Ord e). We don't want the hypothesis {e : EqDec nat} since it will be verified by (Ord e) *) (* TODO: it should not fail *) Fail Elpi Query TC.Solver lp:{{ compile {{:gref cInst}} _ _ CL, CL = (pi a\ pi b\ (_ :- (Hyp a b))), coq.say Hyp, pi a b\ expected-found (do _) (Hyp a b). }}. coq-elpi-2.1.0/apps/tc/tests/WIP/premisesSort/000077500000000000000000000000001460156013500210755ustar00rootroot00000000000000coq-elpi-2.1.0/apps/tc/tests/WIP/premisesSort/sort1.v000066400000000000000000000006141460156013500223350ustar00rootroot00000000000000From elpi.apps.tc.tests.premisesSort Require Import sortCode. Set Warnings "+elpi". Class A (S : Type). Class B (S : Type). Class C (S : Type). Global Instance A1 : A nat. Admitted. Global Instance A2 : A bool. Admitted. Global Instance B1 : B nat. Admitted. Global Instance C1 {T : Type} `{A T, B T} : C bool. Admitted. (* Simpl example where we do backtrack *) Goal C bool. apply _. Qed.coq-elpi-2.1.0/apps/tc/tests/WIP/premisesSort/sort2.v000066400000000000000000000014021460156013500223320ustar00rootroot00000000000000From elpi.apps.tc.tests.premisesSort Require Import sortCode. Elpi Debug "simple-compiler". Set TC AddModes. Class A (S : Type). Class B (S : Type). Class C (S : Type). Global Hint Mode A + : typeclass_instances. Global Instance A1 : A nat. Admitted. Global Instance B1 : B nat. Admitted. (* Here since the output of T is input in A, we want to reorder the goals such that the proof of be is computed first. Question do we want to raise an error or try to rearrange subgoals in C1. We can try to make an analysis in the compiling phase to raise the error. *) Global Instance C1 {T : Type} `{e : A T, B T} : C bool. Admitted. Elpi AddAllClasses. Elpi AddAllInstances. Elpi Override TC TC.Solver All. Elpi Print TC.Solver. Goal C bool. apply _. Qed.coq-elpi-2.1.0/apps/tc/tests/WIP/premisesSort/sort3.v000066400000000000000000000014061460156013500223370ustar00rootroot00000000000000From elpi.apps.tc.tests.premisesSort Require Import sortCode. Elpi Debug "simple-compiler". Class A (S : Type) (T : Type). Class B (S : Type) (T : Type). Class C (S : Type). Global Hint Mode A + - : typeclass_instances. Global Hint Mode B + - : typeclass_instances. Elpi AddAllClasses. Global Instance A1 : A nat nat. Admitted. Global Instance B1 : B nat nat. Admitted. Global Instance C1 {S T : Type} `{B S T, A T S} : C T. Admitted. Elpi AddAllInstances. Elpi Override TC TC.Solver All. Goal C nat. apply _. Qed. (* Following has a cyclic dependecy, therefore error *) (* Global Instance C2 {S T : Type} `{A T S, B S T} : C bool. Admitted. *) (* Elpi AddInstances C2. *) (* Global Instance C3 {S T : Type} `{B T S} : C S. Admitted. *) (* Elpi AddInstances C3. *)coq-elpi-2.1.0/apps/tc/tests/WIP/premisesSort/sort4.v000066400000000000000000000040531460156013500223410ustar00rootroot00000000000000From elpi.apps.tc.tests.premisesSort Require Import sortCode. Elpi Debug "simple-compiler". Set TC AddModes. Class A (S : Type) (T : Type). Class C (S : Type) (T : Type). Class B (S : Type) (T : Type) `(A S T, C S T) := f : forall (x : S), x = x. Global Hint Mode A + + : typeclass_instances. Global Hint Mode C + + : typeclass_instances. Global Instance A1 : A nat nat. Admitted. Global Instance C1 : C nat nat. Admitted. Global Instance B1 (S : Type) (T : Type) (a : A S T) (c : C S T) : B S T a c. Admitted. Elpi AddAllClasses. Elpi AddAllInstances. Elpi Override TC TC.Solver All. Elpi Accumulate tc.db lp:{{ pred get-inout-sealed-goal i:argument_mode, i:sealed-goal, o:list term. get-inout-sealed-goal AMode (seal (goal _ _ (app [global GR | L]) Sol _)) Res :- tc-mode GR Modes, std.append L [Sol] L', std.map2-filter L' Modes (t\m\r\ pr AMode _ = m, var t, r = t) Res. get-inout-sealed-goal out (seal (goal _ _ _ Sol _)) [Sol]. get-inout-sealed-goal _ _ []. pred sort-goals i:list sealed-goal, o:list int. sort-goals L NL :- std.map-i L (i\x\r\ r = pr x i) LookupList, std.map L (x\r\ sigma M\ get-inout-sealed-goal in x M, r = pr x M) InputModes, std.map L (x\r\ sigma Output Deps\ get-inout-sealed-goal out x Output, std.map-filter InputModes (x\r\ sigma Fst Snd\ pr Fst Snd = x, std.exists Output (v\ std.exists Snd (v1\ occurs_var v v1)), r = Fst) Deps, % O(N^2) sigma Output2Nb Deps2Nb\ std.lookup! LookupList x Output2Nb, std.map Deps (std.lookup! LookupList) Deps2Nb, r = pr Output2Nb Deps2Nb) Graph, coq.toposort Graph NL. pred sort-sealed-goals i:list sealed-goal, o:list sealed-goal. sort-sealed-goals SGL SortedSGL :- sort-goals SGL SGLIndexes, std.map SGLIndexes (x\r\ std.nth x SGL r) SortedSGL. :after "firstHook" msolve L N :- !, sort-sealed-goals L LSort, coq.say LSort, coq.ltac.all (coq.ltac.open solve) LSort N. :after "firstHook" msolve A _ :- coq.say A, sep, fail. }}. Elpi Typecheck TC.Solver. Goal 3 = 3. Fail apply f. Abort.coq-elpi-2.1.0/apps/tc/tests/WIP/premisesSort/sortCode.v000066400000000000000000000112421460156013500230460ustar00rootroot00000000000000 From elpi Require Import tc. Elpi Accumulate tc.db lp:{{ pred get-pattern-fragment i:term, o:list term. pred get-inout i:argument_mode, i:term, o:list term. % TODO: the second arg may not be an (app L) get-inout AMode (app [global GR | L]) Res :- std.drop-last 1 {tc-mode GR} Modes, std.map2-filter L Modes (t\m\r\ pr AMode _ = m, r = t) Res. get-inout _ _ []. pred input-must-have-predecessor i:term, i:term, i:list term, i:list term. input-must-have-predecessor _ _ [] _ :- !. input-must-have-predecessor Instance Premise [Mode | Modes] Premises :- std.exists Premises (p\ sigma MOut\ get-inout out p MOut, std.mem MOut Mode), input-must-have-predecessor Instance Premise Modes Premises. input-must-have-predecessor Instance Premise [Mode | _] _ :- coq.error "Input mode" Mode "of" Premise "cannot be inferred from the other premises of the instance" Instance. % CurrentType is the type of the current instance to get its input variables, % These variables should not create edges in the graph pred sort-hypothesis i:term, i:term, i:list term, o:list int. sort-hypothesis Instance (app [_ | InputCurrentType]) L NL :- std.map-i L (i\x\r\ r = pr x i) LookupList, std.map L (premise\r\ sigma M M'\ get-inout in premise M, std.filter M (x\ not (std.mem InputCurrentType x)) M', input-must-have-predecessor Instance premise M' L, r = pr premise M') InputModes, % foreach goal, we associate those goals having a dependency on it, % in particular a goal G2 depends on G1 if a variable V is in % output mode for G1 and in input mode for G2 (the dependency graph will % and edge going from G1 to G2 : G1 -> G2) std.map L (x\r\ sigma Output Deps\ % O(N^3 * check of occurs) % the list of variable in input of the current goal G get-inout out x Output, % for each output modes of all goals, we keep those having an output % which exists in the input variable of G std.map-filter InputModes (x\r\ sigma Fst Snd\ pr Fst Snd = x, std.exists Output (v\ std.exists Snd (v1\ occurs v v1)), r = Fst) Deps, % O(N^2) sigma Output2Nb Deps2Nb\ std.lookup! LookupList x Output2Nb, std.map Deps (std.lookup! LookupList) Deps2Nb, r = pr Output2Nb Deps2Nb) Graph, coq.toposort Graph NL. pred sort-and-compile-premises i:term, i:term, i:list term, i:list term, i:prop, o:list prop. sort-and-compile-premises Instance CurrentType Types Vars IsPositive Premises :- sort-hypothesis Instance CurrentType Types TypesSortedIndexes, % O (n^3) % std.map-i Types (i\e\r\ r = i) TypesSortedIndexes, std.map TypesSortedIndexes (x\r\ std.nth x Vars r) SortedVars, % O (n^2) std.map TypesSortedIndexes (x\r\ std.nth x Types r) SortedTypes, % O (n^2) std.map2-filter SortedTypes SortedVars (t\v\r\ compile-aux1 t v [] [] [] (not IsPositive) false r _) Premises. pred compile-aux1 i:term, i:term, i:list term, i:list univ, i:list term, i:prop, i:prop, o:prop, o:bool. :name "compiler-aux:start" compile-aux1 Ty I [] [X | XS] [] IsPositive IsHead (pi x\ C x) IsLeaf :- !, pi x\ copy (sort (typ X)) (sort (typ x)) => copy Ty (Ty1 x), compile-aux1 (Ty1 x) I [] XS [] IsPositive IsHead (C x) IsLeaf. compile-aux1 (prod N T F) I ListVar [] Types IsPositive IsHead Clause ff :- !, (if IsPositive (Clause = pi x\ C x) (Clause = (pi x\ decl x N T => C x))), pi p\ sigma Type\ if (app-has-class T, not (occurs p (F p))) (Type = T) (Type = app []), compile-aux1 (F p) I [p | ListVar] [] [Type | Types] IsPositive IsHead (C p) _. :if "simple-compiler" % TODO: here we don't do pattern fragment unification compile-aux1 Ty I ListVar [] Types IsPositive IsHead Clause tt :- !, sort-and-compile-premises I Ty Types ListVar IsPositive Premises, coq.mk-app I {std.rev ListVar} AppInst, make-tc IsHead Ty AppInst Premises Clause. compile-aux1 Ty I ListVar [] Types IsPositive IsHead Clause tt :- !, sort-and-compile-premises I Ty Types ListVar IsPositive Premises, coq.mk-app I {std.rev ListVar} AppInst, std.append {get-pattern-fragment Ty} {get-pattern-fragment AppInst} Term-to-be-fixed, std.fold Term-to-be-fixed 0 (e\acc\r\ sigma L X\ e = app X, std.length X L, r is acc + L - 1) Len, if (IsPositive) (IsPositiveBool = tt) (IsPositiveBool = ff), remove-ho-unification IsHead IsPositiveBool Len Ty AppInst Premises Term-to-be-fixed [] [] [] [] [] Clause. :after "firstHook" compile-aux Ty Inst _Premises _VarAcc UnivL IsPositive IsHead Clause NoPremises :- !, compile-aux1 Ty Inst [] UnivL [] (IsPositive = tt, true; false) IsHead Clause NoPremises. }}. Elpi Typecheck TC.Solver.coq-elpi-2.1.0/apps/tc/tests/auto_compile.v000066400000000000000000000032241460156013500206070ustar00rootroot00000000000000From elpi.apps Require Import tc. Elpi Override TC TC.Solver All. Require Import Bool. (* TODO: How to add the #[deterministic] pragma in front of the class? *) (* #[deterministic] Class A (T : Type) := {succ : T -> T}. *) Class A (T : Type) := {succ : T -> T}. #[local] Instance B : A nat := {succ n := S n}. Instance C : A bool := {succ b := negb b}. Instance Prod (X Y: Type) `(A X, A Y) : A (X * Y) := {succ b := match b with (a, b) => (succ a, succ b) end}. Elpi Accumulate TC.Solver lp:{{ :after "firstHook" solve _ _ :- coq.say "Solving in ELPI!", fail. }}. Goal A (nat * (nat * bool)). apply _. Qed. Module M. Class B (T : nat). Section A. Instance X : B 1. Qed. Goal B 1. apply _. Qed. Global Instance Y : B 2. Qed. Goal B 2. apply _. Qed. End A. Goal B 1. Proof. Fail apply _. Abort. Goal B 2. Proof. apply _. Qed. Section B. Variable V : nat. Global Instance Z : `(B 0) -> B V. Qed. Global Instance W : B 0. Qed. End B. Goal B 0. apply _. Qed. Goal B 10. apply _. Qed. End M. Goal M.B 1. apply M.X. Qed. Goal M.B 0. apply _. Qed. Goal M.B 10. apply _. Qed. Elpi Query TC.Solver lp:{{ % Small test for instance order sigma I L\ std.findall (instance _ _ _) I, std.map-filter I (x\y\ x = instance _ y {{:gref M.B}}) [{{:gref M.W}}, {{:gref M.Y}}, {{:gref M.Z}}]. }}. Module S. Class Cl (i: nat). #[local] Instance Cl1 : Cl 1. Qed. #[global] Instance Cl2 : Cl 2. Qed. #[export] Instance Cl3 : Cl 3. Qed. End S. Elpi Override TC TC.Solver None. Goal S.Cl 1 /\ S.Cl 2 /\ S.Cl 3. Proof. split. all:cycle 1. split. apply _. Fail apply _. Import S. apply _. Fail apply _. Abort.coq-elpi-2.1.0/apps/tc/tests/bigTest.v000066400000000000000000002345631460156013500175440ustar00rootroot00000000000000From elpi.apps Require Import tc. Elpi Override TC TC.Solver All. (** This file collects type class interfaces, notations, and general theorems that are used throughout the whole development. Most importantly it contains abstract interfaces for ordered structures, sets, and various other data structures. *) (* We want to ensure that [le] and [lt] refer to operations on [nat]. These two functions being defined both in [Coq.Bool] and in [Coq.Peano], we must export [Coq.Peano] later than any export of [Coq.Bool]. *) (* We also want to ensure that notations from [Coq.Utf8] take precedence over the ones of [Coq.Peano] (see Coq PR#12950), so we import [Utf8] last. *) From Coq Require Export Morphisms RelationClasses List Bool Setoid Peano Utf8. From Coq Require Import Permutation. Export ListNotations. From Coq.Program Require Export Basics Syntax. TC.AddAllClasses. TC.AddAllInstances. (** This notation is necessary to prevent [length] from being printed as [strings.length] if strings.v is imported and later base.v. See also strings.v and https://gitlab.mpi-sws.org/iris/stdpp/-/merge_requests/144 and https://gitlab.mpi-sws.org/iris/stdpp/-/merge_requests/129. *) Notation length := Datatypes.length. (** * Enable implicit generalization. *) (** This option enables implicit generalization in arguments of the form [`{...}] (i.e., anonymous arguments). Unfortunately, it also enables implicit generalization in [Instance]. We think that the fact that both behaviors are coupled together is a [bug in Coq](https://github.com/coq/coq/issues/6030). *) Global Generalizable All Variables. (** * Tweak program *) (** 1. Since we only use Program to solve logical side-conditions, they should always be made Opaque, otherwise we end up with performance problems due to Coq blindly unfolding them. Note that in most cases we use [Next Obligation. (* ... *) Qed.], for which this option does not matter. However, sometimes we write things like [Solve Obligations with naive_solver (* ... *)], and then the obligations should surely be opaque. *) Global Unset Transparent Obligations. (** 2. Do not let Program automatically simplify obligations. The default obligation tactic is [Tactics.program_simpl], which, among other things, introduces all variables and gives them fresh names. As such, it becomes impossible to refer to hypotheses in a robust way. *) Global Obligation Tactic := idtac. (** 3. Hide obligations and unsealing lemmas from the results of the [Search] commands. *) Add Search Blacklist "_obligation_". Add Search Blacklist "_unseal". (** * Sealing off definitions *) #[projections(primitive=yes)] Record seal {A} (f : A) := { unseal : A; seal_eq : unseal = f }. Global Arguments unseal {_ _} _ : assert. Global Arguments seal_eq {_ _} _ : assert. (** * Solving type class instances *) (** The tactic [tc_solve] is used to solve type class goals by invoking type class search. It is similar to [apply _], but it is more robust since it does not affect unrelated goals/evars due to https://github.com/coq/coq/issues/6583. The tactic [tc_solve] is particularly useful when building custom tactics that need tight control over when type class search is invoked. In Iris, many of the proof mode tactics make use of [notypeclasses refine] and use [tc_solve] to manually invoke type class search. Note that [typeclasses eauto] is multi-success. That means, whenever subsequent tactics fail, it will backtrack to [typeclasses eauto] to try the next type class instance. This is almost always undesired and can lead to poor performance and horrible error messages. Hence, we wrap it in a [once]. *) Ltac tc_solve := solve [once (typeclasses eauto)]. (** * Non-backtracking type classes *) (** The type class [TCNoBackTrack P] can be used to establish [P] without ever backtracking on the instance of [P] that has been found. Backtracking may normally happen when [P] contains evars that could be instanciated in different ways depending on which instance is picked, and type class search somewhere else depends on this evar. The proper way of handling this would be by setting Coq's option `Typeclasses Unique Instances`. However, this option seems to be broken, see Coq issue #6714. See https://gitlab.mpi-sws.org/FP/iris-coq/merge_requests/112 for a rationale of this type class. *) Class TCNoBackTrack (P : Prop) := TCNoBackTrack_intro { tc_no_backtrack : P }. Global Hint Extern 0 (TCNoBackTrack _) => notypeclasses refine (TCNoBackTrack_intro _ _); tc_solve : typeclass_instances. (* A conditional at the type class level. Note that [TCIf P Q R] is not the same as [TCOr (TCAnd P Q) R]: the latter will backtrack to [R] if it fails to establish [Q], i.e. does not have the behavior of a conditional. Furthermore, note that [TCOr (TCAnd P Q) (TCAnd (TCNot P) R)] would not work; we generally would not be able to prove the negation of [P]. *) Inductive TCIf (P Q R : Prop) : Prop := | TCIf_true : P → Q → TCIf P Q R | TCIf_false : R → TCIf P Q R. Existing Class TCIf. Global Hint Extern 0 (TCIf _ _ _) => first [notypeclasses refine (TCIf_true _ _ _ _ _); [tc_solve|] |notypeclasses refine (TCIf_false _ _ _ _)] : typeclass_instances. (** * Typeclass opaque definitions *) (** The constant [tc_opaque] is used to make definitions opaque for just type class search. Note that [simpl] is set up to always unfold [tc_opaque]. *) Definition tc_opaque {A} (x : A) : A := x. Global Typeclasses Opaque tc_opaque. Global Arguments tc_opaque {_} _ /. (** Below we define type class versions of the common logical operators. It is important to note that we duplicate the definitions, and do not declare the existing logical operators as type classes. That is, we do not say: Existing Class or. Existing Class and. If we could define the existing logical operators as classes, there is no way of disambiguating whether a premise of a lemma should be solved by type class resolution or not. These classes are useful for two purposes: writing complicated type class premises in a more concise way, and for efficiency. For example, using the [Or] class, instead of defining two instances [P → Q1 → R] and [P → Q2 → R] we could have one instance [P → Or Q1 Q2 → R]. When we declare the instance that way, we avoid the need to derive [P] twice. *) Inductive TCOr (P1 P2 : Prop) : Prop := | TCOr_l : P1 → TCOr P1 P2 | TCOr_r : P2 → TCOr P1 P2. Existing Class TCOr. Global Existing Instance TCOr_l | 9. Global Existing Instance TCOr_r | 10. Global Hint Mode TCOr ! ! : typeclass_instances. Inductive TCAnd (P1 P2 : Prop) : Prop := TCAnd_intro : P1 → P2 → TCAnd P1 P2. Existing Class TCAnd. Global Existing Instance TCAnd_intro. Global Hint Mode TCAnd ! ! : typeclass_instances. Inductive TCTrue : Prop := TCTrue_intro : TCTrue. Existing Class TCTrue. Global Existing Instance TCTrue_intro. (** The class [TCFalse] is not stricly necessary as one could also use [False]. However, users might expect that TCFalse exists and if it does not, it can cause hard to diagnose bugs due to automatic generalization. *) Inductive TCFalse : Prop :=. Existing Class TCFalse. (** The class [TCUnless] can be used to check that search for [P] fails. This is useful as a guard for certain instances together with classes like [TCFastDone] (see [tactics.v]) to prevent infinite loops (e.g. when saturating the context). *) Notation TCUnless P := (TCIf P TCFalse TCTrue). Inductive TCForall {A} (P : A → Prop) : list A → Prop := | TCForall_nil : TCForall P [] | TCForall_cons x xs : P x → TCForall P xs → TCForall P (x :: xs). Existing Class TCForall. Global Existing Instance TCForall_nil. Global Existing Instance TCForall_cons. Global Hint Mode TCForall ! ! ! : typeclass_instances. (** The class [TCForall2 P l k] is commonly used to transform an input list [l] into an output list [k], or the converse. Therefore there are two modes, either [l] input and [k] output, or [k] input and [l] input. *) Inductive TCForall2 {A B} (P : A → B → Prop) : list A → list B → Prop := | TCForall2_nil : TCForall2 P [] [] | TCForall2_cons x y xs ys : P x y → TCForall2 P xs ys → TCForall2 P (x :: xs) (y :: ys). Existing Class TCForall2. Global Existing Instance TCForall2_nil. Global Existing Instance TCForall2_cons. Global Hint Mode TCForall2 ! ! ! ! - : typeclass_instances. Global Hint Mode TCForall2 ! ! ! - ! : typeclass_instances. Inductive TCExists {A} (P : A → Prop) : list A → Prop := | TCExists_cons_hd x l : P x → TCExists P (x :: l) | TCExists_cons_tl x l: TCExists P l → TCExists P (x :: l). Existing Class TCExists. Global Existing Instance TCExists_cons_hd | 10. Global Existing Instance TCExists_cons_tl | 20. Global Hint Mode TCExists ! ! ! : typeclass_instances. Inductive TCElemOf {A} (x : A) : list A → Prop := | TCElemOf_here xs : TCElemOf x (x :: xs) | TCElemOf_further y xs : TCElemOf x xs → TCElemOf x (y :: xs). Existing Class TCElemOf. Global Existing Instance TCElemOf_here. Global Existing Instance TCElemOf_further. Global Hint Mode TCElemOf ! ! ! : typeclass_instances. (** The intended use of [TCEq x y] is to use [x] as input and [y] as output, but this is not enforced. We use output mode [-] (instead of [!]) for [x] to ensure that type class search succeed on goals like [TCEq (if ? then e1 else e2) ?y], see https://gitlab.mpi-sws.org/iris/iris/merge_requests/391 for a use case. Mode [-] is harmless, the only instance of [TCEq] is [TCEq_refl] below, so we cannot create loops. *) Inductive TCEq {A} (x : A) : A → Prop := TCEq_refl : TCEq x x. Existing Class TCEq. Global Existing Instance TCEq_refl. Global Hint Mode TCEq ! - - : typeclass_instances. Lemma TCEq_eq {A} (x1 x2 : A) : TCEq x1 x2 ↔ x1 = x2. Proof. split; destruct 1; reflexivity. Qed. (** The [TCSimpl x y] type class is similar to [TCEq] but performs [simpl] before proving the goal by reflexivity. Similar to [TCEq], the argument [x] is the input and [y] the output. When solving [TCEq x y], the argument [x] should be a concrete term and [y] an evar for the [simpl]ed result. *) Class TCSimpl {A} (x x' : A) := TCSimpl_TCEq : TCEq x x'. Global Hint Extern 0 (TCSimpl _ _) => (* Since the second argument should be an evar, we can call [simpl] on the whole goal. *) simpl; notypeclasses refine (TCEq_refl _) : typeclass_instances. Global Hint Mode TCSimpl ! - - : typeclass_instances. Lemma TCSimpl_eq {A} (x1 x2 : A) : TCSimpl x1 x2 ↔ x1 = x2. Proof. apply TCEq_eq. Qed. Inductive TCDiag {A} (C : A → Prop) : A → A → Prop := | TCDiag_diag x : C x → TCDiag C x x. Existing Class TCDiag. Global Existing Instance TCDiag_diag. Global Hint Mode TCDiag ! ! ! - : typeclass_instances. Global Hint Mode TCDiag ! ! - ! : typeclass_instances. (** Given a proposition [P] that is a type class, [tc_to_bool P] will return [true] iff there is an instance of [P]. It is often useful in Ltac programming, where one can do [lazymatch tc_to_bool P with true => .. | false => .. end]. *) Definition tc_to_bool (P : Prop) {p : bool} `{TCIf P (TCEq p true) (TCEq p false)} : bool := p. (** Throughout this development we use [stdpp_scope] for all general purpose notations that do not belong to a more specific scope. *) Declare Scope stdpp_scope. Delimit Scope stdpp_scope with stdpp. Global Open Scope stdpp_scope. (** Change [True] and [False] into notations in order to enable overloading. We will use this to give [True] and [False] a different interpretation for embedded logics. *) Notation "'True'" := True (format "True") : type_scope. Notation "'False'" := False (format "False") : type_scope. (** Change [forall] into a notation in order to enable overloading. *) Notation "'forall' x .. y , P" := (forall x, .. (forall y, P) ..) (at level 200, x binder, y binder, right associativity, only parsing) : type_scope. (** * Equality *) (** Introduce some Haskell style like notations. *) Notation "(=)" := eq (only parsing) : stdpp_scope. Notation "( x =.)" := (eq x) (only parsing) : stdpp_scope. Notation "(.= x )" := (λ y, eq y x) (only parsing) : stdpp_scope. Notation "(≠)" := (λ x y, x ≠ y) (only parsing) : stdpp_scope. Notation "( x ≠.)" := (λ y, x ≠ y) (only parsing) : stdpp_scope. Notation "(.≠ x )" := (λ y, y ≠ x) (only parsing) : stdpp_scope. Infix "=@{ A }" := (@eq A) (at level 70, only parsing, no associativity) : stdpp_scope. Notation "(=@{ A } )" := (@eq A) (only parsing) : stdpp_scope. Notation "(≠@{ A } )" := (λ X Y, ¬X =@{A} Y) (only parsing) : stdpp_scope. Notation "X ≠@{ A } Y":= (¬X =@{ A } Y) (at level 70, only parsing, no associativity) : stdpp_scope. Global Hint Extern 0 (_ = _) => reflexivity : core. Global Hint Extern 100 (_ ≠ _) => discriminate : core. Global Instance: ∀ A, PreOrder (=@{A}). Proof. split; repeat intro; congruence. Qed. (** ** Setoid equality *) (** We define an operational type class for setoid equality, i.e., the "canonical" equivalence for a type. The typeclass is tied to the \equiv symbol. This is based on (Spitters/van der Weegen, 2011). *) Class Equiv A := equiv: relation A. Global Hint Mode Equiv ! : typeclass_instances. (** We instruct setoid rewriting to infer [equiv] as a relation on type [A] when needed. This allows setoid_rewrite to solve constraints of shape [Proper (eq ==> ?R) f] using [Proper (eq ==> (equiv (A:=A))) f] when an equivalence relation is available on type [A]. We put this instance at level 150 so it does not take precedence over Coq's stdlib instances, favoring inference of [eq] (all Coq functions are automatically morphisms for [eq]). We have [eq] (at 100) < [≡] (at 150) < [⊑] (at 200). *) Global Instance equiv_rewrite_relation `{Equiv A} : RewriteRelation (@equiv A _) | 150 := {}. Infix "≡" := equiv (at level 70, no associativity) : stdpp_scope. Infix "≡@{ A }" := (@equiv A _) (at level 70, only parsing, no associativity) : stdpp_scope. Notation "(≡)" := equiv (only parsing) : stdpp_scope. Notation "( X ≡.)" := (equiv X) (only parsing) : stdpp_scope. Notation "(.≡ X )" := (λ Y, Y ≡ X) (only parsing) : stdpp_scope. Notation "(≢)" := (λ X Y, ¬X ≡ Y) (only parsing) : stdpp_scope. Notation "X ≢ Y":= (¬X ≡ Y) (at level 70, no associativity) : stdpp_scope. Notation "( X ≢.)" := (λ Y, X ≢ Y) (only parsing) : stdpp_scope. Notation "(.≢ X )" := (λ Y, Y ≢ X) (only parsing) : stdpp_scope. Notation "(≡@{ A } )" := (@equiv A _) (only parsing) : stdpp_scope. Notation "(≢@{ A } )" := (λ X Y, ¬X ≡@{A} Y) (only parsing) : stdpp_scope. Notation "X ≢@{ A } Y":= (¬X ≡@{ A } Y) (at level 70, only parsing, no associativity) : stdpp_scope. (** The type class [LeibnizEquiv] collects setoid equalities that coincide with Leibniz equality. We provide the tactic [fold_leibniz] to transform such setoid equalities into Leibniz equalities, and [unfold_leibniz] for the reverse. Various std++ tactics assume that this class is only instantiated if [≡] is an equivalence relation. *) Class LeibnizEquiv A `{Equiv A} := leibniz_equiv (x y : A) : x ≡ y → x = y. Global Hint Mode LeibnizEquiv ! ! : typeclass_instances. Lemma leibniz_equiv_iff `{LeibnizEquiv A, !Reflexive (≡@{A})} (x y : A) : x ≡ y ↔ x = y. Proof. split; [apply leibniz_equiv|]. intros ->; reflexivity. Qed. Ltac fold_leibniz := repeat match goal with | H : context [ _ ≡@{?A} _ ] |- _ => setoid_rewrite (leibniz_equiv_iff (A:=A)) in H | |- context [ _ ≡@{?A} _ ] => setoid_rewrite (leibniz_equiv_iff (A:=A)) end. Ltac unfold_leibniz := repeat match goal with | H : context [ _ =@{?A} _ ] |- _ => setoid_rewrite <-(leibniz_equiv_iff (A:=A)) in H | |- context [ _ =@{?A} _ ] => setoid_rewrite <-(leibniz_equiv_iff (A:=A)) end. Definition equivL {A} : Equiv A := (=). (** A [Params f n] instance forces the setoid rewriting mechanism not to rewrite in the first [n] arguments of the function [f]. We will declare such instances for all operational type classes in this development. *) Global Instance: Params (@equiv) 2 := {}. (** The following instance forces [setoid_replace] to use setoid equality (for types that have an [Equiv] instance) rather than the standard Leibniz equality. *) Global Instance equiv_default_relation `{Equiv A} : DefaultRelation (≡@{A}) | 3 := {}. Global Hint Extern 0 (_ ≡ _) => reflexivity : core. Global Hint Extern 0 (_ ≡ _) => symmetry; assumption : core. (** * Type classes *) (** ** Decidable propositions *) (** This type class by (Spitters/van der Weegen, 2011) collects decidable propositions. *) Class Decision (P : Prop) := decide : {P} + {¬P}. Global Hint Mode Decision ! : typeclass_instances. Global Arguments decide _ {_} : simpl never, assert. (** Although [RelDecision R] is just [∀ x y, Decision (R x y)], we make this an explicit class instead of a notation for two reasons: - It allows us to control [Hint Mode] more precisely. In particular, if it were defined as a notation, the above [Hint Mode] for [Decision] would not prevent diverging instance search when looking for [RelDecision (@eq ?A)], which would result in it looking for [Decision (@eq ?A x y)], i.e. an instance where the head position of [Decision] is not en evar. - We use it to avoid inefficient computation due to eager evaluation of propositions by [vm_compute]. This inefficiency arises for example if [(x = y) := (f x = f y)]. Since [decide (x = y)] evaluates to [decide (f x = f y)], this would then lead to evaluation of [f x] and [f y]. Using the [RelDecision], the [f] is hidden under a lambda, which prevents unnecessary evaluation. *) Class RelDecision {A B} (R : A → B → Prop) := decide_rel x y :> Decision (R x y). Global Hint Mode RelDecision ! ! ! : typeclass_instances. Global Arguments decide_rel {_ _} _ {_} _ _ : simpl never, assert. Notation EqDecision A := (RelDecision (=@{A})). (** ** Inhabited types *) (** This type class collects types that are inhabited. *) Class Inhabited (A : Type) : Type := populate { inhabitant : A }. Global Hint Mode Inhabited ! : typeclass_instances. Global Arguments populate {_} _ : assert. (** ** Proof irrelevant types *) (** This type class collects types that are proof irrelevant. That means, all elements of the type are equal. We use this notion only used for propositions, but by universe polymorphism we can generalize it. *) Class ProofIrrel (A : Type) : Prop := proof_irrel (x y : A) : x = y. Global Hint Mode ProofIrrel ! : typeclass_instances. (** ** Common properties *) (** These operational type classes allow us to refer to common mathematical properties in a generic way. For example, for injectivity of [(k ++.)] it allows us to write [inj (k ++.)] instead of [app_inv_head k]. *) Class Inj {A B} (R : relation A) (S : relation B) (f : A → B) : Prop := inj x y : S (f x) (f y) → R x y. Class Inj2 {A B C} (R1 : relation A) (R2 : relation B) (S : relation C) (f : A → B → C) : Prop := inj2 x1 x2 y1 y2 : S (f x1 x2) (f y1 y2) → R1 x1 y1 ∧ R2 x2 y2. Class Cancel {A B} (S : relation B) (f : A → B) (g : B → A) : Prop := cancel x : S (f (g x)) x. Class Surj {A B} (R : relation B) (f : A → B) := surj y : ∃ x, R (f x) y. Class IdemP {A} (R : relation A) (f : A → A → A) : Prop := idemp x : R (f x x) x. Class Comm {A B} (R : relation A) (f : B → B → A) : Prop := comm x y : R (f x y) (f y x). Class LeftId {A} (R : relation A) (i : A) (f : A → A → A) : Prop := left_id x : R (f i x) x. Class RightId {A} (R : relation A) (i : A) (f : A → A → A) : Prop := right_id x : R (f x i) x. Class Assoc {A} (R : relation A) (f : A → A → A) : Prop := assoc x y z : R (f x (f y z)) (f (f x y) z). Class LeftAbsorb {A} (R : relation A) (i : A) (f : A → A → A) : Prop := left_absorb x : R (f i x) i. Class RightAbsorb {A} (R : relation A) (i : A) (f : A → A → A) : Prop := right_absorb x : R (f x i) i. Class AntiSymm {A} (R S : relation A) : Prop := anti_symm x y : S x y → S y x → R x y. Class Total {A} (R : relation A) := total x y : R x y ∨ R y x. Class Trichotomy {A} (R : relation A) := trichotomy x y : R x y ∨ x = y ∨ R y x. Class TrichotomyT {A} (R : relation A) := trichotomyT x y : {R x y} + {x = y} + {R y x}. Notation Involutive R f := (Cancel R f f). Lemma involutive {A} {R : relation A} (f : A → A) `{Involutive R f} x : R (f (f x)) x. Proof. auto. Qed. Global Arguments irreflexivity {_} _ {_} _ _ : assert. Global Arguments inj {_ _ _ _} _ {_} _ _ _ : assert. Global Arguments inj2 {_ _ _ _ _ _} _ {_} _ _ _ _ _: assert. Global Arguments cancel {_ _ _} _ _ {_} _ : assert. Global Arguments surj {_ _ _} _ {_} _ : assert. Global Arguments idemp {_ _} _ {_} _ : assert. Global Arguments comm {_ _ _} _ {_} _ _ : assert. Global Arguments left_id {_ _} _ _ {_} _ : assert. Global Arguments right_id {_ _} _ _ {_} _ : assert. Global Arguments assoc {_ _} _ {_} _ _ _ : assert. Global Arguments left_absorb {_ _} _ _ {_} _ : assert. Global Arguments right_absorb {_ _} _ _ {_} _ : assert. Global Arguments anti_symm {_ _} _ {_} _ _ _ _ : assert. Global Arguments total {_} _ {_} _ _ : assert. Global Arguments trichotomy {_} _ {_} _ _ : assert. Global Arguments trichotomyT {_} _ {_} _ _ : assert. Lemma not_symmetry `{R : relation A, !Symmetric R} x y : ¬R x y → ¬R y x. Proof. intuition. Qed. Lemma symmetry_iff `(R : relation A) `{!Symmetric R} x y : R x y ↔ R y x. Proof. intuition. Qed. Lemma not_inj `{Inj A B R R' f} x y : ¬R x y → ¬R' (f x) (f y). Proof. intuition. Qed. Lemma not_inj2_1 `{Inj2 A B C R R' R'' f} x1 x2 y1 y2 : ¬R x1 x2 → ¬R'' (f x1 y1) (f x2 y2). Proof. intros HR HR''. destruct (inj2 f x1 y1 x2 y2); auto. Qed. Lemma not_inj2_2 `{Inj2 A B C R R' R'' f} x1 x2 y1 y2 : ¬R' y1 y2 → ¬R'' (f x1 y1) (f x2 y2). Proof. intros HR' HR''. destruct (inj2 f x1 y1 x2 y2); auto. Qed. Lemma inj_iff {A B} {R : relation A} {S : relation B} (f : A → B) `{!Inj R S f} `{!Proper (R ==> S) f} x y : S (f x) (f y) ↔ R x y. Proof. firstorder. Qed. Global Instance inj2_inj_1 `{Inj2 A B C R1 R2 R3 f} y : Inj R1 R3 (λ x, f x y). Proof. repeat intro; edestruct (inj2 f); eauto. Qed. Global Instance inj2_inj_2 `{Inj2 A B C R1 R2 R3 f} x : Inj R2 R3 (f x). Proof. repeat intro; edestruct (inj2 f); eauto. Qed. Elpi Override TC - ProperProxy. Lemma cancel_inj `{Cancel A B R1 f g, !Equivalence R1, !Proper (R2 ==> R1) f} : Inj R1 R2 g. Proof. intros x y E. rewrite <-(cancel f g x), <-(cancel f g y), E. reflexivity. Qed. Lemma cancel_surj `{Cancel A B R1 f g} : Surj R1 f. Proof. intros y. exists (g y). auto. Qed. (** The following lemmas are specific versions of the projections of the above type classes for Leibniz equality. These lemmas allow us to enforce Coq not to use the setoid rewriting mechanism. *) Lemma idemp_L {A} f `{!@IdemP A (=) f} x : f x x = x. Proof. auto. Qed. Lemma comm_L {A B} f `{!@Comm A B (=) f} x y : f x y = f y x. Proof. auto. Qed. Lemma left_id_L {A} i f `{!@LeftId A (=) i f} x : f i x = x. Proof. auto. Qed. Lemma right_id_L {A} i f `{!@RightId A (=) i f} x : f x i = x. Proof. auto. Qed. Lemma assoc_L {A} f `{!@Assoc A (=) f} x y z : f x (f y z) = f (f x y) z. Proof. auto. Qed. Lemma left_absorb_L {A} i f `{!@LeftAbsorb A (=) i f} x : f i x = i. Proof. auto. Qed. Lemma right_absorb_L {A} i f `{!@RightAbsorb A (=) i f} x : f x i = i. Proof. auto. Qed. (** ** Generic orders *) (** The classes [PreOrder], [PartialOrder], and [TotalOrder] use an arbitrary relation [R] instead of [⊆] to support multiple orders on the same type. *) Definition strict {A} (R : relation A) : relation A := λ X Y, R X Y ∧ ¬R Y X. Global Instance: Params (@strict) 2 := {}. Class PartialOrder {A} (R : relation A) : Prop := { partial_order_pre :> PreOrder R; partial_order_anti_symm :> AntiSymm (=) R }. Global Hint Mode PartialOrder ! ! : typeclass_instances. Class TotalOrder {A} (R : relation A) : Prop := { total_order_partial :> PartialOrder R; total_order_trichotomy :> Trichotomy (strict R) }. Global Hint Mode TotalOrder ! ! : typeclass_instances. (** * Logic *) Global Instance prop_inhabited : Inhabited Prop := populate True. Notation "(∧)" := and (only parsing) : stdpp_scope. Notation "( A ∧.)" := (and A) (only parsing) : stdpp_scope. Notation "(.∧ B )" := (λ A, A ∧ B) (only parsing) : stdpp_scope. Notation "(∨)" := or (only parsing) : stdpp_scope. Notation "( A ∨.)" := (or A) (only parsing) : stdpp_scope. Notation "(.∨ B )" := (λ A, A ∨ B) (only parsing) : stdpp_scope. Notation "(↔)" := iff (only parsing) : stdpp_scope. Notation "( A ↔.)" := (iff A) (only parsing) : stdpp_scope. Notation "(.↔ B )" := (λ A, A ↔ B) (only parsing) : stdpp_scope. Global Hint Extern 0 (_ ↔ _) => reflexivity : core. Global Hint Extern 0 (_ ↔ _) => symmetry; assumption : core. Lemma or_l P Q : ¬Q → P ∨ Q ↔ P. Proof. tauto. Qed. Lemma or_r P Q : ¬P → P ∨ Q ↔ Q. Proof. tauto. Qed. Lemma and_wlog_l (P Q : Prop) : (Q → P) → Q → (P ∧ Q). Proof. tauto. Qed. Lemma and_wlog_r (P Q : Prop) : P → (P → Q) → (P ∧ Q). Proof. tauto. Qed. Lemma impl_transitive (P Q R : Prop) : (P → Q) → (Q → R) → (P → R). Proof. tauto. Qed. Lemma forall_proper {A} (P Q : A → Prop) : (∀ x, P x ↔ Q x) → (∀ x, P x) ↔ (∀ x, Q x). Proof. firstorder. Qed. Lemma exist_proper {A} (P Q : A → Prop) : (∀ x, P x ↔ Q x) → (∃ x, P x) ↔ (∃ x, Q x). Proof. firstorder. Qed. Global Instance eq_comm {A} : Comm (↔) (=@{A}). Proof. red; intuition. Qed. Global Instance flip_eq_comm {A} : Comm (↔) (λ x y, y =@{A} x). Proof. red; intuition. Qed. Global Instance iff_comm : Comm (↔) (↔). Proof. red; intuition. Qed. Global Instance and_comm : Comm (↔) (∧). Proof. red; intuition. Qed. Global Instance and_assoc : Assoc (↔) (∧). Proof. red; intuition. Qed. Global Instance and_idemp : IdemP (↔) (∧). Proof. red; intuition. Qed. Global Instance or_comm : Comm (↔) (∨). Proof. red; intuition. Qed. Global Instance or_assoc : Assoc (↔) (∨). Proof. red; intuition. Qed. Global Instance or_idemp : IdemP (↔) (∨). Proof. red; intuition. Qed. Global Instance True_and : LeftId (↔) True (∧). Proof. red; intuition. Qed. Global Instance and_True : RightId (↔) True (∧). Proof. red; intuition. Qed. Global Instance False_and : LeftAbsorb (↔) False (∧). Proof. red; intuition. Qed. Global Instance and_False : RightAbsorb (↔) False (∧). Proof. red; intuition. Qed. Global Instance False_or : LeftId (↔) False (∨). Proof. red; intuition. Qed. Global Instance or_False : RightId (↔) False (∨). Proof. red; intuition. Qed. Global Instance True_or : LeftAbsorb (↔) True (∨). Proof. red; intuition. Qed. Global Instance or_True : RightAbsorb (↔) True (∨). Proof. red; intuition. Qed. Global Instance True_impl : LeftId (↔) True impl. Proof. unfold impl. red; intuition. Qed. Global Instance impl_True : RightAbsorb (↔) True impl. Proof. unfold impl. red; intuition. Qed. (** * Common data types *) (** ** Functions *) Notation "(→)" := (λ A B, A → B) (only parsing) : stdpp_scope. Notation "( A →.)" := (λ B, A → B) (only parsing) : stdpp_scope. Notation "(.→ B )" := (λ A, A → B) (only parsing) : stdpp_scope. Notation "t $ r" := (t r) (at level 65, right associativity, only parsing) : stdpp_scope. Notation "($)" := (λ f x, f x) (only parsing) : stdpp_scope. Notation "(.$ x )" := (λ f, f x) (only parsing) : stdpp_scope. Infix "∘" := compose : stdpp_scope. Notation "(∘)" := compose (only parsing) : stdpp_scope. Notation "( f ∘.)" := (compose f) (only parsing) : stdpp_scope. Notation "(.∘ f )" := (λ g, compose g f) (only parsing) : stdpp_scope. Global Instance impl_inhabited {A} `{Inhabited B} : Inhabited (A → B) := populate (λ _, inhabitant). (** Ensure that [simpl] unfolds [id], [compose], and [flip] when fully applied. *) Global Arguments id _ _ / : assert. Global Arguments compose _ _ _ _ _ _ / : assert. Global Arguments flip _ _ _ _ _ _ / : assert. Global Arguments const _ _ _ _ / : assert. Global Typeclasses Transparent id compose flip const. Definition fun_map {A A' B B'} (f: A' → A) (g: B → B') (h : A → B) : A' → B' := g ∘ h ∘ f. Global Instance const_proper `{R1 : relation A, R2 : relation B} (x : B) : Reflexive R2 → Proper (R1 ==> R2) (λ _, x). Proof. intros ? y1 y2; reflexivity. Qed. Global Instance id_inj {A} : Inj (=) (=) (@id A). Proof. intros ??; auto. Qed. Global Instance compose_inj {A B C} R1 R2 R3 (f : A → B) (g : B → C) : Inj R1 R2 f → Inj R2 R3 g → Inj R1 R3 (g ∘ f). Proof. red; intuition. Qed. Global Instance id_surj {A} : Surj (=) (@id A). Proof. intros y; exists y; reflexivity. Qed. Global Instance compose_surj {A B C} R (f : A → B) (g : B → C) : Surj (=) f → Surj R g → Surj R (g ∘ f). Proof. intros ?? x. unfold compose. destruct (surj g x) as [y ?]. destruct (surj f y) as [z ?]. exists z. congruence. Qed. Global Instance const2_comm {A B} (x : B) : Comm (=) (λ _ _ : A, x). Proof. intros ?; reflexivity. Qed. Global Instance const2_assoc {A} (x : A) : Assoc (=) (λ _ _ : A, x). Proof. intros ???; reflexivity. Qed. Global Instance id1_assoc {A} : Assoc (=) (λ x _ : A, x). Proof. intros ???; reflexivity. Qed. Global Instance id2_assoc {A} : Assoc (=) (λ _ x : A, x). Proof. intros ???; reflexivity. Qed. Global Instance id1_idemp {A} : IdemP (=) (λ x _ : A, x). Proof. intros ?; reflexivity. Qed. Global Instance id2_idemp {A} : IdemP (=) (λ _ x : A, x). Proof. intros ?; reflexivity. Qed. (** ** Lists *) Global Instance list_inhabited {A} : Inhabited (list A) := populate []. Definition zip_with {A B C} (f : A → B → C) : list A → list B → list C := fix go l1 l2 := match l1, l2 with x1 :: l1, x2 :: l2 => f x1 x2 :: go l1 l2 | _ , _ => [] end. Notation zip := (zip_with pair). (** ** Booleans *) (** The following coercion allows us to use Booleans as propositions. *) Coercion Is_true : bool >-> Sortclass. Global Hint Unfold Is_true : core. Global Hint Immediate Is_true_eq_left : core. Global Hint Resolve orb_prop_intro andb_prop_intro : core. Notation "(&&)" := andb (only parsing). Notation "(||)" := orb (only parsing). Infix "&&*" := (zip_with (&&)) (at level 40). Infix "||*" := (zip_with (||)) (at level 50). Global Instance bool_inhabated : Inhabited bool := populate true. Definition bool_le (β1 β2 : bool) : Prop := negb β1 || β2. Infix "=.>" := bool_le (at level 70). Infix "=.>*" := (Forall2 bool_le) (at level 70). Global Instance: PartialOrder bool_le. Proof. repeat split; repeat intros [|]; compute; tauto. Qed. Lemma andb_True b1 b2 : b1 && b2 ↔ b1 ∧ b2. Proof. destruct b1, b2; simpl; tauto. Qed. Lemma orb_True b1 b2 : b1 || b2 ↔ b1 ∨ b2. Proof. destruct b1, b2; simpl; tauto. Qed. Lemma negb_True b : negb b ↔ ¬b. Proof. destruct b; simpl; tauto. Qed. Lemma Is_true_true (b : bool) : b ↔ b = true. Proof. now destruct b. Qed. Lemma Is_true_true_1 (b : bool) : b → b = true. Proof. apply Is_true_true. Qed. Lemma Is_true_true_2 (b : bool) : b = true → b. Proof. apply Is_true_true. Qed. Lemma Is_true_false (b : bool) : ¬ b ↔ b = false. Proof. now destruct b; simpl. Qed. Lemma Is_true_false_1 (b : bool) : ¬b → b = false. Proof. apply Is_true_false. Qed. Lemma Is_true_false_2 (b : bool) : b = false → ¬b. Proof. apply Is_true_false. Qed. (** ** Unit *) Global Instance unit_equiv : Equiv unit := λ _ _, True. Global Instance unit_equivalence : Equivalence (≡@{unit}). Proof. repeat split. Qed. Global Instance unit_leibniz : LeibnizEquiv unit. Proof. intros [] []; reflexivity. Qed. Global Instance unit_inhabited: Inhabited unit := populate (). (** ** Empty *) Global Instance Empty_set_equiv : Equiv Empty_set := λ _ _, True. Global Instance Empty_set_equivalence : Equivalence (≡@{Empty_set}). Proof. repeat split. Qed. Global Instance Empty_set_leibniz : LeibnizEquiv Empty_set. Proof. intros [] []; reflexivity. Qed. (** ** Products *) Notation "( x ,.)" := (pair x) (only parsing) : stdpp_scope. Notation "(., y )" := (λ x, (x,y)) (only parsing) : stdpp_scope. Notation "p .1" := (fst p) (at level 2, left associativity, format "p .1"). Notation "p .2" := (snd p) (at level 2, left associativity, format "p .2"). Global Instance: Params (@pair) 2 := {}. Global Instance: Params (@fst) 2 := {}. Global Instance: Params (@snd) 2 := {}. Global Instance: Params (@curry) 3 := {}. Global Instance: Params (@uncurry) 3 := {}. Definition uncurry3 {A B C D} (f : A → B → C → D) (p : A * B * C) : D := let '(a,b,c) := p in f a b c. Global Instance: Params (@uncurry3) 4 := {}. Definition uncurry4 {A B C D E} (f : A → B → C → D → E) (p : A * B * C * D) : E := let '(a,b,c,d) := p in f a b c d. Global Instance: Params (@uncurry4) 5 := {}. Definition curry3 {A B C D} (f : A * B * C → D) (a : A) (b : B) (c : C) : D := f (a, b, c). Global Instance: Params (@curry3) 4 := {}. Definition curry4 {A B C D E} (f : A * B * C * D → E) (a : A) (b : B) (c : C) (d : D) : E := f (a, b, c, d). Global Instance: Params (@curry4) 5 := {}. Definition prod_map {A A' B B'} (f: A → A') (g: B → B') (p : A * B) : A' * B' := (f (p.1), g (p.2)). Global Instance: Params (@prod_map) 4 := {}. Global Arguments prod_map {_ _ _ _} _ _ !_ / : assert. Definition prod_zip {A A' A'' B B' B''} (f : A → A' → A'') (g : B → B' → B'') (p : A * B) (q : A' * B') : A'' * B'' := (f (p.1) (q.1), g (p.2) (q.2)). Global Instance: Params (@prod_zip) 6 := {}. Global Arguments prod_zip {_ _ _ _ _ _} _ _ !_ !_ / : assert. Definition prod_swap {A B} (p : A * B) : B * A := (p.2, p.1). Global Arguments prod_swap {_ _} !_ /. Global Instance: Params (@prod_swap) 2 := {}. Global Instance prod_inhabited {A B} (iA : Inhabited A) (iB : Inhabited B) : Inhabited (A * B) := match iA, iB with populate x, populate y => populate (x,y) end. (** Note that we need eta for products for the [uncurry_curry] lemmas to hold in non-applied form ([uncurry (curry f) = f]). *) Lemma curry_uncurry {A B C} (f : A → B → C) : curry (uncurry f) = f. Proof. reflexivity. Qed. Lemma uncurry_curry {A B C} (f : A * B → C) p : uncurry (curry f) p = f p. Proof. destruct p; reflexivity. Qed. Lemma curry3_uncurry3 {A B C D} (f : A → B → C → D) : curry3 (uncurry3 f) = f. Proof. reflexivity. Qed. Lemma uncurry3_curry3 {A B C D} (f : A * B * C → D) p : uncurry3 (curry3 f) p = f p. Proof. destruct p as [[??] ?]; reflexivity. Qed. Lemma curry4_uncurry4 {A B C D E} (f : A → B → C → D → E) : curry4 (uncurry4 f) = f. Proof. reflexivity. Qed. Lemma uncurry4_curry4 {A B C D E} (f : A * B * C * D → E) p : uncurry4 (curry4 f) p = f p. Proof. destruct p as [[[??] ?] ?]; reflexivity. Qed. (** [pair_eq] as a name is more consistent with our usual naming. *) Lemma pair_eq {A B} (a1 a2 : A) (b1 b2 : B) : (a1, b1) = (a2, b2) ↔ a1 = a2 ∧ b1 = b2. Proof. apply pair_equal_spec. Qed. Global Instance pair_inj {A B} : Inj2 (=) (=) (=) (@pair A B). Proof. injection 1; auto. Qed. Global Instance prod_map_inj {A A' B B'} (f : A → A') (g : B → B') : Inj (=) (=) f → Inj (=) (=) g → Inj (=) (=) (prod_map f g). Proof. intros ?? [??] [??] ?; simpl in *; f_equal; [apply (inj f)|apply (inj g)]; congruence. Qed. Elpi Override TC - ProperProxy Proper. Global Instance prod_swap_cancel {A B} : Cancel (=) (@prod_swap A B) (@prod_swap B A). Proof. intros [??]; reflexivity. Qed. Global Instance prod_swap_inj {A B} : Inj (=) (=) (@prod_swap A B). Proof. apply cancel_inj. Qed. Global Instance prod_swap_surj {A B} : Surj (=) (@prod_swap A B). Proof. apply cancel_surj. Qed. Definition prod_relation {A B} (R1 : relation A) (R2 : relation B) : relation (A * B) := λ x y, R1 (x.1) (y.1) ∧ R2 (x.2) (y.2). Section prod_relation. Context `{RA : relation A, RB : relation B}. Global Instance prod_relation_refl : Reflexive RA → Reflexive RB → Reflexive (prod_relation RA RB). Proof. firstorder eauto. Qed. Global Instance prod_relation_sym : Symmetric RA → Symmetric RB → Symmetric (prod_relation RA RB). Proof. firstorder eauto. Qed. Global Instance prod_relation_trans : Transitive RA → Transitive RB → Transitive (prod_relation RA RB). Proof. firstorder eauto. Qed. Global Instance prod_relation_equiv : Equivalence RA → Equivalence RB → Equivalence (prod_relation RA RB). Proof. split; apply _. Qed. Global Instance pair_proper' : Proper (RA ==> RB ==> prod_relation RA RB) pair. Proof. firstorder eauto. Qed. Global Instance pair_inj' : Inj2 RA RB (prod_relation RA RB) pair. Proof. inversion_clear 1; eauto. Qed. Global Instance fst_proper' : Proper (prod_relation RA RB ==> RA) fst. Proof. firstorder eauto. Qed. Global Instance snd_proper' : Proper (prod_relation RA RB ==> RB) snd. Proof. firstorder eauto. Qed. Global Instance prod_swap_proper' : Proper (prod_relation RA RB ==> prod_relation RB RA) prod_swap. Proof. firstorder eauto. Qed. Global Instance curry_proper' `{RC : relation C} : Proper ((prod_relation RA RB ==> RC) ==> RA ==> RB ==> RC) curry. Proof. firstorder eauto. Qed. Global Instance uncurry_proper' `{RC : relation C} : Proper ((RA ==> RB ==> RC) ==> prod_relation RA RB ==> RC) uncurry. Proof. intros f1 f2 Hf [x1 y1] [x2 y2] []; apply Hf; assumption. Qed. Global Instance curry3_proper' `{RC : relation C, RD : relation D} : Proper ((prod_relation (prod_relation RA RB) RC ==> RD) ==> RA ==> RB ==> RC ==> RD) curry3. Proof. firstorder eauto. Qed. Global Instance uncurry3_proper' `{RC : relation C, RD : relation D} : Proper ((RA ==> RB ==> RC ==> RD) ==> prod_relation (prod_relation RA RB) RC ==> RD) uncurry3. Proof. intros f1 f2 Hf [[??] ?] [[??] ?] [[??] ?]; apply Hf; assumption. Qed. Global Instance curry4_proper' `{RC : relation C, RD : relation D, RE : relation E} : Proper ((prod_relation (prod_relation (prod_relation RA RB) RC) RD ==> RE) ==> RA ==> RB ==> RC ==> RD ==> RE) curry4. Proof. firstorder eauto. Qed. Global Instance uncurry4_proper' `{RC : relation C, RD : relation D, RE : relation E} : Proper ((RA ==> RB ==> RC ==> RD ==> RE) ==> prod_relation (prod_relation (prod_relation RA RB) RC) RD ==> RE) uncurry4. Proof. intros f1 f2 Hf [[[??] ?] ?] [[[??] ?] ?] [[[??] ?] ?]; apply Hf; assumption. Qed. End prod_relation. Global Instance prod_equiv `{Equiv A,Equiv B} : Equiv (A * B) := prod_relation (≡) (≡). (** Below we make [prod_equiv] type class opaque, so we first lift all instances *) Section prod_setoid. Context `{Equiv A, Equiv B}. Elpi Accumulate TC.Solver lp:{{ shorten tc-Coq.Classes.RelationClasses.{tc-Equivalence}. :after "lastHook" tc-Equivalence A RA R :- RA = {{@equiv _ (@prod_equiv _ _ _ _)}}, RA' = {{@prod_relation _ _ _ _}}, coq.unify-eq RA RA' ok, % coq.say A RA, tc-Equivalence A RA' R. }}. (* Elpi Typecheck TC.Solver. *) Global Instance prod_equivalence@{i} (C D: Type@{i}) `{Equiv C, Equiv D}: @Equivalence C (≡@{C}) → @Equivalence D (≡@{D}) → @Equivalence (C * D) (≡@{C * D}) := _. Elpi Accumulate TC.Solver lp:{{ pred remove_equiv_prod_equiv i:term, o:term. remove_equiv_prod_equiv T1 T3 :- T1 = {{@equiv _ (@prod_equiv _ _ _ _)}}, !, T2 = {{@prod_relation lp:F lp:G lp:A lp:B}}, coq.unify-eq T1 T2 ok, remove_equiv_prod_equiv A X, remove_equiv_prod_equiv B Y, {{@prod_relation lp:F lp:G lp:X lp:Y}} = T3. remove_equiv_prod_equiv (app L1) (app L2) :- !, std.map L1 remove_equiv_prod_equiv L2. remove_equiv_prod_equiv A A. shorten tc-Coq.Classes.Morphisms.{tc-Proper}. :after "lastHook" tc-Proper A B C R :- B = {{ @respectful _ _ _ _ }}, remove_equiv_prod_equiv B B1, tc-Proper A B1 C R. tc-Proper A {{@respectful lp:K1 lp:K2 lp:B1 (@respectful lp:K3 lp:K4 lp:B2 lp:B3)}} C S :- C1 = {{ @equiv _ _ }}, C2 = {{ @equiv _ _ }}, C3 = {{ @prod_relation _ _ _ _ }}, coq.unify-eq B1 C1 ok, coq.unify-eq B2 C2 ok, coq.unify-eq B3 C3 ok, tc-Proper A {{@respectful lp:K1 lp:K2 lp:C1 (@respectful lp:K3 lp:K4 lp:C2 lp:C3)}} C S. }}. Elpi Typecheck TC.Solver. Global Instance pair_proper : Proper ((≡) ==> (≡) ==> (≡@{A*B})) pair := _. Elpi Accumulate TC.Solver lp:{{ shorten tc-elpi.apps.tc.tests.bigTest.{tc-Inj2}. % shorten tc-bigTest.{tc-Inj2}. :after "lastHook" tc-Inj2 A B C RA RB RC F S :- RC = app [global {coq.locate "equiv"} | _], remove_equiv_prod_equiv RC RC', tc-Inj2 A B C RA RB RC' F S. }}. Elpi Typecheck TC.Solver. Global Instance pair_equiv_inj : Inj2 (≡) (≡) (≡@{A*B}) pair := _. Global Instance fst_proper : Proper ((≡@{A*B}) ==> (≡)) fst := _. Global Instance snd_proper : Proper ((≡@{A*B}) ==> (≡)) snd := _. Global Instance prod_swap_proper : Proper ((≡@{A*B}) ==> (≡@{B*A})) prod_swap := _. Global Instance curry_proper `{Equiv C} : Proper (((≡@{A*B}) ==> (≡@{C})) ==> (≡) ==> (≡) ==> (≡)) curry := _. Global Instance uncurry_proper `{Equiv C} : Proper (((≡) ==> (≡) ==> (≡)) ==> (≡@{A*B}) ==> (≡@{C})) uncurry := _. Global Instance curry3_proper `{Equiv C, Equiv D} : Proper (((≡@{A*B*C}) ==> (≡@{D})) ==> (≡) ==> (≡) ==> (≡) ==> (≡)) curry3 := _. Global Instance uncurry3_proper `{Equiv C, Equiv D} : Proper (((≡) ==> (≡) ==> (≡) ==> (≡)) ==> (≡@{A*B*C}) ==> (≡@{D})) uncurry3 := _. Global Instance curry4_proper `{Equiv C, Equiv D, Equiv E} : Proper (((≡@{A*B*C*D}) ==> (≡@{E})) ==> (≡) ==> (≡) ==> (≡) ==> (≡) ==> (≡)) curry4 := _. Global Instance uncurry4_proper `{Equiv C, Equiv D, Equiv E} : Proper (((≡) ==> (≡) ==> (≡) ==> (≡) ==> (≡)) ==> (≡@{A*B*C*D}) ==> (≡@{E})) uncurry4 := _. Lemma pair_equiv (a1 a2 : A) (b1 b2 : B) : (a1, b1) ≡ (a2, b2) ↔ a1 ≡ a2 ∧ b1 ≡ b2. Proof. reflexivity. Qed. End prod_setoid. Global Typeclasses Opaque prod_equiv. Global Instance prod_leibniz `{LeibnizEquiv A, LeibnizEquiv B} : LeibnizEquiv (A * B). Proof. intros [??] [??] [??]; f_equal; apply leibniz_equiv; auto. Qed. (** ** Sums *) Definition sum_map {A A' B B'} (f: A → A') (g: B → B') (xy : A + B) : A' + B' := match xy with inl x => inl (f x) | inr y => inr (g y) end. Global Arguments sum_map {_ _ _ _} _ _ !_ / : assert. Global Instance sum_inhabited_l {A B} (iA : Inhabited A) : Inhabited (A + B) := match iA with populate x => populate (inl x) end. Global Instance sum_inhabited_r {A B} (iB : Inhabited B) : Inhabited (A + B) := match iB with populate y => populate (inr y) end. Global Instance inl_inj {A B} : Inj (=) (=) (@inl A B). Proof. injection 1; auto. Qed. Global Instance inr_inj {A B} : Inj (=) (=) (@inr A B). Proof. injection 1; auto. Qed. Global Instance sum_map_inj {A A' B B'} (f : A → A') (g : B → B') : Inj (=) (=) f → Inj (=) (=) g → Inj (=) (=) (sum_map f g). Proof. intros ?? [?|?] [?|?] [=]; f_equal; apply (inj _); auto. Qed. Inductive sum_relation {A B} (RA : relation A) (RB : relation B) : relation (A + B) := | inl_related x1 x2 : RA x1 x2 → sum_relation RA RB (inl x1) (inl x2) | inr_related y1 y2 : RB y1 y2 → sum_relation RA RB (inr y1) (inr y2). Section sum_relation. Context `{RA : relation A, RB : relation B}. Global Instance sum_relation_refl : Reflexive RA → Reflexive RB → Reflexive (sum_relation RA RB). Proof. intros ?? [?|?]; constructor; reflexivity. Qed. Global Instance sum_relation_sym : Symmetric RA → Symmetric RB → Symmetric (sum_relation RA RB). Proof. destruct 3; constructor; eauto. Qed. Global Instance sum_relation_trans : Transitive RA → Transitive RB → Transitive (sum_relation RA RB). Proof. destruct 3; inversion_clear 1; constructor; eauto. Qed. Global Instance sum_relation_equiv : Equivalence RA → Equivalence RB → Equivalence (sum_relation RA RB). Proof. split; apply _. Qed. Global Instance inl_proper' : Proper (RA ==> sum_relation RA RB) inl. Proof. constructor; auto. Qed. Global Instance inr_proper' : Proper (RB ==> sum_relation RA RB) inr. Proof. constructor; auto. Qed. Global Instance inl_inj' : Inj RA (sum_relation RA RB) inl. Proof. inversion_clear 1; auto. Qed. Global Instance inr_inj' : Inj RB (sum_relation RA RB) inr. Proof. inversion_clear 1; auto. Qed. End sum_relation. Global Instance sum_equiv `{Equiv A, Equiv B} : Equiv (A + B) := sum_relation (≡) (≡). Elpi Accumulate TC.Solver lp:{{ pred remove_equiv_sum_equiv i:term, o:term. remove_equiv_sum_equiv T1 T3 :- T1 = {{@equiv _ (@sum_equiv _ _ _ _)}}, !, T2 = {{@sum_relation lp:F lp:G lp:A lp:B}}, coq.unify-eq T1 T2 ok, remove_equiv_sum_equiv A X, remove_equiv_sum_equiv B Y, {{@sum_relation lp:F lp:G lp:X lp:Y}} = T3. remove_equiv_sum_equiv (app L1) (app L2) :- !, std.map L1 remove_equiv_sum_equiv L2. remove_equiv_sum_equiv A A. shorten tc-Coq.Classes.Morphisms.{tc-Proper}. :after "lastHook" tc-Proper A B C R :- B = {{ @respectful _ _ _ _ }}, remove_equiv_sum_equiv B B1, tc-Proper A B1 C R. }}. Elpi Typecheck TC.Solver. Global Instance inl_proper `{Equiv A, Equiv B} : Proper ((≡) ==> (≡)) (@inl A B) := _. Global Instance inr_proper `{Equiv A, Equiv B} : Proper ((≡) ==> (≡)) (@inr A B) := _. Elpi Accumulate TC.Solver lp:{{ shorten tc-elpi.apps.tc.tests.bigTest.{tc-Inj}. % shorten tc-bigTest.{tc-Inj}. :after "lastHook" tc-Inj A B R1 R2 S C :- R2 = {{@equiv (sum _ _) sum_equiv}}, R2' = {{sum_relation _ _}}, coq.unify-eq R2 R2' ok, tc-Inj A B R1 R2' S C. }}. Elpi Typecheck TC.Solver. Global Instance inl_equiv_inj `{Equiv A, Equiv B} : Inj (≡) (≡) (@inl A B) := _. Global Instance inr_equiv_inj `{Equiv A, Equiv B} : Inj (≡) (≡) (@inr A B) := _. Global Typeclasses Opaque sum_equiv. (** ** Option *) Global Instance option_inhabited {A} : Inhabited (option A) := populate None. (** ** Sigma types *) Global Arguments existT {_ _} _ _ : assert. Global Arguments projT1 {_ _} _ : assert. Global Arguments projT2 {_ _} _ : assert. Global Arguments exist {_} _ _ _ : assert. Global Arguments proj1_sig {_ _} _ : assert. Global Arguments proj2_sig {_ _} _ : assert. Notation "x ↾ p" := (exist _ x p) (at level 20) : stdpp_scope. Notation "` x" := (proj1_sig x) (at level 10, format "` x") : stdpp_scope. Lemma proj1_sig_inj {A} (P : A → Prop) x (Px : P x) y (Py : P y) : x↾Px = y↾Py → x = y. Proof. injection 1; trivial. Qed. Section sig_map. Context `{P : A → Prop} `{Q : B → Prop} (f : A → B) (Hf : ∀ x, P x → Q (f x)). Definition sig_map (x : sig P) : sig Q := f (`x) ↾ Hf _ (proj2_sig x). Global Instance sig_map_inj: (∀ x, ProofIrrel (P x)) → Inj (=) (=) f → Inj (=) (=) sig_map. Proof. intros ?? [x Hx] [y Hy]. injection 1. intros Hxy. apply (inj f) in Hxy; subst. rewrite (proof_irrel _ Hy). auto. Qed. End sig_map. Global Arguments sig_map _ _ _ _ _ _ !_ / : assert. Definition proj1_ex {P : Prop} {Q : P → Prop} (p : ∃ x, Q x) : P := let '(ex_intro _ x _) := p in x. Definition proj2_ex {P : Prop} {Q : P → Prop} (p : ∃ x, Q x) : Q (proj1_ex p) := let '(ex_intro _ x H) := p in H. (** * Operations on sets *) (** We define operational type classes for the traditional operations and relations on sets: the empty set [∅], the union [(∪)], intersection [(∩)], and difference [(∖)], the singleton [{[_]}], the subset [(⊆)] and element of [(∈)] relation, and disjointess [(##)]. *) Class Empty A := empty: A. Global Hint Mode Empty ! : typeclass_instances. Notation "∅" := empty (format "∅") : stdpp_scope. Global Instance empty_inhabited `(Empty A) : Inhabited A := populate ∅. Class Union A := union: A → A → A. Global Hint Mode Union ! : typeclass_instances. Global Instance: Params (@union) 2 := {}. Infix "∪" := union (at level 50, left associativity) : stdpp_scope. Notation "(∪)" := union (only parsing) : stdpp_scope. Notation "( x ∪.)" := (union x) (only parsing) : stdpp_scope. Notation "(.∪ x )" := (λ y, union y x) (only parsing) : stdpp_scope. Infix "∪*" := (zip_with (∪)) (at level 50, left associativity) : stdpp_scope. Notation "(∪*)" := (zip_with (∪)) (only parsing) : stdpp_scope. Definition union_list `{Empty A} `{Union A} : list A → A := fold_right (∪) ∅. Global Arguments union_list _ _ _ !_ / : assert. Notation "⋃ l" := (union_list l) (at level 20, format "⋃ l") : stdpp_scope. Class Intersection A := intersection: A → A → A. Global Hint Mode Intersection ! : typeclass_instances. Global Instance: Params (@intersection) 2 := {}. Infix "∩" := intersection (at level 40) : stdpp_scope. Notation "(∩)" := intersection (only parsing) : stdpp_scope. Notation "( x ∩.)" := (intersection x) (only parsing) : stdpp_scope. Notation "(.∩ x )" := (λ y, intersection y x) (only parsing) : stdpp_scope. Class Difference A := difference: A → A → A. Global Hint Mode Difference ! : typeclass_instances. Global Instance: Params (@difference) 2 := {}. Infix "∖" := difference (at level 40, left associativity) : stdpp_scope. Notation "(∖)" := difference (only parsing) : stdpp_scope. Notation "( x ∖.)" := (difference x) (only parsing) : stdpp_scope. Notation "(.∖ x )" := (λ y, difference y x) (only parsing) : stdpp_scope. Infix "∖*" := (zip_with (∖)) (at level 40, left associativity) : stdpp_scope. Notation "(∖*)" := (zip_with (∖)) (only parsing) : stdpp_scope. Class Singleton A B := singleton: A → B. Global Hint Mode Singleton - ! : typeclass_instances. Global Instance: Params (@singleton) 3 := {}. Notation "{[ x ]}" := (singleton x) (at level 1) : stdpp_scope. Notation "{[ x ; y ; .. ; z ]}" := (union .. (union (singleton x) (singleton y)) .. (singleton z)) (at level 1) : stdpp_scope. Class SubsetEq A := subseteq: relation A. Global Hint Mode SubsetEq ! : typeclass_instances. Global Instance: Params (@subseteq) 2 := {}. Infix "⊆" := subseteq (at level 70) : stdpp_scope. Notation "(⊆)" := subseteq (only parsing) : stdpp_scope. Notation "( X ⊆.)" := (subseteq X) (only parsing) : stdpp_scope. Notation "(.⊆ X )" := (λ Y, Y ⊆ X) (only parsing) : stdpp_scope. Notation "X ⊈ Y" := (¬X ⊆ Y) (at level 70) : stdpp_scope. Notation "(⊈)" := (λ X Y, X ⊈ Y) (only parsing) : stdpp_scope. Notation "( X ⊈.)" := (λ Y, X ⊈ Y) (only parsing) : stdpp_scope. Notation "(.⊈ X )" := (λ Y, Y ⊈ X) (only parsing) : stdpp_scope. Infix "⊆@{ A }" := (@subseteq A _) (at level 70, only parsing) : stdpp_scope. Notation "(⊆@{ A } )" := (@subseteq A _) (only parsing) : stdpp_scope. Infix "⊆*" := (Forall2 (⊆)) (at level 70) : stdpp_scope. Notation "(⊆*)" := (Forall2 (⊆)) (only parsing) : stdpp_scope. Global Hint Extern 0 (_ ⊆ _) => reflexivity : core. Global Hint Extern 0 (_ ⊆* _) => reflexivity : core. Infix "⊂" := (strict (⊆)) (at level 70) : stdpp_scope. Notation "(⊂)" := (strict (⊆)) (only parsing) : stdpp_scope. Notation "( X ⊂.)" := (strict (⊆) X) (only parsing) : stdpp_scope. Notation "(.⊂ X )" := (λ Y, Y ⊂ X) (only parsing) : stdpp_scope. Notation "X ⊄ Y" := (¬X ⊂ Y) (at level 70) : stdpp_scope. Notation "(⊄)" := (λ X Y, X ⊄ Y) (only parsing) : stdpp_scope. Notation "( X ⊄.)" := (λ Y, X ⊄ Y) (only parsing) : stdpp_scope. Notation "(.⊄ X )" := (λ Y, Y ⊄ X) (only parsing) : stdpp_scope. Infix "⊂@{ A }" := (strict (⊆@{A})) (at level 70, only parsing) : stdpp_scope. Notation "(⊂@{ A } )" := (strict (⊆@{A})) (only parsing) : stdpp_scope. Notation "X ⊆ Y ⊆ Z" := (X ⊆ Y ∧ Y ⊆ Z) (at level 70, Y at next level) : stdpp_scope. Notation "X ⊆ Y ⊂ Z" := (X ⊆ Y ∧ Y ⊂ Z) (at level 70, Y at next level) : stdpp_scope. Notation "X ⊂ Y ⊆ Z" := (X ⊂ Y ∧ Y ⊆ Z) (at level 70, Y at next level) : stdpp_scope. Notation "X ⊂ Y ⊂ Z" := (X ⊂ Y ∧ Y ⊂ Z) (at level 70, Y at next level) : stdpp_scope. (** We define type classes for multisets: disjoint union [⊎] and the multiset singleton [{[+ _ +]}]. Multiset literals [{[+ x1; ..; xn +]}] are defined in terms of iterated disjoint union [{[+ x1 +]} ⊎ .. ⊎ {[+ xn +]}], and are thus different from set literals [{[ x1; ..; xn ]}], which use [∪]. Note that in principle we could reuse the set singleton [{[ _ ]}] for multisets, and define [{[+ x1; ..; xn +]}] as [{[ x1 ]} ⊎ .. ⊎ {[ xn ]}]. However, this would risk accidentally using [{[ x1; ..; xn ]}] for multisets (leading to unexpected results) and lead to ambigious pretty printing for [{[+ x +]}]. *) Class DisjUnion A := disj_union: A → A → A. Global Hint Mode DisjUnion ! : typeclass_instances. Global Instance: Params (@disj_union) 2 := {}. Infix "⊎" := disj_union (at level 50, left associativity) : stdpp_scope. Notation "(⊎)" := disj_union (only parsing) : stdpp_scope. Notation "( x ⊎.)" := (disj_union x) (only parsing) : stdpp_scope. Notation "(.⊎ x )" := (λ y, disj_union y x) (only parsing) : stdpp_scope. Class SingletonMS A B := singletonMS: A → B. Global Hint Mode SingletonMS - ! : typeclass_instances. Global Instance: Params (@singletonMS) 3 := {}. Notation "{[+ x +]}" := (singletonMS x) (at level 1, format "{[+ x +]}") : stdpp_scope. Notation "{[+ x ; y ; .. ; z +]}" := (disj_union .. (disj_union (singletonMS x) (singletonMS y)) .. (singletonMS z)) (at level 1, format "{[+ x ; y ; .. ; z +]}") : stdpp_scope. Definition option_to_set `{Singleton A C, Empty C} (mx : option A) : C := match mx with None => ∅ | Some x => {[ x ]} end. Fixpoint list_to_set `{Singleton A C, Empty C, Union C} (l : list A) : C := match l with [] => ∅ | x :: l => {[ x ]} ∪ list_to_set l end. Fixpoint list_to_set_disj `{SingletonMS A C, Empty C, DisjUnion C} (l : list A) : C := match l with [] => ∅ | x :: l => {[+ x +]} ⊎ list_to_set_disj l end. Class ScalarMul N A := scalar_mul : N → A → A. Global Hint Mode ScalarMul - ! : typeclass_instances. (** The [N] arguments is typically [nat] or [Z], so we do not want to rewrite in that. Hence, the value of [Params] is 3. *) Global Instance: Params (@scalar_mul) 3 := {}. (** The notation [*:] and level is taken from ssreflect, see https://github.com/math-comp/math-comp/blob/master/mathcomp/ssreflect/ssrnotations.v *) Infix "*:" := scalar_mul (at level 40) : stdpp_scope. Notation "(*:)" := scalar_mul (only parsing) : stdpp_scope. Notation "( x *:.)" := (scalar_mul x) (only parsing) : stdpp_scope. Notation "(.*: x )" := (λ y, scalar_mul y x) (only parsing) : stdpp_scope. (** The class [Lexico A] is used for the lexicographic order on [A]. This order is used to create finite maps, finite sets, etc, and is typically different from the order [(⊆)]. *) Class Lexico A := lexico: relation A. Global Hint Mode Lexico ! : typeclass_instances. Class ElemOf A B := elem_of: A → B → Prop. Global Hint Mode ElemOf - ! : typeclass_instances. Global Instance: Params (@elem_of) 3 := {}. Infix "∈" := elem_of (at level 70) : stdpp_scope. Notation "(∈)" := elem_of (only parsing) : stdpp_scope. Notation "( x ∈.)" := (elem_of x) (only parsing) : stdpp_scope. Notation "(.∈ X )" := (λ x, elem_of x X) (only parsing) : stdpp_scope. Notation "x ∉ X" := (¬x ∈ X) (at level 80) : stdpp_scope. Notation "(∉)" := (λ x X, x ∉ X) (only parsing) : stdpp_scope. Notation "( x ∉.)" := (λ X, x ∉ X) (only parsing) : stdpp_scope. Notation "(.∉ X )" := (λ x, x ∉ X) (only parsing) : stdpp_scope. Infix "∈@{ B }" := (@elem_of _ B _) (at level 70, only parsing) : stdpp_scope. Notation "(∈@{ B } )" := (@elem_of _ B _) (only parsing) : stdpp_scope. Notation "x ∉@{ B } X" := (¬x ∈@{B} X) (at level 80, only parsing) : stdpp_scope. Notation "(∉@{ B } )" := (λ x X, x ∉@{B} X) (only parsing) : stdpp_scope. Class Disjoint A := disjoint : A → A → Prop. Global Hint Mode Disjoint ! : typeclass_instances. Global Instance: Params (@disjoint) 2 := {}. Infix "##" := disjoint (at level 70) : stdpp_scope. Notation "(##)" := disjoint (only parsing) : stdpp_scope. Notation "( X ##.)" := (disjoint X) (only parsing) : stdpp_scope. Notation "(.## X )" := (λ Y, Y ## X) (only parsing) : stdpp_scope. Infix "##@{ A }" := (@disjoint A _) (at level 70, only parsing) : stdpp_scope. Notation "(##@{ A } )" := (@disjoint A _) (only parsing) : stdpp_scope. Infix "##*" := (Forall2 (##)) (at level 70) : stdpp_scope. Notation "(##*)" := (Forall2 (##)) (only parsing) : stdpp_scope. Global Hint Extern 0 (_ ## _) => symmetry; eassumption : core. Global Hint Extern 0 (_ ##* _) => symmetry; eassumption : core. Class Filter A B := filter: ∀ (P : A → Prop) `{∀ x, Decision (P x)}, B → B. Global Hint Mode Filter - ! : typeclass_instances. Class UpClose A B := up_close : A → B. Global Hint Mode UpClose - ! : typeclass_instances. Notation "↑ x" := (up_close x) (at level 20, format "↑ x"). (** * Monadic operations *) (** We define operational type classes for the monadic operations bind, join and fmap. We use these type classes merely for convenient overloading of notations and do not formalize any theory on monads (we do not even define a class with the monad laws). *) Class MRet (M : Type → Type) := mret: ∀ {A}, A → M A. Global Arguments mret {_ _ _} _ : assert. Global Instance: Params (@mret) 3 := {}. Global Hint Mode MRet ! : typeclass_instances. Class MBind (M : Type → Type) := mbind : ∀ {A B}, (A → M B) → M A → M B. Global Arguments mbind {_ _ _ _} _ !_ / : assert. Global Instance: Params (@mbind) 4 := {}. Global Hint Mode MBind ! : typeclass_instances. Class MJoin (M : Type → Type) := mjoin: ∀ {A}, M (M A) → M A. Global Arguments mjoin {_ _ _} !_ / : assert. Global Instance: Params (@mjoin) 3 := {}. Global Hint Mode MJoin ! : typeclass_instances. Class FMap (M : Type → Type) := fmap : ∀ {A B}, (A → B) → M A → M B. Global Arguments fmap {_ _ _ _} _ !_ / : assert. Global Instance: Params (@fmap) 4 := {}. Global Hint Mode FMap ! : typeclass_instances. Class OMap (M : Type → Type) := omap: ∀ {A B}, (A → option B) → M A → M B. Global Arguments omap {_ _ _ _} _ !_ / : assert. Global Instance: Params (@omap) 4 := {}. Global Hint Mode OMap ! : typeclass_instances. Notation "m ≫= f" := (mbind f m) (at level 60, right associativity) : stdpp_scope. Notation "( m ≫=.)" := (λ f, mbind f m) (only parsing) : stdpp_scope. Notation "(.≫= f )" := (mbind f) (only parsing) : stdpp_scope. Notation "(≫=)" := (λ m f, mbind f m) (only parsing) : stdpp_scope. Notation "x ↠y ; z" := (y ≫= (λ x : _, z)) (at level 20, y at level 100, z at level 200, only parsing) : stdpp_scope. Notation "' x ↠y ; z" := (y ≫= (λ x : _, z)) (at level 20, x pattern, y at level 100, z at level 200, only parsing) : stdpp_scope. Infix "<$>" := fmap (at level 61, left associativity) : stdpp_scope. Notation "x ;; z" := (x ≫= λ _, z) (at level 100, z at level 200, only parsing, right associativity): stdpp_scope. Notation "ps .*1" := (fmap (M:=list) fst ps) (at level 2, left associativity, format "ps .*1"). Notation "ps .*2" := (fmap (M:=list) snd ps) (at level 2, left associativity, format "ps .*2"). (** For any monad that has a builtin way to throw an exception/error *) Class MThrow (E : Type) (M : Type → Type) := mthrow : ∀ {A}, E → M A. Global Arguments mthrow {_ _ _ _} _ : assert. Global Instance: Params (@mthrow) 4 := {}. Global Hint Mode MThrow ! ! : typeclass_instances. (** We use unit as the error content for monads that can only report an error without any payload like an option *) Global Notation MFail := (MThrow ()). Global Notation mfail := (mthrow ()). Definition guard_or {E} (e : E) `{MThrow E M, MRet M} P `{Decision P} : M P := match decide P with | left H => mret H | right _ => mthrow e end. Global Notation guard := (guard_or ()). (** * Operations on maps *) (** In this section we define operational type classes for the operations on maps. In the file [fin_maps] we will axiomatize finite maps. The function look up [m !! k] should yield the element at key [k] in [m]. *) Class Lookup (K A M : Type) := lookup: K → M → option A. Global Hint Mode Lookup - - ! : typeclass_instances. Global Instance: Params (@lookup) 5 := {}. Notation "m !! i" := (lookup i m) (at level 20) : stdpp_scope. Notation "(!!)" := lookup (only parsing) : stdpp_scope. Notation "( m !!.)" := (λ i, m !! i) (only parsing) : stdpp_scope. Notation "(.!! i )" := (lookup i) (only parsing) : stdpp_scope. Global Arguments lookup _ _ _ _ !_ !_ / : simpl nomatch, assert. (** The function [lookup_total] should be the total over-approximation of the partial [lookup] function. *) Class LookupTotal (K A M : Type) := lookup_total : K → M → A. Global Hint Mode LookupTotal - - ! : typeclass_instances. Global Instance: Params (@lookup_total) 5 := {}. Notation "m !!! i" := (lookup_total i m) (at level 20) : stdpp_scope. Notation "(!!!)" := lookup_total (only parsing) : stdpp_scope. Notation "( m !!!.)" := (λ i, m !!! i) (only parsing) : stdpp_scope. Notation "(.!!! i )" := (lookup_total i) (only parsing) : stdpp_scope. Global Arguments lookup_total _ _ _ _ !_ !_ / : simpl nomatch, assert. (** The singleton map *) Class SingletonM K A M := singletonM: K → A → M. Global Hint Mode SingletonM - - ! : typeclass_instances. Global Instance: Params (@singletonM) 5 := {}. Notation "{[ k := a ]}" := (singletonM k a) (at level 1) : stdpp_scope. (** The function insert [<[k:=a]>m] should update the element at key [k] with value [a] in [m]. *) Class Insert (K A M : Type) := insert: K → A → M → M. Global Hint Mode Insert - - ! : typeclass_instances. Global Instance: Params (@insert) 5 := {}. Notation "<[ k := a ]>" := (insert k a) (at level 5, right associativity, format "<[ k := a ]>") : stdpp_scope. Global Arguments insert _ _ _ _ !_ _ !_ / : simpl nomatch, assert. (** Notation for more elements (up to 13) *) (* Defining a generic notation does not seem possible with Coq's recursive notation system, so we define individual notations for some cases relevant in practice. *) (* The "format" makes sure that linebreaks are placed after the separating semicola [;] when printing. *) (* TODO : we are using parantheses in the "de-sugaring" of the notation instead of [$] because Coq 8.12 and earlier have trouble with using the notation for printing otherwise. Once support for Coq 8.12 is dropped, this can be replaced with [$]. *) Notation "{[ k1 := a1 ; k2 := a2 ]}" := (<[ k1 := a1 ]>{[ k2 := a2 ]}) (at level 1, format "{[ '[hv' '[' k1 := a1 ; ']' '/' '[' k2 := a2 ']' ']' ]}") : stdpp_scope. Notation "{[ k1 := a1 ; k2 := a2 ; k3 := a3 ]}" := (<[ k1 := a1 ]> ( <[ k2 := a2 ]>{[ k3 := a3 ]})) (at level 1, format "{[ '[hv' '[' k1 := a1 ; ']' '/' '[' k2 := a2 ; ']' '/' '[' k3 := a3 ']' ']' ]}") : stdpp_scope. Notation "{[ k1 := a1 ; k2 := a2 ; k3 := a3 ; k4 := a4 ]}" := (<[ k1 := a1 ]> ( <[ k2 := a2 ]> ( <[ k3 := a3 ]>{[ k4 := a4 ]}))) (at level 1, format "{[ '[hv' '[' k1 := a1 ; ']' '/' '[' k2 := a2 ; ']' '/' '[' k3 := a3 ; ']' '/' '[' k4 := a4 ']' ']' ]}") : stdpp_scope. Notation "{[ k1 := a1 ; k2 := a2 ; k3 := a3 ; k4 := a4 ; k5 := a5 ]}" := (<[ k1 := a1 ]> ( <[ k2 := a2 ]> ( <[ k3 := a3 ]> ( <[ k4 := a4 ]>{[ k5 := a5 ]})))) (at level 1, format "{[ '[hv' '[' k1 := a1 ; ']' '/' '[' k2 := a2 ; ']' '/' '[' k3 := a3 ; ']' '/' '[' k4 := a4 ; ']' '/' '[' k5 := a5 ']' ']' ]}") : stdpp_scope. Notation "{[ k1 := a1 ; k2 := a2 ; k3 := a3 ; k4 := a4 ; k5 := a5 ; k6 := a6 ]}" := (<[ k1 := a1 ]> ( <[ k2 := a2 ]> ( <[ k3 := a3 ]> ( <[ k4 := a4 ]> ( <[ k5 := a5 ]>{[ k6 := a6 ]}))))) (at level 1, format "{[ '[hv' '[' k1 := a1 ; ']' '/' '[' k2 := a2 ; ']' '/' '[' k3 := a3 ; ']' '/' '[' k4 := a4 ; ']' '/' '[' k5 := a5 ; ']' '/' '[' k6 := a6 ']' ']' ]}") : stdpp_scope. Notation "{[ k1 := a1 ; k2 := a2 ; k3 := a3 ; k4 := a4 ; k5 := a5 ; k6 := a6 ; k7 := a7 ]}" := (<[ k1 := a1 ]> ( <[ k2 := a2 ]> ( <[ k3 := a3 ]> ( <[ k4 := a4 ]> ( <[ k5 := a5 ]> ( <[ k6 := a6 ]>{[ k7 := a7 ]})))))) (at level 1, format "{[ '[hv' '[' k1 := a1 ; ']' '/' '[' k2 := a2 ; ']' '/' '[' k3 := a3 ; ']' '/' '[' k4 := a4 ; ']' '/' '[' k5 := a5 ; ']' '/' '[' k6 := a6 ; ']' '/' '[' k7 := a7 ']' ']' ]}") : stdpp_scope. Notation "{[ k1 := a1 ; k2 := a2 ; k3 := a3 ; k4 := a4 ; k5 := a5 ; k6 := a6 ; k7 := a7 ; k8 := a8 ]}" := (<[ k1 := a1 ]> ( <[ k2 := a2 ]> ( <[ k3 := a3 ]> ( <[ k4 := a4 ]> ( <[ k5 := a5 ]> ( <[ k6 := a6 ]> ( <[ k7 := a7 ]>{[ k8 := a8 ]}))))))) (at level 1, format "{[ '[hv' '[' k1 := a1 ; ']' '/' '[' k2 := a2 ; ']' '/' '[' k3 := a3 ; ']' '/' '[' k4 := a4 ; ']' '/' '[' k5 := a5 ; ']' '/' '[' k6 := a6 ; ']' '/' '[' k7 := a7 ; ']' '/' '[' k8 := a8 ']' ']' ]}") : stdpp_scope. Notation "{[ k1 := a1 ; k2 := a2 ; k3 := a3 ; k4 := a4 ; k5 := a5 ; k6 := a6 ; k7 := a7 ; k8 := a8 ; k9 := a9 ]}" := (<[ k1 := a1 ]> ( <[ k2 := a2 ]> ( <[ k3 := a3 ]> ( <[ k4 := a4 ]> ( <[ k5 := a5 ]> ( <[ k6 := a6 ]> ( <[ k7 := a7 ]> ( <[ k8 := a8 ]>{[ k9 := a9 ]})))))))) (at level 1, format "{[ '[hv' '[' k1 := a1 ; ']' '/' '[' k2 := a2 ; ']' '/' '[' k3 := a3 ; ']' '/' '[' k4 := a4 ; ']' '/' '[' k5 := a5 ; ']' '/' '[' k6 := a6 ; ']' '/' '[' k7 := a7 ; ']' '/' '[' k8 := a8 ; ']' '/' '[' k9 := a9 ']' ']' ]}") : stdpp_scope. Notation "{[ k1 := a1 ; k2 := a2 ; k3 := a3 ; k4 := a4 ; k5 := a5 ; k6 := a6 ; k7 := a7 ; k8 := a8 ; k9 := a9 ; k10 := a10 ]}" := (<[ k1 := a1 ]> ( <[ k2 := a2 ]> ( <[ k3 := a3 ]> ( <[ k4 := a4 ]> ( <[ k5 := a5 ]> ( <[ k6 := a6 ]> ( <[ k7 := a7 ]> ( <[ k8 := a8 ]> ( <[ k9 := a9 ]>{[ k10 := a10 ]}))))))))) (at level 1, format "{[ '[hv' '[' k1 := a1 ; ']' '/' '[' k2 := a2 ; ']' '/' '[' k3 := a3 ; ']' '/' '[' k4 := a4 ; ']' '/' '[' k5 := a5 ; ']' '/' '[' k6 := a6 ; ']' '/' '[' k7 := a7 ; ']' '/' '[' k8 := a8 ; ']' '/' '[' k9 := a9 ; ']' '/' '[' k10 := a10 ']' ']' ]}") : stdpp_scope. Notation "{[ k1 := a1 ; k2 := a2 ; k3 := a3 ; k4 := a4 ; k5 := a5 ; k6 := a6 ; k7 := a7 ; k8 := a8 ; k9 := a9 ; k10 := a10 ; k11 := a11 ]}" := (<[ k1 := a1 ]> ( <[ k2 := a2 ]> ( <[ k3 := a3 ]> ( <[ k4 := a4 ]> ( <[ k5 := a5 ]> ( <[ k6 := a6 ]> ( <[ k7 := a7 ]> ( <[ k8 := a8 ]> ( <[ k9 := a9 ]> ( <[ k10 := a10 ]>{[ k11 := a11 ]})))))))))) (at level 1, format "{[ '[hv' '[' k1 := a1 ; ']' '/' '[' k2 := a2 ; ']' '/' '[' k3 := a3 ; ']' '/' '[' k4 := a4 ; ']' '/' '[' k5 := a5 ; ']' '/' '[' k6 := a6 ; ']' '/' '[' k7 := a7 ; ']' '/' '[' k8 := a8 ; ']' '/' '[' k9 := a9 ; ']' '/' '[' k10 := a10 ; ']' '/' '[' k11 := a11 ']' ']' ]}") : stdpp_scope. Notation "{[ k1 := a1 ; k2 := a2 ; k3 := a3 ; k4 := a4 ; k5 := a5 ; k6 := a6 ; k7 := a7 ; k8 := a8 ; k9 := a9 ; k10 := a10 ; k11 := a11 ; k12 := a12 ]}" := (<[ k1 := a1 ]> ( <[ k2 := a2 ]> ( <[ k3 := a3 ]> ( <[ k4 := a4 ]> ( <[ k5 := a5 ]> ( <[ k6 := a6 ]> ( <[ k7 := a7 ]> ( <[ k8 := a8 ]> ( <[ k9 := a9 ]> ( <[ k10 := a10 ]> ( <[ k11 := a11 ]>{[ k12 := a12 ]}))))))))))) (at level 1, format "{[ '[hv' '[' k1 := a1 ; ']' '/' '[' k2 := a2 ; ']' '/' '[' k3 := a3 ; ']' '/' '[' k4 := a4 ; ']' '/' '[' k5 := a5 ; ']' '/' '[' k6 := a6 ; ']' '/' '[' k7 := a7 ; ']' '/' '[' k8 := a8 ; ']' '/' '[' k9 := a9 ; ']' '/' '[' k10 := a10 ; ']' '/' '[' k11 := a11 ; ']' '/' '[' k12 := a12 ']' ']' ]}") : stdpp_scope. Notation "{[ k1 := a1 ; k2 := a2 ; k3 := a3 ; k4 := a4 ; k5 := a5 ; k6 := a6 ; k7 := a7 ; k8 := a8 ; k9 := a9 ; k10 := a10 ; k11 := a11 ; k12 := a12 ; k13 := a13 ]}" := (<[ k1 := a1 ]> ( <[ k2 := a2 ]> ( <[ k3 := a3 ]> ( <[ k4 := a4 ]> ( <[ k5 := a5 ]> ( <[ k6 := a6 ]> ( <[ k7 := a7 ]> ( <[ k8 := a8 ]> ( <[ k9 := a9 ]> ( <[ k10 := a10 ]> ( <[ k11 := a11 ]> ( <[ k12 := a12 ]>{[ k13 := a13 ]})))))))))))) (at level 1, format "{[ '[hv' '[' k1 := a1 ; ']' '/' '[' k2 := a2 ; ']' '/' '[' k3 := a3 ; ']' '/' '[' k4 := a4 ; ']' '/' '[' k5 := a5 ; ']' '/' '[' k6 := a6 ; ']' '/' '[' k7 := a7 ; ']' '/' '[' k8 := a8 ; ']' '/' '[' k9 := a9 ; ']' '/' '[' k10 := a10 ; ']' '/' '[' k11 := a11 ; ']' '/' '[' k12 := a12 ; ']' '/' '[' k13 := a13 ']' ']' ]}") : stdpp_scope. (** The function delete [delete k m] should delete the value at key [k] in [m]. If the key [k] is not a member of [m], the original map should be returned. *) Class Delete (K M : Type) := delete: K → M → M. Global Hint Mode Delete - ! : typeclass_instances. Global Instance: Params (@delete) 4 := {}. Global Arguments delete _ _ _ !_ !_ / : simpl nomatch, assert. (** The function [alter f k m] should update the value at key [k] using the function [f], which is called with the original value. *) Class Alter (K A M : Type) := alter: (A → A) → K → M → M. Global Hint Mode Alter - - ! : typeclass_instances. Global Instance: Params (@alter) 4 := {}. Global Arguments alter {_ _ _ _} _ !_ !_ / : simpl nomatch, assert. (** The function [partial_alter f k m] should update the value at key [k] using the function [f], which is called with the original value at key [k] or [None] if [k] is not a member of [m]. The value at [k] should be deleted if [f] yields [None]. *) Class PartialAlter (K A M : Type) := partial_alter: (option A → option A) → K → M → M. Global Hint Mode PartialAlter - - ! : typeclass_instances. Global Instance: Params (@partial_alter) 4 := {}. Global Arguments partial_alter _ _ _ _ _ !_ !_ / : simpl nomatch, assert. (** The function [dom m] should yield the domain of [m]. That is a finite set of type [D] that contains the keys that are a member of [m]. [D] is an output of the typeclass, i.e., there can be only one instance per map type [M]. *) Class Dom (M D : Type) := dom: M → D. Global Hint Mode Dom ! - : typeclass_instances. Global Instance: Params (@dom) 3 := {}. Global Arguments dom : clear implicits. Global Arguments dom {_ _ _} !_ / : simpl nomatch, assert. (** The function [merge f m1 m2] should merge the maps [m1] and [m2] by constructing a new map whose value at key [k] is [f (m1 !! k) (m2 !! k)].*) Class Merge (M : Type → Type) := merge: ∀ {A B C}, (option A → option B → option C) → M A → M B → M C. Global Hint Mode Merge ! : typeclass_instances. Global Instance: Params (@merge) 4 := {}. Global Arguments merge _ _ _ _ _ _ !_ !_ / : simpl nomatch, assert. (** The function [union_with f m1 m2] is supposed to yield the union of [m1] and [m2] using the function [f] to combine values of members that are in both [m1] and [m2]. *) Class UnionWith (A M : Type) := union_with: (A → A → option A) → M → M → M. Global Hint Mode UnionWith - ! : typeclass_instances. Global Instance: Params (@union_with) 3 := {}. Global Arguments union_with {_ _ _} _ !_ !_ / : simpl nomatch, assert. (** Similarly for intersection and difference. *) Class IntersectionWith (A M : Type) := intersection_with: (A → A → option A) → M → M → M. Global Hint Mode IntersectionWith - ! : typeclass_instances. Global Instance: Params (@intersection_with) 3 := {}. Global Arguments intersection_with {_ _ _} _ !_ !_ / : simpl nomatch, assert. Class DifferenceWith (A M : Type) := difference_with: (A → A → option A) → M → M → M. Global Hint Mode DifferenceWith - ! : typeclass_instances. Global Instance: Params (@difference_with) 3 := {}. Global Arguments difference_with {_ _ _} _ !_ !_ / : simpl nomatch, assert. Definition intersection_with_list `{IntersectionWith A M} (f : A → A → option A) : M → list M → M := fold_right (intersection_with f). Global Arguments intersection_with_list _ _ _ _ _ !_ / : assert. (** * Notations for lattices. *) (** SqSubsetEq registers the "canonical" partial order for a type, and is used for the \sqsubseteq symbol. *) Class SqSubsetEq A := sqsubseteq: relation A. Global Hint Mode SqSubsetEq ! : typeclass_instances. Global Instance: Params (@sqsubseteq) 2 := {}. Infix "⊑" := sqsubseteq (at level 70) : stdpp_scope. Notation "(⊑)" := sqsubseteq (only parsing) : stdpp_scope. Notation "( x ⊑.)" := (sqsubseteq x) (only parsing) : stdpp_scope. Notation "(.⊑ y )" := (λ x, sqsubseteq x y) (only parsing) : stdpp_scope. Infix "⊑@{ A }" := (@sqsubseteq A _) (at level 70, only parsing) : stdpp_scope. Notation "(⊑@{ A } )" := (@sqsubseteq A _) (only parsing) : stdpp_scope. (** [sqsubseteq] does not take precedence over the stdlib's instances (like [eq], [impl], [iff]) or std++'s [equiv]. We have [eq] (at 100) < [≡] (at 150) < [⊑] (at 200). *) Global Instance sqsubseteq_rewrite `{SqSubsetEq A} : RewriteRelation (⊑@{A}) | 200 := {}. Global Hint Extern 0 (_ ⊑ _) => reflexivity : core. Class Meet A := meet: A → A → A. Global Hint Mode Meet ! : typeclass_instances. Global Instance: Params (@meet) 2 := {}. Infix "⊓" := meet (at level 40) : stdpp_scope. Notation "(⊓)" := meet (only parsing) : stdpp_scope. Notation "( x ⊓.)" := (meet x) (only parsing) : stdpp_scope. Notation "(.⊓ y )" := (λ x, meet x y) (only parsing) : stdpp_scope. Class Join A := join: A → A → A. Global Hint Mode Join ! : typeclass_instances. Global Instance: Params (@join) 2 := {}. Infix "⊔" := join (at level 50) : stdpp_scope. Notation "(⊔)" := join (only parsing) : stdpp_scope. Notation "( x ⊔.)" := (join x) (only parsing) : stdpp_scope. Notation "(.⊔ y )" := (λ x, join x y) (only parsing) : stdpp_scope. Class Top A := top : A. Global Hint Mode Top ! : typeclass_instances. Notation "⊤" := top (format "⊤") : stdpp_scope. Class Bottom A := bottom : A. Global Hint Mode Bottom ! : typeclass_instances. Notation "⊥" := bottom (format "⊥") : stdpp_scope. (** * Axiomatization of sets *) (** The classes [SemiSet A C], [Set_ A C], and [TopSet A C] axiomatize sets of type [C] with elements of type [A]. The first class, [SemiSet] does not include intersection and difference. It is useful for the case of lists, where decidable equality is needed to implement intersection and difference, but not union. Note that we cannot use the name [Set] since that is a reserved keyword. Hence we use [Set_]. *) Class SemiSet A C `{ElemOf A C, Empty C, Singleton A C, Union C} : Prop := { not_elem_of_empty (x : A) : x ∉@{C} ∅; (* We prove [elem_of_empty : x ∈@{C} ∅ ↔ False] in [sets.v], which is more convenient for rewriting. *) elem_of_singleton (x y : A) : x ∈@{C} {[ y ]} ↔ x = y; elem_of_union (X Y : C) (x : A) : x ∈ X ∪ Y ↔ x ∈ X ∨ x ∈ Y }. Global Hint Mode SemiSet - ! - - - - : typeclass_instances. Class Set_ A C `{ElemOf A C, Empty C, Singleton A C, Union C, Intersection C, Difference C} : Prop := { set_semi_set :> SemiSet A C; elem_of_intersection (X Y : C) (x : A) : x ∈ X ∩ Y ↔ x ∈ X ∧ x ∈ Y; elem_of_difference (X Y : C) (x : A) : x ∈ X ∖ Y ↔ x ∈ X ∧ x ∉ Y }. Global Hint Mode Set_ - ! - - - - - - : typeclass_instances. Class TopSet A C `{ElemOf A C, Empty C, Top C, Singleton A C, Union C, Intersection C, Difference C} : Prop := { top_set_set :> Set_ A C; elem_of_top' (x : A) : x ∈@{C} ⊤; (* We prove [elem_of_top : x ∈@{C} ⊤ ↔ True] in [sets.v], which is more convenient for rewriting. *) }. Global Hint Mode TopSet - ! - - - - - - - : typeclass_instances. (** We axiomative a finite set as a set whose elements can be enumerated as a list. These elements, given by the [elements] function, may be in any order and should not contain duplicates. *) Class Elements A C := elements: C → list A. Global Hint Mode Elements - ! : typeclass_instances. Global Instance: Params (@elements) 3 := {}. (** We redefine the standard library's [In] and [NoDup] using type classes. *) Inductive elem_of_list {A} : ElemOf A (list A) := | elem_of_list_here (x : A) l : x ∈ x :: l | elem_of_list_further (x y : A) l : x ∈ l → x ∈ y :: l. Global Existing Instance elem_of_list. Lemma elem_of_list_In {A} (l : list A) x : x ∈ l ↔ In x l. Proof. split. - induction 1; simpl; auto. - induction l; destruct 1; subst; constructor; auto. Qed. Inductive NoDup {A} : list A → Prop := | NoDup_nil_2 : NoDup [] | NoDup_cons_2 x l : x ∉ l → NoDup l → NoDup (x :: l). Lemma NoDup_ListNoDup {A} (l : list A) : NoDup l ↔ List.NoDup l. Proof. split. - induction 1; constructor; rewrite <-?elem_of_list_In; auto. - induction 1; constructor; rewrite ?elem_of_list_In; auto. Qed. (** Decidability of equality of the carrier set is admissible, but we add it anyway so as to avoid cycles in type class search. *) Class FinSet A C `{ElemOf A C, Empty C, Singleton A C, Union C, Intersection C, Difference C, Elements A C, EqDecision A} : Prop := { fin_set_set :> Set_ A C; elem_of_elements (X : C) x : x ∈ elements X ↔ x ∈ X; NoDup_elements (X : C) : NoDup (elements X) }. Global Hint Mode FinSet - ! - - - - - - - - : typeclass_instances. Class Size C := size: C → nat. Global Hint Mode Size ! : typeclass_instances. Global Arguments size {_ _} !_ / : simpl nomatch, assert. Global Instance: Params (@size) 2 := {}. (** The class [MonadSet M] axiomatizes a type constructor [M] that can be used to construct a set [M A] with elements of type [A]. The advantage of this class, compared to [Set_], is that it also axiomatizes the the monadic operations. The disadvantage is that not many inhabitants are possible: we will only provide as inhabitants [propset] and [listset], which are represented respectively using Boolean functions and lists with duplicates. More interesting implementations typically need decidable equality, or a total order on the elements, which do not fit in a type constructor of type [Type → Type]. *) Class MonadSet M `{∀ A, ElemOf A (M A), ∀ A, Empty (M A), ∀ A, Singleton A (M A), ∀ A, Union (M A), !MBind M, !MRet M, !FMap M, !MJoin M} : Prop := { monad_set_semi_set A :> SemiSet A (M A); elem_of_bind {A B} (f : A → M B) (X : M A) (x : B) : x ∈ X ≫= f ↔ ∃ y, x ∈ f y ∧ y ∈ X; elem_of_ret {A} (x y : A) : x ∈@{M A} mret y ↔ x = y; elem_of_fmap {A B} (f : A → B) (X : M A) (x : B) : x ∈ f <$> X ↔ ∃ y, x = f y ∧ y ∈ X; elem_of_join {A} (X : M (M A)) (x : A) : x ∈ mjoin X ↔ ∃ Y : M A, x ∈ Y ∧ Y ∈ X }. (** The [Infinite A] class axiomatizes types [A] with infinitely many elements. It contains a function [fresh : list A → A] that given a list [xs] gives an element [fresh xs ∉ xs]. We do not directly make [fresh] a field of the [Infinite] class, but use a separate operational type class [Fresh] for it. That way we can overload [fresh] to pick fresh elements from other data structure like sets. See the file [fin_sets], where we define [fresh : C → A] for any finite set implementation [FinSet C A]. Note: we require [fresh] to respect permutations, which is needed to define the aforementioned [fresh] function on finite sets that respects set equality. Instead of instantiating [Infinite] directly, consider using [max_infinite] or [inj_infinite] from the [infinite] module. *) Class Fresh A C := fresh: C → A. Global Hint Mode Fresh - ! : typeclass_instances. Global Instance: Params (@fresh) 3 := {}. Global Arguments fresh : simpl never. Class Infinite A := { infinite_fresh :> Fresh A (list A); infinite_is_fresh (xs : list A) : fresh xs ∉ xs; infinite_fresh_Permutation :> Proper (@Permutation A ==> (=)) fresh; }. Global Hint Mode Infinite ! : typeclass_instances. Global Arguments infinite_fresh : simpl never. (** * Miscellaneous *) Class Half A := half: A → A. Global Hint Mode Half ! : typeclass_instances. Notation "½" := half (format "½") : stdpp_scope. Notation "½*" := (fmap (M:=list) half) : stdpp_scope. coq-elpi-2.1.0/apps/tc/tests/classes_declare.v000066400000000000000000000032601460156013500212430ustar00rootroot00000000000000From elpi.apps Require Import tc. Elpi Override TC TC.Solver All. (* Base test *) Section S1. TC.Declare Class class1 (n : nat). (* TODO: here coq can solve the goal without applying Build_class1 *) Instance inst1 : class1 3. Proof. apply Build_class1. Qed. Goal exists x, class1 x. Proof. eexists. apply _. Qed. End S1. (* Deterministic class test *) Section S2. #[deterministic] TC.Declare Class class2 (n : nat). Instance inst2 : class2 1 | 0. Proof. apply Build_class2. Qed. Instance inst2' : class2 2 | 1. Proof. apply Build_class2. Qed. Class aux (i: nat). Instance inst_aux : forall n, class2 n -> aux n -> aux 3. Qed. Section S2'. Local Instance inst_aux' : aux 1. Qed. Goal aux 3. apply _. Qed. End S2'. Section S2'. Local Instance inst_aux'' : aux 2. Qed. Goal aux 3. Proof. Succeed apply (inst_aux 2 inst2' inst_aux''). (* Note: since class2 is deterministic we cannot backtrack. The first hypothesis of inst_aux is unified to inst2, this causes `aux 2` to fail. The instance inst2' is not tried due to the deterministic class *) Fail apply _. Abort. End S2'. End S2. (* Mode test *) Section S3. #[mode(i)] TC.Declare Class class3 (n : nat). Instance inst3 : class3 0. Proof. apply Build_class3. Qed. Goal exists x, class3 x. Proof. eexists. Succeed apply inst3. Fail apply _. Abort. End S3. Section S31. #[mode(o=ff)] TC.Declare Class class31 (n : nat). Instance inst31 : class31 0. Proof. apply Build_class31. Qed. Goal exists x, class31 x. Proof. eexists. Succeed apply inst31. Fail apply _. Abort. End S31. coq-elpi-2.1.0/apps/tc/tests/compile_add_pred.v000066400000000000000000000067201460156013500214050ustar00rootroot00000000000000From elpi Require Import elpi. Elpi Db tc.db lp:{{ pred classes i:gref. pred bool->mode-term i:bool, o:string. bool->mode-term tt "i:term". bool->mode-term ff "o:term". pred modes->string i:list bool, o:string. modes->string L S :- std.map L bool->mode-term L', std.string.concat "," L' S. pred list-init i:int, i:(int -> A -> prop), o:list A. list-init N _ _ :- N < 0, std.fatal-error "list-init negative length". list-init 0 _ [] :- !. list-init N F [A | TL] :- F N A, N1 is N - 1, list-init N1 F TL. pred fail->bool i:prop, o:bool. fail->bool P ff :- P, !. fail->bool _ tt. pred make-tc-modes i:int, o:string. make-tc-modes NB_args ModesStr :- list-init NB_args (x\r\ fail->bool (x = 1) r) ModesBool, modes->string ModesBool ModesStr. pred gref->pred-name i:gref, o:string. gref->pred-name Gr S :- coq.gref->id Gr S', S is "tc-" ^ S'. pred add-tc-pred i:gref, i:int. add-tc-pred Gr NbArgs :- not (classes Gr), make-tc-modes NbArgs Modes, gref->pred-name Gr GrStr, D is "pred " ^ GrStr ^ " " ^ Modes ^ ".", coq.elpi.add-predicate "tc.db" D, coq.elpi.accumulate _ "tc.db" (clause _ _ (classes Gr)). add-tc-pred _ _. pred make-tc i:term, i:term, i:list prop, o:prop. make-tc Ty Inst Hyp Clause :- app [global TC | TL] = Ty, gref->pred-name TC TC_Str, std.append TL [Inst] Args, std.length Args ArgsLen, add-tc-pred TC ArgsLen, coq.elpi.predicate TC_Str Args Q, Clause = (Q :- Hyp). pred app-has-class i:term, o:gref. app-has-class (prod _ _ T) C :- pi x\ app-has-class (T x) C. app-has-class (app [global T|_]) T :- coq.TC.class? T. pred compile i:term, i:term, i:list prop, i:list term, o:prop. compile (prod _ T F) I ListRHS ListVar (pi x\ C x) :- !, pi p cond\ sigma Clause L\ if (app-has-class T _) (compile T p [] [] Clause, L = [Clause | ListRHS]) (L = ListRHS), compile (F p) I L [p | ListVar] (C p). compile Ty I Premises ListVar Clause :- !, std.rev Premises PremisesRev, coq.mk-app I {std.rev ListVar} AppInst, make-tc Ty AppInst PremisesRev Clause. }}. Elpi Command addClass. Elpi Accumulate Db tc.db. Elpi Accumulate lp:{{ main [str TC_Name] :- coq.locate TC_Name TC_Gr, coq.env.typeof TC_Gr TC_Ty, coq.count-prods TC_Ty N', N is N' + 1, % Plus one for the solution add-tc-pred TC_Gr N. }}. Elpi Typecheck. Elpi Command compile. Elpi Accumulate Db tc.db. Elpi Accumulate lp:{{ main [str InstName] :- coq.locate InstName InstGr, coq.env.typeof InstGr InstTy, compile InstTy (global InstGr) [] [] Cl, coq.say Cl, coq.elpi.accumulate _ "tc.db" (clause _ _ Cl). }}. Elpi Typecheck. Elpi Tactic solver. Elpi Accumulate Db tc.db. Elpi Accumulate lp:{{ msolve L N :- !, coq.ltac.all (coq.ltac.open solve) {std.rev L} N. solve (goal _ _ Ty Sol _ as G) GL :- var Sol, Ty = app [global TC | TL'], std.append TL' [X] TL, if (coq.elpi.predicate {gref->pred-name TC} TL Q, Q) ( refine X G GL; coq.say "illtyped solution:" {coq.term->string X} ) (GL = [seal G]). }}. Elpi Typecheck. Class EqSimpl (T : Type) := {eqb : T -> T -> bool}. Global Instance EqU : EqSimpl unit := { eqb A B := true }. Global Instance EqP {A B: Type} `(EqSimpl A, EqSimpl B) : EqSimpl (A * B) := { eqb A B := true }. Elpi addClass EqSimpl. Elpi compile EqU. Elpi compile EqP. Elpi Override TC solver All. Check (_ : EqSimpl unit). Check (_ : EqSimpl (unit * unit)). coq-elpi-2.1.0/apps/tc/tests/contextDeepHierarchy.v000066400000000000000000000006471460156013500222560ustar00rootroot00000000000000From elpi.apps Require Import tc. Unset Typeclass Resolution For Conversion. Set TC NameShortPath. Elpi Override TC TC.Solver All. Class X (A: Type). Class Y (A: Type). Class Z (A: Type). Local Instance Inst1@{i} {A: Type@{i}} : X A -> Y A. Qed. Local Instance Inst2@{i} (A : Type@{i}): (forall A : Type@{i}, X A -> Y A) -> Z A. Qed. (* TODO: here Elpi Trace Fails... *) Goal forall A, Z A. intros. apply _. Qed.coq-elpi-2.1.0/apps/tc/tests/eqSimplDef.v000066400000000000000000000006641460156013500201650ustar00rootroot00000000000000Require Import Bool Arith List. Class Eqb A : Type := eqb : A -> A -> bool. Global Hint Mode Eqb + : typeclass_instances. Notation " x == y " := (eqb x y) (no associativity, at level 70). Global Instance eqU : Eqb unit := { eqb x y := true }. Global Instance eqB : Eqb bool := { eqb x y := if x then y else negb y }. Global Instance eqP {A B} `{Eqb A} `{Eqb B} : Eqb (A * B) := { eqb x y := (fst x == fst y) && (snd x == snd y) }.coq-elpi-2.1.0/apps/tc/tests/hook_test.v000066400000000000000000000006521460156013500201300ustar00rootroot00000000000000From elpi.apps Require Import tc. Elpi Override TC TC.Solver All. Elpi TC.AddHook after 1000 1513. Elpi TC.AddHook before 1513 1512. Class A (n : nat). Instance Inst1 : A 3 | 1513. Qed. Instance Inst2 : A 100 | 1512. Qed. Elpi Query TC.Solver lp:{{ sigma InstL GrefL\ std.findall (instance _ _ {{:gref A}}) InstL, std.map InstL (x\r\ x = instance _ r _) GrefL, GrefL = [{{:gref Inst2}}, {{:gref Inst1}}]. }}. coq-elpi-2.1.0/apps/tc/tests/importOrder/000077500000000000000000000000001460156013500202455ustar00rootroot00000000000000coq-elpi-2.1.0/apps/tc/tests/importOrder/f1.v000066400000000000000000000001751460156013500207450ustar00rootroot00000000000000From elpi.apps.tc.tests.importOrder Require Export sameOrderCommand. Class A (T : Set) := f : T -> T. Elpi SameOrderImport.coq-elpi-2.1.0/apps/tc/tests/importOrder/f2a.v000066400000000000000000000005041460156013500211030ustar00rootroot00000000000000From elpi.apps.tc.tests.importOrder Require Export f1. From elpi.apps.tc.tests.importOrder Require Export sameOrderCommand. Global Instance f2aa : A nat := {f x := x}. Global Instance f2ab : A nat := {f x := x}. Global Instance f2ac : A nat := {f x := x}. Global Instance f2ad : A nat := {f x := x}. Elpi SameOrderImport.coq-elpi-2.1.0/apps/tc/tests/importOrder/f2b.v000066400000000000000000000004061460156013500211050ustar00rootroot00000000000000From elpi.apps.tc.tests.importOrder Require Export f1. Global Instance f2ba : A nat := {f x := x}. Global Instance f2bb : A nat := {f x := x}. Global Instance f2bc : A nat := {f x := x}. Global Instance f2bd : A nat := {f x := x}. (* Elpi SameOrderImport. *) coq-elpi-2.1.0/apps/tc/tests/importOrder/f3a.v000066400000000000000000000002071460156013500211040ustar00rootroot00000000000000From elpi.apps.tc.tests.importOrder Require Import f2a. From elpi.apps.tc.tests.importOrder Require Import f2b. Elpi SameOrderImport. coq-elpi-2.1.0/apps/tc/tests/importOrder/f3b.v000066400000000000000000000002061460156013500211040ustar00rootroot00000000000000From elpi.apps.tc.tests.importOrder Require Import f2b. From elpi.apps.tc.tests.importOrder Require Import f2a. Elpi SameOrderImport.coq-elpi-2.1.0/apps/tc/tests/importOrder/f3c.v000066400000000000000000000015641460156013500211150ustar00rootroot00000000000000From elpi.apps.tc.tests.importOrder Require Export f1. Global Instance f3a : A nat := {f x := x}. Global Instance f3b : A nat := {f x := x}. Global Instance f3c : A nat := {f x := x}. Elpi SameOrderImport. Section S1. Variable X : Type. Local Instance f3d : A nat := {f x := x}. Global Instance f3e : A nat := {f x := x}. Global Instance f3f : A nat := {f x := x}. Elpi SameOrderImport. End S1. Elpi SameOrderImport. Section S2. Context (T : Set). Global Instance f3g : A T := {f x := x}. Elpi SameOrderImport. End S2. Elpi SameOrderImport. Section S3. Context (T : Set). Global Instance f3g2 : A (T: Set) := {f x := x}. Global Instance f3h T1 T2 `(A T1, A T2) : A (T1 * T2) := {f x := x}. Global Instance f3g3 : A (T: Set) := {f x := x}. Global Instance f3g4 : A (T: Set) | 10 := {f x := x}. Elpi SameOrderImport. End S3. Elpi SameOrderImport.coq-elpi-2.1.0/apps/tc/tests/importOrder/f3d.v000066400000000000000000000013601460156013500211100ustar00rootroot00000000000000From elpi.apps.tc.tests.importOrder Require Export f1. From elpi.apps.tc.tests.importOrder Require Import f2b. Elpi SameOrderImport. Global Instance f3a' T1 T2 `(A T1, A T2) : A (T1 * T2) := {f x := x}. Elpi SameOrderImport. Module M4'. (* From elpi.apps.tc.tests.importOrder Require Import f2a. *) Elpi SameOrderImport. Global Instance f3a : A nat := {f x := x}. Section S1. Variable X : Type. Global Instance f3b : A nat := {f x := x}. Section S1'. Variable Y : Type. Global Instance f3c : A nat := {f x := x}. End S1'. End S1. Elpi SameOrderImport. Section S2. Variable X : Type. Global Instance f3h T1 T2 `(A T1, A T2) : A (T1 * T2) := {f x := x}. End S2. End M4'. Elpi SameOrderImport. coq-elpi-2.1.0/apps/tc/tests/importOrder/f3e.v000066400000000000000000000012261460156013500211120ustar00rootroot00000000000000From elpi.apps.tc.tests.importOrder Require Export f1. From elpi.apps.tc.tests.importOrder Require Import f2b. From elpi.apps.tc.tests.importOrder Require Import f2a. Global Instance f3a' T1 T2 `(A T1, A T2) : A (T1 * T2) := {f x := x}. Elpi SameOrderImport. Module M4'. Global Instance f3a : A nat := {f x := x}. Section S1. Variable X : Type. Global Instance f3b : A nat := {f x := x}. Section S1'. Variable Y : Type. Global Instance f3c : A nat := {f x := x}. End S1'. End S1. Section S2. Variable X : Type. Global Instance f3h T1 T2 `(A T1, A T2) : A (T1 * T2) | 100 := {f x := x}. End S2. End M4'. Elpi SameOrderImport.coq-elpi-2.1.0/apps/tc/tests/importOrder/f3f.v000066400000000000000000000004731460156013500211160ustar00rootroot00000000000000From elpi.apps.tc.tests.importOrder Require Import f1. Section S1. Context (T : Set). Global Instance f3a : A T := {f x := x}. Elpi SameOrderImport. Section S2. Context (T1 : Set). Global Instance f3b : A T1 := {f x := x}. End S2. Elpi SameOrderImport. End S1. Elpi SameOrderImport.coq-elpi-2.1.0/apps/tc/tests/importOrder/f3g.v000066400000000000000000000003221460156013500211100ustar00rootroot00000000000000From elpi.apps.tc.tests.importOrder Require Export f1. Module M8. Class Classe (A: Type) (B: Type). Global Instance I (a b c d: Type): Classe a a -> Classe b c. Admitted. Elpi SameOrderImport. End M8. coq-elpi-2.1.0/apps/tc/tests/importOrder/f4.v000066400000000000000000000005461460156013500207520ustar00rootroot00000000000000From elpi.apps.tc.tests.importOrder Require Import f3f. From elpi.apps.tc.tests.importOrder Require Import f2a. From elpi.apps.tc.tests.importOrder Require Import f2b. From elpi.apps.tc.tests.importOrder Require Import f3c. From elpi.apps.tc.tests.importOrder Require Import f3d. From elpi.apps.tc.tests.importOrder Require Import f3g. Elpi SameOrderImport.coq-elpi-2.1.0/apps/tc/tests/importOrder/sameOrderCommand.v000066400000000000000000000005371460156013500236610ustar00rootroot00000000000000From elpi.apps Require Export tc. From elpi.apps.tc Extra Dependency "base.elpi" as base. From elpi.apps.tc.tests.importOrder Extra Dependency "tc_same_order.elpi" as tc_same_order. Elpi Command SameOrderImport. Elpi Accumulate Db tc.db. Elpi Accumulate File base. Elpi Accumulate File tc_same_order. Elpi Typecheck. Elpi Override TC TC.Solver All.coq-elpi-2.1.0/apps/tc/tests/importOrder/tc_same_order.elpi000066400000000000000000000017701460156013500237330ustar00rootroot00000000000000% [Typeclass, Coq Instances, Elpi Instances] % the instances of the given typeclass should be in the same order as Coq pred correct_instance_order_aux i:gref, i:(list tc-instance), i:(list gref). :name "tc-correct-instance-order-aux" correct_instance_order_aux _ [] []. correct_instance_order_aux TC [tc-instance I1 _ | TL1] [I1 | TL2] :- correct_instance_order_aux TC TL1 TL2. % [Typeclasses of Coq, Elpi Instances] pred correct_instance_order i:(list gref), i:(list prop). :name "tc-correct-instance-order" correct_instance_order [] _. correct_instance_order [TC | TL] ElpiInst :- coq.TC.db-for TC CoqInst, std.map-filter ElpiInst (x\r\ sigma I\ x = instance _ I TC, r = I) ElpiInstTC, if (correct_instance_order_aux TC CoqInst ElpiInstTC) (correct_instance_order TL ElpiInst) (coq.error "Error in import order\n" "Expected :" CoqInst "\nFound :" ElpiInstTC). :name "tc-same-order-main" main _ :- std.findall (instance _ _ _) ElpiInst, correct_instance_order {coq.TC.db-tc} ElpiInst.coq-elpi-2.1.0/apps/tc/tests/indt_to_inst.v000066400000000000000000000016321460156013500206250ustar00rootroot00000000000000From Coq Require Export List. From elpi.apps Require Export tc. Global Generalizable All Variables. Elpi Override TC TC.Solver All. Class ElemOf A B := elem_of: A -> B -> Prop. Class Elements A C := elements: C -> list A. Inductive elem_of_list {A} : ElemOf A (list A) := | elem_of_list_here (x : A) l : elem_of x (x :: l) | elem_of_list_further (x y : A) l : elem_of x l -> elem_of x (y :: l). Global Existing Instance elem_of_list. Inductive NoDup {A} : list A -> Prop := | NoDup_nil_2 : NoDup nil | NoDup_cons_2 x l : not (elem_of x l) -> NoDup l -> NoDup (x :: l). Module A. Class FinSet1 A C `{ElemOf A C,Elements A C} : Prop := { NoDup_elements (X : C) : NoDup (elements X) }. End A. Module B. Class FinSet2 A C `{ElemOf A C, Elements A C} : Prop := { elem_of_elements2 (X : C) x : iff (elem_of x (elements X)) (elem_of x X); NoDup_elements2 (X : C) : NoDup (elements X) }. End B.coq-elpi-2.1.0/apps/tc/tests/injTest.v000066400000000000000000000056601460156013500175550ustar00rootroot00000000000000From elpi.apps Require Import tc. From Coq Require Import Morphisms RelationClasses List Bool Setoid Peano Utf8. Generalizable All Variables. Elpi Override TC TC.Solver All. Class Inj {A B} (R : relation A) (S : relation B) (f : A -> B) := inj x y : S (f x) (f y) -> R x y. Class Inj2 {A B C} (R1 : relation A) (R2 : relation B) (S : relation C) (f : A → B → C) : Prop := inj2 x1 x2 y1 y2 : S (f x1 x2) (f y1 y2) → R1 x1 y1 ∧ R2 x2 y2. (* Elpi Override TC TC.Solver Only Inj Inj2. *) Definition gInj x := x + 1. Definition fInj x := x * 3. Axiom eq1 : relation nat. Axiom eq2 : relation nat. Axiom eq3 : relation nat. Local Instance isInjg : Inj eq3 eq1 gInj. Admitted. Local Instance isInjf : Inj eq1 eq3 fInj. Admitted. Local Instance isInjf_old : Inj eq1 eq2 fInj. Admitted. Local Instance isInjg_old : Inj eq2 eq3 gInj. Admitted. Local Instance isInjf_eq : Inj eq eq fInj. Admitted. Local Instance isInjg_eq : Inj eq eq gInj. Admitted. Local Instance id_inj {A} : Inj eq eq (@id A). Admitted. Local Instance inl_inj {A B} : Inj eq eq (@inl A B). Admitted. Local Instance inr_inj {A B} : Inj eq eq (@inr A B). Admitted. Definition compose {T1 T2 T3: Type} (g: T2 -> T3) (f : T1 -> T2) (x: T1) := g(f x). Local Instance compose_inj {A B C} R1 R2 R3 (f : A -> B) (g : B -> C) : Inj R1 R2 f -> Inj R2 R3 g -> Inj R1 R3 (compose g f). Admitted. Goal exists A B, Inj A B (compose gInj fInj). Admitted. Goal forall (T1 T2 : Type) (f: T1 -> T2), let r := Inj eq eq f in let x := true in (if x then r else r) -> Inj eq eq f. intros ? ? f r x H. unfold x, r in H. apply _. Qed. Goal forall (T1 T2 : Type) (f: T1 -> T2), let r := Inj eq eq f in let b := true in let cond := (match b with | true => r | false => f = f end) in cond -> Inj eq eq f. intros. unfold cond in H. simpl in H. unfold r in H. apply _. Qed. Elpi Override TC TC.Solver All. (* Elpi Print TC.Solver. *) Local Instance inj2_inj_1 `{Inj2 A B C R1 R2 R3 ff} y : Inj R1 R3 (λ x, ff x y). Admitted. Global Instance inj2_inj_2 `{Inj2 A B C R1 R2 R3 ff} x : Inj R2 R3 (ff x). Admitted. Goal Inj2 eq eq eq Nat.mul -> Inj eq eq (Nat.mul 0). intros. apply _. Qed. Goal Inj2 eq eq eq Nat.add -> Inj eq eq (fun x => Nat.add x 0). intros. apply _. Qed. Definition p (T : Type) := @pair T T. Goal Inj eq eq (compose fInj gInj). Proof. apply _. Qed. Elpi Print TC.Solver. Set Warnings "+elpi". Elpi Accumulate tc.db lp:{{ shorten tc-elpi.apps.tc.tests.injTest.{tc-Inj}. % shorten tc-injTest.{tc-Inj}. tc-Inj T1 T2 R1 R3 F S :- F = (fun _ _ _), G = {{ compose _ _ }}, coq.unify-eq G F ok, tc-Inj T1 T2 R1 R3 G S. }}. Elpi Typecheck TC.Solver. Goal Inj eq eq (compose fInj gInj). apply _. Qed. Goal Inj eq eq (fun x => fInj (gInj x)). apply _. Qed. Goal forall (A: Type) (x: A -> A), let y := Inj eq eq x in let z := y in z -> Inj eq eq (compose x x). Proof. intros T x y z H. unfold z, y in H. apply _. Qed.coq-elpi-2.1.0/apps/tc/tests/nobacktrack.v000066400000000000000000000014631460156013500204140ustar00rootroot00000000000000From elpi.apps Require Import tc. Elpi Debug "simple-compiler". Set TC NameShortPath. Module A. Class C (n : nat) := {}. Elpi TC.Set_deterministic C. Elpi TC.Get_class_info C. Local Instance c_1 : C 1 | 10 := {}. Local Instance c_2 : C 2 | 1 := {}. Class D (n : nat) := {}. Local Instance d_1 : D 1 := {}. Class E (n : nat) := {}. Local Instance foo {n} : C n -> D n -> E n := {}. Elpi Override TC TC.Solver All. Goal exists n, E n. eexists. Fail apply _. Abort. End A. Module B. Class A (T : Set) := f : T -> T. Elpi TC.Set_deterministic A. Global Instance A1 : A bool := {f x := x}. Global Instance A2 `(A bool) : A (bool * bool) := {f x := x}. Global Instance A3 `(A nat) : A (bool * bool) := {f x := x}. Goal A (bool * bool). apply _. Qed. End B.coq-elpi-2.1.0/apps/tc/tests/patternFragment.v000066400000000000000000000036331460156013500212740ustar00rootroot00000000000000From elpi.apps Require Import tc. Elpi Override TC TC.Solver All. Set TC NameShortPath. Set TC CompilerWithPatternFragment. Class Y (A: Type). Class Z (A: Type). Class Ex (P : Type -> Type) (A: Type). Module M4. Local Instance Inst2 A F: (forall (a : Type) (b c : nat), Y (F a b) -> Y (F a c)) -> Z A. Qed. Goal Z bool. Elpi Override TC TC.Solver None. Fail apply _. Elpi Override TC TC.Solver All. apply _. Show Proof. Unshelve. assumption. (* we keep a, the first arg of F *) Show Proof. Qed. Local Instance Inst1: Y (bool * bool). Qed. Goal Z bool. Elpi Override TC TC.Solver None. Succeed apply _. Elpi Override TC TC.Solver All. apply _. Show Proof. Unshelve. apply bool. Show Proof. Qed. End M4. Module M5. Local Instance Inst1: Y (bool * bool). Qed. Local Instance Inst2 A F (R: Type -> Type -> Type): forall x, (forall (a : Type), Y (F a)) -> Ex (R x) A. Qed. Goal forall (A:Type) x (R: Type -> Type -> Type ->Type), Ex (R x x) A. apply _. Qed. End M5. Module M1. Local Instance Inst1: Y (bool * bool). Qed. Local Instance Inst2 A F: (forall (a : Type), Y (F a)) -> Z A. Qed. Goal forall (A:Type), Z A. apply _. Qed. End M1. Module M2. Local Instance Inst1: Y (bool * bool). Qed. Local Instance Inst2 A F: (forall (a: Type), Y (F a)) -> Z A. Qed. Goal Z bool. apply _. Qed. End M2. Module M3. Local Instance Inst1: Y (bool * bool). Qed. Local Instance Inst2 A F: (forall (a b c d: Type), Y (F b c d)) -> Z A. Qed. Goal Z bool. apply _. Qed. End M3. Module M6. Local Instance Inst1: Y (bool * bool). Qed. Local Instance Inst2 A F: (forall (a b c d e f g: Type), Y (F a b c d) -> Y (F e f g a)) -> Z A. Qed. Goal Z bool. apply _. Unshelve. apply nat. Qed. End M6. Module M1b. Local Instance Inst2 A F: (forall (a : Type), Y (F a)) -> Ex F A. Qed. Goal forall (A:Type) (f : Type -> Type), (forall x, Y (f x)) -> exists f, Ex f A. intros. eexists. apply _. Unshelve. apply A. Qed. End M1b. coq-elpi-2.1.0/apps/tc/tests/register/000077500000000000000000000000001460156013500175635ustar00rootroot00000000000000coq-elpi-2.1.0/apps/tc/tests/register/f1.v000066400000000000000000000002071460156013500202570ustar00rootroot00000000000000From elpi.apps Require Import tc. Elpi Override TC TC.Solver All. Class A (n : nat). Instance I1 : A 1. Qed. Goal A 1. apply _. Qed.coq-elpi-2.1.0/apps/tc/tests/register/f2.v000066400000000000000000000002571460156013500202650ustar00rootroot00000000000000From elpi.apps.tc.tests.register Require Export f1. Goal A 1. apply _. Qed. Elpi TC Deactivate Observer TC.Compiler. Instance I2 : A 2. Qed. Goal A 2. Fail apply _. Abort.coq-elpi-2.1.0/apps/tc/tests/register/f3.v000066400000000000000000000012361460156013500202640ustar00rootroot00000000000000From elpi.apps.tc.tests.register Require Import f2. (* Note that in f2, TC.Compiler has been deactivated, therefore I3 should not be added *) Instance I3 : A 3. Qed. Goal A 3. Fail apply _. Abort. Elpi Command custom_observer. Elpi Accumulate lp:{{ main L :- coq.say "Received the following event" L. }}. Elpi TC Activate Observer TC.Compiler. Elpi Register TC Compiler custom_observer. Elpi TC Activate Observer custom_observer. (* Here we have two active event listener for the instance creation: custom observer which simply prints the received event and TC.Compiler that adds I4 to the db *) Instance I4 : A 4. Qed. Goal A 4. apply _. Qed. coq-elpi-2.1.0/apps/tc/tests/section_in_out.v000066400000000000000000000030341460156013500211470ustar00rootroot00000000000000From elpi.apps Require Import tc. From elpi.apps.tc Extra Dependency "base.elpi" as base. Elpi Accumulate tc.db lp:{{ pred origial_tc o:int. }}. Elpi Command len_test. Elpi Accumulate Db tc.db. Elpi Accumulate File base. Elpi Accumulate lp:{{ % contains the number of instances that are not % imported from other files main [int Len] :- std.findall (instance _ _ _) Insts, std.map Insts (x\r\ instance _ r _ = x) R, WantedLength is {origial_tc} + Len, std.assert! ({std.length R} = WantedLength) "Unexpected number of instances", std.forall R (x\ sigma L\ std.assert! (count R x L, L = 1) "Duplicates in instances"). }}. Elpi Query TC.Solver lp:{{ std.findall (instance _ _ _) Rules, std.length Rules Len, coq.elpi.accumulate _ "tc.db" (clause _ _ (origial_tc Len)). }}. Class Eqb A:= eqb: A -> A -> bool. Global Instance eqA : Eqb unit := { eqb x y := true }. Elpi len_test 1. Section A. Context (A : Type). Global Instance eqB : Eqb bool := { eqb x y := if x then y else negb y }. Elpi len_test 2. Global Instance eqC : Eqb A := {eqb _ _ := true}. Elpi len_test 3. Section B. Context (B : Type). Global Instance eqD : Eqb B := {eqb _ _ := true}. Elpi len_test 4. End B. Elpi len_test 4. End A. Elpi len_test 4. Section ClassPersistence. Section S1. Context (X : Type) (A : X). Class class (A : X). Definition x : class A. apply Build_class. Qed. Elpi TC.AddInstances x. Goal exists x, class x. eexists. apply _. Qed. End S1. End ClassPersistence.coq-elpi-2.1.0/apps/tc/tests/stdppInj.v000066400000000000000000000236461460156013500177340ustar00rootroot00000000000000(* Test inspired from https://gitlab.mpi-sws.org/iris/stdpp/-/blob/8c98553ad0ca2029b30cf18b58e321ec3a79172b/stdpp/base.v *) From Coq Require Export Morphisms RelationClasses List Bool Setoid Peano Utf8. From Coq Require Import Permutation. Export ListNotations. From Coq.Program Require Export Basics Syntax. From elpi.apps Require Import tc. Elpi Override TC TC.Solver All. Elpi TC.AddAllClasses. Elpi TC.AddAllInstances. Notation length := Datatypes.length. Global Generalizable All Variables. Global Unset Transparent Obligations. Definition tc_opaque {A} (x : A) : A := x. (* Typeclasses Opaque tc_opaque. *) Global Arguments tc_opaque {_} _ /. Declare Scope stdpp_scope. Delimit Scope stdpp_scope with stdpp. Global Open Scope stdpp_scope. Notation "(=)" := eq (only parsing) : stdpp_scope. Notation "( x =.)" := (eq x) (only parsing) : stdpp_scope. Notation "(.= x )" := (λ y, eq y x) (only parsing) : stdpp_scope. Notation "(≠)" := (λ x y, x ≠ y) (only parsing) : stdpp_scope. Notation "( x ≠.)" := (λ y, x ≠ y) (only parsing) : stdpp_scope. Notation "(.≠ x )" := (λ y, y ≠ x) (only parsing) : stdpp_scope. Infix "=@{ A }" := (@eq A) (at level 70, only parsing, no associativity) : stdpp_scope. Notation "(=@{ A } )" := (@eq A) (only parsing) : stdpp_scope. Notation "(≠@{ A } )" := (λ X Y, ¬X =@{A} Y) (only parsing) : stdpp_scope. Notation "X ≠@{ A } Y":= (¬X =@{ A } Y) (at level 70, only parsing, no associativity) : stdpp_scope. Global Hint Extern 0 (_ = _) => reflexivity : core. Global Hint Extern 100 (_ ≠ _) => discriminate : core. Global Instance: ∀ A, PreOrder (=@{A}). Proof. split; repeat intro; congruence. Qed. Class Equiv A := equiv: relation A. Global Instance equiv_rewrite_relation `{Equiv A} : RewriteRelation (@equiv A _) | 150 := {}. Infix "≡" := equiv (at level 70, no associativity) : stdpp_scope. Infix "≡@{ A }" := (@equiv A _) (at level 70, only parsing, no associativity) : stdpp_scope. Notation "(≡)" := equiv (only parsing) : stdpp_scope. Notation "( X ≡.)" := (equiv X) (only parsing) : stdpp_scope. Notation "(.≡ X )" := (λ Y, Y ≡ X) (only parsing) : stdpp_scope. Notation "(≢)" := (λ X Y, ¬X ≡ Y) (only parsing) : stdpp_scope. Notation "X ≢ Y":= (¬X ≡ Y) (at level 70, no associativity) : stdpp_scope. Notation "( X ≢.)" := (λ Y, X ≢ Y) (only parsing) : stdpp_scope. Notation "(.≢ X )" := (λ Y, Y ≢ X) (only parsing) : stdpp_scope. Notation "(≡@{ A } )" := (@equiv A _) (only parsing) : stdpp_scope. Notation "(≢@{ A } )" := (λ X Y, ¬X ≡@{A} Y) (only parsing) : stdpp_scope. Notation "X ≢@{ A } Y":= (¬X ≡@{ A } Y) (at level 70, only parsing, no associativity) : stdpp_scope. Class LeibnizEquiv A `{Equiv A} := leibniz_equiv (x y : A) : x ≡ y → x = y. Global Hint Mode LeibnizEquiv ! - : typeclass_instances. Global Instance: Params (@equiv) 2 := {}. Global Instance equiv_default_relation `{Equiv A} : DefaultRelation (≡@{A}) | 3 := {}. Global Hint Extern 0 (_ ≡ _) => reflexivity : core. Global Hint Extern 0 (_ ≡ _) => symmetry; assumption : core. Class Inj {A B} (R : relation A) (S : relation B) (f : A → B) : Prop := inj x y : S (f x) (f y) → R x y. Class Inj2 {A B C} (R1 : relation A) (R2 : relation B) (S : relation C) (f : A → B → C) : Prop := inj2 x1 x2 y1 y2 : S (f x1 x2) (f y1 y2) → R1 x1 y1 ∧ R2 x2 y2. Global Arguments irreflexivity {_} _ {_} _ _ : assert. Global Arguments inj {_ _ _ _} _ {_} _ _ _ : assert. Global Arguments inj2 {_ _ _ _ _ _} _ {_} _ _ _ _ _: assert. Global Instance inj2_inj_1 `{Inj2 A B C R1 R2 R3 f} y : Inj R1 R3 (λ x, f x y). Proof. repeat intro; edestruct (inj2 f); eauto. Qed. Global Instance inj2_inj_2 `{Inj2 A B C R1 R2 R3 f} x : Inj R2 R3 (f x). Proof. repeat intro; edestruct (inj2 f); eauto. Qed. Notation "(∧)" := and (only parsing) : stdpp_scope. Notation "( A ∧.)" := (and A) (only parsing) : stdpp_scope. Notation "(.∧ B )" := (λ A, A ∧ B) (only parsing) : stdpp_scope. Notation "(∨)" := or (only parsing) : stdpp_scope. Notation "( A ∨.)" := (or A) (only parsing) : stdpp_scope. Notation "(.∨ B )" := (λ A, A ∨ B) (only parsing) : stdpp_scope. Notation "(↔)" := iff (only parsing) : stdpp_scope. Notation "( A ↔.)" := (iff A) (only parsing) : stdpp_scope. Notation "(.↔ B )" := (λ A, A ↔ B) (only parsing) : stdpp_scope. Global Hint Extern 0 (_ ↔ _) => reflexivity : core. Global Hint Extern 0 (_ ↔ _) => symmetry; assumption : core. Notation "(→)" := (λ A B, A → B) (only parsing) : stdpp_scope. Notation "( A →.)" := (λ B, A → B) (only parsing) : stdpp_scope. Notation "(.→ B )" := (λ A, A → B) (only parsing) : stdpp_scope. Notation "t $ r" := (t r) (at level 65, right associativity, only parsing) : stdpp_scope. Notation "($)" := (λ f x, f x) (only parsing) : stdpp_scope. Notation "(.$ x )" := (λ f, f x) (only parsing) : stdpp_scope. Infix "∘" := compose : stdpp_scope. Notation "(∘)" := compose (only parsing) : stdpp_scope. Notation "( f ∘.)" := (compose f) (only parsing) : stdpp_scope. Notation "(.∘ f )" := (λ g, compose g f) (only parsing) : stdpp_scope. (** Ensure that [simpl] unfolds [id], [compose], and [flip] when fully applied. *) Global Arguments id _ _ / : assert. Global Arguments compose _ _ _ _ _ _ / : assert. Global Arguments flip _ _ _ _ _ _ / : assert. Global Arguments const _ _ _ _ / : assert. Definition fun_map {A A' B B'} (f: A' → A) (g: B → B') (h : A → B) : A' → B' := g ∘ h ∘ f. Global Instance id_inj {A} : Inj (=) (=) (@id A). Proof. intros ??; auto. Qed. Global Instance compose_inj {A B C} R1 R2 R3 (f : A → B) (g : B → C) : Inj R1 R2 f → Inj R2 R3 g → Inj R1 R3 (g ∘ f). Proof. red; intuition. Qed. (** ** Products *) Notation "( x ,.)" := (pair x) (only parsing) : stdpp_scope. Notation "(., y )" := (λ x, (x,y)) (only parsing) : stdpp_scope. Notation "p .1" := (fst p) (at level 2, left associativity, format "p .1"). Notation "p .2" := (snd p) (at level 2, left associativity, format "p .2"). Definition prod_map {A A' B B'} (f: A → A') (g: B → B') (p : A * B) : A' * B' := (f (p.1), g (p.2)). Global Arguments prod_map {_ _ _ _} _ _ !_ / : assert. Global Instance pair_inj {A B} : Inj2 (=) (=) (=) (@pair A B). Proof. injection 1; auto. Qed. Global Instance prod_map_inj {A A' B B'} (f : A → A') (g : B → B') : Inj (=) (=) f → Inj (=) (=) g → Inj (=) (=) (prod_map f g). Proof. intros ?? [??] [??] ?; simpl in *; f_equal; [apply (inj f)|apply (inj g)]; congruence. Qed. Definition prod_relation {A B} (R1 : relation A) (R2 : relation B) : relation (A * B) := λ x y, R1 (x.1) (y.1) ∧ R2 (x.2) (y.2). Section prod_relation. Context `{RA : relation A, RB : relation B}. Global Instance pair_inj' : Inj2 RA RB (prod_relation RA RB) pair. Proof. inversion_clear 1; eauto. Qed. End prod_relation. Global Instance prod_equiv `{Equiv A,Equiv B} : Equiv (A * B) := prod_relation (≡) (≡). Section prod_setoid. Context `{Equiv A, Equiv B}. Elpi Accumulate TC.Solver lp:{{ shorten tc-elpi.apps.tc.tests.stdppInj.{tc-Inj2}. % shorten tc-stdppInj.{tc-Inj2}. tc-Inj2 A B C RA RB RC F S :- RC = app [global {coq.locate "equiv"} | _], Res = {{prod_relation _ _}}, coq.unify-eq RC Res ok, tc-Inj2 A B C RA RB Res F S. }}. Elpi Typecheck TC.Solver. Global Instance pair_equiv_inj : Inj2 (≡) (≡) (≡@{A*B}) pair := _. End prod_setoid. (* Typeclasses Opaque prod_equiv. *) (** ** Sums *) Definition sum_map {A A' B B'} (f: A → A') (g: B → B') (xy : A + B) : A' + B' := match xy with inl x => inl (f x) | inr y => inr (g y) end. Global Arguments sum_map {_ _ _ _} _ _ !_ / : assert. Global Instance inl_inj {A B} : Inj (=) (=) (@inl A B). Proof. injection 1; auto. Qed. Global Instance inr_inj {A B} : Inj (=) (=) (@inr A B). Proof. injection 1; auto. Qed. Global Instance sum_map_inj {A A' B B'} (f : A → A') (g : B → B') : Inj (=) (=) f → Inj (=) (=) g → Inj (=) (=) (sum_map f g). Proof. intros ?? [?|?] [?|?] [=]; f_equal; apply (inj _); auto. Qed. Inductive sum_relation {A B} (RA : relation A) (RB : relation B) : relation (A + B) := | inl_related x1 x2 : RA x1 x2 → sum_relation RA RB (inl x1) (inl x2) | inr_related y1 y2 : RB y1 y2 → sum_relation RA RB (inr y1) (inr y2). Section sum_relation. Context `{RA : relation A, RB : relation B}. Global Instance inl_inj' : Inj RA (sum_relation RA RB) inl. Proof. inversion_clear 1; auto. Qed. Global Instance inr_inj' : Inj RB (sum_relation RA RB) inr. Proof. inversion_clear 1; auto. Qed. End sum_relation. Global Instance sum_equiv `{Equiv A, Equiv B} : Equiv (A + B) := sum_relation (≡) (≡). Elpi Accumulate TC.Solver lp:{{ shorten tc-elpi.apps.tc.tests.stdppInj.{tc-Inj}. % shorten tc-stdppInj.{tc-Inj}. tc-Inj A B RA {{@equiv (sum _ _) (@sum_equiv _ _ _ _)}} S C :- tc-Inj A B RA {{sum_relation _ _}} S C. }}. Elpi Typecheck TC.Solver. Global Instance inl_equiv_inj `{Equiv A, Equiv B} : Inj (≡) (≡) (@inl A B) := _. Global Instance inr_equiv_inj `{Equiv A, Equiv B} : Inj (≡) (≡) (@inr A B) := _. Notation "` x" := (proj1_sig x) (at level 10, format "` x") : stdpp_scope. Elpi Accumulate TC.Solver lp:{{ shorten tc-elpi.apps.tc.tests.stdppInj.{tc-Inj}. tc-Inj A B RA RB F X :- F = fun _ _ _, G = {{@compose _ _ _ _ _}}, coq.unify-eq G F ok, tc-Inj A B RA RB G X. }}. Elpi Typecheck TC.Solver. Definition f := Nat.add 0. Global Instance h: Inj eq eq f. unfold f. simpl. easy. Qed. Elpi Accumulate TC.Solver lp:{{ shorten tc-elpi.apps.tc.tests.stdppInj.{tc-Inj}. :after "lastHook" tc-Inj A B RA RB F S :- F = (fun _ _ _), !, G = {{ compose _ _ }}, coq.unify-eq G F ok, tc-Inj A B RA RB G S. }}. Set Warnings "+elpi". Elpi Typecheck TC.Solver. Goal Inj eq eq (compose (@id nat) id). apply _. Qed. Goal Inj eq eq (compose (compose (@id nat) id) id). apply _. Qed. Goal Inj eq eq (fun (x:nat) => id (id x)). apply _. Qed. Goal Inj eq eq (fun (x: nat) => (compose id id) (id x)). apply (compose_inj eq eq); apply _. Qed.coq-elpi-2.1.0/apps/tc/tests/stdppInjClassic.v000066400000000000000000000213111460156013500212210ustar00rootroot00000000000000(* File inspired from https://gitlab.mpi-sws.org/iris/stdpp/-/blob/8c98553ad0ca2029b30cf18b58e321ec3a79172b/stdpp/base.v *) From Coq Require Export Morphisms RelationClasses List Bool Setoid Peano Utf8. From Coq Require Import Permutation. Export ListNotations. From Coq.Program Require Export Basics Syntax. Notation length := Datatypes.length. Global Generalizable All Variables. Global Unset Transparent Obligations. Definition tc_opaque {A} (x : A) : A := x. (* Typeclasses Opaque tc_opaque. *) Global Arguments tc_opaque {_} _ /. Declare Scope stdpp_scope. Delimit Scope stdpp_scope with stdpp. Global Open Scope stdpp_scope. Notation "(=)" := eq (only parsing) : stdpp_scope. Notation "( x =.)" := (eq x) (only parsing) : stdpp_scope. Notation "(.= x )" := (λ y, eq y x) (only parsing) : stdpp_scope. Notation "(≠)" := (λ x y, x ≠ y) (only parsing) : stdpp_scope. Notation "( x ≠.)" := (λ y, x ≠ y) (only parsing) : stdpp_scope. Notation "(.≠ x )" := (λ y, y ≠ x) (only parsing) : stdpp_scope. Infix "=@{ A }" := (@eq A) (at level 70, only parsing, no associativity) : stdpp_scope. Notation "(=@{ A } )" := (@eq A) (only parsing) : stdpp_scope. Notation "(≠@{ A } )" := (λ X Y, ¬X =@{A} Y) (only parsing) : stdpp_scope. Notation "X ≠@{ A } Y":= (¬X =@{ A } Y) (at level 70, only parsing, no associativity) : stdpp_scope. Global Hint Extern 0 (_ = _) => reflexivity : core. Global Hint Extern 100 (_ ≠ _) => discriminate : core. Global Instance: ∀ A, PreOrder (=@{A}). Proof. split; repeat intro; congruence. Qed. Class Equiv A := equiv: relation A. Global Instance equiv_rewrite_relation `{Equiv A} : RewriteRelation (@equiv A _) | 150 := {}. Infix "≡" := equiv (at level 70, no associativity) : stdpp_scope. Infix "≡@{ A }" := (@equiv A _) (at level 70, only parsing, no associativity) : stdpp_scope. Notation "(≡)" := equiv (only parsing) : stdpp_scope. Notation "( X ≡.)" := (equiv X) (only parsing) : stdpp_scope. Notation "(.≡ X )" := (λ Y, Y ≡ X) (only parsing) : stdpp_scope. Notation "(≢)" := (λ X Y, ¬X ≡ Y) (only parsing) : stdpp_scope. Notation "X ≢ Y":= (¬X ≡ Y) (at level 70, no associativity) : stdpp_scope. Notation "( X ≢.)" := (λ Y, X ≢ Y) (only parsing) : stdpp_scope. Notation "(.≢ X )" := (λ Y, Y ≢ X) (only parsing) : stdpp_scope. Notation "(≡@{ A } )" := (@equiv A _) (only parsing) : stdpp_scope. Notation "(≢@{ A } )" := (λ X Y, ¬X ≡@{A} Y) (only parsing) : stdpp_scope. Notation "X ≢@{ A } Y":= (¬X ≡@{ A } Y) (at level 70, only parsing, no associativity) : stdpp_scope. Class LeibnizEquiv A `{Equiv A} := leibniz_equiv (x y : A) : x ≡ y → x = y. Global Hint Mode LeibnizEquiv ! - : typeclass_instances. Global Instance: Params (@equiv) 2 := {}. Global Instance equiv_default_relation `{Equiv A} : DefaultRelation (≡@{A}) | 3 := {}. Global Hint Extern 0 (_ ≡ _) => reflexivity : core. Global Hint Extern 0 (_ ≡ _) => symmetry; assumption : core. Class Inj {A B} (R : relation A) (S : relation B) (f : A → B) : Prop := inj x y : S (f x) (f y) → R x y. Class Inj2 {A B C} (R1 : relation A) (R2 : relation B) (S : relation C) (f : A → B → C) : Prop := inj2 x1 x2 y1 y2 : S (f x1 x2) (f y1 y2) → R1 x1 y1 ∧ R2 x2 y2. Global Arguments irreflexivity {_} _ {_} _ _ : assert. Global Arguments inj {_ _ _ _} _ {_} _ _ _ : assert. Global Arguments inj2 {_ _ _ _ _ _} _ {_} _ _ _ _ _: assert. Global Instance inj2_inj_1 `{Inj2 A B C R1 R2 R3 f} y : Inj R1 R3 (λ x, f x y). Proof. repeat intro; edestruct (inj2 f); eauto. Qed. Global Instance inj2_inj_2 `{Inj2 A B C R1 R2 R3 f} x : Inj R2 R3 (f x). Proof. repeat intro; edestruct (inj2 f); eauto. Qed. Notation "(∧)" := and (only parsing) : stdpp_scope. Notation "( A ∧.)" := (and A) (only parsing) : stdpp_scope. Notation "(.∧ B )" := (λ A, A ∧ B) (only parsing) : stdpp_scope. Notation "(∨)" := or (only parsing) : stdpp_scope. Notation "( A ∨.)" := (or A) (only parsing) : stdpp_scope. Notation "(.∨ B )" := (λ A, A ∨ B) (only parsing) : stdpp_scope. Notation "(↔)" := iff (only parsing) : stdpp_scope. Notation "( A ↔.)" := (iff A) (only parsing) : stdpp_scope. Notation "(.↔ B )" := (λ A, A ↔ B) (only parsing) : stdpp_scope. Global Hint Extern 0 (_ ↔ _) => reflexivity : core. Global Hint Extern 0 (_ ↔ _) => symmetry; assumption : core. Notation "(→)" := (λ A B, A → B) (only parsing) : stdpp_scope. Notation "( A →.)" := (λ B, A → B) (only parsing) : stdpp_scope. Notation "(.→ B )" := (λ A, A → B) (only parsing) : stdpp_scope. Notation "t $ r" := (t r) (at level 65, right associativity, only parsing) : stdpp_scope. Notation "($)" := (λ f x, f x) (only parsing) : stdpp_scope. Notation "(.$ x )" := (λ f, f x) (only parsing) : stdpp_scope. Infix "∘" := compose : stdpp_scope. Notation "(∘)" := compose (only parsing) : stdpp_scope. Notation "( f ∘.)" := (compose f) (only parsing) : stdpp_scope. Notation "(.∘ f )" := (λ g, compose g f) (only parsing) : stdpp_scope. (** Ensure that [simpl] unfolds [id], [compose], and [flip] when fully applied. *) Global Arguments id _ _ / : assert. Global Arguments compose _ _ _ _ _ _ / : assert. Global Arguments flip _ _ _ _ _ _ / : assert. Global Arguments const _ _ _ _ / : assert. Definition fun_map {A A' B B'} (f: A' → A) (g: B → B') (h : A → B) : A' → B' := g ∘ h ∘ f. Global Instance id_inj {A} : Inj (=) (=) (@id A). Proof. intros ??; auto. Qed. Global Instance compose_inj {A B C} R1 R2 R3 (f : A → B) (g : B → C) : Inj R1 R2 f → Inj R2 R3 g → Inj R1 R3 (g ∘ f). Proof. red; intuition. Qed. (** ** Products *) Notation "( x ,.)" := (pair x) (only parsing) : stdpp_scope. Notation "(., y )" := (λ x, (x,y)) (only parsing) : stdpp_scope. Notation "p .1" := (fst p) (at level 2, left associativity, format "p .1"). Notation "p .2" := (snd p) (at level 2, left associativity, format "p .2"). Definition prod_map {A A' B B'} (f: A → A') (g: B → B') (p : A * B) : A' * B' := (f (p.1), g (p.2)). Global Arguments prod_map {_ _ _ _} _ _ !_ / : assert. Global Instance pair_inj {A B} : Inj2 (=) (=) (=) (@pair A B). Proof. injection 1; auto. Qed. Global Instance prod_map_inj {A A' B B'} (f : A → A') (g : B → B') : Inj (=) (=) f → Inj (=) (=) g → Inj (=) (=) (prod_map f g). Proof. intros ?? [??] [??] ?; simpl in *; f_equal; [apply (inj f)|apply (inj g)]; congruence. Qed. Definition prod_relation {A B} (R1 : relation A) (R2 : relation B) : relation (A * B) := λ x y, R1 (x.1) (y.1) ∧ R2 (x.2) (y.2). Section prod_relation. Context `{RA : relation A, RB : relation B}. Global Instance pair_inj' : Inj2 RA RB (prod_relation RA RB) pair. Proof. inversion_clear 1; eauto. Qed. End prod_relation. Global Instance prod_equiv `{Equiv A,Equiv B} : Equiv (A * B) := prod_relation (≡) (≡). Section prod_setoid. Context `{Equiv A, Equiv B}. Global Instance pair_equiv_inj : Inj2 (≡) (≡) (≡@{A*B}) pair := _. End prod_setoid. (* Typeclasses Opaque prod_equiv. *) (** ** Sums *) Definition sum_map {A A' B B'} (f: A → A') (g: B → B') (xy : A + B) : A' + B' := match xy with inl x => inl (f x) | inr y => inr (g y) end. Global Arguments sum_map {_ _ _ _} _ _ !_ / : assert. Global Instance inl_inj {A B} : Inj (=) (=) (@inl A B). Proof. injection 1; auto. Qed. Global Instance inr_inj {A B} : Inj (=) (=) (@inr A B). Proof. injection 1; auto. Qed. Global Instance sum_map_inj {A A' B B'} (f : A → A') (g : B → B') : Inj (=) (=) f → Inj (=) (=) g → Inj (=) (=) (sum_map f g). Proof. intros ?? [?|?] [?|?] [=]; f_equal; apply (inj _); auto. Qed. Inductive sum_relation {A B} (RA : relation A) (RB : relation B) : relation (A + B) := | inl_related x1 x2 : RA x1 x2 → sum_relation RA RB (inl x1) (inl x2) | inr_related y1 y2 : RB y1 y2 → sum_relation RA RB (inr y1) (inr y2). Section sum_relation. Context `{RA : relation A, RB : relation B}. Global Instance inl_inj' : Inj RA (sum_relation RA RB) inl. Proof. inversion_clear 1; auto. Qed. Global Instance inr_inj' : Inj RB (sum_relation RA RB) inr. Proof. inversion_clear 1; auto. Qed. End sum_relation. Global Instance sum_equiv `{Equiv A, Equiv B} : Equiv (A + B) := sum_relation (≡) (≡). Global Instance inl_equiv_inj `{Equiv A, Equiv B} : Inj (≡) (≡) (@inl A B) := _. Global Instance inr_equiv_inj `{Equiv A, Equiv B} : Inj (≡) (≡) (@inr A B) := _. Notation "` x" := (proj1_sig x) (at level 10, format "` x") : stdpp_scope. Definition f := Nat.add 0. Global Instance h: Inj eq eq f. unfold f. simpl. easy. Qed. Goal Inj eq eq (compose (@id nat) id). apply _. Qed. Goal Inj eq eq (compose (compose (@id nat) id) id). apply _. Qed. (* Goal Inj eq eq (fun (x:nat) => id (id x)). apply _. Qed. *) Goal Inj eq eq (fun (x: nat) => (compose id id) (id x)). apply (compose_inj eq eq); apply _. Qed.coq-elpi-2.1.0/apps/tc/tests/test.v000066400000000000000000000014561460156013500171130ustar00rootroot00000000000000From elpi.apps.tc.tests Require Import stdppInj. Elpi TC.Solver. Set TC TimeRefine. Set TC ResolutionTime. Set Debug "elpitime". Elpi Accumulate TC.Solver lp:{{ shorten tc-elpi.apps.tc.tests.stdppInj.{tc-Inj}. :after "firstHook" tc-Inj A B RA RB {{@compose lp:A lp:A lp:A lp:FL lp:FL}} Sol :- !, tc-Inj A B RA RB FL Sol1, coq.typecheck A TA ok, coq.typecheck RA TRA ok, coq.typecheck FL TFL ok, coq.typecheck Sol1 TSol1 ok, Sol = {{ let a : lp:TA := lp:A in let sol : lp:TSol1 := lp:Sol1 in let ra : lp:TRA := lp:RA in let fl : lp:TFL := lp:FL in @compose_inj a a a ra ra ra fl fl sol sol}}. }}. Elpi Typecheck TC.Solver. Goal Inj eq eq((compose (compose (compose f f )(compose f f ))(compose (compose f f )(compose f f )))). Time apply _. Qed. coq-elpi-2.1.0/apps/tc/tests/test_commands_API.v000066400000000000000000000021141460156013500214550ustar00rootroot00000000000000From elpi.apps Require Import tc. From elpi.apps.tc.tests Require Import eqSimplDef. Elpi Command len_test. Elpi Accumulate Db tc.db. Elpi Accumulate lp:{{ pred count i:gref, i:int. count GR Len :- if (const _ = GR) (std.findall (instance _ _ GR) Cl, std.assert! ({std.length Cl} = Len) "Unexpected number of instances") true. main [str E, int Len] :- coq.locate E GR, count GR Len. }}. Elpi Typecheck. Elpi AddClasses Eqb. Module test1. Elpi AddInstances Eqb ignoreInstances eqP. Elpi len_test Eqb 2. End test1. Reset test1. Module test2. Elpi len_test Eqb 0. End test2. Reset test2. Module test3. Elpi AddInstances Eqb. Elpi len_test Eqb 3. End test3. Reset test3. (* About RewriteRelation. About RelationClasses.RewriteRelation. Elpi Query TC.Solver lp:{{ coq.gref->id {{:gref RelationClasses.RewriteRelation}} L. }}. *) Module test4. Elpi AddAllClasses. Elpi AddAllInstances eqU. Elpi Query TC.Solver lp:{{ EqP = {{:gref eqU}}, std.assert! (not (instance _ EqP _)) "EqP should not be in the DB". }}. End test4.coq-elpi-2.1.0/apps/tc/tests/test_tc.v000066400000000000000000000003101460156013500175650ustar00rootroot00000000000000From elpi.apps Require Import tc. Elpi Override TC TC.Solver All. Class a (N: nat). Instance b : a 3. Qed. Instance c : a 4. Qed. Elpi AddAllClasses. Elpi AddAllInstances. Goal a 4. apply _. Qed. coq-elpi-2.1.0/apps/tc/theories/000077500000000000000000000000001460156013500164175ustar00rootroot00000000000000coq-elpi-2.1.0/apps/tc/theories/add_commands.v000066400000000000000000000064371460156013500212310ustar00rootroot00000000000000(* license: GNU Lesser General Public License Version 2.1 or later *) (* ------------------------------------------------------------------------- *) From elpi.apps Require Import db. From elpi.apps.tc Extra Dependency "tc_aux.elpi" as tc_aux. From elpi.apps.tc Extra Dependency "compiler.elpi" as compiler. From elpi.apps.tc Extra Dependency "parser_addInstances.elpi" as parser_addInstances. From elpi.apps.tc Extra Dependency "solver.elpi" as solver. From elpi.apps.tc Extra Dependency "create_tc_predicate.elpi" as create_tc_predicate. Elpi Command TC.AddAllInstances. Elpi Accumulate Db tc.db. Elpi Accumulate Db tc_options.db. Elpi Accumulate File compiler. Elpi Accumulate lp:{{ main L :- args->str-list L L1, std.forall {coq.TC.db-tc} (x\ add-tc-or-inst-gr [] L1 [x]). }}. Elpi Typecheck. Elpi Command TC.AddInstances. Elpi Accumulate Db tc.db. Elpi Accumulate Db tc_options.db. Elpi Accumulate File parser_addInstances. Elpi Accumulate lp:{{ main Arguments :- parse Arguments Res, run-command Res. }}. Elpi Typecheck. Elpi Command TC.AddAllClasses. Elpi Accumulate Db tc.db. Elpi Accumulate Db tc_options.db. Elpi Accumulate File create_tc_predicate. Elpi Accumulate lp:{{ % Ignore is the list of classes we do not want to add main IgnoreStr :- std.map IgnoreStr (x\r\ sigma S\ str S = x, coq.locate S r) IgnoreGR, std.forall {coq.TC.db-tc} (x\ if (std.mem IgnoreGR x) true (add-class-gr classic x)). }}. Elpi Typecheck. Elpi Command TC.AddClasses. Elpi Accumulate Db tc.db. Elpi Accumulate Db tc_options.db. Elpi Accumulate File create_tc_predicate. Elpi Accumulate lp:{{ main L :- std.mem {attributes} (attribute "deterministic" _), std.forall {args->str-list L} (add-class-str deterministic). main L :- std.forall {args->str-list L} (add-class-str classic). main _ :- coq.error "This commands accepts: [classic|deterministic]? TC-names*". }}. Elpi Typecheck. Elpi Command TC.AddHook. Elpi Accumulate Db tc.db. Elpi Accumulate Db tc_options.db. Elpi Accumulate File tc_aux. Elpi Accumulate lp:{{ pred addHook i:grafting, i:string. addHook Grafting NewName :- @global! => add-tc-db NewName Grafting (hook NewName). main [str "before", str OldHook, str NewHook] :- addHook (before OldHook) NewHook. main [str "after", str OldHook, str NewHook] :- addHook (after OldHook) NewHook. main [Graft, int OldHook, NewHook] :- main [Graft, str {calc (int_to_string OldHook)}, NewHook]. main [Graft, OldHook, int NewHook] :- main [Graft, OldHook, str {calc (int_to_string NewHook)}]. main _ :- coq.error "Invalid call to command AddHook. A valid call looks like" "[ElpiAddHook Pos OldName NewName] where:" " - Pos is either after or before" " - OldName is the name of an existing hook" " - NewName is the name of the new hook". }}. Elpi Typecheck. Elpi Command TC.Declare. Elpi Accumulate Db tc.db. Elpi Accumulate Db tc_options.db. Elpi Accumulate File create_tc_predicate. Elpi Accumulate lp:{{ main [indt-decl D] :- declare-class D. main _ :- coq.error "Argument should be an inductive type". }}. Elpi Typecheck. Elpi Export TC.AddAllClasses. Elpi Export TC.AddAllInstances. Elpi Export TC.AddClasses. Elpi Export TC.AddInstances. Elpi Export TC.AddHook. Elpi Export TC.Declare.coq-elpi-2.1.0/apps/tc/theories/db.v000066400000000000000000000051041460156013500171730ustar00rootroot00000000000000(* license: GNU Lesser General Public License Version 2.1 or later *) (* ------------------------------------------------------------------------- *) From elpi Require Import elpi. From elpi.apps.tc Extra Dependency "base.elpi". From elpi.apps.tc Extra Dependency "tc_aux.elpi". (* tc_option.db contains the set of options used by the solver of tc. all the options are set to false by default *) Elpi Db tc_options.db lp:{{ pred oTC-ignore-eta-reduction o:list string. oTC-ignore-eta-reduction ["TC", "IgnoreEtaReduction"]. % Time taken by only instance search (we time tc-recursive-search) pred oTC-time-instance-search o:list string. oTC-time-instance-search ["TC", "Time", "Instance", "Search"]. % Time taken by the whole search in tc pred oTC-time o:list string. oTC-time ["TC", "Time"]. % Time taken to refine the solution pred oTC-time-refine o:list string. oTC-time-refine ["TC", "Time", "Refine"]. pred oTC-clauseNameShortName o:list string. oTC-clauseNameShortName ["TC", "NameShortPath"]. pred oTC-debug o:list string. oTC-debug ["TC", "Debug"]. pred oTC-use-pattern-fragment-compiler o:list string. oTC-use-pattern-fragment-compiler ["TC", "CompilerWithPatternFragment"]. pred all-options o:list ((list string) -> prop). all-options [ oTC-ignore-eta-reduction, oTC-time-refine, oTC-time, oTC-clauseNameShortName, oTC-time-instance-search, oTC-debug, oTC-use-pattern-fragment-compiler ]. pred is-option-active i:(list string -> prop). is-option-active Opt :- Opt X, coq.option.get X (coq.option.bool tt). }}. Elpi Db tc.db lp:{{ % the type of search for a typeclass % deterministic :- no backtrack after having found a solution/fail % classic :- the classic search, if a path is failing, we backtrack kind search-mode type. type deterministic search-mode. type classic search-mode. % [instance Path InstGR ClassGR], ClassGR is the class implemented by InstGR pred instance o:list string, o:gref, o:gref. % [class ClassGR PredName SearchMode], for each class GR, it contains % the name of its predicate and its SearchMode pred class o:gref, o:string, o:search-mode. % pred on which we graft instances in the database pred hook o:string. :name "firstHook" hook "firstHook". :name "lastHook" hook "lastHook". % the set of instances that we are not yet able to compile, % in majority they use universe polimorphism pred banned o:gref. % [tc-signature TC Modes], returns for each Typeclass TC % its Modes pred tc-mode i:gref, o:list (pair argument_mode string). }}.coq-elpi-2.1.0/apps/tc/theories/tc.v000066400000000000000000000075301460156013500172210ustar00rootroot00000000000000(* license: GNU Lesser General Public License Version 2.1 or later *) (* ------------------------------------------------------------------------- *) Declare ML Module "coq-elpi-tc.plugin". From elpi.apps.tc Extra Dependency "tc_aux.elpi" as tc_aux. From elpi.apps.tc Extra Dependency "compiler.elpi" as compiler. From elpi.apps.tc Extra Dependency "solver.elpi" as solver. From elpi.apps.tc Extra Dependency "create_tc_predicate.elpi" as create_tc_predicate. From elpi.apps Require Import db. From elpi.apps Require Export add_commands. Elpi Command TC.Print_instances. Elpi Accumulate Db tc.db. Elpi Accumulate lp:{{ pred list-printer i:gref, i:list prop. list-printer _ []. list-printer ClassGR Instances :- std.map Instances (x\r\ x = instance _ r _) InstancesGR, coq.say "Instances list for" ClassGR "is:", std.forall InstancesGR (x\ coq.say " " x). main [str Class] :- std.assert! (coq.locate Class ClassGR) "The entered TC not exists", std.findall (instance _ _ ClassGR) Rules, list-printer ClassGR Rules. main [] :- std.forall {coq.TC.db-tc} (ClassGR\ sigma Rules\ std.findall (instance _ _ ClassGR) Rules, list-printer ClassGR Rules ). }}. Elpi Typecheck. Elpi Tactic TC.Solver. Elpi Accumulate Db tc.db. Elpi Accumulate Db tc_options.db. Elpi Accumulate File compiler. Elpi Accumulate File create_tc_predicate. Elpi Accumulate File solver. Elpi Query lp:{{ sigma Options\ all-options Options, std.forall Options (x\ sigma L\ x L, if (coq.option.available? L _) true (coq.option.add L (coq.option.bool ff) ff)). }}. Elpi Typecheck. Elpi Query lp:{{ sigma Nums\ std.iota 1001 Nums, std.forall Nums (x\ sigma NumStr\ NumStr is int_to_string x, @global! => add-tc-db NumStr (before "lastHook") (hook NumStr) ) }}. Elpi Command TC.Compiler. Elpi Accumulate Db tc.db. Elpi Accumulate Db tc_options.db. Elpi Accumulate File create_tc_predicate. Elpi Accumulate File compiler. Elpi Accumulate lp:{{ main [str Inst, str Cl, str Locality, int Prio] :- !, % coq.safe-dest-app Inst (global GRInst) _, % coq.safe-dest-app Cl (global GRCl) _, coq.locate Cl GRCl, coq.locate Inst GRInst, add-inst GRInst GRCl Locality Prio. main [str Cl] :- !, % coq.safe-dest-app Cl (global GR) _, coq.locate Cl GR, add-class-gr classic GR. main A :- coq.error "Fail in TC.Compiler: not a valid input entry" A. }}. Elpi Typecheck. (* Command allowing to set if a TC is deterministic. *) Elpi Command TC.Set_deterministic. Elpi Accumulate Db tc.db. Elpi Accumulate Db tc_options.db. Elpi Accumulate File tc_aux. Elpi Accumulate lp:{{ main [str ClassStr] :- coq.locate ClassStr ClassGR, std.assert! (coq.TC.class? ClassGR) "Should pass the name of a type class", std.assert! (class ClassGR PredName _) "Cannot find `class ClassGR _ _` in the db", std.assert! (not (instance _ _ ClassGR)) "Cannot set deterministic a class with more than one instance", add-tc-db _ (after "0") (class ClassGR PredName deterministic :- !). }}. Elpi Typecheck. Elpi Command TC.Get_class_info. Elpi Accumulate Db tc.db. Elpi Accumulate lp:{{ main [str ClassStr] :- coq.locate ClassStr ClassGR, class ClassGR PredName SearchMode, coq.say "The predicate of" ClassGR "is" PredName "and search mode is" SearchMode. main [str C] :- coq.error C "is not found in elpi db". main [A] :- std.assert! (str _ = A) true "first argument should be a str". main [_|_] :- coq.error "get_class_info accepts only one argument of type str". main L :- coq.error "Uncaught error on input" L. }}. Elpi Override TC TC.Solver All. Elpi Register TC Compiler TC.Compiler. Elpi Export TC.Print_instances. Elpi Export TC.Solver. Elpi Export TC.Compiler. Elpi Export TC.Get_class_info. Elpi Export TC.Set_deterministic. Elpi TC.AddAllClasses. Elpi TC.AddAllInstances.coq-elpi-2.1.0/apps/tc/theories/wip.v000066400000000000000000000034341460156013500174110ustar00rootroot00000000000000(* license: GNU Lesser General Public License Version 2.1 or later *) (* --------------------------------------------------------------------------*) Declare ML Module "coq-elpi-tc.plugin". From elpi Require Import elpi. From elpi.apps.tc Extra Dependency "base.elpi" as base. From elpi.apps.tc Extra Dependency "compiler.elpi" as compiler. From elpi.apps.tc Extra Dependency "parser_addInstances.elpi" as parser_addInstances. From elpi.apps.tc Extra Dependency "alias.elpi" as alias. From elpi.apps.tc Extra Dependency "solver.elpi" as solver. From elpi.apps.tc Extra Dependency "rewrite_forward.elpi" as rforward. From elpi.apps.tc Extra Dependency "tc_aux.elpi" as tc_aux. From elpi.apps.tc Extra Dependency "create_tc_predicate.elpi" as create_tc_predicate. From elpi.apps Require Import tc. Elpi Command AddForwardRewriting. Elpi Accumulate Db tc.db. Elpi Accumulate Db tc_options.db. Elpi Accumulate File base. Elpi Accumulate File tc_aux. Elpi Accumulate File compiler. Elpi Accumulate File create_tc_predicate. Elpi Accumulate File solver. Elpi Accumulate File tc_aux. Elpi Accumulate File rforward. Elpi Accumulate lp:{{ :before "build-context-clauses" build-context-clauses Ctx Clauses :- !, std.map {coq.env.section} (x\r\ sigma F\ coq.env.typeof (const x) F, r = (decl (global (const x)) _ F)) SectionCtx, std.append Ctx SectionCtx CtxAndSection, compile-ctx {rewrite-dep CtxAndSection} Clauses. main L :- std.forall {args->str-list L} add-lemma->forward. }}. Elpi Typecheck. Elpi Command AddAlias. Elpi Accumulate Db tc.db. Elpi Accumulate Db tc_options.db. Elpi Accumulate File base. Elpi Accumulate File tc_aux. Elpi Accumulate File alias. Elpi Accumulate lp:{{ main [trm New, trm Old] :- add-tc-db _ _ (alias New Old). }}. Elpi Typecheck.coq-elpi-2.1.0/coq-builtin-synterp.elpi000066400000000000000000000343551460156013500200410ustar00rootroot00000000000000 % -- Misc --------------------------------------------------------- % [coq.info ...] Prints an info message external type coq.info variadic any prop. % [coq.notice ...] Prints a notice message external type coq.notice variadic any prop. % [coq.say ...] Prints a notice message external type coq.say variadic any prop. % [coq.warn ...] Prints a generic warning message external type coq.warn variadic any prop. % [coq.warning Category Name ...] % Prints a warning message with a Name and Category which can be used % to silence this warning or turn it into an error. See coqc -w command % line option external type coq.warning string -> string -> variadic any prop. % [coq.error ...] Prints and *aborts* the program. It is a fatal error for % Elpi and Ltac external type coq.error variadic any prop. % [coq.version VersionString Major Minor Patch] Fetches the version of Coq, % as a string and as 3 numbers external pred coq.version o:string, o:int, o:int, o:int. %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %%%%%%%%%%%%%%%%%%%%%%%%%%%% coq-arg-HOAS %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % This section contains the low level data types linking Coq and elpi. % In particular the entry points for commands % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Entry points % % Command and tactic invocation % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Entry point for commands. Eg. "#[att=true] Elpi mycommand foo 3 (f x)." becomes % main [str "foo", int 3, trm (app[f,x])] % in a context where % attributes [attribute "att" (leaf "true")] % holds. The encoding of terms is described below. % See also the coq.parse-attributes utility. pred main i:list argument. pred main-interp i:list argument, i:any. pred main-synterp i:list argument, o:any. pred usage. pred attributes o:list attribute. % see coq-lib.elpi for coq.parse-attributes generating the options below type get-option string -> A -> prop. % The data type of arguments (for commands or tactics) kind argument type. type int int -> argument. % Eg. 1 -2. type str string -> argument. % Eg. x "y" z.w. or any Coq keyword/symbol type trm term -> argument. % Eg. (t). % Extra arguments for commands. [Definition], [Axiom], [Record] and [Context] % take precedence over the [str] argument above (when not "quoted"). % % Eg. Record or Inductive type indt-decl indt-decl -> argument. % Eg. #[universes(polymorphic,...)] Record or Inductive type upoly-indt-decl indt-decl -> upoly-decl -> argument. type upoly-indt-decl indt-decl -> upoly-decl-cumul -> argument. % Eg. Definition or Axiom (when the body is none) type const-decl id -> option term -> arity -> argument. % Eg. #[universes(polymorphic,...)] Definition or Axiom type upoly-const-decl id -> option term -> arity -> upoly-decl -> argument. % Eg. Context A (b : A). type ctx-decl context-decl -> argument. % Declaration of inductive types %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% kind indt-decl type. kind indc-decl type. kind record-decl type. % An arity is written, in Coq syntax, as: % (x : T1) .. (xn : Tn) : S1 -> ... -> Sn -> U % This syntax is used, for example, in the type of an inductive type or % in the type of constructors. We call the abstractions on the left of ":" % "parameters" while we call the type following the ":" (proper) arity. % Note: in some contexts, like the type of an inductive type constructor, % Coq makes no distinction between these two writings % (xn : Tn) : forall y1 : S1, ... and (xn : Tn) (y1 : S1) : ... % while Elpi is a bit more restrictive, since it understands user directives % such as the implicit status of an arguments (eg, using {} instead of () around % the binder), only on parameters. % Moreover parameters carry the name given by the user as an "id", while binders % in terms only carry it as a "name", an irrelevant pretty pringintg hint (see % also the HOAS of terms). A user command can hence only use the names of % parameters, and not the names of "forall" quantified variables in the arity. % % See also the arity->term predicate in coq-lib.elpi type parameter id -> implicit_kind -> term -> (term -> arity) -> arity. type arity term -> arity. type parameter id -> implicit_kind -> term -> (term -> indt-decl) -> indt-decl. type inductive id -> bool -> arity -> (term -> list indc-decl) -> indt-decl. % tt means inductive, ff coinductive type record id -> term -> id -> record-decl -> indt-decl. type constructor id -> arity -> indc-decl. type field field-attributes -> id -> term -> (term -> record-decl) -> record-decl. type end-record record-decl. % Example. % Remark that A is a regular parameter; y is a non-uniform parameter and t % also features an index of type bool. % % Inductive t (A : Type) | (y : nat) : bool -> Type := % | K1 (x : A) {n : nat} : S n = y -> t A n true -> t A y true % | K2 : t A y false % % is written % % (parameter "A" explicit {{ Type }} a\ % inductive "t" tt (parameter "y" explicit {{ nat }} _\ % arity {{ bool -> Type }}) % t\ % [ constructor "K1" % (parameter "y" explicit {{ nat }} y\ % (parameter "x" explicit a x\ % (parameter "n" maximal {{ nat }} n\ % arity {{ S lp:n = lp:y -> lp:t lp:n true -> lp:t lp:y true }}))) % , constructor "K2" % (parameter "y" explicit {{ nat }} y\ % arity {{ lp:t lp:y false }}) ]) % % Remark that the uniform parameters are not passed to occurrences of t, since % they never change, while non-uniform parameters are both abstracted % in each constructor type and passed as arguments to t. % % The coq.typecheck-indt-decl API can be used to fill in implicit arguments % an infer universe constraints in the declaration above (e.g. the hidden % argument of "=" in the arity of K1). % % Note: when and inductive type declaration is passed as an argument to an % Elpi command non uniform parameters must be separated from the uniform ones % with a | (a syntax introduced in Coq 8.12 and accepted by coq-elpi since % version 1.4, in Coq this separator is optional, but not in Elpi). % Context declaration (used as an argument to Elpi commands) kind context-decl type. % Eg. (x : T) or (x := B), body is optional, type may be a variable type context-item id -> implicit_kind -> term -> option term -> (term -> context-decl) -> context-decl. type context-end context-decl. typeabbrev field-attributes (list field-attribute). macro @global! :- get-option "coq:locality" "global". macro @local! :- get-option "coq:locality" "local". % Coq terms are not visible at synterp time, they are always holes kind term type. % -- Parsing time APIs % ---------------------------------------------------- % [id] is a name that matters, we piggy back on Elpi's strings. % Note: [name] is a name that does not matter. typeabbrev id string. % Name of a module /*E*/ typeabbrev modpath (ctype "modpath"). % Name of a module type /*E*/ typeabbrev modtypath (ctype "modtypath"). % [coq.locate-module ModName ModPath] locates a module. It's a fatal error % if ModName cannot be located. *E* external pred coq.locate-module i:id, o:modpath. % [coq.locate-module-type ModName ModPath] locates a module. It's a fatal % error if ModName cannot be located. *E* external pred coq.locate-module-type i:id, o:modtypath. kind located type. type loc-modpath modpath -> located. type loc-modtypath modtypath -> located. % [coq.locate-all Name Located] finds all possible meanings of a string. % Does not fail. external pred coq.locate-all i:id, o:list located. % Coq Module inline directive kind coq.inline type. type coq.inline.no coq.inline. % Coq's [no inline] (aka !) type coq.inline.default coq.inline. % The default, can be omitted type coq.inline.at int -> coq.inline. % Coq's [inline at ] external pred coq.env.begin-module-functor % Starts a functor *E* i:id, % The name of the functor i:option modtypath, % Its module type i:list (pair id modtypath). % Parameters of the functor pred coq.env.begin-module i:id, i:option modtypath. coq.env.begin-module Name MP :- coq.env.begin-module-functor Name MP []. % [coq.env.end-module ModPath] end the current module that becomes known as % ModPath *E* external pred coq.env.end-module o:modpath. external pred coq.env.begin-module-type-functor % Starts a module type functor *E* i:id, % The name of the functor i:list (pair id modtypath). % The parameters of the functor pred coq.env.begin-module-type i:id. coq.env.begin-module-type Name :- coq.env.begin-module-type-functor Name []. % [coq.env.end-module-type ModTyPath] end the current module type that % becomes known as ModPath *E* external pred coq.env.end-module-type o:modtypath. external pred coq.env.apply-module-functor % Applies a functor *E* i:id, % The name of the new module i:option modtypath, % Its module type i:modpath, % The functor being applied i:list modpath, % Its arguments i:coq.inline, % Arguments inlining o:modpath. % The modpath of the new module external pred coq.env.apply-module-type-functor % Applies a type functor *E* i:id, % The name of the new module type i:modtypath, % The functor i:list modpath, % Its arguments i:coq.inline, % Arguments inlining o:modtypath. % The modtypath of the new module type % [coq.env.include-module ModPath Inline] is like the vernacular Include, % Inline can be omitted *E* external pred coq.env.include-module i:modpath, i:coq.inline. % [coq.env.include-module-type ModTyPath Inline] is like the vernacular % Include Type, Inline can be omitted *E* external pred coq.env.include-module-type i:modtypath, i:coq.inline. % [coq.env.import-module ModPath] is like the vernacular Import *E* external pred coq.env.import-module i:modpath. % [coq.env.export-module ModPath] is like the vernacular Export *E* external pred coq.env.export-module i:modpath. % [coq.env.begin-section Name] starts a section named Name *E* external pred coq.env.begin-section i:id. % [coq.env.end-section] end the current section *E* external pred coq.env.end-section . % [coq.modpath->path MP FullPath] extract the full kernel name, each % component is a separate list item external pred coq.modpath->path i:modpath, o:list string. % [coq.modtypath->path MTP FullPath] extract the full kernel name, each % component is a separate list item external pred coq.modtypath->path i:modtypath, o:list string. % [coq.modpath->library MP LibraryPath] extract the enclosing module which % can be Required external pred coq.modpath->library i:modpath, o:modpath. % [coq.modtypath->library MTP LibraryPath] extract the enclosing module % which can be Required external pred coq.modtypath->library i:modtypath, o:modpath. % [coq.env.current-path Path] lists the current module path external pred coq.env.current-path o:list string. % [coq.env.current-section-path Path] lists the current section path external pred coq.env.current-section-path o:list string. % clauses % % A clause like % :name "foo" :before "bar" foo X Y :- bar X Z, baz Z Y % is represented as % clause "foo" (before "bar") (pi x y z\ foo x y :- bar x z, baz z y) % that is exactly what one would load in the context using =>. % % The name and the grafting specification can be left unspecified. kind clause type. type clause id -> grafting -> prop -> clause. % Specify if the clause has to be grafted before, grafted after or replace % a named clause kind grafting type. type before id -> grafting. type after id -> grafting. type replace id -> grafting. % Specify to which module the clause should be attached to kind scope type. type execution-site scope. % The module inside which the Elpi program is run type current scope. % The module being defined (see begin/end-module) type library scope. % The outermost module (carrying the file name) % see coq.elpi.accumulate-clauses pred coq.elpi.accumulate i:scope, i:id, i:clause. coq.elpi.accumulate S N C :- coq.elpi.accumulate-clauses S N [C]. % [coq.elpi.accumulate-clauses Scope DbName Clauses] % Declare that, once the program is over, the given clauses has to be % added to the given db (see Elpi Db). % Clauses usually belong to Coq modules: the Scope argument lets one % select which module: % - execution site (default) is the module in which the pogram is % invoked % - current is the module currently being constructed (see % begin/end-module) % - library is the current file (the module that is named after the file) % The clauses are visible as soon as the enclosing module is % Imported. % Clauses cannot be accumulated inside functors. % Supported attributes: % - @local! (default: false, discard at the end of section or module) % - @global! (default: false, always active, only if Scope is % execution-site, discouraged) external pred coq.elpi.accumulate-clauses i:scope, i:id, i:list clause. % Action executed during the parsing phase (aka synterp) kind synterp-action type. type begin-module id -> synterp-action. type begin-module-type id -> synterp-action. type begin-section id -> synterp-action. type end-module modpath -> synterp-action. type end-module-type modtypath -> synterp-action. type end-section synterp-action. type apply-module-functor id -> synterp-action. type apply-module-type-functor id -> synterp-action. type include-module modpath -> synterp-action. type include-module-type modtypath -> synterp-action. type import-module modpath -> synterp-action. type export-module modpath -> synterp-action. % [coq.synterp-actions A] Get the list of actions performed during the % parsing phase (aka synterp) up to now. external pred coq.synterp-actions o:list synterp-action. % [coq.begin-synterp-group ID Group] Create and open a new synterp action % group with the given name. external pred coq.begin-synterp-group i:id, o:group. % [coq.end-synterp-group Group] End the synterp action group Group. Group % must refer to the most recently openned group. external pred coq.end-synterp-group i:group. % Generic attribute value kind attribute-value type. type leaf-str string -> attribute-value. type leaf-loc loc -> attribute-value. type node list attribute -> attribute-value. % Generic attribute kind attribute type. type attribute string -> attribute-value -> attribute. coq-elpi-2.1.0/coq-builtin.elpi000066400000000000000000002520131460156013500163300ustar00rootroot00000000000000 % Coq terms as the object language of elpi and basic API to access Coq % license: GNU Lesser General Public License Version 2.1 or later % ------------------------------------------------------------------------- % This file is automatically generated from % - coq-HOAS.elpi % - coq_elpi_builtin.ml % and contains the description of the data type of Coq terms and the % API to access Coq. %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %%%%%%%%%%%%%%%%%%%%%%%%%%%% coq-arg-HOAS %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % This section contains the low level data types linking Coq and elpi. % In particular the entry points for commands % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Entry points % % Command and tactic invocation % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Entry point for commands. Eg. "#[att=true] Elpi mycommand foo 3 (f x)." becomes % main [str "foo", int 3, trm (app[f,x])] % in a context where % attributes [attribute "att" (leaf "true")] % holds. The encoding of terms is described below. % See also the coq.parse-attributes utility. pred main i:list argument. pred main-interp i:list argument, i:any. pred main-synterp i:list argument, o:any. pred usage. pred attributes o:list attribute. % see coq-lib.elpi for coq.parse-attributes generating the options below type get-option string -> A -> prop. % The data type of arguments (for commands or tactics) kind argument type. type int int -> argument. % Eg. 1 -2. type str string -> argument. % Eg. x "y" z.w. or any Coq keyword/symbol type trm term -> argument. % Eg. (t). % Extra arguments for commands. [Definition], [Axiom], [Record] and [Context] % take precedence over the [str] argument above (when not "quoted"). % % Eg. Record or Inductive type indt-decl indt-decl -> argument. % Eg. #[universes(polymorphic,...)] Record or Inductive type upoly-indt-decl indt-decl -> upoly-decl -> argument. type upoly-indt-decl indt-decl -> upoly-decl-cumul -> argument. % Eg. Definition or Axiom (when the body is none) type const-decl id -> option term -> arity -> argument. % Eg. #[universes(polymorphic,...)] Definition or Axiom type upoly-const-decl id -> option term -> arity -> upoly-decl -> argument. % Eg. Context A (b : A). type ctx-decl context-decl -> argument. % Declaration of inductive types %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% kind indt-decl type. kind indc-decl type. kind record-decl type. % An arity is written, in Coq syntax, as: % (x : T1) .. (xn : Tn) : S1 -> ... -> Sn -> U % This syntax is used, for example, in the type of an inductive type or % in the type of constructors. We call the abstractions on the left of ":" % "parameters" while we call the type following the ":" (proper) arity. % Note: in some contexts, like the type of an inductive type constructor, % Coq makes no distinction between these two writings % (xn : Tn) : forall y1 : S1, ... and (xn : Tn) (y1 : S1) : ... % while Elpi is a bit more restrictive, since it understands user directives % such as the implicit status of an arguments (eg, using {} instead of () around % the binder), only on parameters. % Moreover parameters carry the name given by the user as an "id", while binders % in terms only carry it as a "name", an irrelevant pretty pringintg hint (see % also the HOAS of terms). A user command can hence only use the names of % parameters, and not the names of "forall" quantified variables in the arity. % % See also the arity->term predicate in coq-lib.elpi type parameter id -> implicit_kind -> term -> (term -> arity) -> arity. type arity term -> arity. type parameter id -> implicit_kind -> term -> (term -> indt-decl) -> indt-decl. type inductive id -> bool -> arity -> (term -> list indc-decl) -> indt-decl. % tt means inductive, ff coinductive type record id -> term -> id -> record-decl -> indt-decl. type constructor id -> arity -> indc-decl. type field field-attributes -> id -> term -> (term -> record-decl) -> record-decl. type end-record record-decl. % Example. % Remark that A is a regular parameter; y is a non-uniform parameter and t % also features an index of type bool. % % Inductive t (A : Type) | (y : nat) : bool -> Type := % | K1 (x : A) {n : nat} : S n = y -> t A n true -> t A y true % | K2 : t A y false % % is written % % (parameter "A" explicit {{ Type }} a\ % inductive "t" tt (parameter "y" explicit {{ nat }} _\ % arity {{ bool -> Type }}) % t\ % [ constructor "K1" % (parameter "y" explicit {{ nat }} y\ % (parameter "x" explicit a x\ % (parameter "n" maximal {{ nat }} n\ % arity {{ S lp:n = lp:y -> lp:t lp:n true -> lp:t lp:y true }}))) % , constructor "K2" % (parameter "y" explicit {{ nat }} y\ % arity {{ lp:t lp:y false }}) ]) % % Remark that the uniform parameters are not passed to occurrences of t, since % they never change, while non-uniform parameters are both abstracted % in each constructor type and passed as arguments to t. % % The coq.typecheck-indt-decl API can be used to fill in implicit arguments % an infer universe constraints in the declaration above (e.g. the hidden % argument of "=" in the arity of K1). % % Note: when and inductive type declaration is passed as an argument to an % Elpi command non uniform parameters must be separated from the uniform ones % with a | (a syntax introduced in Coq 8.12 and accepted by coq-elpi since % version 1.4, in Coq this separator is optional, but not in Elpi). % Context declaration (used as an argument to Elpi commands) kind context-decl type. % Eg. (x : T) or (x := B), body is optional, type may be a variable type context-item id -> implicit_kind -> term -> option term -> (term -> context-decl) -> context-decl. type context-end context-decl. typeabbrev field-attributes (list field-attribute). macro @global! :- get-option "coq:locality" "global". macro @local! :- get-option "coq:locality" "local". %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %%%%%%%%%%%%%%%%%%%%%%%%%%%%%% coq-HOAS %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % This section contains the low level data types linking Coq and elpi. % In particular the data type for terms and the evar_map entries (a sequent) % and the entry points for tactics % Entry point for tactics. Eg. "elpi mytactic foo 3 (f x)." becomes % solve % Where [str "foo", int 3, trm (app[f,x])] is part of . % The encoding of goals is described below. % msolve is for tactics that operate on multiple goals (called via all: ). pred solve i:goal, o:list sealed-goal. pred msolve i:list sealed-goal, o:list sealed-goal. % Extra arguments for tactics type tac ltac1-tactic -> argument. % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Coq's terms % % Types of term formers % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % -- terms -------------------------------------------------------------------- kind term type. type sort sort -> term. % Prop, Type@{i} % constants: inductive types, inductive constructors, definitions type global gref -> term. type pglobal gref -> univ-instance -> term. % binders: to form functions, arities and local definitions type fun name -> term -> (term -> term) -> term. % fun x : t => type prod name -> term -> (term -> term) -> term. % forall x : t, type let name -> term -> term -> (term -> term) -> term. % let x : T := v in % other term formers: function application, pattern matching and recursion type app list term -> term. % app [hd|args] type match term -> term -> list term -> term. % match t p [branch]) type fix name -> int -> term -> (term -> term) -> term. % fix name rno ty bo type primitive primitive-value -> term. % NYI %type cofix name -> term -> (term -> term) -> term. % cofix name ty bo % Notes about (match Scrutinee TypingFunction Branches) when % Inductive i A : A -> nat -> Type := K : forall a : A, i A a 0 % and % Scrutinee be a term of type (i bool true 7) % % - TypingFunction has a very rigid shape that depends on i. Namely % as many lambdas as indexes plus one lambda for the inductive itself % where the value of the parameters are taken from the type of the scrutinee: % fun `a` (indt "bool") a\ % fun `n` (indt "nat) n\ % fun `i` (app[indt "i", indt "bool", a n) i\ .. % Such spine of fun cannot be omitted; else elpi cannot read the term back. % See also coq.bind-ind-arity-no-let in coq-lib.elpi, that builds such spine for you, % or the higher level api coq.build-match (same file) that also takes % care of breanches. % - Branches is a list of terms, the order is the canonical one (the order % of the constructors as they were declared). If the constructor has arguments % (excluding the parameters) then the corresponding term shall be a Coq % function. In this case % fun `x` (indt "bool") x\ .. % -- helpers ------------------------------------------------------------------ macro @cast T TY :- (let `cast` TY T x\x). % -- misc --------------------------------------------------------------------- % When one writes Constraint Handling Rules unification variables are "frozen", % i.e. represented by a fresh constant (the evar key) and a list of terms % (typically the variables in scope). kind evarkey type. type uvar evarkey -> list term -> term. % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Coq's evar_map % % Context and evar declaration % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % An evar_info (displayed as a Coq goal) is essentially a sequent: % % x : t % y := v : x % ---------- % p x y % % is coded as an Elpi query % % pi x1\ decl x1 `x` => % pi x2\ def x2 `y` x1 => % declare-evar % [def x2 `y` x1 , decl x1 `x` ] % (RawEvar x1 x2) (

x1 x2) (Ev x1 x2) % % where, by default, declare-evar creates a syntactic constraint as % % {x1 x2} : % decl x1 `x` , def x2 `y` x1 ?- % evar (RawEvar x1 x2) (

x1 x2) (Ev x1 x2) /* suspended on RawEvar, Ev */ % % When the program is over, a remaining syntactic constraint like the one above % is read back and transformed into the corresponding evar_info. pred decl i:term, o:name, o:term. % Var Name Ty pred def i:term, o:name, o:term, o:term. % Var Name Ty Bo pred declare-evar i:list prop, i:term, i:term, i:term. % Ctx RawEvar Ty Evar :name "default-declare-evar" declare-evar Ctx RawEv Ty Ev :- declare_constraint (declare-evar Ctx RawEv Ty Ev) [RawEv]. % When a goal (evar _ _ _) is turned into a constraint the context is filtered % to only contain decl, def, pp. For now no handling rules for this set of % constraints other than one to remove a constraint pred rm-evar i:term, i:term. rm-evar (uvar as X) (uvar as Y):- !, declare_constraint (rm-evar X Y) [X,Y]. rm-evar _ _. constraint declare-evar evar def decl cache rm-evar { % Override the actual context rule \ (declare-evar Ctx RawEv Ty Ev) <=> (Ctx => evar RawEv Ty Ev). rule \ (rm-evar (uvar X _) (uvar Y _)) (evar (uvar X _) _ (uvar Y _)). rule \ (rm-evar (uvar X _) (uvar Y _)). } % The (evar R Ty E) predicate suspends when R and E are flexible, % and is solved otherwise. % The client may want to provide an alternative implementation of % the clause "default-assign-evar", for example to typechecks that the % term assigned to E has type Ty, or that the term assigned to R % elaborates to a term of type Ty that gets assigned to E. % In tactic mode, elpi/coq-elaborator.elpi wires things up that way. pred evar i:term, i:term, o:term. % Evar Ty RefinedSolution evar (uvar as X) T S :- var S _ VL, !, prune T VL, prune X VL, declare_constraint (evar X T S) [X, S]. :name "default-assign-evar" evar _ _ _. % volatile, only unresolved evars are considered as evars % To ease the creation of a context with decl and def % Eg. @pi-decl `x` x1\ @pi-def `y` y\ ... macro @pi-decl N T F :- pi x\ decl x N T => F x. macro @pi-def N T B F :- pi x\ def x N T B => cache x B_ => F x. macro @pi-parameter ID T F :- sigma N\ (coq.id->name ID N, pi x\ decl x N T => F x). macro @pi-inductive ID A F :- sigma N\ (coq.id->name ID N, coq.arity->term A T, pi x\ decl x N T => F x). % Sometimes it can be useful to pass to Coq a term with unification variables % representing "untyped holes" like an implicit argument _. In particular % a unification variable may exit the so called pattern fragment (applied % to distinct variables) and hence cannot be reliably mapped to Coq as an evar, % but can still be considered as an implicit argument. % By loading in the context get-option "HOAS:holes" tt one forces that % behavior. Here a convenience macro to be put on the LHS of => macro @holes! :- get-option "HOAS:holes" tt. % Similarly, some APIs take a term skeleton in input. In that case unification % variables are totally disregarded (not even mapped to Coq evars). They are % interpreted as the {{ lib:elpi.hole }} constant, which represents an implicit % argument. As a consenque these APIs don't modify the input term at all, but % rather return a copy. Note that if {{ lib:elpi.hole }} is used directly, then % it has to be applied to all variables in scope, since Coq erases variables % that are not used. For example using {{ forall x : nat, lib:elpi.hole }} as % a term skeleton is equivalent to {{ nat -> lib:elpi.hole }}, while % {{ forall x : nat, lib:elpi.hole x lib:elpi.hole more args }} puts x in % the scope of the hole (and passes to is more args). % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Coq's goals and tactic invocation % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % A Coq goal is essentially a sequent, like the evar_info above, but since it % has to be manipulated as first class Elpi data, it is represented in a slightly % different way. For example % % x : t % y := v : x % ---------- % g x y % % is represented by the following term of type sealed-goal % % nabla x1\ % nabla x2\ % seal % (goal % [def x2 `y` x1 , decl x1 `x` ] % (RawEvar x1 x2) ( x1 x2) (Evar x1 x2) % (Arguments x1 x2)) kind goal type. kind sealed-goal type. type nabla (term -> sealed-goal) -> sealed-goal. type seal goal -> sealed-goal. typeabbrev goal-ctx (list prop). type goal goal-ctx -> term -> term -> term -> list argument -> goal. % A sealed-goal closes with nabla the bound names of a % % (goal Ctx RawSolution Ty Solution Arguments) % % where Ctx is a list of decl or def and Solution is a unification variable % to be assigned to a term of type Ty in order to make progress. % RawSolution is used as a trigger: when a term is assigned to it, it is % elaborated against Ty and the resulting term is assigned to Solution. % % Arguments contains data attached to the goal, which lives in its context % and can be used by tactics to solve the goals. % A tactic (an elpi predicate which makes progress on a Coq goal) is % a predicate of type % sealed-goal -> list sealed-goal -> prop % % while the main entry point for a tactic written in Elpi is solve % which has type % goal -> list sealed-goal -> prop % % The utility (coq.ltac.open T G GL) postulates all the variables bounds % by nabla and loads the goal context before calling T on the unsealed % goal. The invocation of a tactic with arguments % 3 x "y" (h x) % on the previous goal results in the following Elpi query: % % (pi x1\ decl x1 `x` => % pi x2\ def x2 `y` x1 => % declare-evar % [def x2 `y` x1 , decl x1 `x` ] % (RawEvar x1 x2) ( x1 x2) (Evar x1 x2)), % (coq.ltac.open solve % (nabla x1\ nabla x2\ seal % (goal % [def x2 `y` x1 , decl x1 `x` ] % (RawEvar x1 x2) ( x1 x2) (Evar x1 x2) % [int 3, str `x`, str`y`, trm (app[const `h`,x1])])) % NewGoals) % % If the goal sequent contains other evars, then a tactic invocation is % an Elpi query made of the conjunction of all the declare-evar queries % corresponding to these evars and the query corresponding to the goal % sequent. NewGoals can be assigned to a list of goals that should be % declared as open. Omitted goals are shelved. If NewGoals is not % assigned, then all unresolved evars become new goals, but the order % of such goals is not specified. % The file elpi-ltac.elpi provides a few combinators (other than coq.ltac.open) % in the tradition of LCF tacticals. The main difference is that the arguments % of custom written tactics must not be passed as predicate arguments but rather % put in the goal they receive. Indeed these arguments can contain terms, and % their bound variables cannot escape the seal. coq.ltac.set-goal-arguments % can be used to put an argument from the current goal context into another % goal. The coq.ltac.call utility can call Ltac1 code (written in Coq) and % pass arguments via this mechanism. % Last, since Elpi is alerady a logic programming language with primitive % support for unification variables, most of the work of a tactic can be % performed without using tacticals (which work on sealed goals) but rather % in the context of the original goal. The last step is typically to call % the refine utility with a term synthesized by the tactic or invoke some % Ltac1 code on that term (e.g. to call vm_compute, see also the example % on the reflexive tactic). % ----- Multi goals tactics. ---- % Coq provides goal selectors, such as all:, to pass to a tactic more than one % goal. In order to write such a tactic, Coq-Elpi provides another entry point % called msolve. To be precise, if there are two goals under focus, say and % , then all: elpi tac runs the following query % % msolve [,] NewGoals ; % note the disjunction % coq.ltac.all (coq.ltac.open solve) [,] NewGoals % % So, if msolve has no clause, Coq-Elpi will use solve on all the goals % independently. If msolve has a cluse, then it can manipulate the entire list % of sealed goals. Note that the argument is in both and but % it is interpreted in both contexts independently. If both goals have a proof % variable named "x" then passing (@eq_refl _ x) as equips both goals with % a (raw) proof that "x = x", no matter what their type is. % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Declarations for Coq's API (environment read/write access, etc). % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % tt = Yes, ff = No, unspecified = No (unspecified means "_" or a variable). typeabbrev opaque? bool. macro @opaque! :- tt. macro @transparent! :- ff. %%%%%%% Attributes to be passed to APIs as in @local! => coq.something %%%%%%%% macro @primitive! :- get-option "coq:primitive" tt. % primitive records macro @reversible! :- get-option "coq:reversible" tt. % coercions macro @no-tc! :- get-option "coq:no_tc" tt. % skip typeclass inference macro @uinstance! I :- get-option "coq:uinstance" I. % universe instance % declaration of universe polymorphic constants % The first list is the one of the unvierse variables being bound % The first boolean is tt if this list can be extended by Coq (or it has to % mention all universes actually used) % The second list if the one with the constaints amond where universes % The second boolean is tt if this list can be extended by Coq or it has to % mention all universe constraints actually required to type check the % declaration) macro @udecl! Vs LV Cs LC :- get-option "coq:udecl" (upoly-decl Vs LV Cs LC). macro @udecl-cumul! Vs LV Cs LC :- get-option "coq:udecl-cumul" (upoly-decl-cumul Vs LV Cs LC). macro @univpoly! :- @udecl! [] tt [] tt. macro @univpoly-cumul! :- @udecl-cumul! [] tt [] tt. macro @ppwidth! N :- get-option "coq:ppwidth" N. % printing width macro @ppall! :- get-option "coq:pp" "all". % printing all macro @ppmost! :- get-option "coq:pp" "most". % printing most of contents macro @pplevel! N :- get-option "coq:pplevel" N. % printing precedence (for parentheses) macro @keepunivs! :- get-option "coq:keepunivs" tt. % skeletons elaboration macro @dropunivs! :- get-option "coq:keepunivs" ff. % add-indt/add-const macro @using! S :- get-option "coq:using" S. % like the #[using=S] attribute macro @inline-at! N :- get-option "coq:inline" (coq.inline.at N). % like Inline(N) macro @inline! N :- get-option "coq:inline" coq.inline.default. % like macro @redflags! F :- get-option "coq:redflags" F. % for whd & co % both arguments are strings eg "8.12.0" "use foo instead" macro @deprecated! Since Msg :- get-option "coq:deprecated" (pr Since Msg). macro @ltacfail! N :- get-option "ltac:fail" N. % retrocompatibility macro for Coq v8.10 macro @coercion! :- [coercion reversible]. % Attributes for a record field. Can be left unspecified, see defaults % below. kind field-attribute type. type coercion coercion-status -> field-attribute. % default off type canonical bool -> field-attribute. % default true, if field is named % Status of a record field w.r.t. coercions kind coercion-status type. type regular coercion-status. type reversible coercion-status. type off coercion-status. %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %%%%%%%%%%%%%%%%%%%%%%%%%%%%%% builtins %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % This section contains the API to access Coq % The marker *E* means *experimental*, i.e. use at your own risk, it may change % substantially or even disappear in future versions. % -- Misc --------------------------------------------------------- % [coq.info ...] Prints an info message external type coq.info variadic any prop. % [coq.notice ...] Prints a notice message external type coq.notice variadic any prop. % [coq.say ...] Prints a notice message external type coq.say variadic any prop. % [coq.warn ...] Prints a generic warning message external type coq.warn variadic any prop. % [coq.warning Category Name ...] % Prints a warning message with a Name and Category which can be used % to silence this warning or turn it into an error. See coqc -w command % line option external type coq.warning string -> string -> variadic any prop. % [coq.error ...] Prints and *aborts* the program. It is a fatal error for % Elpi and Ltac external type coq.error variadic any prop. % [coq.version VersionString Major Minor Patch] Fetches the version of Coq, % as a string and as 3 numbers external pred coq.version o:string, o:int, o:int, o:int. % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % API for objects belonging to the logic % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % -- Environment: names ----------------------------------------------- % To make the API more precise we use different data types for the names % of global objects. % Note: [ctype \"bla\"] is an opaque data type and by convention it is % written [@bla]. % Global constant name typeabbrev constant (ctype "constant"). % Inductive type name typeabbrev inductive (ctype "inductive"). % Inductive constructor name typeabbrev constructor (ctype "constructor"). % Global objects: inductive types, inductive constructors, definitions kind gref type. type const constant -> gref. % Nat.add, List.append, ... type indt inductive -> gref. % nat, list, ... type indc constructor -> gref. % O, S, nil, cons, ... % [id] is a name that matters, we piggy back on Elpi's strings. % Note: [name] is a name that does not matter. typeabbrev id string. % Name of a module /*E*/ typeabbrev modpath (ctype "modpath"). % Name of a module type /*E*/ typeabbrev modtypath (ctype "modtypath"). % Result of coq.locate-all kind located type. type loc-gref gref -> located. type loc-modpath modpath -> located. type loc-modtypath modtypath -> located. type loc-abbreviation abbreviation -> located. % [coq.locate-all Name Located] finds all possible meanings of a string. % Does not fail. external pred coq.locate-all i:id, o:list located. % [coq.locate Name GlobalReference] locates a global definition, inductive % type or constructor via its name. % It unfolds syntactic notations, e.g. "Notation old_name := new_name." % It undestands qualified names, e.g. "Nat.t". % It understands Coqlib Registered names using the "lib:" prefix, % eg "lib:core.bool.true". % It's a fatal error if Name cannot be located. external pred coq.locate i:id, o:gref. % -- Environment: read ------------------------------------------------ % Note: The type [term] is defined in coq-HOAS.elpi % [coq.env.typeof GR Ty] reads the type Ty of a global reference. % Supported attributes: % - @uinstance! I (default: fresh instance I) external pred coq.env.typeof i:gref, o:term. % [coq.env.global GR T] turns a global reference GR into a term, or % viceversa. % T = (global GR) or, if GR points to a universe polymorphic term, % T = (pglobal GR I). % Supported attributes: % - @uinstance! I (default: fresh instance I) external pred coq.env.global o:gref, o:term. external pred coq.env.indt % reads the inductive type declaration for the environment. % Supported attributes: % - @uinstance! I (default: fresh instance I) i:inductive, % reference to the inductive type o:bool, % tt if the type is inductive (ff for co-inductive) o:int, % number of parameters o:int, % number of parameters that are uniform (<= parameters) o:term, % type of the inductive type constructor including parameters o:list constructor, % list of constructor names o:list term. % list of the types of the constructors (type of KNames) including parameters external pred coq.env.indt-decl % reads the inductive type declaration for the environment. % Supported attributes: % - @uinstance! I (default: fresh instance I) i:inductive, % reference to the inductive type o:indt-decl. % HOAS description of the inductive type % [coq.env.indc->indt K I N] finds the inductive I to which constructor K % belongs and its position N among the other constructors external pred coq.env.indc->indt i:constructor, o:inductive, o:int. % [coq.env.indc GR ParamNo UnifParamNo Kno Ty] reads the type Ty of an % inductive constructor GR, as well as % the number of parameters ParamNo and uniform parameters % UnifParamNo and the number of the constructor Kno (0 based). % Supported attributes: % - @uinstance! I (default: fresh instance I) external pred coq.env.indc i:constructor, o:int, o:int, o:int, o:term. % [coq.env.informative? Ind] Checks if Ind is informative, that is, if % it can be eliminated to build a Type. Inductive types in Type % are % informative, as well a singleton types in Prop (which are % regarded as not non-informative). external pred coq.env.informative? i:inductive. % [coq.env.record? Ind PrimProjs] checks if Ind is a record (PrimProjs = tt % if Ind has primitive projections) external pred coq.env.record? i:inductive, o:bool. % [coq.env.recursive? Ind] checks if Ind is recursive external pred coq.env.recursive? i:inductive. % [coq.env.opaque? GR] checks if GR is an opaque constant external pred coq.env.opaque? i:constant. % [coq.env.univpoly? GR PolyArity] checks if GR is universe polymorphic and % if so returns the number of universe variables external pred coq.env.univpoly? i:gref, o:int. % [coq.env.const GR Bo Ty] reads the type Ty and the body Bo of constant % GR. % Opaque constants have Bo = none. % Supported attributes: % - @uinstance! I (default: fresh instance I) external pred coq.env.const i:constant, o:option term, o:term. % [coq.env.const-body GR Bo] reads the body of a constant, even if it is % opaque. % If such body is none, then the constant is a true axiom. % Supported attributes: % - @uinstance! I (default: fresh instance I) external pred coq.env.const-body i:constant, o:option term. % [coq.env.primitive? GR] tests if GR is a primitive constant (like uin63 % addition) or a primitive type (like uint63) external pred coq.env.primitive? i:constant. % [coq.locate-module ModName ModPath] locates a module. It's a fatal error % if ModName cannot be located. *E* external pred coq.locate-module i:id, o:modpath. % [coq.locate-module-type ModName ModPath] locates a module. It's a fatal % error if ModName cannot be located. *E* external pred coq.locate-module-type i:id, o:modtypath. % Contents of a module kind module-item type. type submodule modpath -> list module-item -> module-item. type module-type modtypath -> module-item. type gref gref -> module-item. type module-functor modpath -> list modtypath -> module-item. type module-type-functor modtypath -> list modtypath -> module-item. % [coq.env.module MP Contents] lists the contents of a module (recurses on % submodules) *E* external pred coq.env.module i:modpath, o:list module-item. % [coq.env.module-type MTP Entries] lists the items made visible by module % type (does not recurse on submodules) *E* external pred coq.env.module-type i:modtypath, o:list id. % [coq.env.section GlobalObjects] lists the global objects that are marked % as to be abstracted at the end of the enclosing sections external pred coq.env.section o:list constant. % [coq.env.dependencies GR MP Deps] Computes the direct dependencies of GR. % If MP is given, Deps only contains grefs from that module external pred coq.env.dependencies i:gref, i:modpath, o:coq.gref.set. % [coq.env.transitive-dependencies GR MP Deps] Computes the transitive % dependencies of GR. If MP is given, Deps only contains grefs from that % module external pred coq.env.transitive-dependencies i:gref, i:modpath, o:coq.gref.set. % [coq.env.term-dependencies T S] Computes all the grefs S occurring in the % term T external pred coq.env.term-dependencies i:term, o:coq.gref.set. % [coq.env.current-path Path] lists the current module path external pred coq.env.current-path o:list string. % [coq.env.current-section-path Path] lists the current section path external pred coq.env.current-section-path o:list string. % Deprecated, use coq.env.opaque? pred coq.env.const-opaque? i:constant. coq.env.const-opaque? C :- coq.warning "elpi.deprecated" "elpi.const-opaque" "use coq.env.opaque? in place of coq.env.const-opaque?", coq.env.opaque? C. % Deprecated, use coq.env.primitive? pred coq.env.const-primitive? i:constant. coq.env.const-primitive? C :- coq.warning "elpi.deprecated" "elpi.const-primitive" "use coq.env.primitive? in place of coq.env.const-primitive?", coq.env.primitive? C. % -- Environment: write ----------------------------------------------- % Note: (monomorphic) universe constraints are taken from ELPI's % constraints store. Use coq.univ-* in order to add constraints (or any % higher level facility as coq.typecheck). Load in the context attributes % such as @univpoly!, @univpoly-cumul!, @udecl! or @udecl-cumul! in order to % declare universe polymorphic constants or inductives. % [coq.env.add-const Name Bo Ty Opaque C] Declare a new constant: C gets a % constant derived from Name % and the current module; Ty can be left unspecified and in that case % the % inferred one is taken (as in writing Definition x := t); Bo can be % left % unspecified and in that case an axiom is added (or a section variable, % if a section is open and @local! is used). Omitting the body and the type % is % an error. Note: using this API for declaring an axiom or a section % variable is % deprecated, use coq.env.add-axiom or coq.env.add-section-variable % instead. % Supported attributes: % - @local! (default: false) % - @using! (default: section variables actually used) % - @univpoly! (default unset) % - @udecl! (default unset) % - @dropunivs! (default: false, drops all universe constraints from the % store after the definition) % external pred coq.env.add-const i:id, i:term, i:term, i:opaque?, o:constant. % [coq.env.add-axiom Name Ty C] Declare a new axiom: C gets a constant % derived from Name % and the current module. % Supported attributes: % - @local! (default: false) % - @univpoly! (default unset) % - @using! (default: section variables actually used) % - @inline! (default: no inlining) % - @inline-at! N (default: no inlining) external pred coq.env.add-axiom i:id, i:term, o:constant. % [coq.env.add-section-variable Name Ty C] Declare a new section variable: C % gets a constant derived from Name % and the current module external pred coq.env.add-section-variable i:id, i:term, o:constant. % [coq.env.add-indt Decl I] Declares an inductive type. % Supported attributes: % - @dropunivs! (default: false, drops all universe constraints from the % store after the definition) % - @primitive! (default: false, makes records primitive) external pred coq.env.add-indt i:indt-decl, o:inductive. % Interactive module construction % Coq Module inline directive kind coq.inline type. type coq.inline.no coq.inline. % Coq's [no inline] (aka !) type coq.inline.default coq.inline. % The default, can be omitted type coq.inline.at int -> coq.inline. % Coq's [inline at ] % [coq.env.fresh-global-id ID FID] Generates an id FID which is fresh in % the current module and looks similar to ID, i.e. it is ID concatenated % with a number, starting from 1. % [coq.env.fresh-global-id X X] can be used to check if X is taken external pred coq.env.fresh-global-id i:id, o:id. external pred coq.env.begin-module-functor % Starts a functor. bla bla i:id, % The name of the functor i:option modtypath, % Its module type (optional) i:list (pair id modtypath). % Parameters of the functor (optional) pred coq.env.begin-module i:id, i:option modtypath. coq.env.begin-module Name MP :- coq.env.begin-module-functor Name MP []. % [coq.env.end-module ModPath] end the current module that becomes known as % ModPath *E*. bla bla external pred coq.env.end-module o:modpath. external pred coq.env.begin-module-type-functor % Starts a module type functor *E*. bla bla i:id, % The name of the functor i:list (pair id modtypath). % The parameters of the functor (optional) pred coq.env.begin-module-type i:id. coq.env.begin-module-type Name :- coq.env.begin-module-type-functor Name []. % [coq.env.end-module-type ModTyPath] end the current module type that % becomes known as ModPath *E*. bla bla external pred coq.env.end-module-type o:modtypath. external pred coq.env.apply-module-functor % Applies a functor *E*. bla bla i:id, % The name of the new module i:option modtypath, % Its module type (optional) i:modpath, % The functor being applied (optional) i:list modpath, % Its arguments (optional) i:coq.inline, % Arguments inlining (optional) o:modpath. % The modpath of the new module external pred coq.env.apply-module-type-functor % Applies a type functor *E*. bla bla i:id, % The name of the new module type i:modtypath, % The functor (optional) i:list modpath, % Its arguments (optional) i:coq.inline, % Arguments inlining (optional) o:modtypath. % The modtypath of the new module type % [coq.env.include-module ModPath Inline (optional)] is like the vernacular % Include, Inline can be omitted *E*. bla bla external pred coq.env.include-module i:modpath, i:coq.inline. % [coq.env.include-module-type ModTyPath Inline (optional)] is like the % vernacular Include Type, Inline can be omitted *E*. bla bla external pred coq.env.include-module-type i:modtypath, i:coq.inline. % [coq.env.import-module ModPath] is like the vernacular Import *E* external pred coq.env.import-module i:modpath. % [coq.env.export-module ModPath] is like the vernacular Export *E* external pred coq.env.export-module i:modpath. % Support for sections is limited, in particular sections and % Coq quotations may interact in surprising ways. For example % Section Test. % Variable x : nat. % Elpi Query lp:{{ coq.say {{ x }} }}. % works since x is a global Coq term while % Elpi Query lp:{{ % coq.env.begin-section "Test", % coq.env.add-const "x" _ {{ nat }} _ @local! GRX, % coq.say {{ x }} % }}. % may work in a surprising way or may not work at all since % x is resolved before the section is started hence it cannot % denote the same x as before. % [coq.env.begin-section Name] starts a section named Name *E* external pred coq.env.begin-section i:id. % [coq.env.end-section] end the current section *E* external pred coq.env.end-section . % [coq.env.projections StructureName Projections] given a record % StructureName lists all projections external pred coq.env.projections i:inductive, o:list (option constant). % [coq.env.primitive-projections StructureName Projections] given a record % StructureName lists all primitive projections external pred coq.env.primitive-projections i:inductive, o:list (option (pair projection int)). % -- Sorts (and their universe level, if applicable) ---------------- % Warning: universe polymorphism has to be considered experimental *E* as % a feature, not just as a set of APIs. Unfortunately some of the % current complexity is exposed to the programmer, bare with us. % % The big bang is that in Coq one has terms, types and sorts (which are % the types of types). Some sorts (as of today only Type) some with % a universe level, on paper Type_i for some i. At the sort level % Coq features some form of subtyping: a function expecting a function % to Type, e.g. nat -> Type, can receive a function to Prop, since % Prop <= Type. So far, so good. But what are these levels i % exactly? % % Universe levels are said to be "algebraic", they are made of % variables (see the next section) and the two operators +1 and max. % This is a sort of internal optimization that leaks to the % user/programmer. Indeed these universe levels cannot be (directly) used % in all APIs morally expecting a universe level "i", in particular % the current constraint engine cannot handle constraint with an % algebraic level on the right, e.g. i <= j+1. Since some APIs only % accept universe variables, we provide the coq.univ.variable API % which is able to craft a universe variable which is roughly % equivalent to an algebraic universe, e.g. k such that j+1 = k. % % Coq-Elpi systematically purges algebraic universes from terms (and % types and sorts) when one reads them from the environment. This % makes the embedding of terms less precise than what it could be. % The different data types stay, since Coq will eventually become % able to handle algebraic universes consistently, making this purging % phase unnecessary. % universe level (algebraic: max, +1, univ.variable) typeabbrev univ (ctype "univ"). % Sorts (kinds of types) kind sort type. type prop sort. % impredicative sort of propositions type sprop sort. % impredicative sort of propositions with definitional proof irrelevance type typ univ -> sort. % predicative sort of data (carries a universe level) % [coq.sort.leq S1 S2] constrains S1 <= S2 external pred coq.sort.leq o:sort, o:sort. % [coq.sort.eq S1 S2] constrains S1 = S2 external pred coq.sort.eq o:sort, o:sort. % [coq.sort.sup S1 S2] constrains S2 = S1 + 1 external pred coq.sort.sup o:sort, o:sort. % [coq.sort.pts-triple S1 S2 S3] constrains S3 = sort of product with domain % in S1 and codomain in S2 external pred coq.sort.pts-triple o:sort, o:sort, o:sort. % [coq.univ.print] prints the set of universe constraints external pred coq.univ.print . % [coq.univ.new U] A fresh universe. external pred coq.univ.new o:univ. % [coq.univ Name U] Finds a named unvierse. Can fail. external pred coq.univ o:id, o:univ. % [coq.univ.global? U] succeeds if U is a global universe external pred coq.univ.global? i:univ. % [coq.univ.constraints CL] gives the list of constraints, see also % coq.univ.variable.constraints external pred coq.univ.constraints o:list univ-constraint. % -- Universe variables ------ % universe level variable typeabbrev univ.variable (ctype "univ.variable"). % [coq.univ.variable U L] relates a univ.variable L to a univ U external pred coq.univ.variable o:univ, o:univ.variable. % [coq.univ.variable.constraints L CL] gives the list of constraints on L. % Can be used to craft a strict upoly-decl external pred coq.univ.variable.constraints i:univ.variable, o:list univ-constraint. % [coq.univ.variable.of-term T S] collects all univ.variables occurring in T external pred coq.univ.variable.of-term i:term, o:coq.univ.variable.set. % -- Universe instance (for universe polymorphic global terms) ------ % As of today a universe polymorphic constant can only be instantiated % with universe level variables. That is f@{Prop} is not valid, nor % is f@{u+1}. One can only write f@{u} for any u. % % A univ-instance is morally a list of universe level variables, % but its list syntax is hidden in the terms. If you really need to % craft or inspect one of these, the following APIs can help you. % % Most of the time the user is expected to use coq.env.global which % crafts a fresh, appropriate, universe instance and possibly unify that % term (of the instance it contains) with another one. % Universes level instance for a universe-polymorphic constant typeabbrev univ-instance (ctype "univ-instance"). % [coq.univ-instance UI UL] relates a univ-instance UI and a list of % universe level variables UL external pred coq.univ-instance o:univ-instance, o:list univ.variable. % [coq.univ-instance.unify-eq GR UI1 UI2 Diagnostic] unifies the two % universe instances for the same gref external pred coq.univ-instance.unify-eq i:gref, i:univ-instance, i:univ-instance, o:diagnostic. % [coq.univ-instance.unify-leq GR UI1 UI2 Diagnostic] unifies the two % universe instances for the same gref. Note: if the GR is not *cumulative* % (see Cumulative or #[universes(cumulative)]) then this API imposes an % equality constraint. external pred coq.univ-instance.unify-leq i:gref, i:univ-instance, i:univ-instance, o:diagnostic. % -- Declaration of universe polymorphic global terms ----------- % These are the data types used to declare how constants % and inductive types should be declared (see also the @udecl! % and % @udecl-cumul! macros). Note that only inductive types can be % declared as cumulative. % Constraint between two universes level variables kind univ-constraint type. type lt univ.variable -> univ.variable -> univ-constraint. type le univ.variable -> univ.variable -> univ-constraint. type eq univ.variable -> univ.variable -> univ-constraint. % Variance of a universe level variable kind univ-variance type. type auto univ.variable -> univ-variance. type covariant univ.variable -> univ-variance. type invariant univ.variable -> univ-variance. type irrelevant univ.variable -> univ-variance. % Constraints for a non-cumulative declaration. Boolean tt means loose % (e.g. the '+' in f@{u v + | u < v +}) kind upoly-decl type. type upoly-decl list univ.variable -> bool -> list univ-constraint -> bool -> upoly-decl. % Constraints for a cumulative declaration. Boolean tt means loose (e.g. % the '+' in f@{u v + | u < v +}) kind upoly-decl-cumul type. type upoly-decl-cumul list univ-variance -> bool -> list univ-constraint -> bool -> upoly-decl-cumul. % -- Primitive -------------------------------------------------------- typeabbrev uint63 (ctype "uint63"). typeabbrev float64 (ctype "float64"). typeabbrev projection (ctype "projection"). % Primitive values kind primitive-value type. type uint63 uint63 -> primitive-value. % unsigned integers over 63 bits type float64 float64 -> primitive-value. % double precision foalting points type proj projection -> int -> primitive-value. % primitive projection % [coq.uint63->int U I] Transforms a primitive unsigned integer U into an % elpi integer I. Fails if it does not fit. external pred coq.uint63->int i:uint63, o:int. % [coq.int->uint63 I U] Transforms an elpi integer I into a primitive % unsigned integer U. Fails if I is negative. external pred coq.int->uint63 i:int, o:uint63. % [coq.float64->float F64 F] Transforms a primitive float on 64 bits to an % elpi one. Currently, it should not fail. external pred coq.float64->float i:float64, o:float. % [coq.float->float64 F F64] Transforms an elpi float F to a primitive float % on 64 bits. Currently, it should not fail. external pred coq.float->float64 i:float, o:float64. % [coq.primitive.projection-unfolded P PU] Relates a primitive projection P % to its unfolded version PU. PU is still a primitive projection, but it is % displayed as a match and some Ltac code can see that. external pred coq.primitive.projection-unfolded o:projection, o:projection. % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % API for extra logical objects % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % -- Databases (TC, CS, Coercions) ------------------------------------ % Pattern for canonical values kind cs-pattern type. type cs-gref gref -> cs-pattern. type cs-prod cs-pattern. type cs-default cs-pattern. type cs-sort sort -> cs-pattern. % Canonical Structure instances: (cs-instance Proj ValPat Inst) kind cs-instance type. type cs-instance gref -> cs-pattern -> gref -> cs-instance. % [coq.CS.declare-instance GR] Declares GR as a canonical structure % instance. % Supported attributes: % - @local! (default: false) external pred coq.CS.declare-instance i:gref. % [coq.CS.db Db] reads all instances external pred coq.CS.db o:list cs-instance. % [coq.CS.db-for Proj Value Db] reads all instances for a given Projection % or canonical Value, or both external pred coq.CS.db-for i:gref, i:cs-pattern, o:list cs-instance. % [coq.TC.declare-class GR] Declare GR as a type class external pred coq.TC.declare-class i:gref. % [coq.elpi.toposort Graph Nodes in toposort order] takes a graph and % returns the nodes in topological order external pred coq.elpi.toposort i:list (pair A (list A)), o:list A. % Type class instance priority kind tc-priority type. type tc-priority-given int -> tc-priority. % User given priority type tc-priority-computed int -> tc-priority. % Coq computed priority % Type class instance with priority kind tc-instance type. type tc-instance gref -> tc-priority -> tc-instance. % [coq.TC.declare-instance GR Priority] Declare GR as a Global type class % instance with Priority. % Supported attributes: % - @global! (default: true) external pred coq.TC.declare-instance i:gref, i:int. % [coq.TC.db Instances] reads all type class instances external pred coq.TC.db o:list tc-instance. % [coq.TC.db-tc TypeClasses] reads all type classes external pred coq.TC.db-tc o:list gref. % [coq.TC.db-for GR InstanceList] reads all instances of the given class GR. % Instances are in their precedence order. external pred coq.TC.db-for i:gref, o:list tc-instance. % [coq.TC.get-inst-prio ClassGR InstGR InstPrio] reads the priority of an % instance external pred coq.TC.get-inst-prio i:gref, i:gref, o:tc-priority. % [coq.TC.class? GR] checks if GR is a class external pred coq.TC.class? i:gref. % Node of the coercion graph kind class type. type funclass class. type sortclass class. type grefclass gref -> class. % Edge of the coercion graph kind coercion type. type coercion gref -> int -> gref -> class -> coercion. % ref, nparams, src, tgt % [coq.coercion.declare C] Declares C = (coercion GR NParams From To) as a % coercion From >-> To. % NParams can always be omitted, since it is inferred. % If From or To is unspecified, then the endpoints are inferred. % Supported attributes: % - @global! (default: false) % - @nonuniform! (default: false) % - @reversible! (default: false) external pred coq.coercion.declare i:coercion. % [coq.coercion.db L] reads all declared coercions external pred coq.coercion.db o:list coercion. % [coq.coercion.db-for From To L] L is a path From -> To external pred coq.coercion.db-for i:class, i:class, o:list (pair gref int). % Deprecated, use coq.env.projections pred coq.CS.canonical-projections i:inductive, o:list (option constant). coq.CS.canonical-projections I L :- coq.warning "elpi.deprecated" "elpi.canonical-projections" "use coq.env.projections in place of coq.CS.canonical-projections", coq.env.projections I L. % -- Coq's Hint DB ------------------------------------- % Locality of hints is a delicate matter since the Coq default % is, in some cases, to make an hint active even if the module it belongs % to is not imported (just merely required, which can happen % transitively). % Coq is aiming at changing the default to #[export], that makes an % hint active only when its enclosing module is imported. % See: % https://coq.discourse.group/t/change-of-default-locality-for-hint-commands-in-coq-8-13/1140 % % This old behavior is available via the @global! flag, but is discouraged. % % Hint Mode kind hint-mode type. type mode-ground hint-mode. % No Evar type mode-input hint-mode. % No Head Evar type mode-output hint-mode. % Anything % [coq.hints.add-mode GR DB Mode] Adds a mode declaration to DB about % GR. % Supported attributes: % - @local! (default is export) % - @global! (discouraged, may become deprecated) external pred coq.hints.add-mode i:gref, i:string, i:list hint-mode. % [coq.hints.modes GR DB Modes] Gets all the mode declarations in DB about % GR external pred coq.hints.modes i:gref, i:string, o:list (list hint-mode). % [coq.hints.set-opaque C DB Opaque] Like Hint Opaque C : DB (or Hint % Transparent, if the boolean is ff). % Supported attributes: % - @local! (default is export) % - @global! (discouraged, may become deprecated) external pred coq.hints.set-opaque i:constant, i:string, i:bool. % [coq.hints.opaque C DB Opaque] Reads if constant C is opaque (tt) or % transparent (ff) in DB external pred coq.hints.opaque i:constant, i:string, o:bool. % [coq.hints.add-resolve GR DB Priority Pattern] Like Hint Resolve GR | % Priority Pattern : DB. % Supported attributes: % - @local! (default is export) % - @global! (discouraged, may become deprecated) external pred coq.hints.add-resolve i:gref, i:string, i:int, i:term. % -- Coq's notational mechanisms ------------------------------------- % Implicit status of an argument kind implicit_kind type. type implicit implicit_kind. % regular implicit argument, eg Arguments foo [x] type maximal implicit_kind. % maximally inserted implicit argument, eg Arguments foo {x} type explicit implicit_kind. % explicit argument, eg Arguments foo x % [coq.arguments.implicit GR Imps] reads the implicit arguments declarations % associated to a global reference. See also the [] and {} flags for the % Arguments command. external pred coq.arguments.implicit i:gref, o:list (list implicit_kind). % [coq.arguments.set-implicit GR Imps] sets the implicit arguments % declarations associated to a global reference. % Unspecified means explicit. % See also the [] and {} flags for the Arguments command. % Supported attributes: % - @global! (default: false) external pred coq.arguments.set-implicit i:gref, i:list (list implicit_kind). % [coq.arguments.set-default-implicit GR] sets the default implicit % arguments declarations associated to a global reference. % See also the "default implicits" flag to the Arguments command. % Supported attributes: % - @global! (default: false) external pred coq.arguments.set-default-implicit i:gref. % [coq.arguments.name GR Names] reads the Names of the arguments of a global % reference. See also the (f (A := v)) syntax. external pred coq.arguments.name i:gref, o:list (option id). % [coq.arguments.set-name GR Names] sets the Names of the arguments of a % global reference. % See also the :rename flag to the Arguments command. % Supported attributes: % - @global! (default: false) external pred coq.arguments.set-name i:gref, i:list (option id). % [coq.arguments.scope GR Scopes] reads the notation scope of the arguments % of a global reference. See also the %scope modifier for the Arguments % command external pred coq.arguments.scope i:gref, o:list (list id). % [coq.arguments.set-scope GR Scopes] sets the notation scope of the % arguments of a global reference. % Scope can be a scope name or its delimiter. % See also the %scope modifier for the Arguments command. % Supported attributes: % - @global! (default: false) external pred coq.arguments.set-scope i:gref, i:list (list id). % Strategy for simplification tactics kind simplification_strategy type. type never simplification_strategy. % Arguments foo : simpl never type when list int -> option int -> simplification_strategy. % Arguments foo .. / .. ! .. type when-nomatch list int -> option int -> simplification_strategy. % Arguments foo .. / .. ! .. : simpl nomatch % [coq.arguments.simplification GR Strategy] reads the behavior of the % simplification tactics. Positions are 0 based. See also the ! and / % modifiers for the Arguments command external pred coq.arguments.simplification i:gref, o:option simplification_strategy. % [coq.arguments.set-simplification GR Strategy] sets the behavior of the % simplification tactics. % Positions are 0 based. % See also the ! and / modifiers for the Arguments command. % Supported attributes: % - @global! (default: false) external pred coq.arguments.set-simplification i:gref, i:simplification_strategy. % [coq.locate-abbreviation Name Abbreviation] locates an abbreviation. It's % a fatal error if Name cannot be located. external pred coq.locate-abbreviation i:id, o:abbreviation. % Name of an abbreviation typeabbrev abbreviation (ctype "abbreviation"). % [coq.notation.add-abbreviation Name Nargs Body OnlyParsing Abbreviation] % Declares an abbreviation Name with Nargs arguments. % The term must begin with at least Nargs "fun" nodes whose domain is % ignored, eg (fun _ _ x\ fun _ _ y\ app[global "add",x,y]). % Supported attributes: % - @deprecated! (default: not deprecated) % - @global! (default: false) external pred coq.notation.add-abbreviation i:id, i:int, i:term, i:bool, o:abbreviation. % [coq.notation.abbreviation Abbreviation Args Body] Unfolds an abbreviation external pred coq.notation.abbreviation i:abbreviation, i:list term, o:term. % [coq.notation.abbreviation-body Abbreviation Nargs Body] Retrieves the % body of an abbreviation external pred coq.notation.abbreviation-body i:abbreviation, o:int, o:term. % [coq.notation.add-abbreviation-for-tactic Name TacticName FixedArgs] % Declares a parsing rule similar to % Notation Name X1..Xn := ltac:(elpi TacticName FixedArgs (X1)..(Xn)) % so that Name can be used in the middle of a term to invoke an % elpi tactic. While FixedArgs can contain str, int, and trm all % other arguments will necessarily be terms, and their number is % not fixed (the user can pass as many as he likes). % The tactic receives as the elpi.loc attribute the precise location % at which the term is written (unlike if a regular abbreviation was % declared by hand). % A call to coq.notation.add-abbreviation-for-tactic TacName TacName [] % is equivalent to Elpi Export TacName. external pred coq.notation.add-abbreviation-for-tactic i:string, i:string, i:list argument. % Generic attribute value kind attribute-value type. type leaf-str string -> attribute-value. type leaf-loc loc -> attribute-value. type node list attribute -> attribute-value. % Generic attribute kind attribute type. type attribute string -> attribute-value -> attribute. % -- Coq's pretyper --------------------------------------------------- % [coq.sigma.print] Prints Coq's Evarmap and the mapping to/from Elpi's % unification variables external pred coq.sigma.print . % [coq.typecheck T Ty Diagnostic] typchecks a term T returning its type Ty. % If Ty is provided, then % the inferred type is unified (see unify-leq) with it. % Universe constraints are put in the constraint store. external pred coq.typecheck i:term, o:term, o:diagnostic. % [coq.typecheck-ty Ty U Diagnostic] typchecks a type Ty returning its % universe U. If U is provided, then % the inferred universe is unified (see unify-leq) with it. % Universe constraints are put in the constraint store. external pred coq.typecheck-ty i:term, o:sort, o:diagnostic. % [coq.unify-eq A B Diagnostic] unifies the two terms external pred coq.unify-eq i:term, i:term, o:diagnostic. % [coq.unify-leq A B Diagnostic] unifies the two terms (with cumulativity, % if they are types) external pred coq.unify-leq i:term, i:term, o:diagnostic. % [coq.elaborate-skeleton T ETy E Diagnostic] elabotares T against the % expected type ETy. % T is allowed to contain holes (unification variables) but these are % not assigned even if the elaborated term has a term in place of the % hole. Similarly universe levels present in T are disregarded. % Supported attributes: % - @keepunivs! (default false, do not disregard universe levels) % - @no-tc! (default false, do not infer typeclasses) external pred coq.elaborate-skeleton i:term, o:term, o:term, o:diagnostic. % [coq.elaborate-ty-skeleton T U E Diagnostic] elabotares T expecting it to % be a type of sort U. % T is allowed to contain holes (unification variables) but these are % not assigned even if the elaborated term has a term in place of the % hole. Similarly universe levels present in T are disregarded. % Supported attributes: % - @keepunivs! (default false, do not disregard universe levels) % - @no-tc! (default false, do not infer typeclasses) external pred coq.elaborate-ty-skeleton i:term, o:sort, o:term, o:diagnostic. % -- Coq's reduction flags ------------------------------------ % Flags for lazy, cbv, ... reductions kind coq.redflag type. type coq.redflags.beta coq.redflag. type coq.redflags.delta coq.redflag. % if set then coq.redflags.const disables unfolding type coq.redflags.match coq.redflag. type coq.redflags.fix coq.redflag. type coq.redflags.cofix coq.redflag. type coq.redflags.zeta coq.redflag. type coq.redflags.const constant -> coq.redflag. % enable/disable unfolding % Set of flags for lazy, cbv, ... reductions typeabbrev coq.redflags (ctype "coq.redflags"). type coq.redflags.all coq.redflags. type coq.redflags.allnolet coq.redflags. type coq.redflags.beta coq.redflags. type coq.redflags.betadeltazeta coq.redflags. type coq.redflags.betaiota coq.redflags. type coq.redflags.betaiotazeta coq.redflags. type coq.redflags.betazeta coq.redflags. type coq.redflags.delta coq.redflags. type coq.redflags.zeta coq.redflags. type coq.redflags.nored coq.redflags. % [coq.redflags.add Flags Options NewFlags] Updates reduction Flags by % adding Options external pred coq.redflags.add i:coq.redflags, i:list coq.redflag, o:coq.redflags. % [coq.redflags.sub Flags Options NewFlags] Updates reduction Flags by % removing Options external pred coq.redflags.sub i:coq.redflags, i:list coq.redflag, o:coq.redflags. % -- Coq's reduction machines ------------------------------------ % [coq.reduction.lazy.whd T Tred] Puts T in weak head normal form. % Supported attributes: % - @redflags! (default coq.redflags.all) external pred coq.reduction.lazy.whd i:term, o:term. % [coq.reduction.lazy.norm T Tred] Puts T in normal form. % Supported attributes: % - @redflags! (default coq.redflags.all) external pred coq.reduction.lazy.norm i:term, o:term. % [coq.reduction.lazy.bi-norm T Tred] Puts T in normal form only reducing % beta and iota redexes external pred coq.reduction.lazy.bi-norm i:term, o:term. % [coq.reduction.cbv.norm T Tred] Puts T in normal form using the call by % value strategy. % Supported attributes: % - @redflags! (default coq.redflags.all) external pred coq.reduction.cbv.norm i:term, o:term. % [coq.reduction.vm.norm T Ty Tred] Puts T in normal form using % [vm_compute]'s machinery. Its type Ty can be omitted (but is recomputed) external pred coq.reduction.vm.norm i:term, i:term, o:term. % [coq.reduction.native.norm T Ty Tred] Puts T in normal form using % [native_compute]'s machinery. Its type Ty can be omitted (but is % recomputed). Falls back to vm.norm if native compilation is not available. external pred coq.reduction.native.norm i:term, i:term, o:term. % [coq.reduction.native.available?] Is native compilation available on this % system/configuration? external pred coq.reduction.native.available? . % Deprecated, use coq.reduction.cbv.norm pred coq.reduction.cbv.whd_all i:term, o:term. coq.reduction.cbv.whd_all T R :- coq.warning "elpi.deprecated" "elpi.cbv-whd-all" "use coq.reduction.cbv.norm in place of coq.reduction.cbv.whd_all", coq.reduction.cbv.norm T R. % Deprecated, use coq.reduction.vm.norm pred coq.reduction.vm.whd_all i:term, i:term, o:term. coq.reduction.vm.whd_all T TY R :- coq.warning "elpi.deprecated" "elpi.vm-whd-all" "use coq.reduction.vm.norm in place of coq.reduction.vm.whd_all", coq.reduction.vm.norm T TY R. pred coq.reduction.lazy.whd_all i:term, o:term. coq.reduction.lazy.whd_all X Y :- @redflags! coq.redflags.all => coq.reduction.lazy.whd X Y. % [coq.reduction.eta-contract T Tred] Removes all eta expansions from T external pred coq.reduction.eta-contract i:term, o:term. % -- Coq's conversion strategy tweaks -------------------------- % Strategy for conversion test % expand < ... < level -1 < level 0 < level 1 < ... < opaque kind conversion_strategy type. type opaque conversion_strategy. type expand conversion_strategy. type level int -> conversion_strategy. % default is 0, aka transparent % [coq.strategy.set CL Level] Sets the unfolding priority for all the % constants in the list CL. See the command Strategy. external pred coq.strategy.set i:list constant, i:conversion_strategy. % [coq.strategy.get C Level] Gets the unfolding priority for C external pred coq.strategy.get i:constant, o:conversion_strategy. % -- Coq's tactics -------------------------------------------- % LTac1 tactic expression typeabbrev ltac1-tactic (ctype "ltac1-tactic"). % [coq.ltac.fail Level ...] Interrupts the Elpi program and calls Ltac's % fail Level Msg, where Msg is the printing of the remaining arguments. % Level can be left unspecified and defaults to 0 external type coq.ltac.fail int -> variadic any prop. % [coq.ltac.collect-goals T Goals ShelvedGoals] % Turns the holes in T into Goals. % Goals are closed with nablas. % ShelvedGoals are goals which can be solved by side effect (they occur % in the type of the other goals). % The order of Goals is given by the traversal order of EConstr.fold % (a % fold_left over the terms, letin body comes before the type). % external pred coq.ltac.collect-goals i:term, o:list sealed-goal, o:list sealed-goal. % [coq.ltac.call-ltac1 Tac G GL] Calls Ltac1 tactic Tac on goal G (passing % the arguments of G, see coq.ltac.call for a handy wrapper). % Tac can either be a string (the tactic name), or a value % of type ltac1-tactic, see the tac argument constructor % and the ltac_tactic:(...) syntax to pass arguments to % an elpi tactic. % Supported attributes: % - @no-tc! (default false, do not infer typeclasses) external pred coq.ltac.call-ltac1 i:any, i:goal, o:list sealed-goal. % [coq.ltac.id-free? ID G] % Fails if ID is already used in G. Note that ids which are taken are % renamed % on the fly (since in the HOAS of terms, names are just pretty printing % hints), but for the ergonomy of a tactic it may help to know if an % hypothesis name is already taken. % external pred coq.ltac.id-free? i:id, i:goal. % [coq.ltac.fresh-id Default Ty FreshID] TODO external pred coq.ltac.fresh-id i:id, i:term, o:id. % -- Coq's options system -------------------------------------------- % Coq option value kind coq.option type. type coq.option.int option int -> coq.option. % none means unset type coq.option.string option string -> coq.option. % none means unset type coq.option.bool bool -> coq.option. % [coq.option.get Option Value] reads Option. Reading a non existing option % is a fatal error. external pred coq.option.get i:list string, o:coq.option. % [coq.option.set Option Value] writes Option. Writing a non existing option % is a fatal error. external pred coq.option.set i:list string, i:coq.option. % [coq.option.available? Option Deprecated] checks if Option exists and % tells if is deprecated (tt) or not (ff) external pred coq.option.available? i:list string, o:bool. % [coq.option.add Option Value Deprecated] % adds a new option to Coq setting its current value (and type). % Deprecated can be left unspecified and defaults to ff. % This call cannot be undone in a Coq interactive session, use it once % and for all in a .v file which your clients will load. Eg. % % Elpi Query lp:{{ coq.option.add ... }}. % % external pred coq.option.add i:list string, i:coq.option, i:bool. % -- Datatypes conversions -------------------------------------------- % Name.Name.t: Name hints (in binders), can be input writing a name % between backticks, e.g. `x` or `_` for anonymous. Important: these are % just printing hints with no meaning, hence in elpi two name are always % related: `x` = `y` typeabbrev name (ctype "name"). % [coq.name-suffix Name Suffix NameSuffix] suffixes a Name with a string or % an int or another name external pred coq.name-suffix i:name, i:any, o:name. % [coq.string->name Hint Name] creates a name hint external pred coq.string->name i:string, o:name. pred coq.id->name i:id, o:name. coq.id->name S N :- coq.string->name S N. % [coq.name->id Name Id] tuns a pretty printing hint into a string. This API % is for internal use, no guarantee on its behavior. external pred coq.name->id i:name, o:id. % [coq.gref->id GR Id] extracts the label (last component of a full kernel % name) external pred coq.gref->id i:gref, o:id. % [coq.gref->string GR FullPath] extract the full kernel name external pred coq.gref->string i:gref, o:string. % [coq.gref->path GR FullPath] extract the full path (kernel name without % final id), each component is a separate list item external pred coq.gref->path i:gref, o:list string. % [coq.modpath->path MP FullPath] extract the full kernel name, each % component is a separate list item external pred coq.modpath->path i:modpath, o:list string. % [coq.modtypath->path MTP FullPath] extract the full kernel name, each % component is a separate list item external pred coq.modtypath->path i:modtypath, o:list string. % [coq.modpath->library MP LibraryPath] extract the enclosing module which % can be Required external pred coq.modpath->library i:modpath, o:modpath. % [coq.modtypath->library MTP LibraryPath] extract the enclosing module % which can be Required external pred coq.modtypath->library i:modtypath, o:modpath. % [coq.term->string T S] prints a term T to a string S using Coq's pretty % printer % Supported attributes: % - @ppwidth! N (default 80, max line length) % - @ppall! (default: false, prints all details) % - @ppmost! (default: false, prints most details) % - @pplevel! (default: _, prints parentheses to reach that level, 200 = % off) % - @holes! (default: false, prints evars as _) external pred coq.term->string i:term, o:string. % [coq.term->pp T B] prints a term T to a pp.t B using Coq's pretty % printer" % Supported attributes: % - @ppall! (default: false, prints all details) % - @ppmost! (default: false, prints most details) % - @pplevel! (default: _, prints parentheses to reach that level, 200 = % off) % - @holes! (default: false, prints evars as _) external pred coq.term->pp i:term, o:coq.pp. % [coq.goal->pp G B] prints a goal G to a pp.t B using Coq's pretty % printer" % Supported attributes: % - @ppall! (default: false, prints all details) % - @ppmost! (default: false, prints most details) % - @pplevel! (default: _, prints parentheses to reach that level, 200 = % off) % - @holes! (default: false, prints evars as _) external pred coq.goal->pp i:goal, o:coq.pp. % -- Extra Dependencies ----------------------------------------------- % [coq.extra-dep Identifier FileName] Resolve the file name of an extra % dependency. See also Coq's From xxx Extra Dependency yyy as zzz. external pred coq.extra-dep i:id, o:option id. % -- Access to Elpi's data -------------------------------------------- % clauses % % A clause like % :name "foo" :before "bar" foo X Y :- bar X Z, baz Z Y % is represented as % clause "foo" (before "bar") (pi x y z\ foo x y :- bar x z, baz z y) % that is exactly what one would load in the context using =>. % % The name and the grafting specification can be left unspecified. kind clause type. type clause id -> grafting -> prop -> clause. % Specify if the clause has to be grafted before, grafted after or replace % a named clause kind grafting type. type before id -> grafting. type after id -> grafting. type replace id -> grafting. % Specify to which module the clause should be attached to kind scope type. type execution-site scope. % The module inside which the Elpi program is run type current scope. % The module being defined (see begin/end-module) type library scope. % The outermost module (carrying the file name) % see coq.elpi.accumulate-clauses pred coq.elpi.accumulate i:scope, i:id, i:clause. coq.elpi.accumulate S N C :- coq.elpi.accumulate-clauses S N [C]. % [coq.elpi.accumulate-clauses Scope DbName Clauses] % Declare that, once the program is over, the given clauses has to be % added to the given db (see Elpi Db). % Clauses usually belong to Coq modules: the Scope argument lets one % select which module: % - execution site (default) is the module in which the pogram is % invoked % - current is the module currently being constructed (see % begin/end-module) % - library is the current file (the module that is named after the file) % The clauses are visible as soon as the enclosing module is Imported. % A clause that mentions a section variable is automatically discarded % at the end of the section. % Clauses cannot be accumulated inside functors. % Supported attributes: % - @local! (default: false, discard at the end of section or module) % - @global! (default: false, always active, only if Scope is % execution-site, discouraged) external pred coq.elpi.accumulate-clauses i:scope, i:id, i:list clause. % Specify if a predicate argument is in input or output mode kind argument_mode type. type in argument_mode. type out argument_mode. % [coq.elpi.add-predicate Db Indexing PredName Spec] Declares a new % predicate PredName in the data base Db. % Indexing can be left unspecified. Spec gathers a mode and a % type for each argument. CAVEAT: types and indexing are strings % instead of proper data types; beware parsing errors are fatal. % Supported attributes: % - @local! (default: false, discard at the end of section or module) % - @global! (default: false, always active external pred coq.elpi.add-predicate i:string, i:string, i:string, i:list (pair argument_mode string). % [coq.elpi.predicate PredName Args Pred] Pred is the application of % PredName to Args external pred coq.elpi.predicate i:string, i:list any, o:prop. % -- Synterp ---------------------------------------------------------- % Action executed during the parsing phase (aka synterp) kind synterp-action type. type begin-module id -> synterp-action. type begin-module-type id -> synterp-action. type begin-section id -> synterp-action. type end-module modpath -> synterp-action. type end-module-type modtypath -> synterp-action. type end-section synterp-action. type apply-module-functor id -> synterp-action. type apply-module-type-functor id -> synterp-action. type include-module modpath -> synterp-action. type include-module-type modtypath -> synterp-action. type import-module modpath -> synterp-action. type export-module modpath -> synterp-action. % Synterp action group typeabbrev group (ctype "group"). % [coq.next-synterp-action A] Get the next action performed during parsing % (aka synterp), that is also the next action to be performed during % execution (aka interp). See also coq.replay-synterp-action external pred coq.next-synterp-action o:synterp-action. % [coq.replay-synterp-action-group ID] Execute all actions of synterp action % group ID. ID must be the name of the next group, it must not be opened % already, and there must not be any actions before it. external pred coq.replay-synterp-action-group i:id. % [coq.begin-synterp-group ID Group] Match a begin-synterp-group synterp % operation. ID must be the name of the next synterp action group and there % must not be any actions before it. external pred coq.begin-synterp-group i:id, o:group. % [coq.end-synterp-group Group] Match a end-synterp-group synterp operation. % Group must be the currently opened synterp action group and the group must % not have any more synterp actions or groups left to replay. external pred coq.end-synterp-group i:group. % -- Utils ------------------------------------------------------------ kind coq.gref.set type. % [coq.gref.set.empty A] The empty set external pred coq.gref.set.empty o:coq.gref.set. % [coq.gref.set.mem Elem A] Checks if Elem is in a external pred coq.gref.set.mem i:gref, i:coq.gref.set. % [coq.gref.set.add Elem A B] B is A union {Elem} external pred coq.gref.set.add i:gref, i:coq.gref.set, o:coq.gref.set. % [coq.gref.set.remove Elem A B] B is A \ {Elem} external pred coq.gref.set.remove i:gref, i:coq.gref.set, o:coq.gref.set. % [coq.gref.set.union A B X] X is A union B external pred coq.gref.set.union i:coq.gref.set, i:coq.gref.set, o:coq.gref.set. % [coq.gref.set.inter A B X] X is A intersection B external pred coq.gref.set.inter i:coq.gref.set, i:coq.gref.set, o:coq.gref.set. % [coq.gref.set.diff A B X] X is A \ B external pred coq.gref.set.diff i:coq.gref.set, i:coq.gref.set, o:coq.gref.set. % [coq.gref.set.equal A B] tests A and B for equality external pred coq.gref.set.equal i:coq.gref.set, i:coq.gref.set. % [coq.gref.set.subset A B] tests if A is a subset of B external pred coq.gref.set.subset i:coq.gref.set, i:coq.gref.set. % [coq.gref.set.elements M L] L is M transformed into list external pred coq.gref.set.elements i:coq.gref.set, o:list gref. % [coq.gref.set.cardinal M N] N is the number of elements of M external pred coq.gref.set.cardinal i:coq.gref.set, o:int. % [coq.gref.set.filter M F M1] Filter M w.r.t. the predicate F external pred coq.gref.set.filter i:coq.gref.set, i:gref -> prop, o:coq.gref.set. % [coq.gref.set.map M F M1] Map M w.r.t. the predicate F external pred coq.gref.set.map i:coq.gref.set, i:gref -> gref -> prop, o:coq.gref.set. % CAVEAT: the type parameter of coq.gref.map must be a closed term kind coq.gref.map type -> type. % [coq.gref.map.empty M] The empty map external pred coq.gref.map.empty o:coq.gref.map A. % [coq.gref.map.mem S M] Checks if S is bound in M external pred coq.gref.map.mem i:gref, i:coq.gref.map A. % [coq.gref.map.add S V M M1] M1 is M where V is bound to S external pred coq.gref.map.add i:gref, i:A, i:coq.gref.map A, o:coq.gref.map A. % [coq.gref.map.remove S M M1] M1 is M where S is unbound external pred coq.gref.map.remove i:gref, i:coq.gref.map A, o:coq.gref.map A. % [coq.gref.map.find S M V] V is the binding of S in M external pred coq.gref.map.find i:gref, i:coq.gref.map A, o:A. % [coq.gref.map.bindings M L] L is M transformed into an associative list external pred coq.gref.map.bindings i:coq.gref.map A, o:list (pair gref A). % [coq.gref.map.filter M F M1] Filter M w.r.t. the predicate F external pred coq.gref.map.filter i:coq.gref.map A, i:gref -> A -> prop, o:coq.gref.map A. % [coq.gref.map.map M F M1] Map M w.r.t. the predicate F external pred coq.gref.map.map i:coq.gref.map A, i:gref -> A -> B -> prop, o:coq.gref.map B. kind coq.univ.set type. % [coq.univ.set.empty A] The empty set external pred coq.univ.set.empty o:coq.univ.set. % [coq.univ.set.mem Elem A] Checks if Elem is in a external pred coq.univ.set.mem i:univ, i:coq.univ.set. % [coq.univ.set.add Elem A B] B is A union {Elem} external pred coq.univ.set.add i:univ, i:coq.univ.set, o:coq.univ.set. % [coq.univ.set.remove Elem A B] B is A \ {Elem} external pred coq.univ.set.remove i:univ, i:coq.univ.set, o:coq.univ.set. % [coq.univ.set.union A B X] X is A union B external pred coq.univ.set.union i:coq.univ.set, i:coq.univ.set, o:coq.univ.set. % [coq.univ.set.inter A B X] X is A intersection B external pred coq.univ.set.inter i:coq.univ.set, i:coq.univ.set, o:coq.univ.set. % [coq.univ.set.diff A B X] X is A \ B external pred coq.univ.set.diff i:coq.univ.set, i:coq.univ.set, o:coq.univ.set. % [coq.univ.set.equal A B] tests A and B for equality external pred coq.univ.set.equal i:coq.univ.set, i:coq.univ.set. % [coq.univ.set.subset A B] tests if A is a subset of B external pred coq.univ.set.subset i:coq.univ.set, i:coq.univ.set. % [coq.univ.set.elements M L] L is M transformed into list external pred coq.univ.set.elements i:coq.univ.set, o:list univ. % [coq.univ.set.cardinal M N] N is the number of elements of M external pred coq.univ.set.cardinal i:coq.univ.set, o:int. % [coq.univ.set.filter M F M1] Filter M w.r.t. the predicate F external pred coq.univ.set.filter i:coq.univ.set, i:univ -> prop, o:coq.univ.set. % [coq.univ.set.map M F M1] Map M w.r.t. the predicate F external pred coq.univ.set.map i:coq.univ.set, i:univ -> univ -> prop, o:coq.univ.set. % CAVEAT: the type parameter of coq.univ.map must be a closed term kind coq.univ.map type -> type. % [coq.univ.map.empty M] The empty map external pred coq.univ.map.empty o:coq.univ.map A. % [coq.univ.map.mem S M] Checks if S is bound in M external pred coq.univ.map.mem i:univ, i:coq.univ.map A. % [coq.univ.map.add S V M M1] M1 is M where V is bound to S external pred coq.univ.map.add i:univ, i:A, i:coq.univ.map A, o:coq.univ.map A. % [coq.univ.map.remove S M M1] M1 is M where S is unbound external pred coq.univ.map.remove i:univ, i:coq.univ.map A, o:coq.univ.map A. % [coq.univ.map.find S M V] V is the binding of S in M external pred coq.univ.map.find i:univ, i:coq.univ.map A, o:A. % [coq.univ.map.bindings M L] L is M transformed into an associative list external pred coq.univ.map.bindings i:coq.univ.map A, o:list (pair univ A). % [coq.univ.map.filter M F M1] Filter M w.r.t. the predicate F external pred coq.univ.map.filter i:coq.univ.map A, i:univ -> A -> prop, o:coq.univ.map A. % [coq.univ.map.map M F M1] Map M w.r.t. the predicate F external pred coq.univ.map.map i:coq.univ.map A, i:univ -> A -> B -> prop, o:coq.univ.map B. kind coq.univ.variable.set type. % [coq.univ.variable.set.empty A] The empty set external pred coq.univ.variable.set.empty o:coq.univ.variable.set. % [coq.univ.variable.set.mem Elem A] Checks if Elem is in a external pred coq.univ.variable.set.mem i:univ.variable, i:coq.univ.variable.set. % [coq.univ.variable.set.add Elem A B] B is A union {Elem} external pred coq.univ.variable.set.add i:univ.variable, i:coq.univ.variable.set, o:coq.univ.variable.set. % [coq.univ.variable.set.remove Elem A B] B is A \ {Elem} external pred coq.univ.variable.set.remove i:univ.variable, i:coq.univ.variable.set, o:coq.univ.variable.set. % [coq.univ.variable.set.union A B X] X is A union B external pred coq.univ.variable.set.union i:coq.univ.variable.set, i:coq.univ.variable.set, o:coq.univ.variable.set. % [coq.univ.variable.set.inter A B X] X is A intersection B external pred coq.univ.variable.set.inter i:coq.univ.variable.set, i:coq.univ.variable.set, o:coq.univ.variable.set. % [coq.univ.variable.set.diff A B X] X is A \ B external pred coq.univ.variable.set.diff i:coq.univ.variable.set, i:coq.univ.variable.set, o:coq.univ.variable.set. % [coq.univ.variable.set.equal A B] tests A and B for equality external pred coq.univ.variable.set.equal i:coq.univ.variable.set, i:coq.univ.variable.set. % [coq.univ.variable.set.subset A B] tests if A is a subset of B external pred coq.univ.variable.set.subset i:coq.univ.variable.set, i:coq.univ.variable.set. % [coq.univ.variable.set.elements M L] L is M transformed into list external pred coq.univ.variable.set.elements i:coq.univ.variable.set, o:list univ.variable. % [coq.univ.variable.set.cardinal M N] N is the number of elements of M external pred coq.univ.variable.set.cardinal i:coq.univ.variable.set, o:int. % [coq.univ.variable.set.filter M F M1] Filter M w.r.t. the predicate F external pred coq.univ.variable.set.filter i:coq.univ.variable.set, i:univ.variable -> prop, o:coq.univ.variable.set. % [coq.univ.variable.set.map M F M1] Map M w.r.t. the predicate F external pred coq.univ.variable.set.map i:coq.univ.variable.set, i:univ.variable -> univ.variable -> prop, o:coq.univ.variable.set. % CAVEAT: the type parameter of coq.univ.variable.map must be a closed % term kind coq.univ.variable.map type -> type. % [coq.univ.variable.map.empty M] The empty map external pred coq.univ.variable.map.empty o:coq.univ.variable.map A. % [coq.univ.variable.map.mem S M] Checks if S is bound in M external pred coq.univ.variable.map.mem i:univ.variable, i:coq.univ.variable.map A. % [coq.univ.variable.map.add S V M M1] M1 is M where V is bound to S external pred coq.univ.variable.map.add i:univ.variable, i:A, i:coq.univ.variable.map A, o:coq.univ.variable.map A. % [coq.univ.variable.map.remove S M M1] M1 is M where S is unbound external pred coq.univ.variable.map.remove i:univ.variable, i:coq.univ.variable.map A, o:coq.univ.variable.map A. % [coq.univ.variable.map.find S M V] V is the binding of S in M external pred coq.univ.variable.map.find i:univ.variable, i:coq.univ.variable.map A, o:A. % [coq.univ.variable.map.bindings M L] L is M transformed into an % associative list external pred coq.univ.variable.map.bindings i:coq.univ.variable.map A, o:list (pair univ.variable A). % [coq.univ.variable.map.filter M F M1] Filter M w.r.t. the predicate F external pred coq.univ.variable.map.filter i:coq.univ.variable.map A, i:univ.variable -> A -> prop, o:coq.univ.variable.map A. % [coq.univ.variable.map.map M F M1] Map M w.r.t. the predicate F external pred coq.univ.variable.map.map i:coq.univ.variable.map A, i:univ.variable -> A -> B -> prop, o:coq.univ.variable.map B. % Coq box types for pretty printing: % - Vertical block: each break leads to a new line % - Horizontal block: no line breaking % - Horizontal-vertical block: same as Vertical block, except if this block % is small enough to fit on a single line in which case it is the same % as a Horizontal block % - Horizontal or Vertical block: breaks lead to new line only when % necessary to print the content of the block (the contents flow % inside the box) kind coq.pp.box type. type coq.pp.v int -> coq.pp.box. type coq.pp.h coq.pp.box. type coq.pp.hv int -> coq.pp.box. type coq.pp.hov int -> coq.pp.box. % Coq box model for pretty printing. Items: % - empty % - spc: a spacem, also a breaking hint % - str: a non breakable string % - brk L I: a breaking hint of a given length L contributing I spaces to % indentation when taken % - glue: puts things together % - box B: a box with automatic line breaking according to B % - comment: embedded \\n are turned into nl (see below) % - tag: ignored % - nl: break the line (should not be used) kind coq.pp type. type coq.pp.empty coq.pp. type coq.pp.spc coq.pp. type coq.pp.str string -> coq.pp. type coq.pp.brk int -> int -> coq.pp. type coq.pp.glue list coq.pp -> coq.pp. type coq.pp.box coq.pp.box -> list coq.pp -> coq.pp. type coq.pp.comment list string -> coq.pp. type coq.pp.tag string -> coq.pp -> coq.pp. type coq.pp.nl coq.pp. % [coq.pp->string B S] Prints a pp.t box expression B to a string S % Supported attributes: % - @ppwidth! N (default 80, max line length) external pred coq.pp->string i:coq.pp, o:string. coq-elpi-2.1.0/coq-elpi.opam000066400000000000000000000031561460156013500156200ustar00rootroot00000000000000opam-version: "2.0" name: "coq-elpi" version: "dev" maintainer: "Enrico Tassi " authors: [ "Enrico Tassi" ] license: "LGPL-2.1-or-later" homepage: "https://github.com/LPCIC/coq-elpi" bug-reports: "https://github.com/LPCIC/coq-elpi/issues" dev-repo: "git+https://github.com/LPCIC/coq-elpi" build: [ [ make "build" "COQBIN=%{bin}%/" "ELPIDIR=%{prefix}%/lib/elpi" "OCAMLWARN=" ] [ make "test" "COQBIN=%{bin}%/" "ELPIDIR=%{prefix}%/lib/elpi" ] {with-test} ] install: [ make "install" "COQBIN=%{bin}%/" "ELPIDIR=%{prefix}%/lib/elpi" ] depends: [ "ocaml" {>= "4.09.0" } "stdlib-shims" "elpi" {>= "1.18.2" & < "1.19.0~"} "coq" {>= "8.19" & < "8.20~" } "dot-merlin-reader" {with-dev} "ocaml-lsp-server" {with-dev} ] tags: [ "category:Miscellaneous/Coq Extensions" "keyword:λProlog" "keyword:higher order abstract syntax" "logpath:elpi" ] synopsis: "Elpi extension language for Coq" description: """ Coq-elpi provides a Coq plugin that embeds ELPI. It also provides a way to embed Coq's terms into λProlog using the Higher-Order Abstract Syntax approach and a way to read terms back. In addition to that it exports to ELPI a set of Coq's primitives, e.g. printing a message, accessing the environment of theorems and data types, defining a new constant and so on. For convenience it also provides a quotation and anti-quotation for Coq's syntax in λProlog. E.g. `{{nat}}` is expanded to the type name of natural numbers, or `{{A -> B}}` to the representation of a product by unfolding the `->` notation. Finally it provides a way to define new vernacular commands and new tactics.""" coq-elpi-2.1.0/default.nix000066400000000000000000000006611460156013500153730ustar00rootroot00000000000000{ 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"; ref = "master"; rev = import .nix/coq-nix-toolbox.nix; }; in import auto ({inherit src;} // args) coq-elpi-2.1.0/dune-project000066400000000000000000000000001460156013500155340ustar00rootroot00000000000000coq-elpi-2.1.0/elpi-builtin.elpi000066400000000000000000001210021460156013500164700ustar00rootroot00000000000000% Generated file, do not edit % == Core builtins ===================================== % -- Logic -- pred true. true. pred fail. pred false. external pred (=) o:A, o:A. % unification typeabbrev int (ctype "int"). typeabbrev string (ctype "string"). typeabbrev float (ctype "float"). pred (;) o:prop, o:prop. (A ; _) :- A. (_ ; B) :- B. type (:-) prop -> prop -> prop. type (:-) prop -> list prop -> prop. type (,) variadic prop prop. type uvar A. type (as) A -> A -> A. type (=>) prop -> prop -> prop. type (=>) list prop -> prop -> prop. % -- Control -- external pred !. % The cut operator pred not i:prop. not X :- X, !, fail. not _. % [declare_constraint C Key1 Key2...] declares C blocked % on Key1 Key2 ... (variables, or lists thereof). external type declare_constraint any -> any -> variadic any prop. external pred print_constraints. % prints all constraints % [halt ...] halts the program and print the terms external type halt variadic any prop. pred stop. stop :- halt. % -- Evaluation -- pred (is) o:A, i:A. X is Y :- calc Y X. % [calc Expr Out] unifies Out with the value of Expr. It can be used in % tandem with spilling, eg [f {calc (N + 1)}] external pred calc i:A, o:A. % --- Operators --- type (-) A -> A -> A. type (i-) int -> int -> int. type (r-) float -> float -> float. type (+) int -> int -> int. type (+) float -> float -> float. type (i+) int -> int -> int. type (r+) float -> float -> float. type (*) int -> int -> int. type (*) float -> float -> float. type (/) float -> float -> float. type (mod) int -> int -> int. type (div) int -> int -> int. type (^) string -> string -> string. type (~) int -> int. type (~) float -> float. type (i~) int -> int. type (r~) float -> float. type abs int -> int. type abs float -> float. type iabs int -> int. type rabs float -> float. type max int -> int -> int. type max float -> float -> float. type min int -> int -> int. type min float -> float -> float. type sqrt float -> float. type sin float -> float. type cos float -> float. type arctan float -> float. type ln float -> float. type int_to_real int -> float. type floor float -> int. type ceil float -> int. type truncate float -> int. type size string -> int. type chr int -> string. type rhc string -> int. type string_to_int string -> int. type int_to_string int -> string. type substring string -> int -> int -> string. type real_to_string float -> string. % -- Arithmetic tests -- % [lt_ X Y] checks if X < Y. Works for string, int and float external pred lt_ i:A, i:A. % [gt_ X Y] checks if X > Y. Works for string, int and float external pred gt_ i:A, i:A. % [le_ X Y] checks if X =< Y. Works for string, int and float external pred le_ i:A, i:A. % [ge_ X Y] checks if X >= Y. Works for string, int and float external pred ge_ i:A, i:A. type (<), (>), (=<), (>=) A -> A -> prop. X > Y :- gt_ X Y. X < Y :- lt_ X Y. X =< Y :- le_ X Y. X >= Y :- ge_ X Y. type (i<), (i>), (i=<), (i>=) int -> int -> prop. X i< Y :- lt_ X Y. X i> Y :- gt_ X Y. X i=< Y :- le_ X Y. X i>= Y :- ge_ X Y. type (r<), (r>), (r=<), (r>=) float -> float -> prop. X r< Y :- lt_ X Y. X r> Y :- gt_ X Y. X r=< Y :- le_ X Y. X r>= Y :- ge_ X Y. type (s<), (s>), (s=<), (s>=) string -> string -> prop. X s< Y :- lt_ X Y. X s> Y :- gt_ X Y. X s=< Y :- le_ X Y. X s>= Y :- ge_ X Y. % -- Standard data types (supported in the FFI) -- kind list type -> type. type (::) X -> list X -> list X. type ([]) list X. % Boolean values: tt and ff since true and false are predicates kind bool type. type tt bool. type ff bool. % Pair: the constructor is pr, since ',' is for conjunction kind pair type -> type -> type. type pr A -> B -> pair A B. pred fst i:pair A B, o:A. fst (pr A _) A. pred snd i:pair A B, o:B. snd (pr _ B) B. % The option type (aka Maybe) kind option type -> type. type none option A. type some A -> option A. % Result of a comparison kind cmp type. type eq cmp. type lt cmp. type gt cmp. % Used in builtin variants that return Coq's error rather than failing kind diagnostic type. type ok diagnostic. % Success type error string -> diagnostic. % Failure % == Elpi builtins ===================================== % [dprint ...] prints raw terms (debugging) external type dprint variadic any prop. % [print ...] prints terms external type print variadic any prop. % Deprecated, use trace.counter pred counter i:string, o:int. counter C N :- trace.counter C N. % [quote_syntax FileName QueryText QuotedProgram QuotedQuery] quotes the % program from FileName and the QueryText. See elpi-quoted_syntax.elpi for % the syntax tree external pred quote_syntax i:string, i:string, o:list A, o:A. typeabbrev loc (ctype "Loc.t"). % [loc.fields Loc File StartChar StopChar Line LineStartsAtChar] Decomposes % a loc into its fields external pred loc.fields i:loc, o:string, o:int, o:int, o:int, o:int. % == Regular Expressions ===================================== % [rex.match Rex Subject] checks if Subject matches Rex. Matching is based % on OCaml's Str library external pred rex.match i:string, i:string. % [rex.replace Rex Replacement Subject Out] Out is obtained by replacing all % occurrences of Rex with Replacement in Subject. See also OCaml's % Str.global_replace external pred rex.replace i:string, i:string, i:string, o:string. % [rex.split Rex Subject Out] Out is obtained by splitting Subject at all % occurrences of Rex. See also OCaml's Str.split external pred rex.split i:string, i:string, o:list string. % Deprecated, use rex.match pred rex_match i:string, i:string. rex_match Rx S :- rex.match Rx S. % Deprecated, use rex.replace pred rex_replace i:string, i:string, i:string, o:string. rex_replace Rx R S O :- rex.replace Rx R S O. % Deprecated, use rex.split pred rex_split i:string, i:string, o:list string. rex_split Rx S L :- rex.split Rx S L. % == Elpi nonlogical builtins ===================================== % Opaque ML data types kind ctyp type. type ctype string -> ctyp. % [var V ...] checks if the term V is a variable. When used with tree % arguments it relates an applied variable with its head and argument list. external type var any -> variadic any prop. % [prune V L] V is pruned to L (V is unified with a variable that only sees % the list of names L) external pred prune o:any, i:list any. % [distinct_names L] checks if L is a list of distinct names. If L is the % scope of a unification variable (its arguments, as per var predicate) then % distinct_names L checks that such variable is in the Miller pattern % fragment (L_\lambda) external pred distinct_names i:list any. % [same_var V1 V2] checks if the two terms V1 and V2 are the same variable, % ignoring the arguments of the variables external pred same_var i:A, i:A. % [same_term T1 T2] checks if the two terms T1 and T2 are syntactically % equal (no unification). It behaves differently than same_var since it % recursively compares the arguments of the variables external pred same_term i:A, i:A. % Infix notation for same_term pred (==) i:A, i:A. X == Y :- same_term X Y. % [cmp_term A B Cmp] Compares A and B. Only works if A and B are ground. external pred cmp_term i:any, i:any, o:cmp. % [name T ...] checks if T is a eigenvariable. When used with tree arguments % it relates an applied name with its head and argument list. external type name any -> variadic any prop. % [constant T ...] checks if T is a (global) constant. When used with tree % arguments it relates an applied constant with its head and argument list. external type constant any -> variadic any prop. external pred names % generates the list of eigenvariable o:list any. % list of eigenvariables in order of age (young first) external pred occurs % checks if the atom occurs in the term i:any, % an atom, that is a global constant or a bound name (aka eigenvariable) i:any. % a term % [closed_term T] unify T with a variable that has no eigenvariables in % scope external pred closed_term o:any. % [ground_term T] Checks if T contains unification variables external pred ground_term i:any. % [is_cdata T Ctype] checks if T is primitive of type Ctype, eg (ctype % "int") external pred is_cdata i:any, o:ctyp. pred primitive? i:A, i:string. primitive? X S :- is_cdata X (ctype S). % [new_int N] unifies N with a different int every time it is called. Values % of N are guaranteed to be incresing. external pred new_int o:int. % [findall_solution P L] finds all the solved instances of P and puts them % in L % in the order in which they are found. Instances can contain % eigenvariables % and unification variables. external pred findall_solutions i:prop, o:list prop. % Holds data across bracktracking; can only contain closed terms typeabbrev safe (ctype "safe"). % [new_safe Safe] creates a safe: a store that persists across backtracking external pred new_safe o:safe. % [stash_in_safe Safe Data] stores Data in the Safe external pred stash_in_safe i:safe, i:A. % [open_safe Safe Data] retrieves the Data stored in Safe external pred open_safe i:safe, o:list A. % [if C T E] picks the first success of C then runs T (never E). % if C has no success it runs E. pred if i:prop, i:prop, i:prop. if B T _ :- B, !, T. if _ _ E :- E. % [if2 C1 B1 C2 B2 E] like if but with 2 then branches (and one else branch). pred if2 i:prop, i:prop, i:prop, i:prop, i:prop. if2 G1 P1 _ _ _ :- G1, !, P1. if2 _ _ G2 P2 _ :- G2, !, P2. if2 _ _ _ _ E :- !, E. % [random.init Seed] Initialize OCaml's PRNG with the given Seed external pred random.init i:int. % [random.self_init] Initialize OCaml's PRNG with some seed external pred random.self_init . % [random.int Bound N] unifies N with a random int between 0 and Bound % (excluded) external pred random.int i:int, o:int. #line 0 "builtin_stdlib.elpi" % == stdlib ======================================================= % Conventions: % - all predicates declare a mode with some input arguments, unless... % - predicates whose name ends with R are relations (work in any direction, % that is all arguments are in output mode) % - predicates whose name ends with ! do contain a cut and generate only the % first result % - all errors given by this library end up calling fatal-error[-w-data], % override it in order to handle them differently % - all debug prints by this library end up calling debug-print, override it % in order to handle them differently namespace std { pred fatal-error i:string. :name "default-fatal-error" fatal-error Msg :- halt Msg. pred fatal-error-w-data i:string, i:A. :name "default-fatal-error-w-data" fatal-error-w-data Msg Data :- halt Msg ":" Data. pred debug-print i:string, i:A. :name "default-debug-print" debug-print Msg Data :- print Msg Data. % -- Errors, Debugging, Hacks -- pred ignore-failure! i:prop. ignore-failure! P :- P, !. ignore-failure! _. % [assert! C M] takes the first success of C or fails with message M pred assert! i:prop, i:string. assert! Cond Msg :- (Cond ; fatal-error-w-data Msg Cond), !. % [assert-ok! C M] like assert! but the last argument of the predicate must % be a diagnostic that is printed after M in case it is not ok pred assert-ok! i:(diagnostic -> prop), i:string. assert-ok! Cond Msg :- Cond Diagnostic, !, (Diagnostic = ok ; Diagnostic = error S, fatal-error-w-data Msg S), !. assert-ok! _ Msg :- fatal-error-w-data Msg "no diagnostic returned". % [spy P] traces the call to P, printing all success and the final failure pred spy i:prop. spy P :- trace.counter "run" NR, if (not(NR = 0)) (debug-print "run=" NR) true, debug-print "----<<---- enter: " P, P, debug-print "---->>---- exit: " P. spy P :- debug-print "---->>---- fail: " P, fail. % [spy! P] traces the first call to P without leaving a choice point pred spy! i:prop. spy! P :- trace.counter "run" NR, if (not(NR = 0)) (debug-print "run=" NR) true, debug-print "----<<---- enter: " P, P, debug-print "---->>---- exit: " P, !. spy! P :- debug-print "---->>---- fail: " P, fail. % to silence the type checker pred unsafe-cast o:A, o:B. unsafe-cast X X. % -- List processing -- pred length i:list A, o:int. length [_|L] N :- length L N1, N is N1 + 1. length [] 0. pred rev i:list A, o:list A. rev L RL :- rev.aux L [] RL. rev.aux [X|XS] ACC R :- rev.aux XS [X|ACC] R. rev.aux [] L L. pred last i:list A, o:A. last [] _ :- fatal-error "last on empty list". last [X] X :- !. last [_|XS] R :- last XS R. pred append i:list A, i:list A, o:list A. append [X|XS] L [X|L1] :- append XS L L1 . append [] L L . pred appendR o:list A, o:list A, o:list A. appendR [X|XS] L [X|L1] :- appendR XS L L1 . appendR [] L L . pred take i:int, i:list A, o:list A. take 0 _ [] :- !. take N [X|XS] [X|L] :- !, N1 is N - 1, take N1 XS L. take _ _ _ :- fatal-error "take run out of list items". pred take-last i:int, i:list A, o:list A. take-last N L R :- length L M, D is M - N, drop D L R. pred drop i:int, i:list A, o:list A. drop 0 L L :- !. drop N [_|XS] L :- !, N1 is N - 1, drop N1 XS L. drop _ _ _ :- fatal-error "drop run out of list items". pred drop-last i:int, i:list A, o:list A. drop-last N L R :- length L M, I is M - N, take I L R. pred split-at i:int, i:list A, o:list A, o:list A. split-at 0 L [] L :- !. split-at N [X|XS] [X|LN] LM :- !, N1 is N - 1, split-at N1 XS LN LM. split-at _ _ _ _ :- fatal-error "split-at run out of list items". pred fold i:list B, i:A, i:(B -> A -> A -> prop), o:A. fold [] A _ A. fold [X|XS] A F R :- F X A A1, fold XS A1 F R. pred fold-right i:list B, i:A, i:(B -> A -> A -> prop), o:A. fold-right [] A _ A. fold-right [X|XS] A F R :- fold-right XS A F A', F X A' R. pred fold2 i:list C, i:list B, i:A, i:(C -> B -> A -> A -> prop), o:A. fold2 [] [_|_] _ _ _ :- fatal-error "fold2 on lists of different length". fold2 [_|_] [] _ _ _ :- fatal-error "fold2 on lists of different length". fold2 [] [] A _ A. fold2 [X|XS] [Y|YS] A F R :- F X Y A A1, fold2 XS YS A1 F R. pred map i:list A, i:(A -> B -> prop), o:list B. map [] _ []. map [X|XS] F [Y|YS] :- F X Y, map XS F YS. pred map-i i:list A, i:(int -> A -> B -> prop), o:list B. map-i L F R :- map-i.aux L 0 F R. map-i.aux [] _ _ []. map-i.aux [X|XS] N F [Y|YS] :- F N X Y, M is N + 1, map-i.aux XS M F YS. pred map-filter i:list A, i:(A -> B -> prop), o:list B. map-filter [] _ []. map-filter [X|XS] F [Y|YS] :- F X Y, !, map-filter XS F YS. map-filter [_|XS] F YS :- map-filter XS F YS. :index(1 1) pred map2 i:list A, i:list B, i:(A -> B -> C -> prop), o:list C. map2 [] [_|_] _ _ :- fatal-error "map2 on lists of different length". map2 [_|_] [] _ _ :- fatal-error "map2 on lists of different length". map2 [] [] _ []. map2 [X|XS] [Y|YS] F [Z|ZS] :- F X Y Z, map2 XS YS F ZS. pred map2-filter i:list A, i:list B, i:(A -> B -> C -> prop), o:list C. map2-filter [] [_|_] _ _ :- fatal-error "map2-filter on lists of different length". map2-filter [_|_] [] _ _ :- fatal-error "map2-filter on lists of different length". map2-filter [] [] _ []. map2-filter [X|XS] [Y|YS] F [Z|ZS] :- F X Y Z, !, map2-filter XS YS F ZS. map2-filter [_|XS] [_|YS] F ZS :- map2-filter XS YS F ZS. pred map-ok i:list A, i:(A -> B -> diagnostic -> prop), o:list A, o:diagnostic. map-ok [X|L] P [Y|YS] S :- P X Y S0, if (S0 = ok) (map-ok L P YS S) (S = S0). map-ok [] _ [] ok. pred fold-map i:list A, i:B, i:(A -> B -> C -> B -> prop), o:list C, o:B. fold-map [] A _ [] A. fold-map [X|XS] A F [Y|YS] A2 :- F X A Y A1, fold-map XS A1 F YS A2. pred omap i:option A, i:(A -> B -> prop), o:option B. omap none _ none. omap (some X) F (some Y) :- F X Y. % [nth N L X] picks in X the N-th element of L (L must be of length > N) pred nth i:int, i:list A, o:A. nth 0 [X|_ ] R :- !, X = R. nth N [_|XS] R :- N > 0, !, N1 is N - 1, nth N1 XS R. nth N _ _ :- N < 0, !, fatal-error "nth got a negative index". nth _ _ _ :- fatal-error "nth run out of list items". % [lookup L K V] sees L as a map from K to V pred lookup i:list (pair A B), i:A, o:B. lookup [pr X Y|_] X Y. lookup [_|LS] X Y :- lookup LS X Y. % [lookup! L K V] sees L as a map from K to V, stops at the first binding pred lookup! i:list (pair A B), i:A, o:B. lookup! [pr X Y|_] X Y :- !. lookup! [_|LS] X Y :- lookup! LS X Y. % [mem! L X] succeeds once if X occurs inside L pred mem! i:list A, o:A. mem! [X|_] X :- !. mem! [_|L] X :- mem! L X. % [mem L X] succeeds every time if X occurs inside L pred mem i:list A, o:A. mem [X|_] X. mem [_|L] X :- mem L X. pred exists i:list A, i:(A -> prop). exists [X|_] P :- P X. exists [_|L] P :- exists L P. pred exists2 i:list A, i:list B, i:(A -> B -> prop). exists2 [] [_|_] _ :- fatal-error "exists2 on lists of different length". exists2 [_|_] [] _ :- fatal-error "exists2 on lists of different length". exists2 [X|_] [Y|_] P :- P X Y. exists2 [_|L] [_|M] P :- exists2 L M P. pred forall i:list A, i:(A -> prop). forall [] _. forall [X|L] P :- P X, forall L P. pred forall-ok i:list A, i:(A -> diagnostic -> prop), o:diagnostic. forall-ok [X|L] P S :- P X S0, if (S0 = ok) (forall-ok L P S) (S = S0). forall-ok [] _ ok. pred forall2 i:list A, i:list B, i:(A -> B -> prop). forall2 [] [_|_] _ :- fatal-error "forall2 on lists of different length". forall2 [_|_] [] _ :- fatal-error "forall2 on lists of different length". forall2 [X|XS] [Y|YS] P :- P X Y, forall2 XS YS P. forall2 [] [] _. pred filter i:list A, i:(A -> prop), o:list A. filter [] _ []. filter [X|L] P R :- if (P X) (R = X :: L1) (R = L1), filter L P L1. pred zip i:list A, i:list B, o:list (pair A B). zip [_|_] [] _ :- fatal-error "zip on lists of different length". zip [] [_|_] _ :- fatal-error "zip on lists of different length". zip [X|LX] [Y|LY] [pr X Y|LR] :- zip LX LY LR. zip [] [] []. pred unzip i:list (pair A B), o:list A, o:list B. unzip [] [] []. unzip [pr X Y|L] [X|LX] [Y|LY] :- unzip L LX LY. pred flatten i:list (list A), o:list A. flatten [X|LS] R :- flatten LS LS', append X LS' R. flatten [] []. pred null i:list A. null []. pred iota i:int, o:list int. iota N L :- iota.aux 0 N L. iota.aux X X [] :- !. iota.aux N X [N|R] :- M is N + 1, iota.aux M X R. % [intersperse X L R] R is [L0, X, ..., X, LN] :index(_ 1) pred intersperse i:A, i:list A, o:list A. intersperse _ [] []. intersperse _ [X] [X] :- !. intersperse Sep [X|XS] [X,Sep|YS] :- intersperse Sep XS YS. % -- Misc -- pred flip i:(A -> B -> prop), i:B, i:A. flip P X Y :- P Y X. pred time i:prop, o:float. time P T :- gettimeofday Before, P, gettimeofday After, T is After - Before. pred do! i:list prop. do! []. do! [P|PS] :- P, !, do! PS. :index(_ 1) pred do-ok! o:diagnostic, i:list (diagnostic -> prop). do-ok! ok []. do-ok! S [P|PS] :- P S0, !, if (S0 = ok) (do-ok! S PS) (S = S0). pred lift-ok i:prop, i:string, o:diagnostic. lift-ok P Msg R :- (P, R = ok; R = error Msg). pred spy-do! i:list prop. spy-do! L :- map L (x\y\y = spy x) L1, do! L1. pred while-ok-do! i:diagnostic, i:list (diagnostic -> prop), o:diagnostic. while-ok-do! (error _ as E) _ E. while-ok-do! ok [] ok. while-ok-do! ok [P|PS] R :- P C, !, while-ok-do! C PS R. pred any->string i:A, o:string. any->string X Y :- term_to_string X Y. pred max i:A, i:A, o:A. max N M N :- N >= M, !. max _ M M. % [findall P L] L is the list [P1,P2,P3..] where each Pi is a solution to P. pred findall i:prop, o:list prop. findall P L :- findall_solutions P L. } % [std.string.concat Separator Items Result] concatenates Items % interspersing Separator external pred std.string.concat i:string, i:list string, o:string. % CAVEAT: the type parameter of std.string.map must be a closed term kind std.string.map type -> type. % [std.string.map.empty M] The empty map external pred std.string.map.empty o:std.string.map A. % [std.string.map.mem S M] Checks if S is bound in M external pred std.string.map.mem i:string, i:std.string.map A. % [std.string.map.add S V M M1] M1 is M where V is bound to S external pred std.string.map.add i:string, i:A, i:std.string.map A, o:std.string.map A. % [std.string.map.remove S M M1] M1 is M where S is unbound external pred std.string.map.remove i:string, i:std.string.map A, o:std.string.map A. % [std.string.map.find S M V] V is the binding of S in M external pred std.string.map.find i:string, i:std.string.map A, o:A. % [std.string.map.bindings M L] L is M transformed into an associative list external pred std.string.map.bindings i:std.string.map A, o:list (pair string A). % [std.string.map.filter M F M1] Filter M w.r.t. the predicate F external pred std.string.map.filter i:std.string.map A, i:string -> A -> prop, o:std.string.map A. % [std.string.map.map M F M1] Map M w.r.t. the predicate F external pred std.string.map.map i:std.string.map A, i:string -> A -> B -> prop, o:std.string.map B. % CAVEAT: the type parameter of std.int.map must be a closed term kind std.int.map type -> type. % [std.int.map.empty M] The empty map external pred std.int.map.empty o:std.int.map A. % [std.int.map.mem S M] Checks if S is bound in M external pred std.int.map.mem i:int, i:std.int.map A. % [std.int.map.add S V M M1] M1 is M where V is bound to S external pred std.int.map.add i:int, i:A, i:std.int.map A, o:std.int.map A. % [std.int.map.remove S M M1] M1 is M where S is unbound external pred std.int.map.remove i:int, i:std.int.map A, o:std.int.map A. % [std.int.map.find S M V] V is the binding of S in M external pred std.int.map.find i:int, i:std.int.map A, o:A. % [std.int.map.bindings M L] L is M transformed into an associative list external pred std.int.map.bindings i:std.int.map A, o:list (pair int A). % [std.int.map.filter M F M1] Filter M w.r.t. the predicate F external pred std.int.map.filter i:std.int.map A, i:int -> A -> prop, o:std.int.map A. % [std.int.map.map M F M1] Map M w.r.t. the predicate F external pred std.int.map.map i:std.int.map A, i:int -> A -> B -> prop, o:std.int.map B. % CAVEAT: the type parameter of std.loc.map must be a closed term kind std.loc.map type -> type. % [std.loc.map.empty M] The empty map external pred std.loc.map.empty o:std.loc.map A. % [std.loc.map.mem S M] Checks if S is bound in M external pred std.loc.map.mem i:loc, i:std.loc.map A. % [std.loc.map.add S V M M1] M1 is M where V is bound to S external pred std.loc.map.add i:loc, i:A, i:std.loc.map A, o:std.loc.map A. % [std.loc.map.remove S M M1] M1 is M where S is unbound external pred std.loc.map.remove i:loc, i:std.loc.map A, o:std.loc.map A. % [std.loc.map.find S M V] V is the binding of S in M external pred std.loc.map.find i:loc, i:std.loc.map A, o:A. % [std.loc.map.bindings M L] L is M transformed into an associative list external pred std.loc.map.bindings i:std.loc.map A, o:list (pair loc A). % [std.loc.map.filter M F M1] Filter M w.r.t. the predicate F external pred std.loc.map.filter i:std.loc.map A, i:loc -> A -> prop, o:std.loc.map A. % [std.loc.map.map M F M1] Map M w.r.t. the predicate F external pred std.loc.map.map i:std.loc.map A, i:loc -> A -> B -> prop, o:std.loc.map B. kind std.string.set type. % [std.string.set.empty A] The empty set external pred std.string.set.empty o:std.string.set. % [std.string.set.mem Elem A] Checks if Elem is in a external pred std.string.set.mem i:string, i:std.string.set. % [std.string.set.add Elem A B] B is A union {Elem} external pred std.string.set.add i:string, i:std.string.set, o:std.string.set. % [std.string.set.remove Elem A B] B is A \ {Elem} external pred std.string.set.remove i:string, i:std.string.set, o:std.string.set. % [std.string.set.union A B X] X is A union B external pred std.string.set.union i:std.string.set, i:std.string.set, o:std.string.set. % [std.string.set.inter A B X] X is A intersection B external pred std.string.set.inter i:std.string.set, i:std.string.set, o:std.string.set. % [std.string.set.diff A B X] X is A \ B external pred std.string.set.diff i:std.string.set, i:std.string.set, o:std.string.set. % [std.string.set.equal A B] tests A and B for equality external pred std.string.set.equal i:std.string.set, i:std.string.set. % [std.string.set.subset A B] tests if A is a subset of B external pred std.string.set.subset i:std.string.set, i:std.string.set. % [std.string.set.elements M L] L is M transformed into list external pred std.string.set.elements i:std.string.set, o:list string. % [std.string.set.cardinal M N] N is the number of elements of M external pred std.string.set.cardinal i:std.string.set, o:int. % [std.string.set.filter M F M1] Filter M w.r.t. the predicate F external pred std.string.set.filter i:std.string.set, i:string -> prop, o:std.string.set. % [std.string.set.map M F M1] Map M w.r.t. the predicate F external pred std.string.set.map i:std.string.set, i:string -> string -> prop, o:std.string.set. kind std.int.set type. % [std.int.set.empty A] The empty set external pred std.int.set.empty o:std.int.set. % [std.int.set.mem Elem A] Checks if Elem is in a external pred std.int.set.mem i:int, i:std.int.set. % [std.int.set.add Elem A B] B is A union {Elem} external pred std.int.set.add i:int, i:std.int.set, o:std.int.set. % [std.int.set.remove Elem A B] B is A \ {Elem} external pred std.int.set.remove i:int, i:std.int.set, o:std.int.set. % [std.int.set.union A B X] X is A union B external pred std.int.set.union i:std.int.set, i:std.int.set, o:std.int.set. % [std.int.set.inter A B X] X is A intersection B external pred std.int.set.inter i:std.int.set, i:std.int.set, o:std.int.set. % [std.int.set.diff A B X] X is A \ B external pred std.int.set.diff i:std.int.set, i:std.int.set, o:std.int.set. % [std.int.set.equal A B] tests A and B for equality external pred std.int.set.equal i:std.int.set, i:std.int.set. % [std.int.set.subset A B] tests if A is a subset of B external pred std.int.set.subset i:std.int.set, i:std.int.set. % [std.int.set.elements M L] L is M transformed into list external pred std.int.set.elements i:std.int.set, o:list int. % [std.int.set.cardinal M N] N is the number of elements of M external pred std.int.set.cardinal i:std.int.set, o:int. % [std.int.set.filter M F M1] Filter M w.r.t. the predicate F external pred std.int.set.filter i:std.int.set, i:int -> prop, o:std.int.set. % [std.int.set.map M F M1] Map M w.r.t. the predicate F external pred std.int.set.map i:std.int.set, i:int -> int -> prop, o:std.int.set. kind std.loc.set type. % [std.loc.set.empty A] The empty set external pred std.loc.set.empty o:std.loc.set. % [std.loc.set.mem Elem A] Checks if Elem is in a external pred std.loc.set.mem i:loc, i:std.loc.set. % [std.loc.set.add Elem A B] B is A union {Elem} external pred std.loc.set.add i:loc, i:std.loc.set, o:std.loc.set. % [std.loc.set.remove Elem A B] B is A \ {Elem} external pred std.loc.set.remove i:loc, i:std.loc.set, o:std.loc.set. % [std.loc.set.union A B X] X is A union B external pred std.loc.set.union i:std.loc.set, i:std.loc.set, o:std.loc.set. % [std.loc.set.inter A B X] X is A intersection B external pred std.loc.set.inter i:std.loc.set, i:std.loc.set, o:std.loc.set. % [std.loc.set.diff A B X] X is A \ B external pred std.loc.set.diff i:std.loc.set, i:std.loc.set, o:std.loc.set. % [std.loc.set.equal A B] tests A and B for equality external pred std.loc.set.equal i:std.loc.set, i:std.loc.set. % [std.loc.set.subset A B] tests if A is a subset of B external pred std.loc.set.subset i:std.loc.set, i:std.loc.set. % [std.loc.set.elements M L] L is M transformed into list external pred std.loc.set.elements i:std.loc.set, o:list loc. % [std.loc.set.cardinal M N] N is the number of elements of M external pred std.loc.set.cardinal i:std.loc.set, o:int. % [std.loc.set.filter M F M1] Filter M w.r.t. the predicate F external pred std.loc.set.filter i:std.loc.set, i:loc -> prop, o:std.loc.set. % [std.loc.set.map M F M1] Map M w.r.t. the predicate F external pred std.loc.set.map i:std.loc.set, i:loc -> loc -> prop, o:std.loc.set. #line 0 "builtin_map.elpi" kind std.map type -> type -> type. type std.map std.map.private.map K V -> (K -> K -> cmp -> prop) -> std.map K V. namespace std.map { % [make Eq Ltn M] builds an empty map M where keys are compared using Eq and Ltn pred make i:(K -> K -> cmp -> prop), o:std.map K V. make Cmp (std.map private.empty Cmp). % [find K M V] looks in M for the value V associated to K pred find i:K, i:std.map K V, o:V. find K (std.map M Cmp) V :- private.find M Cmp K V. % [add K V M M1] M1 is M where K is bound to V pred add i:K, i:V, i:std.map K V, o:std.map K V. add K V (std.map M Cmp) (std.map M1 Cmp) :- private.add M Cmp K V M1. % [remove K M M1] M1 is M where K is unbound pred remove i:K, i:std.map K V, o:std.map K V. remove K (std.map M Cmp) (std.map M1 Cmp) :- private.remove M Cmp K M1. % [bindings M L] L is the key-value pairs in increasing order pred bindings i:std.map K V, o:list (pair K V). bindings (std.map M _) L :- private.bindings M [] L. namespace private { % Taken from OCaml's map.ml kind map type -> type -> type. type empty map K V. type node map K V -> K -> V -> map K V -> int -> map K V. pred height i:map K V, o:int. height empty 0. height (node _ _ _ _ H) H. pred create i:map K V, i:K, i:V, i:map K V, o:map K V. create L K V R (node L K V R H) :- H is {std.max {height L} {height R}} + 1. pred bal i:map K V, i:K, i:V, i:map K V, o:map K V. bal L K V R T :- height L HL, height R HR, HL2 is HL + 2, HR2 is HR + 2, bal.aux HL HR HL2 HR2 L K V R T. bal.aux HL _ _ HR2 (node LL LV LD LR _) X D R T :- HL > HR2, {height LL} >= {height LR}, !, create LL LV LD {create LR X D R} T. bal.aux HL _ _ HR2 (node LL LV LD (node LRL LRV LRD LRR _) _) X D R T :- HL > HR2, !, create {create LL LV LD LRL} LRV LRD {create LRR X D R} T. bal.aux _ HR HL2 _ L X D (node RL RV RD RR _) T :- HR > HL2, {height RR} >= {height RL}, !, create {create L X D RL} RV RD RR T. bal.aux _ HR HL2 _ L X D (node (node RLL RLV RLD RLR _) RV RD RR _) T :- HR > HL2, !, create {create L X D RLL} RLV RLD {create RLR RV RD RR} T. bal.aux _ _ _ _ L K V R T :- create L K V R T. pred add i:map K V, i:(K -> K -> cmp -> prop), i:K, i:V, o:map K V. add empty _ K V T :- create empty K V empty T. add (node _ X _ _ _ as M) Cmp X1 XD M1 :- Cmp X1 X E, add.aux E M Cmp X1 XD M1. add.aux eq (node L _ _ R H) _ X XD T :- T = node L X XD R H. add.aux lt (node L V D R _) Cmp X XD T :- bal {add L Cmp X XD} V D R T. add.aux gt (node L V D R _) Cmp X XD T :- bal L V D {add R Cmp X XD} T. pred find i:map K V, i:(K -> K -> cmp -> prop), i:K, o:V. find (node L K1 V1 R _) Cmp K V :- Cmp K K1 E, find.aux E Cmp L R V1 K V. find.aux eq _ _ _ V _ V. find.aux lt Cmp L _ _ K V :- find L Cmp K V. find.aux gt Cmp _ R _ K V :- find R Cmp K V. pred remove-min-binding i:map K V, o:map K V. remove-min-binding (node empty _ _ R _) R :- !. remove-min-binding (node L V D R _) X :- bal {remove-min-binding L} V D R X. pred min-binding i:map K V, o:K, o:V. min-binding (node empty V D _ _) V D :- !. min-binding (node L _ _ _ _) V D :- min-binding L V D. pred merge i:map K V, i:map K V, o:map K V. merge empty X X :- !. merge X empty X :- !. merge M1 M2 R :- min-binding M2 X D, bal M1 X D {remove-min-binding M2} R. pred remove i:map K V, i:(K -> K -> cmp -> prop), i:K, o:map K V. remove empty _ _ empty :- !. remove (node L V D R _) Cmp X M :- Cmp X V E, remove.aux E Cmp L R V D X M. remove.aux eq _ L R _ _ _ M :- merge L R M. remove.aux lt Cmp L R V D X M :- bal {remove L Cmp X} V D R M. remove.aux gt Cmp L R V D X M :- bal L V D {remove R Cmp X} M. pred bindings i:map K V, i:list (pair K V), o:list (pair K V). bindings empty X X. bindings (node L V D R _) X X1 :- bindings L [pr V D|{bindings R X}] X1. } % std.map.private } % std.map #line 0 "builtin_set.elpi" kind std.set type -> type. type std.set std.set.private.set E -> (E -> E -> cmp -> prop) -> std.set E. namespace std.set { % [make Eq Ltn M] builds an empty set M where keys are compared using Eq and Ltn pred make i:(E -> E -> cmp -> prop), o:std.set E. make Cmp (std.set private.empty Cmp). % [mem E M] looks if E is in M pred mem i:E, i:std.set E. mem E (std.set M Cmp):- private.mem M Cmp E. % [add E M M1] M1 is M + {E} pred add i:E, i:std.set E, o:std.set E. add E (std.set M Cmp) (std.set M1 Cmp) :- private.add M Cmp E M1. % [remove E M M1] M1 is M - {E} pred remove i:E, i:std.set E, o:std.set E. remove E (std.set M Cmp) (std.set M1 Cmp) :- private.remove M Cmp E M1. % [cardinal S N] N is the number of elements of S pred cardinal i:std.set E, o:int. cardinal (std.set M _) N :- private.cardinal M N. pred elements i:std.set E, o:list E. elements (std.set M _) L :- private.elements M [] L. namespace private { % Taken from OCaml's set.ml kind set type -> type. type empty set E. type node set E -> E -> set E -> int -> set E. pred height i:set E, o:int. height empty 0. height (node _ _ _ H) H. pred create i:set E, i:E, i:set E, o:set E. create L E R (node L E R H) :- H is {std.max {height L} {height R}} + 1. pred bal i:set E, i:E, i:set E, o:set E. bal L E R T :- height L HL, height R HR, HL2 is HL + 2, HR2 is HR + 2, bal.aux HL HR HL2 HR2 L E R T. bal.aux HL _ _ HR2 (node LL LV LR _) X R T :- HL > HR2, {height LL} >= {height LR}, !, create LL LV {create LR X R} T. bal.aux HL _ _ HR2 (node LL LV (node LRL LRV LRR _) _) X R T :- HL > HR2, !, create {create LL LV LRL} LRV {create LRR X R} T. bal.aux _ HR HL2 _ L X (node RL RV RR _) T :- HR > HL2, {height RR} >= {height RL}, !, create {create L X RL} RV RR T. bal.aux _ HR HL2 _ L X (node (node RLL RLV RLR _) RV RR _) T :- HR > HL2, !, create {create L X RLL} RLV {create RLR RV RR} T. bal.aux _ _ _ _ L E R T :- create L E R T. pred add i:set E, i:(E -> E -> cmp -> prop), i:E, o:set E. add empty _ E T :- create empty E empty T. add (node L X R H) Cmp X1 S :- Cmp X1 X E, add.aux E Cmp L R X X1 H S. add.aux eq _ L R X _ H (node L X R H). add.aux lt Cmp L R E X _ T :- bal {add L Cmp X} E R T. add.aux gt Cmp L R E X _ T :- bal L E {add R Cmp X} T. pred mem i:set E, i:(E -> E -> cmp -> prop), i:E. mem (node L K R _) Cmp E :- Cmp E K O, mem.aux O Cmp L R E. mem.aux eq _ _ _ _. mem.aux lt Cmp L _ E :- mem L Cmp E. mem.aux gt Cmp _ R E :- mem R Cmp E. pred remove-min-binding i:set E, o:set E. remove-min-binding (node empty _ R _) R :- !. remove-min-binding (node L E R _) X :- bal {remove-min-binding L} E R X. pred min-binding i:set E, o:E. min-binding (node empty E _ _) E :- !. min-binding (node L _ _ _) E :- min-binding L E. pred merge i:set E, i:set E, o:set E. merge empty X X :- !. merge X empty X :- !. merge M1 M2 R :- min-binding M2 X, bal M1 X {remove-min-binding M2} R. pred remove i:set E, i:(E -> E -> cmp -> prop), i:E, o:set E. remove empty _ _ empty. remove (node L E R _) Cmp X M :- Cmp X E O, remove.aux O Cmp L R E X M. remove.aux eq _ L R _ _ M :- merge L R M. remove.aux lt Cmp L R E X M :- bal {remove L Cmp X} E R M. remove.aux gt Cmp L R E X M :- bal L E {remove R Cmp X} M. pred cardinal i:set E, o:int. cardinal empty 0. cardinal (node L _ R _) N :- N is {cardinal L} + 1 + {cardinal R}. pred elements i:set E, i:list E, o:list E. elements empty X X. elements (node L E R _) Acc X :- elements L [E|{elements R Acc}] X. } % std.set.private } % std.set % == I/O builtins ===================================== % -- I/O -- typeabbrev in_stream (ctype "in_stream"). type std_in in_stream. typeabbrev out_stream (ctype "out_stream"). type std_out out_stream. type std_err out_stream. % [open_in FileName InStream] opens FileName for input external pred open_in i:string, o:in_stream. % [open_out FileName OutStream] opens FileName for output external pred open_out i:string, o:out_stream. % [open_append FileName OutStream] opens FileName for output in append mode external pred open_append i:string, o:out_stream. % [close_in InStream] closes input stream InStream external pred close_in i:in_stream. % [close_out OutStream] closes output stream OutStream external pred close_out i:out_stream. % [output OutStream Data] writes Data to OutStream external pred output i:out_stream, i:string. % [flush OutStream] flush all output not yet finalized to OutStream external pred flush i:out_stream. % [input InStream Bytes Data] reads Bytes from InStream external pred input i:in_stream, i:int, o:string. % [input_line InStream Line] reads a full line from InStream external pred input_line i:in_stream, o:string. % [eof InStream] checks if no more data can be read from InStream external pred eof i:in_stream. % -- System -- % [gettimeofday T] sets T to the number of seconds elapsed since 1/1/1970 external pred gettimeofday o:float. % [getenv VarName Value] Like Sys.getenv external pred getenv i:string, o:option string. % [system Command RetVal] executes Command and sets RetVal to the exit code external pred system i:string, o:int. % -- Unix -- % gathers the standard file descriptors or a process kind unix.process type. type unix.process out_stream -> in_stream -> in_stream -> unix.process. % [unix.process.open Executable Arguments Environment P Diagnostic] OCaml's % Unix.open_process_args_full. % Note that the first argument is the executable name (as in argv[0]). % If Executable is omitted it defaults to the first element of % Arguments. % Environment can be left unspecified, defaults to the current process % environment. % This API only works reliably since OCaml 4.12. external pred unix.process.open i:string, i:list string, i:list string, o:unix.process, o:diagnostic. % [unix.process.close P Diagnostic] OCaml's Unix.close_process_full external pred unix.process.close i:unix.process, o:diagnostic. % -- Debugging -- % [term_to_string T S] prints T to S external pred term_to_string i:any, o:string. % == Elpi runtime builtins ===================================== % [trace.counter Name Value] reads the Value of a trace point Name external pred trace.counter i:string, o:int. % [gc.get MinorHeapSize MajorHeapIncrement SpaceOverhead Verbose MaxOverhead % StackLimit AllocationPolicy WindowSize] Reads the current settings of the % garbage collector. See also OCaml's Gc.control type documentation. external pred gc.get o:int, o:int, o:int, o:int, o:int, o:int, o:int, o:int. % [gc.set MinorHeapSize MajorHeapIncrement SpaceOverhead Verbose MaxOverhead % StackLimit AllocationPolicy WindowSize] Writes the current settings of the % garbage collector. Any parameter left unspecificed (eg _) is not changed. % See also OCaml's Gc.control type documentation. external pred gc.set i:int, i:int, i:int, i:int, i:int, i:int, i:int, i:int. % [gc.minor] See OCaml's Gc.minor documentation. external pred gc.minor . % [gc.major] See OCaml's Gc.major documentation. external pred gc.major . % [gc.full] See OCaml's Gc.full_major documentation. external pred gc.full . % [gc.compact] See OCaml's Gc.compact documentation. external pred gc.compact . % [gc.stat MinorWords PromotedWords MajorWords MinorCollections % MajorCollections HeapWords HeapChunks LiveWords LiveBlocks FreeWords % FreeBlocks LargestFree Fragments Compactions TopHeapWords StackSize] See % OCaml's Gc.stat documentation. external pred gc.stat o:float, o:float, o:float, o:int, o:int, o:int, o:int, o:int, o:int, o:int, o:int, o:int, o:int, o:int, o:int, o:int. % [gc.quick-stat MinorWords PromotedWords MajorWords MinorCollections % MajorCollections HeapWords HeapChunks Compactions TopHeapWords StackSize] % See OCaml's Gc.quick_stat documentation. external pred gc.quick-stat o:float, o:float, o:float, o:int, o:int, o:int, o:int, o:int, o:int, o:int. % == Lambda Prolog builtins ===================================== % -- Extra I/O -- % [open_string DataIn InStream] opens DataIn as an input stream external pred open_string i:string, o:in_stream. % [lookahead InStream NextChar] peeks one byte from InStream external pred lookahead i:in_stream, o:string. % -- Hacks -- % [string_to_term S T] parses a term T from S external pred string_to_term i:string, o:any. % [readterm InStream T] reads T from InStream, ends with \n external pred readterm i:in_stream, o:any. pred printterm i:out_stream, i:A. printterm S T :- term_to_string T T1, output S T1. pred read o:A. read S :- flush std_out, input_line std_in X, string_to_term X S. coq-elpi-2.1.0/elpi/000077500000000000000000000000001460156013500141555ustar00rootroot00000000000000coq-elpi-2.1.0/elpi/README.md000066400000000000000000000015371460156013500154420ustar00rootroot00000000000000### coq-HOAS Documents how Coq terms are represented in Elpi. ### coq-lib Standard library of Coq specific utilities (in the coq. namespace). ### elpi-command-template Selects which files are accumulated in an `Elpi Command`. ### elpi-tactic-template Selects which files are accumulated in an `Elpi Tactic`. ### coq-elpi-checker Extends the standard type checker for Elpi programs so that it reports errors using Coq's I/O primitives. ### elpi-ltac Implementation of Ltac's like combinators in Elpi. ### elpi-reduction Implementation of reduction in Elpi. Main entry points are `whd` and `hd-beta`. ### coq-elaborator Uses the Coq type inference and unification algorithms in order to implement `of`, `unify-*` and `evar`. ### elpi-elaborator An elaborator completely written in Elpi (work in progress). It implements `of`, `unify-*` and `evar`. coq-elpi-2.1.0/elpi/coq-HOAS.elpi000066400000000000000000000353141460156013500163500ustar00rootroot00000000000000%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %%%%%%%%%%%%%%%%%%%%%%%%%%%%%% coq-HOAS %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % This section contains the low level data types linking Coq and elpi. % In particular the data type for terms and the evar_map entries (a sequent) % and the entry points for tactics % Entry point for tactics. Eg. "elpi mytactic foo 3 (f x)." becomes % solve % Where [str "foo", int 3, trm (app[f,x])] is part of . % The encoding of goals is described below. % msolve is for tactics that operate on multiple goals (called via all: ). pred solve i:goal, o:list sealed-goal. pred msolve i:list sealed-goal, o:list sealed-goal. % Extra arguments for tactics type tac ltac1-tactic -> argument. % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Coq's terms % % Types of term formers % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % -- terms -------------------------------------------------------------------- kind term type. type sort sort -> term. % Prop, Type@{i} % constants: inductive types, inductive constructors, definitions type global gref -> term. type pglobal gref -> univ-instance -> term. % binders: to form functions, arities and local definitions type fun name -> term -> (term -> term) -> term. % fun x : t => type prod name -> term -> (term -> term) -> term. % forall x : t, type let name -> term -> term -> (term -> term) -> term. % let x : T := v in % other term formers: function application, pattern matching and recursion type app list term -> term. % app [hd|args] type match term -> term -> list term -> term. % match t p [branch]) type fix name -> int -> term -> (term -> term) -> term. % fix name rno ty bo type primitive primitive-value -> term. % NYI %type cofix name -> term -> (term -> term) -> term. % cofix name ty bo % Notes about (match Scrutinee TypingFunction Branches) when % Inductive i A : A -> nat -> Type := K : forall a : A, i A a 0 % and % Scrutinee be a term of type (i bool true 7) % % - TypingFunction has a very rigid shape that depends on i. Namely % as many lambdas as indexes plus one lambda for the inductive itself % where the value of the parameters are taken from the type of the scrutinee: % fun `a` (indt "bool") a\ % fun `n` (indt "nat) n\ % fun `i` (app[indt "i", indt "bool", a n) i\ .. % Such spine of fun cannot be omitted; else elpi cannot read the term back. % See also coq.bind-ind-arity-no-let in coq-lib.elpi, that builds such spine for you, % or the higher level api coq.build-match (same file) that also takes % care of breanches. % - Branches is a list of terms, the order is the canonical one (the order % of the constructors as they were declared). If the constructor has arguments % (excluding the parameters) then the corresponding term shall be a Coq % function. In this case % fun `x` (indt "bool") x\ .. % -- helpers ------------------------------------------------------------------ macro @cast T TY :- (let `cast` TY T x\x). % -- misc --------------------------------------------------------------------- % When one writes Constraint Handling Rules unification variables are "frozen", % i.e. represented by a fresh constant (the evar key) and a list of terms % (typically the variables in scope). kind evarkey type. type uvar evarkey -> list term -> term. % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Coq's evar_map % % Context and evar declaration % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % An evar_info (displayed as a Coq goal) is essentially a sequent: % % x : t % y := v : x % ---------- % p x y % % is coded as an Elpi query % % pi x1\ decl x1 `x` => % pi x2\ def x2 `y` x1 => % declare-evar % [def x2 `y` x1 , decl x1 `x` ] % (RawEvar x1 x2) (

x1 x2) (Ev x1 x2) % % where, by default, declare-evar creates a syntactic constraint as % % {x1 x2} : % decl x1 `x` , def x2 `y` x1 ?- % evar (RawEvar x1 x2) (

x1 x2) (Ev x1 x2) /* suspended on RawEvar, Ev */ % % When the program is over, a remaining syntactic constraint like the one above % is read back and transformed into the corresponding evar_info. pred decl i:term, o:name, o:term. % Var Name Ty pred def i:term, o:name, o:term, o:term. % Var Name Ty Bo pred declare-evar i:list prop, i:term, i:term, i:term. % Ctx RawEvar Ty Evar :name "default-declare-evar" declare-evar Ctx RawEv Ty Ev :- declare_constraint (declare-evar Ctx RawEv Ty Ev) [RawEv]. % When a goal (evar _ _ _) is turned into a constraint the context is filtered % to only contain decl, def, pp. For now no handling rules for this set of % constraints other than one to remove a constraint pred rm-evar i:term, i:term. rm-evar (uvar as X) (uvar as Y):- !, declare_constraint (rm-evar X Y) [X,Y]. rm-evar _ _. constraint declare-evar evar def decl cache rm-evar { % Override the actual context rule \ (declare-evar Ctx RawEv Ty Ev) <=> (Ctx => evar RawEv Ty Ev). rule \ (rm-evar (uvar X _) (uvar Y _)) (evar (uvar X _) _ (uvar Y _)). rule \ (rm-evar (uvar X _) (uvar Y _)). } % The (evar R Ty E) predicate suspends when R and E are flexible, % and is solved otherwise. % The client may want to provide an alternative implementation of % the clause "default-assign-evar", for example to typechecks that the % term assigned to E has type Ty, or that the term assigned to R % elaborates to a term of type Ty that gets assigned to E. % In tactic mode, elpi/coq-elaborator.elpi wires things up that way. pred evar i:term, i:term, o:term. % Evar Ty RefinedSolution evar (uvar as X) T S :- var S _ VL, !, prune T VL, prune X VL, declare_constraint (evar X T S) [X, S]. :name "default-assign-evar" evar _ _ _. % volatile, only unresolved evars are considered as evars % To ease the creation of a context with decl and def % Eg. @pi-decl `x` x1\ @pi-def `y` y\ ... macro @pi-decl N T F :- pi x\ decl x N T => F x. macro @pi-def N T B F :- pi x\ def x N T B => cache x B_ => F x. macro @pi-parameter ID T F :- sigma N\ (coq.id->name ID N, pi x\ decl x N T => F x). macro @pi-inductive ID A F :- sigma N\ (coq.id->name ID N, coq.arity->term A T, pi x\ decl x N T => F x). % Sometimes it can be useful to pass to Coq a term with unification variables % representing "untyped holes" like an implicit argument _. In particular % a unification variable may exit the so called pattern fragment (applied % to distinct variables) and hence cannot be reliably mapped to Coq as an evar, % but can still be considered as an implicit argument. % By loading in the context get-option "HOAS:holes" tt one forces that % behavior. Here a convenience macro to be put on the LHS of => macro @holes! :- get-option "HOAS:holes" tt. % Similarly, some APIs take a term skeleton in input. In that case unification % variables are totally disregarded (not even mapped to Coq evars). They are % interpreted as the {{ lib:elpi.hole }} constant, which represents an implicit % argument. As a consenque these APIs don't modify the input term at all, but % rather return a copy. Note that if {{ lib:elpi.hole }} is used directly, then % it has to be applied to all variables in scope, since Coq erases variables % that are not used. For example using {{ forall x : nat, lib:elpi.hole }} as % a term skeleton is equivalent to {{ nat -> lib:elpi.hole }}, while % {{ forall x : nat, lib:elpi.hole x lib:elpi.hole more args }} puts x in % the scope of the hole (and passes to is more args). % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Coq's goals and tactic invocation % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % A Coq goal is essentially a sequent, like the evar_info above, but since it % has to be manipulated as first class Elpi data, it is represented in a slightly % different way. For example % % x : t % y := v : x % ---------- % g x y % % is represented by the following term of type sealed-goal % % nabla x1\ % nabla x2\ % seal % (goal % [def x2 `y` x1 , decl x1 `x` ] % (RawEvar x1 x2) ( x1 x2) (Evar x1 x2) % (Arguments x1 x2)) kind goal type. kind sealed-goal type. type nabla (term -> sealed-goal) -> sealed-goal. type seal goal -> sealed-goal. typeabbrev goal-ctx (list prop). type goal goal-ctx -> term -> term -> term -> list argument -> goal. % A sealed-goal closes with nabla the bound names of a % % (goal Ctx RawSolution Ty Solution Arguments) % % where Ctx is a list of decl or def and Solution is a unification variable % to be assigned to a term of type Ty in order to make progress. % RawSolution is used as a trigger: when a term is assigned to it, it is % elaborated against Ty and the resulting term is assigned to Solution. % % Arguments contains data attached to the goal, which lives in its context % and can be used by tactics to solve the goals. % A tactic (an elpi predicate which makes progress on a Coq goal) is % a predicate of type % sealed-goal -> list sealed-goal -> prop % % while the main entry point for a tactic written in Elpi is solve % which has type % goal -> list sealed-goal -> prop % % The utility (coq.ltac.open T G GL) postulates all the variables bounds % by nabla and loads the goal context before calling T on the unsealed % goal. The invocation of a tactic with arguments % 3 x "y" (h x) % on the previous goal results in the following Elpi query: % % (pi x1\ decl x1 `x` => % pi x2\ def x2 `y` x1 => % declare-evar % [def x2 `y` x1 , decl x1 `x` ] % (RawEvar x1 x2) ( x1 x2) (Evar x1 x2)), % (coq.ltac.open solve % (nabla x1\ nabla x2\ seal % (goal % [def x2 `y` x1 , decl x1 `x` ] % (RawEvar x1 x2) ( x1 x2) (Evar x1 x2) % [int 3, str `x`, str`y`, trm (app[const `h`,x1])])) % NewGoals) % % If the goal sequent contains other evars, then a tactic invocation is % an Elpi query made of the conjunction of all the declare-evar queries % corresponding to these evars and the query corresponding to the goal % sequent. NewGoals can be assigned to a list of goals that should be % declared as open. Omitted goals are shelved. If NewGoals is not % assigned, then all unresolved evars become new goals, but the order % of such goals is not specified. % The file elpi-ltac.elpi provides a few combinators (other than coq.ltac.open) % in the tradition of LCF tacticals. The main difference is that the arguments % of custom written tactics must not be passed as predicate arguments but rather % put in the goal they receive. Indeed these arguments can contain terms, and % their bound variables cannot escape the seal. coq.ltac.set-goal-arguments % can be used to put an argument from the current goal context into another % goal. The coq.ltac.call utility can call Ltac1 code (written in Coq) and % pass arguments via this mechanism. % Last, since Elpi is alerady a logic programming language with primitive % support for unification variables, most of the work of a tactic can be % performed without using tacticals (which work on sealed goals) but rather % in the context of the original goal. The last step is typically to call % the refine utility with a term synthesized by the tactic or invoke some % Ltac1 code on that term (e.g. to call vm_compute, see also the example % on the reflexive tactic). % ----- Multi goals tactics. ---- % Coq provides goal selectors, such as all:, to pass to a tactic more than one % goal. In order to write such a tactic, Coq-Elpi provides another entry point % called msolve. To be precise, if there are two goals under focus, say and % , then all: elpi tac runs the following query % % msolve [,] NewGoals ; % note the disjunction % coq.ltac.all (coq.ltac.open solve) [,] NewGoals % % So, if msolve has no clause, Coq-Elpi will use solve on all the goals % independently. If msolve has a cluse, then it can manipulate the entire list % of sealed goals. Note that the argument is in both and but % it is interpreted in both contexts independently. If both goals have a proof % variable named "x" then passing (@eq_refl _ x) as equips both goals with % a (raw) proof that "x = x", no matter what their type is. % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Declarations for Coq's API (environment read/write access, etc). % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % tt = Yes, ff = No, unspecified = No (unspecified means "_" or a variable). typeabbrev opaque? bool. macro @opaque! :- tt. macro @transparent! :- ff. %%%%%%% Attributes to be passed to APIs as in @local! => coq.something %%%%%%%% macro @primitive! :- get-option "coq:primitive" tt. % primitive records macro @reversible! :- get-option "coq:reversible" tt. % coercions macro @no-tc! :- get-option "coq:no_tc" tt. % skip typeclass inference macro @uinstance! I :- get-option "coq:uinstance" I. % universe instance % declaration of universe polymorphic constants % The first list is the one of the unvierse variables being bound % The first boolean is tt if this list can be extended by Coq (or it has to % mention all universes actually used) % The second list if the one with the constaints amond where universes % The second boolean is tt if this list can be extended by Coq or it has to % mention all universe constraints actually required to type check the % declaration) macro @udecl! Vs LV Cs LC :- get-option "coq:udecl" (upoly-decl Vs LV Cs LC). macro @udecl-cumul! Vs LV Cs LC :- get-option "coq:udecl-cumul" (upoly-decl-cumul Vs LV Cs LC). macro @univpoly! :- @udecl! [] tt [] tt. macro @univpoly-cumul! :- @udecl-cumul! [] tt [] tt. macro @ppwidth! N :- get-option "coq:ppwidth" N. % printing width macro @ppall! :- get-option "coq:pp" "all". % printing all macro @ppmost! :- get-option "coq:pp" "most". % printing most of contents macro @pplevel! N :- get-option "coq:pplevel" N. % printing precedence (for parentheses) macro @keepunivs! :- get-option "coq:keepunivs" tt. % skeletons elaboration macro @dropunivs! :- get-option "coq:keepunivs" ff. % add-indt/add-const macro @using! S :- get-option "coq:using" S. % like the #[using=S] attribute macro @inline-at! N :- get-option "coq:inline" (coq.inline.at N). % like Inline(N) macro @inline! N :- get-option "coq:inline" coq.inline.default. % like macro @redflags! F :- get-option "coq:redflags" F. % for whd & co % both arguments are strings eg "8.12.0" "use foo instead" macro @deprecated! Since Msg :- get-option "coq:deprecated" (pr Since Msg). macro @ltacfail! N :- get-option "ltac:fail" N. % retrocompatibility macro for Coq v8.10 macro @coercion! :- [coercion reversible]. coq-elpi-2.1.0/elpi/coq-arg-HOAS.elpi000066400000000000000000000132161460156013500171140ustar00rootroot00000000000000%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %%%%%%%%%%%%%%%%%%%%%%%%%%%% coq-arg-HOAS %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % This section contains the low level data types linking Coq and elpi. % In particular the entry points for commands % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Entry points % % Command and tactic invocation % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Entry point for commands. Eg. "#[att=true] Elpi mycommand foo 3 (f x)." becomes % main [str "foo", int 3, trm (app[f,x])] % in a context where % attributes [attribute "att" (leaf "true")] % holds. The encoding of terms is described below. % See also the coq.parse-attributes utility. pred main i:list argument. pred main-interp i:list argument, i:any. pred main-synterp i:list argument, o:any. pred usage. pred attributes o:list attribute. % see coq-lib.elpi for coq.parse-attributes generating the options below type get-option string -> A -> prop. % The data type of arguments (for commands or tactics) kind argument type. type int int -> argument. % Eg. 1 -2. type str string -> argument. % Eg. x "y" z.w. or any Coq keyword/symbol type trm term -> argument. % Eg. (t). % Extra arguments for commands. [Definition], [Axiom], [Record] and [Context] % take precedence over the [str] argument above (when not "quoted"). % % Eg. Record or Inductive type indt-decl indt-decl -> argument. % Eg. #[universes(polymorphic,...)] Record or Inductive type upoly-indt-decl indt-decl -> upoly-decl -> argument. type upoly-indt-decl indt-decl -> upoly-decl-cumul -> argument. % Eg. Definition or Axiom (when the body is none) type const-decl id -> option term -> arity -> argument. % Eg. #[universes(polymorphic,...)] Definition or Axiom type upoly-const-decl id -> option term -> arity -> upoly-decl -> argument. % Eg. Context A (b : A). type ctx-decl context-decl -> argument. % Declaration of inductive types %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% kind indt-decl type. kind indc-decl type. kind record-decl type. % An arity is written, in Coq syntax, as: % (x : T1) .. (xn : Tn) : S1 -> ... -> Sn -> U % This syntax is used, for example, in the type of an inductive type or % in the type of constructors. We call the abstractions on the left of ":" % "parameters" while we call the type following the ":" (proper) arity. % Note: in some contexts, like the type of an inductive type constructor, % Coq makes no distinction between these two writings % (xn : Tn) : forall y1 : S1, ... and (xn : Tn) (y1 : S1) : ... % while Elpi is a bit more restrictive, since it understands user directives % such as the implicit status of an arguments (eg, using {} instead of () around % the binder), only on parameters. % Moreover parameters carry the name given by the user as an "id", while binders % in terms only carry it as a "name", an irrelevant pretty pringintg hint (see % also the HOAS of terms). A user command can hence only use the names of % parameters, and not the names of "forall" quantified variables in the arity. % % See also the arity->term predicate in coq-lib.elpi type parameter id -> implicit_kind -> term -> (term -> arity) -> arity. type arity term -> arity. type parameter id -> implicit_kind -> term -> (term -> indt-decl) -> indt-decl. type inductive id -> bool -> arity -> (term -> list indc-decl) -> indt-decl. % tt means inductive, ff coinductive type record id -> term -> id -> record-decl -> indt-decl. type constructor id -> arity -> indc-decl. type field field-attributes -> id -> term -> (term -> record-decl) -> record-decl. type end-record record-decl. % Example. % Remark that A is a regular parameter; y is a non-uniform parameter and t % also features an index of type bool. % % Inductive t (A : Type) | (y : nat) : bool -> Type := % | K1 (x : A) {n : nat} : S n = y -> t A n true -> t A y true % | K2 : t A y false % % is written % % (parameter "A" explicit {{ Type }} a\ % inductive "t" tt (parameter "y" explicit {{ nat }} _\ % arity {{ bool -> Type }}) % t\ % [ constructor "K1" % (parameter "y" explicit {{ nat }} y\ % (parameter "x" explicit a x\ % (parameter "n" maximal {{ nat }} n\ % arity {{ S lp:n = lp:y -> lp:t lp:n true -> lp:t lp:y true }}))) % , constructor "K2" % (parameter "y" explicit {{ nat }} y\ % arity {{ lp:t lp:y false }}) ]) % % Remark that the uniform parameters are not passed to occurrences of t, since % they never change, while non-uniform parameters are both abstracted % in each constructor type and passed as arguments to t. % % The coq.typecheck-indt-decl API can be used to fill in implicit arguments % an infer universe constraints in the declaration above (e.g. the hidden % argument of "=" in the arity of K1). % % Note: when and inductive type declaration is passed as an argument to an % Elpi command non uniform parameters must be separated from the uniform ones % with a | (a syntax introduced in Coq 8.12 and accepted by coq-elpi since % version 1.4, in Coq this separator is optional, but not in Elpi). % Context declaration (used as an argument to Elpi commands) kind context-decl type. % Eg. (x : T) or (x := B), body is optional, type may be a variable type context-item id -> implicit_kind -> term -> option term -> (term -> context-decl) -> context-decl. type context-end context-decl. typeabbrev field-attributes (list field-attribute). macro @global! :- get-option "coq:locality" "global". macro @local! :- get-option "coq:locality" "local". coq-elpi-2.1.0/elpi/coq-elaborator.elpi000066400000000000000000000040171460156013500177440ustar00rootroot00000000000000/* Type inference and unification */ /* license: GNU Lesser General Public License Version 2.1 or later */ /* ------------------------------------------------------------------------- */ % This file does the plumbing to use Coq's elaborator :name "coq-assign-evar-raw" :before "default-assign-evar" evar X Ty R :- var R, !, of X Ty R. :name "coq-assign-evar-refined-hack-8-17-Prop" :before "default-assign-evar" evar X Ty R :- not(var R), same_term Ty {{ Prop }}, coq.version _ 8 17 _, !, hack-8-17.propagate-Prop-constraint-inward R, coq.typecheck R Ty ok, X = R. :name "coq-assign-evar-refined" :before "default-assign-evar" evar X Ty R :- not(var R), !, coq.typecheck R Ty ok, X = R. pred unify-eq i:term, i:term. unify-eq A B :- coq.unify-eq A B ok. pred unify-leq i:term, i:term. unify-leq A B :- coq.unify-leq A B ok. pred of i:term, o:term, o:term. of T Ty TR :- !, coq.elaborate-skeleton T Ty TR ok. namespace hack-8-17 { % This is a very partial fix for Coq 8.17 which "commits" holes to be in Type % too early. We propagate the Prop constraint by hand in some obvious cases. % Example (we add the inner ":Prop"): % Check (A -> _ -> _ : Prop) : Prop. % Starting with Coq 8.18 this is not necessary anymore pred propagate-Prop-constraint-inward i:term. propagate-Prop-constraint-inward {{ forall x : lp:Ty, lp:(F x) }} :- !, @pi-decl `x` Ty x\ propagate-Prop-constraint-inward (F x). propagate-Prop-constraint-inward {{ lp:A /\ lp:B }} :- !, propagate-Prop-constraint-inward A, propagate-Prop-constraint-inward B. propagate-Prop-constraint-inward {{ lp:A \/ lp:B }} :- !, propagate-Prop-constraint-inward A, propagate-Prop-constraint-inward B. propagate-Prop-constraint-inward {{ ~ lp:A }} :- !, propagate-Prop-constraint-inward A. propagate-Prop-constraint-inward (uvar as X) :- !, coq.typecheck X {{ Prop }} ok. propagate-Prop-constraint-inward (app[uvar|_] as X) :- !, coq.typecheck X {{ Prop }} ok. propagate-Prop-constraint-inward _. % no-op in all other cases } coq-elpi-2.1.0/elpi/coq-elpi-checker.elpi000066400000000000000000000016131460156013500201440ustar00rootroot00000000000000/* coq-elpi: Coq terms as the object language of elpi */ /* license: GNU Lesser General Public License Version 2.1 or later */ /* ------------------------------------------------------------------------- */ % redirect to Coq type checking messages :before "default-typechecking-error" error [] _ :- !. :before "default-typechecking-error" error [pr L M] tt :- !, coq.error L M. :before "default-typechecking-error" error Msgs tt :- !, coq.error "At least one of the following errors holds:" {error-concat Msgs}. pred error-concat i:list string, o:string. error-concat [] "\n". error-concat [pr L X] R :- error-concat XS Rest, term_to_string L LS, R is LS ^ " " ^ X. error-concat [pr L X|XS] R :- error-concat XS Rest, term_to_string L LS, R is LS ^ " " ^ X ^ "\n" ^ Rest. :before "default-typechecking-warning" warning L M :- !, coq.warning "elpi" "elpi.typecheck" L M. coq-elpi-2.1.0/elpi/coq-lib-common.elpi000066400000000000000000000153631460156013500176540ustar00rootroot00000000000000/* coq-elpi: Helpers common to synterp and interp */ /* license: GNU Lesser General Public License Version 2.1 or later */ /* ------------------------------------------------------------------------- */ shorten std.{fatal-error, fatal-error-w-data, debug-print}. :before "default-fatal-error" fatal-error M :- !, stop M. :before "default-fatal-error-w-data" fatal-error-w-data Msg Data :- !, term_to_string Data DataS, M is Msg ^ ": " ^ DataS, stop M. :before "default-debug-print" debug-print M Data :- !, coq.say M Data. % HACK: elpi's stop has no argument type stop string -> prop. :name "stop:begin" stop S :- coq.error S. % halt S %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% pred coq.parse-attributes i:list attribute, i:list attribute-signature, o:list prop. % Coq attribute parser, eg [#[attribute=value] Command] % % Usage: % main _ :- % attributes A, % fetch % coq.parse-attributes A Spec Opts, % parse/validate % Opts => (mycode, get-option "foo" V, mycode). % use % % where [Opts] is a list of clauses [get-option StringName Value], where value % can have any type and [Spec] is a list of [attribute-sigmature]. % Example of an attribute signature: % [ % att "this" bool, % att "that.thing" int, % att "algebraic" (oneof ["foo" `-> foo-thing, "bar" `-> barbar]), % ] % % Env variable COQ_ELPI_ATTRIBUTES can be used to pass attributes to all % commands. These attributes names are prefixed by 'elpi.' and are of type % string. % % Eg. % COQ_ELPI_ATTRIBUTES=test=yes,str="some-string" coqc foo.v % results in commands in foo.v to receive % [ attribute "elpi.test" (leaf "yes") , % attribute "elpi.str" (leaf "some-string") | ...] % which are automatically accepted and give rise to % get-option "elpi.test" "yes" % get-option "elpi.str" "some-string" kind attribute-signature type. type att string -> attribute-type -> attribute-signature. type att-ignore-unknown attribute-signature. type supported-attribute attribute-signature -> prop. supported-attribute (att "elpi.loc" loc). supported-attribute (att Name string) :- rex_match "^elpi\\." Name. kind attribute-type type. type int attribute-type. type string attribute-type. type bool attribute-type. type oneof list attribute-mapping -> attribute-type. type attmap attribute-type. % #[map(k1="v1",k2="v2")] type attlist attribute-type. % #[set(b1,b2,b3)] type attlabel attribute-type. % #[label( a(..), b, .. )] if #[label(a, b), a(..), ..] type loc attribute-type. kind attribute-mapping type. type (`->) string -> any -> attribute-mapping. pred coq.valid-str-attribute i:string, i:string, o:option any, o:diagnostic. coq.valid-str-attribute Name Value V Diag :- if (supported-attribute (att Name Type)) (coq.typecheck-attribute Name Type Value LPV Diag, V = some LPV) (if (supported-attribute att-ignore-unknown) (V = none, Diag = ok) (Diag = error {calc ( "Attribute " ^ Name ^ " is not supported")})). pred coq.valid-loc-attribute i:string, i:loc, o:diagnostic. coq.valid-loc-attribute Name Loc Diag :- if (supported-attribute (att Name loc)) (if (primitive? Loc "Loc.t") (Diag = ok) (Diag = error {calc ( "Attribute " ^ Name ^ " takes a loc, got " ^ {std.any->string Loc} ) } )) (if (supported-attribute att-ignore-unknown) (Diag = ok) (Diag = error {calc ( "Attribute " ^ Name ^ " is not supported")})). :index (_ 1 1) pred coq.typecheck-attribute i:string, o:attribute-type, i:string, o:any, o:diagnostic. coq.typecheck-attribute _ int Value V ok :- V is string_to_int Value, !. coq.typecheck-attribute N int Value _ (error Msg) :- Msg is "Attribute " ^ N ^ " takes an integer, got: " ^ Value. coq.typecheck-attribute _ string V V ok. coq.typecheck-attribute _ bool "true" tt ok. coq.typecheck-attribute _ bool "tt" tt ok. coq.typecheck-attribute _ bool "True" tt ok. coq.typecheck-attribute _ bool "on" tt ok. coq.typecheck-attribute _ bool "yes" tt ok. coq.typecheck-attribute _ bool "" tt ok. coq.typecheck-attribute _ bool "false" ff ok. coq.typecheck-attribute _ bool "False" ff ok. coq.typecheck-attribute _ bool "off" ff ok. coq.typecheck-attribute _ bool "ff" ff ok. coq.typecheck-attribute _ bool "no" ff ok. coq.typecheck-attribute N bool Value _ (error Msg) :- Msg is "Attribute " ^ N ^ " takes an boolean, got: " ^ Value. pred coq.is-one-of i:string, o:any, i:attribute-mapping. coq.is-one-of K V (K `-> V). coq.typecheck-attribute _ (oneof L) K V ok :- std.exists L (coq.is-one-of K V), !. coq.typecheck-attribute N (oneof L) K _ (error Msg) :- std.map L (x\r\ sigma tmp\ x = r `-> tmp) S, std.fold S "" (s\ a\ calc (a ^ " " ^ s)) OneOf, Msg is "Attribute " ^ N ^ " takes one of " ^ OneOf ^ ", got: " ^ K. pred append-string i:string, i:string, o:string. append-string "" A A :- !. append-string A B R :- R is A ^ "." ^ B. pred keep-only-label i:attribute, o:attribute. keep-only-label (attribute L _) (attribute L (leaf-str "")). coq.parse-attributes L S O :- std.map S (x\r\ r = supported-attribute x) CS, CS => parse-attributes.aux L "" O, !. parse-attributes.aux [] _ []. parse-attributes.aux [attribute S (node L)|AS] Prefix R :- append-string Prefix S PS, supported-attribute (att PS attlist), !, parse-attributes.aux AS Prefix R1, (pi x\ supported-attribute (att x bool) :- !) => parse-attributes.aux L "" Map, std.append R1 [get-option PS Map] R. parse-attributes.aux [attribute S (node L)|AS] Prefix R :- append-string Prefix S PS, supported-attribute (att PS attmap), !, parse-attributes.aux AS Prefix R1, (pi x\ supported-attribute (att x string) :- !) => parse-attributes.aux L "" Map, std.append R1 [get-option PS Map] R. parse-attributes.aux [attribute S (node L)|AS] Prefix R :- append-string Prefix S PS, supported-attribute (att PS attlabel), !, parse-attributes.aux AS Prefix R1, std.map L keep-only-label Ll, (pi x\ supported-attribute (att x bool) :- !) => parse-attributes.aux Ll "" Map, parse-attributes.aux L Prefix R2, std.append R1 [get-option PS Map|R2] R. parse-attributes.aux [attribute S (node L)|AS] Prefix R :- !, parse-attributes.aux AS Prefix R1, append-string Prefix S PS, parse-attributes.aux L PS R2, std.append R1 R2 R. parse-attributes.aux [attribute S (leaf-str V)|AS] Prefix CLS :- !, append-string Prefix S PS, coq.valid-str-attribute PS V V1 Diag, if (Diag = error Msg) (coq.error Msg) true, if (V1 = some Val) (CLS = [get-option PS Val|R]) (CLS = R), % ignored parse-attributes.aux AS Prefix R. parse-attributes.aux [attribute S (leaf-loc V)|AS] Prefix CLS :- !, append-string Prefix S PS, coq.valid-loc-attribute PS V Diag, if (Diag = error Msg) (coq.error Msg) true, CLS = [get-option PS V|R], parse-attributes.aux AS Prefix R. coq-elpi-2.1.0/elpi/coq-lib.elpi000066400000000000000000000667041460156013500163730ustar00rootroot00000000000000/* coq-elpi: Coq terms as the object language of elpi */ /* license: GNU Lesser General Public License Version 2.1 or later */ /* ------------------------------------------------------------------------- */ shorten std.{fatal-error, fatal-error-w-data, debug-print, unsafe-cast}. shorten std.{rev, map, append, appendR, map2, forall-ok, take, do-ok!, lift-ok}. shorten std.{ omap, take-last, intersperse, map-ok, string.concat }. accumulate elpi/coq-lib-common. :before "stop:begin" stop S :- get-option "ltac:fail" N, !, coq.ltac.fail N S. %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Helpers % % Pure LP code that works with the data types and API above. % Named clauses are natural extension points, eg one can extend % subst-prod to perform reduction in order to expose a "prod" node. %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Term surgery %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% pred coq.subst-prod i:list term, i:term, o:term. coq.subst-prod [] P P :- !. coq.subst-prod [X|XS] (prod _ _ F) P :- !, coq.subst-prod XS (F X) P. coq.subst-prod XS (let _ _ X F) P :- !, coq.subst-prod XS (F X) P. :name "subst-prod:fail" coq.subst-prod [_|_] T _ :- !, fatal-error-w-data "subst-prod: not a product" T. pred coq.subst-fun i:list term, i:term, o:term. coq.subst-fun [] T T :- !. coq.subst-fun [X|XS] (fun _ _ F) T :- !, coq.subst-fun XS (F X) T. coq.subst-fun XS (let _ _ X F) T :- !, coq.subst-fun XS (F X) T. :name "subst-fun:fail" coq.subst-fun [_|_] T _ :- !, fatal-error-w-data "subst-fun: not a lambda" T. pred coq.prod-R-fun o:term, o:term. coq.prod-R-fun (prod N T F) (fun N T R) :- !, pi x\ coq.prod-R-fun (F x) (R x). coq.prod-R-fun (let N T B F) (let N T B R) :- !, pi x\ coq.prod-R-fun (F x) (R x). coq.prod-R-fun X X. pred coq.prod->fun i:term, o:term. coq.prod->fun (prod N T F) (fun N T R) :- !, pi x\ coq.prod->fun (F x) (R x). coq.prod->fun (let N T B F) (let N T B R) :- !, pi x\ coq.prod->fun (F x) (R x). coq.prod->fun X X. pred coq.count-prods i:term, o:int. coq.count-prods (prod _ _ B) N :- !, (pi x\ coq.count-prods (B x) M), N is M + 1. coq.count-prods (let _ _ _ B) N :- !, (pi x\ coq.count-prods (B x) N). :name "count-prod:end" coq.count-prods _ 0 :- !. pred coq.mk-n-holes i:int, o:list A. coq.mk-n-holes 0 [] :- !. coq.mk-n-holes N [HOLE_|R] :- !, M is N - 1, coq.mk-n-holes M R. pred coq.safe-dest-app i:term, o:term, o:list term. coq.safe-dest-app (app [X|XS]) HD AllArgs :- !, coq.safe-dest-app X HD ARGS, append ARGS XS AllArgs. coq.safe-dest-app X X []. pred coq.mk-app i:term, i:list term, o:term. coq.mk-app HD [] HD :- !. coq.mk-app (app L) Args (app LArgs) :- !, append L Args LArgs. coq.mk-app (fun _ _ F) [A|Args] R :- !, coq.mk-app (F A) Args R. coq.mk-app (let _ _ A F) Args R :- !, coq.mk-app (F A) Args R. coq.mk-app HD Args (app [HD|Args]). pred coq.mk-app-uvar i:term, i:list term, o:term. coq.mk-app-uvar HD [] HD :- !. coq.mk-app-uvar (uvar as K) [A|Args] R :- !, unsafe-cast K K', coq.mk-app-uvar (K' A) Args R. % coq.mk-eta n Ty T: performs up to n (when >= 0) eta expasion of T % according to its type Ty. If n < 0 it makes as many step as % products in Ty. There be dragons if T has not type Ty. pred coq.mk-eta i:int, i:term, i:term, o:term. coq.mk-eta 0 _ B B :- !. coq.mk-eta N (prod Name Ty P) (fun _ _ F) (fun Name Ty F1) :- !, N1 is N - 1, pi x \ coq.mk-eta N1 (P x) (F x) (F1 x). coq.mk-eta N (prod Name Ty P) B (fun Name Ty B1) :- !, N1 is N - 1, pi x \ coq.mk-eta N1 (P x) {coq.mk-app B [x]} (B1 x). :name "mk-eta:end" coq.mk-eta _ _ B B :- !. pred coq.saturate i:term, i:term, o:term. coq.saturate Ty T O :- whd Ty [] (prod N Src Tgt) [], !, coq.mk-app T [Hole_] R, @pi-decl N Src x\ coq.saturate (Tgt x) R O. coq.saturate _ X X. % [copy A B] can be used to perform a replacement, eg % (copy (const "foo") (const "bar") :- !) => copy A B % traverses A replacing foo with bar. pred copy i:term, o:term. :name "copy:start" copy X Y :- name X, !, X = Y, !. % avoid loading "copy x x" at binders copy (global _ as C) C :- !. copy (pglobal _ _ as C) C :- !. copy (sort _ as C) C :- !. copy (fun N T F) (fun N T1 F1) :- !, copy T T1, pi x\ copy (F x) (F1 x). copy (let N T B F) (let N T1 B1 F1) :- !, copy T T1, copy B B1, pi x\ copy (F x) (F1 x). copy (prod N T F) (prod N T1 F1) :- !, copy T T1, (pi x\ copy (F x) (F1 x)). copy (app L) (app L1) :- !, map L copy L1. copy (fix N Rno Ty F) (fix N Rno Ty1 F1) :- !, copy Ty Ty1, pi x\ copy (F x) (F1 x). copy (match T Rty B) (match T1 Rty1 B1) :- !, copy T T1, copy Rty Rty1, map B copy B1. copy (primitive _ as C) C :- !. copy (uvar M L as X) W :- var X, !, map L copy L1, coq.mk-app-uvar M L1 W. % when used in CHR rules copy (uvar X L) (uvar X L1) :- map L copy L1. pred copy-ctx-item i:prop, o:prop. copy-ctx-item (decl X N T) (decl X1 N T1) :- copy X X1, copy T T1. copy-ctx-item (def X N T B) (def X1 N T1 B1) :- copy X X1, copy T T1, copy B B1. pred copy-arity i:arity, o:arity. copy-arity (parameter ID IMP T R) (parameter ID IMP T1 R1) :- copy T T1, pi x\ copy-arity (R x) (R1 x). copy-arity (arity T) (arity T1) :- copy T T1. pred copy-indt-decl i:indt-decl, o:indt-decl. copy-indt-decl (parameter ID I Ty D) (parameter ID I Ty1 D1) :- copy Ty Ty1, @pi-parameter ID Ty1 x\ copy-indt-decl (D x) (D1 x). copy-indt-decl (inductive ID CO A D) (inductive ID CO A1 D1) :- copy-arity A A1, @pi-inductive ID A1 i\ std.map (D i) copy-constructor (D1 i). copy-indt-decl (record ID T IDK F) (record ID T1 IDK F1) :- copy T T1, copy-fields F F1. pred copy-fields i:record-decl, o:record-decl. copy-fields end-record end-record. copy-fields (field Att ID T F) (field Att ID T1 F1) :- copy T T1, @pi-parameter ID T1 x\ copy-fields (F x) (F1 x). pred copy-constructor i:indc-decl, o:indc-decl. copy-constructor (constructor ID A) (constructor ID A1) :- copy-arity A A1. pred fold-map i:term, i:A, o:term, o:A. :name "fold-map:start" fold-map X A Y A :- name X, !, X = Y, !. % avoid loading "fold-map x A x A" at binders fold-map (global _ as C) A C A :- !. fold-map (pglobal _ _ as C) A C A :- !. fold-map (sort _ as C) A C A :- !. fold-map (fun N T F) A (fun N T1 F1) A2 :- !, fold-map T A T1 A1, pi x\ fold-map (F x) A1 (F1 x) A2. fold-map (let N T B F) A (let N T1 B1 F1) A3 :- !, fold-map T A T1 A1, fold-map B A1 B1 A2, pi x\ fold-map (F x) A2 (F1 x) A3. fold-map (prod N T F) A (prod N T1 F1) A2 :- !, fold-map T A T1 A1, (pi x\ fold-map (F x) A1 (F1 x) A2). fold-map (app L) A (app L1) A1 :- !, std.fold-map L A fold-map L1 A1. fold-map (fix N Rno Ty F) A (fix N Rno Ty1 F1) A2 :- !, fold-map Ty A Ty1 A1, pi x\ fold-map (F x) A1 (F1 x) A2. fold-map (match T Rty B) A (match T1 Rty1 B1) A3 :- !, fold-map T A T1 A1, fold-map Rty A1 Rty1 A2, std.fold-map B A2 fold-map B1 A3. fold-map (primitive _ as C) A C A :- !. fold-map (uvar M L as X) A W A1 :- var X, !, std.fold-map L A fold-map L1 A1, coq.mk-app-uvar M L1 W. % when used in CHR rules fold-map (uvar X L) A (uvar X L1) A1 :- std.fold-map L A fold-map L1 A1. pred fold-map-ctx-item i:prop, i:A, o:prop,o:A. fold-map-ctx-item (decl X N T) A (decl X1 N T1) A2 :- fold-map X A X1 A1, fold-map T A1 T1 A2. fold-map-ctx-item (def X N T B) A (def X1 N T1 B1) A3 :- fold-map X A X1 A1, fold-map T A1 T1 A2, fold-map B A2 B1 A3. pred fold-map-arity i:arity, i:A, o:arity, o:A. fold-map-arity (parameter ID IMP T R) A (parameter ID IMP T1 R1) A2 :- fold-map T A T1 A1, pi x\ fold-map-arity (R x) A1 (R1 x) A2. fold-map-arity (arity T) A (arity T1) A1 :- fold-map T A T1 A1. % Bridges the gap between the data types used to read/write inductives. % The arguments are the same of coq.env.indt plus an an extra one being % the output (of type indt-decl). pred coq.upoly-decl->attribute i:any, o:prop. coq.upoly-decl->attribute (upoly-decl A B C D) (@udecl! A B C D). coq.upoly-decl->attribute (upoly-decl-cumul A B C D) (@udecl-cumul! A B C D). pred coq.upoly-decl.complete-constraints i:upoly-decl, o:upoly-decl. coq.upoly-decl.complete-constraints (upoly-decl VS LV CS LC) (upoly-decl VS LV CS1 LC) :- std.do! [ std.map VS coq.univ.variable.constraints ExtraL, std.flatten ExtraL Extra, std.filter Extra (c\not(std.mem CS c)) New, std.append CS New CS1, ]. pred coq.upoly-decl-cumul.complete-constraints i:upoly-decl-cumul, o:upoly-decl-cumul. coq.upoly-decl-cumul.complete-constraints (upoly-decl-cumul VS LV CS LC) (upoly-decl-cumul VS LV CS1 LC) :- std.do! [ std.map VS coq.upoly-decl-cumul.complete-constraints.aux ExtraL, std.flatten ExtraL Extra, std.filter Extra (c\not(std.mem CS c)) New, std.append CS New CS1, ]. coq.upoly-decl-cumul.complete-constraints.aux (auto V) CS :- coq.univ.variable.constraints V CS. coq.upoly-decl-cumul.complete-constraints.aux (covariant V) CS :- coq.univ.variable.constraints V CS. coq.upoly-decl-cumul.complete-constraints.aux (invariant V) CS :- coq.univ.variable.constraints V CS. coq.upoly-decl-cumul.complete-constraints.aux (irrelevant V) CS :- coq.univ.variable.constraints V CS. pred coq.build-indt-decl i:(pair inductive id), i:bool, i:int, i:int, i:term, i:list (pair constructor id), i:list term, o:indt-decl. coq.build-indt-decl GR IsInd Pno UPno Arity Kns Ktys Decl :- coq.build-indt-decl-aux GR IsInd Pno UPno Arity Kns Ktys [] Decl. pred coq.build-indt-decl-aux i:pair inductive id, i:bool, i:int, i:int, i:term, i:list (pair constructor id), i:list term, i:list term, o:indt-decl. coq.build-indt-decl-aux (pr GR I) IsInd NUPno 0 Ty Kns KtysNu Params (inductive I IsInd Arity Ks) :- !, coq.term->arity Ty NUPno Arity, std.map KtysNu (k\coq.term->arity k NUPno) Ktys, rev Params ParamsR, (pi i\ Sub i = [ % we factor uniform parameters (pi x l\ copy (app[global (indt GR)|l]) (app[i|x]):- !, appendR ParamsR x l), (pi x l ui\ copy (app[pglobal (indt GR) ui|l]) (app[i|x]):- !, appendR ParamsR x l), (copy (global (indt GR)) i :- !), (pi ui\ copy (pglobal (indt GR) ui) i :- !) ]), pi i\ map2 Kns Ktys (gr_name\ ty\ res\ sigma tmp name\ Sub i => copy-arity ty tmp, gr_name = pr _ name, res = constructor name tmp) (Ks i). coq.build-indt-decl-aux GR IsInd Pno UPno (prod N S T) Kns Ktys Params (parameter NS explicit S Res) :- Pno > 0, UPno > 0, !, coq.name->id N NS, Pno1 is Pno - 1, UPno1 is UPno - 1, pi p\ map Ktys (coq.subst-prod [p]) (Ktys1 p), coq.build-indt-decl-aux GR IsInd Pno1 UPno1 (T p) Kns (Ktys1 p) [p|Params] (Res p). :name "coq.build-indt-decl-aux:fail" coq.build-indt-decl-aux _ _ _ _ _ _ _ _ _ :- !, fatal-error "coq.build-indt-decl-aux: invalid declaration". pred coq.rename-arity i:(id -> id -> prop), i:arity, o:arity. coq.rename-arity RP (parameter ID I TY In) (parameter ID1 I TY Out) :- RP ID ID1, @pi-parameter ID TY p\ coq.rename-arity RP (In p) (Out p). coq.rename-arity _ (arity T) (arity T). % [coq.rename-indt-decl RenameParam RenameIndType RenameIndConstr D D1] % can be used to rename all [id] part of an inductive type declaration pred coq.rename-indt-decl i:(id -> id -> prop), i:(id -> id -> prop), i:(id -> id -> prop), i:indt-decl, o:indt-decl. coq.rename-indt-decl RP RI RK (parameter ID I TY In) (parameter ID1 I TY Out) :- RP ID ID1, @pi-parameter ID TY p\ coq.rename-indt-decl RP RI RK (In p) (Out p). coq.rename-indt-decl RP RI RK (inductive ID Ind A In) (inductive ID1 Ind A1 Out) :- RI ID ID1, coq.rename-arity RP A A1, coq.id->name ID Name, coq.arity->term A TY, @pi-decl Name TY i\ std.map (In i) (coq.rename-indt-decl.aux RP RI RK) (Out i). coq.rename-indt-decl _ RI RK (record ID A KID F) (record ID1 A KID1 F) :- RI ID ID1, RK KID KID1. coq.rename-indt-decl.aux RP _ RK (constructor ID A) (constructor ID1 A1) :- RK ID ID1, coq.rename-arity RP A A1. pred coq.ensure-fresh-global-id i:string, o:string. coq.ensure-fresh-global-id Exp S :- Name is Exp, coq.env.fresh-global-id Name S, if (Name = S) true (coq.warning "elpi" "elpi.renamed" "Global name" Name "is taken, using" S "instead"). % Lifts coq.typecheck to inductive declarations pred coq.typecheck-indt-decl.heuristic-var-type i:term, o:diagnostic. coq.typecheck-indt-decl.heuristic-var-type (uvar _ _ as X) D :- !, coq.univ.new U, coq.unify-eq X (sort (typ U)) D. coq.typecheck-indt-decl.heuristic-var-type _ ok. pred coq.typecheck-indt-arity i:arity, o:term, o:int, o:diagnostic. coq.typecheck-indt-arity (parameter ID _ T D) (prod N T F) NU1 Diag :- do-ok! Diag [ coq.typecheck-ty T _, (d\ @pi-parameter ID T x\ coq.typecheck-indt-arity (D x) (F x) NU d), lift-ok (NU1 is NU + 1) "", lift-ok (coq.id->name ID N) "", ]. coq.typecheck-indt-arity (arity T) T 0 Diag :- do-ok! Diag [ coq.typecheck-ty T _, coq.typecheck-indt-decl.heuristic-var-type T, ]. pred coq.typecheck-indt-decl i:indt-decl, o:diagnostic. coq.typecheck-indt-decl (parameter ID _ T Decl) Diag :- do-ok! Diag [ coq.typecheck-ty T _, (d\ @pi-parameter ID T x\ coq.typecheck-indt-decl (Decl x) d), ]. coq.typecheck-indt-decl (inductive ID _ Arity KDecl) Diag :- do-ok! Diag [ coq.typecheck-indt-arity Arity A NUPNO, d\ @pi-parameter ID A i\ forall-ok (KDecl i) (coq.typecheck-indt-decl-c i A NUPNO) d ]. coq.typecheck-indt-decl (record ID A _IDK FDecl) Diag :- do-ok! Diag [ coq.typecheck-ty A _, d\ @pi-parameter ID A i\ do-ok! d [ lift-ok (coq.typecheck-indt-decl-field i FDecl (K i)) "", coq.typecheck-indt-decl-c i A 0 (constructor "fields" (arity (K i))) ] ]. pred coq.typecheck-indc-arity i:arity, i:int, o:term, o:sort, o:diagnostic. coq.typecheck-indc-arity A 0 T S Diag :- !, coq.arity->term A T, coq.typecheck-ty T S Diag. coq.typecheck-indc-arity (parameter ID _ T D) NUPNO (prod N T F) S Diag :- do-ok! Diag [ coq.typecheck-ty T _, lift-ok (NUPNO1 is NUPNO - 1) "", (d\ @pi-parameter ID T x\ coq.typecheck-indc-arity (D x) NUPNO1 (F x) S d), lift-ok (coq.id->name ID N) "", ]. pred coq.typecheck-indt-decl-c i:term, i:term, i:int, i:indc-decl, o:diagnostic. coq.typecheck-indt-decl-c I S NUPNO (constructor _ID Arity) Diag :- do-ok! Diag [ coq.typecheck-indc-arity Arity NUPNO T KS, coq.typecheck-indt-decl-c.unify-arrow-tgt I 0 S T, lift-ok (coq.arity->sort S IS) "", lift-ok (coq.sort.leq KS IS) "constructor universe too large" ]. pred coq.typecheck-indt-decl-c.unify-arrow-tgt i:term, i:int, i:term, i:term, o:diagnostic. coq.typecheck-indt-decl-c.unify-arrow-tgt I P A (prod N S T) D :- @pi-decl N S x\ coq.typecheck-indt-decl-c.unify-arrow-tgt I P A (T x) D. coq.typecheck-indt-decl-c.unify-arrow-tgt I P A (let N S B T) D :- @pi-def N S B x\ coq.typecheck-indt-decl-c.unify-arrow-tgt I P A (T x) D. coq.typecheck-indt-decl-c.unify-arrow-tgt I P A Concl D :- coq.count-prods A N, coq.mk-n-holes {calc (N + P)} Args, coq.mk-app I Args IArgs, coq.unify-eq Concl IArgs D. pred coq.typecheck-indt-decl-field i:term, i:record-decl, o:term. coq.typecheck-indt-decl-field I end-record I. coq.typecheck-indt-decl-field I (field _ ID T F) (prod N T F1) :- coq.id->name ID N, @pi-decl N T a\ coq.typecheck-indt-decl-field I (F a) (F1 a). % Lifts coq.elaborate-skeleton to inductive declarations pred coq.elaborate-indt-decl-skeleton i:indt-decl, o:indt-decl, o:diagnostic. coq.elaborate-indt-decl-skeleton (parameter ID Imp T Decl) (parameter ID Imp T1 Decl1) Diag :- do-ok! Diag [ coq.elaborate-ty-skeleton T _ T1, (d\ @pi-parameter ID T1 x\ coq.elaborate-indt-decl-skeleton (Decl x) (Decl1 x) d), ]. coq.elaborate-indt-decl-skeleton (inductive ID I Arity KDecl) (inductive ID I Arity1 KDecl1) Diag :- do-ok! Diag [ coq.elaborate-arity-skeleton Arity _ Arity1, lift-ok (coq.arity->nparams Arity1 NUPNO) "", d\ coq.arity->term Arity1 A1, do-ok! d [ coq.typecheck-indt-decl.heuristic-var-type A1, d\ @pi-parameter ID A1 i\ map-ok (KDecl i) (coq.elaborate-indt-decl-skeleton-c i Arity1 NUPNO) (KDecl1 i) d ] ]. coq.elaborate-indt-decl-skeleton (record ID A IDK FDecl) (record ID A1 IDK FDecl1) Diag :- do-ok! Diag [ coq.elaborate-ty-skeleton A _ A1, lift-ok (A1 = sort U) "record type is not a sort", d\ @pi-parameter ID A1 i\ coq.elaborate-indt-decl-skeleton-fields U FDecl FDecl1 d ]. pred coq.elaborate-indt-decl-skeleton-fields i:sort, i:record-decl, o:record-decl, o:diagnostic. coq.elaborate-indt-decl-skeleton-fields _ end-record end-record ok. coq.elaborate-indt-decl-skeleton-fields U (field Att ID A Fields) (field Att ID A1 Fields1) Diag :- do-ok! Diag [ coq.elaborate-ty-skeleton A UA A1, lift-ok (coq.sort.leq UA U) "constructor universe too large", d\ @pi-parameter ID A1 p\ coq.elaborate-indt-decl-skeleton-fields U (Fields p) (Fields1 p) d ]. pred coq.elaborate-indt-decl-skeleton-c i:term, i:arity, i:int, i:indc-decl, o:indc-decl, o:diagnostic. coq.elaborate-indt-decl-skeleton-c I SA NUPNO (constructor ID Arity) (constructor ID Arity1) Diag :- do-ok! Diag [ coq.elaborate-arity-skeleton-nuparams Arity NUPNO KS Arity1, coq.typecheck-indt-decl-c.unify-arity I 0 SA Arity1, lift-ok (coq.arity->sort {coq.arity->term SA} IS) "", lift-ok (coq.sort.leq KS IS) "constructor universe too large" ]. pred coq.typecheck-indt-decl-c.unify-arity i:term, i:int, i:arity, i:arity, o:diagnostic. coq.typecheck-indt-decl-c.unify-arity I PNO (parameter _ _ T1 A) (parameter ID _ T C) D :- do-ok! D [ coq.unify-eq T1 T, lift-ok (PNO1 is PNO + 1) "", d\ @pi-parameter ID T p\ coq.typecheck-indt-decl-c.unify-arity I PNO1 (A p) (C p) d ]. coq.typecheck-indt-decl-c.unify-arity I PNO (arity A) (parameter ID _ T C) D :- @pi-parameter ID T p\ coq.typecheck-indt-decl-c.unify-arity I PNO (arity A) (C p) D. coq.typecheck-indt-decl-c.unify-arity I PNO (arity A) (arity C) D :- coq.typecheck-indt-decl-c.unify-arrow-tgt I PNO A C D. % Lifts coq.elaborate-skeleton to arity pred coq.elaborate-arity-skeleton i:arity, o:sort, o:arity, o:diagnostic. coq.elaborate-arity-skeleton (parameter ID Imp T A) U3 (parameter ID Imp T1 A1) Diag :- do-ok! Diag [ coq.elaborate-ty-skeleton T U1 T1, (d\ @pi-parameter ID T1 i\ coq.elaborate-arity-skeleton (A i) U2 (A1 i) d), lift-ok (coq.sort.pts-triple U1 U2 U3) "coq.elaborate-arity-skeleton: should not happen", ]. coq.elaborate-arity-skeleton (arity A) U (arity A1) Diag :- coq.elaborate-ty-skeleton A U A1 Diag. pred coq.elaborate-arity-skeleton-nuparams i:arity, i:int, o:sort, o:arity, o:diagnostic. coq.elaborate-arity-skeleton-nuparams (parameter ID Imp T A) 0 U3 (parameter ID Imp T1 A1) Diag :- !, do-ok! Diag [ coq.elaborate-ty-skeleton T U1 T1, (d\ @pi-parameter ID T1 i\ coq.elaborate-arity-skeleton-nuparams (A i) 0 U2 (A1 i) d), lift-ok (coq.sort.pts-triple U1 U2 U3) "coq.elaborate-arity-skeleton-nuparams: should not happen", ]. coq.elaborate-arity-skeleton-nuparams (parameter ID Imp T A) N U (parameter ID Imp T1 A1) Diag :- do-ok! Diag [ coq.elaborate-ty-skeleton T _ T1, lift-ok (M is N - 1) "", (d\ @pi-parameter ID T1 i\ coq.elaborate-arity-skeleton-nuparams (A i) M U (A1 i) d), ]. coq.elaborate-arity-skeleton-nuparams (arity A) _ U (arity A1) Diag :- coq.elaborate-ty-skeleton A U A1 Diag. % Converts an arity to a term pred coq.arity->term i:arity, o:term. coq.arity->term (parameter ID _ Ty Rest) (prod Name Ty R) :- coq.id->name ID Name, @pi-decl Name Ty x\ coq.arity->term (Rest x) (R x). coq.arity->term (arity A) A. pred coq.term->arity i:term, i:int, o:arity. coq.term->arity T 0 (arity T). coq.term->arity (prod Name S T) N (parameter ID explicit S R) :- M is N - 1, coq.name->id Name ID, @pi-decl Name S x\ coq.term->arity (T x) M (R x). % extracts the sort at the end of an arity pred coq.arity->sort i:term, o:sort. coq.arity->sort (prod N S X) Y :- !, @pi-decl N S x\ coq.arity->sort (X x) Y. coq.arity->sort (sort X) X :- !. :name "arity->sort:fail" coq.arity->sort T _ :- fatal-error-w-data "arity->sort: not a sort or prod" T. % Counts how many parameters are there pred coq.arity->nparams i:arity, o:int. coq.arity->nparams (parameter _ _ _ In) O :- pi x\ coq.arity->nparams (In x) O1, O is O1 + 1. coq.arity->nparams (arity _) 0. % Prints an arity pred coq.arity->pp o:arity, o:coq.pp. coq.arity->pp (parameter ID Imp T Arity) (coq.pp.glue Res) :- Res = [coq.pp.box (coq.pp.hv 2) [coq.pp.str A, coq.pp.str ID, coq.pp.str " :", coq.pp.spc,TPP,coq.pp.str B], coq.pp.spc, Rest], if2 (Imp = explicit) (A = "(", B = ")") (Imp = maximal) (A = "{", B = "}") (A = "[", B = "]"), coq.term->pp T TPP, @pi-parameter ID T x\ coq.arity->pp (Arity x) Rest. coq.arity->pp (arity T) (coq.pp.glue [coq.pp.str" : ",TPP]) :- coq.term->pp T TPP. % Get impargs setting from an arity pred coq.arity->implicits i:arity, o:list implicit_kind. coq.arity->implicits (parameter Id I Ty F) [I|Is] :- @pi-parameter Id Ty x\ coq.arity->implicits (F x) Is. coq.arity->implicits (arity _) []. % Get impargs setting from an indt-decl pred coq.indt-decl->implicits i:indt-decl, o:list implicit_kind, o:list (list implicit_kind). coq.indt-decl->implicits (parameter Id I Ty F) [I|Is] R :- @pi-parameter Id Ty x\ coq.indt-decl->implicits (F x) Is R1, std.map R1 (l\r\r = [I|l]) R. coq.indt-decl->implicits (record _ _ _ _) [] [[]]. coq.indt-decl->implicits (inductive Id _ A Ks) Is R :- coq.arity->implicits A Is, @pi-inductive Id A x\ std.map (Ks x) (c\i\sigma a\c = constructor _ a,coq.arity->implicits a i) R. % Check if some implicits are set pred coq.any-implicit? i:list implicit_kind. coq.any-implicit? L :- std.exists L (x\not(x = explicit)). % extract gref from terms that happen to have one pred coq.term->gref i:term, o:gref. coq.term->gref (global GR) GR :- !. coq.term->gref (pglobal GR _) GR :- !. coq.term->gref (app [Hd|_]) GR :- !, coq.term->gref Hd GR. coq.term->gref (let _ _ T x\x) GR :- !, coq.term->gref T GR. :name "term->gref:fail" coq.term->gref Term _ :- fatal-error-w-data "term->gref: input has no global reference" Term. pred coq.fresh-type o:term. coq.fresh-type (sort (typ U)) :- coq.univ.new U. pred coq.sort? i:term. coq.sort? (sort _). coq.sort? T :- whd1 T T1, coq.sort? T1. % Map the term under a spine of fun nodes pred coq.map-under-fun i:term, % InputTermUnderLams LamBoundVars TheirTypes Result i:(term -> list term -> list term -> term -> prop), o:term. coq.map-under-fun T F R :- map-under-fun.aux T [] [] F R. map-under-fun.aux (fun N T B) AccT AccTy F (fun N T R) :- !, @pi-decl N T x\ map-under-fun.aux (B x) [x|AccT] [T|AccTy] F (R x). map-under-fun.aux (let N T X B) AccT AccTy F (let N T X R) :- !, @pi-def N T X x\ map-under-fun.aux (B x) AccT AccTy F (R x). map-under-fun.aux End AccT AccTy F R :- F End {rev AccT} {rev AccTy} R. pred coq.iter-under-fun i:term, % InputTermUnderLams LamBoundVars TheirTypes i:(term -> list term -> list term -> prop). coq.iter-under-fun T F :- iter-under-fun.aux T [] [] F. iter-under-fun.aux (fun N T B) AccT AccTy F :- !, @pi-decl N T x\ iter-under-fun.aux (B x) [x|AccT] [T|AccTy] F. iter-under-fun.aux (let _ _ X B) AccT AccTy F :- !, iter-under-fun.aux (B X) AccT AccTy F. iter-under-fun.aux End AccT AccTy F :- F End {rev AccT} {rev AccTy}. % Build a match given the term and function to build the return type and the % branches pred coq.build-match i:term, % T, the term being matched i:term, % the type of T, expected to be an inductive, eventually applied % MkRty: IndSort LamBoundVars TheirTypes Result i:(term -> list term -> list term -> term -> prop), % MkBranch: Constructor ConstructorTyUnderLams LamBoundVars TheirTypes Result i:(term -> term -> list term -> list term -> term -> prop), o:term. % match T (.. MkRty) [ .. MkBranch K1, .. MkBranch K2, ..] coq.build-match T Tty RtyF BranchF (match T Rty Bs) :- whd Tty [] HD Args, if2 (HD = global (indt GR)) true (HD = pglobal (indt GR) I) true fail, @uinstance! I => coq.env.indt GR _ Lno _ Arity Kn Kt, take Lno Args LArgs, @uinstance! I => coq.mk-app {coq.env.global (indt GR)} LArgs IndtLArgs, % Rty coq.subst-prod LArgs Arity ArityArgs, coq.bind-ind-arity-no-let IndtLArgs ArityArgs RtyF Rty, % Bs map Kt (coq.subst-prod LArgs) KtArgs, map KtArgs hd-beta-zeta-reduce KtArgsNorm, map KtArgsNorm coq.prod->fun KtArgsLam, map Kn (k\r\ sigma K\ coq.env.global (indc k) K, coq.mk-app K LArgs r) KnArgs, map2 KnArgs KtArgsLam (k\t\coq.map-under-fun t (BranchF k)) Bs. % XXX the list of arguments are often needed in reverse order pred coq.bind-ind-arity % calls K under (fun Arity (x : Ity Arity) =>..) i:term, % the inductive type i:term, % the arity i:(term -> list term -> list term -> term -> prop), % Sort Vars Tys Out o:term. % bind-ind-arity.aux (prod N T B) (fun N T F) AccT AccTy IT K :- !, @pi-decl N T x\ bind-ind-arity.aux (B x) (F x) [x|AccT] [T|AccTy] IT K. bind-ind-arity.aux (let N T X B) (let N T X F) AccT AccTy IT K :- !, @pi-def N T X x\ bind-ind-arity.aux (B x) (F x) AccT AccTy IT K. bind-ind-arity.aux (sort _ as Sort) (fun `i` ITy F) AccT AccTy IT K :- rev AccT Vars, coq.mk-app IT Vars ITy, @pi-decl `i` ITy x\ K Sort {append Vars [x]} {rev [ITy|AccTy]} (F x). coq.bind-ind-arity IT Arity F R :- bind-ind-arity.aux Arity R [] [] IT F. % As above but let-ins are reduced pred coq.bind-ind-arity-no-let i:term, i:term, i:(term -> list term -> list term -> term -> prop), o:term. coq.bind-ind-arity-no-let IT Arity F R :- (pi N T X B F AccT AccTy IT K\ bind-ind-arity.aux (let N T X B) F AccT AccTy IT K :- !, bind-ind-arity.aux (B X) F AccT AccTy IT K) => bind-ind-arity.aux Arity R [] [] IT F. pred coq.bind-ind-parameters i:inductive, i:(term -> list term -> list term -> term -> prop), o:term. coq.bind-ind-parameters I K O :- coq.env.indt I _ _ N A _ _, coq.bind-ind-parameters.aux N A [] [] K O. coq.bind-ind-parameters.aux 0 Ty Vars Tys K O :- !, K Ty {std.rev Vars} {std.rev Tys} O. coq.bind-ind-parameters.aux I (prod N T F) Vs Ts K (fun N T G) :- I > 0, !, J is I - 1, @pi-decl N T x\ coq.bind-ind-parameters.aux J (F x) [x|Vs] [T|Ts] K (G x). coq.bind-ind-parameters.aux I (let N T B F) Vs Ts K (fun N T G) :- I > 0, !, J is I - 1, @pi-def N T B x\ coq.bind-ind-parameters.aux J (F x) [x|Vs] [T|Ts] K (G x). coq.bind-ind-parameters.aux I T Vs Ts K O :- I > 0, whd1 T T', !, coq.bind-ind-parameters.aux I T' Vs Ts K O. % coq.with-TC Class Instance->Clause Code: runs Code under a context augmented with % all instances for Class transformed by Instance->Clause. pred coq.with-TC i:term, i:(tc-instance -> prop -> prop), i:prop. coq.with-TC Class Instance->Clause Code :- coq.TC.db-for {coq.term->gref Class} Instances, map Instances Instance->Clause Hyps, !, Hyps => Code. %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% pred coq.replay-synterp-action i:synterp-action. coq.replay-synterp-action (begin-module ID) :- coq.env.begin-module ID _. coq.replay-synterp-action (end-module MP) :- coq.env.end-module MP. coq.replay-synterp-action (begin-module-type ID) :- coq.env.begin-module-type ID. coq.replay-synterp-action (end-module-type MTP) :- coq.env.end-module-type MTP. coq.replay-synterp-action (apply-module-functor ID) :- coq.env.apply-module-functor ID _ _ _ _ _. coq.replay-synterp-action (apply-module-type-functor ID) :- coq.env.apply-module-type-functor ID _ _ _ _. coq.replay-synterp-action (include-module MP) :- coq.env.include-module MP _. coq.replay-synterp-action (include-module-type MP) :- coq.env.include-module-type MP _. coq.replay-synterp-action (import-module MP) :- coq.env.import-module MP. coq.replay-synterp-action (export-module MP) :- coq.env.export-module MP. coq.replay-synterp-action (begin-section ID) :- coq.env.begin-section ID. coq.replay-synterp-action (end-section) :- coq.env.end-section. pred coq.replay-next-synterp-actions. coq.replay-next-synterp-actions :- coq.next-synterp-action Action, !, coq.replay-synterp-action Action, !, coq.replay-next-synterp-actions. coq.replay-next-synterp-actions. coq-elpi-2.1.0/elpi/elpi-command-template-synterp.elpi000066400000000000000000000004201460156013500227040ustar00rootroot00000000000000/* Loaded when Elpi Command has a code accumulated at #[synterp] time */ /* license: GNU Lesser General Public License Version 2.1 or later */ /* ------------------------------------------------------------------------- */ accumulate elpi/coq-lib-common.coq-elpi-2.1.0/elpi/elpi-command-template.elpi000066400000000000000000000006421460156013500212100ustar00rootroot00000000000000/* Loaded when Elpi Command is used */ /* license: GNU Lesser General Public License Version 2.1 or later */ /* ------------------------------------------------------------------------- */ accumulate elpi/coq-lib. % basic term manipulation routines accumulate elpi/elpi-reduction. % whd, hd-beta, ... accumulate elpi/elpi-ltac. % refine, or, thenl, ... coq-elpi-2.1.0/elpi/elpi-ltac.elpi000066400000000000000000000114201460156013500167000ustar00rootroot00000000000000/* elpi-ltac: building blocks for tactics */ /* license: GNU Lesser General Public License Version 2.1 or later */ /* ------------------------------------------------------------------------- */ typeabbrev tactic (sealed-goal -> (list sealed-goal -> prop)). typeabbrev open-tactic (goal -> (list sealed-goal -> prop)). % The one tactic ------------------------------------------------------------ pred refine i:term, i:goal, o:list sealed-goal. refine T G GS :- refine.elaborate T G GS. pred refine.elaborate i:term, i:goal, o:list sealed-goal. refine.elaborate T (goal _ RawEv Ty Ev _) GS :- rm-evar RawEv Ev, @keepunivs! => coq.elaborate-skeleton T Ty TR ok, coq.ltac.collect-goals TR GS _, RawEv = T, Ev = TR. pred refine.typecheck i:term, i:goal, o:list sealed-goal. refine.typecheck T (goal _ RawEv Ty Ev _) GS :- rm-evar RawEv Ev, coq.typecheck T Ty ok, coq.ltac.collect-goals T GS _, RawEv = T, Ev = T. pred refine.no_check i:term, i:goal, o:list sealed-goal. refine.no_check T (goal _ RawEv _ Ev _) GS :- rm-evar RawEv Ev, coq.ltac.collect-goals T GS _, RawEv = T, Ev = T. % calling other tactics, with arguments --------------------------------------- pred coq.ltac i:string, i:sealed-goal, o:list sealed-goal. coq.ltac Tac G GS :- coq.ltac.open (coq.ltac.call-ltac1 Tac) G GS. namespace coq.ltac { pred call i:string, i:list argument, i:goal, o:list sealed-goal. call Tac Args G GS :- set-goal-arguments Args G (seal G) (seal G1), coq.ltac.call-ltac1 Tac G1 GS. pred set-goal-arguments i:list argument, i:goal, i:sealed-goal, o:sealed-goal. set-goal-arguments A G (nabla SG) (nabla R) :- pi x\ set-goal-arguments A G (SG x) (R x). set-goal-arguments A (goal Ctx1 _ _ _ _) (seal (goal Ctx2 REv2 Ty2 Ev2 _)) (seal (goal Ctx2 REv2 Ty2 Ev2 I)) :- same_term Ctx1 Ctx2, !, A = I. set-goal-arguments A (goal Ctx1 _ _ _ _) (seal (goal Ctx2 REv2 Ty2 Ev2 _)) (seal (goal Ctx2 REv2 Ty2 Ev2 I)) :- std.map A (private.move-goal-argument Ctx1 Ctx2) I. % Tacticals ---------------------------------------------------------------- pred try i:tactic, i:sealed-goal, o:list sealed-goal. try T G GS :- T G GS. try _ G [G]. :index(_ 1) pred all i:tactic, i:list sealed-goal, o:list sealed-goal. all T [G|Gs] O :- T G O1, all T Gs O2, std.append O1 O2 O. all _ [] []. pred thenl i:list tactic, i:sealed-goal, o:list sealed-goal. thenl [] G [G]. thenl [T|Ts] G GS :- T G NG, all (thenl Ts) NG GS. pred repeat i:tactic, i:sealed-goal, o:list sealed-goal. repeat T G GS :- T G GS1, all (repeat T) GS1 GS. repeat _ G [G]. pred repeat! i:tactic, i:sealed-goal, o:list sealed-goal. repeat! T G GS :- T G GS1, !, all (repeat T) GS1 GS. repeat! _ G [G]. pred or i:list tactic, i:sealed-goal, o:list sealed-goal. or TL G GS :- std.exists TL (t\ t G GS). :index(_ 1) pred open i:open-tactic, i:sealed-goal, o:list sealed-goal. open T (nabla G) O :- (pi x\ open T (G x) (NG x)), private.distribute-nabla NG O. open _ (seal (goal _ _ _ Solution _)) [] :- not (var Solution), !. % solved by side effect open T (seal (goal Ctx _ _ _ _ as G)) O :- std.filter Ctx private.not-already-assumed Ctx1, Ctx1 => T G O, if (var O) (G = goal _ _ _ P _, coq.ltac.collect-goals P O1 O2, std.append O1 O2 O) true. % helper code --------------------------------------------------------------- namespace private { :index(_ _ 1) pred move-goal-argument i:list prop, i:list prop, i:argument, o:argument. move-goal-argument _ _ (int _ as A) A. move-goal-argument _ _ (str _ as A) A. move-goal-argument _ _ (tac _) _ :- coq.error "NIY: move tactic goal argument to another context". move-goal-argument C D (trm T) (trm T1) :- std.rev C Cr, std.rev D Dr, std.assert! (move-term Cr Dr T T1) "cannot move goal argument to the right context", !. :index(2) pred move-term i:list prop, i:list prop, i:term, o:term. move-term [] _ T T1 :- copy T T1. move-term [decl X _ TX|C1] [decl Y _ TY|C2] T T1 :- std.do! [ copy TX TX1, same_term TX1 TY ], !, copy X Y => move-term C1 C2 T T1. move-term [def X _ TX BX|C1] [def Y _ TY BY|C2] T T1 :- std.do! [ copy TX TX1, same_term TX1 TY, copy BX BX1, same_term BX1 BY ], !, copy X Y => move-term C1 C2 T T1. move-term [decl X _ _|C1] C2 T T1 :- not(occurs X T), !, move-term C1 C2 T T1. move-term [def X _ _ _|C1] C2 T T1 :- not(occurs X T), !, move-term C1 C2 T T1. move-term C1 [_|C2] T T1 :- move-term C1 C2 T T1. pred distribute-nabla i:(term -> list sealed-goal), o:list sealed-goal. distribute-nabla (_\ []) []. distribute-nabla (x\ [X x| XS x]) [nabla X|R] :- (pi x\ occurs x (X x)), !, distribute-nabla XS R. distribute-nabla (x\ [X| XS x]) [X|R] :- distribute-nabla XS R. pred not-already-assumed i:prop. not-already-assumed (decl X _ _Ty) :- not(decl X _ _ ; def X _ _ _). not-already-assumed (def X _ _Ty _Bo) :- not(decl X _ _ ; def X _ _ _). }}coq-elpi-2.1.0/elpi/elpi-reduction.elpi000066400000000000000000000102161460156013500177530ustar00rootroot00000000000000/* Reduction (whd, hd-beta, ...) */ /* license: GNU Lesser General Public License Version 2.1 or later */ /* ------------------------------------------------------------------------- */ % Entry points typeabbrev stack (list term). pred hd-beta i:term, i:stack, o:term, o:stack. pred hd-beta-zeta i:term, i:stack, o:term, o:stack. pred hd-beta-zeta-reduce i:term, o:term. pred whd i:term, i:stack, o:term, o:stack. pred whd-indc i:term, o:constructor, o:stack. pred unwind i:term, i:stack, o:term. pred whd1 i:term, o:term. %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% shorten std.{append, nth, drop}. % indirection, to be used if we add to the stack "match" frames unwind T A R :- if (var T) (coq.mk-app-uvar T A R) (coq.mk-app T A R). pred nth-stack i:int, i:stack, o:stack, o:term, o:stack. nth-stack 0 [X|XS] [] X XS :- !. nth-stack N [X|XS] [X|Before] At After :- M is N - 1, nth-stack M XS Before At After. % whd beta-iota-delta-zeta, main code whd (app [Hd|Args]) C X XC :- !, whd Hd {append Args C} X XC. whd (fun _ _ _ as X) [] X [] :- !. whd (fun N T F) [B|C] X XC :- !, (pi x\ def x N T B => cache x BN_ => whd (F x) C (F1 x) (C1 x)), X = F1 B, XC = C1 B. whd (let N T B F) C X XC :- !, (pi x\ def x N T B => cache x BN_ => whd (F x) C (F1 x) (C1 x)), X = F1 B, XC = C1 B. whd (global (const GR)) C X XC :- unfold GR none C D DC, !, whd D DC X XC. whd (pglobal (const GR) I) C X XC :- unfold GR (some I) C D DC, !, whd D DC X XC. whd (primitive (proj _ N)) [A|C] X XC :- whd-indc A _ KA, !, whd {proj-red KA N C} X XC. whd (global (const GR) as HD) C X XC :- coq.env.primitive? GR, !, unwind HD C Orig, coq.reduction.lazy.whd_all Orig R, if (same_term Orig R) (X = HD, XC = C) (whd R [] X XC). whd (match A _ L) C X XC :- whd-indc A GR KA, !, whd {match-red GR KA L C} X XC. whd (fix _ N _ F as Fix) C X XC :- nth-stack N C LA A RA, whd-indc A GR KA, !, whd {fix-red F Fix LA GR KA RA} X XC. whd N C X XC :- name N, def N _ _ V, !, cache-whd N VN V, whd VN C X XC. whd X C X C. % assert A reduces to a constructor whd-indc A GR KA :- whd A [] VA C, !, VA = global (indc GR), KA = C. % [whd1 T R] asserts progress was made in reducing T to R. whd1 T R :- whd T [] HD ARGS, unwind HD ARGS R, not(same_term T R). % iota step pred match-red i:constructor, i:list term, i:list term, i:stack, o:term, o:stack. match-red GR KArgs BL C X XC :- coq.env.indc GR Lno _ Ki _, drop Lno KArgs Args, nth Ki BL Bi, hd-beta {coq.mk-app Bi Args} C X XC. pred proj-red i:list term, i:int, i:stack, o:term, o:stack. proj-red Args FieldNo C V C :- nth FieldNo Args V. % iota step pred fix-red i:(term -> term), i:term, i:list term, i:constructor, i:list term, i:list term, o:term, o:stack. fix-red F Fix LA GR KA RA X XC :- append LA [{coq.mk-app (global (indc GR)) KA}|RA] ArgsWRedRecNo, hd-beta {coq.mk-app (F Fix) ArgsWRedRecNo} [] X XC. pred unfold % delta (global constants) + hd-beta i:constant, % name i:option univ-instance, % universe instance if the constant is universe polymorphic i:stack, % args o:term, % body o:stack. % args after hd-beta unfold GR none A BO BOC :- coq.env.const GR (some B) _, hd-beta B A BO BOC. unfold GR (some I) A BO BOC :- @uinstance! I => coq.env.const GR (some B) _, hd-beta B A BO BOC. % ensures its first argument is the whd of the second pred cache i:term, o:term. pred cache-whd i:term, i:term, i:term. cache-whd N K V :- cache N VN, var VN, !, whd V [] X XC, unwind X XC VN, K = VN. cache-whd N K _ :- cache N K, !. cache-whd N _ _ :- coq.error "anomaly: def with no cache:" {coq.term->string N}. hd-beta (app [Hd|Args]) S X C :- !, hd-beta Hd {append Args S} X C. hd-beta (fun _ _ F) [A|AS] X C :- !, hd-beta (F A) AS X C. :name "hd-beta:end" hd-beta X C X C. hd-beta-zeta (app [Hd|Args]) S X C :- !, hd-beta-zeta Hd {append Args S} X C. hd-beta-zeta (fun _ _ F) [A|AS] X C :- !, hd-beta-zeta (F A) AS X C. hd-beta-zeta (let _ _ B F) AS X C :- !, hd-beta-zeta (F B) AS X C. :name "hd-beta-zeta:end" hd-beta-zeta X C X C. hd-beta-zeta-reduce T R :- hd-beta-zeta T [] H S, unwind H S R. coq-elpi-2.1.0/elpi/elpi-tactic-template.elpi000066400000000000000000000011031460156013500210320ustar00rootroot00000000000000/* Loaded when Elpi Command is used */ /* license: GNU Lesser General Public License Version 2.1 or later */ /* ------------------------------------------------------------------------- */ accumulate elpi/coq-lib. % basic term manipulation routines accumulate elpi/elpi-reduction. % whd, hd-beta, ... % Since the elaborator written in Elpi is not ready, we fallback to the Coq one % accumulate engine/elaborator. % of, unify accumulate elpi/coq-elaborator. accumulate elpi/elpi-ltac. % refine, or, thenl, ... coq-elpi-2.1.0/elpi/elpi_elaborator.elpi000066400000000000000000000350451460156013500202020ustar00rootroot00000000000000/* Type inference and unification */ /* license: GNU Lesser General Public License Version 2.1 or later */ /* ------------------------------------------------------------------------- */ shorten std.{rev, append, ignore-failure!, mem, map2, split-at, map, assert!}. % Entry points pred unify-eq i:term, i:term. pred unify-list-eq i:list term, i:list term. pred unify-leq i:term, i:term. pred of i:term, o:term, o:term. % of Term Type(i/o) RefinedTerm %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %%%%% Reduction %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% :before "hd-beta:end" hd-beta (uvar as K) [A|AS] X C :- !, % auto-intro assert! (of A TA _) "already typed", unify-eq K (fun `hd_beta_auto` TA F), hd-beta (F A) AS X C. :before "hd-beta-zeta:end" hd-beta-zeta (uvar as K) [A|AS] X C :- !, % auto-intro assert! (of A TA _) "already typed", unify-eq K (fun `hd_beta_zeta_auto` TA F), hd-beta-zeta (F A) AS X C. %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %%%%% Unification %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % invariant: hd-beta terms % we start with ff, tt to handle symmetric cases % NOTE: rec-calls with unify (ensured hd-beta + ff) , symmetric rules are typically ! % NOTE: asymmetric rules are not ! otherwise the flip rule is killed % NOTE: whd are ! % names: unif X C T D M kind cumul type. type eq cumul. type leq cumul. macro @tail-cut-if Option Hd Hyps :- ( (Hd :- get-option Option tt, Hyps, !), (Hd :- not(get-option Option tt), Hyps ) ). pred unif i:term, i:stack, i:term, i:stack, i:bool, i:cumul. :if "DBG:unif" unif X CX Y CY D M :- coq.say {counter "run"} "unif" X CX "==" Y CY "(flipped?" D "cumul:" M ")", fail. pred swap i:bool, i:(A -> B -> prop), i:A, i:B. swap tt F A B :- F B A. swap ff F A B :- F A B. % flexible cases @tail-cut-if "unif:greedy" (unif (uvar V L) [] T D _ _) (!, (bind-list L {unwind T D} V)). @tail-cut-if "unif:greedy" (unif X C (uvar V L) [] _ _) (!, bind-list L {unwind X C} V). unif (sort prop) [] (sort (uvar as Y)) [] _ _ :- !, Y = prop. unif X [] (sort (uvar as Y)) [] M U :- !, coq.univ.new Lvl, Y = typ Lvl, unif X [] (sort Y) [] M U. unif (sort (uvar as X)) [] Y [] M U :- !, coq.univ.new Lvl, X = typ Lvl, unif (sort X) [] Y [] M U. unif (sort S1) [] (sort S2) [] M eq :- !, swap M coq.sort.eq S1 S2. unif (sort S1) [] (sort S2) [] M leq :- !, swap M coq.sort.leq S1 S2. unif (primitive X) [] (primitive X) [] ff _ :- !. unif (global (indt GR1)) C (global (indt GR2)) D _ _ :- !, GR1 = GR2, unify-ctxs C D. unif (global (indc GR1)) C (global (indc GR2)) D _ _ :- !, GR1 = GR2, unify-ctxs C D. unif (pglobal (indt GR1) I1) C (pglobal (indt GR2) I2) D _ eq :- !, GR1 = GR2, coq.univ-instance.unify-eq (indt GR1) I1 I2 ok, unify-ctxs C D. unif (pglobal (indt GR1) I1) C (pglobal (indt GR2) I2) D _ leq :- !, GR1 = GR2, coq.univ-instance.unify-leq (indt GR1) I1 I2 ok, unify-ctxs C D. % fast path for stuck term on the right unif X C (global (indt _) as T) D ff U :- !, unif T D {whd X C} tt U. % TODO:1 unif X C (global (indc _) as T) D ff U :- !, unif T D {whd X C} tt U. % TODO:1 unif X C (pglobal (indt _) _ as T) D ff U :- !, unif T D {whd X C} tt U. % TODO:1 unif X C (pglobal (indc _) _ as T) D ff U :- !, unif T D {whd X C} tt U. % TODO:1 % congruence rules TODO: is the of assumption really needed? unif (fun N T1 F1) [] (fun M T2 F2) [] _ _ :- !, ignore-failure! (N = M), unify T1 T2 eq, pi x\ (decl x N T1) => unify (F1 x) (F2 x) eq. unif (prod N T1 F1) [] (prod M T2 F2) [] _ U :- !, ignore-failure! (N = M), unify T1 T2 eq, pi x\ (decl x N T1) => unify (F1 x) (F2 x) U. unif (fix N Rno Ty1 F1) B1 (fix M Rno Ty2 F2) B2 _ _ :- !, ignore-failure! (N = M), unify Ty1 Ty2 eq, (pi f\ (decl f N Ty1) => unify (F1 f) (F2 f) eq), unify-ctxs B1 B2. unif (match A1 R1 L1) B1 (match A2 R2 L2) B2 _ _ :- !, unify A1 A2 eq, unify R1 R2 eq, unify-list L1 L2, unify-ctxs B1 B2. % congruence heuristic (same maybe-non-normal head) unif (let N T1 B1 F1) C1 (let M T2 B2 F2) C2 _ _ :- ignore-failure! (N = M), unify T1 T2 eq, unify B1 B2 eq, (@pi-def N T1 B1 x\ unify (F1 x) (F2 x) eq), unify-ctxs C1 C2, !. unif (global (const GR)) C (global (const GR)) D _ _ :- unify-ctxs C D, !. unif (pglobal (const GR) I1) C (pglobal (const GR) I2) D _ eq :- coq.univ-instance.unify-eq (const GR) I1 I2 ok, unify-ctxs C D, !. unif (pglobal (const GR) I1) C (pglobal (const GR) I2) D _ leq :- coq.univ-instance.unify-leq (const GR) I1 I2 ok, unify-ctxs C D, !. unif X C T D _ _ :- name X, name T, X = T, unify-ctxs C D. % 1 step reduction TODO:1 unif (global (const GR)) C T D M U :- unfold GR none C X1 C1, !, unif X1 C1 T D M U. unif (pglobal (const GR) I) C T D M U :- unfold GR (some I) C X1 C1, !, unif X1 C1 T D M U. unif (let N TB B F) C1 T C2 M U :- !, @pi-def N TB B x\ unif {hd-beta (F x) C1} T C2 M U. unif (match A _ L) C T D M U :- whd-indc A GR KA, !, unif {match-red GR KA L C} T D M U. unif (fix _ N _ F as X) C T D M U :- nth-stack N C LA A RA, whd-indc A GR KA, !, unif {fix-red F X LA GR KA RA} T D M U. unif X C T D M U :- name X, def X _ _ V, !, unif {hd-beta V C} T D M U. % TODO we could use _VN if nonflex % TODO:1 turn into (if reducible then reduce1 else fully-reduce2 tt) % symmetry unif X C T D ff U :- !, unif T D X C tt U. % error % unif X C1 Y C2 _tt :- !, % print "Error: " {coq.term->string {unwind X C1}} "vs" {coq.term->string {unwind Y C2}}. %, halt. % Contexts happens to be lists, so we just reuse the code pred unify-list i:list term, i:list term. unify-list L1 L2 :- unify-ctxs L1 L2. % the entry points of rec calls: unify unify-ctxs pred unify-ctxs i:list term, i:list term. unify-ctxs [] []. unify-ctxs [X|XS] [Y|YS] :- unify X Y eq, !, unify-ctxs XS YS. pred unify i:term, i:term, i:cumul. unify A B C :- unif {hd-beta A []} {hd-beta B []} ff C. %%%%%% entry points for clients %%%%%%% unify-eq X Y :- unify X Y eq. unify-leq X Y :- unify X Y leq. unify-list-eq L1 L2 :- unify-list L1 L2. %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %%%% Flexible case %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Binding a list of terms (delift in Matita, invert subst in Coq) % We use a keyd discipline, i.e. we only bind terms with a rigid head pred key i:term. key (global _) :- !. key (pglobal _ _) :- !. key C :- name C, !. key (primitive _) :- !. pred bind-list i:list term, i:term, o:A. bind-list [] T T' :- bind T T1, T1 = T'. bind-list [app [C| AS] |VS] T R :- key C, !, pi x\ (pi L X\ bind (app[C|L]) X :- get-option "unif:greedy" tt, unify-list-eq L AS, X = x, !) => (pi L X\ bind (app[C|L]) X :- not (get-option "unif:greedy" tt),unify-list-eq L AS, X = x) => bind-list VS T (R x). bind-list [C|VS] T R :- key C, def C _ _ V, key V, !, pi x\ @tail-cut-if "unif:greedy" (bind C x) true => @tail-cut-if "unif:greedy" (bind V x) true => bind-list VS T (R x). bind-list [C|VS] T R :- key C, !, pi x\ @tail-cut-if "unif:greedy" (bind C x) true => bind-list VS T (R x). bind-list [ _ |VS] T R :- !, pi x\ bind-list VS T (R x). % CAVEAT: (app FLEX), (match _ _ FLEX) are not terms! pred bind i:term, o:term. bind X Y :- name X, X = Y, !. bind X Y :- name X, def X _ _ T, !, bind T Y. bind (global _ as C) C :- !. bind (pglobal _ _ as C) C :- !. bind (sort _ as C) C :- !. bind (fix N Rno Ty F) (fix N Rno Ty1 F1) :- !, bind Ty Ty1, pi x\ decl x N Ty => bind (F x) (F1 x). bind (match T Rty B) X :- !, bind T T1, bind Rty Rty1, map B bind B1, X = (match T1 Rty1 B1). bind (app L) X :- !, map L bind L1, X = app L1. bind (fun N T F) (fun N T1 F1) :- !, bind T T1, pi x\ decl x N T => bind (F x) (F1 x). bind (let N T B F) (let N T1 B1 F1) :- !, bind T T1, bind B B1, @pi-def N T B x\ bind (F x) (F1 x). bind (prod N T F) X :- !, bind T T1, (@pi-decl N T x\ bind (F x) (F1 x)), X = (prod N T1 F1). bind (uvar M L) W :- map L bind L1, coq.mk-app-uvar M L1 W. %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %%%% Type checking %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %%%%% eat-prod head head-ty args-done todo-args refined-app refined-ty %%%%%%%% pred bidir-app i:term, i:term, i:list term, o:term. :name "of:bidirectional-app" bidir-app _ _ _ _. pred saturate-dummy i:term, o:term. saturate-dummy (prod _ _ F) R :- pi x\ saturate-dummy (F x) R. saturate-dummy X X. pred ensure-prod.aux i:list A, i:term, o:term, o:bool. ensure-prod.aux [] X X _. ensure-prod.aux [_|Args] (prod N S T) (prod N S T1) NU :- !, pi x\ ensure-prod.aux Args (T x) (T1 x) NU. ensure-prod.aux [_|Args] uvar (prod Name_ Src_ R) tt :- !, pi x\ ensure-prod.aux Args (R x) (R x) tt. ensure-prod.aux Args X R NU :- whd1 X Y, ensure-prod.aux Args Y R NU. % TODO: do not fail if whd1 fails and the term is not flexible since it % may just need to be passed a concrete argument pred ensure-prod i:list A, i:term. ensure-prod Args Ty :- ensure-prod.aux Args Ty R NeedsUnif, if (var NeedsUnif) true (of R _ R1, unify-eq Ty R1). pred eat-prod i:list term, i:term, i:term, o:list term, o:term, o:term. :if "DBG:of" eat-prod [] Hd Prod Adone Res ResTy :- coq.say "eat-prod" Hd {rev Adone} "==" Res ";" Prod "=<=" ResTy, fail. eat-prod [] Hd Prod Adone Res ResTy :- !, rev Adone Args, unify-eq Res {coq.mk-app Hd Args}, unify-leq Prod ResTy. % XXX why not unif? eat-prod [A|AS] Hd (prod _ Src Tgt as Prod) Adone Res ResTy :- bidir-app Hd Prod Adone ResTy, of A Src ResA, eat-prod AS Hd (Tgt ResA) [ResA|Adone] Res ResTy. % TODO: add a whd1 eg in case of a n-ary function :if "DBG:of" of X Tx Rx :- coq.say {counter "run"} "of" X Tx Rx, fail. of X Tx R :- name X, (decl X _ T ; def X _ T _), unify-leq T Tx, R = X. of (fun N S F) LamTy (fun M S2 F2) :- of (prod N S _) (sort _U) (prod M S2 T), unify-leq (prod M S2 T) LamTy, pi x\ decl x M S2 => of (F x) (T x) (F2 x). of (app [X]) Ty R :- !, of X Ty R. of (app [Hd|Args]) TyApp App :- of Hd Prod Hd1, ensure-prod Args Prod, eat-prod Args Hd1 Prod [] App TyApp. of (prod N S F) ProdTy (prod N ResS ResF) :- closed_term U1, closed_term U2, closed_term U, of S (sort U1) ResS, (pi x\ decl x N ResS => of (F x) (sort U2) (ResF x)), pts U1 U2 U, unify-leq (sort U) ProdTy. of (match T Rty Bs) ResRtyInst (match ResT ResRty ResBs) :- of T TyT ResT, % T : TyT = (indt GR) LArgs RArgs, and (indt GR) : Ty coq.safe-dest-app TyT (global (indt GR)) Args, coq.env.indt GR _IsInd Lno _Luno Ty Kn Ks, % TODO LUno split-at Lno Args LArgs RArgs, % TODO: not a failure, just type err % fix LArgs on ind ty and constructors ty coq.subst-prod LArgs Ty TyLArgs, map Ks (coq.subst-prod LArgs) KsLArgs, % Rty skeleton (uknown ending) = fun rargs, fun e : indt largs rargs, ? mk-rty [] {coq.mk-app (global (indt GR)) LArgs} TyLArgs ResRtyRaw, of ResRtyRaw _ ResRty, unify-eq Rty ResRty, % Rty must type each branch map2 KsLArgs Kn (mk-bty Rty Lno) BsTy, map2 Bs BsTy of ResBs, % Outside type unify-leq {coq.mk-app ResRty {append RArgs [ResT]}} ResRtyInst. of (let N Ty Bo F) TyFx (let N ResTy ResBo ResF) :- of Ty (sort _) ResTy, of Bo ResTy ResBo, pi x\ def x N ResTy ResBo => cache x T_ => of (F x) TyFx (ResF x). of (fix N Rno Ty BoF) ResTy (fix N Rno RTy ResBoF) :- of Ty (sort _) RTy, unify-leq RTy ResTy, pi f\ decl f N RTy => of (BoF f) ResTy (ResBoF f). of (sort S) (sort S1) (sort S) :- coq.sort.sup S S1. of (global GR as X) T X :- coq.env.typeof GR T1, unify-leq T1 T. of (pglobal GR I as X) T X :- @uinstance! I => coq.env.typeof GR T1, unify-leq T1 T. of (primitive (uint63 _) as X) T X :- unify-leq {{ lib:num.int63.type }} T. of (primitive (float64 _) as X) T X :- unify-leq {{ lib:num.float.type }} T. of (uvar as X) T Y :- !, evar X T Y. :if "OVERRIDE_COQ_ELABORATOR" :name "refiner-assign-evar" :before "default-assign-evar" evar X Ty S :- !, of X Ty S. pred coerce o:term, o:term, o:term, o:term. pred coerced i:term, i:term, i:term, o:term. pred coerceible i:term, o:term, i:term, o:term. of X T R :- get-option "of:coerce" tt, not (var T), of X XT Y, coerced XT T Y R. :if "DBG:of" of X Tx Rx :- coq.say {counter "run"} "of [FAIL]" X Tx Rx, fail. pred utc % Uniqueness of typing i:list term, % names (canonical) i:term, % type living in names i:list term, % values (explicit subst on names) i:term, % type living in values o:prop. % goal checking compatibility of the two types utc [] T1 [] T2 (unify-eq T1V T2) :- !, copy T1 T1V. utc [N|NS] T1 [V|VS] T2 C :- !, copy N V => utc NS T1 VS T2 C. utc [] T1 VS T2 C :- !, utc [] {coq.subst-prod VS T1} [] T2 C. % FIXME: reduction utc [_|NS] (prod _ _ F) [] T2 C :- !, % FIXME: reduction assert! (pi x\ F x = F1) "restriction bug", utc NS F1 [] T2 C. % This could be done in ML pred canonical? i:list term. canonical? []. canonical? [N|NS] :- name N, not(mem NS N), canonical? NS. constraint declare-evar evar decl def cache rm-evar { rule (E1 : G1 ?- evar _ T1 (uvar K L1)) % canonical \ (E2 : G2 ?- evar _ T2 (uvar K L2)) % actual | (canonical? L1, utc L1 T1 L2 T2 Condition, coq.say "CHR: Uniqueness of typing of" K "+" L1 "<->" L2, coq.say E1 "|>" G1 "|-" K L1 ":" T1, coq.say E2 "|>" G2 "|-" K L2 ":" T2, coq.say E2 "|>" G2 "|-" Condition "\n" ) <=> (E2 : G2 ?- Condition). } % typing match %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% type mk-rty list term -> term -> term -> term -> prop. mk-rty ARGS HD (prod N S T) (fun N S F) :- !, pi x\ mk-rty [x|ARGS] HD (T x) (F x). mk-rty ARGS HD _ (fun _ IndApp _FRESH) :- coq.mk-app HD {rev ARGS} IndApp. type mk-bty term -> int -> term -> constructor -> term -> prop. mk-bty Rty Lno (prod N S T) Ki (prod N S B) :- !, pi x\ mk-bty Rty Lno (T x) Ki (B x). mk-bty Rty Lno T Ki AppRtyNorm :- coq.safe-dest-app T (global (indt _)) Args, split-at Lno Args LArgs RArgs, coq.mk-app Rty {append RArgs [{coq.mk-app (global (indc Ki)) {append LArgs RArgs}}]} AppRty, hd-beta-zeta-reduce AppRty AppRtyNorm. mk-bty Rty Lno T Ki AppRtyNorm :- coq.safe-dest-app T (pglobal (indt _) I) Args, split-at Lno Args LArgs RArgs, coq.mk-app Rty {append RArgs [{coq.mk-app (pglobal (indc Ki) I) {append LArgs RArgs}}]} AppRty, hd-beta-zeta-reduce AppRty AppRtyNorm. % PTS sorts %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% pred pts i:sort, i:sort, o:sort. pts X Y U :- coq.sort.pts-triple X Y U. coq-elpi-2.1.0/etc/000077500000000000000000000000001460156013500137775ustar00rootroot00000000000000coq-elpi-2.1.0/etc/alectryon_elpi.py000077500000000000000000000274211460156013500173730ustar00rootroot00000000000000#!/usr/bin/env python3 import sys from os.path import join, dirname # This is a custom driver: it exposes the same interface as # Alectryon's usual CLI, but: # - it sets the internal parameter pp_margin of SerAPI to a different value # - it installs a new ghref RST role # - it install a new pygments lexer for Elpi # - it patches Coq's pygments lexer to handle quotations to Elpi root = join(dirname(__file__), "..") sys.path.insert(0, root) # SERAPI ###################################################################### from alectryon.cli import main from alectryon.serapi import SerAPI SerAPI.DEFAULT_PP_ARGS['pp_margin'] = 55 # PYGMENTS ELPI ############################################################### from pygments.lexer import RegexLexer, default, words, bygroups, include, inherit from pygments.regexopt import regex_opt, regex_opt_inner from pygments.token import \ Text, Comment, Operator, Keyword, Name, String, Number class ElpiLexer(RegexLexer): """ For the `Elpi `_ programming language. .. versionadded:: 1.0 """ name = 'Elpi' aliases = ['elpi'] filenames = ['*.elpi'] mimetypes = ['text/x-elpi'] lcase_re = r"[a-z]" ucase_re = r"[A-Z]" digit_re = r"[0-9]" schar2_re = r"(\+|\*|/|\^|<|>|`|'|\?|@|#|~|=|&|!)" schar_re = r"({}|-|\$|_)".format(schar2_re) idchar_re = r"({}|{}|{}|{})".format(lcase_re,ucase_re,digit_re,schar_re) idcharstarns_re = r"({}+|(?=\.[a-z])\.{}+)".format(idchar_re,idchar_re) symbchar_re = r"({}|{}|{}|{}|:)".format(lcase_re, ucase_re, digit_re, schar_re) constant_re = r"({}{}*|{}{}*|{}{}*|_{}+)".format(ucase_re, idchar_re, lcase_re, idcharstarns_re,schar2_re, symbchar_re,idchar_re) symbol_re=r"(,|<=>|->|:-|;|\?-|->|&|=>|as|<|=<|=|==|>=|>|i<|i=<|i>=|i>|is|r<|r=<|r>=|r>|s<|s=<|s>=|s>|@|::|`->|`:|`:=|\^|-|\+|i-|i\+|r-|r\+|/|\*|div|i\*|mod|r\*|~|i~|r~)" escape_re=r"\(({}|{})\)".format(constant_re,symbol_re) const_sym_re = r"({}|{}|{})".format(constant_re,symbol_re,escape_re) tokens = { 'root': [ include('elpi') ], 'elpi': [ include('_elpi-comment'), (r"(:before|:after|:if|:name)(\s*)(\")",bygroups(Keyword.ElpiMode,Text,String.Double),'elpi-string'), (r"(:index)(\s*\()",bygroups(Keyword.ElpiMode,Text),'elpi-indexing-expr'), (r"\b(external pred|pred)(\s+)({})".format(const_sym_re),bygroups(Keyword.ElpiKeyword,Text,Name.ElpiFunction),'elpi-pred-item'), (r"\b(external type|type)(\s+)(({}(,\s*)?)+)".format(const_sym_re),bygroups(Keyword.ElpiKeyword,Text,Name.ElpiFunction),'elpi-type'), (r"\b(kind)(\s+)(({}|,)+)".format(const_sym_re),bygroups(Keyword.ElpiKeyword,Text,Name.ElpiFunction),'elpi-type'), (r"\b(typeabbrev)(\s+)({})".format(const_sym_re),bygroups(Keyword.ElpiKeyword,Text,Name.ElpiFunction),'elpi-type'), (r"\b(accumulate)(\s+)(\")",bygroups(Keyword.ElpiKeyword,Text,String.Double),'elpi-string'), (r"\b(accumulate|shorten|namespace|local)(\s+)({})".format(constant_re),bygroups(Keyword.ElpiKeyword,Text,Text)), (r"\b(pi|sigma)(\s+)([a-zA-Z][A-Za-z0-9_ ]*)(\\)",bygroups(Keyword.ElpiKeyword,Text,Name.ElpiVariable,Text)), (r"\brule\b",Keyword.ElpiKeyword), (r"\b(constraint)(\s+)(({}(\s+)?)+)".format(const_sym_re),bygroups(Keyword.ElpiKeyword,Text,Name.ElpiFunction)), (r"(?=[A-Z_]){}".format(constant_re),Name.ElpiVariable), (r"(?=[a-z_]){}\\".format(constant_re),Name.ElpiVariable), (r"_",Name.ElpiVariable), (r"({}|!|=>|;)".format(symbol_re),Keyword.ElpiKeyword), (constant_re,Text), (r"\[|\]|\||=>",Keyword.ElpiKeyword), (r'"', String.Double, 'elpi-string'), (r'`', String.Double, 'elpi-btick'), (r'\'', String.Double, 'elpi-tick'), (r'\{[^\{]', Text, 'elpi-spill'), (r"\(",Text,'elpi-in-parens'), (r'\d[\d_]*', Number.ElpiInteger), (r'-?\d[\d_]*(.[\d_]*)?([eE][+\-]?\d[\d_]*)', Number.ElpiFloat), (r"[+\*-/\^]", Operator), ], '_elpi-comment': [ (r'%[^\n]*\n',Comment), (r'/\*',Comment,'elpi-multiline-comment'), (r"\s+",Text), ], 'elpi-multiline-comment': [ (r'\*/',Comment,'#pop'), (r'.',Comment) ], 'elpi-indexing-expr':[ (r'[0-9 _]+',Number.ElpiInteger), (r'\)',Text,'#pop'), ], 'elpi-type': [ (r"(ctype\s+)(\")",bygroups(Keyword.Type,String.Double),'elpi-string'), (r'->',Keyword.Type), (constant_re,Keyword.Type), (r"\(|\)",Keyword.Type), (r"\.",Text,'#pop'), include('_elpi-comment'), ], 'elpi-pred-item': [ (r"[io]:",Keyword.ElpiMode,'elpi-ctype'), (r"\.",Text,'#pop'), include('_elpi-comment'), ], 'elpi-ctype': [ (r"(ctype\s+)(\")",bygroups(Keyword.Type,String.Double),'elpi-string'), (constant_re,Keyword.Type), (r"\(|\)",Keyword.Type), (r",",Text,'#pop'), (r"\.",Text,'#pop:2'), include('_elpi-comment'), ], 'elpi-btick': [ (r'[^` ]+', String.Double), (r'`', String.Double, '#pop'), ], 'elpi-tick': [ (r'[^\' ]+', String.Double), (r'\'', String.Double, '#pop'), ], 'elpi-string': [ (r'[^\"]+', String.Double), (r'"', String.Double, '#pop'), ], 'elpi-spill': [ (r'\{[^\{]', Text, '#push'), (r'\}[^\}]', Text, '#pop'), include('elpi'), ], 'elpi-in-parens': [ (r"\(", Operator, '#push'), (r"\)", Operator, '#pop'), include('elpi'), ], } from pygments.lexers._mapping import LEXERS LEXERS['ElpiLexer'] = ('alectryon_elpi','Elpi',('elpi',),('*.elpi',),('text/x-elpi',)) # PYGMENTS COQ-ELPI ########################################################### from alectryon.pygments_lexer import CoqLexer class CoqElpiLexer(CoqLexer, ElpiLexer): tokens = { 'root': [ # No clue what inherit would do here, so we copy Coq's ones include('_basic'), include('_vernac'), include('_keywords'), include('_other'), ], '_quotations': [ (r"lp:\{\{",String.Interpol, 'elpi'), (r"(lp:)([A-Za-z_0-9']+)",bygroups(String.Interpol, Name.ElpiVariable)), (r"(lp:)(\()([A-Z][A-Za-z_0-9']*)([a-z0-9 ]+)(\))",bygroups(String.Interpol,String.Interpol,Name.ElpiVariable,Text,String.Interpol)), ], 'antiquotation': [ (r"\}\}",String.Interpol,'#pop'), include('root') ], 'elpi': [ (r"\}\}",String.Interpol,'#pop'), (r"\b(global|sort|app|fun|let|prod|match|fix)\b", Keyword.ElpiKeyword), (r"\{\{(:[a-z]+)?",String.Interpol,'antiquotation'), # back to Coq inherit ], '_other': [ include('_quotations'), inherit ], } import alectryon.pygments_lexer alectryon.pygments_lexer.CoqLexer = CoqElpiLexer # DOCUTILS #################################################################### import docutils from docutils.parsers.rst import directives, roles # type: ignore from docutils import nodes def set_line(node, lineno, sm): node.source, node.line = sm.get_source_and_line(lineno) import re import time import pickle import atexit ghref_cache = {} def dump_ghref_cache(): when = int(time.time() / 1000) file = '/tmp/ghref_cache_{}'.format(str(when)) pickle.dump(ghref_cache,open(file,'wb')) atexit.register(dump_ghref_cache) try: when = int(time.time() / 1000) file = '/tmp/ghref_cache_{}'.format(str(when)) ghref_cache = pickle.load(open(file,'rb')) #print('loaded cache', when, file) except: #print('failed to loaded cache', file) ghref_cache = {} ghref_scrape_re = re.compile("\"sha\"[: ]*\"([a-zA-Z0-9]+)\"",re.IGNORECASE) def ghref_role(role, rawtext, text, lineno, inliner, options={}, content=[]): src = options.get('src',None) if src is None: msg = inliner.reporter.error("{}: no src option".format(role), line=lineno) return [inliner.problematic(rawtext, rawtext, msg)], [msg] components = str.split(src,sep=" ") if len(components) != 4: msg = inliner.reporter.error("{}: src should be 4 space separated strings".format(role), line=lineno) return [inliner.problematic(rawtext, rawtext, msg)], [msg] org, repo, branch, path = components uri = "https://github.com/{}/{}/blob/{}/{}".format(org,repo,branch,path) roles.set_classes(options) options.setdefault("classes", []).append("ghref") if uri in ghref_cache: code, rawuri, uri = ghref_cache[uri] else: from urllib import request apiuri = "https://api.github.com/repos/{}/{}/commits/{}/branches-where-head".format(org,repo,branch) try: with request.urlopen(apiuri) as f: json = f.read().decode('utf-8') except: msg = inliner.reporter.error("{}: could not download: {}".format(role,apiuri), line=lineno) return [inliner.problematic(rawtext, rawtext, msg)], [msg] try: # A json parser would be nicer sha = ghref_scrape_re.search(json).group(1) except: msg = inliner.reporter.error("{}: could not scrape for permalink: {}".format(role,uri), line=lineno) return [inliner.problematic(rawtext, rawtext, msg)], [msg] puri = "https://github.com/{}/{}/blob/{}/{}".format(org,repo,sha,path) rawuri = "https://raw.githubusercontent.com/{}/{}/{}/{}".format(org,repo,sha,path) try: with request.urlopen(rawuri) as f: code = f.read().decode('utf-8') except: msg = inliner.reporter.error("{}: could not download: {}".format(role,rawuri), line=lineno) return [inliner.problematic(rawtext, rawtext, msg)], [msg] ghref_cache[uri]=(code,rawuri,puri) uri=puri mangler = options.get('replace',None) mangler_with = options.get('replace_with','') if mangler is None: name = text else: name = re.sub(mangler,mangler_with,text) pattern = options.get('pattern','') from string import Template pattern = Template(pattern).safe_substitute(name = re.escape(name)) pattern = re.compile(pattern) for num, line in enumerate(code.splitlines(), 1): if pattern.search(line): uri = uri + '#L' + str(num) break else: msg = inliner.reporter.error("{}: {} not found in {} using pattern {}".format(role,text,rawuri,pattern), line=lineno) return [inliner.problematic(rawtext, rawtext, msg)], [msg] node = nodes.reference(rawtext, text, refuri=uri, **options) set_line(node, lineno, inliner.reporter) return [node], [] ghref_role.name = "ghref" ghref_role.options = { # the GH source, 4 fields separated by space: org repo branch path. Eg # :src: cpitclaudel alectryon master alectryon/docutils.py "src": directives.unchanged, # the regex to find the location in the raw file at path. I must use $name # this is replaced by the text in :ghref:`text`. Eg # :pattern: ^def $name "pattern": directives.unchanged, # optionally mangle the name before substituting it in the regexp using # re.sub. Eg # :replace: this # :replace_with: that "replace": directives.unchanged, "replace_with": directives.unchanged } roles.register_canonical_role("ghref", ghref_role) ############################################################################### __all__ = [ "ElpiLexer", "CoqElpiLexer"] if __name__ == "__main__": main() coq-elpi-2.1.0/etc/coq-elpi.lang000066400000000000000000000273501460156013500163620ustar00rootroot00000000000000 *.v \(\* \*\)