pax_global_header00006660000000000000000000000064147417344360014527gustar00rootroot0000000000000052 comment=ab1554e47ee114f9e689330b931791d1888db5ad coq-elpi-2.4.0/000077500000000000000000000000001474173443600132435ustar00rootroot00000000000000coq-elpi-2.4.0/.gitattributes000066400000000000000000000000401474173443600161300ustar00rootroot00000000000000*.elpi linguist-language=prolog coq-elpi-2.4.0/.github/000077500000000000000000000000001474173443600146035ustar00rootroot00000000000000coq-elpi-2.4.0/.github/workflows/000077500000000000000000000000001474173443600166405ustar00rootroot00000000000000coq-elpi-2.4.0/.github/workflows/doc.yml000066400000000000000000000026341474173443600201350ustar00rootroot00000000000000# 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.14.2 - 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.8.20.0+0.20.0 ./coq-elpi.opam coq-core.8.20.0 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@v4 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.4.0/.github/workflows/main.yml000066400000000000000000000060401474173443600203070ustar00rootroot00000000000000# 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: docker: runs-on: ubuntu-latest # container actions require GNU/Linux strategy: matrix: image: - 'coqorg/coq:dev' - 'coqorg/coq:8.20.0' fail-fast: false # don't stop jobs if one fails steps: - uses: actions/checkout@v3 - uses: coq-community/docker-coq-action@v1 with: opam_file: 'coq-elpi.opam' custom_image: ${{ matrix.image }} export: 'OPAMWITHTEST OPAMIGNORECONSTRAINTS OPAMVERBOSE' # space-separated list of variables env: OPAMWITHTEST: 'true' OPAMIGNORECONSTRAINTS: 'coq' OPAMVERBOSE: '3' 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@v3 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} coq-elpi.opam https://github.com/LPCIC/coq-elpi/releases/download/$TAG/coq-elpi-${TAG##v}.tar.gz coq-elpi-2.4.0/.github/workflows/nix-action-coq-8.20.yml000066400000000000000000002653501474173443600226140ustar00rootroot00000000000000jobs: QuickChick: 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@v4 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@v4 with: fetch-depth: 0 ref: ${{ env.tested_commit }} - name: Cachix install uses: cachix/install-nix-action@v30 with: nix_path: nixpkgs=channel:nixpkgs-unstable - name: Cachix setup coq-elpi uses: cachix/cachix-action@v15 with: authToken: ${{ secrets.CACHIX_AUTH_TOKEN }} extraPullNames: coq, coq-community, math-comp name: coq-elpi - id: stepCheck name: Checking presence of CI target QuickChick run: "nb_dry_run=$(NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link \\\n --argstr bundle \"coq-8.20\" --argstr job \"QuickChick\" \\\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.20" --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.20" --argstr job "mathcomp-ssreflect" - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: ExtLib' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-8.20" --argstr job "ExtLib" - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: simple-io' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-8.20" --argstr job "simple-io" - 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.20" --argstr job "QuickChick" autosubst: 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@v4 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@v4 with: fetch-depth: 0 ref: ${{ env.tested_commit }} - name: Cachix install uses: cachix/install-nix-action@v30 with: nix_path: nixpkgs=channel:nixpkgs-unstable - name: Cachix setup coq-elpi uses: cachix/cachix-action@v15 with: authToken: ${{ secrets.CACHIX_AUTH_TOKEN }} extraPullNames: coq, coq-community, math-comp name: coq-elpi - id: stepCheck name: Checking presence of CI target autosubst run: "nb_dry_run=$(NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link \\\n --argstr bundle \"coq-8.20\" --argstr job \"autosubst\" \\\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.20" --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.20" --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.20" --argstr job "autosubst" 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@v4 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@v4 with: fetch-depth: 0 ref: ${{ env.tested_commit }} - name: Cachix install uses: cachix/install-nix-action@v30 with: nix_path: nixpkgs=channel:nixpkgs-unstable - name: Cachix setup coq-elpi uses: cachix/cachix-action@v15 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.20\" --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.20" --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@v4 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@v4 with: fetch-depth: 0 ref: ${{ env.tested_commit }} - name: Cachix install uses: cachix/install-nix-action@v30 with: nix_path: nixpkgs=channel:nixpkgs-unstable - name: Cachix setup coq-elpi uses: cachix/cachix-action@v15 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.20\" --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.20" --argstr job "coq" - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: stdlib' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-8.20" --argstr job "stdlib" - 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.20" --argstr job "coq-elpi" coqeal: needs: - coq - mathcomp-algebra - multinomials - mathcomp-real-closed 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@v4 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@v4 with: fetch-depth: 0 ref: ${{ env.tested_commit }} - name: Cachix install uses: cachix/install-nix-action@v30 with: nix_path: nixpkgs=channel:nixpkgs-unstable - name: Cachix setup coq-elpi uses: cachix/cachix-action@v15 with: authToken: ${{ secrets.CACHIX_AUTH_TOKEN }} extraPullNames: coq, coq-community, math-comp name: coq-elpi - id: stepCheck name: Checking presence of CI target coqeal run: "nb_dry_run=$(NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link \\\n --argstr bundle \"coq-8.20\" --argstr job \"coqeal\" \\\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.20" --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.20" --argstr job "mathcomp-algebra" - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: bignums' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-8.20" --argstr job "bignums" - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: paramcoq' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-8.20" --argstr job "paramcoq" - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: multinomials' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-8.20" --argstr job "multinomials" - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: mathcomp-real-closed' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-8.20" --argstr job "mathcomp-real-closed" - 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.20" --argstr job "coqeal" coquelicot: 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@v4 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@v4 with: fetch-depth: 0 ref: ${{ env.tested_commit }} - name: Cachix install uses: cachix/install-nix-action@v30 with: nix_path: nixpkgs=channel:nixpkgs-unstable - name: Cachix setup coq-elpi uses: cachix/cachix-action@v15 with: authToken: ${{ secrets.CACHIX_AUTH_TOKEN }} extraPullNames: coq, coq-community, math-comp name: coq-elpi - id: stepCheck name: Checking presence of CI target coquelicot run: "nb_dry_run=$(NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link \\\n --argstr bundle \"coq-8.20\" --argstr job \"coquelicot\" \\\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.20" --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.20" --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.20" --argstr job "coquelicot" 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@v4 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@v4 with: fetch-depth: 0 ref: ${{ env.tested_commit }} - name: Cachix install uses: cachix/install-nix-action@v30 with: nix_path: nixpkgs=channel:nixpkgs-unstable - name: Cachix setup coq-elpi uses: cachix/cachix-action@v15 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.20\" --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.20" --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.20" --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.20" --argstr job "hierarchy-builder" interval: needs: - coq - coquelicot - mathcomp-ssreflect - mathcomp-fingroup 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@v4 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@v4 with: fetch-depth: 0 ref: ${{ env.tested_commit }} - name: Cachix install uses: cachix/install-nix-action@v30 with: nix_path: nixpkgs=channel:nixpkgs-unstable - name: Cachix setup coq-elpi uses: cachix/cachix-action@v15 with: authToken: ${{ secrets.CACHIX_AUTH_TOKEN }} extraPullNames: coq, coq-community, math-comp name: coq-elpi - id: stepCheck name: Checking presence of CI target interval run: "nb_dry_run=$(NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link \\\n --argstr bundle \"coq-8.20\" --argstr job \"interval\" \\\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.20" --argstr job "coq" - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: bignums' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-8.20" --argstr job "bignums" - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: coquelicot' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-8.20" --argstr job "coquelicot" - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: flocq' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-8.20" --argstr job "flocq" - 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.20" --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.20" --argstr job "mathcomp-fingroup" - 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.20" --argstr job "interval" 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@v4 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@v4 with: fetch-depth: 0 ref: ${{ env.tested_commit }} - name: Cachix install uses: cachix/install-nix-action@v30 with: nix_path: nixpkgs=channel:nixpkgs-unstable - name: Cachix setup coq-elpi uses: cachix/cachix-action@v15 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.20\" --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.20" --argstr job "coq" - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: stdlib' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-8.20" --argstr job "stdlib" - 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.20" --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.20" --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.20" --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.20" --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.20" --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.20" --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.20" --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.20" --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@v4 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@v4 with: fetch-depth: 0 ref: ${{ env.tested_commit }} - name: Cachix install uses: cachix/install-nix-action@v30 with: nix_path: nixpkgs=channel:nixpkgs-unstable - name: Cachix setup coq-elpi uses: cachix/cachix-action@v15 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.20\" --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.20" --argstr job "coq" - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: stdlib' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-8.20" --argstr job "stdlib" - 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.20" --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.20" --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.20" --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.20" --argstr job "mathcomp-algebra" mathcomp-analysis: needs: - coq - mathcomp-reals - 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@v4 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@v4 with: fetch-depth: 0 ref: ${{ env.tested_commit }} - name: Cachix install uses: cachix/install-nix-action@v30 with: nix_path: nixpkgs=channel:nixpkgs-unstable - name: Cachix setup coq-elpi uses: cachix/cachix-action@v15 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.20\" --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.20" --argstr job "coq" - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: mathcomp-reals' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-8.20" --argstr job "mathcomp-reals" - 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.20" --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.20" --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.20" --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.20" --argstr job "mathcomp-analysis" mathcomp-analysis-stdlib: needs: - coq - mathcomp-analysis - mathcomp-reals-stdlib - 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@v4 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@v4 with: fetch-depth: 0 ref: ${{ env.tested_commit }} - name: Cachix install uses: cachix/install-nix-action@v30 with: nix_path: nixpkgs=channel:nixpkgs-unstable - name: Cachix setup coq-elpi uses: cachix/cachix-action@v15 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-stdlib run: "nb_dry_run=$(NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link \\\n --argstr bundle \"coq-8.20\" --argstr job \"mathcomp-analysis-stdlib\" \\\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.20" --argstr job "coq" - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: mathcomp-analysis' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-8.20" --argstr job "mathcomp-analysis" - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: mathcomp-reals-stdlib' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-8.20" --argstr job "mathcomp-reals-stdlib" - 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.20" --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.20" --argstr job "mathcomp-analysis-stdlib" 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@v4 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@v4 with: fetch-depth: 0 ref: ${{ env.tested_commit }} - name: Cachix install uses: cachix/install-nix-action@v30 with: nix_path: nixpkgs=channel:nixpkgs-unstable - name: Cachix setup coq-elpi uses: cachix/cachix-action@v15 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.20\" --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.20" --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.20" --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.20" --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@v4 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@v4 with: fetch-depth: 0 ref: ${{ env.tested_commit }} - name: Cachix install uses: cachix/install-nix-action@v30 with: nix_path: nixpkgs=channel:nixpkgs-unstable - name: Cachix setup coq-elpi uses: cachix/cachix-action@v15 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.20\" --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.20" --argstr job "coq" - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: stdlib' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-8.20" --argstr job "stdlib" - 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.20" --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.20" --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.20" --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.20" --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.20" --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.20" --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.20" --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@v4 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@v4 with: fetch-depth: 0 ref: ${{ env.tested_commit }} - name: Cachix install uses: cachix/install-nix-action@v30 with: nix_path: nixpkgs=channel:nixpkgs-unstable - name: Cachix setup coq-elpi uses: cachix/cachix-action@v15 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.20\" --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.20" --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.20" --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.20" --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.20" --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.20" --argstr job "mathcomp-classical" mathcomp-experimental-reals: needs: - coq - mathcomp-reals - 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@v4 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@v4 with: fetch-depth: 0 ref: ${{ env.tested_commit }} - name: Cachix install uses: cachix/install-nix-action@v30 with: nix_path: nixpkgs=channel:nixpkgs-unstable - name: Cachix setup coq-elpi uses: cachix/cachix-action@v15 with: authToken: ${{ secrets.CACHIX_AUTH_TOKEN }} extraPullNames: coq, coq-community, math-comp name: coq-elpi - id: stepCheck name: Checking presence of CI target mathcomp-experimental-reals run: "nb_dry_run=$(NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link \\\n --argstr bundle \"coq-8.20\" --argstr job \"mathcomp-experimental-reals\" \\\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.20" --argstr job "coq" - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: mathcomp-reals' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-8.20" --argstr job "mathcomp-reals" - 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.20" --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.20" --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.20" --argstr job "mathcomp-experimental-reals" 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@v4 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@v4 with: fetch-depth: 0 ref: ${{ env.tested_commit }} - name: Cachix install uses: cachix/install-nix-action@v30 with: nix_path: nixpkgs=channel:nixpkgs-unstable - name: Cachix setup coq-elpi uses: cachix/cachix-action@v15 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.20\" --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.20" --argstr job "coq" - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: stdlib' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-8.20" --argstr job "stdlib" - 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.20" --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.20" --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.20" --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.20" --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.20" --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.20" --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@v4 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@v4 with: fetch-depth: 0 ref: ${{ env.tested_commit }} - name: Cachix install uses: cachix/install-nix-action@v30 with: nix_path: nixpkgs=channel:nixpkgs-unstable - name: Cachix setup coq-elpi uses: cachix/cachix-action@v15 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.20\" --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.20" --argstr job "coq" - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: stdlib' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-8.20" --argstr job "stdlib" - 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.20" --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.20" --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.20" --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@v4 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@v4 with: fetch-depth: 0 ref: ${{ env.tested_commit }} - name: Cachix install uses: cachix/install-nix-action@v30 with: nix_path: nixpkgs=channel:nixpkgs-unstable - name: Cachix setup coq-elpi uses: cachix/cachix-action@v15 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.20\" --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.20" --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.20" --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.20" --argstr job "mathcomp-finmap" mathcomp-real-closed: needs: - coq - mathcomp-ssreflect - mathcomp-algebra - mathcomp-field - mathcomp-fingroup - mathcomp-solvable - mathcomp-bigenough 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@v4 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@v4 with: fetch-depth: 0 ref: ${{ env.tested_commit }} - name: Cachix install uses: cachix/install-nix-action@v30 with: nix_path: nixpkgs=channel:nixpkgs-unstable - name: Cachix setup coq-elpi uses: cachix/cachix-action@v15 with: authToken: ${{ secrets.CACHIX_AUTH_TOKEN }} extraPullNames: coq, coq-community, math-comp name: coq-elpi - id: stepCheck name: Checking presence of CI target mathcomp-real-closed run: "nb_dry_run=$(NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link \\\n --argstr bundle \"coq-8.20\" --argstr job \"mathcomp-real-closed\" \\\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.20" --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.20" --argstr job "mathcomp-ssreflect" - 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.20" --argstr job "mathcomp-algebra" - 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.20" --argstr job "mathcomp-field" - 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.20" --argstr job "mathcomp-fingroup" - 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.20" --argstr job "mathcomp-solvable" - 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.20" --argstr job "mathcomp-bigenough" - 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.20" --argstr job "mathcomp-real-closed" mathcomp-reals: needs: - coq - mathcomp-classical - 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@v4 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@v4 with: fetch-depth: 0 ref: ${{ env.tested_commit }} - name: Cachix install uses: cachix/install-nix-action@v30 with: nix_path: nixpkgs=channel:nixpkgs-unstable - name: Cachix setup coq-elpi uses: cachix/cachix-action@v15 with: authToken: ${{ secrets.CACHIX_AUTH_TOKEN }} extraPullNames: coq, coq-community, math-comp name: coq-elpi - id: stepCheck name: Checking presence of CI target mathcomp-reals run: "nb_dry_run=$(NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link \\\n --argstr bundle \"coq-8.20\" --argstr job \"mathcomp-reals\" \\\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.20" --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.20" --argstr job "mathcomp-classical" - 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.20" --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.20" --argstr job "mathcomp-reals" mathcomp-reals-stdlib: needs: - coq - mathcomp-reals - 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@v4 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@v4 with: fetch-depth: 0 ref: ${{ env.tested_commit }} - name: Cachix install uses: cachix/install-nix-action@v30 with: nix_path: nixpkgs=channel:nixpkgs-unstable - name: Cachix setup coq-elpi uses: cachix/cachix-action@v15 with: authToken: ${{ secrets.CACHIX_AUTH_TOKEN }} extraPullNames: coq, coq-community, math-comp name: coq-elpi - id: stepCheck name: Checking presence of CI target mathcomp-reals-stdlib run: "nb_dry_run=$(NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link \\\n --argstr bundle \"coq-8.20\" --argstr job \"mathcomp-reals-stdlib\" \\\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.20" --argstr job "coq" - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: mathcomp-reals' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-8.20" --argstr job "mathcomp-reals" - 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.20" --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.20" --argstr job "mathcomp-reals-stdlib" 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@v4 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@v4 with: fetch-depth: 0 ref: ${{ env.tested_commit }} - name: Cachix install uses: cachix/install-nix-action@v30 with: nix_path: nixpkgs=channel:nixpkgs-unstable - name: Cachix setup coq-elpi uses: cachix/cachix-action@v15 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.20\" --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.20" --argstr job "coq" - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: stdlib' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-8.20" --argstr job "stdlib" - 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.20" --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.20" --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.20" --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.20" --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.20" --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@v4 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@v4 with: fetch-depth: 0 ref: ${{ env.tested_commit }} - name: Cachix install uses: cachix/install-nix-action@v30 with: nix_path: nixpkgs=channel:nixpkgs-unstable - name: Cachix setup coq-elpi uses: cachix/cachix-action@v15 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.20\" --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.20" --argstr job "coq" - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: stdlib' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-8.20" --argstr job "stdlib" - 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.20" --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.20" --argstr job "mathcomp-ssreflect" multinomials: needs: - coq - mathcomp-ssreflect - mathcomp-algebra - mathcomp-finmap - mathcomp-fingroup - mathcomp-bigenough 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@v4 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@v4 with: fetch-depth: 0 ref: ${{ env.tested_commit }} - name: Cachix install uses: cachix/install-nix-action@v30 with: nix_path: nixpkgs=channel:nixpkgs-unstable - name: Cachix setup coq-elpi uses: cachix/cachix-action@v15 with: authToken: ${{ secrets.CACHIX_AUTH_TOKEN }} extraPullNames: coq, coq-community, math-comp name: coq-elpi - id: stepCheck name: Checking presence of CI target multinomials run: "nb_dry_run=$(NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link \\\n --argstr bundle \"coq-8.20\" --argstr job \"multinomials\" \\\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.20" --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.20" --argstr job "mathcomp-ssreflect" - 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.20" --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.20" --argstr job "mathcomp-finmap" - 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.20" --argstr job "mathcomp-fingroup" - 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.20" --argstr job "mathcomp-bigenough" - 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.20" --argstr job "multinomials" 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@v4 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@v4 with: fetch-depth: 0 ref: ${{ env.tested_commit }} - name: Cachix install uses: cachix/install-nix-action@v30 with: nix_path: nixpkgs=channel:nixpkgs-unstable - name: Cachix setup coq-elpi uses: cachix/cachix-action@v15 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.20\" --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.20" --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.20" --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.20" --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.20" --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.20" --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.20" --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.20" --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.20" --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.20" --argstr job "odd-order" relation-algebra: 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@v4 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@v4 with: fetch-depth: 0 ref: ${{ env.tested_commit }} - name: Cachix install uses: cachix/install-nix-action@v30 with: nix_path: nixpkgs=channel:nixpkgs-unstable - name: Cachix setup coq-elpi uses: cachix/cachix-action@v15 with: authToken: ${{ secrets.CACHIX_AUTH_TOKEN }} extraPullNames: coq, coq-community, math-comp name: coq-elpi - id: stepCheck name: Checking presence of CI target relation-algebra run: "nb_dry_run=$(NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link \\\n --argstr bundle \"coq-8.20\" --argstr job \"relation-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.20" --argstr job "coq" - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: aac-tactics' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-8.20" --argstr job "aac-tactics" - 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.20" --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.20" --argstr job "relation-algebra" name: Nix CI for bundle coq-8.20 on: pull_request: paths: - .github/workflows/nix-action-coq-8.20.yml pull_request_target: paths-ignore: - .github/workflows/nix-action-coq-8.20.yml types: - opened - synchronize - reopened push: branches: - master coq-elpi-2.4.0/.github/workflows/nix-action-coq-master-min-elpi.yml000066400000000000000000002273671474173443600252360ustar00rootroot00000000000000jobs: 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@v4 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@v4 with: fetch-depth: 0 ref: ${{ env.tested_commit }} - name: Cachix install uses: cachix/install-nix-action@v30 with: nix_path: nixpkgs=channel:nixpkgs-unstable - name: Cachix setup coq-elpi uses: cachix/cachix-action@v15 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-master-min-elpi\" --argstr job \"coq\" \\\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 current CI target run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-master-min-elpi" --argstr job "coq" coq-elpi: needs: - coq - stdlib 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@v4 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@v4 with: fetch-depth: 0 ref: ${{ env.tested_commit }} - name: Cachix install uses: cachix/install-nix-action@v30 with: nix_path: nixpkgs=channel:nixpkgs-unstable - name: Cachix setup coq-elpi uses: cachix/cachix-action@v15 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-master-min-elpi\" --argstr job \"coq-elpi\" \\\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-master-min-elpi" --argstr job "coq" - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: stdlib' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-master-min-elpi" --argstr job "stdlib" - 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-master-min-elpi" --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@v4 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@v4 with: fetch-depth: 0 ref: ${{ env.tested_commit }} - name: Cachix install uses: cachix/install-nix-action@v30 with: nix_path: nixpkgs=channel:nixpkgs-unstable - name: Cachix setup coq-elpi uses: cachix/cachix-action@v15 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-master-min-elpi\" --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-master-min-elpi" --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-master-min-elpi" --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-master-min-elpi" --argstr job "hierarchy-builder" mathcomp: needs: - coq - stdlib - 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@v4 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@v4 with: fetch-depth: 0 ref: ${{ env.tested_commit }} - name: Cachix install uses: cachix/install-nix-action@v30 with: nix_path: nixpkgs=channel:nixpkgs-unstable - name: Cachix setup coq-elpi uses: cachix/cachix-action@v15 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-master-min-elpi\" --argstr job \"mathcomp\" \\\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-master-min-elpi" --argstr job "coq" - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: stdlib' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-master-min-elpi" --argstr job "stdlib" - 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-master-min-elpi" --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-master-min-elpi" --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-master-min-elpi" --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-master-min-elpi" --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-master-min-elpi" --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-master-min-elpi" --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-master-min-elpi" --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-master-min-elpi" --argstr job "mathcomp" mathcomp-algebra: needs: - coq - stdlib - 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@v4 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@v4 with: fetch-depth: 0 ref: ${{ env.tested_commit }} - name: Cachix install uses: cachix/install-nix-action@v30 with: nix_path: nixpkgs=channel:nixpkgs-unstable - name: Cachix setup coq-elpi uses: cachix/cachix-action@v15 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-master-min-elpi\" --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-master-min-elpi" --argstr job "coq" - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: stdlib' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-master-min-elpi" --argstr job "stdlib" - 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-master-min-elpi" --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-master-min-elpi" --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-master-min-elpi" --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-master-min-elpi" --argstr job "mathcomp-algebra" mathcomp-analysis: needs: - coq - mathcomp-reals - 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@v4 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@v4 with: fetch-depth: 0 ref: ${{ env.tested_commit }} - name: Cachix install uses: cachix/install-nix-action@v30 with: nix_path: nixpkgs=channel:nixpkgs-unstable - name: Cachix setup coq-elpi uses: cachix/cachix-action@v15 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-master-min-elpi\" --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-master-min-elpi" --argstr job "coq" - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: mathcomp-reals' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-master-min-elpi" --argstr job "mathcomp-reals" - 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-master-min-elpi" --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-master-min-elpi" --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-master-min-elpi" --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-master-min-elpi" --argstr job "mathcomp-analysis" mathcomp-analysis-stdlib: needs: - coq - mathcomp-analysis - mathcomp-reals-stdlib - 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@v4 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@v4 with: fetch-depth: 0 ref: ${{ env.tested_commit }} - name: Cachix install uses: cachix/install-nix-action@v30 with: nix_path: nixpkgs=channel:nixpkgs-unstable - name: Cachix setup coq-elpi uses: cachix/cachix-action@v15 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-stdlib run: "nb_dry_run=$(NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link \\\n --argstr bundle \"coq-master-min-elpi\" --argstr job \"mathcomp-analysis-stdlib\" \\\ \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-master-min-elpi" --argstr job "coq" - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: mathcomp-analysis' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-master-min-elpi" --argstr job "mathcomp-analysis" - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: mathcomp-reals-stdlib' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-master-min-elpi" --argstr job "mathcomp-reals-stdlib" - 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-master-min-elpi" --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-master-min-elpi" --argstr job "mathcomp-analysis-stdlib" 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@v4 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@v4 with: fetch-depth: 0 ref: ${{ env.tested_commit }} - name: Cachix install uses: cachix/install-nix-action@v30 with: nix_path: nixpkgs=channel:nixpkgs-unstable - name: Cachix setup coq-elpi uses: cachix/cachix-action@v15 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-master-min-elpi\" --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-master-min-elpi" --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-master-min-elpi" --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-master-min-elpi" --argstr job "mathcomp-bigenough" mathcomp-character: needs: - coq - stdlib - 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@v4 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@v4 with: fetch-depth: 0 ref: ${{ env.tested_commit }} - name: Cachix install uses: cachix/install-nix-action@v30 with: nix_path: nixpkgs=channel:nixpkgs-unstable - name: Cachix setup coq-elpi uses: cachix/cachix-action@v15 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-master-min-elpi\" --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-master-min-elpi" --argstr job "coq" - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: stdlib' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-master-min-elpi" --argstr job "stdlib" - 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-master-min-elpi" --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-master-min-elpi" --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-master-min-elpi" --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-master-min-elpi" --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-master-min-elpi" --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-master-min-elpi" --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-master-min-elpi" --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@v4 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@v4 with: fetch-depth: 0 ref: ${{ env.tested_commit }} - name: Cachix install uses: cachix/install-nix-action@v30 with: nix_path: nixpkgs=channel:nixpkgs-unstable - name: Cachix setup coq-elpi uses: cachix/cachix-action@v15 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-master-min-elpi\" --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-master-min-elpi" --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-master-min-elpi" --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-master-min-elpi" --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-master-min-elpi" --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-master-min-elpi" --argstr job "mathcomp-classical" mathcomp-experimental-reals: needs: - coq - mathcomp-reals - 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@v4 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@v4 with: fetch-depth: 0 ref: ${{ env.tested_commit }} - name: Cachix install uses: cachix/install-nix-action@v30 with: nix_path: nixpkgs=channel:nixpkgs-unstable - name: Cachix setup coq-elpi uses: cachix/cachix-action@v15 with: authToken: ${{ secrets.CACHIX_AUTH_TOKEN }} extraPullNames: coq, coq-community, math-comp name: coq-elpi - id: stepCheck name: Checking presence of CI target mathcomp-experimental-reals run: "nb_dry_run=$(NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link \\\n --argstr bundle \"coq-master-min-elpi\" --argstr job \"mathcomp-experimental-reals\"\ \ \\\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-master-min-elpi" --argstr job "coq" - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: mathcomp-reals' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-master-min-elpi" --argstr job "mathcomp-reals" - 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-master-min-elpi" --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-master-min-elpi" --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-master-min-elpi" --argstr job "mathcomp-experimental-reals" mathcomp-field: needs: - coq - stdlib - 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@v4 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@v4 with: fetch-depth: 0 ref: ${{ env.tested_commit }} - name: Cachix install uses: cachix/install-nix-action@v30 with: nix_path: nixpkgs=channel:nixpkgs-unstable - name: Cachix setup coq-elpi uses: cachix/cachix-action@v15 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-master-min-elpi\" --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-master-min-elpi" --argstr job "coq" - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: stdlib' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-master-min-elpi" --argstr job "stdlib" - 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-master-min-elpi" --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-master-min-elpi" --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-master-min-elpi" --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-master-min-elpi" --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-master-min-elpi" --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-master-min-elpi" --argstr job "mathcomp-field" mathcomp-fingroup: needs: - coq - stdlib - 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@v4 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@v4 with: fetch-depth: 0 ref: ${{ env.tested_commit }} - name: Cachix install uses: cachix/install-nix-action@v30 with: nix_path: nixpkgs=channel:nixpkgs-unstable - name: Cachix setup coq-elpi uses: cachix/cachix-action@v15 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-master-min-elpi\" --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-master-min-elpi" --argstr job "coq" - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: stdlib' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-master-min-elpi" --argstr job "stdlib" - 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-master-min-elpi" --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-master-min-elpi" --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-master-min-elpi" --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@v4 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@v4 with: fetch-depth: 0 ref: ${{ env.tested_commit }} - name: Cachix install uses: cachix/install-nix-action@v30 with: nix_path: nixpkgs=channel:nixpkgs-unstable - name: Cachix setup coq-elpi uses: cachix/cachix-action@v15 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-master-min-elpi\" --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-master-min-elpi" --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-master-min-elpi" --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-master-min-elpi" --argstr job "mathcomp-finmap" mathcomp-real-closed: needs: - coq - mathcomp-ssreflect - mathcomp-algebra - mathcomp-field - mathcomp-fingroup - mathcomp-solvable - mathcomp-bigenough 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@v4 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@v4 with: fetch-depth: 0 ref: ${{ env.tested_commit }} - name: Cachix install uses: cachix/install-nix-action@v30 with: nix_path: nixpkgs=channel:nixpkgs-unstable - name: Cachix setup coq-elpi uses: cachix/cachix-action@v15 with: authToken: ${{ secrets.CACHIX_AUTH_TOKEN }} extraPullNames: coq, coq-community, math-comp name: coq-elpi - id: stepCheck name: Checking presence of CI target mathcomp-real-closed run: "nb_dry_run=$(NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link \\\n --argstr bundle \"coq-master-min-elpi\" --argstr job \"mathcomp-real-closed\" \\\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-master-min-elpi" --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-master-min-elpi" --argstr job "mathcomp-ssreflect" - 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-master-min-elpi" --argstr job "mathcomp-algebra" - 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-master-min-elpi" --argstr job "mathcomp-field" - 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-master-min-elpi" --argstr job "mathcomp-fingroup" - 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-master-min-elpi" --argstr job "mathcomp-solvable" - 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-master-min-elpi" --argstr job "mathcomp-bigenough" - 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-master-min-elpi" --argstr job "mathcomp-real-closed" mathcomp-reals: needs: - coq - mathcomp-classical - 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@v4 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@v4 with: fetch-depth: 0 ref: ${{ env.tested_commit }} - name: Cachix install uses: cachix/install-nix-action@v30 with: nix_path: nixpkgs=channel:nixpkgs-unstable - name: Cachix setup coq-elpi uses: cachix/cachix-action@v15 with: authToken: ${{ secrets.CACHIX_AUTH_TOKEN }} extraPullNames: coq, coq-community, math-comp name: coq-elpi - id: stepCheck name: Checking presence of CI target mathcomp-reals run: "nb_dry_run=$(NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link \\\n --argstr bundle \"coq-master-min-elpi\" --argstr job \"mathcomp-reals\" \\\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-master-min-elpi" --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-master-min-elpi" --argstr job "mathcomp-classical" - 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-master-min-elpi" --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-master-min-elpi" --argstr job "mathcomp-reals" mathcomp-reals-stdlib: needs: - coq - mathcomp-reals - 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@v4 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@v4 with: fetch-depth: 0 ref: ${{ env.tested_commit }} - name: Cachix install uses: cachix/install-nix-action@v30 with: nix_path: nixpkgs=channel:nixpkgs-unstable - name: Cachix setup coq-elpi uses: cachix/cachix-action@v15 with: authToken: ${{ secrets.CACHIX_AUTH_TOKEN }} extraPullNames: coq, coq-community, math-comp name: coq-elpi - id: stepCheck name: Checking presence of CI target mathcomp-reals-stdlib run: "nb_dry_run=$(NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link \\\n --argstr bundle \"coq-master-min-elpi\" --argstr job \"mathcomp-reals-stdlib\" \\\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-master-min-elpi" --argstr job "coq" - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: mathcomp-reals' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-master-min-elpi" --argstr job "mathcomp-reals" - 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-master-min-elpi" --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-master-min-elpi" --argstr job "mathcomp-reals-stdlib" mathcomp-solvable: needs: - coq - stdlib - 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@v4 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@v4 with: fetch-depth: 0 ref: ${{ env.tested_commit }} - name: Cachix install uses: cachix/install-nix-action@v30 with: nix_path: nixpkgs=channel:nixpkgs-unstable - name: Cachix setup coq-elpi uses: cachix/cachix-action@v15 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-master-min-elpi\" --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-master-min-elpi" --argstr job "coq" - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: stdlib' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-master-min-elpi" --argstr job "stdlib" - 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-master-min-elpi" --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-master-min-elpi" --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-master-min-elpi" --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-master-min-elpi" --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-master-min-elpi" --argstr job "mathcomp-solvable" mathcomp-ssreflect: needs: - coq - stdlib - 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@v4 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@v4 with: fetch-depth: 0 ref: ${{ env.tested_commit }} - name: Cachix install uses: cachix/install-nix-action@v30 with: nix_path: nixpkgs=channel:nixpkgs-unstable - name: Cachix setup coq-elpi uses: cachix/cachix-action@v15 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-master-min-elpi\" --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-master-min-elpi" --argstr job "coq" - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: stdlib' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-master-min-elpi" --argstr job "stdlib" - 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-master-min-elpi" --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-master-min-elpi" --argstr job "mathcomp-ssreflect" multinomials: needs: - coq - mathcomp-ssreflect - mathcomp-algebra - mathcomp-finmap - mathcomp-fingroup - mathcomp-bigenough 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@v4 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@v4 with: fetch-depth: 0 ref: ${{ env.tested_commit }} - name: Cachix install uses: cachix/install-nix-action@v30 with: nix_path: nixpkgs=channel:nixpkgs-unstable - name: Cachix setup coq-elpi uses: cachix/cachix-action@v15 with: authToken: ${{ secrets.CACHIX_AUTH_TOKEN }} extraPullNames: coq, coq-community, math-comp name: coq-elpi - id: stepCheck name: Checking presence of CI target multinomials run: "nb_dry_run=$(NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link \\\n --argstr bundle \"coq-master-min-elpi\" --argstr job \"multinomials\" \\\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-master-min-elpi" --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-master-min-elpi" --argstr job "mathcomp-ssreflect" - 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-master-min-elpi" --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-master-min-elpi" --argstr job "mathcomp-finmap" - 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-master-min-elpi" --argstr job "mathcomp-fingroup" - 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-master-min-elpi" --argstr job "mathcomp-bigenough" - 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-master-min-elpi" --argstr job "multinomials" 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@v4 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@v4 with: fetch-depth: 0 ref: ${{ env.tested_commit }} - name: Cachix install uses: cachix/install-nix-action@v30 with: nix_path: nixpkgs=channel:nixpkgs-unstable - name: Cachix setup coq-elpi uses: cachix/cachix-action@v15 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-master-min-elpi\" --argstr job \"odd-order\" \\\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-master-min-elpi" --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-master-min-elpi" --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-master-min-elpi" --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-master-min-elpi" --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-master-min-elpi" --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-master-min-elpi" --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-master-min-elpi" --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-master-min-elpi" --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-master-min-elpi" --argstr job "odd-order" stdlib: 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@v4 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@v4 with: fetch-depth: 0 ref: ${{ env.tested_commit }} - name: Cachix install uses: cachix/install-nix-action@v30 with: nix_path: nixpkgs=channel:nixpkgs-unstable - name: Cachix setup coq-elpi uses: cachix/cachix-action@v15 with: authToken: ${{ secrets.CACHIX_AUTH_TOKEN }} extraPullNames: coq, coq-community, math-comp name: coq-elpi - id: stepCheck name: Checking presence of CI target stdlib run: "nb_dry_run=$(NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link \\\n --argstr bundle \"coq-master-min-elpi\" --argstr job \"stdlib\" \\\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-master-min-elpi" --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-master-min-elpi" --argstr job "stdlib" name: Nix CI for bundle coq-master-min-elpi on: pull_request: paths: - .github/workflows/nix-action-coq-master-min-elpi.yml pull_request_target: paths-ignore: - .github/workflows/nix-action-coq-master-min-elpi.yml types: - opened - synchronize - reopened push: branches: - master coq-elpi-2.4.0/.github/workflows/nix-action-coq-master.yml000066400000000000000000002247751474173443600235260ustar00rootroot00000000000000jobs: 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@v4 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@v4 with: fetch-depth: 0 ref: ${{ env.tested_commit }} - name: Cachix install uses: cachix/install-nix-action@v30 with: nix_path: nixpkgs=channel:nixpkgs-unstable - name: Cachix setup coq-elpi uses: cachix/cachix-action@v15 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-master\" --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-master" --argstr job "coq" coq-elpi: needs: - coq - stdlib 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@v4 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@v4 with: fetch-depth: 0 ref: ${{ env.tested_commit }} - name: Cachix install uses: cachix/install-nix-action@v30 with: nix_path: nixpkgs=channel:nixpkgs-unstable - name: Cachix setup coq-elpi uses: cachix/cachix-action@v15 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-master\" --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-master" --argstr job "coq" - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: stdlib' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-master" --argstr job "stdlib" - 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-master" --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@v4 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@v4 with: fetch-depth: 0 ref: ${{ env.tested_commit }} - name: Cachix install uses: cachix/install-nix-action@v30 with: nix_path: nixpkgs=channel:nixpkgs-unstable - name: Cachix setup coq-elpi uses: cachix/cachix-action@v15 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-master\" --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-master" --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-master" --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-master" --argstr job "hierarchy-builder" mathcomp: needs: - coq - stdlib - 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@v4 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@v4 with: fetch-depth: 0 ref: ${{ env.tested_commit }} - name: Cachix install uses: cachix/install-nix-action@v30 with: nix_path: nixpkgs=channel:nixpkgs-unstable - name: Cachix setup coq-elpi uses: cachix/cachix-action@v15 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-master\" --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-master" --argstr job "coq" - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: stdlib' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-master" --argstr job "stdlib" - 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-master" --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-master" --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-master" --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-master" --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-master" --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-master" --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-master" --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-master" --argstr job "mathcomp" mathcomp-algebra: needs: - coq - stdlib - 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@v4 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@v4 with: fetch-depth: 0 ref: ${{ env.tested_commit }} - name: Cachix install uses: cachix/install-nix-action@v30 with: nix_path: nixpkgs=channel:nixpkgs-unstable - name: Cachix setup coq-elpi uses: cachix/cachix-action@v15 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-master\" --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-master" --argstr job "coq" - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: stdlib' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-master" --argstr job "stdlib" - 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-master" --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-master" --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-master" --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-master" --argstr job "mathcomp-algebra" mathcomp-analysis: needs: - coq - mathcomp-reals - 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@v4 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@v4 with: fetch-depth: 0 ref: ${{ env.tested_commit }} - name: Cachix install uses: cachix/install-nix-action@v30 with: nix_path: nixpkgs=channel:nixpkgs-unstable - name: Cachix setup coq-elpi uses: cachix/cachix-action@v15 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-master\" --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-master" --argstr job "coq" - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: mathcomp-reals' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-master" --argstr job "mathcomp-reals" - 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-master" --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-master" --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-master" --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-master" --argstr job "mathcomp-analysis" mathcomp-analysis-stdlib: needs: - coq - mathcomp-analysis - mathcomp-reals-stdlib - 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@v4 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@v4 with: fetch-depth: 0 ref: ${{ env.tested_commit }} - name: Cachix install uses: cachix/install-nix-action@v30 with: nix_path: nixpkgs=channel:nixpkgs-unstable - name: Cachix setup coq-elpi uses: cachix/cachix-action@v15 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-stdlib run: "nb_dry_run=$(NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link \\\n --argstr bundle \"coq-master\" --argstr job \"mathcomp-analysis-stdlib\" \\\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-master" --argstr job "coq" - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: mathcomp-analysis' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-master" --argstr job "mathcomp-analysis" - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: mathcomp-reals-stdlib' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-master" --argstr job "mathcomp-reals-stdlib" - 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-master" --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-master" --argstr job "mathcomp-analysis-stdlib" 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@v4 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@v4 with: fetch-depth: 0 ref: ${{ env.tested_commit }} - name: Cachix install uses: cachix/install-nix-action@v30 with: nix_path: nixpkgs=channel:nixpkgs-unstable - name: Cachix setup coq-elpi uses: cachix/cachix-action@v15 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-master\" --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-master" --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-master" --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-master" --argstr job "mathcomp-bigenough" mathcomp-character: needs: - coq - stdlib - 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@v4 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@v4 with: fetch-depth: 0 ref: ${{ env.tested_commit }} - name: Cachix install uses: cachix/install-nix-action@v30 with: nix_path: nixpkgs=channel:nixpkgs-unstable - name: Cachix setup coq-elpi uses: cachix/cachix-action@v15 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-master\" --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-master" --argstr job "coq" - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: stdlib' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-master" --argstr job "stdlib" - 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-master" --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-master" --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-master" --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-master" --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-master" --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-master" --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-master" --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@v4 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@v4 with: fetch-depth: 0 ref: ${{ env.tested_commit }} - name: Cachix install uses: cachix/install-nix-action@v30 with: nix_path: nixpkgs=channel:nixpkgs-unstable - name: Cachix setup coq-elpi uses: cachix/cachix-action@v15 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-master\" --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-master" --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-master" --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-master" --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-master" --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-master" --argstr job "mathcomp-classical" mathcomp-experimental-reals: needs: - coq - mathcomp-reals - 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@v4 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@v4 with: fetch-depth: 0 ref: ${{ env.tested_commit }} - name: Cachix install uses: cachix/install-nix-action@v30 with: nix_path: nixpkgs=channel:nixpkgs-unstable - name: Cachix setup coq-elpi uses: cachix/cachix-action@v15 with: authToken: ${{ secrets.CACHIX_AUTH_TOKEN }} extraPullNames: coq, coq-community, math-comp name: coq-elpi - id: stepCheck name: Checking presence of CI target mathcomp-experimental-reals run: "nb_dry_run=$(NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link \\\n --argstr bundle \"coq-master\" --argstr job \"mathcomp-experimental-reals\" \\\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-master" --argstr job "coq" - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: mathcomp-reals' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-master" --argstr job "mathcomp-reals" - 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-master" --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-master" --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-master" --argstr job "mathcomp-experimental-reals" mathcomp-field: needs: - coq - stdlib - 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@v4 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@v4 with: fetch-depth: 0 ref: ${{ env.tested_commit }} - name: Cachix install uses: cachix/install-nix-action@v30 with: nix_path: nixpkgs=channel:nixpkgs-unstable - name: Cachix setup coq-elpi uses: cachix/cachix-action@v15 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-master\" --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-master" --argstr job "coq" - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: stdlib' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-master" --argstr job "stdlib" - 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-master" --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-master" --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-master" --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-master" --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-master" --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-master" --argstr job "mathcomp-field" mathcomp-fingroup: needs: - coq - stdlib - 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@v4 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@v4 with: fetch-depth: 0 ref: ${{ env.tested_commit }} - name: Cachix install uses: cachix/install-nix-action@v30 with: nix_path: nixpkgs=channel:nixpkgs-unstable - name: Cachix setup coq-elpi uses: cachix/cachix-action@v15 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-master\" --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-master" --argstr job "coq" - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: stdlib' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-master" --argstr job "stdlib" - 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-master" --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-master" --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-master" --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@v4 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@v4 with: fetch-depth: 0 ref: ${{ env.tested_commit }} - name: Cachix install uses: cachix/install-nix-action@v30 with: nix_path: nixpkgs=channel:nixpkgs-unstable - name: Cachix setup coq-elpi uses: cachix/cachix-action@v15 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-master\" --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-master" --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-master" --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-master" --argstr job "mathcomp-finmap" mathcomp-real-closed: needs: - coq - mathcomp-ssreflect - mathcomp-algebra - mathcomp-field - mathcomp-fingroup - mathcomp-solvable - mathcomp-bigenough 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@v4 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@v4 with: fetch-depth: 0 ref: ${{ env.tested_commit }} - name: Cachix install uses: cachix/install-nix-action@v30 with: nix_path: nixpkgs=channel:nixpkgs-unstable - name: Cachix setup coq-elpi uses: cachix/cachix-action@v15 with: authToken: ${{ secrets.CACHIX_AUTH_TOKEN }} extraPullNames: coq, coq-community, math-comp name: coq-elpi - id: stepCheck name: Checking presence of CI target mathcomp-real-closed run: "nb_dry_run=$(NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link \\\n --argstr bundle \"coq-master\" --argstr job \"mathcomp-real-closed\" \\\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-master" --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-master" --argstr job "mathcomp-ssreflect" - 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-master" --argstr job "mathcomp-algebra" - 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-master" --argstr job "mathcomp-field" - 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-master" --argstr job "mathcomp-fingroup" - 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-master" --argstr job "mathcomp-solvable" - 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-master" --argstr job "mathcomp-bigenough" - 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-master" --argstr job "mathcomp-real-closed" mathcomp-reals: needs: - coq - mathcomp-classical - 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@v4 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@v4 with: fetch-depth: 0 ref: ${{ env.tested_commit }} - name: Cachix install uses: cachix/install-nix-action@v30 with: nix_path: nixpkgs=channel:nixpkgs-unstable - name: Cachix setup coq-elpi uses: cachix/cachix-action@v15 with: authToken: ${{ secrets.CACHIX_AUTH_TOKEN }} extraPullNames: coq, coq-community, math-comp name: coq-elpi - id: stepCheck name: Checking presence of CI target mathcomp-reals run: "nb_dry_run=$(NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link \\\n --argstr bundle \"coq-master\" --argstr job \"mathcomp-reals\" \\\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-master" --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-master" --argstr job "mathcomp-classical" - 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-master" --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-master" --argstr job "mathcomp-reals" mathcomp-reals-stdlib: needs: - coq - mathcomp-reals - 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@v4 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@v4 with: fetch-depth: 0 ref: ${{ env.tested_commit }} - name: Cachix install uses: cachix/install-nix-action@v30 with: nix_path: nixpkgs=channel:nixpkgs-unstable - name: Cachix setup coq-elpi uses: cachix/cachix-action@v15 with: authToken: ${{ secrets.CACHIX_AUTH_TOKEN }} extraPullNames: coq, coq-community, math-comp name: coq-elpi - id: stepCheck name: Checking presence of CI target mathcomp-reals-stdlib run: "nb_dry_run=$(NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link \\\n --argstr bundle \"coq-master\" --argstr job \"mathcomp-reals-stdlib\" \\\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-master" --argstr job "coq" - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: mathcomp-reals' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-master" --argstr job "mathcomp-reals" - 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-master" --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-master" --argstr job "mathcomp-reals-stdlib" mathcomp-solvable: needs: - coq - stdlib - 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@v4 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@v4 with: fetch-depth: 0 ref: ${{ env.tested_commit }} - name: Cachix install uses: cachix/install-nix-action@v30 with: nix_path: nixpkgs=channel:nixpkgs-unstable - name: Cachix setup coq-elpi uses: cachix/cachix-action@v15 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-master\" --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-master" --argstr job "coq" - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: stdlib' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-master" --argstr job "stdlib" - 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-master" --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-master" --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-master" --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-master" --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-master" --argstr job "mathcomp-solvable" mathcomp-ssreflect: needs: - coq - stdlib - 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@v4 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@v4 with: fetch-depth: 0 ref: ${{ env.tested_commit }} - name: Cachix install uses: cachix/install-nix-action@v30 with: nix_path: nixpkgs=channel:nixpkgs-unstable - name: Cachix setup coq-elpi uses: cachix/cachix-action@v15 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-master\" --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-master" --argstr job "coq" - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: stdlib' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-master" --argstr job "stdlib" - 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-master" --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-master" --argstr job "mathcomp-ssreflect" multinomials: needs: - coq - mathcomp-ssreflect - mathcomp-algebra - mathcomp-finmap - mathcomp-fingroup - mathcomp-bigenough 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@v4 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@v4 with: fetch-depth: 0 ref: ${{ env.tested_commit }} - name: Cachix install uses: cachix/install-nix-action@v30 with: nix_path: nixpkgs=channel:nixpkgs-unstable - name: Cachix setup coq-elpi uses: cachix/cachix-action@v15 with: authToken: ${{ secrets.CACHIX_AUTH_TOKEN }} extraPullNames: coq, coq-community, math-comp name: coq-elpi - id: stepCheck name: Checking presence of CI target multinomials run: "nb_dry_run=$(NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link \\\n --argstr bundle \"coq-master\" --argstr job \"multinomials\" \\\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-master" --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-master" --argstr job "mathcomp-ssreflect" - 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-master" --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-master" --argstr job "mathcomp-finmap" - 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-master" --argstr job "mathcomp-fingroup" - 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-master" --argstr job "mathcomp-bigenough" - 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-master" --argstr job "multinomials" 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@v4 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@v4 with: fetch-depth: 0 ref: ${{ env.tested_commit }} - name: Cachix install uses: cachix/install-nix-action@v30 with: nix_path: nixpkgs=channel:nixpkgs-unstable - name: Cachix setup coq-elpi uses: cachix/cachix-action@v15 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-master\" --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-master" --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-master" --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-master" --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-master" --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-master" --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-master" --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-master" --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-master" --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-master" --argstr job "odd-order" stdlib: 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@v4 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@v4 with: fetch-depth: 0 ref: ${{ env.tested_commit }} - name: Cachix install uses: cachix/install-nix-action@v30 with: nix_path: nixpkgs=channel:nixpkgs-unstable - name: Cachix setup coq-elpi uses: cachix/cachix-action@v15 with: authToken: ${{ secrets.CACHIX_AUTH_TOKEN }} extraPullNames: coq, coq-community, math-comp name: coq-elpi - id: stepCheck name: Checking presence of CI target stdlib run: "nb_dry_run=$(NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link \\\n --argstr bundle \"coq-master\" --argstr job \"stdlib\" \\\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-master" --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-master" --argstr job "stdlib" name: Nix CI for bundle coq-master on: pull_request: paths: - .github/workflows/nix-action-coq-master.yml pull_request_target: paths-ignore: - .github/workflows/nix-action-coq-master.yml types: - opened - synchronize - reopened push: branches: - master coq-elpi-2.4.0/.gitignore000066400000000000000000000011541474173443600152340ustar00rootroot00000000000000*.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 *.timing _build tmp.out coq-elpi-tests.opam coq-elpi-tests.install coq-elpi.installcoq-elpi-2.4.0/.nix/000077500000000000000000000000001474173443600141175ustar00rootroot00000000000000coq-elpi-2.4.0/.nix/config.nix000066400000000000000000000027551474173443600161150ustar00rootroot00000000000000with builtins; with (import {}).lib; let master = [ "coqeal" "hierarchy-builder" "mathcomp" "mathcomp-analysis" "mathcomp-bigenough" "mathcomp-classical" "mathcomp-finmap" "mathcomp-real-closed" "multinomials" "odd-order" ]; common-bundles = listToAttrs (forEach master (p: { name = p; value.override.version = "master"; })) // { mathcomp-single-planB-src.job = false; mathcomp-single-planB.job = false; mathcomp-single.job = false; deriving.job = false; reglang.job = false; }; in { format = "1.0.0"; attribute = "coq-elpi"; default-bundle = "coq-8.20"; bundles = { "coq-8.20" = { coqPackages = common-bundles // { coq.override.version = "8.20"; }; # only way to override elpi version is in .nix/coq-overlays/coq-elpi/default.nix }; "coq-master" = { coqPackages = common-bundles // { coq.override.version = "master"; stdlib.override.version = "master"; coqeal.job = false; # broken in master, c.f. https://github.com/coq/coq/pull/19228 }; }; "coq-master-min-elpi" = { coqPackages = common-bundles // { coq.override.version = "master"; stdlib.override.version = "master"; coqeal.job = false; # broken in master, c.f. https://github.com/coq/coq/pull/19228 }; }; }; cachix.coq = {}; cachix.math-comp = {}; cachix.coq-community = {}; cachix.coq-elpi.authToken = "CACHIX_AUTH_TOKEN"; } coq-elpi-2.4.0/.nix/coq-nix-toolbox.nix000066400000000000000000000000531474173443600176770ustar00rootroot00000000000000"15528c384deb76abecd596520bc3d9986b06344d" coq-elpi-2.4.0/.nix/coq-overlays/000077500000000000000000000000001474173443600165435ustar00rootroot00000000000000coq-elpi-2.4.0/.nix/coq-overlays/coq-elpi/000077500000000000000000000000001474173443600202545ustar00rootroot00000000000000coq-elpi-2.4.0/.nix/coq-overlays/coq-elpi/default.nix000066400000000000000000000121741474173443600224250ustar00rootroot00000000000000{ lib, mkCoqDerivation, which, coq, stdlib, version ? null, }: 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 = "1.18.1"; }; } { case = "8.19"; out = { version = "1.18.1"; }; } { case = "8.20"; out = { version = "2.0.7"; }; } ] { version = "2.0.7"; } ); in (mkCoqDerivation { pname = "elpi"; repo = "coq-elpi"; owner = "LPCIC"; inherit version; defaultVersion = lib.switch coq.coq-version [ { case = "8.20"; out = "2.2.0"; } { case = "8.19"; out = "2.0.1"; } { case = "8.18"; out = "2.0.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."2.2.0".sha256 = "sha256-rADEoqTXM7/TyYkUKsmCFfj6fjpWdnZEOK++5oLfC/I="; release."2.0.1".sha256 = "sha256-cuoPsEJ+JRLVc9Golt2rJj4P7lKltTrrmQijjoViooc="; release."2.0.0".sha256 = "sha256-A/cH324M21k3SZ7+YWXtaYEbu6dZQq3K0cb1RMKjbsM="; 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; useDuneifVersion = v: lib.versions.isGe "2.2.0" v || v == "dev"; propagatedBuildInputs = [ coq.ocamlPackages.findlib elpi stdlib ]; preConfigure = '' make elpi/dune || true ''; meta = { description = "Coq plugin embedding ELPI"; maintainers = [ lib.maintainers.cohencyril ]; license = lib.licenses.lgpl21Plus; }; }).overrideAttrs ( o: lib.optionalAttrs (o.version != null && (o.version == "dev" || lib.versions.isGe "2.2.0" o.version)) { propagatedBuildInputs = o.propagatedBuildInputs ++ [ coq.ocamlPackages.ppx_optcomp ]; } ) coq-elpi-2.4.0/.ocamlformat000066400000000000000000000000051474173443600155430ustar00rootroot00000000000000m=120coq-elpi-2.4.0/.vscode/000077500000000000000000000000001474173443600146045ustar00rootroot00000000000000coq-elpi-2.4.0/.vscode/settings.json000066400000000000000000000017271474173443600173460ustar00rootroot00000000000000{ "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.4.0/Changelog.md000066400000000000000000001407251474173443600154650ustar00rootroot00000000000000# [2.4.0] 15/1/2025 Requires Elpi 2.0.7 and Coq 8.20. ### API - Change `coq.env.add-section-variable` now takes the implicit status of the variable # [2.3.0] - 6/12/2024 Requires Elpi 2.0.3 and Coq 8.20. The major change is the port to Elpi 2.0 that reports type checking errors to the location of the offending term and not its enclosing rule. ### Vernacular - `Elpi Accumulate Db Header ` to accumulate just the `Db` declaration but no code added after that - `Elpi File ` to name a piece of code without requiring an external file - `Elpi Accumulate File Signature ` to accumulate only the types declarations from a file. - `Elpi Typecheck` is deprecated and is a no-op since `Elpi Accumulate` performs type checking incrementally ### HOAS - new `open-trm` argument for tactics with syntax ````(...)``` and `ltac_open_term:(...)`. Open terms can mention free variables. - new `{{:pat ...}}` quotations inside which `_` is interpreted as a wildcard, not as a regular evar. ### API - Support export locality in `coq.TC.declare-instance` - `tc-instance` now just carries a priority, no matter if inferred or declared, and works for instances added as `Hint Resolve` to the `typclass_instances` database ### Build system - Support dune workspace build with `elpi` ### Misc - Resolve `.elpi` files based on Coq's resolver. Paths are now expected to be of the form `/`, where `` part is a logical Coq directory (as mapped with `-Q` or `-R`), and `` is a relative path from the corresponding directory. # [2.2.3] - 30/07/2024 Requires Elpi 1.19.2 and Coq 8.19 or Coq 8.20. ### API - New `coq.arguments.reset-simplification` - Change some speedup concerning universes # [2.2.2] - 15/07/2024 Requires Elpi 1.19.2 and Coq 8.19 or Coq 8.20. ### Packaging - Fix release script to just publish coq-elpi (and not coq-elpi-tests) - Fix opam constraints by adding upper bound # [2.2.1] - 12/07/2024 Requires Elpi 1.19.2 and Coq 8.19 or Coq 8.20. ### Error reporting - Fix type checking errors on inline code are now reported on the correct line in LSP based interfaces ### Build system - Fix various missing dependencies - Fix rebuild before installation - Change CI no more use of docker images - Change silence `default-output-directory` warning ### Apps/tc - Change organize the code inside a `tc` namespace ### Apps/derive - Change do not leak `positive_scope` open # [2.2.0] - 28/06/2024 Requires Elpi 1.19.2 and Coq 8.19 or Coq 8.20. ### Build system - Change switch to dune - New ppx_optcomp to support multiple Coq version - New no need for dot-merlin-reader, OCaml's language server understands dune ### Apps/tc - Change supports higher order unification - Change syntax to register, enable and disable solver - Change solutions found in Elpi are eta-contracted ### API - New `coq.debug` - New `coq.pstring->string` and `coq.string->pstring` - New `@warn!` attribute for `coq.notation.add-abbreviation` - New `coq.*.set.min`, `coq.*.set.max`, `coq.*.set.choose`, `coq.*.set.fold`, `coq.*.set.partition` - New `coq.*.map.fold` - New `coq.env.projection?` and `coq-env.primitive-projection?` ### HOAS - New `primitive (pstring S)` in Coq 8.20 # Changelog ## [2.1.1] - 15/05/2024 Requires Elpi 1.18.2 and Coq 8.19. ### Commands - Fix initial synterp state of commands with a synterp phase ## [2.1.0] - 29/03/2024 Requires Elpi 1.18.2 and Coq 8.19. ### 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.4.0/LICENSE000066400000000000000000000635351474173443600142640ustar00rootroot00000000000000 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.4.0/Makefile000066400000000000000000000035401474173443600147050ustar00rootroot00000000000000dune = dune $(1) $(DUNE_$(1)_FLAGS) elpi/dune: elpi/dune.in @rm -f $@ @echo "; generated by make, do not edit" > $@ @if $$(coqc --version | grep -q "8.19\|8.20") ; then \ sed -e 's/@@STDLIB_THEORY@@//' $< >> $@ ; \ else \ sed -e 's/@@STDLIB_THEORY@@/(theories Stdlib)/' $< >> $@ ; \ fi @chmod a-w $@ all: elpi/dune $(call dune,build) $(call dune,build) builtin-doc .PHONY: all build-core: elpi/dune $(call dune,build) theories $(call dune,build) builtin-doc .PHONY: build-core build-apps: elpi/dune $(call dune,build) $$(find apps -type d -name theories) .PHONY: build-apps build: elpi/dune $(call dune,build) -p coq-elpi @install $(call dune,build) builtin-doc .PHONY: build test-core: elpi/dune $(call dune,runtest) tests $(call dune,build) tests .PHONY: test-core test-apps: elpi/dune $(call dune,build) $$(find apps -type d -name tests) .PHONY: test-apps test: elpi/dune $(call dune,runtest) $(call dune,build) tests $(call dune,build) $$(find apps -type d -name tests) .PHONY: test examples: elpi/dune $(call dune,build) examples .PHONY: examples doc: build @echo "########################## generating doc ##########################" @mkdir -p doc @$(foreach tut,$(wildcard examples/tutorial*$(ONLY)*.v),\ echo ALECTRYON $(tut) && OCAMLPATH=$(shell pwd)/_build/install/default/lib ./etc/alectryon_elpi.py \ --frontend coq+rst \ --output-directory doc \ --pygments-style vs \ -R $(shell pwd)/_build/install/default/lib/coq/user-contrib/elpi_elpi elpi_elpi \ -R $(shell pwd)/_build/install/default/lib/coq/user-contrib/elpi elpi \ $(tut) &&) true @cp ./_build/default/examples/stlc.txt doc/ @cp etc/tracer.png doc/ clean: $(call dune,clean) .PHONY: clean install: elpi/dune $(call dune,install) coq-elpi .PHONY: install nix: nix-shell --arg do-nothing true --run "updateNixToolBox && genNixActions" .PHONY: nix coq-elpi-2.4.0/README.md000066400000000000000000000673671474173443600145450ustar00rootroot00000000000000[![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.20.yml/badge.svg)](https://github.com/LPCIC/coq-elpi/actions/workflows/nix-action-coq-8.20.yml) [![Nix CI](https://github.com/LPCIC/coq-elpi/actions/workflows/nix-action-coq-master.yml/badge.svg)](https://github.com/LPCIC/coq-elpi/actions/workflows/nix-action-coq-master.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. - [open terms](examples/example_open_terms.v) implements a tactic like `replace` that receives terms containing free variables, i.e. variables bound in the goal but not in the proof context. ### 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 ` declares `` as a piece of code that can be accumulated via `Elpi Accumulate File`. The content is given in the external file `` to be found in the Coq load path `some.load.path`. - `Elpi File .` declares `` as a piece of code that can be accumulated via `Elpi Accumulate File`. This time the code is given in the .v file. It understands the `#[phase]` attribute, see [synterp-vs-interp](README.md#separation-of-parsing-from-execution-of-vernacular-commands). - `Elpi Accumulate [|] [|File [Signature] |Db [Header] ]` 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 `Extra Dependency` or `Elpi File`. Accumulating `File Signature ` only adds the signautre declarations (kinds, types, modes, type abbreviations) from `` skipping the code (clauses/rules). Accumulating `Db Header `, instead of `Db `, accumulates only the first chunk of code associated with Db, typically the type declaration of the predicates that live in the Db. When defining a command or tactic it can be useful to first accumulate the Db header, then some code (possibly calling the predicate living in the Db), and finally accumulating the (full) Db. Note that when a command is executed it may need to be (partially) recompiled, e.g. if the Db was updated. In this case all the code accumulated after the Db (but not after its header) may need to be recompiled. Hence we recommend to accumulate Dbs last. 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). It understands the `#[local]`, `#[global]`, and `#[superglobal]` scope attributes, although only when accumulating to a `` (all accumulations to a program are `#[superglobal]`). Default accumulation to db is the equivalent of `#[export]`. See the Coq reference manual for the meaning of these scopes. - `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 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"`. - `` is a qualified Coq name, eg `foo.elpi` (note that `Extra Dependency` only allows simple identifiers). - `` 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](builtin-doc/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_open_term:(v)` (for `v` of type `uconstr`) - `ltac_(string|int|term|open_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) uconstr(U) := elpi tac ltac_string:(X) ltac_string:(Y) ltac_int:(Z) ltac_term:(T) ltac_term_list:(L) ltac_tactic:(intros P) ltac_open_term:(U). ``` 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 ...`. Argument `U` flagged as `ltac_open_constr` can mention free variables. The Elpi tactic receives `open-trm N F` where `N` is the number of free variables in `U` and `F` is `fun x1 => ... fun xN => U`. 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. ``` `(T)``` can be used to pass an open term to `elpi tactic ...`. ##### 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](builtin-doc/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](builtin-doc/coq-builtin.elpi) documents the HOAS encoding of Coq terms and the API to access Coq - [coq-builtin-synterp](builtin-doc/coq-builtin-synterp.elpi) documents APIs to interact with Coq at parsing time - [elpi-buitin](builtin-doc/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.4.0/_CoqProject000066400000000000000000000050561474173443600154040ustar00rootroot00000000000000-arg -w -arg +elpi.deprecated -arg -w -arg -ambiguous-extra-dep -arg -w -arg -future-coercion-class-field # Plugins. -I _build/install/default/lib # Theories -Q theories elpi -Q _build/default/theories elpi -Q elpi elpi_elpi -Q _build/default/elpi elpi_elpi -Q examples elpi.examples -Q _build/default/examples elpi.examples -Q apps/coercion/tests elpi.apps.coercion.tests -Q _build/default/apps/coercion/tests elpi.apps.coercion.tests -Q apps/coercion/theories elpi.apps.coercion -Q _build/default/apps/coercion/theories elpi.apps.coercion -Q apps/cs/tests elpi.apps.cs.tests -Q _build/default/apps/cs/tests elpi.apps.cs.tests -Q apps/cs/theories elpi.apps.cs -Q _build/default/apps/cs/theories elpi.apps.cs -Q apps/derive/elpi elpi.apps.derive.elpi -Q _build/default/apps/derive/elpi elpi.apps.derive.elpi -Q apps/derive/examples elpi.apps.derive.examples -Q _build/default/apps/derive/examples elpi.apps.derive.examples -Q apps/derive/tests elpi.apps.derive.tests -Q _build/default/apps/derive/tests elpi.apps.derive.tests -Q apps/derive/theories elpi.apps.derive -Q _build/default/apps/derive/theories elpi.apps.derive -Q apps/derive/theories/derive elpi.apps.derive.derive -Q _build/default/apps/derive/theories/derive elpi.apps.derive.derive -Q apps/eltac/examples elpi.apps.eltac.examples -Q _build/default/apps/eltac/examples elpi.apps.eltac.examples -Q apps/eltac/tests elpi.apps.eltac.tests -Q _build/default/apps/eltac/tests elpi.apps.eltac.tests -Q apps/eltac/theories elpi.apps.eltac -Q _build/default/apps/eltac/theories elpi.apps.eltac -Q apps/locker/elpi elpi.apps.locker.elpi -Q _build/default/apps/locker/elpi elpi.apps.locker.elpi -Q apps/locker/tests elpi.apps.locker.tests -Q _build/default/apps/locker/tests elpi.apps.locker.tests -Q apps/locker/theories elpi.apps.locker -Q _build/default/apps/locker/theories elpi.apps.locker -Q apps/NES/elpi elpi.apps.NES.elpi -Q _build/default/apps/NES/elpi elpi.apps.NES.elpi -Q apps/NES/examples elpi.apps.NES.examples -Q _build/default/apps/NES/examples elpi.apps.NES.examples -Q apps/NES/tests elpi.apps.NES.tests -Q _build/default/apps/NES/tests elpi.apps.NES.tests -Q apps/NES/theories elpi.apps.NES -Q _build/default/apps/NES/theories elpi.apps.NES -Q apps/tc/elpi elpi.apps.tc.elpi -Q _build/default/apps/tc/elpi elpi.apps.tc.elpi -Q apps/tc/examples elpi.apps.tc.examples -Q _build/default/apps/tc/examples elpi.apps.tc.examples -Q _build/default/apps/tc/tests elpi.apps.tc.tests -Q apps/tc/theories elpi.apps.tc -Q _build/default/apps/tc/theories elpi.apps.tc # Cram tests. -Q tests elpi.tests -Q _build/default/tests elpi.tests coq-elpi-2.4.0/apps/000077500000000000000000000000001474173443600142065ustar00rootroot00000000000000coq-elpi-2.4.0/apps/NES/000077500000000000000000000000001474173443600146335ustar00rootroot00000000000000coq-elpi-2.4.0/apps/NES/elpi/000077500000000000000000000000001474173443600155645ustar00rootroot00000000000000coq-elpi-2.4.0/apps/NES/elpi/dune000066400000000000000000000007231474173443600164440ustar00rootroot00000000000000(coq.theory (name elpi.apps.NES.elpi) (package coq-elpi) (theories elpi)) (rule (target dummy.v) (deps (glob_files *.elpi)) (action (with-stdout-to %{target} (progn (echo "Require Import String.\nOpen Scope string_scope.\nLocal Definition _hash := \"\n") (run coq_elpi_shafile %{deps}) (echo "\".\n"))))) (install (files (glob_files (*.elpi with_prefix coq/user-contrib/elpi/apps/NES/elpi/))) (section lib_root) (package coq-elpi)) coq-elpi-2.4.0/apps/NES/elpi/nes_interp.elpi000066400000000000000000000056521474173443600206150ustar00rootroot00000000000000namespace 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.4.0/apps/NES/elpi/nes_synterp.elpi000066400000000000000000000135041474173443600210130ustar00rootroot00000000000000namespace 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.4.0/apps/NES/examples/000077500000000000000000000000001474173443600164515ustar00rootroot00000000000000coq-elpi-2.4.0/apps/NES/examples/dune000066400000000000000000000001501474173443600173230ustar00rootroot00000000000000(coq.theory (name elpi.apps.NES.examples) (theories elpi elpi.apps.NES)) (include_subdirs qualified) coq-elpi-2.4.0/apps/NES/examples/usage_NES.v000066400000000000000000000037201474173443600204530ustar00rootroot00000000000000From 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.4.0/apps/NES/tests/000077500000000000000000000000001474173443600157755ustar00rootroot00000000000000coq-elpi-2.4.0/apps/NES/tests/dune000066400000000000000000000001771474173443600166600ustar00rootroot00000000000000(coq.theory (name elpi.apps.NES.tests) (package coq-elpi-tests) (theories elpi elpi.apps.NES)) (include_subdirs qualified) coq-elpi-2.4.0/apps/NES/tests/test_NES.v000066400000000000000000000023021474173443600176450ustar00rootroot00000000000000From 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.4.0/apps/NES/tests/test_NES_lib.v000066400000000000000000000014161474173443600205000ustar00rootroot00000000000000From elpi.apps.NES.elpi Extra Dependency "nes_synterp.elpi" as nes_synterp. From elpi.apps.NES.elpi 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 Export Make. Make Cats.And.Dogs. Print Cats.And.Dogs.x. coq-elpi-2.4.0/apps/NES/tests/test_NES_perf.v000066400000000000000000000623321474173443600206720ustar00rootroot00000000000000From 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.4.0/apps/NES/tests/test_NES_perf_optimal.v000066400000000000000000001210261474173443600224130ustar00rootroot00000000000000From 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.4.0/apps/NES/tests/test_NES_resolve.v000066400000000000000000000011351474173443600214070ustar00rootroot00000000000000From 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.4.0/apps/NES/tests/test_module_namespace.v000066400000000000000000000001371474173443600225250ustar00rootroot00000000000000From elpi.apps Require Import NES. Module MyModule. End MyModule. Succeed NES.Begin MyModule. coq-elpi-2.4.0/apps/NES/theories/000077500000000000000000000000001474173443600164555ustar00rootroot00000000000000coq-elpi-2.4.0/apps/NES/theories/NES.v000066400000000000000000000062541474173443600173000ustar00rootroot00000000000000From elpi.apps.NES.elpi Extra Dependency "nes_synterp.elpi" as nes_synterp. From elpi.apps.NES.elpi 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 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 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 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 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 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 Export NES.Print. coq-elpi-2.4.0/apps/NES/theories/dune000066400000000000000000000001701474173443600173310ustar00rootroot00000000000000(coq.theory (name elpi.apps.NES) (package coq-elpi) (theories elpi elpi.apps.NES.elpi)) (include_subdirs qualified) coq-elpi-2.4.0/apps/README.md000066400000000000000000000005141474173443600154650ustar00rootroot00000000000000## 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.4.0/apps/coercion/000077500000000000000000000000001474173443600160075ustar00rootroot00000000000000coq-elpi-2.4.0/apps/coercion/README.md000066400000000000000000000036761474173443600173020ustar00rootroot00000000000000# 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 }}. }}. 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.4.0/apps/coercion/src/000077500000000000000000000000001474173443600165765ustar00rootroot00000000000000coq-elpi-2.4.0/apps/coercion/src/META.coq-elpi-coercion000066400000000000000000000004431474173443600225570ustar00rootroot00000000000000 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.4.0/apps/coercion/src/coq_elpi_coercion_hook.mlg000066400000000000000000000065461474173443600240060ustar00rootroot00000000000000DECLARE PLUGIN "coq-elpi.coercion" { open Elpi open Elpi_plugin open Coq_elpi_arg_syntax open Coq_elpi_vernacular let relevant = EConstr.ERelevance.relevant let anonR = Context.make_annot Names.Name.Anonymous EConstr.ERelevance.irrelevant let nameR x = Context.make_annot (Names.Name.Name x) EConstr.ERelevance.irrelevant let annotR x = Context.make_annot x EConstr.ERelevance.irrelevant let build_expected_type env sigma expected = match expected with | Coercion.Type t -> sigma, t, false | Coercion.Product -> let (sigma, (source, _)) = Evarutil.new_type_evar env sigma Evd.univ_flexible in let (sigma, (target, _)) = let env = EConstr.push_rel (Context.Rel.Declaration.LocalAssum (EConstr.annotR (Names.Name (Namegen.default_dependent_ident)) , source)) env in Evarutil.new_type_evar env sigma Evd.univ_flexible in sigma, EConstr.mkProd (annotR (Names.Name (Namegen.default_type_ident)), source, target), true | Coercion.Sort -> let (sigma, t) = Evarutil.new_Type sigma in sigma, t, true let return s g t = Some (s,g,t) let elpi_coercion_hook program env sigma ~flags v ~inferred ~expected = let atts = [] in let sigma, expected, retype = build_expected_type env sigma expected in let sigma, goal = Evarutil.new_evar env sigma expected in let goal_evar, _ = EConstr.destEvar sigma goal in let query state = let loc = Elpi.API.State.get Coq_elpi_builtins_synterp.invocation_site_loc state in let depth = 0 in let state, q, gls = Coq_elpi_HOAS.solvegoals2query sigma [goal_evar] loc ~main:[v; inferred] ~in_elpi_tac_arg:Coq_elpi_arg_HOAS.in_elpi_tac_econstr ~depth ~base:() 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, qatts, gls in let loc = Loc.initial Loc.ToplevelInput in match Interp.get_and_compile ~loc program with | None -> None | Some (cprogram, _) -> match Interp.run ~loc cprogram (Fun (query)) with | API.Execute.Success solution -> let gls = Evar.Set.singleton goal_evar in let sigma, _, _ = Coq_elpi_HOAS.solution2evd ~eta_contract_solution:false sigma solution gls in if Evd.is_defined sigma goal_evar then let t = if retype then Retyping.get_type_of env sigma goal else expected in return sigma goal t 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.4.0/apps/coercion/src/dune000066400000000000000000000005151474173443600174550ustar00rootroot00000000000000(library (name elpi_coercion_plugin) (public_name coq-elpi.coercion) (flags :standard -w -27) (preprocess (pps ppx_optcomp -- -cookie "ppx_optcomp.env=env ~coq:(Defined \"%{coq:version.major}.%{coq:version.minor}\")")) (libraries coq-core.plugins.ltac coq-core.vernac coq-elpi.elpi)) (coq.pp (modules coq_elpi_coercion_hook)) coq-elpi-2.4.0/apps/coercion/src/elpi_coercion_plugin.mlpack000066400000000000000000000000261474173443600241550ustar00rootroot00000000000000Coq_elpi_coercion_hookcoq-elpi-2.4.0/apps/coercion/tests/000077500000000000000000000000001474173443600171515ustar00rootroot00000000000000coq-elpi-2.4.0/apps/coercion/tests/coercion.t/000077500000000000000000000000001474173443600212145ustar00rootroot00000000000000coq-elpi-2.4.0/apps/coercion/tests/coercion.t/run.t000066400000000000000000000003641474173443600222100ustar00rootroot00000000000000 $ . ../setup-project.sh $ dune build test.vo true && false : bool natmul R n : ringType_sort R : ringType_sort R natmul R n : ringType_sort R : ringType_sort R $ dune build test2.vo true : bool : bool coq-elpi-2.4.0/apps/coercion/tests/coercion.t/test.v000066400000000000000000000013201474173443600223560ustar00rootroot00000000000000From elpi.apps Require Import coercion. #[warning="-deprecated-from-Coq"] From Coq Require Import Bool. Elpi Accumulate coercion.db lp:{{ coercion _ {{ True }} {{ Prop }} {{ bool }} {{ true }}. coercion _ {{ False }} {{ Prop }} {{ bool }} {{ false }}. }}. 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. }}. 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.4.0/apps/coercion/tests/coercion.t/test2.v000066400000000000000000000000511474173443600224400ustar00rootroot00000000000000Require Import test. Check True : bool. coq-elpi-2.4.0/apps/coercion/tests/coercion_open.t/000077500000000000000000000000001474173443600222355ustar00rootroot00000000000000coq-elpi-2.4.0/apps/coercion/tests/coercion_open.t/run.t000066400000000000000000000001021474173443600232170ustar00rootroot00000000000000 $ . ../setup-project.sh $ dune build test.vo 1 : nat coq-elpi-2.4.0/apps/coercion/tests/coercion_open.t/test.v000066400000000000000000000012741474173443600234070ustar00rootroot00000000000000From elpi.apps Require Import coercion. #[warning="-deprecated-from-Coq"] From Coq Require Import Arith ssreflect. Ltac my_solver := trivial with arith. Elpi Accumulate coercion 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 [], ]. }}. 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. Check 1. coq-elpi-2.4.0/apps/coercion/tests/dune000066400000000000000000000001621474173443600200260ustar00rootroot00000000000000(cram (applies_to :whole_subtree) (deps %{bin:coqc} %{bin:coqdep} (package coq-elpi) setup-project.sh)) coq-elpi-2.4.0/apps/coercion/tests/setup-project.sh000077700000000000000000000000001474173443600270602../../../etc/setup-project.shustar00rootroot00000000000000coq-elpi-2.4.0/apps/coercion/theories/000077500000000000000000000000001474173443600176315ustar00rootroot00000000000000coq-elpi-2.4.0/apps/coercion/theories/coercion.v000066400000000000000000000013251474173443600216220ustar00rootroot00000000000000Declare ML Module "coq-elpi.coercion". 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 Db Header coercion.db. Elpi Accumulate lp:{{ solve (goal Ctx _ Ty Sol [trm V, trm VTy]) _ :- coercion Ctx V VTy Ty Sol. }}. Elpi Accumulate Db coercion.db. Elpi CoercionFallbackTactic coercion. coq-elpi-2.4.0/apps/coercion/theories/dune000066400000000000000000000002071474173443600205060ustar00rootroot00000000000000(coq.theory (name elpi.apps.coercion) (package coq-elpi) (theories elpi) (plugins coq-elpi.coercion)) (include_subdirs qualified) coq-elpi-2.4.0/apps/cs/000077500000000000000000000000001474173443600146135ustar00rootroot00000000000000coq-elpi-2.4.0/apps/cs/README.md000066400000000000000000000017521474173443600160770ustar00rootroot00000000000000# 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 }}. }}. Check eq_refl _ : (sort _) = nat. ``` coq-elpi-2.4.0/apps/cs/src/000077500000000000000000000000001474173443600154025ustar00rootroot00000000000000coq-elpi-2.4.0/apps/cs/src/META.coq-elpi-cs000066400000000000000000000004131474173443600201640ustar00rootroot00000000000000 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.4.0/apps/cs/src/coq_elpi_cs_hook.mlg000066400000000000000000000067711474173443600214160ustar00rootroot00000000000000DECLARE PLUGIN "coq-elpi.cs" { open Elpi open Elpi_plugin open Coq_elpi_arg_syntax open Coq_elpi_vernacular let elpi_cs_hook program env sigma ((proji, u), params1, c1) (t2, args2) = let atts = [] in let rhs = Reductionops.Stack.zip sigma (t2, Reductionops.Stack.append_app_list args2 Reductionops.Stack.empty) in let sigma, (goal_ty, _) = Evarutil.new_type_evar env sigma Evd.UnivRigid in let sigma, goal = Evarutil.new_evar env sigma goal_ty in let goal_evar, _ = EConstr.destEvar sigma goal in let nparams = Structures.Structure.projection_nparams proji in let query state = let loc = Elpi.API.State.get Coq_elpi_builtins_synterp.invocation_site_loc state in let state, q, gls = let lhs = match params1 with | Some params1 -> EConstr.mkApp (EConstr.mkConstU (proji, u), Array.of_list params1) | None -> EConstr.mkConstU (proji, u) in Coq_elpi_HOAS.solvegoals2query sigma [goal_evar] loc ~main:[lhs; rhs] ~in_elpi_tac_arg:Coq_elpi_arg_HOAS.in_elpi_tac_econstr ~depth:0 ~base:() state in let state, qatts = atts2impl loc Summary.Stage.Interp ~depth:0 state atts q in let state = API.State.set Coq_elpi_builtins.tactic_mode state true in state, qatts, gls in let loc = Loc.initial Loc.ToplevelInput in match Interp.get_and_compile ~loc program with | None -> None | Some (cprogram, _) -> begin match Interp.run ~loc cprogram (Fun query) with | API.Execute.Success solution -> let gls = Evar.Set.singleton goal_evar in let sigma, _, _ = Coq_elpi_HOAS.solution2evd ~eta_contract_solution:false sigma solution gls in if Evd.is_defined sigma goal_evar then let constant = EConstr.to_constr sigma goal in let args_goal, t = Reduction.whd_decompose_lambda env constant in let args_type = List.rev_map Context.Rel.Declaration.get_type args_goal in let args_type = List.map EConstr.of_constr args_type in let args = snd (Constr.decompose_app_list t) in let params, projs = CList.chop nparams args in let i = Structures.Structure.projection_number env proji in let lhs = List.nth projs i in let lhs = EConstr.of_constr lhs in let _, sk1 = EConstr.decompose_app sigma lhs in let open Structures.CanonicalSolution in Some (sigma, { constant = EConstr.of_constr constant; abstractions_ty = args_type; body = lhs; nparams; params = List.map EConstr.of_constr params; cvalue_abstraction = None; cvalue_arguments = Array.to_list sk1}) else None | API.Execute.NoMoreSteps | API.Execute.Failure -> None end [%%if coq = "8.20"] let adapt_hook f : Evarconv.hook = fun env sigma (s,l,t) x -> f env sigma (s,Some l,t) x [%%else] let adapt_hook f : Evarconv.hook = f [%%endif] 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.register_hook ~name (adapt_hook cs_hook); let inCs = let cache program = cs_hook_program := Some program; Evarconv.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" "CS" qualified_name(p) ] -> { let () = ignore_unknown_attributes atts in add_cs_hook (snd p) } END coq-elpi-2.4.0/apps/cs/src/dune000066400000000000000000000004731474173443600162640ustar00rootroot00000000000000(library (name elpi_cs_plugin) (public_name coq-elpi.cs) (flags :standard -w -27) (preprocess (pps ppx_optcomp -- -cookie "ppx_optcomp.env=env ~coq:(Defined \"%{coq:version.major}.%{coq:version.minor}\")")) (libraries coq-core.plugins.ltac coq-core.vernac coq-elpi.elpi)) (coq.pp (modules coq_elpi_cs_hook)) coq-elpi-2.4.0/apps/cs/src/elpi_cs_plugin.mlpack000066400000000000000000000000211474173443600215600ustar00rootroot00000000000000Coq_elpi_cs_hook coq-elpi-2.4.0/apps/cs/tests/000077500000000000000000000000001474173443600157555ustar00rootroot00000000000000coq-elpi-2.4.0/apps/cs/tests/cs.t.disabled_broken_8.19/000077500000000000000000000000001474173443600224115ustar00rootroot00000000000000coq-elpi-2.4.0/apps/cs/tests/cs.t.disabled_broken_8.19/run.t.disabled_broken_8.19000066400000000000000000000012531474173443600271700ustar00rootroot00000000000000 $ DEPS="elpi elpi.apps.cs" $ . ../setup-project.sh $ dune build test.vo 1 : nat eq_refl : {| sort := id (A:=nat) |} = id (A:=nat) : {| sort := id (A:=nat) |} = id (A:=nat) 11 : nat eq_refl : {| sort := id (A:=nat) |} 1 = id 1 : {| sort := id (A:=nat) |} 1 = id 1 2 : nat eq_refl : {| sort := id (A:=nat) |} = id1 nat : {| sort := id (A:=nat) |} = id1 nat 3 : nat eq_refl : sort1 nat {| sort := id (A:=nat) |} = id (A:=nat) : sort1 nat {| sort := id (A:=nat) |} = id (A:=nat) 4 : nat eq_refl : sort1 nat {| sort := id (A:=nat) |} = id1 nat : sort1 nat {| sort := id (A:=nat) |} = id1 nat coq-elpi-2.4.0/apps/cs/tests/cs.t.disabled_broken_8.19/test.v000066400000000000000000000010461474173443600235600ustar00rootroot00000000000000From elpi.apps Require Import cs. From Coq Require Import Bool. 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) }}. }}. 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.4.0/apps/cs/tests/dune000066400000000000000000000001621474173443600166320ustar00rootroot00000000000000(cram (applies_to :whole_subtree) (deps %{bin:coqc} %{bin:coqdep} (package coq-elpi) setup-project.sh)) coq-elpi-2.4.0/apps/cs/tests/setup-project.sh000077700000000000000000000000001474173443600256642../../../etc/setup-project.shustar00rootroot00000000000000coq-elpi-2.4.0/apps/cs/theories/000077500000000000000000000000001474173443600164355ustar00rootroot00000000000000coq-elpi-2.4.0/apps/cs/theories/cs.v000066400000000000000000000012451474173443600172330ustar00rootroot00000000000000Declare ML Module "coq-elpi.cs". 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 CS canonical_solution. coq-elpi-2.4.0/apps/cs/theories/dune000066400000000000000000000001731474173443600173140ustar00rootroot00000000000000(coq.theory (name elpi.apps.cs) (package coq-elpi) (theories elpi) (plugins coq-elpi.cs)) (include_subdirs qualified) coq-elpi-2.4.0/apps/derive/000077500000000000000000000000001474173443600154645ustar00rootroot00000000000000coq-elpi-2.4.0/apps/derive/README.md000066400000000000000000000510601474173443600167450ustar00rootroot00000000000000# 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 (aka record update syntax) - `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 ". }}. ``` 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 *) . ``` 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.4.0/apps/derive/derive.svg000066400000000000000000001620751474173443600174760ustar00rootroot00000000000000 image/svg+xml eqOK induction eqK eq param1 projK bcongr injection isK discriminate eqcorrect param1functor param1congr param1inhab param1trivial coq-elpi-2.4.0/apps/derive/elpi/000077500000000000000000000000001474173443600164155ustar00rootroot00000000000000coq-elpi-2.4.0/apps/derive/elpi/bcongr.elpi000066400000000000000000000114211474173443600205410ustar00rootroot00000000000000 /* 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) kind arg type. 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.4.0/apps/derive/elpi/cast.elpi000066400000000000000000000045261474173443600202310ustar00rootroot00000000000000/* 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 { pred arity i:list term, i:list term, o:term. 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). pred args i:list term, i:list term, o:term. 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). pred arg i:int, i:term, i:term, i:term, i:list term, o:list term, i:list term, o:list term. 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. pred args-ty i:term, i:term, i:term, i:list term, o:list term, o:list term, o:term. 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). pred body i:int, i:int, i:list term, o:term. 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). pred rty i:term, i:list term, i:term, i:term, i:list term, i:list term, o:term. rty A Rest X _ [Y,E] _ R :- args-ty E X Y [A|Rest] Rest [Y] R. pred body-branch i:list term, i:term, i:term, i:term, i:list term, i:list term, o:term. 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.4.0/apps/derive/elpi/derive.elpi000066400000000000000000000146441474173443600205570ustar00rootroot00000000000000/* 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.4.0/apps/derive/elpi/derive_hook.elpi000066400000000000000000000011001474173443600215560ustar00rootroot00000000000000/* 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. % if a derivation fails it should end by calling stop, instead of coq.error, % so that derive can make the failure non fatal type stop string -> prop. coq-elpi-2.4.0/apps/derive/elpi/derive_synterp.elpi000066400000000000000000000047411474173443600223400ustar00rootroot00000000000000/* 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.4.0/apps/derive/elpi/derive_synterp_hook.elpi000066400000000000000000000006431474173443600233550ustar00rootroot00000000000000/* 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.4.0/apps/derive/elpi/discriminate.elpi000066400000000000000000000024461474173443600217510ustar00rootroot00000000000000/* 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.4.0/apps/derive/elpi/dune000066400000000000000000000007311474173443600172740ustar00rootroot00000000000000(coq.theory (name elpi.apps.derive.elpi) (package coq-elpi) (theories elpi)) (rule (target dummy.v) (deps (glob_files *.elpi)) (action (with-stdout-to %{target} (progn (echo "Require Import String.\nOpen Scope string_scope.\nLocal Definition _hash := \"\n") (run coq_elpi_shafile %{deps}) (echo "\".\n"))))) (install (files (glob_files (*.elpi with_prefix coq/user-contrib/elpi/apps/derive/elpi/))) (section lib_root) (package coq-elpi)) coq-elpi-2.4.0/apps/derive/elpi/eq.elpi000066400000000000000000000155421474173443600177040ustar00rootroot00000000000000/* 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 : list prop)) (pi x f\ eq-db (A1 x) (B1 x) (C1 x f) :- (L1 x f : list prop)) :- 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.4.0/apps/derive/elpi/eqK.elpi000066400000000000000000000075061474173443600200200ustar00rootroot00000000000000/* 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.4.0/apps/derive/elpi/eqOK.elpi000066400000000000000000000030671474173443600201350ustar00rootroot00000000000000/* 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.4.0/apps/derive/elpi/eqType.elpi000066400000000000000000000150211474173443600205360ustar00rootroot00000000000000/* 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.4.0/apps/derive/elpi/eqb.elpi000066400000000000000000000243131474173443600200420ustar00rootroot00000000000000/* equality test generation */ /* license: GNU Lesser General Public License Version 2.1 or later */ /* ------------------------------------------------------------------------- */ pred feqb.trm->term i:trm, o:term. 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) : term), 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) : term), % 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) : term), 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.4.0/apps/derive/elpi/eqbOK.elpi000066400000000000000000000052261474173443600202760ustar00rootroot00000000000000/* equality test soundness proof */ /* license: GNU Lesser General Public License Version 2.1 or later */ /* ------------------------------------------------------------------------- */ pred feqb.trm->term i:trm, o:term. 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) : term), 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.4.0/apps/derive/elpi/eqbcorrect.elpi000066400000000000000000000451511474173443600214270ustar00rootroot00000000000000/* equality test correctness and reflexivity proof */ /* license: GNU Lesser General Public License Version 2.1 or later */ /* ------------------------------------------------------------------------- */ pred feqb.trm->term i:trm, o:term. 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) : term), 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 }} : term), 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] : term), ]), 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 }} : term), 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 }} : term -> term), GOAL = (x\ {{ @eq (option lp:T) (@Some lp:T lp:K) (lp:Construct (lp:Tag lp:K) lp:x) }} : term -> term), 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 }} : term), (@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 }} : term), 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 ] : term), 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.4.0/apps/derive/elpi/eqcorrect.elpi000066400000000000000000000114341474173443600212620ustar00rootroot00000000000000/* 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.4.0/apps/derive/elpi/fields.elpi000066400000000000000000000305561474173443600205470ustar00rootroot00000000000000/* 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. pred box.aux2 i:term, i:inductive, i:trm, o:list constructor, o:list box-spec. 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.4.0/apps/derive/elpi/idx2inv.elpi000066400000000000000000000064361474173443600206640ustar00rootroot00000000000000/* 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.4.0/apps/derive/elpi/induction.elpi000066400000000000000000000123501474173443600212650ustar00rootroot00000000000000/* 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.4.0/apps/derive/elpi/injection.elpi000066400000000000000000000040071474173443600212530ustar00rootroot00000000000000/* 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.4.0/apps/derive/elpi/invert.elpi000066400000000000000000000071061474173443600206030ustar00rootroot00000000000000/* 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.4.0/apps/derive/elpi/isK.elpi000066400000000000000000000030371474173443600200210ustar00rootroot00000000000000/* 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.4.0/apps/derive/elpi/lens.elpi000066400000000000000000000071211474173443600202320ustar00rootroot00000000000000/* 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.4.0/apps/derive/elpi/lens_laws.elpi000066400000000000000000000112071474173443600212600ustar00rootroot00000000000000/* 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.4.0/apps/derive/elpi/map.elpi000066400000000000000000000156141474173443600200540ustar00rootroot00000000000000/* 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:any, 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.4.0/apps/derive/elpi/param1.elpi000066400000000000000000000164471474173443600204650ustar00rootroot00000000000000/* Unary parametricity translation (Realizability) */ /* license: GNU Lesser General Public License Version 2.1 or later */ /* ------------------------------------------------------------------------- */ % Author: Cyril Cohen pred reali-done i:gref. :index(3) pred reali i:term, o:term. type realiR term -> term -> prop. 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, 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.4.0/apps/derive/elpi/param1_congr.elpi000066400000000000000000000045561474173443600216530ustar00rootroot00000000000000/* 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.4.0/apps/derive/elpi/param1_functor.elpi000066400000000000000000000215041474173443600222130ustar00rootroot00000000000000/* map over a container */ /* license: GNU Lesser General Public License Version 2.1 or later */ /* ------------------------------------------------------------------------- */ pred param1-functor-db i:term, i:term, o:term. pred param1-functor-for i:inductive, o:gref, o:list bool. 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). pred bo-k-args.aux i:term, i:list term, i:list term, i:term, o:term. 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:any, 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. % 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.4.0/apps/derive/elpi/param1_inhab.elpi000066400000000000000000000117071474173443600216200ustar00rootroot00000000000000/* 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.4.0/apps/derive/elpi/param1_trivial.elpi000066400000000000000000000117261474173443600222120ustar00rootroot00000000000000/* 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.4.0/apps/derive/elpi/param2.elpi000066400000000000000000000205701474173443600204560ustar00rootroot00000000000000/* Binary parametricity translation */ /* license: GNU Lesser General Public License Version 2.1 or later */ /* ------------------------------------------------------------------------- */ % Author: Cyril Cohen pred param-done i:gref. :index(3) pred param i:term, o:term, o:term. type paramR term -> term -> term -> prop. 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.4.0/apps/derive/elpi/paramX_lib.elpi000066400000000000000000000055011474173443600213470ustar00rootroot00000000000000/* 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.4.0/apps/derive/elpi/projK.elpi000066400000000000000000000126611474173443600203630ustar00rootroot00000000000000/* 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.4.0/apps/derive/elpi/tag.elpi000066400000000000000000000045111474173443600200440ustar00rootroot00000000000000/* 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.4.0/apps/derive/examples/000077500000000000000000000000001474173443600173025ustar00rootroot00000000000000coq-elpi-2.4.0/apps/derive/examples/dune000066400000000000000000000001561474173443600201620ustar00rootroot00000000000000(coq.theory (name elpi.apps.derive.examples) (theories elpi elpi.apps.derive)) (include_subdirs qualified) coq-elpi-2.4.0/apps/derive/examples/readme.v000066400000000000000000000012251474173443600207260ustar00rootroot00000000000000(* 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.4.0/apps/derive/examples/usage.v000066400000000000000000000054621474173443600206040ustar00rootroot00000000000000(** 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.4.0/apps/derive/tests/000077500000000000000000000000001474173443600166265ustar00rootroot00000000000000coq-elpi-2.4.0/apps/derive/tests/dune000066400000000000000000000002651474173443600175070ustar00rootroot00000000000000(coq.theory (name elpi.apps.derive.tests) (package coq-elpi-tests) (flags :standard -w -default-output-directory) (theories elpi elpi.apps.derive)) (include_subdirs qualified) coq-elpi-2.4.0/apps/derive/tests/test_bcongr.v000066400000000000000000000077021474173443600213340ustar00rootroot00000000000000From 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. Redirect "tmp" Check unit_bcongr_tt : reflect (tt = tt) true. Redirect "tmp" Check peano_bcongr_Zero : reflect (Zero = Zero) true. Redirect "tmp" Check peano_bcongr_Succ : forall x y b, reflect (x = y) b -> reflect (Succ x = Succ y) b. Redirect "tmp" Check option_bcongr_None : forall A, reflect (None A = None A) true. Redirect "tmp" Check option_bcongr_Some : forall A x y b, reflect (x = y) b -> reflect (Some A x = Some A y) b. Redirect "tmp" 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). Redirect "tmp" Check seq_bcongr_Nil : forall A, reflect (Nil A = Nil A) true. Redirect "tmp" 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). Redirect "tmp" Check rose_bcongr_Leaf : forall A x y b, reflect (x = y) b -> reflect (Leaf A x = Leaf A y) b. Redirect "tmp" Check rose_bcongr_Node : forall A l1 l2 b, reflect (l1 = l2) b -> reflect (Node A l1 = Node A l2) b. Redirect "tmp" Check nest_bcongr_NilN : forall A, reflect (NilN A = NilN A) true. Redirect "tmp" 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). Redirect "tmp" 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. Redirect "tmp" 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). Redirect "tmp" 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. Redirect "tmp" Check prim_int_bcongr_PI : forall x y b, reflect (x = y) b -> reflect (PI x = PI y) b. Redirect "tmp" Check prim_float_bcongr_PF : forall x y b, reflect (x = y) b -> reflect (PF x = PF y) b. (* Check large_bcongr_K1. *) Redirect "tmp" 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). Redirect "tmp" 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). Redirect "tmp" 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). Redirect "tmp" Check enum_bcongr_E1 : reflect (E1 = E1) true. Redirect "tmp" Check enum_bcongr_E2 : reflect (E2 = E2) true. Redirect "tmp" Check enum_bcongr_E3 : reflect (E3 = E3) true. coq-elpi-2.4.0/apps/derive/tests/test_derive.v000066400000000000000000000203601474173443600213330ustar00rootroot00000000000000From 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. Redirect "tmp" Check nat_eqb : nat -> nat -> bool. Redirect "tmp" Check is_nat : nat -> Type. Redirect "tmp" Check is_nat_inhab : forall x, is_nat x. Redirect "tmp" Check is_nat_functor : forall x, is_nat x -> is_nat x. Redirect "tmp" Check nat_induction : forall P, P 0 -> (forall n, P n -> P (S n)) -> forall x, is_nat x -> P x. Redirect "tmp" Check nat_tag : nat -> Numbers.BinNums.positive. Redirect "tmp" Check nat_fields_t : Numbers.BinNums.positive -> Type. Redirect "tmp" Check nat_fields : forall (n:nat), nat_fields_t (nat_tag n). Redirect "tmp" Check nat_construct : forall (p: Numbers.BinNums.positive), nat_fields_t p -> option nat. Redirect "tmp" Check nat_constructP : forall (n:nat), nat_construct (nat_tag n) (nat_fields n) = Some n. Redirect "tmp" Check nat_eqb : nat -> nat -> bool. Redirect "tmp" Check nat_eqb_correct. Redirect "tmp" Check nat_eqb_refl. (* ---------------------------------------------------- *) Elpi derive.param1 andb. (* Prelude: Elpi derive list. *) Redirect "tmp" Check list_map : forall A B, (A -> B) -> list A -> list B. Redirect "tmp" Check is_nil : forall A P, is_list A P (@nil A). Redirect "tmp" Check is_cons : forall A P x (Px : P x) tl (Ptl : is_list A P tl), is_list A P (cons x tl). Redirect "tmp" 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. Redirect "tmp" 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. Redirect "tmp" Check list_tag : forall A, list A -> Numbers.BinNums.positive. Redirect "tmp" Check list_fields_t : (Type -> Numbers.BinNums.positive -> Type). Redirect "tmp" Check list_fields : forall (A:Type) (l:list A), list_fields_t A (list_tag A l). Redirect "tmp" Check list_construct : forall (A:Type) (p: Numbers.BinNums.positive), list_fields_t A p -> option (list A). Redirect "tmp" Check list_constructP : forall (A:Type) (l:list A), list_construct A (list_tag A l) (list_fields A l) = Some l. Redirect "tmp" Check list_eqb : forall A, (A -> A -> bool) -> list A -> list A -> bool. Redirect "tmp" Check list_eqb_correct. Redirect "tmp" Check list_eqb_refl. (* ---------------------------------------------------- *) Require Vector. Elpi Print derive "elpi.apps.derive.tests/derive". #[only(eqOK), verbose] derive nat. Module Vector. derive Vector.t. End Vector. Redirect "tmp" Check Vector.t_eq : forall A, (A -> A -> bool) -> forall n, Vector.t A n -> Vector.t A n -> bool. Redirect "tmp" Check Vector.t_isk_nil : forall A n, Vector.t A n -> bool. Redirect "tmp" Check Vector.t_isk_cons : forall A n, Vector.t A n -> bool. Redirect "tmp" Check Vector.t_map : forall A B, (A -> B) -> forall n, Vector.t A n -> Vector.t B n. Redirect "tmp" Check Vector.t_getk_cons1 : forall A n, A -> forall m, Vector.t A m -> Vector.t A n -> A. Redirect "tmp" Check Vector.t_getk_cons2 : forall A n, A -> forall m, Vector.t A m -> Vector.t A n -> nat. Redirect "tmp" 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}. Redirect "tmp" Check Vector.is_t : forall A, (A -> Type) -> forall n, is_nat n -> Vector.t A n -> Type. Redirect "tmp" Check Vector.is_nil : forall A (PA : A -> Type), Vector.is_t A PA 0 is_O (Vector.nil A). Redirect "tmp" 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). Redirect "tmp" 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. Redirect "tmp" 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. Redirect "tmp" 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. Redirect "tmp" 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. derive list. derive rtree. End XXX. Fail Check XXX.rtree_is_rtree_map. Redirect "tmp" Check XXX.rtree_tag : forall A, rtree A -> Numbers.BinNums.positive. Redirect "tmp" Check XXX.rtree_fields_t : (Type -> Numbers.BinNums.positive -> Type). Redirect "tmp" Check XXX.rtree_fields : forall (A:Type) (l:rtree A), XXX.rtree_fields_t A (XXX.rtree_tag A l). Redirect "tmp" Check XXX.rtree_construct : forall (A:Type) (p: Numbers.BinNums.positive), XXX.rtree_fields_t A p -> option (rtree A). Redirect "tmp" 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. Redirect "tmp" 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. Redirect "tmp" 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). Redirect "tmp" Check Pred.Pred_to_Predinv : forall T, Pred T -> Pred.Predinv T. (* #286 *) Module Import derive_container. Unset Implicit Arguments. Import XXX. derive Inductive wimpls {A} `{rtree A} := Kwi (x:A) (y : x = x) : wimpls | Kwa. End derive_container. About wimpls.wimpls. About wimpls.Kwi. Redirect "tmp" Check Kwi _ (refl_equal 3). From Coq Require Ascii. #[only(param2)] derive Ascii.ascii. coq-elpi-2.4.0/apps/derive/tests/test_derive_stdlib.v000066400000000000000000000143621474173443600227010ustar00rootroot00000000000000(* 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.4.0/apps/derive/tests/test_derive_vector.v.skip000066400000000000000000000105731474173443600236670ustar00rootroot00000000000000From elpi.apps Require Import derive derive.projK. 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.4.0/apps/derive/tests/test_eq.v000066400000000000000000000041571474173443600204700ustar00rootroot00000000000000From 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). Redirect "tmp" Check empty_eq : eq_test empty. Redirect "tmp" Check unit_eq : eq_test unit. Redirect "tmp" Check peano_eq : eq_test peano. Redirect "tmp" Check option_eq : forall A, eq_test A -> eq_test (option A). Redirect "tmp" Check pair_eq : forall A, eq_test A -> forall B, eq_test B -> eq_test (pair A B). Redirect "tmp" Check seq_eq : forall A, eq_test A -> eq_test (seq A). Redirect "tmp" Check rose_eq : forall A, eq_test A -> eq_test (rose A). Fail Check nest_eq. Fail Check w_eq. Redirect "tmp" Check vect_eq : forall A, eq_test A -> forall i, eq_test (vect A i). Fail Check dyn_eq. Redirect "tmp" Check zeta_eq : forall A, eq_test A -> eq_test (zeta A). Redirect "tmp" Check beta_eq : forall A, eq_test A -> eq_test (beta A). Fail Check iota_eq : eq_test iota. Redirect "tmp" Check large_eq : eq_test large. Redirect "tmp" Check prim_int_eq : eq_test prim_int. Redirect "tmp" Check prim_float_eq : eq_test prim_float. Redirect "tmp" Check fo_record_eq : eq_test fo_record. Redirect "tmp" Check pa_record_eq : forall A, eq_test A -> eq_test (pa_record A). Redirect "tmp" Check pr_record_eq : forall A, eq_test A -> eq_test (pr_record A). Redirect "tmp" Check enum_eq : eq_test enum. coq-elpi-2.4.0/apps/derive/tests/test_eqK.v000066400000000000000000000063621474173443600206030ustar00rootroot00000000000000From 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. Redirect "tmp" Check eq_axiom_tt : eq_axiom_at unit unit_eq tt. Redirect "tmp" Check eq_axiom_Zero : eq_axiom_at peano peano_eq Zero. Redirect "tmp" Check eq_axiom_Succ : forall y, eq_axiom_at peano peano_eq y -> eq_axiom_at peano peano_eq (Succ y). Redirect "tmp" Check eq_axiom_None : forall A f, eq_axiom_at (option A) (option_eq A f) (None A). Redirect "tmp" 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). Redirect "tmp" 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). Redirect "tmp" Check eq_axiom_Nil: forall A f, eq_axiom_at (seq A) (seq_eq A f) (Nil A). Redirect "tmp" 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). Redirect "tmp" 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). Redirect "tmp" 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). Redirect "tmp" Check eq_axiom_Envelope. Redirect "tmp" Check eq_axiom_Redex. (*Check eq_axiom_K1.*) Redirect "tmp" Check eq_axiom_PI. Redirect "tmp" Check eq_axiom_PF. Redirect "tmp" 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). Redirect "tmp" 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). Redirect "tmp" 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). Redirect "tmp" Check eq_axiom_E1 : eq_axiom_at enum enum_eq E1. Redirect "tmp" Check eq_axiom_E2 : eq_axiom_at enum enum_eq E2. Redirect "tmp" Check eq_axiom_E3 : eq_axiom_at enum enum_eq E3. coq-elpi-2.4.0/apps/derive/tests/test_eqOK.v000066400000000000000000000061541474173443600207210ustar00rootroot00000000000000From 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). Redirect "tmp" Check empty_eq_OK : ok empty empty_eq. Redirect "tmp" Check unit_eq_OK : ok unit unit_eq. Redirect "tmp" Check peano_eq_OK : ok peano peano_eq. Redirect "tmp" Check option_eq_OK : forall A f, ok A f -> ok (option A) (option_eq A f). Redirect "tmp" 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). Redirect "tmp" Check seq_eq_OK : forall A f, ok A f -> ok (seq A) (seq_eq A f). Redirect "tmp" 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. Redirect "tmp" Check zeta_eq_OK : forall A f, ok A f -> ok (zeta A) (zeta_eq A f). Redirect "tmp" 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. *) Redirect "tmp" Check prim_int_eq_OK. Fail Check prim_float_eq_OK. Redirect "tmp" Check fo_record_eq_OK : ok fo_record fo_record_eq. Redirect "tmp" Check pa_record_eq_OK : forall A f, ok A f -> ok (pa_record A) (pa_record_eq A f). Redirect "tmp" Check pr_record_eq_OK : forall A f, ok A f -> ok (pr_record A) (pr_record_eq A f). Redirect "tmp" 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. Redirect "tmp" 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.4.0/apps/derive/tests/test_eqType_ast.v000066400000000000000000000030231474173443600221700ustar00rootroot00000000000000From 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.4.0/apps/derive/tests/test_eqb.v000066400000000000000000000053601474173443600206270ustar00rootroot00000000000000From 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). Redirect "tmp" Check empty_eqb : eq_test empty. Redirect "tmp" Check unit_eqb : eq_test unit. Redirect "tmp" Check peano_eqb : eq_test peano. Redirect "tmp" Check option_eqb : forall A, eq_test A -> eq_test (option A). Redirect "tmp" Check pair_eqb : forall A, eq_test A -> forall B, eq_test B -> eq_test (pair A B). Redirect "tmp" Check seq_eqb : forall A, eq_test A -> eq_test (seq A). Redirect "tmp" 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). Redirect "tmp" 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*) Redirect "tmp" Check prim_int_eqb : eq_test prim_int. Fail Check prim_float_eqb : eq_test prim_float. Redirect "tmp" Check fo_record_eqb : eq_test fo_record. Redirect "tmp" Check pa_record_eqb : forall A, eq_test A -> eq_test (pa_record A). Redirect "tmp" Check pr_record_eqb : forall A, eq_test A -> eq_test (pr_record A). Redirect "tmp" Check enum_eqb : eq_test enum. Redirect "tmp" Check sigma_bool_eqb : eq_test sigma_bool. Redirect "tmp" Check ord_eqb : forall p1 p2, eq_test2 (ord p1) (ord p2). Redirect "tmp" Check ord2_eqb : forall p1 p2, eq_test2 (ord2 p1) (ord2 p2). Redirect "tmp" Check val_eqb : eq_test val. Redirect "tmp" Check alias_eqb : eq_test alias. coq-elpi-2.4.0/apps/derive/tests/test_eqbOK.v000066400000000000000000000031221474173443600210530ustar00rootroot00000000000000From 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. Redirect "tmp" Check peano_eqb_OK : forall n m, Bool.reflect (n = m) (peano_eqb n m). Redirect "tmp" 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). Redirect "tmp" Check ord_eqb_OK : forall n (o1 o2 : ord n), Bool.reflect (o1 = o2) (ord_eqb n n o1 o2). Redirect "tmp" Check alias_eqb_OK : forall x y : alias, Bool.reflect (x = y) (alias_eqb x y). coq-elpi-2.4.0/apps/derive/tests/test_eqbcorrect.v000066400000000000000000000051731474173443600222130ustar00rootroot00000000000000From 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. Redirect "tmp" Check peano_eqb_correct : forall n m, peano_eqb n m = true -> n = m. Redirect "tmp" Check peano_eqb_refl : forall n, peano_eqb n n = true. Redirect "tmp" Check ord_eqb_correct : forall n, eqb_correct (ord_eqb n n). Redirect "tmp" Check ord_eqb_refl : forall n, eqb_reflexive (ord_eqb n n). Redirect "tmp" Check ord2_eqb_correct : forall n, eqb_correct (ord2_eqb n n). Redirect "tmp" Check ord2_eqb_refl : forall n, eqb_reflexive (ord2_eqb n n). Redirect "tmp" Check val_eqb_correct : eqb_correct val_eqb. Redirect "tmp" Check val_eqb_refl : eqb_reflexive val_eqb. Redirect "tmp" Check alias_eqb_correct : eqb_correct alias_eqb. Redirect "tmp" Check alias_eqb_refl : eqb_reflexive alias_eqb. coq-elpi-2.4.0/apps/derive/tests/test_eqcorrect.v000066400000000000000000000057751474173443600220610ustar00rootroot00000000000000From 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). Redirect "tmp" Check empty_eq_correct : correct empty is_empty empty_eq. Redirect "tmp" Check unit_eq_correct : correct unit is_unit unit_eq. Redirect "tmp" Check peano_eq_correct : correct peano is_peano peano_eq. Redirect "tmp" Check option_eq_correct : forall A f, correct (option A) (is_option A (eq_axiom_at A f)) (option_eq A f). Redirect "tmp" 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). Redirect "tmp" Check seq_eq_correct : forall A f, correct (seq A) (is_seq A (eq_axiom_at A f)) (seq_eq A f). Redirect "tmp" 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. Redirect "tmp" Check zeta_eq_correct : forall A f, correct (zeta A) (is_zeta A (eq_axiom_at A f)) (zeta_eq A f). Redirect "tmp" 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. *) Redirect "tmp" Check prim_int_eq_correct. Fail Check prim_float_eq_correct. Redirect "tmp" Check fo_record_eq_correct : correct fo_record is_fo_record fo_record_eq. Redirect "tmp" 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). Redirect "tmp" 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). Redirect "tmp" Check enum_eq_correct : correct enum is_enum enum_eq. coq-elpi-2.4.0/apps/derive/tests/test_fields.v000066400000000000000000000246731474173443600213360ustar00rootroot00000000000000From 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. Redirect "tmp" Check empty_fields_t : positive -> Type. Redirect "tmp" Check empty_fields : forall (n:empty), empty_fields_t (empty_tag n). Redirect "tmp" Check empty_construct : forall (p: positive), empty_fields_t p -> Datatypes.option empty. Redirect "tmp" Check empty_constructP : forall (n:empty), empty_construct (empty_tag n) (empty_fields n) = Datatypes.Some n. Redirect "tmp" Check unit_fields_t : positive -> Type. Redirect "tmp" Check unit_fields : forall (n:unit), unit_fields_t (unit_tag n). Redirect "tmp" Check unit_construct : forall (p: positive), unit_fields_t p -> Datatypes.option unit. Redirect "tmp" Check unit_constructP : forall (n:unit), unit_construct (unit_tag n) (unit_fields n) = Datatypes.Some n. Redirect "tmp" Check peano_fields_t : positive -> Type. Redirect "tmp" Check peano_fields : forall (n:peano), peano_fields_t (peano_tag n). Redirect "tmp" Check peano_construct : forall (p: positive), peano_fields_t p -> Datatypes.option peano. Redirect "tmp" Check peano_constructP : forall (n:peano), peano_construct (peano_tag n) (peano_fields n) = Datatypes.Some n. Redirect "tmp" Check option_fields_t : Type -> Numbers.BinNums.positive -> Type. Redirect "tmp" Check option_fields : forall (A:Type) (l:option A), option_fields_t A (option_tag A l). Redirect "tmp" Check option_construct : forall (A:Type) (p: Numbers.BinNums.positive), option_fields_t A p -> Datatypes.option (option A). Redirect "tmp" Check option_constructP : forall (A:Type) (l:option A), option_construct A (option_tag A l) (option_fields A l) = Datatypes.Some l. Redirect "tmp" Check pair_fields_t : Type -> Type -> Numbers.BinNums.positive -> Type. Redirect "tmp" Check pair_fields : forall (A B :Type) (l:pair A B), pair_fields_t A B (pair_tag A B l). Redirect "tmp" Check pair_construct : forall (A B:Type) (p: Numbers.BinNums.positive), pair_fields_t A B p -> Datatypes.option (pair A B). Redirect "tmp" 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. Redirect "tmp" Check seq_fields_t : Type -> Numbers.BinNums.positive -> Type. Redirect "tmp" Check seq_fields : forall (A:Type) (l:seq A), seq_fields_t A (seq_tag A l). Redirect "tmp" Check seq_construct : forall (A:Type) (p: Numbers.BinNums.positive), seq_fields_t A p -> Datatypes.option (seq A). Redirect "tmp" Check seq_constructP : forall (A:Type) (l:seq A), seq_construct A (seq_tag A l) (seq_fields A l) = Datatypes.Some l. Redirect "tmp" Check rose_fields_t : Type -> Numbers.BinNums.positive -> Type. Redirect "tmp" Check rose_fields : forall (A:Type) (l:rose A), rose_fields_t A (rose_tag A l). Redirect "tmp" Check rose_construct : forall (A:Type) (p: Numbers.BinNums.positive), rose_fields_t A p -> Datatypes.option (rose A). Redirect "tmp" 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. Redirect "tmp" Check beta_fields_t : Type -> Numbers.BinNums.positive -> Type. Redirect "tmp" Check beta_fields : forall (A:Type) (l:beta A), beta_fields_t A (beta_tag A l). Redirect "tmp" Check beta_construct : forall (A:Type) (p: Numbers.BinNums.positive), beta_fields_t A p -> Datatypes.option (beta A). Redirect "tmp" 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. Redirect "tmp" Check large_fields_t : positive -> Type. Redirect "tmp" Check large_fields : forall (n:large), large_fields_t (large_tag n). Redirect "tmp" Check large_construct : forall (p: positive), large_fields_t p -> Datatypes.option large. Redirect "tmp" Check large_constructP : forall (n:large), large_construct (large_tag n) (large_fields n) = Datatypes.Some n. Redirect "tmp" Check prim_int_fields_t : positive -> Type. Redirect "tmp" Check prim_int_fields : forall (n:prim_int), prim_int_fields_t (prim_int_tag n). Redirect "tmp" Check prim_int_construct : forall (p: positive), prim_int_fields_t p -> Datatypes.option prim_int. Redirect "tmp" 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. Redirect "tmp" Check pa_record_fields_t : Type -> Numbers.BinNums.positive -> Type. Redirect "tmp" Check pa_record_fields : forall (A:Type) (l:pa_record A), pa_record_fields_t A (pa_record_tag A l). Redirect "tmp" Check pa_record_construct : forall (A:Type) (p: Numbers.BinNums.positive), pa_record_fields_t A p -> Datatypes.option (pa_record A). Redirect "tmp" 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. Redirect "tmp" Check pr_record_fields_t : Type -> Numbers.BinNums.positive -> Type. Redirect "tmp" Check pr_record_fields : forall (A:Type) (l:pr_record A), pr_record_fields_t A (pr_record_tag A l). Redirect "tmp" Check pr_record_construct : forall (A:Type) (p: Numbers.BinNums.positive), pr_record_fields_t A p -> Datatypes.option (pr_record A). Redirect "tmp" 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. Redirect "tmp" Check sigma_bool_fields_t : Numbers.BinNums.positive -> Type. Redirect "tmp" Check sigma_bool_fields : forall (l:sigma_bool), sigma_bool_fields_t (sigma_bool_tag l). Redirect "tmp" Check sigma_bool_construct : forall (p: Numbers.BinNums.positive), sigma_bool_fields_t p -> Datatypes.option sigma_bool. Redirect "tmp" Check sigma_bool_constructP : forall (l:sigma_bool), sigma_bool_construct (sigma_bool_tag l) (sigma_bool_fields l) = Datatypes.Some l. Redirect "tmp" Check ord_fields_t : peano -> Numbers.BinNums.positive -> Type. Redirect "tmp" Check ord_fields : forall (p:peano) (o:ord p), ord_fields_t p (ord_tag p o). Redirect "tmp" Check ord_construct : forall (n:peano) (p:Numbers.BinNums.positive), ord_fields_t n p -> Datatypes.option (ord n). Redirect "tmp" Check ord_constructP : forall (p:peano) (o:ord p), ord_construct p (ord_tag p o) (ord_fields p o) = Datatypes.Some o. Redirect "tmp" Check ord2_fields_t : peano -> Numbers.BinNums.positive -> Type. Redirect "tmp" Check ord2_fields : forall (p:peano) (o:ord2 p), ord2_fields_t p (ord2_tag p o). Redirect "tmp" Check ord2_construct : forall (n:peano) (p:Numbers.BinNums.positive), ord2_fields_t n p -> Datatypes.option (ord2 n). Redirect "tmp" Check ord2_constructP : forall (p:peano) (o:ord2 p), ord2_construct p (ord2_tag p o) (ord2_fields p o) = Datatypes.Some o. Redirect "tmp" Check val_fields_t : Numbers.BinNums.positive -> Type. Redirect "tmp" Check val_fields : forall i : val, val_fields_t (val_tag i). Redirect "tmp" Check val_construct : forall (p: Numbers.BinNums.positive), val_fields_t p -> Datatypes.option val. Redirect "tmp" Check val_constructP : forall (v:val), val_construct (val_tag v) (val_fields v) = Datatypes.Some v. coq-elpi-2.4.0/apps/derive/tests/test_idx2inv.v000066400000000000000000000004231474173443600214360ustar00rootroot00000000000000From 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. Redirect "tmp" 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.4.0/apps/derive/tests/test_induction.v000066400000000000000000000107161474173443600220550ustar00rootroot00000000000000From 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. Redirect "tmp" Check empty_induction : forall P : empty -> Prop, forall x, is_empty x -> P x. Redirect "tmp" Check unit_induction : forall P : unit -> Prop, P tt -> forall x, is_unit x -> P x. Redirect "tmp" Check peano_induction : forall P, P Zero -> (forall n, P n -> P (Succ n)) -> forall x, is_peano x -> P x. Redirect "tmp" 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. Redirect "tmp" 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. Redirect "tmp" 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. Redirect "tmp" 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. Redirect "tmp" 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. Redirect "tmp" 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. Redirect "tmp" 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. Redirect "tmp" Check dyn_induction : forall P, (forall T PT (t : T), PT t -> P (box T t)) -> forall x, is_dyn x -> P x. Redirect "tmp" 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. Redirect "tmp" Check iota_induction. Redirect "tmp" Check large_induction. Redirect "tmp" Check prim_int_induction. Redirect "tmp" Check prim_float_induction. Redirect "tmp" 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. Redirect "tmp" 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. Redirect "tmp" 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. Redirect "tmp" 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. Redirect "tmp" Check enum_induction : forall P, (P E1) -> (P E2) -> (P E3) -> forall x, is_enum x -> P x. Redirect "tmp" Check sigma_bool_induction. Redirect "tmp" 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. Redirect "tmp" 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.4.0/apps/derive/tests/test_invert.v000066400000000000000000000011531474173443600213630ustar00rootroot00000000000000From 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. Redirect "tmp" Check test_inv : Type -> bool -> Type. Redirect "tmp" Check K1_inv : forall A b, b = true -> test_inv A b. Redirect "tmp" 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.4.0/apps/derive/tests/test_isK.v000066400000000000000000000046141474173443600206070ustar00rootroot00000000000000From 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. Redirect "tmp" Check unit_is_tt : unit -> bool. Redirect "tmp" Check peano_is_Zero : peano -> bool. Redirect "tmp" Check peano_is_Succ : peano -> bool. Redirect "tmp" Check option_is_None : forall A, option A -> bool. Redirect "tmp" Check option_is_Some : forall A, option A -> bool. Redirect "tmp" Check pair_is_Comma : forall A B, pair A B -> bool. Redirect "tmp" Check seq_is_Nil : forall A, seq A -> bool. Redirect "tmp" Check seq_is_Cons : forall A, seq A -> bool. Redirect "tmp" Check rose_is_Leaf : forall A, rose A -> bool. Redirect "tmp" Check rose_is_Node : forall A, rose A -> bool. Redirect "tmp" Check nest_is_NilN : forall A, nest A -> bool. Redirect "tmp" Check nest_is_ConsN : forall A, nest A -> bool. Redirect "tmp" Check w_is_via : forall A, w A -> bool. Redirect "tmp" Check vect_is_VNil : forall A i, vect A i -> bool. Redirect "tmp" Check vect_is_VCons : forall A i, vect A i -> bool. Redirect "tmp" Check dyn_is_box : dyn -> bool. Redirect "tmp" Check zeta_is_Envelope : forall A, zeta A -> bool. Redirect "tmp" Check beta_is_Redex : forall A, beta A -> bool. Redirect "tmp" Check iota_is_Why : iota -> bool. Redirect "tmp" Check large_is_K1. Redirect "tmp" Check large_is_K2. Redirect "tmp" Check prim_int_is_PI. Redirect "tmp" Check prim_float_is_PF. Redirect "tmp" Check fo_record_is_Build_fo_record : fo_record -> bool. Redirect "tmp" Check pa_record_is_Build_pa_record : forall A, pa_record A -> bool. Redirect "tmp" Check pr_record_is_Build_pr_record : forall A, pr_record A -> bool. Redirect "tmp" Check enum_is_E1 : enum -> bool. coq-elpi-2.4.0/apps/derive/tests/test_lens.v000066400000000000000000000026531474173443600210230ustar00rootroot00000000000000From 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. Redirect "tmp" Check _f1 : Lens fo_record fo_record peano peano. Redirect "tmp" Check _f2 : Lens fo_record fo_record unit unit. Redirect "tmp" Check @_f3 : forall A, Lens (pa_record A) (pa_record A) peano peano. Redirect "tmp" Check @_f4 : forall A, Lens (pa_record A) (pa_record A) A A. Redirect "tmp" Check @_pf3 : forall A, Lens (pr_record A) (pr_record A) peano peano. Redirect "tmp" 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.4.0/apps/derive/tests/test_lens_laws.v000066400000000000000000000035551474173443600220530ustar00rootroot00000000000000 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. Redirect "tmp" Check _f1_view_set : view_set _f1. Redirect "tmp" Check _f2_view_set : view_set _f2. Redirect "tmp" Check _f3_view_set : forall A, view_set (_f3 A). Redirect "tmp" Check _f4_view_set : forall A, view_set (_f4 A). Redirect "tmp" Check _pf3_view_set : forall A, view_set (_pf3 A). Redirect "tmp" Check _pf4_view_set : forall A, view_set (_pf4 A). Redirect "tmp" Check _f1_set_set : set_set _f1. Redirect "tmp" Check _f2_set_set : set_set _f2. Redirect "tmp" Check _f3_set_set : forall A, set_set (_f3 A). Redirect "tmp" Check _f4_set_set : forall A, set_set (_f4 A). Redirect "tmp" Check _pf3_set_set : forall A, set_set (_pf3 A). Redirect "tmp" Check _pf4_set_set : forall A, set_set (_pf4 A). Redirect "tmp" Check _f1_set_view : set_view _f1. Redirect "tmp" Check _f2_set_view : set_view _f2. Redirect "tmp" Check _f3_set_view : forall A, set_view (_f3 A). Redirect "tmp" Check _f4_set_view : forall A, set_view (_f4 A). Redirect "tmp" Check _pf3_set_view : forall A, set_view (_pf3 A). Redirect "tmp" Check _pf4_set_view : forall A, set_view (_pf4 A). Redirect "tmp" Check _f1_f2_exchange : exchange _f1 _f2. Redirect "tmp" Check _f2_f1_exchange : exchange _f2 _f1. Redirect "tmp" Check _f3_f4_exchange : forall A, exchange (_f3 A) (_f4 A). Redirect "tmp" Check _f4_f3_exchange : forall A, exchange (_f4 A) (_f3 A). Redirect "tmp" Check _pf3_pf4_exchange : forall A, exchange (_pf3 A) (_pf4 A). Redirect "tmp" Check _pf4_pf3_exchange : forall A, exchange (_pf4 A) (_pf3 A). coq-elpi-2.4.0/apps/derive/tests/test_map.v000066400000000000000000000036261474173443600206400ustar00rootroot00000000000000From 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). Redirect "tmp" Check empty_map : map empty. Redirect "tmp" Check unit_map : map unit. Redirect "tmp" Check peano_map : map peano. Redirect "tmp" Check option_map : map1 option. Redirect "tmp" Check pair_map : forall A B (f : A -> B) C D (g : C -> D), (pair A C) -> (pair B D). Redirect "tmp" Check seq_map : map1 seq. Redirect "tmp" Check rose_map : map1 rose. Fail Check nest_map. Fail Check w_map. Redirect "tmp" Check vect_map : forall A B (f : A -> B) i, vect A i -> vect B i. Redirect "tmp" Check dyn_map : map dyn. Redirect "tmp" Check zeta_map : forall A B (f : A -> B), zeta A -> zeta B. Fail Check beta_map. Redirect "tmp" Check iota_map : map iota. Redirect "tmp" Check large_map : map large. Redirect "tmp" Check prim_int_map : map prim_int. Redirect "tmp" Check prim_float_map : map prim_float. Redirect "tmp" Check pa_record_map : map1 pa_record. Redirect "tmp" Check pr_record_map : map1 pr_record. coq-elpi-2.4.0/apps/derive/tests/test_param1.v000066400000000000000000000131051474173443600212350ustar00rootroot00000000000000From 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). Redirect "tmp" Check is_empty : pred empty. Redirect "tmp" Check is_unit : pred unit. Redirect "tmp" Check is_peano : pred peano. Redirect "tmp" Check is_option : forall A, pred A -> pred (option A). Redirect "tmp" Check is_pair : forall A, pred A -> forall B, pred B -> pred (pair A B). Redirect "tmp" Check is_seq : forall A, pred A -> pred (seq A). Redirect "tmp" Check is_rose : forall A, pred A -> pred (rose A). Redirect "tmp" Check is_nest : forall A, pred A -> pred (nest A). Redirect "tmp" Check is_w : forall A, pred A -> pred (w A). Redirect "tmp" Check is_vect : forall A, pred A -> forall i, is_peano i -> pred (vect A i). Redirect "tmp" Check is_dyn : pred dyn. Redirect "tmp" Check is_zeta : forall A, pred A -> pred (zeta A). Redirect "tmp" Check is_beta : forall A, pred A -> pred (beta A). Redirect "tmp" Check is_iota : pred iota. Redirect "tmp" Check is_large : pred large. Redirect "tmp" Check is_prim_int : pred prim_int. Redirect "tmp" Check is_prim_float : pred prim_float. Redirect "tmp" Check is_fo_record : pred fo_record. Redirect "tmp" Check is_pa_record : forall A, pred A -> pred (pa_record A). Redirect "tmp" Check is_pr_record : forall A, pred A -> pred (pr_record A). Redirect "tmp" Check is_enum : pred enum. Redirect "tmp" Check is_ord : forall (p : peano) (pa : is_peano p), pred (ord p). Redirect "tmp" Check is_ord2 : forall (p : peano) (pa : is_peano p), pred (ord2 p). Redirect "tmp" 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. Redirect "tmp" Elpi Query derive.param1 lp:{{ reali {{O}} Y }}. Redirect "tmp" 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. Redirect "tmp" Check (is_pred : is_nat2nat pred). Fixpoint predn n := match n with 0 => 0 | S n => S (predn n) end. Elpi derive.param1 predn. Redirect "tmp" Check (is_predn : is_nat2nat predn). Redirect "tmp" 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. Redirect "tmp" Elpi Query derive.param1 lp:{{ coq.TC.db-for {coq.term->gref {{@reali_db}}} PDb }}. #[warning="-non-recursive"] 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 "elpi.apps.derive.tests/derive.param1". #[warning="-non-recursive"] 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.4.0/apps/derive/tests/test_param1_congr.v000066400000000000000000000067431474173443600224370ustar00rootroot00000000000000From 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. Redirect "tmp" Check congr_is_tt : is_tt = is_tt. Redirect "tmp" Check congr_is_Zero : is_Zero = is_Zero. Redirect "tmp" Check congr_is_Succ : forall x p1 p2, p1 = p2 -> is_Succ x p1 = is_Succ x p2. Redirect "tmp" Check congr_is_None : forall A PA, is_None A PA = is_None A PA. Redirect "tmp" Check congr_is_Some : forall A PA x p1 p2, p1 = p2 -> is_Some A PA x p1 = is_Some A PA x p2. Redirect "tmp" 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. Redirect "tmp" Check congr_is_Nil : forall A PA, is_Nil A PA = is_Nil A PA. Redirect "tmp" 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. Redirect "tmp" Check congr_is_Leaf : forall A PA x p1 p2, p1 = p2 -> is_Leaf A PA x p1 = is_Leaf A PA x p2. Redirect "tmp" 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. Redirect "tmp" Check congr_is_via : forall A PA x p1 p2, p1 = p2 -> is_via A PA x p1 = is_via A PA x p2. Redirect "tmp" 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. Redirect "tmp" 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. Redirect "tmp" 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 . *) Redirect "tmp" Check congr_is_PI. Redirect "tmp" Check congr_is_PF. Redirect "tmp" 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. Redirect "tmp" 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. Redirect "tmp" 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. Redirect "tmp" Check congr_is_E1 : is_E1 = is_E1. coq-elpi-2.4.0/apps/derive/tests/test_param1_functor.v000066400000000000000000000061661474173443600230060ustar00rootroot00000000000000From 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. Redirect "tmp" Check is_empty_functor : func is_empty. Redirect "tmp" Check is_unit_functor : func is_unit. Redirect "tmp" Check is_peano_functor : func is_peano. Redirect "tmp" Check is_option_functor : func1 is_option. Redirect "tmp" Check is_pair_functor : func2 is_pair. Redirect "tmp" Check is_seq_functor : func1 is_seq. Redirect "tmp" Check is_rose_functor : func1 is_rose. Fail Check is_nest_functor : func1 is_nest. Fail Check is_w_functor. Redirect "tmp" 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. Redirect "tmp" Check is_dyn_functor : func is_dyn. Redirect "tmp" Check is_zeta_functor : func1 is_zeta. Redirect "tmp" Check is_beta_functor : func1 is_beta. Redirect "tmp" Check is_iota_functor : func is_iota. Redirect "tmp" Check is_large_functor : func is_large. Redirect "tmp" Check is_prim_int_functor : func is_prim_int. Redirect "tmp" Check is_prim_float_functor : func is_prim_float. Redirect "tmp" Check is_fo_record_functor : func is_fo_record. Redirect "tmp" Check is_pa_record_functor : func1 is_pa_record. Redirect "tmp" Check is_pr_record_functor : func1 is_pr_record. Redirect "tmp" Check is_enum_functor : func is_enum. Redirect "tmp" Check is_ord_functor : forall n pn, func (is_ord n pn). Redirect "tmp" Check is_ord2_functor : forall n pn, func (is_ord2 n pn). Redirect "tmp" Check is_val_functor : func is_val. coq-elpi-2.4.0/apps/derive/tests/test_param1_trivial.v000066400000000000000000000123131474173443600227670ustar00rootroot00000000000000From 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. Redirect "tmp" Check is_empty_trivial : trivial empty is_empty. Redirect "tmp" Check is_unit_trivial : trivial unit is_unit. Redirect "tmp" Check is_peano_trivial : trivial peano is_peano. Redirect "tmp" Check is_option_trivial : forall A P, trivial A P -> trivial (option A) (is_option A P). Redirect "tmp" 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). Redirect "tmp" Check is_seq_trivial : forall A P, trivial A P -> trivial (seq A) (is_seq A P). Redirect "tmp" 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. Redirect "tmp" Check is_zeta_trivial : forall A P, trivial A P -> trivial (zeta A) (is_zeta A P). Redirect "tmp" Check is_beta_trivial : forall A P, trivial A P -> trivial (beta A) (is_beta A P). Fail Check is_iota_trivial. Redirect "tmp" Check is_large_trivial : trivial large is_large. Redirect "tmp" Check is_prim_int_trivial : trivial prim_int is_prim_int. Redirect "tmp" Check is_prim_float_trivial : trivial prim_float is_prim_float. Redirect "tmp" Check is_fo_record_trivial : trivial fo_record is_fo_record. Redirect "tmp" Check is_pa_record_trivial : forall A P, trivial A P -> trivial (pa_record A) (is_pa_record A P). Redirect "tmp" Check is_pr_record_trivial : forall A P, trivial A P -> trivial (pr_record A) (is_pr_record A P). Redirect "tmp" Check is_enum_trivial : trivial enum is_enum. Redirect "tmp" Check is_sigma_bool_trivial : trivial sigma_bool is_sigma_bool. Redirect "tmp" Check is_ord_trivial : forall p px, trivial (ord p) (is_ord p px). Redirect "tmp" Check is_ord2_trivial : forall p px, trivial (ord2 p) (is_ord2 p px). Redirect "tmp" Check is_val_trivial : trivial val is_val. Redirect "tmp" Check is_empty_inhab : full empty is_empty. Redirect "tmp" Check is_unit_inhab : full unit is_unit. Redirect "tmp" Check is_peano_inhab : full peano is_peano. Redirect "tmp" Check is_option_inhab : forall A P, full A P -> full (option A) (is_option A P). Redirect "tmp" 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). Redirect "tmp" Check is_seq_inhab : forall A P, full A P -> full (seq A) (is_seq A P). Redirect "tmp" 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. Redirect "tmp" Check is_zeta_inhab : forall A P, full A P -> full (zeta A) (is_zeta A P). Redirect "tmp" Check is_beta_inhab : forall A P, full A P -> full (beta A) (is_beta A P). Fail Check is_iota_inhab. Redirect "tmp" Check is_large_inhab : full large is_large. Redirect "tmp" Check is_prim_int_inhab : full prim_int is_prim_int. Redirect "tmp" Check is_prim_float_inhab : full prim_float is_prim_float. Redirect "tmp" Check is_fo_record_inhab : full fo_record is_fo_record. Redirect "tmp" Check is_pa_record_inhab : forall A P, full A P -> full (pa_record A) (is_pa_record A P). Redirect "tmp" Check is_pr_record_inhab : forall A P, full A P -> full (pr_record A) (is_pr_record A P). Redirect "tmp" Check is_enum_inhab : full enum is_enum. Redirect "tmp" Check is_sigma_bool_inhab : full sigma_bool is_sigma_bool. Redirect "tmp" Check is_ord_inhab : forall p px, full (ord p) (is_ord p px). Redirect "tmp" Check is_ord2_inhab : forall p px, full (ord2 p) (is_ord2 p px). Redirect "tmp" Check is_val_inhab : full val is_val. coq-elpi-2.4.0/apps/derive/tests/test_param2.v000066400000000000000000000047621474173443600212470ustar00rootroot00000000000000From 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. Redirect "tmp" 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. Redirect "tmp" Check (predn_R : nat2nat_R predn predn). Redirect "tmp" 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.4.0/apps/derive/tests/test_projK.v000066400000000000000000000064461474173443600211530ustar00rootroot00000000000000From 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. Redirect "tmp" Check projSucc1 : peano -> peano -> peano. Redirect "tmp" Check projSome1 : forall A, A -> option A -> A. Redirect "tmp" Check projComma1 : forall A B, A -> B -> pair A B -> A. Redirect "tmp" Check projComma2 : forall A B, A -> B -> pair A B -> B. Redirect "tmp" Check projCons1 : forall A, A -> seq A -> seq A -> A. Redirect "tmp" Check projCons2 : forall A, A -> seq A -> seq A -> seq A. Redirect "tmp" Check projLeaf1 : forall A, A -> rose A -> A. Redirect "tmp" Check projNode1 : forall A, seq (rose A) -> rose A -> seq (rose A). Redirect "tmp" Check projConsN1 : forall A, A -> nest (pair A A) -> nest A -> A. Redirect "tmp" Check projConsN2 : forall A, A -> nest (pair A A) -> nest A -> nest (pair A A). Redirect "tmp" Check projvia1 : forall A, (A -> w A) -> w A -> (A -> w A). Redirect "tmp" Check projVCons1 : forall A i, A -> forall j, vect A j -> vect A i -> A. Redirect "tmp" Check projVCons2 : forall A i, A -> forall j, vect A j -> vect A i -> peano. Redirect "tmp" Check projVCons3 : forall A i, A -> forall j, vect A j -> vect A i -> { w & vect A w }. Redirect "tmp" Check projbox1 : forall T, T -> dyn -> Type. Redirect "tmp" Check projbox2 : forall T, T -> dyn -> { T : Type & T }. Redirect "tmp" Check projEnvelope1 : forall A, A -> A -> zeta A -> A. Redirect "tmp" Check eq_refl 0 : projEnvelope1 nat 1 1 (Envelope nat 0 1) = 0. Redirect "tmp" Check projEnvelope2 : forall A, A -> A -> zeta A -> A. Redirect "tmp" Check eq_refl 0 : projEnvelope2 nat 1 1 (Envelope nat 1 0) = 0. Redirect "tmp" Check projRedex1 : forall A, A -> beta A -> A. Redirect "tmp" Check projWhy1 : forall n : peano, match n return Type with | Zero => peano | Succ _ => unit end -> iota -> peano. Redirect "tmp" 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 }. Redirect "tmp" Check projPI1. Redirect "tmp" Check projPF1. Redirect "tmp" Check projBuild_fo_record1 : peano -> unit -> fo_record -> peano. Redirect "tmp" Check projBuild_fo_record2 : peano -> unit -> fo_record -> unit. Redirect "tmp" Check projBuild_pa_record2 : forall A, peano -> A -> pa_record A -> A. Redirect "tmp" Check projBuild_pr_record2 : forall A, peano -> A -> pr_record A -> A. coq-elpi-2.4.0/apps/derive/tests/test_readme.v000066400000000000000000000047321474173443600213170ustar00rootroot00000000000000From 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.4.0/apps/derive/tests/test_tag.v000066400000000000000000000041301474173443600206250ustar00rootroot00000000000000From 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). Redirect "tmp" Check empty_tag : tag empty. Redirect "tmp" Check unit_tag : tag unit. Redirect "tmp" Check peano_tag : tag peano. Redirect "tmp" Check option_tag : forall A, tag (option A). Redirect "tmp" Check pair_tag : forall A B, tag (pair A B). Redirect "tmp" Check seq_tag : forall A, tag (seq A). Redirect "tmp" Check rose_tag : forall A, tag (rose A). Redirect "tmp" Check nest_tag : forall A, tag (nest A). Redirect "tmp" Check w_tag : forall A, tag (w A). Redirect "tmp" Check vect_tag : forall A i, tag (vect A i). Redirect "tmp" Check dyn_tag : tag dyn. Fail Check zeta_tag : forall A, tag (zeta A). Redirect "tmp" Check beta_tag : forall A, tag (beta A). Redirect "tmp" Check iota_tag : tag iota. Redirect "tmp" Check large_tag : tag large. Redirect "tmp" Check prim_int_tag : tag prim_int. Redirect "tmp" Check prim_float_tag : tag prim_float. Redirect "tmp" Check pa_record_tag : forall A, tag (pa_record A). Redirect "tmp" Check pr_record_tag : forall A, tag (pr_record A). Redirect "tmp" Check ord_tag : forall p : peano, tag (ord p). Redirect "tmp" Check ord2_tag : forall p : peano, tag (ord2 p). Redirect "tmp" Check val_tag : tag val. coq-elpi-2.4.0/apps/derive/theories/000077500000000000000000000000001474173443600173065ustar00rootroot00000000000000coq-elpi-2.4.0/apps/derive/theories/derive.v000066400000000000000000000072051474173443600207570ustar00rootroot00000000000000(* 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.elpi Extra Dependency "derive_hook.elpi" as derive_hook. From elpi.apps.derive.elpi Extra Dependency "derive_synterp_hook.elpi" as derive_synterp_hook. From elpi.apps.derive.elpi Extra Dependency "derive.elpi" as derive. From elpi.apps.derive.elpi Extra Dependency "derive_synterp.elpi" as derive_synterp. From elpi Require Import elpi. Elpi File derive.lib lp:{{ % if a derivation fails it should end by calling stop, instead of coq.error, % so that derive can make the failure non fatal type stop string -> prop. }}. 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 Export derive. coq-elpi-2.4.0/apps/derive/theories/derive/000077500000000000000000000000001474173443600205645ustar00rootroot00000000000000coq-elpi-2.4.0/apps/derive/theories/derive/bcongr.v000066400000000000000000000041721474173443600222310ustar00rootroot00000000000000(* Generates congruence lemmas using reflect license: GNU Lesser General Public License Version 2.1 or later ------------------------------------------------------------------------- *) From elpi.apps.derive.elpi Extra Dependency "injection.elpi" as injection. From elpi.apps.derive.elpi Extra Dependency "bcongr.elpi" as bcongr. From elpi.apps.derive.elpi Extra Dependency "derive_hook.elpi" as derive_hook. From elpi.apps.derive.elpi 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. }}. #[superglobal] Elpi Accumulate derive.bcongr.db File derive.lib. #[superglobal] Elpi Accumulate derive.bcongr.db lp:{{ :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 ". }}. (* 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.4.0/apps/derive/theories/derive/cast.v000066400000000000000000000012321474173443600217030ustar00rootroot00000000000000(* Generates (once and forall) cast operators (trasport). license: GNU Lesser General Public License Version 2.1 or later ------------------------------------------------------------------------- *) From elpi.apps.derive.elpi 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 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.4.0/apps/derive/theories/derive/eq.v000066400000000000000000000043611474173443600213640ustar00rootroot00000000000000(* Generates equality tests. license: GNU Lesser General Public License Version 2.1 or later ------------------------------------------------------------------------- *) From elpi.apps.derive.elpi Extra Dependency "eq.elpi" as eq. From elpi.apps.derive.elpi Extra Dependency "derive_hook.elpi" as derive_hook. From elpi.apps.derive.elpi 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 }} :- !. % quick access type eq-for inductive -> constant -> prop. }}. #[superglobal] Elpi Accumulate derive.eq.db File derive.lib. #[superglobal] Elpi Accumulate derive.eq.db lp:{{ pred whd1 i:term, o:term. :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. }}. 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 []". }}. (* 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.4.0/apps/derive/theories/derive/eqK.v000066400000000000000000000052231474173443600214750ustar00rootroot00000000000000(* 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.elpi Extra Dependency "discriminate.elpi" as discriminate. From elpi.apps.derive.elpi Extra Dependency "eqK.elpi" as eqK. From elpi.apps.derive.elpi Extra Dependency "derive_hook.elpi" as derive_hook. From elpi.apps.derive.elpi 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. }}. #[superglobal] Elpi Accumulate derive.eqK.db File derive.lib. #[superglobal] Elpi Accumulate derive.eqK.db lp:{{ :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 []". }}. (* 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.4.0/apps/derive/theories/derive/eqOK.v000066400000000000000000000037361474173443600216230ustar00rootroot00000000000000(* 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.elpi Extra Dependency "paramX_lib.elpi" as paramX. From elpi.apps.derive.elpi Extra Dependency "param1.elpi" as param1. From elpi.apps.derive.elpi Extra Dependency "eqOK.elpi" as eqOK. From elpi.apps.derive.elpi Extra Dependency "derive_hook.elpi" as derive_hook. From elpi.apps.derive.elpi 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_congr 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 []". }}. (* 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.4.0/apps/derive/theories/derive/eqOK_trivial.v.skip000066400000000000000000000030471474173443600243150ustar00rootroot00000000000000(* 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.4.0/apps/derive/theories/derive/eqType_ast.v000066400000000000000000000033761474173443600231020ustar00rootroot00000000000000From elpi Require Import elpi. From Coq Require Import PrimInt63 PrimFloat. From elpi.apps Require Import derive. From elpi.apps.derive.elpi Extra Dependency "eqType.elpi" as eqType. From elpi.apps.derive.elpi Extra Dependency "derive_hook.elpi" as derive_hook. From elpi.apps.derive.elpi 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 _. }}. (* 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.4.0/apps/derive/theories/derive/eqb.v000066400000000000000000000043551474173443600215310ustar00rootroot00000000000000From 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.elpi Extra Dependency "fields.elpi" as fields. From elpi.apps.derive.elpi Extra Dependency "eqb.elpi" as eqb. From elpi.apps.derive.elpi Extra Dependency "eqType.elpi" as eqType. From elpi.apps.derive.elpi Extra Dependency "derive_hook.elpi" as derive_hook. From elpi.apps.derive.elpi 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 whd1 i:term, o:term. 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 ". }}. (* 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.4.0/apps/derive/theories/derive/eqbOK.v000066400000000000000000000035251474173443600217610ustar00rootroot00000000000000(* 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.elpi Extra Dependency "eqbOK.elpi" as eqbOK. From elpi.apps.derive.elpi Extra Dependency "eqType.elpi" as eqType. From elpi.apps.derive.elpi Extra Dependency "derive_hook.elpi" as derive_hook. From elpi.apps.derive.elpi Extra Dependency "derive_synterp_hook.elpi" as derive_synterp_hook. Elpi Db derive.eqbOK.db lp:{{ pred eqbok-for o:gref, o:constant. }}. #[superglobal] Elpi Accumulate derive.eqbOK.db File derive.lib. (* 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 ". }}. (* 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.4.0/apps/derive/theories/derive/eqb_core_defs.v000066400000000000000000000103371474173443600235370ustar00rootroot00000000000000Require Import Eqdep_dec. Require Import PArith. Require Import ssreflect ssrbool. Set Implicit Arguments. Unset Strict Implicit. Unset Printing Implicit Defensive. Local 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.4.0/apps/derive/theories/derive/eqbcorrect.v000066400000000000000000000071771474173443600231200ustar00rootroot00000000000000From 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.elpi Extra Dependency "paramX_lib.elpi" as paramX. From elpi.apps.derive.elpi Extra Dependency "param1.elpi" as param1. From elpi.apps.derive.elpi Extra Dependency "eqType.elpi" as eqType. From elpi.apps.derive.elpi Extra Dependency "eqbcorrect.elpi" as eqbcorrect. From elpi.apps.derive.elpi Extra Dependency "derive_hook.elpi" as derive_hook. From elpi.apps.derive.elpi 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 ". }}. (* 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.4.0/apps/derive/theories/derive/eqcorrect.v000066400000000000000000000054131474173443600227450ustar00rootroot00000000000000(* 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.elpi Extra Dependency "eqcorrect.elpi" as eqcorrect. From elpi.apps.derive.elpi Extra Dependency "derive_hook.elpi" as derive_hook. From elpi.apps.derive.elpi 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. }}. #[superglobal] Elpi Accumulate derive.eqcorrect.db File derive.lib. #[superglobal] Elpi Accumulate derive.eqcorrect.db lp:{{ 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 []". }}. (* 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.4.0/apps/derive/theories/derive/experimental.v000066400000000000000000000004371474173443600234540ustar00rootroot00000000000000(* 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 . coq-elpi-2.4.0/apps/derive/theories/derive/fields.v000066400000000000000000000037251474173443600222300ustar00rootroot00000000000000From 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.elpi Extra Dependency "fields.elpi" as fields. From elpi.apps.derive.elpi Extra Dependency "eqType.elpi" as eqType. From elpi.apps.derive.elpi Extra Dependency "derive_hook.elpi" as derive_hook. From elpi.apps.derive.elpi 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 Db Header derive.eqType.db. Elpi Accumulate Db Header derive.tag.db. Elpi Accumulate Db Header derive.fields.db. Elpi Accumulate File derive_hook. Elpi Accumulate File eqType. Elpi Accumulate File fields. 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 []". }}. (* 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.4.0/apps/derive/theories/derive/idx2inv.v000066400000000000000000000037321474173443600223430ustar00rootroot00000000000000(* 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.elpi Extra Dependency "paramX_lib.elpi" as paramX. From elpi.apps.derive.elpi Extra Dependency "param1_functor.elpi" as param1_functor. From elpi.apps.derive.elpi Extra Dependency "idx2inv.elpi" as idx2inv. From elpi.apps.derive.elpi Extra Dependency "derive_hook.elpi" as derive_hook. From elpi.apps.derive.elpi 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 []". }}. (* 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.4.0/apps/derive/theories/derive/induction.v000066400000000000000000000037461474173443600227610ustar00rootroot00000000000000(* Generates the induction principle. license: GNU Lesser General Public License Version 2.1 or later ------------------------------------------------------------------------- *) From elpi.apps.derive.elpi Extra Dependency "paramX_lib.elpi" as paramX. From elpi.apps.derive.elpi Extra Dependency "param1.elpi" as param1. From elpi.apps.derive.elpi Extra Dependency "induction.elpi" as induction. From elpi.apps.derive.elpi Extra Dependency "derive_hook.elpi" as derive_hook. From elpi.apps.derive.elpi 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. }}. #[superglobal] Elpi Accumulate derive.induction.db File derive.lib. #[superglobal] Elpi Accumulate derive.induction.db lp:{{ :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 ". }}. (* 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.4.0/apps/derive/theories/derive/invert.v000066400000000000000000000025501474173443600222640ustar00rootroot00000000000000(* 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.elpi Extra Dependency "invert.elpi" as invert. From elpi.apps.derive.elpi Extra Dependency "derive_hook.elpi" as derive_hook. From elpi.apps.derive.elpi 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 []". }}. (* 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.4.0/apps/derive/theories/derive/isK.v000066400000000000000000000034411474173443600215030ustar00rootroot00000000000000(* 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.elpi Extra Dependency "isK.elpi" as isK. From elpi.apps.derive.elpi Extra Dependency "derive_hook.elpi" as derive_hook. From elpi.apps.derive.elpi 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. }}. #[superglobal] Elpi Accumulate derive.isK.db File derive.lib. #[superglobal] Elpi Accumulate derive.isK.db lp:{{ :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 []". }}. (* 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.4.0/apps/derive/theories/derive/legacy.v000066400000000000000000000005131474173443600222160ustar00rootroot00000000000000(* 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 . coq-elpi-2.4.0/apps/derive/theories/derive/lens.v000066400000000000000000000036561474173443600217260ustar00rootroot00000000000000(* A lens, to see better. license: GNU Lesser General Public License Version 2.1 or later ------------------------------------------------------------------------- *) From elpi.apps.derive.elpi Extra Dependency "lens.elpi" as lens. From elpi.apps.derive.elpi Extra Dependency "derive_hook.elpi" as derive_hook. From elpi.apps.derive.elpi 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 Db Header derive.lens.db. 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 []". }}. (* 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.4.0/apps/derive/theories/derive/lens_laws.v000066400000000000000000000052721474173443600227500ustar00rootroot00000000000000(* Equations for lenses license: GNU Lesser General Public License Version 2.1 or later ------------------------------------------------------------------------- *) From elpi.apps.derive.elpi Extra Dependency "lens_laws.elpi" as lens_laws. From elpi.apps.derive.elpi Extra Dependency "derive_hook.elpi" as derive_hook. From elpi.apps.derive.elpi 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 Db Header derive.lens.db. Elpi Accumulate Db Header derive.lens_laws.db. 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 []". }}. (* 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.4.0/apps/derive/theories/derive/map.v000066400000000000000000000026501474173443600215330ustar00rootroot00000000000000(* 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.elpi Extra Dependency "map.elpi" as map. From elpi.apps.derive.elpi Extra Dependency "derive_hook.elpi" as derive_hook. From elpi.apps.derive.elpi 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 ". }}. (* 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.4.0/apps/derive/theories/derive/param1.v000066400000000000000000000074131474173443600221410ustar00rootroot00000000000000(* Unary parametricity translation. license: GNU Lesser General Public License Version 2.1 or later ------------------------------------------------------------------------- *) From elpi.apps.derive.elpi Extra Dependency "paramX_lib.elpi" as paramX. From elpi.apps.derive.elpi Extra Dependency "param1.elpi" as param1. From elpi.apps.derive.elpi Extra Dependency "derive_hook.elpi" as derive_hook. From elpi.apps.derive.elpi 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:{{ :index(3) pred reali i:term, o:term. type realiR term -> term -> prop. pred reali-done i:gref. }}. #[superglobal] Elpi Accumulate derive.param1.db File derive.lib. #[superglobal] Elpi Accumulate derive.param1.db lp:{{ 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. 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 ". }}. 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.4.0/apps/derive/theories/derive/param1_congr.v000066400000000000000000000035551474173443600233340ustar00rootroot00000000000000(* 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.elpi Extra Dependency "paramX_lib.elpi" as paramX. From elpi.apps.derive.elpi Extra Dependency "param1_congr.elpi" as param1_congr. From elpi.apps.derive.elpi Extra Dependency "derive_hook.elpi" as derive_hook. From elpi.apps.derive.elpi 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 []". }}. (* 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.4.0/apps/derive/theories/derive/param1_functor.v000066400000000000000000000035561474173443600237050ustar00rootroot00000000000000(* 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.elpi Extra Dependency "param1_functor.elpi" as param1_functor. From elpi.apps.derive.elpi Extra Dependency "derive_hook.elpi" as derive_hook. From elpi.apps.derive.elpi Extra Dependency "derive_synterp_hook.elpi" as derive_synterp_hook. From elpi Require Import elpi. From elpi.apps Require Import derive derive.param1. 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 []". }}. (* 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.4.0/apps/derive/theories/derive/param1_trivial.v000066400000000000000000000171731474173443600236770ustar00rootroot00000000000000(* 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.elpi Extra Dependency "paramX_lib.elpi" as paramX. From elpi.apps.derive.elpi Extra Dependency "param1.elpi" as param1. From elpi.apps.derive.elpi Extra Dependency "param1_inhab.elpi" as param1_inhab. From elpi.apps.derive.elpi Extra Dependency "param1_trivial.elpi" as param1_trivial. From elpi.apps.derive.elpi Extra Dependency "derive_hook.elpi" as derive_hook. From elpi.apps.derive.elpi 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. type param1-trivial-db term -> term -> prop. type param1-trivial-db-args list term -> list term -> prop. pred param1-inhab-done i:inductive. type param1-inhab-db term -> term -> prop. type param1-inhab-db-args list term -> list term -> prop. }}. #[superglobal] Elpi Accumulate derive.param1.trivial.db File derive.lib. #[superglobal] Elpi Accumulate derive.param1.trivial.db Db Header derive.param1.db. #[superglobal] Elpi Accumulate derive.param1.trivial.db lp:{{ pred coq.mk-app i:term, i:list term, o:term. pred coq.sort? i:term. 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. 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). 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. 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 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 ". }}. (* 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). derivation _ _ (derive "param1_trivial" (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.4.0/apps/derive/theories/derive/param2.v000066400000000000000000000043321474173443600221370ustar00rootroot00000000000000(* Binary parametricity translation. license: GNU Lesser General Public License Version 2.1 or later ------------------------------------------------------------------------- *) From elpi.apps.derive.elpi Extra Dependency "paramX_lib.elpi" as paramX. From elpi.apps.derive.elpi Extra Dependency "param2.elpi" as param2. From elpi.apps.derive.elpi Extra Dependency "derive_hook.elpi" as derive_hook. From elpi.apps.derive.elpi 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:{{ :index(3) pred param i:term, o:term, o:term. type paramR term -> term -> term -> prop. pred param-done i:gref. }}. #[superglobal] Elpi Accumulate derive.param2.db File derive.lib. #[superglobal] Elpi Accumulate derive.param2.db lp:{{ :name "param:fail" param X _ _ :- M is "derive.param2: No binary parametricity translation for " ^ {coq.term->string X}, stop M. :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 ". }}. (* 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.4.0/apps/derive/theories/derive/projK.v000066400000000000000000000034611474173443600220440ustar00rootroot00000000000000(* 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.elpi Extra Dependency "projK.elpi" as projK. From elpi.apps.derive.elpi Extra Dependency "derive_hook.elpi" as derive_hook. From elpi.apps.derive.elpi 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. }}. #[superglobal] Elpi Accumulate derive.projK.db File derive.lib. #[superglobal] Elpi Accumulate derive.projK.db lp:{{ :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 []". }}. (* 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.4.0/apps/derive/theories/derive/std.v000066400000000000000000000015061474173443600215470ustar00rootroot00000000000000(* 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 . (* 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.4.0/apps/derive/theories/derive/tag.v000066400000000000000000000025151474173443600215310ustar00rootroot00000000000000From elpi Require Import elpi. From elpi.apps Require Import derive. From Coq Require Import PArith. From elpi.apps.derive.elpi Extra Dependency "tag.elpi" as tag. From elpi.apps.derive.elpi Extra Dependency "derive_hook.elpi" as derive_hook. From elpi.apps.derive.elpi 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 Db Header derive.tag.db. 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 ". }}. (* 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.4.0/apps/derive/theories/dune000066400000000000000000000001761474173443600201700ustar00rootroot00000000000000(coq.theory (name elpi.apps.derive) (package coq-elpi) (theories elpi elpi.apps.derive.elpi)) (include_subdirs qualified) coq-elpi-2.4.0/apps/eltac/000077500000000000000000000000001474173443600152765ustar00rootroot00000000000000coq-elpi-2.4.0/apps/eltac/examples/000077500000000000000000000000001474173443600171145ustar00rootroot00000000000000coq-elpi-2.4.0/apps/eltac/examples/dune000066400000000000000000000001541474173443600177720ustar00rootroot00000000000000(coq.theory (name elpi.apps.eltac.examples) (theories elpi elpi.apps.eltac)) (include_subdirs qualified) coq-elpi-2.4.0/apps/eltac/examples/usage_eltac.v000066400000000000000000000004701474173443600215600ustar00rootroot00000000000000From 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.4.0/apps/eltac/tests/000077500000000000000000000000001474173443600164405ustar00rootroot00000000000000coq-elpi-2.4.0/apps/eltac/tests/dune000066400000000000000000000002031474173443600173110ustar00rootroot00000000000000(coq.theory (name elpi.apps.eltac.tests) (package coq-elpi-tests) (theories elpi elpi.apps.eltac)) (include_subdirs qualified) coq-elpi-2.4.0/apps/eltac/tests/test_assumption.v000066400000000000000000000003041474173443600220650ustar00rootroot00000000000000From 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.4.0/apps/eltac/tests/test_case.v000066400000000000000000000012661474173443600206060ustar00rootroot00000000000000From 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.4.0/apps/eltac/tests/test_clear.v000066400000000000000000000005221474173443600207530ustar00rootroot00000000000000From 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.4.0/apps/eltac/tests/test_constructor.v000066400000000000000000000003741474173443600222570ustar00rootroot00000000000000From 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.4.0/apps/eltac/tests/test_cycle.v000066400000000000000000000004771474173443600207750ustar00rootroot00000000000000From 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.4.0/apps/eltac/tests/test_discriminate.v000066400000000000000000000012301474173443600223350ustar00rootroot00000000000000From 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.4.0/apps/eltac/tests/test_fail.v000066400000000000000000000001531474173443600206000ustar00rootroot00000000000000From elpi.apps Require Import eltac.fail. Goal False. try (eltac.fail 0). Fail try (eltac.fail 1). Abort. coq-elpi-2.4.0/apps/eltac/tests/test_generalize.v000066400000000000000000000003101474173443600220050ustar00rootroot00000000000000From 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.4.0/apps/eltac/tests/test_injection.v000066400000000000000000000011111474173443600216420ustar00rootroot00000000000000From 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.4.0/apps/eltac/tests/test_intro.v000066400000000000000000000002631474173443600210220ustar00rootroot00000000000000From 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.4.0/apps/eltac/theories/000077500000000000000000000000001474173443600171205ustar00rootroot00000000000000coq-elpi-2.4.0/apps/eltac/theories/assumption.v000066400000000000000000000004631474173443600215140ustar00rootroot00000000000000From 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". }}. Tactic Notation "eltac.assumption" := elpi assumption. coq-elpi-2.4.0/apps/eltac/theories/case.v000066400000000000000000000022171474173443600202240ustar00rootroot00000000000000From 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 ". }}. Tactic Notation "eltac.case" constr(T) := elpi case ltac_term:(T). coq-elpi-2.4.0/apps/eltac/theories/clear.v000066400000000000000000000035611474173443600204020ustar00rootroot00000000000000From 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. }}. 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 }}. Tactic Notation "eltac.clearbody" hyp_list(V) := elpi clearbody ltac_term_list:(V). coq-elpi-2.4.0/apps/eltac/theories/constructor.v000066400000000000000000000010001474173443600216630ustar00rootroot00000000000000From 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". }}. Tactic Notation "eltac.constructor" := elpi constructor. coq-elpi-2.4.0/apps/eltac/theories/cycle.v000066400000000000000000000012301474173443600204020ustar00rootroot00000000000000From 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). }}. Tactic Notation "eltac.cycle" int(n) := elpi cycle ltac_int:(n). coq-elpi-2.4.0/apps/eltac/theories/discriminate.v000066400000000000000000000011301474173443600217550ustar00rootroot00000000000000From elpi.apps.derive.elpi 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 ". }}. Tactic Notation "eltac.discriminate" constr(T) := elpi discriminate ltac_term:(T). coq-elpi-2.4.0/apps/eltac/theories/dune000066400000000000000000000001701474173443600177740ustar00rootroot00000000000000(coq.theory (name elpi.apps.eltac) (package coq-elpi) (theories elpi elpi.apps.derive)) (include_subdirs qualified) coq-elpi-2.4.0/apps/eltac/theories/fail.v000066400000000000000000000004401474173443600202200ustar00rootroot00000000000000From 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. }}. Tactic Notation "eltac.fail" int(n) := elpi fail ltac_int:(n). coq-elpi-2.4.0/apps/eltac/theories/generalize.v000066400000000000000000000010751474173443600214370ustar00rootroot00000000000000From 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. }}. Tactic Notation "eltac.generalize" constr(V) := elpi generalize ltac_term:(V). coq-elpi-2.4.0/apps/eltac/theories/injection.v000066400000000000000000000012231474173443600212670ustar00rootroot00000000000000From elpi.apps.derive.elpi 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 ". }}. Tactic Notation "eltac.injection" constr(T) := elpi injection ltac_term:(T). coq-elpi-2.4.0/apps/eltac/theories/intro.v000066400000000000000000000007111474173443600204410ustar00rootroot00000000000000From 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". }}. 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.4.0/apps/eltac/theories/tactics.v000066400000000000000000000002161474173443600207400ustar00rootroot00000000000000From elpi.apps.eltac Require Export intro constructor assumption discriminate injection case generalize fail clear cycle .coq-elpi-2.4.0/apps/locker/000077500000000000000000000000001474173443600154655ustar00rootroot00000000000000coq-elpi-2.4.0/apps/locker/README.md000066400000000000000000000027751474173443600167570ustar00rootroot00000000000000# 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.4.0/apps/locker/elpi/000077500000000000000000000000001474173443600164165ustar00rootroot00000000000000coq-elpi-2.4.0/apps/locker/elpi/dune000066400000000000000000000007311474173443600172750ustar00rootroot00000000000000(coq.theory (name elpi.apps.locker.elpi) (package coq-elpi) (theories elpi)) (rule (target dummy.v) (deps (glob_files *.elpi)) (action (with-stdout-to %{target} (progn (echo "Require Import String.\nOpen Scope string_scope.\nLocal Definition _hash := \"\n") (run coq_elpi_shafile %{deps}) (echo "\".\n"))))) (install (files (glob_files (*.elpi with_prefix coq/user-contrib/elpi/apps/locker/elpi/))) (section lib_root) (package coq-elpi)) coq-elpi-2.4.0/apps/locker/elpi/locker.elpi000066400000000000000000000113661474173443600205570ustar00rootroot00000000000000/* 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.4.0/apps/locker/tests/000077500000000000000000000000001474173443600166275ustar00rootroot00000000000000coq-elpi-2.4.0/apps/locker/tests/dune000066400000000000000000000002051474173443600175020ustar00rootroot00000000000000(coq.theory (name elpi.apps.locker.tests) (package coq-elpi-tests) (theories elpi elpi.apps.locker)) (include_subdirs qualified) coq-elpi-2.4.0/apps/locker/tests/test_locker.v000066400000000000000000000062011474173443600213330ustar00rootroot00000000000000From 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.4.0/apps/locker/theories/000077500000000000000000000000001474173443600173075ustar00rootroot00000000000000coq-elpi-2.4.0/apps/locker/theories/dune000066400000000000000000000001761474173443600201710ustar00rootroot00000000000000(coq.theory (name elpi.apps.locker) (package coq-elpi) (theories elpi elpi.apps.locker.elpi)) (include_subdirs qualified) coq-elpi-2.4.0/apps/locker/theories/locker.v000066400000000000000000000046661474173443600207710ustar00rootroot00000000000000(* Locking mechanisms. license: GNU Lesser General Public License Version 2.1 or later ------------------------------------------------------------------------- *) From elpi.apps.locker.elpi 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 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 Export mlock. coq-elpi-2.4.0/apps/tc/000077500000000000000000000000001474173443600146145ustar00rootroot00000000000000coq-elpi-2.4.0/apps/tc/README.md000066400000000000000000000541151474173443600161010ustar00rootroot00000000000000# 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.4.0/apps/tc/elpi/000077500000000000000000000000001474173443600155455ustar00rootroot00000000000000coq-elpi-2.4.0/apps/tc/elpi/WIP/000077500000000000000000000000001474173443600162045ustar00rootroot00000000000000coq-elpi-2.4.0/apps/tc/elpi/WIP/deactivate_evar.elpi000066400000000000000000000021011474173443600221770ustar00rootroot00000000000000/* when solving a goal in tc, we want to trigger the declared evar only after the proof search. This means that, while the search is performed, we do not risk to assign too early incorrect types (for example with wrong universes). The evar typechecking is triggered after the search, just before refining the proof with the original goal. We use the guard declare-evars-now that to trigger the constraints to reproduce this behavior. */ % pred declare-evar-later i:list prop, i:term, i:term, i:term. % pred declare-evars-now. % constraint declare-evar-later declare-evars-now { % rule declare-evars-now \ (declare-evar-later Ctx RawEv Ty Ev) <=> (declare-evars-now, Ctx => evar RawEv Ty Ev). % rule \ declare-evars-now. % } % declare-evars-now :- % declare_constraint declare-evars-now [_]. % We want to deactivate the evar declaration if coming from the % original goal (the original type class problem to be solved) % :before "default-declare-evar" % :name "tc-solver-declare-evar" % declare-evar Ctx X Ty E :- !, % declare_constraint (declare-evar-later Ctx X Ty E) [_]. coq-elpi-2.4.0/apps/tc/elpi/WIP/force_llam.elpi000066400000000000000000000124661474173443600211730ustar00rootroot00000000000000% This is an effort for forcing llam links when used as input variables % in a premise call. However, this brings several issues to find % the right variable to activate the right link.s namespace force-llam { pred is-uvar-destruct i:term, o:term. is-uvar-destruct T R :- name T Hd _, name-pair R Hd _, !. is-uvar-destruct T T :- is-uvar T. % At compile time, given a premise p with a flexible argument X. % If X is expected to be in input mode, we add the auxiliary clause % `solve-llam-t X`, so that, if any suspended % llam link on X exists, then it is forced before solving p pred modes i:list string, i:list term, o:list prop. modes ["o"] [] [] :- !. modes ["+" | Ms] [X | Xs] [P | Ps] :- is-uvar-destruct X R, !, P = tc.link.solve-llam-t R, modes Ms Xs Ps. modes ["!" | Ms] [X | Xs] [P | Ps] :- is-uvar-destruct X R, !, P = tc.link.solve-llam-t R, modes Ms Xs Ps. modes [_ | Ms] [_ | Xs] Ps :- modes Ms Xs Ps. % The following rule represents a try to force llam links when input of % of other premises. compile-conclusion ff Goal Proof HOPremisesIn HOPremisesOut Premises Clause :- coq.safe-dest-app Goal Class Args, tc.get-mode {tc.get-TC-of-inst-type Class} Modes, force-llam.modes Modes Args ForceLlam, tc.make-tc Goal Proof Premises ff Clause1, Prems = [HOPremisesIn, ForceLlam, [Clause1], HOPremisesOut], std.flatten Prems AllPremises, Clause = do AllPremises. % Scope Var Args Rhs pred progress-llam-refine i:list term, i:term, i:list term, o:term. progress-llam-refine S V [A|As] R :- name A, not (std.mem! S A), !, % prune (V' A) [A|S], eta V (fun _ _ (x\ V' x)), progress-llam-refine [A|S] (V' A) As R. progress-llam-refine _ V [] V. progress-llam-refine _ V As (app [V|As]). pred split-pf i:list term, i:list term, o:list term, o:list term. split-pf [] _ [] [] :- !. split-pf [X|Xs] Old [X|Ys] L :- name X, not (std.mem! Old X), !, split-pf Xs [X|Old] Ys L. split-pf Xs _ [] Xs. pred lam->fun i:term, i:list term, i:any. lam->fun T [] R :- !, std.unsafe-cast R R', copy T T', R' = T'. lam->fun Hd [H|L] R :- !, pi x\ (copy H x :- !) => lam->fun Hd L (R' x), std.unsafe-cast R Rx, Rx = R'. pred unify-align i:term, i:term, i:list term, i:list term. unify-align (app L) Hd PF NPF :- Len is {std.length L} - {std.length NPF}, Len >= 0, std.split-at Len L L' NPF, Z = app L', coq.mk-app Z NPF TT, lam->fun TT {std.append PF NPF} Hd. pred unify-const i:term, i:term, i:list term. unify-const N R [] :- !, copy N X, R = X. unify-const N R [A|As] :- not found.aux, A == N, !, pi x\ found.aux => (copy N x :- !) => unify-const N (R' x) As, std.unsafe-cast R Rx, Rx = R'. unify-const N R [_|As] :- pi x\ unify-const N (R' x) As, std.unsafe-cast R Rx, Rx = R'. pred unify-heuristics i:term, i:term. unify-heuristics A T :- tc.unify-eq A T. % unify-heuristics (app _ as A) (fun _ _ B) :- !, % coq.error "A", % eta-expand A (fun _ _ A'), pi x\ unify-heuristics (A' x) (B x). % unify-heuristics (app _ as A) B :- var B Hd Tl, !, % split-pf Tl [] PF NPF, % unify-align A Hd PF NPF. % unify-heuristics A B :- name A, var B Hd Tl, !, % TODO: also const % unify-const A Hd Tl. % unify-heuristics (app L) (app[X|L']) :- % var X, !, % Len is {std.length L} - {std.length L'}, Len > 0, % std.split-at Len L Hd L', % if (Hd = [X]) true (X = app Hd). % unify-heuristics (app L) (app L') :- % std.forall2 L L' unify-heuristics. % % The following rule leaves elpi uvars outside PF in coq % % unify-heuristics A B :- A = B. % % The following seems to solve the problem of the previous rule % % TODO: I don't understand why the following rule cant be written as: % % unify-heuristics A B :- var B Hb Lb, A = app[Hb|Lb] % % without breaking test CoqUvar2 % unify-heuristics (uvar Ha []) (uvar Hb Lb) :- !, % Ha = app[Hb|Lb]. % unify-heuristics (fun _ _ Bo) (uvar Hb_ Lb1) :- not (distinct_names Lb1), !, % Lb1 = [_ | Lb], % std.spy-do![prune Z Lb, % % std.unsafe-cast Hb Hb1, % (pi x\ unify-heuristics (Bo x) Z), % Hb_ = % coq.error "TODO" Z]. % unify-heuristics A B :- A = B. pred llam-aux i:term, i:term. llam-aux A (uvar _ S as T) :- distinct_names S, !, A = T. % Here, both A and T are in PF llam-aux A (uvar _ _ as T) :- !, A = T. llam-aux A (app [H|L] as T) :- var A, var H, !, get-vars T Vars, declare_constraint (llam A (app [H|L])) [_,A|Vars]. llam-aux A (app [H|L] as T) :- var H, !, get-vars T Vars, declare_constraint (llam A (app [H|L])) [_|Vars]. llam-aux A (app [H|L]) :- coq.mk-app H L T, !, unify-heuristics A T. llam L (app [H|As]) :- var H _ S, !, progress-llam-refine S H As Rhs, llam-aux L Rhs. llam L Rhs :- llam-aux L Rhs. pred solve-llam-t-cond i:term, i:term. :name "solve-llam-t-cond" solve-llam-t-cond (uvar A _) (app [uvar B _ | _]) :- A = B. % Aims to force a llam link suspended on the given variable pred solve-llam-t o:term. solve-llam-t X :- var X, !, declare_constraint (solve-llam-t X) [X]. solve-llam-t _. constraint solve-llam solve-llam-t llam { rule \ (solve-llam-t X) (llam A B) | (solve-llam-t-cond X B) <=> (unify-heuristics A B). rule solve-llam \ (llam A B) <=> (unify-heuristics A B). rule \ solve-llam. } } coq-elpi-2.4.0/apps/tc/elpi/WIP/modes.elpi000066400000000000000000000036141474173443600201720ustar00rootroot00000000000000/* 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 (tc.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.4.0/apps/tc/elpi/alias.elpi000066400000000000000000000014131474173443600175100ustar00rootroot00000000000000/* license: GNU Lesser General Public License Version 2.1 or later */ /* ------------------------------------------------------------------------- */ namespace tc { 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.4.0/apps/tc/elpi/base.elpi000066400000000000000000000107071474173443600173370ustar00rootroot00000000000000/* 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 [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 exists! i:list A, i:(A -> prop). exists! [X|_] A :- A X, !. exists! [_|L] A :- exists! L A. 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, !. pred if-true i:prop, i:prop. if-true A B :- if A B true. pred if-false i:prop, i:prop. if-false A B :- if A true B. pred std.findall-unary i:(A -> prop), o:list A. std.findall-unary P L :- std.findall (P _) V, std.map V (x\y\ P y = x) L. pred print-repeat-aux i:int, i:string, o:string. print-repeat-aux 0 _ S :- coq.say S. print-repeat-aux N A S :- N > 0, N1 is N - 1, S' is A ^ S, print-repeat-aux N1 A S'. pred print-repeat i:int, i:string. print-repeat I S :- print-repeat-aux I S "". pred split-at-not-fatal i:int, i:list A, o:list A, o:list A. split-at-not-fatal 0 L [] L :- !. split-at-not-fatal N [X|XS] [X|LN] LM :- !, N1 is N - 1, split-at-not-fatal N1 XS LN LM. pred undup-same i:list A, o:list A. undup-same [] []. undup-same [X|Xs] [X|Ys] :- std.forall Xs (x\ not (x == X)), !, undup-same Xs Ys. undup-same [_|Xs] Ys :- undup-same Xs Ys. :index (1) pred is-coq-term i:any. is-coq-term (sort _). is-coq-term (global _). is-coq-term (pglobal _ _). is-coq-term (app _). is-coq-term (fun _ _ _). is-coq-term (prod _ _ _ ). is-coq-term (fix _ _ _ _ ). is-coq-term (match _ _ _). is-coq-term (let _ _ _ _). is-coq-term (primitive _). kind nat type. type z nat. type s nat -> nat. type inf nat. :index (1) pred add-nat i:nat, i:nat, o:nat. add-nat inf _ inf. add-nat _ inf inf. add-nat z N N. add-nat (s N) M (s P) :- add-nat N M P. pred max-nat i:nat, i:nat, o:nat. max-nat z N N :- !. max-nat N z N :- !. max-nat inf _ inf :- !. max-nat _ inf inf :- !. max-nat (s N) (s M) (s P) :- max-nat N M P. pred min-nat i:nat, i:nat, o:nat. min-nat z _ z :- !. min-nat _ z z :- !. min-nat inf A A :- !. min-nat A inf A :- !. min-nat (s N) (s M) (s P) :- min-nat N M P. pred length-nat i:list A, o:nat. length-nat [] z. length-nat [_|L] (s N) :- length-nat L N. pred count-prod i:term , o:nat. count-prod (prod _ _ B) (s N) :- !, pi x\ count-prod (B x) N. count-prod _ z. pred close-prop i:(A -> list prop), o:list prop. close-prop (x\ []) [] :- !. close-prop (x\ [X | Xs x]) [X| Xs'] :- !, close-prop Xs Xs'. close-prop (x\ [X x | Xs x]) [pi x\ X x | Xs'] :- !, close-prop Xs Xs'. pred close-prop-no-prune i:(A -> list prop), o:list prop. close-prop-no-prune (x\ []) [] :- !. close-prop-no-prune (x\ [X x | Xs x]) [pi x\ X x | Xs'] :- !, close-prop-no-prune Xs Xs'. % [close-term-ty (x\ L) Ty R] Ty is the type of x pred close-term-ty i:(term -> list prop), i:term, o:list prop. close-term-ty (x\ []) _ [] :- !. close-term-ty (x\ [X | Xs x]) Ty [X| Xs'] :- !, close-term-ty Xs Ty Xs'. close-term-ty (x\ [X x | Xs x]) Ty [@pi-decl `x` Ty x\ X x | Xs'] :- !, close-term-ty Xs Ty Xs'. pred close-term-no-prune-ty i:(term -> list prop), i:term, o:list prop. close-term-no-prune-ty (x\ []) _ [] :- !. close-term-no-prune-ty (x\ [X x | Xs x]) Ty [@pi-decl `x` Ty x\ X x | Xs'] :- !, close-term-no-prune-ty Xs Ty Xs'. coq-elpi-2.4.0/apps/tc/elpi/compiler1.elpi000066400000000000000000000120521474173443600203130ustar00rootroot00000000000000/* license: GNU Lesser General Public License Version 2.1 or later */ /* ------------------------------------------------------------------------- */ namespace tc { % 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 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 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.aux i:gref, i:gref i:list prop, i:grafting. add-inst.aux Inst TC Locality Grafting :- coq.env.current-section-path SectionPath, tc.compile.instance-gr Inst Clause, tc.get-full-path Inst ClauseName, (Locality => ( tc.add-tc-db ClauseName Grafting Clause, tc.add-tc-db _ Grafting (tc.instance SectionPath Inst TC Locality))). add-inst.aux Inst _ _ _ :- (@global! => tc.add-tc-db _ _ (tc.banned Inst)), coq.error "Not-added" "TC_solver" "[TC] Not yet able to compile" Inst "...". pred add-inst i:gref, i:gref, i:string, i:int. add-inst Inst TC LocalityStr Prio :- get-locality LocalityStr Locality, if (Prio = -1) (tc.get-inst-prio Inst Prio1) (Prio1 = Prio), Grafting is after (int_to_string Prio1), add-inst.aux Inst TC Locality Grafting. pred is-local. is-local :- std.mem {attributes} (attribute "local" _). pred add-inst>db.aux i:gref. add-inst>db.aux Inst :- tc.get-inst-prio Inst Prio, tc.get-TC-of-inst-type {coq.env.typeof Inst} TC, % Note: this is an approximation of instance locality when added with % TC.AddAllInstances or TC.AddInstances InstName if (is-local; has-context-deps Inst) (LocalityStr = "Local") (LocalityStr = "Export"), add-inst Inst TC LocalityStr Prio. % [add-inst->db IgnoreClassDepL ForceAdd Inst] compiles and add the Inst to % the database if the instance is not tc.banned or if it does not depend on a TC % inside the list IgnoreClassDepL. pred add-inst->db i:list gref, i:bool, i:gref. add-inst->db _ tt Inst :- !, add-inst>db.aux Inst. add-inst->db _ _ Inst :- tc.banned Inst, !, (coq.warning "tc.banned-inst" "TC-warning" Inst "is tc.banned"). add-inst->db _ _ Inst :- tc.instance _ Inst _ _, !. % the instance has already been added add-inst->db IgnoreClassDepL _ Inst :- get-class-dependencies Inst Dep, std.exists Dep (std.mem IgnoreClassDepL), !, coq.warning "invalid-dependency-inst" "TC-warning" Inst "depneds on a tc.banned TC". add-inst->db _ _ Inst :- !, add-inst>db.aux Inst. % 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:- tc.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) (tc.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") ). pred build-args i:term, o:list term. build-args (prod _ _ Bo) [{{0}} | TL] :- !, build-args (Bo _) TL. build-args _ [{{0}}]. % [remove-inst GR] remove an instance from the DB by replacing it with `dummy` pred remove-inst i:gref. remove-inst InstGR :- tc.get-full-path InstGR ClauseName, tc.instance _ InstGR ClassGR Locality, tc.gref->pred-name ClassGR PredName, coq.env.typeof ClassGR ClassTy, coq.elpi.predicate PredName {build-args ClassTy} Clause, tc.remove-clause ClauseName Clause Locality. pred is-in-path i:string, i:gref. is-in-path Path GR :- std.mem {coq.gref->path GR} Path. % [add-path ClassName Path] adds only the instances from a given path name pred add-path i:string, i:string. add-path ClassName Path :- coq.locate ClassName GR, std.filter {tc.get-inst-by-tc-name GR} (is-in-path Path) InstInPath, std.forall InstInPath (add-inst->db [] ff). namespace class-coercion { kind task type. type add task. type remove task. pred do-task i:task, i:gref. do-task add GR :- add-inst->db [] tt GR. do-task remove GR :- remove-inst GR. pred loop-proj i:task, i:list argument. loop-proj _ []. loop-proj Task [str Proj | TL] :- coq.locate Proj GRProj, tc.existing-instance GRProj, !, do-task Task GRProj, loop-proj Task TL. loop-proj Task [_|TL] :- loop-proj Task TL. } }coq-elpi-2.4.0/apps/tc/elpi/create_tc_predicate.elpi000066400000000000000000000121731474173443600223750ustar00rootroot00000000000000/* license: GNU Lesser General Public License Version 2.1 or later */ /* ------------------------------------------------------------------------- */ namespace tc { shorten tc.{search-mode}. % The predicate of a class is local if inside a section and readded at section end. % This way, section variables are generalized pred get-class-locality o:list prop. get-class-locality [@local!] :- coq.env.current-section-path [_ | _], !. get-class-locality [@global!]. % [add-class-gr SearchMode ClassGR] adds the predicate for the class with its corresponing mode % NOTE: the mode inside TC.declare_mode has the priority over Coq mode or #[mode=(...)] TC.Declare pred add-class-gr i:search-mode, i:gref. % the predicate for the class has alread been added add-class-gr _ ClassGR :- tc.class ClassGR _ _ _, !. add-class-gr SearchMode ClassGR :- std.assert! (coq.TC.class? ClassGR) "Only gref of type classes can be added as new predicates", tc.get-elpi-mode ClassGR EM SM, tc.gref->pred-name ClassGR PredName, get-class-locality Locality, Locality => ( coq.elpi.add-predicate "tc.db" _ PredName EM, tc.add-tc-db _ _ (tc.class ClassGR PredName SearchMode SM)). pred add-class-str i:search-mode, i:string. add-class-str SearchMode ClassStr :- coq.locate ClassStr ClassGR, add-class-gr SearchMode ClassGR. pred attr->search-mode o:search-mode. attr->search-mode tc.deterministic :- get-option "deterministic" tt, !. attr->search-mode tc.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 tc.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 = []) ( tc.modes-of-class ClassGR EM, std.map EM tc.elpi->string-mode SM )( coq.hints.add-mode ClassGR "typeclass_instances" CoqModes, std.map CoqModes (x\y\tc.string->coq-mode y x) SM', std.append SM' ["o"] SM ), % CAVEAT: this triggers the observer coq.TC.declare-class ClassGR, attr->search-mode SearchMode, tc.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 => tc.add-tc-db _ (after "0") (tc.class ClassGR PredName SearchMode SM :- !). 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). % Contains some instruction that are executed just after the creation of % the predicate for the class namespace eta-reduction-aux { pred is-functional i:term. is-functional (prod _ _ _). pred replace i:list term, i:term, o:list term, o:term. replace [] _ [] _ :- !. replace [(fun _ _ _ as T) | Xs] X' [X' | Xs] T :- !. replace [X | XS] NEW [X | YS] S :- replace XS NEW YS S. % a call to compile builds a new rule for the given class where only one % parameter P of function type is crafted. Compiled rules have only one % premise where P is possibly eta-contructed at runtime. The absence of bang % in the first rule (after is-functional T) allows to get all rules for and % functional parameter through the std.findall in the main predicate below. pred compile i:gref, i:term, i:bool, i:list term, o:prop. compile ClassGR (prod _ T Bo) ff L (pi name ty body\ Cl body ty name) :- is-functional T, pi name ty body x\ sigma Inp\ Inp = (fun name ty body), compile ClassGR (Bo x) tt [Inp|L] (Cl name ty body). compile ClassGR (prod _ _ Bo) S L (pi x\ Cl x) :- pi x\ compile ClassGR (Bo x) S [x|L] (Cl x). compile ClassGR (sort _) tt L (pi sol new-term\ Cl new-term sol) :- pi solution new-term\ sigma Args Args' Q Q'\ std.do![ tc.gref->pred-name ClassGR PredName, std.rev [solution | L] Args, replace Args new-term Args' T, coq.elpi.predicate PredName Args Q, coq.elpi.predicate PredName Args' Q', (Cl new-term solution) = (Q :- [coq.reduction.eta-contract T new-term, if (T == new-term) fail (Q')]) ]. % A debug predicate to print the genereted clauses pred generated-clauses. pred main i:string. main S :- coq.locate S ClassGR, coq.env.typeof ClassGR ClassTy, % a clause for eta contruction per argument of functional type is created % we get all the rules with the finall std.findall (compile ClassGR ClassTy ff [] _) SFindall, std.map SFindall (x\r\ compile _ _ _ _ r = x) SMap, if generated-clauses (coq.say SMap) true, std.forall SMap (tc.add-tc-db _ _). } }coq-elpi-2.4.0/apps/tc/elpi/dune000066400000000000000000000007211474173443600164230ustar00rootroot00000000000000(coq.theory (name elpi.apps.tc.elpi) (package coq-elpi) (theories elpi)) (rule (target dummy.v) (deps (glob_files *.elpi)) (action (with-stdout-to %{target} (progn (echo "Require Import String.\nOpen Scope string_scope.\nLocal Definition _hash := \"\n") (run coq_elpi_shafile %{deps}) (echo "\".\n"))))) (install (files (glob_files (*.elpi with_prefix coq/user-contrib/elpi/apps/tc/elpi/))) (section lib_root) (package coq-elpi)) coq-elpi-2.4.0/apps/tc/elpi/ho_compile.elpi000066400000000000000000000436771474173443600205570ustar00rootroot00000000000000namespace tc { shorten tc.{r-ar, range-arity}. namespace compile { namespace instance { pred is-name o:term. pred is-uvar o:term. % [name-pair H0 Hn Ar] % the variable H0 (applied 0 time) is associated to the variable Hn which is % applied Ar times. pred name-pair o:term, o:term, o:nat. pred force-llam-mem i:term, o:term. namespace decompile { pred decompile-term-aux i:term, i:pair (list term) (list prop), o:term, o:pair (list term) (list prop). decompile-term-aux X A Y A :- name X, !, X = Y, !. % avoid loading "decompile-term-aux x A x A" at binders decompile-term-aux (global _ as C) A C A :- !. decompile-term-aux (pglobal _ _ as T) L T' L :- !, copy T T', !. decompile-term-aux (sort _ as T) L T' L :- !, copy T T', !. decompile-term-aux (uvar as X) L X L :- !. decompile-term-aux (tc.maybe-eta-tm T S) (pr [X|XS] L1) Y (pr XS' [NL | L2]) :- !, name Y X S, decompile-term-aux T (pr XS L1) T' (pr XS' L2), NL = tc.link.eta Y T'. decompile-term-aux (tc.prod-range T _) A T' A' :- !, decompile-term-aux T A T' A'. % Maybe-llam when H is a coq unif variable quantified in the instance type % In the following instance, X is a HO variable applied to a constant (not a name) % Instance i : forall (X : T1 -> T2) (a : T1), c (X a). decompile-term-aux (tc.maybe-llam-tm (app[app[H | PF] | NPF]) S) (pr [X|XS] L1) Y (pr XS' [NL | L2]) :- not (var H), !, % is-uvar H, holds name Y X S, length-nat PF Len, std.assert!(name-pair H V Len) "[TC] fail to find name-pair", name Hd V PF, std.fold-map NPF (pr XS L1) decompile-term-aux Tl (pr XS' L2), NL = tc.link.llam Y (app [Hd|Tl]). % Maybe-llam when H is a hole appearing in the shelved goals % This happens when the instance to be compiled comes from the context % Example: Goal exists (X : T1 -> T2), forall a, c (X a) -> ... % intros; eexists. (* In the context we have the instance `H: c (?X a)` *) decompile-term-aux (tc.maybe-llam-tm (app[app[H | PF] | NPF]) S) A Z (pr XS' [NL | L3]) :- !, var H _ Scope, !, std.append Scope S S', prune Z S', tc.compile.goal.make-pairs [T] Pairs, % We build on the fly the eta-links for T (Pairs => (tc.compile.goal.build-eta-links-of-vars [T] P, tc.compile.goal.get-uva-pair-arity T PF Y)), std.fold-map NPF A decompile-term-aux Tl (pr XS' L2), std.append P L2 L3, NL = tc.link.llam Z (app [Y|Tl]). decompile-term-aux (fun Name Ty Bo) (pr XS L) (fun Name Ty' Bo') (pr XS2 L3) :- !, (pi x\ is-name x => decompile-term-aux (Bo x) (pr XS []) (Bo' x) (pr XS1 (L1x x))), close-term-no-prune-ty L1x Ty L1, decompile-term-aux Ty (pr XS1 L) Ty' (pr XS2 L2), std.append L1 L2 L3. decompile-term-aux (prod Name Ty Bo) (pr XS L) (prod Name Ty' Bo') (pr XS2 L3) :- !, (pi x\ is-name x => decompile-term-aux (Bo x) (pr XS []) (Bo' x) (pr XS1 (L1x x))), close-term-no-prune-ty L1x Ty L1, decompile-term-aux Ty (pr XS1 L) Ty' (pr XS2 L2), std.append L1 L2 L3. % HO var when H is a quantified variable in the instance type being in PF % Example: Instance i: forall (X : T1 -> T2), (forall a, c1 (X a)) -> c2. % Note: X is the HO var taken into account which is applied to the list of % distinct_names [a] decompile-term-aux (app [H|L]) N R N :- is-uvar H, std.forall L is-name, % Not needed, since precompile does this check distinct_names L, !, % Not needed, since precompile does this check length-nat L Len, std.assert! (name-pair H V Len) "[TC] name-pair not found", name R V L. % HO var when H is a hole appearing in the shelved goals decompile-term-aux (app [T|L]) (pr A B) Z (pr A B') :- var T _ Scope, std.forall L is-name, % Not needed, since decompile for llam leaves only PF distinct_names L, !, % Not needed, since decompile for llam leaves only PF std.append Scope L Scope', prune Z Scope', tc.compile.goal.make-pairs [T] Pairs, % We build on the fly the eta-links for `T` (Pairs => (tc.compile.goal.build-eta-links-of-vars [T] P, tc.compile.goal.get-uva-pair-arity T L Y)), var Z Y Scope', std.append P B B'. decompile-term-aux (app L) PR (app L') PR' :- !, std.fold-map L PR decompile-term-aux L' PR'. decompile-term-aux A B _ _ :- coq.error "[TC] cannot decompile-term-aux of" A B. pred decompile-term i:list term, o:list term, i:term, o:term, o:list prop. decompile-term L L' T R Links :- decompile-term-aux T (pr L []) R (pr L' Links). } % TODO: also replace (sort (typ X)) and (pglobal _ X) with holes in the place of X pred clean-term i:term, o:term. clean-term A B :- (pi t s r \ copy (tc.maybe-eta-tm t s) r :- !, copy t r, !) => (pi t s r \ copy (tc.prod-range t s) r :- !, copy t r, !) => (pi t s r \ copy (tc.maybe-llam-tm t s) r :- !, copy t r, !) => std.assert! (copy A B) "[TC] clean-term error". pred main i:nat, % the number of problematic terms i:term, % the type of the instance i:term, % the global gref of the instance i:list univ, % the list of univ variable to be replaced with elpi fresh vars i:list univ-instance, % the list of univ-instance to be replaced with elpi fresh vars o:prop. % the compiled clause for the instance main N Ty ProofHd [] [] Clause :- add-pi-problematic-terms N [] Ty ProofHd Clause. main N Ty ProofHd [Univ | UnivL] UnivInstL (pi x\ Clause x) :- !, pi x\ (copy (sort (typ Univ)) (sort (typ x)) :- !) => main N Ty ProofHd UnivL UnivInstL (Clause x). main N Ty ProofHd [] [UnivInst | UnivInstL] (pi x\ Clause x) :- !, pi x\ (copy (pglobal A UnivInst) (pglobal A x) :- !) => main N Ty ProofHd [] UnivInstL (Clause x). % Start to charge the right number of pi for the resulting clause: % This number is equal to the number of problematic terms + number of subterms with shape `sort _` and `pglobal _ _` pred add-pi-problematic-terms i:nat, % the number of pi to quantify i:list term, % the list of quantified pi i:term, % the fuel of the compilation (the type of the instance) i:term, % the global gref of the current instance o:prop. % the compiled clause for the instance add-pi-problematic-terms z L Ty ProofHd Clause :- compile-ty L _ ProofHd tt Ty [] [] Clause. add-pi-problematic-terms (s N) L Ty ProofHd (pi x\ Clause x) :- pi x\ is-uvar x => add-pi-problematic-terms N [x|L] Ty ProofHd (Clause x). % Builds a eta link between the varibale A whose type _must_ be of type `prod` % A is linked with B : A =_eta (fun (x : Ty) => B_x) pred make-eta-link-aux i:term, % A : The variable to eta-expand i:term, % prod _ Ty Bo : The type of A i:pair term name, % pr B Bn : The eta-expanded version of B with its name (they are fresh names) i:list term, % L : The list of name in the scope of A and B o:prop, % Link : The new eta-link o:term, % Ty' : The cleaned version of the binder in Ty o:(term -> term). % Bo : the body of the type of A make-eta-link-aux A (prod _ Ty Bo) (pr B Name) L Link Ty' Bo :- !, clean-term Ty Ty', name A' A {std.rev L}, Link = tc.link.eta A' (fun Name Ty' B'), pi x\ sigma L'\ std.rev [x|L] L', name (B' x) B L'. % Going under prod-range make-eta-link-aux A (tc.prod-range Prod _) BN L Link Ty' Bo :- !, make-eta-link-aux A Prod BN L Link Ty' Bo. % The type of a higher order variable can be hidden behind a definition % In this case we unfold this definition to get the prod constructor make-eta-link-aux A T BN L Link Ty' Bo :- coq.safe-dest-app T Hd Ag, (@redflags! coq.redflags.delta => coq.reduction.lazy.whd Hd Hd'), not (Hd = Hd'), !, coq.mk-app Hd' Ag TT', make-eta-link-aux A TT' BN L Link Ty' Bo. make-eta-link-aux _ T _ _ _ _ _ :- coq.error "[TC] make-eta-link-aux of" T. % Create spine of eta-links pred make-eta-link i:term, i:term, i:list (pair term name), i:list term, i:list prop, o:prop. make-eta-link P PTy [Hd] L Links (do [Link1|Links]) :- !, make-eta-link-aux P PTy Hd L Link1 _ _. make-eta-link P PTy [(pr B _ as Hd)|Tl] L Links (pi x\ decl x `x` PTy' => Res x) :- !, make-eta-link-aux P PTy Hd L Link1 PTy' Bo, pi x\ make-eta-link B (Bo x) Tl [x|L] [Link1|Links] (Res x). make-eta-link P PTy _ _ _ _ :- coq.error "[TC] make-eta-link error : empty list of pairs" P PTy. % Accumulates pi for eta-links pred add-link-eta-dedup i:(list prop -> prop -> prop), i:range-arity, i:term, i:term, i:(list (pair term name)), i:list prop, o:prop. % Base case when the variable is always used at same arity add-link-eta-dedup F (r-ar _ z) _ _ [] PremR Clause :- !, F PremR Clause. add-link-eta-dedup F (r-ar _ z) P Pty Acc PremR Clause :- !, make-eta-link P Pty Acc [] [] LinkEtaDedup, F [LinkEtaDedup|PremR] Clause. add-link-eta-dedup F (r-ar M (s N)) P PTy Acc PremR (pi x y\ Clause x y) :- !, pi x y\ name-pair P x (s N) => is-uvar x => add-link-eta-dedup F (r-ar M N) P PTy [pr x y|Acc] PremR (Clause x y). add-link-eta-dedup _ Ar P PTy _ _ _ :- coq.error "[TC] add-link-eta-dedup error" Ar P PTy. pred compile-premise i:list term, o:list term, i:term, i:term, i:term, i:bool, i:term, i:list term, i:list prop, o:prop. compile-premise L L2 P PTy ProofHd IsPositive ITy ProofTlR PremR Clause :- ((pi a b c\ tc.get-TC-of-inst-type (tc.prod-range a c) b :- tc.get-TC-of-inst-type a b) => tc.get-TC-of-inst-type PTy TC), !, compile-ty L L1 P {neg IsPositive} PTy [] [] NewPrem, if (tc.class TC _ tc.deterministic _) (NewPrem' = do-once NewPrem) (NewPrem' = NewPrem), compile-ty L1 L2 ProofHd IsPositive ITy ProofTlR [NewPrem' | PremR] Clause. compile-premise L L1 _ _ ProofHd IsPositive ITy ProofTlR PremR Clause :- compile-ty L L1 ProofHd IsPositive ITy ProofTlR PremR Clause. pred compile-ty i:list term, i:list term, i:term, i:bool, i:term, i:list term, i:list prop, o:prop. compile-ty L L1 ProofHd IsPositive (tc.prod-range (prod N Ty Bo) Arity) ProofTlR PremR Clause :- !, std.do![ if (IsPositive = tt) (Clause = (pi x\ C x), E = is-uvar) (clean-term Ty Ty', Clause = (pi x\ decl x N Ty' => C x), E = is-name), pi p\ sigma F\ F = compile-premise L L1 p Ty ProofHd IsPositive (Bo p) [p|ProofTlR], decl p N Ty' => name-pair p p z => E p => add-link-eta-dedup F Arity p Ty [] PremR (C p) ]. compile-ty L L2 ProofHd IsPositive Goal ProofTlR PremR Clause :- std.do![ coq.mk-app ProofHd {std.rev ProofTlR} Proof, decompile.decompile-term L L1 Proof Proof' Prem1, decompile.decompile-term L1 L2 Goal Goal' Prem2, compile-conclusion IsPositive Goal' Proof' Prem2 Prem1 {std.rev PremR} Clause ]. pred compile-conclusion i:bool, % tt if the term is in positive position i:term, % the goal (invariant: it is a constant or a application) i:term, % the proof i:list prop, % the list of HOPremises in input mode i:list prop, % the list of HOPremises in output mode i:list prop, % the premises o:prop. % the compiled clause for the instance compile-conclusion tt Goal Proof HOPremisesIn HOPremisesOut Premises Clause :- std.append {std.append HOPremisesIn Premises} HOPremisesOut AllPremises, tc.make-tc Goal Proof AllPremises tt Clause. compile-conclusion ff Goal Proof HOPremisesIn HOPremisesOut Premises Clause :- tc.make-tc Goal Proof Premises ff Clause1, Clause = (do HOPremisesIn, Clause1, do HOPremisesOut). pred context i:goal-ctx, o:list prop. context [] []. context [X | Xs] [Clause | ResTl] :- (decl Var _ Ty = X; def Var _ Ty _ = X), tc.is-instance-term Ty, !, std.assert! (compile.instance Ty Var Clause) "[TC] cannot compile instance of context", context Xs ResTl. context [_ | Tl] L :- context Tl L. } % build a list of Clauses of type tc to be temporarly added to the % database, used in theorems having assumptions. pred context i:goal-ctx, o:list prop. :name "tc-compile-context" context Ctx Clauses :- std.assert! (instance.context Ctx Clauses) "[TC] cannot compile context". pred instance i:term, i:term, o:prop. instance Ty ProofHd Clause :- tc.time-it tc.oTC-time-compile-instance ( tc.normalize-ty Ty Ty', tc.precomp.instance Ty' Ty'' N UnivConst UnivInst, instance.main N Ty'' ProofHd UnivConst UnivInst Clause ) "Compile Instance". pred instance-gr i:gref, o:prop. % If the instance is polymorphic, we wrap its gref into the pglobal constructor instance-gr InstGR (pi x\ Clause x) :- coq.env.univpoly? InstGR _, !, coq.env.typeof InstGR Ty, pi x\ tc.compile.instance Ty (pglobal InstGR x) (Clause x). instance-gr InstGR Clause :- coq.env.typeof InstGR Ty, tc.compile.instance Ty (global InstGR) Clause. namespace goal { % [uvar-pair V1 Ty V2] List of uvar for link-eta-dedup % V1 has arity n and V2 has arity n+1 % If V1 has type A -> B, then A = Ty pred uvar-pair i:term, o:term, o:term. % Type Var Cnt uvar-pair-list pred make-pairs-aux i:term, i:term, o:list prop. make-pairs-aux (prod _ Ty Bo) V [pi x\ uvar-pair x Ty X' :- x == V, ! | L] :- !, pi x\ make-pairs-aux (Bo x) X' L. make-pairs-aux _ _ []. pred make-pairs i:list term, o:list prop. make-pairs [] [] :- !. make-pairs [X|Xs] L :- !, coq.typecheck X Ty ok, make-pairs-aux Ty X L', make-pairs Xs L'', std.append L' L'' L. pred get-uva-pair-arity i:term, i:list term, o:term. get-uva-pair-arity X [] X :- !. get-uva-pair-arity X [_|L] Z :- uvar-pair X _ Y, !, get-uva-pair-arity Y L Z. pred decompile-problematic-term i:term, i:list prop, o:term, o:list prop. decompile-problematic-term (tc.maybe-eta-tm T S) L V [tc.link.eta V T' | L2] :- prune V S, !, fold-map T L T' L2. decompile-problematic-term (tc.prod-range T _) A T' A' :- fold-map T A T' A'. decompile-problematic-term (tc.maybe-llam-tm (app [app[H|S] | NPF]) Sc) L Z [NL|L'] :- !, prune Z Sc, get-uva-pair-arity H S Y, std.fold-map NPF L fold-map Tl L', NL = tc.link.llam Z (app[Y | Tl]). % TODO: complete this fold decompile-problematic-term (app[X|S]) L Z L :- var X _ Scope, std.append Scope S Scope', distinct_names Scope', !, get-uva-pair-arity X S Y, prune Z Scope', var Z Y Scope'. decompile-problematic-term A L A L :- var A, !. decompile-problematic-term (fun N Ty Bo) L (fun N Ty' Bo') L3 :- (pi x\ fold-map (Bo x) [] (Bo' x) (Lx x)), close-term-no-prune-ty Lx Ty L1, fold-map Ty L Ty' L2, std.append L2 L1 L3. decompile-problematic-term (prod N Ty Bo) L (prod N Ty' Bo') L3 :- (pi x\ fold-map (Bo x) [] (Bo' x) (Lx x)), close-term-no-prune-ty Lx Ty L1, fold-map Ty L Ty' L2, std.append L2 L1 L3. pred compile i:term, i:list prop, o:term, o:list prop. compile T L T' L' :- (pi t l t' l'\ fold-map t l t' l' :- decompile-problematic-term t l t' l', !) => fold-map T L T' L'. % Uva Binders LinkEta pred build-eta-links-of-vars-aux i:term, i:list term, o:list prop. build-eta-links-of-vars-aux Old L [Hd | Xs] :- uvar-pair Old Ty Next, !, prune OldScope L, prune Name L, var OldScope Old L, Hd = tc.link.eta OldScope (fun Name Ty (x\ NextScope x)), pi x\ sigma L'\ std.append L [x] L', prune (NextScope x) L', var (NextScope x) Next L', build-eta-links-of-vars-aux Next L' (Ys x), !, sigma Closed\ (close-term-no-prune-ty Ys Ty Closed), Xs = Closed. build-eta-links-of-vars-aux _ _ []. pred build-eta-links-of-vars i:list term, o:list prop. build-eta-links-of-vars [] []. build-eta-links-of-vars [V|Vars] L :- var V Hd S, build-eta-links-of-vars-aux Hd S L', build-eta-links-of-vars Vars L'', std.append L' L'' L. } % Goal Goal' Links pred goal i:term, o:term, o:list prop. :name "compile-goal" goal Goal Goal' Links :- tc.precomp.goal Goal GoalPrecomp Vars, !, goal.make-pairs Vars Pairs, Pairs => ( std.assert!(goal.build-eta-links-of-vars Vars EtaLinks) "[TC] cannot build eta-links", std.assert!(goal.compile GoalPrecomp EtaLinks Goal' Links) "[TC] cannot compile goal" ). } }coq-elpi-2.4.0/apps/tc/elpi/ho_link.elpi000066400000000000000000000136201474173443600200450ustar00rootroot00000000000000namespace tc { namespace link { pred get-vars i:term, o:list term. get-vars T R :- (pi X H L Ign\ fold-map X L X [H|L] :- var X H Ign, !) => fold-map T [] _ R. %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % ETA LINK % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% namespace eta { pred eta-expand i:term, o:term. eta-expand T1 (fun _ _ B) :- (name T1; is-coq-term T1), !, pi x\ coq.mk-app T1 [x] (B x). eta-expand T1 (fun _ _ R) :- pi x\ name (R x) T1 [x]. :index (_ _ 1) pred may-contract-to i:list term, i:term, i:term. may-contract-to _ N N :- name N, !. may-contract-to L N V :- var V _ S, !, std.forall [N|L] (x\ exists! S (may-contract-to [] x)). may-contract-to L N (app [N|A]) :- std.length A {std.length L}, std.forall2 {std.rev L} A (may-contract-to []). may-contract-to L N (fun _ _ B) :- pi x\ may-contract-to [x|L] N (B x). pred occurs-rigidly i:term, i:term. occurs-rigidly N N :- name N, !. occurs-rigidly _ V :- var V, !, fail. occurs-rigidly N (app A) :- exists! A (occurs-rigidly N). occurs-rigidly N (fun _ _ B) :- pi x\ occurs-rigidly N (B x). pred maybe-eta-aux i:term, i:list term. maybe-eta-aux V L :- var V _ S, std.forall L (std.mem! S). maybe-eta-aux (app [_|A]) L :- SplitLen is {std.length A} - {std.length L}, split-at-not-fatal SplitLen A HD TL, std.forall L (x\ not (exists! HD (occurs-rigidly x))), std.forall2 {std.rev L} TL (may-contract-to []). maybe-eta-aux (fun _ _ B) L :- pi x\ maybe-eta-aux (B x) [x|L]. pred maybe-eta i:term. maybe-eta (fun _ _ B) :- pi x\ maybe-eta-aux (B x) [x]. pred unify-left-right i:term, i:term. unify-left-right (fun _ _ A) (fun _ _ A') :- !, pi x\ unify-left-right (A x) (A' x). unify-left-right A (fun _ _ _ as T) :- !, eta-expand A Ae, pi x\ unify-left-right Ae T. unify-left-right A A' :- A = A'. pred progress-eta-left i:term, o:term. progress-eta-left A _ :- var A, !, fail. progress-eta-left (fun _ _ A) (fun _ _ A). progress-eta-left A A' :- (name A; is-coq-term A), !, eta-expand A A'. pred progress-eta-right i:term, o:term. progress-eta-right (fun _ _ B as T) T :- pi x\ var (B x), !, fail. progress-eta-right A A' :- coq.reduction.eta-contract A A', not (A = A'), !. progress-eta-right A A :- not (maybe-eta A), !. pred scope-check i:term, i:term. scope-check (uvar _ L) T :- prune A L, A = T, !. pred relocate i:list term, i:list term, i:term, o:term. relocate [] [] T T' :- copy T T', coq.say "Copy result is" T T'. relocate [X|Xs] [Y|Ys] T T' :- coq.say "Charging" (copy Y X), (copy Y X :- !) => relocate Xs Ys T T'. pred collect-store o:list prop. pred collect-store-aux i:list prop, o:list prop. collect-store L :- collect-store-aux [] L. collect-store-aux X L :- declare_constraint (collect-store-aux X L) [_]. pred unify-eta i:term, i:term. % unify-eta A B :- coq.say "Unify-eta" "A"A"B"B, fail. unify-eta A B :- var A, !, A = B, !. unify-eta (fun _ _ A) (fun _ _ B) :- !, pi x\ unify-eta (A x) (B x). unify-eta A (fun _ _ _ as B) :- !, eta-expand A A', unify-eta A' B. unify-eta A B :- A = B. constraint eta uvar relocate fun collect-store-aux solve-eta { rule solve-eta \ (eta A B) <=> (unify-eta A B). rule \ solve-eta. % rule (N1 : G1 ?- eta (uvar X L1) (fun _ T1 B1)) % \ (N2 : G2 ?- eta (uvar X L2) (fun _ T2 B2)) % | ( % pi x\ relocate L1 L2 (B2 x) (B2' x) % % coq.say "Deduplicating" % % (eta (uvar X L1) (fun _ T1 B1)) % % (eta (uvar X L2) (fun _ T2 B2)) % % "B2' is" (B2') % ) % <=> (N1 : G1 ?- B1 = B2'). % TODO: link collect do not work since it closes links and % therefore variables are prune % rule \ (tc.link.eta A B) (collect-store-aux L R) | (coq.say A B {names}) <=> (collect-store-aux [tc.link.eta A B|L] R). % rule \ (collect-store-aux L R) <=> (R = L). } pred eta i:term, i:term. eta _ B :- var B, coq.error "[TC] link.eta error, flexible rhs". eta A (fun _ _ B as T) :- not (var A), not (var B), !, unify-left-right A T. eta A B :- progress-eta-right B B', !, A = B'. eta A B :- progress-eta-left A A', !, A' = B. eta A B :- scope-check A B, get-vars B Vars, declare_constraint (eta A B) [_,A|Vars]. } %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % LLAM LINK % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% namespace llam { pred llam i:term, i:term. llam A (uvar _ S as T) :- distinct_names S, !, A = T. llam A (app [H|L] as T) :- var A, var H, !, get-vars T Vars, declare_constraint (llam A (app [H|L])) [_,A|Vars]. llam (fun _ _ _ as F) (app [H | TL]) :- var H _ Scope, !, std.drop-last 1 TL TL', H = fun _ _Ty (x\ Bo'), % TODO give a valid _Ty: should be: (Ty of dropped -> Ty of F) prune H' Scope, coq.mk-app H' TL' Bo', pi x\ llam F Bo'. llam A B :- !, tc.unify-eq A B. constraint solve-llam solve-llam-t llam { rule solve-llam \ (llam A B) <=> (A = B). rule \ solve-llam. } } pred eta i:term, i:term. eta A B :- eta.eta A B. pred solve-eta. solve-eta :- declare_constraint solve-eta [_]. pred llam i:term, i:term. llam A B :- llam.llam A B. pred solve-llam. solve-llam :- declare_constraint solve-llam [_]. } }coq-elpi-2.4.0/apps/tc/elpi/ho_precompile.elpi000066400000000000000000000304751474173443600212560ustar00rootroot00000000000000namespace tc { shorten tc.{r-ar, range-arity}. namespace precomp { namespace instance { % Tells if the current name is a bound variables pred is-name o:term. % Tells if the current name stands for a uvar pred is-uvar o:term. :index (_ _ 1) pred may-contract-to i:list term, i:term, i:term. may-contract-to _ N N :- !. may-contract-to L N (app [V|S]) :- var V, !, std.forall [N|L] (x\ exists! S (may-contract-to [] x)). may-contract-to L N (app [V|S]) :- is-uvar V, !, std.forall [N|L] (x\ exists! S (may-contract-to [] x)). may-contract-to L N (app [N|A]) :- std.length A {std.length L}, std.forall2 {std.rev L} A (may-contract-to []). may-contract-to L N (fun _ _ B) :- pi x\ may-contract-to [x|L] N (B x). :index (_ 1) pred occurs-rigidly i:term, i:term. occurs-rigidly N N :- name N, !. occurs-rigidly _ (app [N|_]) :- is-uvar N, !, fail. occurs-rigidly _ (app [N|_]) :- var N, !, fail. occurs-rigidly N (app A) :- exists! A (occurs-rigidly N). occurs-rigidly N (fun _ _ B) :- pi x\ occurs-rigidly N (B x). pred maybe-eta-aux i:term, i:list term. maybe-eta-aux (app[V|S]) L :- is-uvar V, !, std.forall L (x\ exists! S (y\ may-contract-to [] x y)). maybe-eta-aux (app[V|S]) L :- var V, !, std.forall L (x\ exists! S (y\ may-contract-to [] x y)). maybe-eta-aux (app [_|A]) L :- SplitLen is {std.length A} - {std.length L}, split-at-not-fatal SplitLen A HD TL, std.forall L (x\ not (exists! HD (occurs-rigidly x))), std.forall2 {std.rev L} TL (may-contract-to []). maybe-eta-aux (fun _ _ B) L :- pi x\ maybe-eta-aux (B x) [x|L]. pred maybe-eta i:term. maybe-eta (fun _ _ B) :- pi x\ maybe-eta-aux (B x) [x]. pred free-var o:list term. free-var L :- std.findall (is-name _) T, std.map T (x\y\ x = is-name y) L. pred split-pf i:list term, i:list term, o:list term, o:list term. split-pf [] _ [] [] :- !. split-pf [X|Xs] Old [X|Ys] L :- is-name X, not (std.mem! Old X), !, split-pf Xs [X|Old] Ys L. split-pf Xs _ [] Xs. kind positivity type. type is_pos positivity. type is_neg positivity. type is_neg_fix positivity. :index (1 _) pred neg i:positivity, o:positivity. neg is_pos is_neg :- !. neg is_neg is_pos :- !. neg is_neg_fix is_neg_fix :- !. macro @max-min :- r-ar inf z. pred min-max-nat i:range-arity, i:range-arity, o:range-arity. min-max-nat (r-ar A B) (r-ar A' B') (r-ar A'' B'') :- !, min-nat A A' A'', max-nat B B' B''. % TODO: this is incomplete: it lacks of some term constructors pred get-range-arity-aux i:term, i:term, o:range-arity. get-range-arity-aux N N (r-ar z z) :- !. get-range-arity-aux _ N @max-min :- name N, !. get-range-arity-aux T (app [T|L]) R :- !, length-nat L Len, std.fold L (r-ar Len Len) (x\y\w\ sigma M\ get-range-arity-aux T x M, min-max-nat y M w) R. get-range-arity-aux T (app [_|L]) R :- !, std.fold L @max-min (x\y\w\ sigma M\ get-range-arity-aux T x M, min-max-nat y M w) R. get-range-arity-aux T (fun _ Ty B) R2 :- !, get-range-arity-aux T Ty R, (pi x\ get-range-arity-aux T (B x) R1), min-max-nat R R1 R2. get-range-arity-aux T (prod _ Ty B) R2 :- !, get-range-arity-aux T Ty R, (pi x\ get-range-arity-aux T (B x) R1), min-max-nat R R1 R2. get-range-arity-aux _ (global _) @max-min :- !. get-range-arity-aux _ uvar @max-min :- !. get-range-arity-aux _ (sort _) @max-min :- !. get-range-arity-aux _ (pglobal _ _) @max-min :- !. get-range-arity-aux A B _ :- coq.error "Count maximal arity failure" A B. pred get-range-arity i:term, i:term, i:term, o:range-arity. get-range-arity _ Ty _ (r-ar z N) :- tc.get-TC-of-inst-type Ty _, !, count-prod Ty N. get-range-arity B _ T N :- !, get-range-arity-aux B T N. pred precompile-aux i:positivity, i:term, i:nat, o:term, o:nat. precompile-aux _ X A Y A :- name X, !, X = Y, !. % avoid loading "precompile-aux x A x A" at binders precompile-aux _ (global _ as C) A C A :- !. precompile-aux _ (pglobal _ _ as C) A C A :- !. precompile-aux _ (sort _ as C) A C A :- !. % Detect maybe-eta term % TODO: should I precompile also the type of the fun and put it in the output term precompile-aux _ (fun Name Ty B as T) N (tc.maybe-eta-tm (fun Name Ty B') Scope) (s M) :- maybe-eta T, !, free-var Scope, precompile-aux is_neg_fix Ty N _ N', (pi x\ is-name x => precompile-aux is_neg_fix (B x) N' (B' x) M). precompile-aux _ (app [X|XS]) N (tc.maybe-llam-tm (app [app[X | PF] | NPF1]) Scope) (s M) :- if (is-uvar X) (Sc = []) (var X _ Sc), split-pf XS Sc PF NPF, not (NPF = []), !, % else XS is a list of distinct names, i.e. `app [X|XS]` is in PF free-var Scope, std.fold-map NPF N (precompile-aux is_neg_fix) NPF1 M. % Charge if we work with unification variable or local name % And returns the subterms is a prod-range precompile-aux IsP (prod Name Ty B) N (tc.prod-range (prod Name Ty' B') MaxAr) P :- !, std.assert! (pi x\ get-range-arity x Ty (B x) MaxAr) "[TC] get-range-arity should not fail", if (IsP = is_pos) (C = x\ is-uvar x) (C = x\ is-name x), std.assert! (pi x\ C x => precompile-aux IsP (B x) N (B' x) M) "[TC] should not fail", precompile-aux {neg IsP} Ty M Ty' P. % Working with fun precompile-aux _ (fun N T F) A (fun N T1 F1) A2 :- !, precompile-aux _ T A T1 A1, pi x\ is-name x => precompile-aux is_neg_fix (F x) A1 (F1 x) A2. precompile-aux _ (app L) A (app L1) A1 :- !, std.fold-map L A (precompile-aux is_neg_fix) L1 A1. precompile-aux _ X A X A :- var X, !. % TODO: what about the following constructors? % precompile-aux IsP (let N T B F) A (let N T1 B1 F1) A3 :- !, % precompile-aux IsP T A T1 A1, precompile-aux IsP B A1 B1 A2, pi x\ is-name x => precompile-aux IsP (F x) A2 (F1 x) A3. % precompile-aux IsP (fix N Rno Ty F) A (fix N Rno Ty1 F1) A2 :- !, % precompile-aux IsP Ty A Ty1 A1, pi x\ is-name x => precompile-aux IsP (F x) A1 (F1 x) A2. % precompile-aux IsP (match T Rty B) A (match T1 Rty1 B1) A3 :- !, % precompile-aux IsP T A T1 A1, precompile-aux IsP Rty A1 Rty1 A2, std.fold-map B A2 (precompile-aux IsP) B1 A3. % precompile-aux _ (primitive _ as C) A C A :- !. % precompile-aux IsP (uvar M L as X) A W A1 :- var X, !, std.fold-map L A (precompile-aux IsP) L1 A1, coq.mk-app-uvar M L1 W. % % when used in CHR rules % precompile-aux IsP (uvar X L) A (uvar X L1) A1 :- std.fold-map L A (precompile-aux IsP) L1 A1. pred get-univ-instances i:term, o:list univ-instance. get-univ-instances T L :- (pi x L\ fold-map (pglobal _ x) L _ [x | L] :- !) => fold-map T [] _ L, !. pred get-univ i:term, o:list univ. get-univ T L :- coq.univ.variable.set.elements {coq.univ.variable.of-term T} Vars, std.map Vars (x\r\ coq.univ.variable r x) L. } /* [tc.precomp.instance T T' N] Returns T' N from T, where: T' is obtained by the replacement of - all maybe-eta term `t1` with (tc.maybe-eta-tm `t1` `s`) where `s` = FV(`t1`) ==> This helps knowing if a subterm should be replaced with a `eta-link` - all `prod _ Ty (x\ Bo x)` with (tc.prod-range (prod _ Ty (x\ Bo x)) N), where N is represent the "maximal" application of `x` in `Bo` for example: let Ty = {{Type -> Type -> Type -> Type -> Type}}, and Bo = x\ c1 (x nat bool) (x nat) (x nat nat bool) the term `prod _ Ty Bo` is replaced with (tc.prod-range (prod _ T Bo) 3) since x is applied at most 3 times in Bo ==> This helps charging the right number of `eta-link` for map-deduplication rule N is the number of problematic terms in T */ pred instance i:term, o:term, o:nat, o:list univ, o:list univ-instance. instance T T' N UnivConstL UnivInstL :- tc.precomp.instance.get-univ T UnivConstL, tc.precomp.instance.get-univ-instances T UnivInstL, std.assert!(instance.precompile-aux instance.is_pos T z T' N) "[TC] cannot precompile instance". namespace goal { :index (_ _ 1) pred may-contract-to i:list term, i:term, i:term. may-contract-to _ N N :- !. % TODO: here we should do var V _ Scope and use scope: N can be in Scope but not in S may-contract-to L N (app [V|S]) :- var V, !, std.forall [N|L] (x\ exists! S (may-contract-to [] x)). may-contract-to L N (app [N|A]) :- std.length A {std.length L}, std.forall2 {std.rev L} A (may-contract-to []). may-contract-to L N (fun _ _ B) :- pi x\ may-contract-to [x|L] N (B x). :index (_ 1) pred occurs-rigidly i:term, i:term. occurs-rigidly N N :- name N, !. occurs-rigidly _ (app [N|_]) :- var N, !, fail. occurs-rigidly N (app A) :- exists! A (occurs-rigidly N). occurs-rigidly N (fun _ _ B) :- pi x\ occurs-rigidly N (B x). pred maybe-eta-aux i:term, i:list term. % TODO: here we should do var V _ Scope and use Scope: an elt in L can appear in Scope maybe-eta-aux (app[V|S]) L :- var V, !, std.forall L (x\ exists! S (y\ may-contract-to [] x y)). maybe-eta-aux (app [_|A]) L :- SplitLen is {std.length A} - {std.length L}, split-at-not-fatal SplitLen A HD TL, std.forall L (x\ not (exists! HD (occurs-rigidly x))), std.forall2 {std.rev L} TL (may-contract-to []). maybe-eta-aux (fun _ _ B) L :- pi x\ maybe-eta-aux (B x) [x|L]. pred maybe-eta i:term. maybe-eta (fun _ _ B) :- pi x\ maybe-eta-aux (B x) [x]. pred split-pf i:list term, i:list term, o:list term, o:list term. split-pf [] _ [] [] :- !. split-pf [X|Xs] Old [X|Ys] L :- name X, not (std.mem! Old X), !, split-pf Xs [X|Old] Ys L. split-pf Xs _ [] Xs. pred precompile-aux i:term, i:list term, o:term, o:list term. precompile-aux X A Y A :- name X, !, X = Y, !. % avoid loading "precompile-aux x A x A" at binders precompile-aux (global _ as C) A C A :- !. precompile-aux (pglobal _ _ as C) A C A :- !. precompile-aux (sort _ as C) A C A :- !. % Detect maybe-eta term precompile-aux (fun Name Ty B as T) N (tc.maybe-eta-tm (fun Name Ty' B') Scope) M :- maybe-eta T, !, names Scope, (pi x\ precompile-aux (B x) N (B' x) M'), precompile-aux Ty M' Ty' M. % Detect maybe-beta term precompile-aux (app [X|XS]) N (tc.maybe-llam-tm (app [app[X | PF] | NPF1]) Scope1) [X|M] :- var X _ Scope, split-pf XS Scope PF NPF, not (NPF = []), !, % else XS is a list of distinct names, i.e. `app [X|XS]` is in PF names Scope1, std.fold-map NPF N precompile-aux NPF1 M. % In the goal there are precompile-aux (prod Name Ty B) N (tc.prod-range (prod Name Ty' B') (r-ar z MaxAr)) P :- !, count-prod Ty MaxAr, std.assert! (pi x\ precompile-aux (B x) N (B' x) M) "[TC] should not fail", precompile-aux Ty M Ty' P. % Working with fun precompile-aux (fun N T F) A (fun N T F1) A2 :- !, A = A1, /*precompile-aux IsP T A T1 A1,*/ pi x\ precompile-aux (F x) A1 (F1 x) A2. precompile-aux (app L) A (app L1) A1 :- !, std.fold-map L A precompile-aux L1 A1. precompile-aux (let N T B F) A (let N T1 B1 F1) A3 :- !, precompile-aux T A T1 A1, precompile-aux B A1 B1 A2, pi x\ precompile-aux (F x) A2 (F1 x) A3. precompile-aux (fix N Rno Ty F) A (fix N Rno Ty1 F1) A2 :- !, precompile-aux Ty A Ty1 A1, pi x\ precompile-aux (F x) A1 (F1 x) A2. precompile-aux (match T Rty B) A (match T1 Rty1 B1) A3 :- !, precompile-aux T A T1 A1, precompile-aux Rty A1 Rty1 A2, std.fold-map B A2 precompile-aux B1 A3. precompile-aux (primitive _ as C) A C A :- !. precompile-aux X A X [X|A] :- var X, !. } pred goal i:term, o:term, o:list term. goal T T' Vars' :- std.assert!(goal.precompile-aux T [] T' Vars) "[TC] cannot precompile goal", undup-same Vars Vars'. } }coq-elpi-2.4.0/apps/tc/elpi/modes.elpi000066400000000000000000000115041474173443600175300ustar00rootroot00000000000000namespace tc { shorten tc.{pending-mode}. typeabbrev elpi-mode (pair argument_mode string). typeabbrev elpi-modeL (list elpi-mode). typeabbrev string-modeL (list string). macro @pending-mode! :- "pending mode". pred string->coq-mode o:string, o:hint-mode. string->coq-mode uvar uvar :- coq.error "[TC] string->coq-mode". string->coq-mode "!" mode-input :- !. string->coq-mode "+" mode-ground :- !. string->coq-mode "-" mode-output :- !. 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->elpi-mode i:hint-mode, o:elpi-mode. :name "coq->elpi-mode" coq->elpi-mode mode-ground (pr in "term"). % approximation /* The coq input-mode corresponds to the elpi mode out Instance : option_equiv : ∀ {A : Type}, Equiv A → Equiv (option A) Mode: Equiv ! Check _ : forall x, Equiv A -> Equiv (option _). In coq, the Check gives the instance option_equiv In elpi, we would have the rule: `tc-Equiv (option A) (option_equiv A B) :- tc-equiv A B.` since the argument in first position of the premise is flexible, then we have a failure */ coq->elpi-mode mode-input (pr out "term"). coq->elpi-mode mode-output (pr out "term"). pred string->elpi-mode i:string, o:elpi-mode. string->elpi-mode S R :- coq->elpi-mode {string->coq-mode S} R, !. string->elpi-mode _ (pr out "term"). pred elpi->string-mode i:elpi-mode, o:string. elpi->string-mode (pr in _) "i" :- !. elpi->string-mode (pr out _) "o". % 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 (elpi-mode). 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->elpi-mode} [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 add-pending-mode i:list string. add-pending-mode _ :- pending-mode _, coq.error "[TC] A pending mode already exists. Build a class with that mode to avoid this error". add-pending-mode M :- tc.add-tc-db @pending-mode! _ (pending-mode M). pred remove-pending-mode. remove-pending-mode :- tc.remove-clause @pending-mode! (pending-mode []) []. pred check-pending-mode-arity i:gref, i:list A. check-pending-mode-arity GR L :- coq.env.typeof GR Ty, coq.count-prods Ty N, N' is N + 1, std.assert! (std.length L N') "Pending mode invalid for class GR". pred get-elpi-mode i:gref, o:elpi-modeL, o:string-modeL. get-elpi-mode ClassGR EM SM :- pending-mode SM, !, check-pending-mode-arity ClassGR SM, remove-pending-mode, std.map SM string->elpi-mode EM. get-elpi-mode ClassGR EM SM :- modes-of-class ClassGR EM, std.map EM elpi->string-mode SM. pred get-evars i:term, o:list term. get-evars T L :- (pi hd T L\ fold-map T L _ [hd | L] :- var T hd _, !) => fold-map T [] _ L. pred evars o:term. pred action-to-accumulate i:string, i:term, o:list prop. action-to-accumulate _ T [evars HD] :- var T HD _, !. action-to-accumulate _ _ []. pred mode-check i:string, i:term. % heuristic: if we are in "+" mode, then all evars in T should only be % in that argument mode-check "+" T :- !, std.findall-unary evars L, get-evars T EV, std.forall EV (x\ std.forall L (x'\ not (x == x'))). mode-check "!" uvar :- !, fail. mode-check _ _. pred modes-check.aux i:list string, i:list term. modes-check.aux [] [_|_] :- coq.error "[TC] modes-check invalid list length". modes-check.aux [_|_] [] :- coq.error "[TC] modes-check invalid list length". modes-check.aux [] []. modes-check.aux [X|XS] [Y|YS] :- std.do![ mode-check X Y, % check on argument X wrt mode Y action-to-accumulate X Y P, % action P to accumulate P => modes-check.aux XS YS % accumulate P and iterate of XS YS ]. pred modes-check i:term. modes-check (global _). modes-check (pglobal _ _). modes-check (app [ClassTerm | Args]) :- tc.class-gref ClassTerm ClassGR, tc.get-mode ClassGR M, std.drop-last 1 M M', modes-check.aux M' Args. } coq-elpi-2.4.0/apps/tc/elpi/parser_addInstances.elpi000066400000000000000000000031021474173443600223700ustar00rootroot00000000000000/* license: GNU Lesser General Public License Version 2.1 or later */ /* ------------------------------------------------------------------------- */ namespace tc { 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) :- coq.locate ClassName ClassGR, tc.add-tc-or-inst-gr IgnoreClasses [] [ClassGR]. run-command (tcOrInst InstNames) :- std.map InstNames coq.locate InstGR, tc.add-tc-or-inst-gr [] [] InstGR. run-command (path ClassName Path):- tc.add-path ClassName Path. run-command (ignoreInstances ClassName InstNames):- coq.locate ClassName ClassGR, tc.add-tc-or-inst-gr [] InstNames [ClassGR]. run-command (addInstPrio Prio InstanceName) :- coq.locate InstanceName InstGr, tc.compile.instance-gr InstGr C, S is int_to_string Prio, tc.add-tc-db _ (before S) C. }coq-elpi-2.4.0/apps/tc/elpi/rewrite_forward.elpi000066400000000000000000000061111474173443600216240ustar00rootroot00000000000000/* license: GNU Lesser General Public License Version 2.1 or later */ /* ------------------------------------------------------------------------- */ namespace tc { 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.4.0/apps/tc/elpi/solver.elpi000066400000000000000000000056101474173443600177340ustar00rootroot00000000000000/* license: GNU Lesser General Public License Version 2.1 or later */ /* ------------------------------------------------------------------------- */ main _. msolve L N :- tc.time-it tc.oTC-time-msolve (coq.ltac.all (coq.ltac.open tc.solve-aux) L N) "msolve". msolve L _ :- coq.ltac.fail _ "[TC] fail to solve" L. namespace tc { pred build-query-from-goal i:term, i:term, o:prop, o:list prop. build-query-from-goal Goal Proof Q PostProcess :- tc.compile.goal Goal Goal' PostProcess, !, coq.safe-dest-app Goal' (global TC) TL', std.append TL' [Proof] TL, !, coq.elpi.predicate {tc.gref->pred-name TC} TL Q. type tc.mode_fail term. pred refine-proof i:term, i:goal, o:list sealed-goal. refine-proof tc.mode_fail G [seal G] :- !. refine-proof Proof G GL :- if-true print-solution (coq.say "[TC] The proof is <<<" Proof ">>>"), if-true print-solution-pp (coq.say "[TC] The proof is <<<" {coq.term->string Proof} ">>>"), /*********** CHECK IF THE PROOF TYPECHECKS ***********/ tc.time-it tc.oTC-time-refine (@no-tc! => refine.typecheck Proof G GL) "refine.typecheck", if-true print-solution (coq.say "[TC] The proof typechecks"). pred solve-under-context i:term, o:term. solve-under-context Ty Proof :- tc.time-it tc.oTC-time-compile-goal (build-query-from-goal Ty Proof Q PostProcess) "build query", !, if-true print-compiled-goal (coq.say "[TC] the compiled goal is" Q), !, tc.time-it tc.oTC-time-instance-search ( do PostProcess, Q, tc.link.solve-eta, % Trigger eta links tc.link.solve-llam % Trigger llam links ) "instance search". pred solve-aux i:goal, o:list sealed-goal. solve-aux (goal Ctx _ Ty P_ Ag_ as G) GL :- tc.time-it _ (solve-aux1 Ctx Ty Proof) "full instance search", refine-proof Proof G GL. pred solve-aux1 i:goal-ctx, i:term, o:term. :name "solve-aux-intros" solve-aux1 Ctx (prod N X T) Proof :- !, @pi-decl _ X x\ solve-aux1 [decl x N X | Ctx] (T x) (Proof' x), if (Proof' x = tc.mode_fail) (Proof = tc.mode_fail) (Proof = fun N X Proof'). :name "solve-aux-conclusion" solve-aux1 Ctx TyRaw Proof :- tc.time-it _ (tc.normalize-ty TyRaw Ty) "normalize ty", if-true print-goal (coq.say "The goal is <<<" Ty ">>>"), if-true print-goal-pp (coq.say "The goal is <<<" {coq.term->string Ty} ">>>"), tc.time-it tc.oTC-time-mode-check (tc.modes-check Ty) "mode check", !, tc.time-it _ (tc.compile.context Ctx CtxClause) "compile context", !, CtxClause => solve-under-context Ty Proof. solve-aux1 _ _ tc.mode_fail :- if-true (print-solution; print-solution-pp) (coq.say "Invalid mode call"). pred print-solution. % Print the solution in HOAS pred print-solution-pp. % Print the solution in coq pp pred print-goal. % Print the goal in HOAS pred print-goal-pp. % Print the goal with coq pp pred print-compiled-goal. }coq-elpi-2.4.0/apps/tc/elpi/tc_aux.elpi000066400000000000000000000176721474173443600177200ustar00rootroot00000000000000/* license: GNU Lesser General Public License Version 2.1 or later */ /* ------------------------------------------------------------------------- */ namespace tc { % return if a gref is an existsing instance % TODO: this could be replaced with an API % coq.TC.get-class-of-inst i:gref, o:gref pred existing-instance i:gref. existing-instance InstGR :- coq.env.typeof InstGR InstTy, get-TC-of-inst-type InstTy ClassGR, coq.TC.class? ClassGR, coq.TC.db-for ClassGR DB, std.mem! DB (tc-instance InstGR _). pred under-p-global i:term, o:gref. under-p-global (global GR) GR. under-p-global (pglobal GR _) GR. pred class-gref i:term, o:gref. class-gref T ClassGR :- under-p-global T ClassGR, coq.TC.class? ClassGR. % returns the TC from the type of an instance % TODO: This could 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) ClassGR:- !, pi x\ get-TC-of-inst-type (A x) ClassGR. get-TC-of-inst-type T ClassGR :- coq.safe-dest-app T HD _, not (var HD), class-gref HD ClassGR. 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 (tc.instance SectionPath _ _ _) Insts, coq.env.section SectionVars, std.map-filter Insts (x\r\ sigma X\ tc.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 :- if (not (ground_term PR)) (coq.error "[TC] anomaly: open rule:" PR) true, 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 (tc.is-option-active tc.oTC-clauseNameShortName) (Path = "") (coq.gref->path Gr [Hd | Tl], if (Hd = "Coq") (Hd' = "Corelib") (Hd' = Hd), std.string.concat "." [Hd'|Tl] 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 get-mode i:gref, o:list string. get-mode ClassGR M :- tc.class ClassGR _ _ M, !. get-mode ClassGR _ :- coq.error "[TC]" ClassGR "is an unknown class". /* [make-tc.aux B Sol Head Body Rule] builds the rule with the given Head and body paying attention to the positivity of the clause Note: if the Rule being constructed is negative (B = ff), then Rules returns a solution Sol used inside the proof. If the solution is already given, we do not run the premise. This would ask Sol to be ground (ground_term S). Here, for performance issues, we simply check that the solution is not a flexible term */ pred make-tc.aux i:bool, i:term, i:prop, i:list prop, o:prop. make-tc.aux tt _ Head [] Head :- !. make-tc.aux ff Sol Head [] P :- !, P = if (var Sol) Head true. make-tc.aux tt _ Head Body (Head :- Body) :- !. make-tc.aux ff Sol Head Body P :- !, P = if (var Sol) (Body => Head) true. pred make-tc i:term, i:term, i:list prop, i:bool, o:prop. make-tc Goal Sol RuleBody IsPositive Rule :- coq.safe-dest-app Goal Class Args, get-TC-of-inst-type Class ClassGR, gref->pred-name ClassGR ClassStr, std.append Args [Sol] ArgsSol, coq.elpi.predicate ClassStr ArgsSol RuleHead, make-tc.aux IsPositive Sol RuleHead RuleBody Rule. % 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, 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. pred constant->redflag i:prop, o:coq.redflag. constant->redflag (tc.unfold-constant C) (coq.redflags.const C). pred normalize-ty i:term, o:term. :name "normalize-ty" normalize-ty G1 G2 :- std.findall (tc.unfold-constant _) UnfoldFindall, std.map UnfoldFindall constant->redflag UnfoldRF, coq.redflags.add coq.redflags.nored [coq.redflags.beta, coq.redflags.delta | UnfoldRF] RF, @redflags! RF => coq.reduction.lazy.norm G1 G2. pred dummy. pred remove-clause i:string, i:prop, i:list prop. remove-clause ClauseName P Locality :- %Locality => add-tc-db _ (remove ClauseName) P. Locality => add-tc-db _ (replace ClauseName) (P :- fail). % [section-var->decl.aux L R] auxiliary function for `section-var->decl` pred section-var->decl.aux i:list constant, o:list prop. section-var->decl.aux [] []. section-var->decl.aux [X|XS] [Y|YS] :- coq.env.typeof (const X) Ty, Y = (decl (global (const X)) _ Ty), section-var->decl.aux XS YS. % [section-var->decl L] decl representing seciton variables with their types pred section-var->decl o:list prop. section-var->decl L :- section-var->decl.aux {coq.env.section} L. pred time-is-active i:(list string -> prop). :name "time-is-active" time-is-active _ :- coq.option.get ["Time", "TC", "Bench"] (coq.option.bool tt), !. time-is-active Opt :- tc.is-option-active Opt. pred time-aux i:string, i:float. time-aux Msg Time :- !, coq.debug "[TC] - Time of" Msg "is" Time. pred give-res i:prop, o:prop. give-res P true :- P. give-res _ fail. pred time-res i:prop, o:float, o:prop. time-res P T Res :- std.time (give-res P Res) T. pred build-msg i:prop, i:string, o:string. build-msg true S S :- !. build-msg fail S S' :- S' is S ^ " fail". pred time-it i:(list string -> prop), i:prop, i:string. time-it Opt P Msg :- time-is-active Opt, !, time-res P Time Res, build-msg Res Msg Msg', time-aux Msg' Time, Res. time-it _ P _ :- P. kind range-arity type. type r-ar nat -> nat -> range-arity. type prod-range term -> % The current qunatified uvar range-arity -> % Its minimum and maximal application term. type maybe-eta-tm term -> % The current precompiled subterm list term -> % The list of FV in the precomp subterm term. type maybe-llam-tm term -> % The current precompiled subterm: shape is app[app[X,PF],NPF] list term -> % The eta-expanded version of X, from X^{len(PF)} to X^{len(PF)+len(NPF)} term. } coq-elpi-2.4.0/apps/tc/elpi/tc_same_order.elpi000066400000000000000000000020021474173443600212200ustar00rootroot00000000000000% [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 = tc.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 (tc.instance _ _ _ _) ElpiInst, correct_instance_order {coq.TC.db-tc} ElpiInst.coq-elpi-2.4.0/apps/tc/elpi/unif.elpi000066400000000000000000000217611474173443600173700ustar00rootroot00000000000000namespace tc{ namespace unif{ shorten std.{rev, append, ignore-failure!, mem, map2, split-at, map, assert!}. %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %%%%% Unification %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% pred unify-eq i:term, i:term. pred unify-list-eq i:list term, i:list term. pred unify-leq i:term, i:term. % 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 -> A -> prop), i:A, i:A. swap tt F A B :- F B A. swap ff F A B :- F A B. % flexible cases unif (uvar V L) [] T D _ _ :- get-option "unif:greedy" tt, !, bind-list L {unwind T D} V, !. unif (uvar V L) [] T D _ _ :- !, bind-list L {unwind T D} V. unif X C (uvar V L) [] _ _ :- get-option "unif:greedy" tt, !, bind-list L {unwind X C} V, !. 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. % Note lists are reversed + the 2nd length should be leq then the 1st pred unify-lists i:list term, i:list term. unify-lists [X] [Y] :- !, X = Y. unify-lists L [X] :- !, app {std.rev L} = X. unify-lists [X|Xs] [Y|Ys] :- X = Y, unify-lists Xs Ys. pred unify i:term, i:term, i:cumul. unify T1 (app [HD|TL]) _ :- not (var T1), var HD, !, T1 = app L1, unify-lists {std.rev L1} {std.rev [HD|TL]}. unify A B C :- unif {hd-beta A []} {hd-beta B []} ff C. %%%% 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:any. 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. unify-eq X Y :- unify X Y eq. unify-leq X Y :- unify X Y leq. } } pred tc.unif-aux i:(A -> A -> prop), i:A, i:A. tc.unif-aux P A B :- [(pi K A AS X C TA F\ hd-beta (uvar as K) [A|AS] X C :- !, % auto-intro std.assert-ok! (coq.typecheck A TA) "already typed", K = (fun `hd_beta_auto` TA F), hd-beta (F A) AS X C), (pi K A AS X C TA F\ hd-beta-zeta (uvar as K) [A|AS] X C :- !, % auto-intro std.assert-ok! (coq.typecheck A TA) "already typed", K = (fun `hd_beta_zeta_auto` TA F), hd-beta-zeta (F A) AS X C)] => P A B. pred tc.unify-eq i:term, i:term. pred tc.unify-leq i:term, i:term. pred tc.unify-list-eq i:list term, i:list term. tc.unify-eq X Y :- tc.unif-aux tc.unif.unify-eq X Y. tc.unify-leq X Y :- tc.unif-aux tc.unif.unify-leq X Y. tc.unify-list-eq X Y :- tc.unif-aux tc.unif.unify-list X Y. coq-elpi-2.4.0/apps/tc/examples/000077500000000000000000000000001474173443600164325ustar00rootroot00000000000000coq-elpi-2.4.0/apps/tc/examples/dune000066400000000000000000000001461474173443600173110ustar00rootroot00000000000000(coq.theory (name elpi.apps.tc.examples) (theories elpi elpi.apps.tc)) (include_subdirs qualified) coq-elpi-2.4.0/apps/tc/examples/tutorial.v000066400000000000000000000051521474173443600204670ustar00rootroot00000000000000Require 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 "elpi.apps.tc.examples/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 TC Solver Override 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 "elpi.apps.tc.examples/TC.Solver". End Backtrack. TC.Print_instances. TC.Get_class_info DecidableClass.Decidable. coq-elpi-2.4.0/apps/tc/src/000077500000000000000000000000001474173443600154035ustar00rootroot00000000000000coq-elpi-2.4.0/apps/tc/src/META.coq-elpi-tc000066400000000000000000000004131474173443600201660ustar00rootroot00000000000000 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.4.0/apps/tc/src/coq_elpi_class_tactics_takeover.ml000066400000000000000000000137301474173443600243330ustar00rootroot00000000000000(* coq-elpi: Coq terms as the object language of elpi *) (* license: GNU Lesser General Public License Version 2.1 or later *) (* ------------------------------------------------------------------------- *) type aaction = ARm | AAdd | ASet | ANone | AAll module Coq_elpi_lib_obj = struct let add_obj_no_discharge name cache = Libobject.(declare_object (global_object_nodischarge name ~cache ~subst:None)) let add_superobj_no_discharge name cache = Libobject.(declare_object (superglobal_object_nodischarge name ~cache ~subst:None)) end open Util open Typeclasses open Elpi open Elpi_plugin open Coq_elpi_utils module GRSet = Names.GlobRef.Set module CSMap = CString.Map let qname2str observer = String.concat "." observer let str2gr = Coq_elpi_utils.locate_simple_qualid let elpi_fails program_name = let open Pp in let kind = "TC_Solve" 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." ])) module type M = sig type elt type t val empty : t val diff : t -> t -> t val union : t -> t -> t val add : elt -> t -> t val gr2elt : Names.GlobRef.t -> elt val mem : elt -> t -> bool val of_qualid_list : Libnames.qualid list -> t end (* Set of overridden class *) module OSet : M = struct module M = GRSet type t = M.t type elt = M.elt let empty = M.empty let diff = M.diff let union = M.union let add = M.add let mem = M.mem let gr2elt (x: Names.GlobRef.t) : elt = x let of_qualid_list (x: Libnames.qualid list) : t = let add s x = add (Coq_elpi_utils.locate_simple_qualid x) s in List.fold_left add empty x end module Modes = struct (** override_mode *) type omode = | AllButFor of OSet.t | Only of OSet.t type action = | Set of omode | Add of OSet.t | Rm of OSet.t let omodes = ref (CSMap.empty : omode CSMap.t) let create_solver_omode solver = omodes := CSMap.add solver (Only OSet.empty) !omodes let takeover (qname, new_mode,c) = let name = qname2str qname in if c then create_solver_omode name else let old_mode = CSMap.find name !omodes in let new_mode = match old_mode, new_mode with | _, Set(mode) -> mode | AllButFor s, Add grl -> AllButFor (OSet.diff s grl) | AllButFor s, Rm grl -> AllButFor (OSet.union s grl) | Only s, Add grl -> Only (OSet.union s grl) | Only s, Rm grl -> Only (OSet.diff s grl) in omodes := CSMap.set name new_mode !omodes let cache_solver_mode = Coq_elpi_lib_obj.add_superobj_no_discharge "TC_Solver_omode" takeover end module Solver = struct let solve_TC program = let open Class_tactics in { solver = fun env sigma ~depth ~unique ~best_effort ~goals -> let atts = [] in let gls = goals in let query ~base state = let loc = Elpi.API.State.get Coq_elpi_builtins_synterp.invocation_site_loc state in let depth = 0 in let state, q, gls = Coq_elpi_HOAS.solvegoals2query sigma gls loc ~main:[] ~in_elpi_tac_arg:Coq_elpi_arg_HOAS.(in_elpi_tac ~loc:(to_coq_loc loc)) ~depth ~base 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, qatts, gls in let loc = Loc.initial Loc.ToplevelInput in match Coq_elpi_vernacular.Interp.get_and_compile ~loc program with | None -> assert false | Some (base,_) -> match Coq_elpi_vernacular.Interp.run ~loc base (Fun (query ~base)) with | API.Execute.Success solution -> let sigma, sub_goals, to_shelve = Coq_elpi_HOAS.solution2evd ~eta_contract_solution:true sigma solution (Evar.Set.of_list goals) in let sigma = Evd.shelve sigma sub_goals in sub_goals = [], 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)) -> raise Not_found } type action = | Create | Activate | Deactivate 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,_),_)) -> OSet.mem (OSet.gr2elt cl.cl_impl) classes | None -> default let covered omode env sigma s = match omode () with | Modes.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 action_manager (qname, x) = let name = qname2str qname in match x with | Create -> Class_tactics.register_solver ~name (solve_TC qname, covered (fun () -> CSMap.get name !Modes.omodes)); | Activate -> Class_tactics.activate_solver ~name | Deactivate -> Class_tactics.deactivate_solver ~name let cache_solver = Coq_elpi_lib_obj.add_superobj_no_discharge "TC_Solver" action_manager end let set_solver_mode kind qname (l: Libnames.qualid list) = let l = OSet.of_qualid_list l in let cache_solver_mode = Modes.cache_solver_mode in match kind with | AAdd -> Lib.add_leaf (cache_solver_mode (qname, Add l, false)) | ARm -> Lib.add_leaf (cache_solver_mode (qname, Rm l, false)) | AAll -> Lib.add_leaf (cache_solver_mode (qname, Set (AllButFor OSet.empty), false)) | ANone-> Lib.add_leaf (cache_solver_mode (qname, Set (Only OSet.empty), false)) | ASet -> Lib.add_leaf (cache_solver_mode (qname, Set (Only l), false)) let solver_register l = Lib.add_leaf (Solver.cache_solver (l, Create)); Lib.add_leaf (Modes.cache_solver_mode (l, Add OSet.empty, true)) let solver_activate l = Lib.add_leaf (Solver.cache_solver (l, Activate)) let solver_deactivate l = Lib.add_leaf (Solver.cache_solver (l, Deactivate)) coq-elpi-2.4.0/apps/tc/src/coq_elpi_class_tactics_takeover.mli000066400000000000000000000011111474173443600244720ustar00rootroot00000000000000(* coq-elpi: Coq terms as the object language of elpi *) (* license: GNU Lesser General Public License Version 2.1 or later *) (* ------------------------------------------------------------------------- *) type aaction = ARm | AAdd | ASet | ANone | AAll val set_solver_mode : aaction -> string list -> Libnames.qualid list -> unit val solver_register : Elpi_plugin.Coq_elpi_utils.qualified_name -> unit val solver_activate : Elpi_plugin.Coq_elpi_utils.qualified_name -> unit val solver_deactivate : Elpi_plugin.Coq_elpi_utils.qualified_name -> unit coq-elpi-2.4.0/apps/tc/src/coq_elpi_tc_hook.mlg000066400000000000000000000045001474173443600214040ustar00rootroot00000000000000(* license: GNU Lesser General Public License Version 2.1 or later *) (* ------------------------------------------------------------------------- *) DECLARE PLUGIN "coq-elpi.tc" { 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" "TC" "Solver" "Register" qualified_name(p) ] -> { let () = ignore_unknown_attributes atts in solver_register(snd p) } | #[ atts = any_attribute ] [ "Elpi" "TC" "Solver" "Activate" qualified_name(p) ] -> { let () = ignore_unknown_attributes atts in solver_activate(snd p) } | #[ atts = any_attribute ] [ "Elpi" "TC" "Solver" "Deactivate" qualified_name(p) ] -> { let () = ignore_unknown_attributes atts in solver_deactivate(snd p) } | #[ atts = any_attribute ] [ "Elpi" "TC" "Solver" "Override" qualified_name(p) "All" ] -> { let () = ignore_unknown_attributes atts in set_solver_mode AAll (snd p) [] } | #[ atts = any_attribute ] [ "Elpi" "TC" "Solver" "Override" qualified_name(p) "None" ] -> { let () = ignore_unknown_attributes atts in set_solver_mode ANone (snd p) [] } | #[ atts = any_attribute ] [ "Elpi" "TC" "Solver" "Override" qualified_name(p) "Only" ne_reference_list(cs) ] -> { let () = ignore_unknown_attributes atts in set_solver_mode ASet (snd p) cs } | #[ atts = any_attribute ] [ "Elpi" "TC" "Solver" "Override" qualified_name(p) "Add" reference_list(cs) ] -> { let () = ignore_unknown_attributes atts in set_solver_mode AAdd (snd p) cs } | #[ atts = any_attribute ] [ "Elpi" "TC" "Solver" "Override" qualified_name(p) "Rm" reference_list(cs) ] -> { let () = ignore_unknown_attributes atts in set_solver_mode ARm (snd p) cs } ENDcoq-elpi-2.4.0/apps/tc/src/coq_elpi_tc_register.ml000066400000000000000000000127011474173443600221230ustar00rootroot00000000000000(* 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 = [Cmd.String "new_class"; gref2elpi_term x.cl_impl] let observer_default_instance (x : Typeclasses.typeclass) : Coq_elpi_arg_HOAS.Cmd.raw list = [Cmd.String "default_instance";gref2elpi_term x.cl_impl] let observer_coercion add (x : Typeclasses.typeclass) : Coq_elpi_arg_HOAS.Cmd.raw list = let name2str x = Cmd.String (Names.Name.print x |> Pp.string_of_ppcmds) in let proj = x.cl_projs |> List.map (fun (x: Typeclasses.class_method) -> x.meth_name) in let mode = if add then "add_coercions" else "remove_coercions" in Cmd.String mode :: List.map name2str proj (** 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 [ Cmd.String "new_instance"; gref2elpi_term instance; gref2elpi_term class_name; locality2elpi_string locality; prio2elpi_int info ] let class_runner f cl = let actions = [ observer_coercion false; observer_class; observer_coercion true; (* observer_default_instance *) ] in List.iter (fun obs -> f (obs cl)) actions let inObservation = Libobject.declare_object @@ Libobject.local_object "TC_HACK_OBSERVER_CLASSES" ~cache:(fun (run,cl) -> class_runner run 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 x = match x with | Create (name, loc_name_atts) -> let t1 = Sys.time () in begin try let observer = Classes.register_observer ~name (observer_evt loc_name_atts) in observers := StringMap.add name observer !observers; Classes.activate_observer observer with e when CErrors.is_anomaly e -> Feedback.msg_warning Pp.(str (Printf.sprintf "%s already registered" name)) end; let t2 = Sys.time () in if Coq_elpi_tc_time.get_time_tc_bench () then Feedback.msg_debug Pp.(str @@ Printf.sprintf "[TC] register.ml time is %.5f" (t1 -. t2)) | 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.4.0/apps/tc/src/coq_elpi_tc_time.ml000066400000000000000000000006721474173443600212410ustar00rootroot00000000000000open Elpi_plugin let time_tc_bench = ref false let set_time_tc_bench = (:=) time_tc_bench let get_time_tc_bench () = !time_tc_bench let () = Goptions.declare_bool_option { optstage = Summary.Stage.Interp; optdepr = None; optkey = ["Time";"TC";"Bench"]; optread = get_time_tc_bench; optwrite = set_time_tc_bench; } let time_all b = CDebug.set_flag Coq_elpi_utils.elpitime_flag b; set_time_tc_bench bcoq-elpi-2.4.0/apps/tc/src/dune000066400000000000000000000004731474173443600162650ustar00rootroot00000000000000(library (name elpi_tc_plugin) (public_name coq-elpi.tc) (flags :standard -w -27) (preprocess (pps ppx_optcomp -- -cookie "ppx_optcomp.env=env ~coq:(Defined \"%{coq:version.major}.%{coq:version.minor}\")")) (libraries coq-core.plugins.ltac coq-core.vernac coq-elpi.elpi)) (coq.pp (modules coq_elpi_tc_hook)) coq-elpi-2.4.0/apps/tc/src/elpi_tc_plugin.mlpack000066400000000000000000000001261474173443600215700ustar00rootroot00000000000000Coq_elpi_tc_time Coq_elpi_tc_register Coq_elpi_class_tactics_takeover Coq_elpi_tc_hookcoq-elpi-2.4.0/apps/tc/tests/000077500000000000000000000000001474173443600157565ustar00rootroot00000000000000coq-elpi-2.4.0/apps/tc/tests/WIP/000077500000000000000000000000001474173443600164155ustar00rootroot00000000000000coq-elpi-2.4.0/apps/tc/tests/WIP/add_alias.v000066400000000000000000000011321474173443600205020ustar00rootroot00000000000000From elpi.apps Require Import tc. Elpi TC Solver Override 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.4.0/apps/tc/tests/WIP/cyclicTC_jarl.v000066400000000000000000000035011474173443600213100ustar00rootroot00000000000000From elpi.apps Require Import tc. Elpi Debug "simple-compiler". Set TC NameShortPath. Elpi TC Solver Override 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" tc.make-tc IsHead Ty Inst Hyp Clause :- !, app [global TC | TL] = Ty, tc.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 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 AddRecursivelyDependantTC (A) (B). Elpi Bound Steps 10000. Check (_ : B bool). Check (_ : A nat). coq-elpi-2.4.0/apps/tc/tests/WIP/included_proof.v000066400000000000000000000013331474173443600216000ustar00rootroot00000000000000From 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 TC Solver Override 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.4.0/apps/tc/tests/WIP/premisesSort/000077500000000000000000000000001474173443600211145ustar00rootroot00000000000000coq-elpi-2.4.0/apps/tc/tests/WIP/premisesSort/sort1.v000066400000000000000000000006141474173443600223540ustar00rootroot00000000000000From 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.4.0/apps/tc/tests/WIP/premisesSort/sort2.v000066400000000000000000000014511474173443600223550ustar00rootroot00000000000000From 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 TC Solver Override TC.Solver All. Elpi Print TC.Solver "elpi.apps.tc.tests/TC.Solver". Goal C bool. apply _. Qed. coq-elpi-2.4.0/apps/tc/tests/WIP/premisesSort/sort3.v000066400000000000000000000014151474173443600223560ustar00rootroot00000000000000From 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 TC Solver Override 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.4.0/apps/tc/tests/WIP/premisesSort/sort4.v000066400000000000000000000040311474173443600223540ustar00rootroot00000000000000From 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 TC Solver Override 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. }}. Goal 3 = 3. Fail apply f. Abort.coq-elpi-2.4.0/apps/tc/tests/WIP/premisesSort/sortCode.v000066400000000000000000000112141474173443600230640ustar00rootroot00000000000000 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, tc.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. }}. coq-elpi-2.4.0/apps/tc/tests/auto_compile.v000066400000000000000000000032541474173443600206310ustar00rootroot00000000000000From elpi.apps Require Import tc. Elpi TC Solver Override 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 (tc.instance _ _ _ _) I, std.map-filter I (x\y\ x = tc.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 TC Solver Override 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.4.0/apps/tc/tests/bench/000077500000000000000000000000001474173443600170355ustar00rootroot00000000000000coq-elpi-2.4.0/apps/tc/tests/bench/bench_inj.py000066400000000000000000000074451474173443600213400ustar00rootroot00000000000000import subprocess import time import sys import os import re """ About this file: - it aims to test elpi vs coq performances of type class search. - it should be run from the ./apps/tc folder - parameters of command line: * N : the depth of the tree to build in tests/test.v * -nocoq : optional to test only elpi * -onlyOne : optional to run the test only for the tree of size N. By default, the tests are made for each i in [1..N] included """ INJ_BASE_FUN = "f" KEYS = "coqT, elpiT, tcSearch, refineT, compilT, runtimeT, buildQuery".split(", ") def buildDict(): res = dict() for key in KEYS: res[key] = [] return res def printDict(d): for key in KEYS: d[key] = sum(d[key])/len(d[key]) L = [d[k] for k in KEYS] L.append(d["elpiT"] - d["refineT"] - d["buildQuery"]) L.append(d["coqT"] / d["elpiT"]) L.append(d["elpiT"] / d["coqT"] if d["coqT"] > 0 else 100) print(", ".join(map(lambda x: str(round(x, 5)), L))) def findFloats(s): return [float(x) for x in re.findall("\d+\.\d*", s)] def filterLines(lines): #print(lines) validStarts = ["Finished", "Refine", "Elpi:", "Instance search", "Time build query"] for line in lines.split("\n"): for start in validStarts: if start in line: yield line def parseFile(s): lines = [findFloats(x) for x in filterLines(s)] #print(lines) base = 0 coqT = lines[base][0] buildQuery = lines[base + 1][0] tcSearch = lines[base + 2][0] refineT = lines[base + 3][0] elpiStats = lines[base + 4] compilT, runtimeT = elpiStats[0], elpiStats[-1] elpiT = lines[base + 5][0] res = buildDict() for key in KEYS: res[key].append(eval(key)) #print(res) return res def buildTree(len): if len == 0: return INJ_BASE_FUN + " " S = buildTree(len-1) STR = "(compose " + S + S + ")" return STR accumulate = """ Elpi Accumulate TC_solver lp:{{ :after "firstHook" tc {{:gref Inj}} {{Inj lp:R1 lp:R1 (@compose lp:A lp:A lp:A lp:L lp:R)}} Sol :- L = R, !, tc {{:gref Inj}} {{Inj lp:R1 lp:R1 lp:L}} InjL, Sol = {{@compose_inj lp:A lp:A lp:A lp:R1 lp:R1 lp:R1 lp:L lp:L lp:InjL lp:InjL }}. }}. """ def writeFile(fileName: str, composeLen: int, isCoq: bool): PREAMBLE = f"""\ From elpi.apps.tc.tests Require Import {"stdppInjClassic" if isCoq else "stdppInj"}. {"" if isCoq else 'Elpi TC.Solver. Set TC Time Refine. Set TC Time Instance Search. Set TC Time Build Query. Set Debug "elpitime".'} """ GOAL = buildTree(composeLen) with open(fileName + ".v", "w") as fd: fd.write(PREAMBLE) fd.write(f"Goal Inj eq eq({GOAL}). Time apply _. Qed.\n") def runCoqMake(fileName): fileName = fileName + ".vo" if (os.path.exists(file_name)): subprocess.run(["rm", fileName]) return subprocess.check_output(["make", fileName]).decode() def run(file_name, height): def partialFun(isCoq: bool): writeFile(file_name, height, isCoq) return runCoqMake(file_name) return partialFun def loopTreeDepth(file_name: str, maxHeight: int, makeCoq=True, onlyOne=False): print("Height, Coq, Elpi, TC search, Refine, ElpiCompil, ElpiRuntime, BuildQuery, ElpiNoRefine, Ratio(Coq/Elpi), Ratio(Elpi/Coq)") for i in range(1 if not onlyOne else maxHeight, maxHeight+1): FUN = run(file_name, i) x = FUN(True) if makeCoq else "Finished 0.0" y = FUN(False) print(i, ", ", end="", sep="") # print("The xx result is " , x) dic = parseFile(x + y) printDict(dic) if __name__ == "__main__": print(os.curdir) file_name = "tests/bench/bench_inj" height = int(sys.argv[1]) loopTreeDepth(file_name, height, makeCoq=not ( "-nocoq" in sys.argv), onlyOne=("-onlyOne" in sys.argv)) #writeFile(file_name, 1, False)coq-elpi-2.4.0/apps/tc/tests/bench/bench_inj.v000066400000000000000000000002731474173443600211450ustar00rootroot00000000000000From elpi.apps.tc.tests Require Import stdppInj. Elpi TC.Solver. Set TC Time Refine. Set TC Time Instance Search. Set Debug "elpitime". Goal Inj eq eq((compose f f )). Time apply _. Qed. coq-elpi-2.4.0/apps/tc/tests/bigTest.v000066400000000000000000002345311474173443600175560ustar00rootroot00000000000000From elpi.apps Require Import tc. Elpi TC Solver Override 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 TC Solver Override TC.Solver Rm 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 := {}. Set Warnings "-future-coercion-class-field". 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 1, left associativity, format "p .1"). Notation "p .2" := (snd p) (at level 1, 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 TC Solver Override TC.Solver Rm 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-Corelib.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. }}. (* *) 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-Corelib.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. }}. 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. }}. 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-Corelib.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. }}. 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. }}. 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. *) (* _ : 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.4.0/apps/tc/tests/compile_add_pred.v.skip000066400000000000000000000066431474173443600223750ustar00rootroot00000000000000From 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 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 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]). }}. 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.4.0/apps/tc/tests/contextDeepHierarchy.v000066400000000000000000000006561474173443600222750ustar00rootroot00000000000000From elpi.apps Require Import tc. Unset Typeclass Resolution For Conversion. Set TC NameShortPath. Elpi TC Solver Override 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.4.0/apps/tc/tests/dune000066400000000000000000000003011474173443600166260ustar00rootroot00000000000000(coq.theory (name elpi.apps.tc.tests) (flags :standard -async-proofs-cache force) (package coq-elpi-tests) (theories elpi elpi.apps.tc)) (include_subdirs qualified) (dirs :standard \ WIP) coq-elpi-2.4.0/apps/tc/tests/eqSimplDef.v000066400000000000000000000006641474173443600202040ustar00rootroot00000000000000Require 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.4.0/apps/tc/tests/hook_test.v000066400000000000000000000006731474173443600201520ustar00rootroot00000000000000From elpi.apps Require Import tc. Elpi TC Solver Override 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 (tc.instance _ _ {{:gref A}} _) InstL, std.map InstL (x\r\ x = tc.instance _ r _ _) GrefL, GrefL = [{{:gref Inst2}}, {{:gref Inst1}}]. }}. coq-elpi-2.4.0/apps/tc/tests/hyp_in_conl.v000066400000000000000000000036561474173443600204600ustar00rootroot00000000000000From elpi.apps Require Import tc. (* Here we want to test that if the solution of a premise is rigid then the premise is not run *) Module M1. Structure ofe := Ofe { ofe_car : Type; }. Class D (I : ofe). Class C (X : ofe) (I : D X). Definition ofe_nat : ofe := Ofe nat. Instance c : forall (H : D (Ofe nat)), C ofe_nat H := {}. Goal forall (H : D (Ofe nat)), True -> exists H, C (ofe_nat) H. intros. notypeclasses refine (ex_intro _ _ _ ). apply _. Qed. End M1. Module M2. Class A. Class B (I : A). Class C (A : A) (I : B A). Instance c : forall (A : A) (B : B A), C A B := {}. Goal forall (A : A) (B : B A), exists A B, C A B. intros. do 2 notypeclasses refine (ex_intro _ _ _ ). apply _. Qed. End M2. Module M3. Class A. Class B (I : A). Class C (A : A) (I : B A). Instance c : forall (A : A) (B : B A), C A B := {}. Set Warnings "+elpi". Section s. Elpi Accumulate TC.Solver lp:{{ :before "0" tc-elpi.apps.tc.tests.hyp_in_conl.M3.tc-A _ :- coq.say "In tc-A", fail. :before "0" tc-elpi.apps.tc.tests.hyp_in_conl.M3.tc-B _ _ :- coq.say "In tc-B", fail. }}. Local Instance AX : A := {}. Local Instance BX : A -> (B AX) := {}. Definition d : C AX (BX _) := _. Definition d' : C _ (BX _) := _. Definition d'' : C AX _ := _. Check (c _ _) : C AX _. (* Here we give the solver a partial solution with a hole in it. This hole correspond to the premise of the typeclass B (an instance of A). Due to the var condition on the resolution of rule's premises, the premise of `C`, that is, `B X` is not solved since we have the partial solution `BX _`. (see: [here](https://github.com/LPCIC/coq-elpi/blob/889bd3fc16c31f35c850edf5a0df2f70ea9c655a/apps/tc/elpi/tc_aux.elpi#L124)) *) Elpi Query TC.Solver lp:{{ S = {{c AX (BX _)}}, tc.solve-aux1 [] {{C _ _}} S. }}. End s. End M3.coq-elpi-2.4.0/apps/tc/tests/importOrder/000077500000000000000000000000001474173443600202645ustar00rootroot00000000000000coq-elpi-2.4.0/apps/tc/tests/importOrder/f1.v000066400000000000000000000001751474173443600207640ustar00rootroot00000000000000From elpi.apps.tc.tests.importOrder Require Export sameOrderCommand. Class A (T : Set) := f : T -> T. Elpi SameOrderImport.coq-elpi-2.4.0/apps/tc/tests/importOrder/f2a.v000066400000000000000000000005041474173443600211220ustar00rootroot00000000000000From 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.4.0/apps/tc/tests/importOrder/f2b.v000066400000000000000000000004061474173443600211240ustar00rootroot00000000000000From 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.4.0/apps/tc/tests/importOrder/f3a.v000066400000000000000000000002071474173443600211230ustar00rootroot00000000000000From elpi.apps.tc.tests.importOrder Require Import f2a. From elpi.apps.tc.tests.importOrder Require Import f2b. Elpi SameOrderImport. coq-elpi-2.4.0/apps/tc/tests/importOrder/f3b.v000066400000000000000000000002061474173443600211230ustar00rootroot00000000000000From elpi.apps.tc.tests.importOrder Require Import f2b. From elpi.apps.tc.tests.importOrder Require Import f2a. Elpi SameOrderImport.coq-elpi-2.4.0/apps/tc/tests/importOrder/f3c.v000066400000000000000000000015641474173443600211340ustar00rootroot00000000000000From 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.4.0/apps/tc/tests/importOrder/f3d.v000066400000000000000000000013601474173443600211270ustar00rootroot00000000000000From 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.4.0/apps/tc/tests/importOrder/f3e.v000066400000000000000000000012261474173443600211310ustar00rootroot00000000000000From 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.4.0/apps/tc/tests/importOrder/f3f.v000066400000000000000000000004731474173443600211350ustar00rootroot00000000000000From 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.4.0/apps/tc/tests/importOrder/f3g.v000066400000000000000000000003221474173443600211270ustar00rootroot00000000000000From 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.4.0/apps/tc/tests/importOrder/f4.v000066400000000000000000000005461474173443600207710ustar00rootroot00000000000000From 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.4.0/apps/tc/tests/importOrder/sameOrderCommand.v000066400000000000000000000007061474173443600236760ustar00rootroot00000000000000From elpi.apps Require Export tc. From elpi.apps.tc.elpi Extra Dependency "ho_link.elpi" as ho_link. From elpi.apps.tc.elpi Extra Dependency "tc_same_order.elpi" as tc_same_order. From elpi.apps.tc.elpi Extra Dependency "unif.elpi" as unif. Set Warnings "+elpi". Elpi Command SameOrderImport. Elpi Accumulate Db tc.db. Elpi Accumulate File unif. Elpi Accumulate File ho_link. Elpi Accumulate File tc_same_order. Elpi TC Solver Override TC.Solver All.coq-elpi-2.4.0/apps/tc/tests/indt_to_inst.v000066400000000000000000000016411474173443600206440ustar00rootroot00000000000000From Coq Require Export List. From elpi.apps Require Export tc. Global Generalizable All Variables. Elpi TC Solver Override 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.4.0/apps/tc/tests/injTest.v000066400000000000000000000056301474173443600175710ustar00rootroot00000000000000From elpi.apps Require Import tc. From Coq Require Import Morphisms RelationClasses List Bool Setoid Peano Utf8. Generalizable All Variables. Elpi TC Solver Override 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 TC Solver Override 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 TC Solver Override TC.Solver All. 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. (* TODO: This does not work *) 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. 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. }}. 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.4.0/apps/tc/tests/lemma_with_max_impl.v000066400000000000000000000021351474173443600221620ustar00rootroot00000000000000From elpi.apps Require Import tc. Class A (n : nat). Instance a : A 0 := {}. Class B (n : nat). Class C (n : nat). Instance b x: C x := {}. Lemma foo: forall (x n: nat) `{A x} `{C n}, True -> B n. Admitted. Lemma bar: forall (n: nat) `{A n}, True -> B n. Admitted. Goal exists n, B n. Proof. eexists. (* Note: `{A x} and `{C n} are solved with x = 0, n remains a hole *) (* Moreover, True remains as active goal + a shelved goal remain for n *) refine (foo _ _ _). auto. Unshelve. constructor. Qed. Goal exists x, B x. Proof. eexists. (* Note: `{A x} is solved with x = 0 *) refine (bar _ _). auto. Qed. Goal exists x, C x. Proof. eexists. apply _. Unshelve. constructor. Qed. Class Decision (P : Type). Goal forall (A : Type) (P1: A -> Prop), exists (P : A -> A -> A -> Prop), forall z y , (forall x, Decision (P1 x)) -> forall x, Decision (P z y x). Proof. eexists; intros. apply _. Unshelve. auto. Qed. Elpi Tactic A. Elpi Accumulate lp:{{ msolve L _ :- coq.ltac.fail _ "[TC] fail to solve" L. }}. Goal exists n, B n. eexists. Fail apply _. Abort. coq-elpi-2.4.0/apps/tc/tests/nobacktrack.v000066400000000000000000000014721474173443600204330ustar00rootroot00000000000000From 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 TC Solver Override 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.4.0/apps/tc/tests/patternFragment.v000066400000000000000000000101151474173443600213040ustar00rootroot00000000000000From elpi.apps Require Import tc. Elpi TC Solver Override 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 TC Solver Override TC.Solver None. Fail apply _. Elpi TC Solver Override TC.Solver All. apply _. Unshelve. assumption. (* we keep a, the first arg of F *) Qed. Local Instance Inst1: Y (bool * bool). Qed. Goal Z bool. Elpi TC Solver Override TC.Solver None. Succeed apply _. Elpi TC Solver Override TC.Solver All. apply _. Unshelve. assumption. Qed. End M4. (* Module M10. Class Y (I: nat). Goal exists F, forall a b c : Type, Y (F a b) -> Y (F c b). eexists. Elpi Trace Browser. apply _. *) 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 withAnd. Elpi Accumulate TC.Solver lp:{{ :before "solve-aux-conclusion" solve-aux (goal _ _ TyRaw _ _ as G) GL :- not (var TyRaw), if (TyRaw = app [global C|_], coq.TC.class? C) fail (GL = [seal G]). }}. Module M6. Class and (a : Prop) (b : Prop). Instance andI {a b : Prop} : a -> b -> and a b. Qed. Local Instance Inst2 A F: and (F = fun _ _ => nat) (forall (a b c: Type), Y (F a b) -> Y (F b c)) -> Z A. Qed. Goal Z bool. Elpi Bound Steps 1000. Elpi Accumulate TC.Solver lp:{{ print-solution. }}. apply _. Unshelve. reflexivity. Qed. End M6. (* Module M10. Class and (a : Prop) (b : Prop). Instance andI {a b : Prop} : a -> b -> and a b. Qed. Elpi Accumulate TC.Solver lp:{{ :before "solve-aux-conclusion" solve-aux (goal _ _ TyRaw _ _ as G) GL :- not (var TyRaw), if (TyRaw = app [global C|_], coq.TC.class? C) fail (GL = [seal G]). }}. Local Instance Inst2 A F: (and (F = fun _ _ => nat) (forall (a b c: Type), Y (F a b) -> Y (F c b))) -> Z A. Qed. Goal Z bool. eapply Inst2. apply andI. (* reflexivity. *) 2: { Set Printing Existential Instances. apply _. intros. apply _. Qed. End M10. *) End withAnd. *) Module M7. Local Instance Inst2 A F: (forall (a b c: Type), Y (F a b) -> Y nat) -> Z A. Qed. Goal Z bool. apply _. Qed. End M7. Module M8. Local Instance Inst2 A F: (forall (a b c: Type), Y nat -> Y (F a b)) -> Z A. Qed. Goal Z bool. apply _. Qed. End M8. Module M9. Local Instance Inst2 A F: (forall (a b c: Type), Y (F a b) -> Y (F b c)) -> Z A. Qed. Goal Z bool. eapply _. Unshelve. apply nat. Qed. End M9. Module M1b. Local Instance Inst2 A F: (forall (a : Type), Y (F a)) -> Ex F A. Qed. Definition goal := forall (A:Type) (f : Type -> Type), (forall x, Y (f x)) -> exists g, Ex g A /\ g nat = g bool. Section coq. Elpi TC Solver Override TC.Solver None. Goal goal. Proof. intros ???. (* eexists (fun _ => nat). *) eexists; constructor. apply _. Show Proof. Abort. Elpi TC Solver Override TC.Solver All. End coq. Section elpi. Goal goal. Proof. intros ???. eexists; constructor. Show. apply _. Show. reflexivity. Unshelve. apply nat. Qed. End elpi. End M1b. coq-elpi-2.4.0/apps/tc/tests/register/000077500000000000000000000000001474173443600176025ustar00rootroot00000000000000coq-elpi-2.4.0/apps/tc/tests/register/f1.v000066400000000000000000000002161474173443600202760ustar00rootroot00000000000000From elpi.apps Require Import tc. Elpi TC Solver Override TC.Solver All. Class A (n : nat). Instance I1 : A 1. Qed. Goal A 1. apply _. Qed.coq-elpi-2.4.0/apps/tc/tests/register/f2.v000066400000000000000000000002571474173443600203040ustar00rootroot00000000000000From 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.4.0/apps/tc/tests/register/f3.v000066400000000000000000000012361474173443600203030ustar00rootroot00000000000000From 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.4.0/apps/tc/tests/section_in_out.v000066400000000000000000000030021474173443600211610ustar00rootroot00000000000000From elpi.apps Require Import tc. Elpi Accumulate tc.db lp:{{ pred origial_tc o:int. }}. Elpi Command len_test. Elpi Accumulate Db tc.db. Elpi Accumulate lp:{{ % contains the number of instances that are not % imported from other files main [int Len] :- std.findall (tc.instance _ _ _ _) Insts, std.map Insts (x\r\ tc.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 (tc.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. Hint Resolve x : typeclass_instances. Elpi TC.AddInstances x. Goal exists x, class x. eexists. apply _. Qed. End S1. End ClassPersistence.coq-elpi-2.4.0/apps/tc/tests/stdppInj.v000066400000000000000000000235251474173443600177470ustar00rootroot00000000000000(* 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 TC Solver Override 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) | 100. 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) | 100. 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 1, left associativity, format "p .1"). Notation "p .2" := (snd p) (at level 1, 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. }}. 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. }}. 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. }}. 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". 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.4.0/apps/tc/tests/stdppInjClassic.v000066400000000000000000000213111474173443600212400ustar00rootroot00000000000000(* 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 1, left associativity, format "p .1"). Notation "p .2" := (snd p) (at level 1, 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.4.0/apps/tc/tests/test.v000066400000000000000000000346501474173443600171340ustar00rootroot00000000000000From elpi Require Import tc. Section test_max_arity. Elpi Query TC.Solver lp:{{ T = (c1\ prod `c` _ c2 \ prod `_` (prod `a` _ c3 \ app [global _, app [c1, c3], c2]) c3 \ app [global _, c1, c2]), pi x\ tc.precomp.instance.get-range-arity x _ (T x) (tc.r-ar z (s z)). }}. End test_max_arity. Module test_link_eta_generation. Class c (T : Type -> Type -> Type -> Type). Class d (T : Type) (T : Type -> Type -> Type -> Type). Elpi Accumulate TC.Solver lp:{{ :after "0" tc.compile.instance.compile-conclusion _ (app [H|_]) _ _ _ Premises _ :- H = {{test_link_eta_generation.c}}, !, std.assert! (Premises = [do [tc.link.eta _ _] | _]) "[TC] Wrong number of eta links", coq.say "Good padding from here", fail. }}. Elpi Query TC.Solver lp:{{ ToCompile = {{forall (T : Type -> Type -> Type -> Type), (forall (a: Type), d a T) -> c T}}, not (tc.compile.instance ToCompile _ _). }}. End test_link_eta_generation. Module simpleHO. Class A (t : nat -> nat) (t' : Type). Class B (t : nat) (t' : Type). Instance I1: forall F c, (forall a, B (F a) c) -> A F c. Qed. Instance I2 : B 3 bool. Qed. Goal exists x, A x bool. Proof. eexists. apply _. Qed. End simpleHO. Module HO_1. Axiom (f : bool -> unit -> nat -> nat). Class A (t : bool -> unit -> nat -> nat). Class B (t : unit -> nat -> nat). Class C (t : nat). Instance I1: forall a b, (C (f true a b)). Qed. Instance I2: forall F, (forall x y, C (F x y)) -> B F. Qed. Instance I3: forall F, (forall x, B (F x)) -> A F. Qed. Goal B (fun x y => f true x y). apply _. Qed. Goal exists x, A x. eexists. Time apply _. Unshelve. (* Note: here we find a most general solution than Coq's one *) apply tt. apply 3. Qed. End HO_1. Module HO_2. Axiom f : Type -> Type -> Type. Class A (t : Type -> Type -> Type) (t : Type -> Type -> Type). Instance I: forall f, A f (fun x y => f y x). Qed. Goal A f (fun x y => f y x). apply _. Qed. End HO_2. Module HO_3. Axiom (f : nat -> nat -> nat). Class A (t : nat -> nat -> nat -> nat). Class B (t : nat -> nat -> nat). Class C (t : nat -> nat). Instance I1: (C (f 3)). Qed. Instance I2: forall F, (forall x, C (F x)) -> B F. Qed. Instance I3: forall F, (forall x, B (F x)) -> A F. Qed. Goal exists x,B x. eexists. apply _. Qed. End HO_3. Module HO_4. Axiom (f : nat -> nat -> nat -> nat). Class A (t : nat -> nat -> nat -> nat -> nat -> nat). Class B (t : nat -> nat -> nat -> nat -> nat). Class C (t : nat -> nat -> nat). Instance I1: C (fun x => f x 3). Qed. Instance I2: forall F, (forall x y, C (F x y)) -> B (fun a b => F b a). Qed. Instance I3: forall F, (forall x, B (F x)) -> A F. Qed. Goal exists x, A x. eexists. apply _. Qed. End HO_4. Module HO_swap. Axiom (f : Type -> Type -> Type). Elpi Query TC.Solver lp:{{ tc.link.eta.maybe-eta (fun `x` _ c0 \ fun `y` _ c1 \ A2 c1 c0), tc.link.eta.maybe-eta (fun `x` _ c0 \ fun `y` _ c1 \ A2 (A c1) c0), tc.link.eta.maybe-eta {{fun x y => f x y}}. }}. Class c1 (T : (Type -> Type -> Type)). Class c2 (T : (Type -> Type -> Type)). Elpi Query TC.Solver lp:{{ @pi-decl `x` {{Type -> Type}} f\ tc.precomp.instance.is-uvar f => sigma T\ tc.precomp.instance {{c1 (fun x y => lp:f y x)}} T N _ _, std.assert! (T = app[{{c1}}, tc.maybe-eta-tm _ _]) "[TC] invalid precomp". }}. Instance a1 : forall (F : Type -> Type -> Type), c2 (fun x y => F y x) -> c1 F. Qed. Instance b1 : c2 f. Qed. Goal c1 (fun x y => f y x). apply _. Qed. End HO_swap. Module HO_5. Axiom (f : Type -> Type -> Type). Class c1 (T : (Type -> Type -> Type)). Class c2 (T : (Type -> Type -> Type)). Class c3 (T : (Type -> Type -> Type)). Instance a1 : forall (F : Type -> Type -> Type), (c2 (fun x y => F y x) -> c3 (fun x y => F y x)) -> c1 F. Qed. Instance a2 : c2 f -> c3 f. Qed. Goal c1 (fun x y => f y x). apply _. Qed. End HO_5. Module HO_6. Axiom (f : Type -> Type -> Type). Class c1 (T : (Type -> Type -> Type)). Class c2 (T : (Type -> Type -> Type)). Class c3 (G : nat -> nat) (T : (Type -> Type -> Type)). Instance a1 : forall (F : Type -> Type -> Type), (c2 (fun x y => F y x) -> forall G, c3 G (fun x y => F y x)) -> c1 F. Qed. Instance a2 : forall F, c2 f -> c3 F f. Qed. Goal c1 (fun x y => f y x). apply _. Qed. End HO_6. Module HO_7. (* Here maybe-eta is in the goal, with a flexible head *) Axiom f : Type -> Type -> Type. Class c1 (T : Type -> Type -> Type) (T : Type -> Type -> Type). Instance i1: c1 f (fun x y => f y x). Qed. (* TODO: decl M _ {{Type -> Type -> Type}} => coq.typecheck M Ty ok. Ty is flex, I would like it to be (prod _ _ (x\ prod _ _ _))) to make the following test succeed Elpi Query TC.Solver lp:{{ decl M _ {{Type -> Type -> Type}} => tc.compile.goal {{c1 (fun x y => lp:M y x) lp:M}} G L, std.length L Len, std.assert! (Len = 5). }}. *) Goal exists M, c1 (fun x y => M y x) M. eexists. apply _. Qed. End HO_7. Module HO_81. Class c1 (T : Type). Instance i1 F : c1 F. Qed. Elpi Accumulate TC.Solver lp:{{ :before "compile-goal" tc.compile.goal Goal _ _ :- Goal = {{HO_81.c1 lp:_}}, !, tc.precomp.goal Goal _ Vars, !, tc.compile.goal.make-pairs Vars Pairs, std.assert! (Pairs = []) "", fail. }}. Goal exists X, c1 X. eexists. (* Failure is good, since here we simply check that the number of uvar-pair built by tc.precomp is zero. This is because the type of ?X is Type (i.e. it has `arity` zero) *) Fail apply _. Abort. End HO_81. Module HO_8. Class c1 (T : Type -> Type -> Type). Instance i1 F : c1 (fun x => F x). Qed. Goal exists X, c1 X. eexists. apply _. Unshelve. apply nat. Qed. End HO_8. Module HO_9. Axiom f : Type -> Type -> Type. Class c1 (T : Type -> Type). Instance i1 A: c1 (fun x => f (A x) (A x)). Qed. Elpi Query TC.Solver lp:{{ pi F\ sigma T\ decl F `x` {{Type -> Type}} ==> tc.precomp.instance.is-uvar F ==> tc.precomp.instance {{c1 (fun x => f (lp:F x) (lp:F x))}} T N _ _, std.assert! (T = app [{{c1}}, tc.maybe-eta-tm _ _]) "Invalid precompilation". }}. Goal exists X, c1 X. eexists. (* TODO: here good solution, but universe problem!!! *) eapply (i1 (fun x => _)). (* apply _. *) Unshelve. auto. Qed. End HO_9. Module HO_10. Axiom f : Type -> Type -> Type. Class c1 (T : Type -> Type -> Type). Instance i1 A: c1 (fun x y => f (A x y) (A x y)). Qed. (* Note: here interesting link-dedup *) Goal exists X, c1 X. eexists. (* TODO: here good solution, but universe problem!!! *) (* apply _. *) eapply (i1 (fun _ _ => _)). Unshelve. auto. Qed. End HO_10. Module HO_scope_check1. Axiom f : Type -> (Type -> Type) -> Type. Axiom g : Type -> Type -> Type. Axiom a : Type. Class c1 (T : Type -> Type). Instance i1 : forall X, c1 (fun x => f x (fun y => g x (X y))). Qed. Goal c1 (fun x => f x (g x)). apply _. Qed. Elpi Query TC.Solver lp:{{ sigma X Q\ % To avoid printing in console tc.build-query-from-goal {{c1 (fun x => f x lp:X)}} _ Q _, (pi A L T\ tc.link.eta.scope-check (uvar _ L) (fun _ _ (x\ app [{{g}}|_] as T)) :- !, std.assert! (not (prune A L, A = T)) "[TC] Should fail by Scope Check", fail) => not Q. }}. (* Here fail on scope check *) Goal exists X, c1 (fun x => f x X). eexists. Fail apply _. Abort. End HO_scope_check1. Module beta_reduce_preprocess. Axiom f : Type -> Type -> Type. Module in_instance. Class c1 (T:Type). Instance i1 : c1 ((fun x y => f y x) nat bool). Qed. Goal c1 (f bool nat). apply _. Qed. End in_instance. Module in_goal. Class c1 (T : Type). Instance i1 : c1 (f nat bool). Qed. Goal c1 ((fun x y => f y x) bool nat). apply _. Qed. End in_goal. End beta_reduce_preprocess. Module Llam_1. Class A (i: nat -> nat). Class B (i: nat -> nat). Elpi Query TC.Solver lp:{{ @pi-decl `x` {{Type -> Type}} f\ tc.precomp.instance.is-uvar f => @pi-decl `x` {{Type -> Type}} g\ tc.precomp.instance.is-uvar g => sigma T\ tc.precomp.instance {{A (fun x => lp:f (lp:g x))}} T N _ _, std.assert! (T = app[{{A}}, tc.maybe-eta-tm (fun _ _ (x\ tc.maybe-llam-tm _ _)) _]) "[TC] invalid precomp". }}. Instance I1: forall F G, B G -> A (fun x => F (G x)). Qed. Instance I2: B (fun x => x). Qed. (* HERE progress-llam-refine! *) (* While back-chaining `I1`, the eta-link for `F (G x)` is triggered, and the `llam-link` for `F (G x)` becomes `S =llam F (G x)` the premise `B G` assigns `G` to the identity (thanks to I2), this updates the `llam-link` to `S = llam F x`. `F x` is in PF, and can safely be unfied to `S`. The finaly substitution is therefore: I1 S (fun x => x) I2 *) Goal A S. apply _. Qed. End Llam_1. Module Llam_2. Axiom a : nat. Class c1 (i: nat). Class c2 (i: nat -> nat). Instance I1: forall F, c2 F -> c1 (F a). Qed. Instance I2: c2 (fun x => x). Qed. (* HERE progress-rhs! *) (* While back-chaining, the goal unify with I1. `c2 F` is unified with `c2 (fun x => x)` due to I2. F is now rigid can be beta-reduced to a *) Goal c1 a. (* Note : if, as coq, we force the llam link immediately, then apply _ fails *) Fail apply _. Abort. Goal exists X, c1 X. eexists. apply _. Qed. End Llam_2. Module Llam_3. Axiom f: bool -> unit -> nat -> nat -> nat -> nat. Class c1 (i : nat). Class c2 (i: nat). Class c3 (i: bool -> unit -> nat -> nat -> nat -> nat). Instance I1 : forall (F: bool -> unit -> nat -> nat -> nat) G, c3 G -> (forall a b c d, c2 (G a b c d (F a b c d))) -> c1 0. Qed. Instance I2 : c3 f. Qed. Instance I3 a b c d F: c2 (f a b c d F). Qed. Goal c1 0. apply _. Unshelve. auto. Qed. End Llam_3. Module Llam_4. Axiom f : Type -> (Type -> Type) -> Type. Axiom g : Type -> Type -> Type. Axiom a : Type. Class c1 (T : Type -> Type). Instance i1 : forall X, c1 (fun x => f x (X x (fun (_: nat) => a) x)). Qed. Fail Elpi Query TC.Solver lp:{{ sigma X Q\ % To avoid printing in console tc.build-query-from-goal {{c1 (fun x => f x lp:X)}} _ Q _, not Q. }}. End Llam_4. Module Llam_5. Definition NN := nat -> nat. Class c1 (T : nat). (* Instance has a uvar whose type is hidden behind a definition *) Instance i : forall (x : NN), c1 (x 3). Qed. Goal c1 (id 3). apply _. Qed. End Llam_5. Module Llam_6. Class B (i: nat -> nat -> nat). Elpi Query TC.Solver lp:{{ (pi x\ tc.unify-eq {{fun _ => 0}} (P x x)), coq.say (P {{1}} {{2}}), std.assert! (P {{1}} {{2}} = {{ fun _ => 0}}) "Heuristic error". }}. Axiom (f : nat -> nat). Instance instB: B (fun _ _ => f 3) := {}. Class A. Instance instA : forall X, B (fun x => X x x) -> A := {}. Goal A. apply _. Qed. End Llam_6. Module CoqUvar. Class c1 (i:Type -> Type -> Type). Elpi Query TC.Solver lp:{{ tc.precomp.instance {{c1 (fun x y => lp:F y x)}} T _ _ _, coq.say T, Expected = app[{{c1}}, tc.maybe-eta-tm (fun _ _ Inn) []], std.assert! (T = Expected) "[TC] invalid precompile1", pi x\ sigma ExpectedInn\ ExpectedInn = tc.maybe-eta-tm (A x) [x], std.assert! ((Inn x) = ExpectedInn) "[TC] invalid precompile2". }}. Goal exists F, c1 (fun x y => F y x) -> c1 F. (* exists (fun x y => nat); auto. *) eexists. apply _. Unshelve. apply nat. Qed. End CoqUvar. Module CoqUvar1. Class c1. Class c2 (i:Type -> Type -> Type). Axiom f : Type -> Type -> Type. Instance i1: c2 f -> c1. Qed. Goal exists F, c2 (fun x y => F y x) -> c1. (* exists (fun x y => f y x); apply i1. *) eexists. intros. apply _. Qed. End CoqUvar1. Module CoqUvar2. Axiom t : Type. Class c1 (T : Type). Instance i1 (F: Type -> Type): c1 (F t). Qed. Goal exists F, c1 (F t). eexists. (* Set Debug "unification". *) (* TODO: here we produce a eta-expanded proof, which produce a coq unification between `?F a` and `fun x => X x` if we eta-reduce then coq has to unify `?F a` against `X` which succeeds *) apply _. Fail Check (i1 (fun x => _)) : c1 ( (fun x => _) t). (* ??? *) Unshelve. auto. Qed. End CoqUvar2. Module CoqUvar3. Axiom f : Type -> Type -> Type. Class c1 (T : Type -> Type -> Type). Instance i1 A: c1 (fun x y => f (A x y) (A x y)). Qed. Elpi Query TC.Solver lp:{{ tc.precomp.goal {{c1 (fun x y => lp:X (lp:A x y) y)}} C _, Expected = app [{{c1}}, tc.maybe-eta-tm (fun _ _ Body1) _], Body1 = (x\ tc.maybe-eta-tm (fun _ _ (Body2 x)) [x]), Body2 = (x\y\ tc.maybe-llam-tm (app [app [X], (Y x y), y]) [x,y]), std.assert! (C = Expected) "[TC] invalid compilation". }}. (* Note: here interesting link-dedup *) Goal exists X (A: Type -> Type -> Type), c1 (fun x y => X (A x y) y). (* do 2 eexists. apply _. Show Proof. Unshelve. apply T. apply T. Show Proof. *) (* proof is OK, but for universes!!!! *) apply (ex_intro (fun X : Type -> Type -> Type => exists A : Type -> Type -> Type, c1 (fun x y : Type => X (A x y) y)) (fun _ H : Type => f H H) (ex_intro (fun A : Type -> Type -> Type => c1 (fun x y : Type => (fun _ H : Type => f H H) (A x y) y)) (fun H _ : Type => H) (i1 (fun _ H : Type => H)))). Qed. Axiom g : Type -> Type -> Type. (* Note: here interesting failing link-dedup *) Goal exists (A: Type -> Type -> Type), c1 (fun x y => g (A x y) y). do 1 eexists. Fail apply _. Abort. End CoqUvar3. Module CoqUvar4. Axiom f : Type -> Type -> Type. Class c1 (T : Type -> Type -> Type). Elpi Query TC.Solver lp:{{ tc.precomp.instance {{c1 (fun x y => lp:X (lp:A x y) y)}} C _ _ _, Expected = app [{{c1}}, tc.maybe-eta-tm (fun _ _ Body1) _], Body1 = (x\ tc.maybe-eta-tm (fun _ _ (Body2 x)) [x]), Body2 = (x\y\ tc.maybe-llam-tm (app [app [X], (Y x y), y]) [y,x]), std.assert! (C = Expected) "[TC] invalid compilation". }}. (* Note: here interesting failtc-c1ing link-dedup *) Goal forall f, exists X, c1 (X nat) -> c1 (f nat nat). do 1 eexists. apply _. Qed. End CoqUvar4. (* TODO: add test with negative premise having a variable with type (M A) where M and A are coq uvar, this is in order to clean-term with llam *)coq-elpi-2.4.0/apps/tc/tests/test_HO.v000066400000000000000000000235551474173443600175240ustar00rootroot00000000000000From elpi Require Import tc. Set TC NameShortPath. Module FO_prod. Section XX. Context (A B : Type) (y : B) (Q : A -> Prop). Class Ccc (i : Prop). Global Instance i P : Ccc (forall (x: A), P x y). Qed. Goal forall (P : nat -> A -> B -> Prop), Ccc (forall x, P 0 x y). apply _. Qed. End XX. End FO_prod. Module FO_app. Class nice_predicate {T : Type} (P : T -> Prop). Instance partial_app: forall (T : Type) (P : T -> T -> Prop), forall x, nice_predicate (P x). Qed. (* Unification is done between `p 0 x` and `P X` (The latter is not in PF) The former's elpi representation is `app [p, {{0}}, x]` while the latter is `P t p x (X t p x)` - `t` stands for T : Type - `P` is the unif variable `P` in partial_app - `X` is the unif variable `x` in partial_app We are outside the pattern fragment. The heuristics splits the arguments of `P` into `[t, p, x]` and `[(X t p x)]`, where `[t,p,x]` is the longest prefix in PF and `(X t p x)` is the remaining tail. We call the former PF and the latter NPF Len N the length of NPF and M the length of `[p, {{0}}, x]`, then we split `[p, {{0}}, x]` at position `M - N`. We obtain the sublists: `[p, {{0}}]` and `[x]`. We then unify `[x]` with `[(X t p x)]`. Let `L` the concatenation of `PF` and `NPF`, then the head P of the elpi unification variable is obtained by adding 4 lambda abstraction (the length of `L`), and for each abstraction `x` at depth `i` we add the local clause `copy L.(i) x`. The final result is `P = (x\y\z\w\ app[y, {{0}}, w])` *) Lemma ex1 (T : Type) (p : nat -> T -> T -> Prop) (x : T) : nice_predicate (p 0 x). apply _. Show Proof. Unshelve. Defined. Check eq_refl : ex1 = fun T p x => @partial_app T (p 0) x. (* Check eq_refl : ex1 = fun T p x => @partial_app T (fun _ => p 0 x) x. *) Lemma ex2 (T : Type) (p : nat -> T -> T -> Prop) y : nice_predicate (fun x => p 0 y x). apply _. Unshelve. (* auto. *) Defined. Check eq_refl : ex2 = fun T p y => @partial_app T (p 0) y. (* Check eq_refl : ex2 = fun T p y => @partial_app T (fun _ => p 0 y) y. *) Existing Instance partial_app. Elpi TC Solver Override TC.Solver None. Lemma ex3 (T : Type) (p : nat -> T -> T -> Prop) y : nice_predicate (fun x => p 0 x y). Fail apply _. (* Coq KO *) Fail apply partial_app. (* Coq KO *) apply (@partial_app T (fun a b => p 0 b a) y). Abort. Lemma ex4 (T : Type) (p : nat -> T -> T -> Prop) y : nice_predicate (fun x => p 0 y x). Fail apply _. (* Coq KO *) Succeed apply partial_app. (* Coq eta! *) apply (@partial_app T (p 0) y). Abort. End FO_app. Elpi TC Solver Override TC.Solver All. Module FO_app1. Class Singleton (B: Type). Class Singleton1 (B: Type). Instance s M: (forall A : Type, Singleton1 (M A)) -> forall A : Type, Singleton (M A). Qed. Goal forall M, (forall A : Type, Singleton1 (M A)) -> forall A : Type, Singleton (M A). apply _. (* Unshelve. *) (* apply nat. *) Qed. End FO_app1. Module FO_app2. Section XX. Context (A B : Type). Class Functional (B: Type). Instance s1 F: Functional (F B) -> Functional (F B) -> Functional (F A). Qed. Definition f (x : Type) := Type. Context (H : Functional (f B)). Goal Functional (f A). apply _. Abort. End XX. End FO_app2. Module FO_app3. Definition X := Type -> Type. Axiom f : X. Class C (I : Type -> Type). Instance I : C (fun _ => f nat). Qed. Goal exists (R : Type -> Type) , forall (T:Type), C (fun x => R T) /\ R bool = f nat. eexists. intros. split. (* Here we commit the only existing solution for R, that is, R := fun _ => f nat, note that R does not see T *) apply _. reflexivity. Qed. Goal exists (R : Type -> Type) , C (fun x => R nat) /\ R bool = f nat. eexists. split. (* Here there is no mgu: there are in fact two solutions for R 1. R := fun _ => f nat 2. R := fun x => f x == f, in our case we commit the second *) apply _. Show Proof. Fail reflexivity. Abort. (* ============= We restart and try the good sol ============= *) Goal exists (R : Type -> Type) , C (fun x => R nat) /\ R bool = f nat. exists (fun x => f nat). split. apply _. reflexivity. Qed. Goal exists (R : Type -> Type) , C (fun x => R unit) /\ R bool = f nat. eexists. (* Here we fail, even though there exists the solution R := fun _ => f nat *) Fail apply _. Unshelve. 2:{ refine (fun x => f nat). } split. apply _. reflexivity. Qed. Goal exists (R : Type -> Type) , C (fun x => R nat) /\ R bool = f bool. eexists. split. apply _. reflexivity. Qed. End FO_app3. Module HO_PF. Class Extensionality (T : Type). Instance fun_1 (A1 : Type) (A2 : A1 -> Type) : Extensionality (forall a : A1, A2 a). Qed. Lemma ex1 : Extensionality (nat -> nat). apply _. Defined. Check eq_refl : ex1 = @fun_1 nat (fun _ => nat). Lemma ex2 : Extensionality (forall x : nat, x = x + 1). apply _. Defined. Check eq_refl : ex2 = @fun_1 nat (fun a => a = a + 1). Axiom odd : nat -> Type. Lemma ex3 : Extensionality (forall x : nat, odd x). apply _. Defined. Goal ex3 = ex3. unfold ex3. match goal with |- @fun_1 nat odd = _ => idtac end. reflexivity. Abort. (* Instance for multiple lambdas *) Instance fun_2 (A1 : Type) (A2 : A1 -> A1 -> Type) : Extensionality (forall a b : A1, A2 b a). Qed. Lemma ex4 : Extensionality (nat -> nat -> nat). apply _. Qed. End HO_PF. Module HO_PF1. Parameter A : Type. Class Decision (P : Type). (* Global Hint Mode Decision ! : typeclass_instances. *) Section sol_in_hyp. Goal forall (P1: A -> Prop), exists (P : A -> A -> A -> Prop), forall z y , (forall x, Decision (P1 x)) -> forall x, Decision (P z y x). Proof. eexists; intros. Elpi Bound Steps 30000. Set Typeclasses Debug. apply _. Unshelve. auto. Qed. End sol_in_hyp. Class Exists (P : A -> Type) (l : A). Instance Exists_dec (P : A -> Type): (forall x, Decision (P x)) -> forall l, Decision (Exists P l). Qed. Section test. Goal forall P (l:A) , Decision (Exists P l). Proof. intros. Fail apply _. (* We fail without infinite loop thanks to ho-links *) Abort. End test. Goal forall (P1: A -> Prop) l, exists (P : A -> A -> A -> Prop), forall z y , (forall x, Decision (P1 x)) -> Decision (Exists (P z y) l) /\ P z y y = P1 z. Proof. eexists; intros. split. (* forall x : A, Decision (P1 x) = forall x : A, Decision ((?P z y) x) *) (* x |- Decision (P1 ?x) = Decision ((?P z y) x) *) (* We take the most general solution for P, it picks P = (fun a b c => P1 ?x) *) apply _. simpl. (* Reflexivity fix ?x = a hence (fun a b c => P1 a) z y y = P1 z is solvable *) reflexivity. Qed. Lemma ho_in_coq (P1: A -> Prop) l: exists (P : A -> A -> A -> Prop), forall z y , (forall x, Decision (P1 x)) -> Decision (Exists (P z y) l) /\ P z y y = P1 z. Proof. Elpi TC Solver Override TC.Solver None. eexists; intros. (* epose (H _). *) (* clearbody d. *) (* clear H. *) split. (* Print HintDb typeclass_instances. *) (* Set Elpi Typeclasses Debug. *) (* Coq doesn't give the most general solution for P, it picks P = (fun _ _ x => P1 x) *) apply _. Fail reflexivity. Abort. Elpi TC Solver Override TC.Solver All. Section test. Context (P1: Type -> Prop). Context (H : Decision (P1 nat)). Goal exists P, forall (x y:A) , Decision (P x y). Proof. eexists; intros. apply _. Abort. End test. End HO_PF1. Section HO_PF2. Class cl1 (i : Type). Class cl2 {i : Type} (y : cl1 i). Class cl3 {i : Type} (y : cl1 i). Instance i1 : forall (H : forall x, cl1 x), cl2 (H nat) -> cl3 (H bool). Qed. Goal forall (H : forall x, cl1 x), cl2 (H nat) -> cl3 (H bool). Proof. apply _. Qed. Goal forall (H : forall x, cl1 x), cl2 (H nat) -> exists x (i_cl1: cl1 x), cl3 i_cl1. Proof. intros. do 2 eexists. apply _. Qed. End HO_PF2. Module D. Class C1 (T : Type -> Type) (i: forall x, T x). Class D. Instance I : forall (T : Type -> Type) (H : forall x, T x), C1 T (fun x => H x) -> D . Qed. Instance J: forall (T : Type -> Type) (H : forall x, T x), C1 T H. Qed. Goal D. intros. apply _. Unshelve. all: try apply 3; try apply nat. Qed. End D. Module F. Class C1 (T : Type -> Type) (i: forall x, T x). Class D. Instance I : forall (T : Type -> Type) (H : forall x, T x), C1 T (fun x => H x) -> D . Qed. Goal forall (T : Type -> Type) (H : forall x, T x), C1 T H -> D. intros. Set Typeclasses Debug. Set Debug "tactic-unification". Elpi TC Solver Override TC.Solver None. Fail apply _. (* Here coq's unfication algorithm fails: it is not able to solce H =~ fun x => ?H x, even though it is sufficient to eta-expand the lhs *) Elpi TC Solver Override TC.Solver All. apply _. Qed. End F. Module F'. Class C2 (T : Type -> Type) (i: forall x, T x). Class D. Instance I : forall (T : Type -> Type) (H : forall x, T x), C2 T H -> D . Qed. Goal forall (T : Type -> Type) (H : forall x, T x), C2 T (fun x => H x) -> D. intros. Set Debug "tactic-unification". Elpi TC Solver Override TC.Solver None. apply _. (* Here coq succeds: it is able to solce ?H =~ fun x => H x *) Abort. Goal forall (T : Type -> Type) (H : forall x, T x), C2 T (fun x => H x) -> D. Elpi TC Solver Override TC.Solver None. apply _. Qed. End F'. Module E. Class C3 (i : nat -> nat -> nat). Instance I : C3 (plus). Qed. Class D3 (i : Prop). Instance I2 (F : nat -> nat -> nat) : C3 F -> D3 (forall x y, F x y = F y x) . Qed. Goal D3 (forall n m, n + m = m + n). apply _. Qed. End E. coq-elpi-2.4.0/apps/tc/tests/test_backtrack_several_goals.v000066400000000000000000000040121474173443600240340ustar00rootroot00000000000000Module M. Class C (i: nat). Instance i1: C 1 := {}. Instance i2: C 2 := {}. Class E (i: nat). Instance e1 : E 1 := {}. Lemma m {i} {H : C i} {H1 : E i}: C i. Admitted. Class D (i:nat) (o: C i). Instance d1 (H: C 1) : D 1 H := {}. Goal exists i, C i. eexists. Set Typeclasses Debug. (* Here backtracking is done *) apply m. Qed. End M. Module M1. Class C (i: nat). Instance i1: C 1 := {}. Instance i2: C 2 := {}. Class E (i: nat). Instance e1 : E 1 := {}. Lemma m {i} (H : C i) (H1 : E i): C i. Admitted. Class D (i:nat) (o: C i). Instance d1 (H: C 1) : D 1 H := {}. Goal exists i, C i. eexists. Set Typeclasses Debug. apply m. (* Note: in coq the following command fails since apply is a single entry command, i.e. it cannot receive multiple goal at the same time. Therefore `apply _` will be triggered on the `n` goals. *) Fail all: apply _. all: typeclasses eauto. Qed. End M1. (* Here similar problems using the coq-elpi solver *) From elpi Require Import elpi tc. Module ElpiBt. Class C (i: nat). Instance i1: C 1 := {}. Instance i2: C 2 := {}. Class E (i: nat). Instance e1 : E 1 := {}. Elpi Tactic T. Elpi Accumulate lp:{{ msolve A B :- coq.say A, coq.ltac.all (coq.ltac.open solve-aux) A B. pred solve-aux i:goal, o:list sealed-goal. solve-aux (goal _ _ G _ _ as GG) L :- coq.say "Goal is" {coq.term->string G}, solvee G S, coq.say "Solution for" {coq.term->string G} "is" {coq.term->string S}, refine S GG L. pred solvee o:term, o:term. solvee {{C 2}} {{i2}}. solvee {{C 1}} {{i1}}. solvee {{E 1}} {{e1}}. }}. Goal exists i, C i /\ E i. eexists. split. all : elpi T. Qed. End ElpiBt. Module M_in_elpi. Class C (i: nat). Instance c0: C 0 := {}. Instance c1: C 1 := {}. Class E (i: nat). Instance e0 : E 0 := {}. Lemma m {i} {H : C i} {H1 : E i}: C i. Admitted. Goal exists i, C i. eexists. apply m. Qed. End M_in_elpi.coq-elpi-2.4.0/apps/tc/tests/test_coercion.v000066400000000000000000000040071474173443600210060ustar00rootroot00000000000000From elpi Require Import tc. Module Animals. Module Bird1. Inductive info := Fly | NotFly. Class Animal (i : info). Class Bird (i : info) := IsAnimal :: Animal i. Instance dove : Bird Fly. split. Qed. (* It exists a ground solution for tc-Animal *) Elpi Query TC.Solver lp:{{ tc-elpi.apps.tc.tests.test_coercion.Animals.Bird1.tc-Animal _ S, ground_term S. }}. (* It does not exist a solution for tc-Animal with a flexible solution *) Elpi Query TC.Solver lp:{{ not (tc-elpi.apps.tc.tests.test_coercion.Animals.Bird1.tc-Animal _ S, not (ground_term S)). }}. Goal Animal Fly. apply _. Qed. Goal Animal NotFly. Fail solve [apply _]. Abort. End Bird1. Module Bird2. Class Animal. Class Bird1 := IsAnimal : Animal. Instance dove : Bird1. split. Qed. (* It does not exists an instance for Animal1 *) Elpi Query TC.Solver lp:{{ not (tc-elpi.apps.tc.tests.test_coercion.Animals.Bird2.tc-Animal _). }}. Goal Animal. Fail solve [apply _]. apply IsAnimal. Abort. End Bird2. End Animals. Module Vehicle. Class Wheels (i: nat). Class NoWheels := { (* the first argument of no_wheels is implicit! *) wheels0 :: Wheels 0; }. Class Boat := { wheels :: NoWheels }. Goal Boat -> Wheels 0. intros. apply _. Qed. End Vehicle. Module foo. Class B (i : nat). Section s. (* Class with coercion depending on section parameters *) Context (A : Type). Class C (i : nat) : Set := { f (x : A) :: B i }. End s. End foo. Module foo1. Class B (i : nat). Section s. (* Class with coercion not depending on section parameters *) Class C (i : nat) : Set := { f :: B i }. End s. Goal C 3 -> B 3. apply _. Abort. End foo1. Module localCoercion. Class B (i : nat). Section s. Class C (i : nat) : Set := { #[local] f :: B i }. Goal C 3 -> B 3. apply _. Qed. End s. Goal C 3 -> B 3. Fail apply _. Abort. End localCoercion. coq-elpi-2.4.0/apps/tc/tests/test_coercion_import.v000066400000000000000000000001661474173443600224020ustar00rootroot00000000000000From elpi.apps.tc.tests Require Import test_coercion. Import Animals.Bird1. Elpi Query TC.Solver lp:{{ true. }}. coq-elpi-2.4.0/apps/tc/tests/test_commands_API.v000066400000000000000000000021001474173443600214670ustar00rootroot00000000000000From 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 counti i:gref, i:int. counti GR Len :- if (const _ = GR) (std.findall (tc.instance _ _ GR _) Cl, std.assert! ({std.length Cl} = Len) "Unexpected number of instances") true. main [str E, int Len] :- coq.locate E GR, counti GR Len. }}. TC.AddClasses Eqb. Module test1. TC.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. TC.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. TC.AddAllClasses. TC.AddAllInstances eqU. Elpi Query TC.Solver lp:{{ EqP = {{:gref eqU}}, std.assert! (not (tc.instance _ EqP _ _)) "EqP should not be in the DB". }}. End test4.coq-elpi-2.4.0/apps/tc/tests/test_eta.v000066400000000000000000000015671474173443600177660ustar00rootroot00000000000000From elpi Require Import tc. Module M1. Axiom T : Type. Axiom P : T -> T -> T. Class eta (P: T -> T -> T). Instance I1: eta P. Qed. Goal eta (fun x => P x). Proof. apply _. Qed. Goal eta (fun x y => P x y). Proof. apply _. Qed. End M1. Module M2. Axiom T : Type. Axiom P1 : T -> T. Axiom P2 : T -> T -> T. Class eta (P1 : T -> T) (P2: T -> T -> T). Instance I1: eta P1 P2. Qed. Goal eta (fun x => P1 x) P2. Proof. apply _. Qed. Goal eta P1 (fun x y => P2 x y). Proof. apply _. Qed. Goal eta (fun x => P1 x) (fun x y => P2 x y). Proof. apply _. Qed. End M2. Module M3. Axiom T : Type. Axiom P : T -> T. Class eta (P: T -> T). Class aux (P: T -> T). Instance auxInst : aux (fun x => x). Qed. Instance I1: forall (P : T -> T), aux (fun x => P x) -> eta P. Qed. Goal exists P, eta (fun x => P x). Proof. eexists. apply _. Qed. End M3. coq-elpi-2.4.0/apps/tc/tests/test_import/000077500000000000000000000000001474173443600203275ustar00rootroot00000000000000coq-elpi-2.4.0/apps/tc/tests/test_import/f1.v000066400000000000000000000001771474173443600210310ustar00rootroot00000000000000From elpi.apps Require Export tc. From Coq Require Export Morphisms. Elpi TC Solver Override TC.Solver Rm Proper ProperProxy. coq-elpi-2.4.0/apps/tc/tests/test_import/f2.v000066400000000000000000000000661474173443600210270ustar00rootroot00000000000000From elpi.apps.tc.tests.test_import Require Import f1.coq-elpi-2.4.0/apps/tc/tests/test_pending_mode.v000066400000000000000000000110661474173443600216400ustar00rootroot00000000000000From elpi Require Import tc. Require Import Bool. Module m1. Elpi TC.Pending_mode +. Class C (i : nat). Instance C0 : C 0. Qed. Goal exists x, C x. eexists. Fail apply _. Abort. Class C' (i : nat). Instance C0' : C' 0. Qed. Goal exists x, C' x. eexists. apply _. Abort. Elpi TC.Pending_mode +. Fail Elpi TC.Pending_mode +. Class C'' (i : nat). Instance C0'' : C'' 0. Qed. Goal exists x, C'' x. eexists. Fail apply _. Abort. End m1. Module ground. Elpi TC.Pending_mode +. Class C (i : Type). Instance i : C (list nat). Qed. Goal exists (x : Type), C (list x). eexists. Fail apply _. Abort. End ground. Module ground1. Elpi TC.Pending_mode +. Class C (i : Type). Instance i x: C x. Qed. Goal exists (x : Type), C (list x). eexists. apply _. Abort. End ground1. Module ground2. Elpi TC.Pending_mode +. Class C (i : Type). Instance i (x: Type): C (list x). Qed. Goal exists (x : Type), C (list x). eexists. apply _. Abort. End ground2. Module ground3. Elpi TC.Pending_mode + +. Class C {i : Type} (f : i -> i -> Prop). Instance i {X : Type}: C (@eq X). Qed. Hint Mode C ! ! : typeclass_instances. Goal exists (X : Type), C (@eq X). eexists. Fail apply _. Abort. End ground3. Module ground4. Elpi TC.Pending_mode - +. Class C {i : Type} (f : i -> i -> Prop). Instance i {X : Type}: C (@eq X). Qed. Hint Mode C ! ! : typeclass_instances. Goal exists (X : Type), @C (list X) eq. eexists. apply _. Abort. End ground4. Module rigid_head1. Elpi TC.Pending_mode !. Class C (i : Type). Instance i: C (list nat). Qed. Hint Mode C ! : typeclass_instances. Goal exists (x : Type), C (list x). eexists. apply _. Qed. Goal exists (x : Type), C x. eexists. Fail apply _. Abort. End rigid_head1. Module rigid_head2. Elpi TC.Pending_mode ! !. Class C {i : Type} (f : i -> i -> Prop). Instance i {X : Type}: C (@eq X). Qed. Hint Mode C ! ! : typeclass_instances. Goal exists (X : Type), C (@eq X). eexists. Fail apply _. Abort. End rigid_head2. Module simplEq. TC.Pending_mode "!". 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 Goal exists T: Type, forall n m : T, eqb n m = false. Goal forall n m : bool, eqb n m = false. Abort. End simplEq. Module force_input_link. TC.Pending_mode "+". Class A (i: nat -> nat -> nat). Global Hint Mode A + : typeclass_instances. Axiom (f : nat -> nat -> nat). Instance instA: A f := {}. Class B (i: nat). Instance instB : forall R, A R -> forall x y, B (R x y) := {}. Goal B (f 0 0). apply _. Qed. End force_input_link. Module force_input_link_HO_var1. TC.Pending_mode !. Class A (i: Type). Global Hint Mode A ! : typeclass_instances. (*Mode also added in elpi*) Axiom f : Type -> Type. Axiom g : Type -> Type. Class B (i :Type). (* Elpi Trace Browser. *) Instance i: forall X (Y: Type), (forall Y, A (X Y)) -> B (X Y) := {}. Instance a : forall x, A (g x) := {}. Instance b x : A (f x) -> A (f x) := {}. Goal B (g nat). apply _. Qed. End force_input_link_HO_var1. Module force_input_link_HO_var2. TC.Pending_mode !. Class A (i: Type). Global Hint Mode A ! : typeclass_instances. (*Mode also added in elpi*) Axiom f : Type -> Type. Axiom g : Type -> Type. Class B (i :Type). Instance i: forall X (Y: Type), A (X Y) -> B (X Y) := {}. Instance a : A (g nat) := {}. Instance b x : A (f x) -> A (f x) | 0 := {}. Goal B (g nat). apply _. Abort. End force_input_link_HO_var2. Module force_input_link_HO_var3. TC.Pending_mode !. Class A (i: Type). Global Hint Mode A ! : typeclass_instances. (*Mode also added in elpi*) Axiom g : Type -> Type. Class B (i :Type). (* TODO: This instance should not be compilable ? The premise has always a flex term while its mode is rigid head *) Instance i: forall X (Y: Type), (A X) -> B nat := {}. Instance b x : A x -> A x := {}. Goal B nat. (* TODO: this should not loop, note that we have no way to stop it in elpi since the current modes on arguments do not filter out instance b *) Fail Timeout 1 apply _. Abort. End force_input_link_HO_var3. coq-elpi-2.4.0/apps/tc/tests/test_scope.v000066400000000000000000000004621474173443600203170ustar00rootroot00000000000000From elpi Require Import tc. Section M. Class C (i : Type -> Type). Context (Q : Type -> Type). Goal C Q -> exists (T : Type -> Type), forall R, C R -> C (T). eexists. intros. Set Printing Existential Instances. assert (C Q) by auto. Elpi Trace Browser. apply _. Show Proof. Abort. End M.coq-elpi-2.4.0/apps/tc/tests/test_shelve.v000066400000000000000000000005051474173443600204720ustar00rootroot00000000000000From elpi.apps Require Import tc. Class C. Instance T (n:nat) : C := {}. Elpi TC Solver Deactivate TC.Solver. (* THIS IS COQ *) Goal C. Fail apply _. eapply _. Show. Unshelve. Show. apply (T 2). Qed. (* THIS IS ELPI *) Goal C. Fail apply _. eapply _. Show. Unshelve. Show. apply (T 2). Qed. coq-elpi-2.4.0/apps/tc/tests/test_tc.v000066400000000000000000000003131474173443600176070ustar00rootroot00000000000000From elpi.apps Require Import tc. Elpi TC Solver Override TC.Solver All. Class a (N: nat). Instance b : a 3. Qed. Instance c : a 4. Qed. TC.AddAllClasses. TC.AddAllInstances. Goal a 4. apply _. Qed. coq-elpi-2.4.0/apps/tc/tests/test_tc_declare.v000066400000000000000000000032661474173443600213000ustar00rootroot00000000000000From elpi.apps Require Import tc. Elpi TC Solver Override 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.4.0/apps/tc/tests/test_tele_app.v000066400000000000000000000012371474173443600210000ustar00rootroot00000000000000From elpi.apps Require Import tc. (* From stdpp/telescopes.v *) (* A test where polymorphic universes are used *) Polymorphic Inductive tele : Type := | TeleO : tele | TeleS {X} (binder : X -> tele) : tele. Polymorphic Fixpoint tele_fun (TT : tele) (T : Type) : Type := match TT with | TeleO => T | TeleS b => forall x, tele_fun (b x) T end. Class FMap (X : Type -> Type). (* Since the instance is polymorphic, then the proof of the compiled elpi rule should be wrapped inside the pglobal constructor *) Polymorphic Instance tele_fmap {TT : tele} : FMap (tele_fun TT) := {}. Goal forall x, FMap (tele_fun x). intros. apply _. Show Proof. Qed.coq-elpi-2.4.0/apps/tc/tests/test_unfold.v000066400000000000000000000013561474173443600205000ustar00rootroot00000000000000From elpi Require Import tc. Module NAT. (* Unfold on S vs Nat.succ *) TC.Unfold Nat.succ. Class nat2 (T : nat -> nat). Elpi Accumulate TC.Solver lp:{{ % Just to print what is beeing normalized :after "firstHook" tc.normalize-ty T _ :- coq.say "Normalizing" T, fail. }}. (* The unfold is done in the goal *) Module NAT1. Instance i1 : nat2 S. Qed. Goal nat2 Nat.succ. apply _. Qed. End NAT1. (* The unfold is done at instance compilation *) Module NAT2. Instance i1 : nat2 Nat.succ. Qed. Goal nat2 S. apply _. Qed. End NAT2. (* The unfold is done on the instance and on the goal *) Module NAT3. Instance i1 : nat2 Nat.succ. Qed. Goal nat2 Nat.succ. apply _. Qed. End NAT3. End NAT.coq-elpi-2.4.0/apps/tc/tests/tlc.v000066400000000000000000000027001474173443600167260ustar00rootroot00000000000000(* Test inspired from tlc library *) From elpi Require Import tc. Module extensionability. Notation binary A := (A -> A -> Prop). Class Extensionality (T : Type). Global Instance Extensionality_pred_2 (A1 : Type) (A2 : forall (x1 : A1), Type): Extensionality (forall (x1:A1) (x2:A2 x1), Prop). Qed. Goal forall A, Extensionality (binary A). intros. apply _. Qed. End extensionability. Module SlowExecution. Set Implicit Arguments. Elpi Accumulate TC.Solver lp:{{ % :after "normalize-ty" tc.link.scope-check _ _ :- !, true. }}. Class Extensionality (A:Type) := Extensionality_make { extensionality_hyp : A -> A -> Prop; extensionality : forall (x y : A), extensionality_hyp x y -> x = y }. Section FuncExtDep. Variables (A1 : Type). Variables (A2 : forall (x1 : A1), Type). Variables (A3 : forall (x1 : A1) (x2 : A2 x1), Type). Variables (A4 : forall (x1 : A1) (x2 : A2 x1) (x3 : A3 x2), Type). Variables (A5 : forall (x1 : A1) (x2 : A2 x1) (x3 : A3 x2) (x4 : A4 x3), Type). Variables (A6 : forall (x1 : A1) (x2 : A2 x1) (x3 : A3 x2) (x4 : A4 x3) (x5 : A5 x4), Type). Global Instance Extensionality_fun_1 : Extensionality (forall (x1:A1), A2 x1). Admitted. End FuncExtDep. Lemma eq_existT_same_eq (A : Type) (P : A -> Type) (p : A) (x y : P p): (existT P p x = existT P p y) = (x = y). Proof. Timeout 10 Fail refine (@extensionality _ _). Abort. End SlowExecution. coq-elpi-2.4.0/apps/tc/theories/000077500000000000000000000000001474173443600164365ustar00rootroot00000000000000coq-elpi-2.4.0/apps/tc/theories/add_commands.v000066400000000000000000000117411474173443600212420ustar00rootroot00000000000000(* license: GNU Lesser General Public License Version 2.1 or later *) (* ------------------------------------------------------------------------- *) From elpi.apps.tc Require Import db. From elpi.apps.tc.elpi Extra Dependency "tc_aux.elpi" as tc_aux. From elpi.apps.tc.elpi Extra Dependency "ho_precompile.elpi" as ho_precompile. From elpi.apps.tc.elpi Extra Dependency "ho_compile.elpi" as ho_compile. From elpi.apps.tc.elpi Extra Dependency "compiler1.elpi" as compiler1. From elpi.apps.tc.elpi Extra Dependency "unif.elpi" as unif. From elpi.apps.tc.elpi Extra Dependency "modes.elpi" as modes. From elpi.apps.tc.elpi Extra Dependency "ho_link.elpi" as ho_link. From elpi.apps.tc.elpi Extra Dependency "parser_addInstances.elpi" as parser_addInstances. From elpi.apps.tc.elpi Extra Dependency "solver.elpi" as solver. From elpi.apps.tc.elpi Extra Dependency "create_tc_predicate.elpi" as create_tc_predicate. Set Warnings "+elpi". Elpi Command TC.AddAllInstances. Elpi Accumulate Db tc.db. Elpi Accumulate Db tc_options.db. Elpi Accumulate File tc_aux. Elpi Accumulate File ho_precompile. Elpi Accumulate File unif. Elpi Accumulate File ho_link. Elpi Accumulate File ho_compile. Elpi Accumulate File compiler1. Elpi Accumulate File modes. Elpi Accumulate lp:{{ main L :- args->str-list L L1, tc.time-it _ (std.forall {coq.TC.db-tc} (x\ tc.add-tc-or-inst-gr [] L1 [x])) "TC.AddAllInstances". }}. Elpi Command TC.AddInstances. Elpi Accumulate Db tc.db. Elpi Accumulate Db tc_options.db. Elpi Accumulate File tc_aux. Elpi Accumulate File ho_precompile. Elpi Accumulate File ho_compile. Elpi Accumulate File unif. Elpi Accumulate File ho_link. Elpi Accumulate File compiler1. Elpi Accumulate File modes. Elpi Accumulate File parser_addInstances. Elpi Accumulate lp:{{ main Arguments :- tc.parse Arguments Res, tc.run-command Res. }}. Elpi Command TC.AddAllClasses. Elpi Accumulate Db tc.db. Elpi Accumulate Db tc_options.db. Elpi Accumulate File tc_aux. Elpi Accumulate File modes. 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, tc.time-it _ (std.forall {coq.TC.db-tc} (x\ if (std.mem IgnoreGR x) true (tc.add-class-gr tc.classic x))) "TC.AddAllClasses". }}. Elpi Command TC.AddClasses. Elpi Accumulate Db tc.db. Elpi Accumulate Db tc_options.db. Elpi Accumulate File tc_aux. Elpi Accumulate File modes. Elpi Accumulate File create_tc_predicate. Elpi Accumulate lp:{{ pred tc.add-all-classes i:list argument , i:tc.search-mode. tc.add-all-classes L S :- tc.time-it _ (std.forall {args->str-list L} (tc.add-class-str S)) "TC.AddClasses". main L :- std.mem {attributes} (attribute "deterministic" _), tc.add-all-classes L tc.deterministic. main L :- tc.add-all-classes L tc.classic. main _ :- coq.error "This commands accepts: [classic|deterministic]? TC-names*". }}. Elpi Command TC.AddHook. Elpi Accumulate Db tc.db. Elpi Accumulate Db tc_options.db. Elpi Accumulate File tc_aux. Elpi Accumulate lp:{{ pred tc.addHook i:grafting, i:string. tc.addHook Grafting NewName :- @global! => tc.add-tc-db NewName Grafting (tc.hook NewName). main [str "before", str OldHook, str NewHook] :- tc.addHook (before OldHook) NewHook. main [str "after", str OldHook, str NewHook] :- tc.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 Command TC.Declare. Elpi Accumulate Db tc.db. Elpi Accumulate Db tc_options.db. Elpi Accumulate File tc_aux. Elpi Accumulate File modes. Elpi Accumulate File create_tc_predicate. Elpi Accumulate lp:{{ main _ :- coq.warning "TC.Declare" {tc.warning-name} "This command does not fully mirror the watned behavior if the class has methods with implicit arguments (those implicits will be neglected)", fail. main [indt-decl D] :- tc.declare-class D. main _ :- coq.error "Argument should be an inductive type". }}. Elpi Command TC.Pending_mode. Elpi Accumulate Db tc.db. Elpi Accumulate Db tc_options.db. Elpi Accumulate File tc_aux. Elpi Accumulate File modes. Elpi Accumulate File create_tc_predicate. Elpi Accumulate lp:{{ main M :- % the "o" added at the end of M stands for the solution of the goal std.append M [str "o"] M1, tc.add-pending-mode {args->str-list M1}. }}. Elpi Export TC.AddAllClasses. Elpi Export TC.AddAllInstances. Elpi Export TC.AddClasses. Elpi Export TC.AddInstances. Elpi Export TC.AddHook. Elpi Export TC.Declare. Elpi Export TC.Pending_mode.coq-elpi-2.4.0/apps/tc/theories/db.v000066400000000000000000000072141474173443600172160ustar00rootroot00000000000000(* license: GNU Lesser General Public License Version 2.1 or later *) (* ------------------------------------------------------------------------- *) From elpi Require Import 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:{{ namespace tc { pred oTC-eta-reduce-proof o:list string. oTC-eta-reduce-proof ["TC", "Eta", "Reduce", "Proof"]. % 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"]. pred oTC-time-compile-goal o:list string. oTC-time-compile-goal ["TC", "Time", "Compile", "Query"]. pred oTC-time-mode-check o:list string. oTC-time-mode-check ["TC", "Time", "Mode", "Check"]. % Time taken by the whole search in tc pred oTC-time-msolve o:list string. oTC-time-msolve ["TC", "Time"]. % Time taken to refine the solution pred oTC-time-refine o:list string. oTC-time-refine ["TC", "Time", "Refine"]. pred oTC-time-compile-instance o:list string. oTC-time-compile-instance ["TC", "Time", "Compile", "Instance"]. pred oTC-time-compile-class o:list string. oTC-time-compile-class ["TC", "Time", "Compile", "Class"]. 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-eta-reduce-proof, oTC-time-refine, oTC-time-msolve, oTC-clauseNameShortName, oTC-time-instance-search, oTC-debug, oTC-use-pattern-fragment-compiler, oTC-time-compile-goal, oTC-time-mode-check, oTC-time-compile-instance, oTC-time-compile-class ]. pred is-option-active i:(list string -> prop). is-option-active uvar :- !, fail. is-option-active Opt :- Opt X, coq.option.get X (coq.option.bool tt). pred warning-name o:string. warning-name "[TC] Warning". } }}. Elpi Db tc.db lp:{{ namespace tc { % 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 Locality], ClassGR is the class implemented by InstGR % Locality is either the empty list, or [@local!], or [@global!] pred instance o:list string, o:gref, o:gref, o:list prop. % [class ClassGR PredName SearchMode Modes], for each class GR, it contains % the name of its predicate and its SearchMode :index (5) pred class o:gref, o:string, o:search-mode, o:list string. % pred on which we graft instances in the database pred hook o:string. :name "firstHook" hook "firstHook". :name "lastHook" hook "lastHook". % [unfold-constant C] constants to be unfolded before goal resolution pred unfold-constant o:constant. % the set of instances that we are not yet able to compile, % in majority they use universe polimorphism pred banned o:gref. pred pending-mode o:list string. pred dummy. pred ho-link o:term, i:term, o:A. pred link.eta i:term, i:term. pred link.llam i:term, i:term. } }}. From elpi.apps.tc.elpi Extra Dependency "base.elpi" as base. #[superglobal] Elpi Accumulate tc.db File base. coq-elpi-2.4.0/apps/tc/theories/dune000066400000000000000000000002471474173443600173170ustar00rootroot00000000000000(coq.theory (name elpi.apps.tc) (package coq-elpi) (theories elpi elpi.apps.tc.elpi) (flags -w -all -w -elpi) (plugins coq-elpi.tc)) (include_subdirs qualified) coq-elpi-2.4.0/apps/tc/theories/tc.v000066400000000000000000000155161474173443600172430ustar00rootroot00000000000000(* license: GNU Lesser General Public License Version 2.1 or later *) (* ------------------------------------------------------------------------- *) Declare ML Module "coq-elpi.tc". From elpi.apps.tc.elpi Extra Dependency "tc_aux.elpi" as tc_aux. (* From elpi.apps.tc.elpi Extra Dependency "compiler.elpi" as compiler. *) From elpi.apps.tc.elpi Extra Dependency "ho_precompile.elpi" as ho_precompile. From elpi.apps.tc.elpi Extra Dependency "ho_compile.elpi" as ho_compile. From elpi.apps.tc.elpi Extra Dependency "compiler1.elpi" as compiler1. From elpi.apps.tc.elpi Extra Dependency "modes.elpi" as modes. From elpi.apps.tc.elpi Extra Dependency "unif.elpi" as unif. From elpi.apps.tc.elpi Extra Dependency "ho_link.elpi" as ho_link. From elpi.apps.tc.elpi Extra Dependency "solver.elpi" as solver. From elpi.apps.tc.elpi Extra Dependency "create_tc_predicate.elpi" as create_tc_predicate. From elpi.apps Require Import db. From elpi.apps Require Export add_commands. Set Warnings "+elpi". Elpi Command TC.Print_instances. Elpi Accumulate Db tc.db. Elpi Accumulate lp:{{ pred tc.list-printer-aux i:prop. tc.list-printer-aux (tc.instance _ InstGR _ Locality) :- coq.say InstGR "with locality" Locality. pred tc.list-printer i:gref, i:list prop. tc.list-printer _ []. tc.list-printer ClassGR Instances :- coq.say "Instances list for" ClassGR "is:", std.forall Instances tc.list-printer-aux. main [str Class] :- std.assert! (coq.locate Class ClassGR) "The entered TC not exists", std.findall (tc.instance _ _ ClassGR _) Rules, tc.list-printer ClassGR Rules. main [] :- std.forall {coq.TC.db-tc} (ClassGR\ sigma Rules\ std.findall (tc.instance _ _ ClassGR _) Rules, tc.list-printer ClassGR Rules ). }}. Elpi Tactic TC.Solver. Elpi Accumulate Db tc.db. Elpi Accumulate Db tc_options.db. Elpi Accumulate File tc_aux. Elpi Accumulate File unif. Elpi Accumulate File ho_link. (* Elpi Accumulate File compiler. *) Elpi Accumulate File ho_precompile. Elpi Accumulate File ho_compile. Elpi Accumulate File compiler1. Elpi Accumulate File create_tc_predicate. Elpi Accumulate File modes. Elpi Accumulate File solver. Elpi Query lp:{{ sigma Options\ tc.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 Query lp:{{ sigma Nums\ std.iota 1001 Nums, std.forall Nums (x\ sigma NumStr\ NumStr is int_to_string x, @global! => tc.add-tc-db NumStr (before "lastHook") (tc.hook NumStr) ) }}. Elpi Command TC.Compiler. Elpi Accumulate Db tc.db. Elpi Accumulate Db tc_options.db. Elpi Accumulate File tc_aux. Elpi Accumulate File create_tc_predicate. Elpi Accumulate File ho_precompile. Elpi Accumulate File ho_compile. Elpi Accumulate File unif. Elpi Accumulate File ho_link. Elpi Accumulate File compiler1. Elpi Accumulate File modes. Elpi Accumulate lp:{{ /* Projections of a class that are coercions, are wrongly compiled: In the following code: ```coq Class Animal. Class Bird := IsAnimal :> Animal. ``` The instance IsAnimal of type Bird -> Animal, is compiled before the predicate for Bird; hence, Bird is not recognize as a premise of IsAnimal. This problem is due to the order in which the registers for Instance and Class creation are run. The solution is to do the following two jobs when a class C is created: 1: for every projection P of C, if P is a coercion, the wrongly compiled instance is replaced with a `dummy` clause. 2: the predicate for the class is created 3: for every projection P of C, if P is a coercion, the correct instance is created and added to the db */ shorten tc.class-coercion.{add, remove, loop-proj}. main [str "remove_coercions" | Proj] :- !, loop-proj remove Proj. main [str "add_coercions" | Proj] :- !, loop-proj add Proj. main [str "new_instance", str Inst, str Cl, str Locality, int Prio] :- !, tc.time-it _ (coq.locate Cl GRCl, coq.locate Inst GRInst, tc.add-inst GRInst GRCl Locality Prio) "Compiler for Instance". main [str "new_class", str Cl] :- !, tc.time-it tc.oTC-time-compile-class ( coq.locate Cl GR, tc.add-class-gr tc.classic GR ) "Compiler for Class". % used to build ad-hoc instance for eta-reduction on the argument of % Cl that have function type main [str "default_instance", str Cl] :- !, tc.eta-reduction-aux.main Cl. main A :- coq.error "Fail in TC.Compiler: not a valid input entry" A. }}. (* 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! (tc.class ClassGR PredName _ Modes) "Cannot find `class ClassGR _ _` in the db", std.assert! (not (tc.instance _ _ ClassGR _)) "Cannot set deterministic a class with an already existing instance", tc.add-tc-db _ (after "0") (tc.class ClassGR PredName tc.deterministic Modes :- !). }}. Elpi Command TC.Get_class_info. 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, tc.class ClassGR PredName SearchMode Modes, coq.say "[TC] For " ClassGR ":", coq.say " elpi predicate :" PredName, coq.say " search mode is :" SearchMode, coq.say " modes are :" Modes. main [str C] :- coq.error "[TC]" C "is not found in elpi db". main [A] :- std.assert! (str _ = A) "first argument should be a str". main [_|_] :- coq.error "[TC] Get_class_info accepts only one argument of type str". main [] :- coq.error "[TC] Get_class_info accepts only one argument of type str". main L :- coq.error "[TC] Uncaught error on input" L. }}. Elpi Command TC.Unfold. Elpi Accumulate Db tc_options.db. Elpi Accumulate Db tc.db. Elpi Accumulate File tc_aux. Elpi Accumulate lp:{{ pred tc.add-unfold i:gref. tc.add-unfold (const C) :- if (tc.unfold-constant C) true (tc.add-tc-db _ _ (tc.unfold-constant C)). tc.add-unfold GR :- coq.error "[TC]" GR "is not a constant". main L :- ErrMsg = "[TC] TC.Unfold accepts a list of string is accepted", std.map L (x\r\ sigma R\ std.assert! (str R = x) ErrMsg, coq.locate R r) L', std.forall L' tc.add-unfold. }}. Elpi TC Solver Register TC.Solver. Elpi TC Solver Activate TC.Solver. Elpi TC Solver Override 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 Export TC.Unfold. Set Warnings "elpi". Elpi TC.AddAllClasses. Elpi TC.AddAllInstances.coq-elpi-2.4.0/apps/tc/theories/wip.v000066400000000000000000000040421474173443600174240ustar00rootroot00000000000000(* license: GNU Lesser General Public License Version 2.1 or later *) (* --------------------------------------------------------------------------*) Declare ML Module "coq-elpi.tc". From elpi Require Import elpi. From elpi.apps.tc.elpi Extra Dependency "modes.elpi" as modes. From elpi.apps.tc.elpi Extra Dependency "ho_precompile.elpi" as ho_precompile. From elpi.apps.tc.elpi Extra Dependency "ho_compile.elpi" as ho_compile. From elpi.apps.tc.elpi Extra Dependency "compiler1.elpi" as compiler1. From elpi.apps.tc.elpi Extra Dependency "ho_link.elpi" as ho_link. From elpi.apps.tc.elpi Extra Dependency "parser_addInstances.elpi" as parser_addInstances. From elpi.apps.tc.elpi Extra Dependency "alias.elpi" as alias. From elpi.apps.tc.elpi Extra Dependency "solver.elpi" as solver. From elpi.apps.tc.elpi Extra Dependency "rewrite_forward.elpi" as rforward. From elpi.apps.tc.elpi Extra Dependency "tc_aux.elpi" as tc_aux. From elpi.apps.tc.elpi Extra Dependency "create_tc_predicate.elpi" as create_tc_predicate. (* From elpi.apps Require Import tc. Set Warnings "+elpi". 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 ho_link. Elpi Accumulate File modes. Elpi Accumulate File ho_precompile. Elpi Accumulate File compiler1. Elpi Accumulate File ho_compile. Elpi Accumulate File create_tc_predicate. Elpi Accumulate File solver. Elpi Accumulate File rforward. Elpi Accumulate lp:{{ :before "tc-compile-context" tc.compile.context Ctx Clauses :- !, std.append Ctx {section-var->decl} CtxAndSection, tc.compile.instance.context {rewrite-dep CtxAndSection} Clauses. main L :- std.forall {args->str-list L} add-lemma->forward. }}. 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 ho_link. Elpi Accumulate File alias. Elpi Accumulate lp:{{ main [trm New, trm Old] :- add-tc-db _ _ (alias New Old). }}. *)coq-elpi-2.4.0/builtin-doc/000077500000000000000000000000001474173443600154545ustar00rootroot00000000000000coq-elpi-2.4.0/builtin-doc/coq-builtin-synterp.elpi000066400000000000000000000350131474173443600222610ustar00rootroot00000000000000 kind implicit_kind type. kind field-attribute type. kind upoly-decl type. kind upoly-decl-cumul type. % -- 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.debug ...] Prints a debug message external type coq.debug 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). type open-trm int -> term -> argument. % 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 kind arity type. 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*/ kind modpath type. % Name of a module type /*E*/ kind modtypath type. % [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 remove 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. % Synterp action group kind group type. % [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.4.0/builtin-doc/coq-builtin.elpi000066400000000000000000002630051474173443600205630ustar00rootroot00000000000000 % 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). type open-trm int -> term -> argument. % 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 kind arity type. 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 branches. % - 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 consequence 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 already 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 clause, 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 universe 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 is the one with the constraints 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.debug ...] Prints a debug message external type coq.debug 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 kind constant type. % Inductive type name kind inductive type. % Inductive constructor name kind constructor type. % 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*/ kind modpath type. % Name of a module type /*E*/ kind modtypath type. % 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 understands 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 I 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:implicit_kind, i:term, o:constant. pred coq.env.add-context i:context-decl. coq.env.add-context context-end. coq.env.add-context (context-item Name I Ty none Rest) :- coq.env.add-section-variable Name I Ty C, coq.env.add-context (Rest {coq.env.global (const C)}). coq.env.add-context (context-item Name _I Ty (some Bo) Rest) :- coq.env.add-const Name Bo Ty ff C, coq.env.add-context (Rest {coq.env.global (const C)}). % [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.projection? Constant Number of parameters] if the constant is a % projection, returns the number of parameters of its record. external pred coq.env.projection? i:constant, o:int. % [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)). % [coq.env.primitive-projection? Projection Compatibility constant] relates % a projection to its compatibility constant. external pred coq.env.primitive-projection? i:projection, o:constant. % -- 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) kind univ type. % 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 kind univ.variable type. % [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 kind univ-instance type. % [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 -------------------------------------------------------- kind uint63 type. kind float64 type. kind pstring type. kind projection type. % 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 pstring pstring -> primitive-value. % primitive string 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. % [coq.pstring->string PS S] Transforms a Coq primitive string to an elpi % string. It does not fail. external pred coq.pstring->string i:pstring, o:string. % [coq.string->pstring S PS] Transforms an elpi string into a Coq primitive % string. It fails if the lenght of S is greater than the maximal primitive % string length. external pred coq.string->pstring i:string, o:pstring. % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % 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 with priority kind tc-instance type. type tc-instance gref -> int -> 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:int. % [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.arguments.reset-simplification GR] resets the behavior of the % simplification tactics. % Also resets the ! and / modifiers for the Arguments command. % Supported attributes: % - @global! (default: false) external pred coq.arguments.reset-simplification i:gref. % [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 kind abbreviation type. % [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) % - @warn! (default: no warning) % - @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 kind coq.redflags type. 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 kind ltac1-tactic type. % [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` kind name type. % [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 remove 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 kind group type. % [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.choose M X] X is an element of M external pred coq.gref.set.choose i:coq.gref.set, o:gref. % [coq.gref.set.min M X] X is the smallest element of M external pred coq.gref.set.min i:coq.gref.set, o:gref. % [coq.gref.set.max M X] X is the bigger of M external pred coq.gref.set.max i:coq.gref.set, o: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. % [coq.gref.set.fold M Acc F Acc1] fold M w.r.t. the predicate F external pred coq.gref.set.fold i:coq.gref.set, i:A, i:gref -> A -> A -> prop, o:A. % [coq.gref.set.partition M F M1 M2] Partitions M w.r.t. the predicate F, M1 % is where F holds external pred coq.gref.set.partition i:coq.gref.set, i:gref -> prop, o:coq.gref.set, 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. % [coq.gref.map.fold M Acc F Acc1] fold M w.r.t. the predicate F external pred coq.gref.map.fold i:coq.gref.map A, i:C, i:gref -> A -> C -> C -> prop, o:C. 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.choose M X] X is an element of M external pred coq.univ.set.choose i:coq.univ.set, o:univ. % [coq.univ.set.min M X] X is the smallest element of M external pred coq.univ.set.min i:coq.univ.set, o:univ. % [coq.univ.set.max M X] X is the bigger of M external pred coq.univ.set.max i:coq.univ.set, o: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. % [coq.univ.set.fold M Acc F Acc1] fold M w.r.t. the predicate F external pred coq.univ.set.fold i:coq.univ.set, i:A, i:univ -> A -> A -> prop, o:A. % [coq.univ.set.partition M F M1 M2] Partitions M w.r.t. the predicate F, M1 % is where F holds external pred coq.univ.set.partition i:coq.univ.set, i:univ -> prop, o:coq.univ.set, 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. % [coq.univ.map.fold M Acc F Acc1] fold M w.r.t. the predicate F external pred coq.univ.map.fold i:coq.univ.map A, i:C, i:univ -> A -> C -> C -> prop, o:C. 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.choose M X] X is an element of M external pred coq.univ.variable.set.choose i:coq.univ.variable.set, o:univ.variable. % [coq.univ.variable.set.min M X] X is the smallest element of M external pred coq.univ.variable.set.min i:coq.univ.variable.set, o:univ.variable. % [coq.univ.variable.set.max M X] X is the bigger of M external pred coq.univ.variable.set.max i:coq.univ.variable.set, o: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. % [coq.univ.variable.set.fold M Acc F Acc1] fold M w.r.t. the predicate F external pred coq.univ.variable.set.fold i:coq.univ.variable.set, i:A, i:univ.variable -> A -> A -> prop, o:A. % [coq.univ.variable.set.partition M F M1 M2] Partitions M w.r.t. the % predicate F, M1 is where F holds external pred coq.univ.variable.set.partition i:coq.univ.variable.set, i:univ.variable -> prop, o:coq.univ.variable.set, 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.univ.variable.map.fold M Acc F Acc1] fold M w.r.t. the predicate F external pred coq.univ.variable.map.fold i:coq.univ.variable.map A, i:C, i:univ.variable -> A -> C -> C -> prop, o:C. % 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.4.0/builtin-doc/dune000066400000000000000000000005061474173443600163330ustar00rootroot00000000000000(executable (name gen_doc) (libraries elpi_plugin)) (rule (targets coq-builtin.elpi coq-builtin-synterp.elpi elpi-builtin.elpi) (deps gen_doc.exe) (mode promote) (action (run ./gen_doc.exe))) (install (files coq-builtin.elpi coq-builtin-synterp.elpi elpi-builtin.elpi) (section doc) (package coq-elpi)) coq-elpi-2.4.0/builtin-doc/elpi-builtin.elpi000066400000000000000000001306511474173443600207320ustar00rootroot00000000000000 % File generated by elpi -document-builtins, do not edit % == Core builtins ===================================== % -- Logic -- pred true. true. pred fail. pred false. external pred (=) o:A, o:A. % unification external pred (pi) i:A -> prop. external pred (sigma) i:A -> prop. kind int type. kind string type. kind float type. pred (;) i:prop, i: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. 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. pred (>) i:A, i:A. X > Y :- gt_ X Y. pred (<) i:A, i:A. X < Y :- lt_ X Y. pred (=<) i:A, i:A. X =< Y :- le_ X Y. pred (>=) i:A, i:A. X >= Y :- ge_ X Y. pred (i>) i:int, i:int. X i> Y :- gt_ X Y. pred (i<) i:int, i:int. X i< Y :- lt_ X Y. pred (i=<) i:int, i:int. X i=< Y :- le_ X Y. pred (i>=) i:int, i:int. X i>= Y :- ge_ X Y. pred (r>) i:float, i:float. X r> Y :- gt_ X Y. pred (r<) i:float, i:float. X r< Y :- lt_ X Y. pred (r=<) i:float, i:float. X r=< Y :- le_ X Y. pred (r>=) i:float, i:float. X r>= Y :- ge_ X Y. pred (s>) i:string, i:string. X s> Y :- gt_ X Y. pred (s<) i:string, i:string. X s< Y :- lt_ X Y. pred (s=<) i:string, i:string. X s=< Y :- le_ X Y. pred (s>=) i:string, i:string. 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. kind triple type -> type -> type -> type. type triple A -> B -> C -> triple A B C. pred triple_1 i:triple A B C, o:A. triple_1 (triple A _ _) A. pred triple_2 i:triple A B C, o:B. triple_2 (triple _ B _) B. pred triple_3 i:triple A B C, o:C. triple_3 (triple _ _ C) C. % 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. kind loc type. % [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 ===================================== % [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 "int" external pred is_cdata i:any, o:string. pred primitive? i:A, i:string. primitive? X S :- is_cdata X 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. P may or may not be % instantiated. Instances should be found in L. external pred findall_solutions i:prop, o:list prop. % Holds data across bracktracking; can only contain closed terms kind safe type. % [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 1 "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! _. pred once i:prop. once P :- P, !. % [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:(pred o:diagnostic), 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. :untyped 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. pred rev.aux i:list A, i:list A, o:list A. 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 [] L L. appendR [X|XS] L [X|L1] :- appendR XS L L1. 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:(pred i:B, i:A, o:A), 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:(pred i:B, i:A, o:A), 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:(pred i:C, i:B, i:A, o:A), 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:(pred i:A, o:B), o:list B. map [] _ []. map [X|XS] F [Y|YS] :- F X Y, map XS F YS. pred map-i i:list A, i:(pred i:int, i:A, o:B), o:list B. map-i L F R :- map-i.aux L 0 F R. pred map-i.aux i:list A, i:int, i:(pred i:int, i:A, o:B), o:list B. 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:(pred i:A, o:B), 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:(pred i:A, i:B, o:C), 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:(pred i:A, i:B, o:C), 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:(pred i:A, i:B, o:diagnostic), o:list B, 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:(pred i:A, i:B, o:C, o:B), 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:(pred i:A, o:B), 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:(pred i:A). exists [X|_] P :- P X. exists [_|L] P :- exists L P. pred exists2 i:list A, i:list B, i:(pred i:A, i:B). 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:(pred i:A). forall [] _. forall [X|L] P :- P X, forall L P. pred forall-ok i:list A, i:(pred i:A, o:diagnostic), 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:(pred i:A, i:B). 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:(pred i:A), 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 []. % [make N E L] L is [E, ..., E] and L has length N pred list.make i:int, i:A, o:list A. list.make 0 _ [] :- !. list.make N E [E|L] :- N' is N - 1, list.make N' E L. % [init N F L] L is [F 0, ..., F (N-1)] pred list.init i:int, i:(pred i:int, o:A), o:list A. list.init N F L :- list.init.aux 0 N F L. pred list.init.aux i:int, i:int, i:(pred i:int, o:A), o:list A. list.init.aux N N _ [] :- !. list.init.aux N M F [E|L] :- F N E, N' is N + 1, list.init.aux N' M F L. pred iota i:int, o:list int. iota N L :- list.init N (x\y\ x = y) L. % [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:(pred i:A, i:B), 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 (pred o:diagnostic). 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 (pred o:diagnostic), 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. % [std.string.map.fold M Acc F Acc1] fold M w.r.t. the predicate F external pred std.string.map.fold i:std.string.map A, i:C, i:string -> A -> C -> C -> prop, o:C. % 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. % [std.int.map.fold M Acc F Acc1] fold M w.r.t. the predicate F external pred std.int.map.fold i:std.int.map A, i:C, i:int -> A -> C -> C -> prop, o:C. % 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. % [std.loc.map.fold M Acc F Acc1] fold M w.r.t. the predicate F external pred std.loc.map.fold i:std.loc.map A, i:C, i:loc -> A -> C -> C -> prop, o:C. 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.choose M X] X is an element of M external pred std.string.set.choose i:std.string.set, o:string. % [std.string.set.min M X] X is the smallest element of M external pred std.string.set.min i:std.string.set, o:string. % [std.string.set.max M X] X is the bigger of M external pred std.string.set.max i:std.string.set, o: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. % [std.string.set.fold M Acc F Acc1] fold M w.r.t. the predicate F external pred std.string.set.fold i:std.string.set, i:A, i:string -> A -> A -> prop, o:A. % [std.string.set.partition M F M1 M2] Partitions M w.r.t. the predicate F, % M1 is where F holds external pred std.string.set.partition i:std.string.set, i:string -> prop, o:std.string.set, 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.choose M X] X is an element of M external pred std.int.set.choose i:std.int.set, o:int. % [std.int.set.min M X] X is the smallest element of M external pred std.int.set.min i:std.int.set, o:int. % [std.int.set.max M X] X is the bigger of M external pred std.int.set.max i:std.int.set, o: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. % [std.int.set.fold M Acc F Acc1] fold M w.r.t. the predicate F external pred std.int.set.fold i:std.int.set, i:A, i:int -> A -> A -> prop, o:A. % [std.int.set.partition M F M1 M2] Partitions M w.r.t. the predicate F, M1 % is where F holds external pred std.int.set.partition i:std.int.set, i:int -> prop, o:std.int.set, 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.choose M X] X is an element of M external pred std.loc.set.choose i:std.loc.set, o:loc. % [std.loc.set.min M X] X is the smallest element of M external pred std.loc.set.min i:std.loc.set, o:loc. % [std.loc.set.max M X] X is the bigger of M external pred std.loc.set.max i:std.loc.set, o: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. % [std.loc.set.fold M Acc F Acc1] fold M w.r.t. the predicate F external pred std.loc.set.fold i:std.loc.set, i:A, i:loc -> A -> A -> prop, o:A. % [std.loc.set.partition M F M1 M2] Partitions M w.r.t. the predicate F, M1 % is where F holds external pred std.loc.set.partition i:std.loc.set, i:loc -> prop, o:std.loc.set, o:std.loc.set. #line 1 "builtin_map.elpi" kind std.map type -> type -> type. type std.map std.map.private.map K V -> (pred i:K, i:K, o:cmp) -> 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:(pred i:K, i:K, o:cmp), 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. pred bal.aux i:int, i:int, i:int, i:int, i:map K V, i:K, i:V, i:map K V, o:map K V. 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:(pred i:K, i:K, o:cmp), 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. pred add.aux i:cmp, i:map K V, i:(pred i:K, i:K, o:cmp), i:K, i:V, o:map K V. 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:(pred i:K, i:K, o:cmp), 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. pred find.aux i:cmp, i:(pred i:K, i:K, o:cmp), i:map K V, i:map K V, i:V, i:K, o: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:(pred i:K, i:K, o:cmp), 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. pred remove.aux i:cmp, i:(pred i:K, i:K, o:cmp), i:map K V, i:map K V, i:K, i:V, i:K, o:map K V. 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 1 "builtin_set.elpi" kind std.set type -> type. type std.set std.set.private.set E -> (pred i:E, i:E, o:cmp) -> 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:(pred i:E, i:E, o:cmp), 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. pred bal.aux i:int, i:int, i:int, i:int, i:set E, i:E, i:set E, o:set E. 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:(pred i:E, i:E, o:cmp), 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. pred add.aux i:cmp, i:(pred i:E, i:E, o:cmp), i:set E, i:set E, i:E, i:E, i:int, o:set E. 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:(pred i:E, i:E, o:cmp), i:E. mem (node L K R _) Cmp E :- Cmp E K O, mem.aux O Cmp L R E. mem.aux eq _ _ _ _. pred mem.aux i:cmp, i:(pred i:E, i:E, o:cmp), i:set E, i:set E, i:E. 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:(pred i:E, i:E, o:cmp), 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. pred remove.aux i:cmp, i:(pred i:E, i:E, o:cmp), i:set E, i:set E, i:E, i:E, o:set E. 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 -- kind in_stream type. type std_in in_stream. kind out_stream type. 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. pred printterm i:out_stream, i:A. printterm S T :- term_to_string T T1, output S T1. coq-elpi-2.4.0/builtin-doc/gen_doc.ml000066400000000000000000000000751474173443600174060ustar00rootroot00000000000000let _ = Elpi_plugin.Coq_elpi_programs.document_builtins () coq-elpi-2.4.0/coq-elpi-tests.opam000066400000000000000000000012431474173443600167720ustar00rootroot00000000000000# This file is generated by dune, edit dune-project instead opam-version: "2.0" synopsis: "Technical package to run tests" description: "Do not install" 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" depends: [ "dune" {>= "3.13"} "coq-elpi" "odoc" {with-doc} ] build: [ ["dune" "subst"] {dev} [ "dune" "build" "-p" name "-j" jobs "@install" "@runtest" {with-test} "@doc" {with-doc} ] ] dev-repo: "git+https://github.com/LPCIC/coq-elpi.git" coq-elpi-2.4.0/coq-elpi.opam000066400000000000000000000031441474173443600156340ustar00rootroot00000000000000# This file is generated by dune, edit dune-project instead opam-version: "2.0" 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." maintainer: ["Enrico Tassi "] authors: ["Enrico Tassi "] license: "LGPL-2.1-or-later" tags: [ "category:Miscellaneous/Coq Extensions" "keyword:λProlog" "keyword:higher order abstract syntax" "logpath:elpi" ] homepage: "https://github.com/LPCIC/coq-elpi" bug-reports: "https://github.com/LPCIC/coq-elpi/issues" depends: [ "dune" {>= "3.13"} "ocaml" {>= "4.10.0"} "elpi" {>= "2.0.7" & < "2.1.0~"} "coq" {>= "8.20+rc1" & < "8.21~"} "ppx_optcomp" "ocaml-lsp-server" {with-dev-setup} "odoc" {with-doc} ] build: [ ["dune" "subst"] {dev} [ make "elpi/dune"] [ "dune" "build" "-p" name "-j" jobs "@install" "@runtest" {with-test} "@doc" {with-doc} ] ] dev-repo: "git+https://github.com/LPCIC/coq-elpi.git" coq-elpi-2.4.0/default.nix000066400000000000000000000006611474173443600154120ustar00rootroot00000000000000{ 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.4.0/dune000066400000000000000000000004721474173443600141240ustar00rootroot00000000000000(env (dev (flags (:standard -w -9 -w -32 -w -27 -w -6 -w -37 -warn-error -A)) (coq (flags -w +elpi.deprecated -w +elpi.implication-precedence -bt))) (fatalwarnings (flags (:standard -w -9 -w -32 -w -27 -w -6 -w -37 -warn-error +A)) (coq (flags -w +elpi.deprecated -w +elpi.implication-precedence -bt)))) coq-elpi-2.4.0/dune-project000066400000000000000000000027171474173443600155740ustar00rootroot00000000000000(lang dune 3.13) (using coq 0.8) (name coq-elpi) ;(generate_opam_files) (source (github LPCIC/coq-elpi)) (license LGPL-2.1-or-later) (authors "Enrico Tassi ") (maintainers "Enrico Tassi ") (package (name coq-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.") (tags ("category:Miscellaneous/Coq Extensions" "keyword:λProlog" "keyword:higher order abstract syntax" "logpath:elpi")) (depends (ocaml (>= 4.10.0)) (elpi (and (>= 2.0.3) (< 2.1.0~))) (coq (and (>= 8.20+rc1) (< 8.21~))) ppx_optcomp (ocaml-lsp-server :with-dev-setup))) (package (name coq-elpi-tests) (synopsis "Technical package to run tests") (description "Do not install") (depends coq-elpi)) coq-elpi-2.4.0/elpi/000077500000000000000000000000001474173443600141745ustar00rootroot00000000000000coq-elpi-2.4.0/elpi/README.md000066400000000000000000000015371474173443600154610ustar00rootroot00000000000000### 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.4.0/elpi/coq-HOAS.elpi000066400000000000000000000353171474173443600163720ustar00rootroot00000000000000%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 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 branches. % - 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 consequence 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 already 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 clause, 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 universe 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 is the one with the constraints 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.4.0/elpi/coq-arg-HOAS.elpi000066400000000000000000000133071474173443600171340ustar00rootroot00000000000000%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %%%%%%%%%%%%%%%%%%%%%%%%%%%% 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). type open-trm int -> term -> argument. % 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 kind arity type. 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.4.0/elpi/coq-elaborator.elpi000066400000000000000000000040201474173443600177550ustar00rootroot00000000000000/* 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.4.0/elpi/coq-elpi-checker.elpi000066400000000000000000000025651474173443600201720ustar00rootroot00000000000000/* 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 [pr L M|MS] tt :- Msgs = [pr L M|MS], all-same-loc L Msgs, !, coq.error L "At least one of the following errors holds:" {error-concat-noloc Msgs}. :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 L R :- std.string.concat "\n" {std.map L error-pp-wloc} R. pred error-concat-noloc i:list string, o:string. error-concat-noloc L R :- std.string.concat "\n" {std.map L error-pp-noloc} R. pred error-pp-wloc i:pair loc string, o:string. error-pp-wloc (pr L S) R :- R is {std.any->string L} ^ " " ^ S. pred error-pp-noloc i:pair loc string, o:string. error-pp-noloc (pr _ S) R :- R is "- " ^ S. pred all-same-loc i:loc, i:list (pair loc string). all-same-loc L XS :- std.forall XS (x\sigma s\x = pr L s). :before "default-typechecking-warning" warning L M :- !, coq.warning "elpi" "elpi.typecheck" L M. coq-elpi-2.4.0/elpi/coq-lib-common.elpi000066400000000000000000000155001474173443600176640ustar00rootroot00000000000000/* 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.debug 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") (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, !. pred parse-attributes.aux i:list attribute, i:string, o:list prop. 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.4.0/elpi/coq-lib.elpi000066400000000000000000000703141474173443600164020ustar00rootroot00000000000000/* 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_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:any, 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, ]. pred coq.upoly-decl-cumul.complete-constraints.aux i:univ-variance, o:list univ-constraint. 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. pred coq.rename-indt-decl.aux i:(id -> id -> prop), i:(id -> id -> prop), i:(id -> id -> prop), i:indc-decl, o:indc-decl. 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. pred map-under-fun.aux i:term, i:list term, i:list term, i:(term -> list term -> list term -> term -> prop), o:term. 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. pred iter-under-fun.aux i:term, i:list term, i:list term, i:(term -> list term -> list term -> prop). 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. % pred coq.bind-ind-arity.aux i:term, o:term, i:list term, i:list term, i:term, i:(term -> list term -> list term -> term -> prop). coq.bind-ind-arity.aux (prod N T B) (fun N T F) AccT AccTy IT K :- !, @pi-decl N T x\ coq.bind-ind-arity.aux (B x) (F x) [x|AccT] [T|AccTy] IT K. coq.bind-ind-arity.aux (let N T X B) (let N T X F) AccT AccTy IT K :- !, @pi-def N T X x\ coq.bind-ind-arity.aux (B x) (F x) AccT AccTy IT K. coq.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 :- coq.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\ coq.bind-ind-arity.aux (let N T X B) F AccT AccTy IT K :- !, coq.bind-ind-arity.aux (B X) F AccT AccTy IT K) => coq.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. pred coq.bind-ind-parameters.aux i:int, i:term, i:list term, i:list term, i:(term -> list term -> list term -> term -> prop), o:term. 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.4.0/elpi/dune.in000066400000000000000000000007131474173443600154600ustar00rootroot00000000000000(coq.theory (name elpi_elpi) ; FIXME (package coq-elpi) @@STDLIB_THEORY@@) (rule (target dummy.v) (deps (glob_files *.elpi)) (action (with-stdout-to %{target} (progn (echo "Require Import String.\nOpen Scope string_scope.\nLocal Definition _hash := \"\n") (run coq_elpi_shafile %{deps}) (echo "\".\n"))))) (install (files (glob_files (*.elpi with_prefix coq/user-contrib/elpi_elpi/))) (section lib_root) (package coq-elpi)) coq-elpi-2.4.0/elpi/elpi-command-template-synterp.elpi000066400000000000000000000004261474173443600227310ustar00rootroot00000000000000/* Loaded when Elpi Command has a code accumulated at #[synterp] time */ /* license: GNU Lesser General Public License Version 2.1 or later */ /* ------------------------------------------------------------------------- */ accumulate elpi_elpi/coq-lib-common. coq-elpi-2.4.0/elpi/elpi-command-template.elpi000066400000000000000000000006611474173443600212300ustar00rootroot00000000000000/* Loaded when Elpi Command is used */ /* license: GNU Lesser General Public License Version 2.1 or later */ /* ------------------------------------------------------------------------- */ accumulate elpi_elpi/coq-lib. % basic term manipulation routines accumulate elpi_elpi/elpi-reduction. % whd, hd-beta, ... accumulate elpi_elpi/elpi-ltac. % refine, or, thenl, ... coq-elpi-2.4.0/elpi/elpi-ltac.elpi000066400000000000000000000114241474173443600167230ustar00rootroot00000000000000/* 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.4.0/elpi/elpi-reduction.elpi000066400000000000000000000102361474173443600177740ustar00rootroot00000000000000/* 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, !, not(var VA), 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.4.0/elpi/elpi-tactic-template.elpi000066400000000000000000000006231474173443600210570ustar00rootroot00000000000000/* Loaded when Elpi Command is used */ /* license: GNU Lesser General Public License Version 2.1 or later */ /* ------------------------------------------------------------------------- */ % Since the elaborator written in Elpi is not ready, we fallback to the Coq one % accumulate engine/elaborator. % of, unify accumulate elpi_elpi/coq-elaborator.coq-elpi-2.4.0/elpi/elpi_elaborator.elpi000066400000000000000000000354541474173443600202250ustar00rootroot00000000000000/* 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 -> A -> prop), i:A, i:A. swap tt F A B :- F B A. swap ff F A B :- F A B. % flexible cases unif (uvar V L) [] T D _ _ :- get-option "unif:greedy" tt, !, bind-list L {unwind T D} V, !. unif (uvar V L) [] T D _ _ :- !, bind-list L {unwind T D} V. unif X C (uvar V L) [] _ _ :- get-option "unif:greedy" tt, !, bind-list L {unwind X C} V, !. 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:any. 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:elpi.uint63 }} T. of (primitive (float64 _) as X) T X :- unify-leq {{ lib:elpi.float64 }} T. of (primitive (pstring _) as X) T X :- unify-leq {{ lib:elpi.pstring }} 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.4.0/etc/000077500000000000000000000000001474173443600140165ustar00rootroot00000000000000coq-elpi-2.4.0/etc/alectryon_elpi.py000077500000000000000000000274211474173443600174120ustar00rootroot00000000000000#!/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.4.0/etc/coq-elpi.lang000066400000000000000000000273501474173443600164010ustar00rootroot00000000000000 *.v \(\* \*\)