Compare commits

..

54 Commits

Author SHA1 Message Date
Leonardo de Moura
f296779e46 doc: add simproc release notes 2024-01-08 18:08:28 -08:00
Scott Morrison
9b2b4aa284 test: timeout in Mathlib.Computability.PartrecCode 2024-01-08 13:51:33 -08:00
Leonardo de Moura
e6ed38551b fix: panic at ite and dite simprocs 2024-01-08 13:51:21 -08:00
Scott Morrison
72e5a94c05 test: test for panic in simprocs 2024-01-08 13:51:21 -08:00
Leonardo de Moura
7c5a37b408 chore: cleanup builtin simprocs using OptionT 2024-01-08 13:51:21 -08:00
Leonardo de Moura
f4a213fccf chroe: fix tests 2024-01-08 13:51:21 -08:00
Leonardo de Moura
2bab43e759 chore: update stage0 2024-01-08 13:51:21 -08:00
Leonardo de Moura
a23029a716 chore: use mathlib naming convention 2024-01-08 13:51:21 -08:00
Leonardo de Moura
8fbf40843f chore: better method names 2024-01-08 13:51:21 -08:00
Leonardo de Moura
2d738dcae0 chore: add default parameter value for (simprocs : Simprocs) 2024-01-08 13:51:21 -08:00
Leonardo de Moura
9c16fedf5a chore: add another simproc test 2024-01-08 13:51:21 -08:00
Leonardo de Moura
789979ee8e fix: trace used builtin simprocs even if they are not in the environment 2024-01-08 13:51:21 -08:00
Leonardo de Moura
b57fdc096a chore: fix tests 2024-01-08 13:51:21 -08:00
Leonardo de Moura
33295bcca1 chore: update stage0 2024-01-08 13:51:21 -08:00
Leonardo de Moura
d1c385df45 chore: remove staging workaround 2024-01-08 13:51:21 -08:00
Leonardo de Moura
9826229bd3 chore: update stage0 2024-01-08 13:51:21 -08:00
Leonardo de Moura
80b3e87574 chore: remove staging workaround 2024-01-08 13:51:21 -08:00
Leonardo de Moura
382db25052 test: builtin simproc option that is not in the environment 2024-01-08 13:51:21 -08:00
Leonardo de Moura
dfe3983d1c chore: update stage0 2024-01-08 13:51:21 -08:00
Leonardo de Moura
bb6a7faecf fix: allow builtin simprocs to be provided to simp even if they are not in the environment
Motivation: `simp?`
2024-01-08 13:51:21 -08:00
Leonardo de Moura
822158d264 test: Int simprocs 2024-01-08 13:51:21 -08:00
Leonardo de Moura
c8b2d6f0d2 chore: typo 2024-01-08 13:51:21 -08:00
Leonardo de Moura
df2ecb54ea feat: add simprocs for Int 2024-01-08 13:51:21 -08:00
Leonardo de Moura
549d47eadb feat: add simprocs for UInt 2024-01-08 13:51:21 -08:00
Leonardo de Moura
c2cbef108e feat: replace ite and dite shortcircuit theorems with simproc
Motivation: better `simp` cache behavior. Recall that `simp` cache
uses `dischargeDepth`.
2024-01-08 13:51:20 -08:00
Leonardo de Moura
e2c49b4983 feat: add simprocs for Fin 2024-01-08 13:51:20 -08:00
Leonardo de Moura
4e6ec09011 chore: update stage0 2024-01-08 13:51:20 -08:00
Leonardo de Moura
a1d438c59f chore: remove bogus registerSimproc 2024-01-08 13:51:20 -08:00
Leonardo de Moura
dd7e6e3d2e feat: add basic simprocs for Nat 2024-01-08 13:51:20 -08:00
Leonardo de Moura
d86771b1e3 chore: update stage0 2024-01-08 13:51:20 -08:00
Leonardo de Moura
1f103b7509 feat: add builtin simproc support 2024-01-08 13:51:20 -08:00
Leonardo de Moura
04ce796bbe chore: missing copyright 2024-01-08 13:51:20 -08:00
Leonardo de Moura
33bc436539 feat: add simp option - <simproc-name>
We can now disable `simproc`s using the same notation we use to
disable rewriting rules in the simplifier.
2024-01-08 13:51:20 -08:00
Leonardo de Moura
ea231eff5d feat: trace simprocs 2024-01-08 13:51:20 -08:00
Leonardo de Moura
f275ccec19 feat: add option simprocs
It is true by default. Packages can set it to false to disable
simplification procedue support for backward compatibility.
2024-01-08 13:51:20 -08:00
Leonardo de Moura
88a0bbc4a8 chore: fix test 2024-01-08 13:51:20 -08:00
Leonardo de Moura
f7f73dee49 chore: update stage0
`Origin.decl` constructor has an extra field.
2024-01-08 13:51:20 -08:00
Leonardo de Moura
dc1d2c80e2 fix: simp.trace missing pre annotation 2024-01-08 13:51:20 -08:00
Leonardo de Moura
6e9ea192c1 feat: allow extra simprocs to be provided as simp arguments 2024-01-08 13:51:20 -08:00
Leonardo de Moura
9f09264a3f feat: simp only should not use default simproc set 2024-01-08 13:51:20 -08:00
Leonardo de Moura
3060997392 feat: simproc declaration vs simproc attribute
Allow `simproc`s to be declared without setting the `[simproc]`
attribute. A `simproc` declaration is function + pattern.

Motivation: allow them to be provided as arguments to `simp` **and** `simp only`.

TODO: track their use in `simp`.
TODO: builtin simprocs
2024-01-08 13:51:20 -08:00
Leonardo de Moura
312b8eba73 feat: add simprocs
TODO:
- `builtin_simproc` attribute
- more tests
2024-01-08 13:51:20 -08:00
Leonardo de Moura
0055018f4c chore: address feedback 2024-01-08 13:51:20 -08:00
Leonardo de Moura
8aac0fec26 refactor: simplify simpImpl 2024-01-08 13:51:20 -08:00
Leonardo de Moura
102928b533 refactor: simplify match-expressions at pre simp method 2024-01-08 13:51:20 -08:00
Leonardo de Moura
0041d4dccb chore: simplify mutual at simpImpl 2024-01-08 13:51:20 -08:00
Leonardo de Moura
7b2dc2aca7 refactor: use unsafe code to break recursion in simp implementation
Motivations:
- We can simplify the big mutual recursion and the implementation.
- We can implement the support for `match`-expressions in the `pre` method.
- It is easier to define and simplify `Simprocs`.
2024-01-08 13:51:20 -08:00
Leonardo de Moura
ec958f37e2 chore: fix regression due to changes in previous commits
The example was looping with the new `simp` reduction strategy. Here
is the looping trace.
```
List.reverseAux (List.reverseAux as []) bs
==> rewrite using reverseAux_reverseAux
List.reverseAux [] (List.reverseAux (List.reverseAux as []) bs)
==> unfold reverseAux
List.reverseAux (List.reverseAux as []) bs
==> rewrite using reverseAux_reverseAux
List.reverseAux [] (List.reverseAux (List.reverseAux as []) bs)
==> ...
```
2024-01-08 13:51:20 -08:00
Leonardo de Moura
81d4336384 feat: add pre simp lemmas for if-then-else terms
See new test for example that takes exponential time without new simp
theorems.
TODO: replace auxiliary theorems with simprocs as soon as we implement them.
2024-01-08 13:51:20 -08:00
Leonardo de Moura
cac7160edf feat: better support for match-application in the simplifier
The new test exposes a performance problem found in software
verification applications.
2024-01-08 13:51:20 -08:00
Leonardo de Moura
d2a40c863b feat: add Expr.getAppArgsN 2024-01-08 13:51:20 -08:00
Leonardo de Moura
979a315f4a feat: add Expr.getAppPrefix 2024-01-08 13:51:20 -08:00
Leonardo de Moura
7e2f93bb29 feat: add reduceStep, and try pre simp steps again if term was reduced 2024-01-08 13:51:20 -08:00
Leonardo de Moura
2ea2ef5f75 perf: (try to) fix regression introduced by #3139 2024-01-07 10:05:35 -08:00
634 changed files with 2934 additions and 11580 deletions

View File

@@ -1,22 +0,0 @@
name: Actionlint
on:
push:
branches:
- 'master'
paths:
- '.github/**'
pull_request:
paths:
- '.github/**'
merge_group:
jobs:
actionlint:
runs-on: ubuntu-latest
steps:
- name: Checkout
uses: actions/checkout@v3
- name: actionlint
uses: raven-actions/actionlint@v1
with:
pyflakes: false # we do not use python scripts

View File

@@ -46,7 +46,7 @@ jobs:
github.event_name == 'pull_request' && !contains( github.event.pull_request.labels.*.name, 'full-ci')
}}
run: |
echo "quick=${{env.quick}}" >> "$GITHUB_OUTPUT"
echo "quick=${{env.quick}}" >> $GITHUB_OUTPUT
- name: Configure build matrix
id: set-matrix
@@ -124,11 +124,10 @@ jobs:
"release": true,
"quick": false,
"cross": true,
"cross_target": "aarch64-apple-darwin",
"shell": "bash -euxo pipefail {0}",
"CMAKE_OPTIONS": "-DUSE_GMP=OFF -DLEAN_INSTALL_SUFFIX=-darwin_aarch64",
"llvm-url": "https://github.com/leanprover/lean-llvm/releases/download/15.0.1/lean-llvm-aarch64-apple-darwin.tar.zst https://github.com/leanprover/lean-llvm/releases/download/15.0.1/lean-llvm-x86_64-apple-darwin.tar.zst",
"prepare-llvm": "../script/prepare-llvm-macos.sh lean-llvm-aarch64-* lean-llvm-x86_64-*",
"prepare-llvm": "EXTRA_FLAGS=--target=aarch64-apple-darwin ../script/prepare-llvm-macos.sh lean-llvm-aarch64-* lean-llvm-x86_64-*",
"binary-check": "otool -L",
"tar": "gtar" // https://github.com/actions/runner-images/issues/2619
},
@@ -152,10 +151,9 @@ jobs:
"release": true,
"quick": false,
"cross": true,
"cross_target": "aarch64-unknown-linux-gnu",
"shell": "nix-shell --arg pkgsDist \"import (fetchTarball \\\"channel:nixos-19.03\\\") {{ localSystem.config = \\\"aarch64-unknown-linux-gnu\\\"; }}\" --run \"bash -euxo pipefail {0}\"",
"llvm-url": "https://github.com/leanprover/lean-llvm/releases/download/15.0.1/lean-llvm-x86_64-linux-gnu.tar.zst https://github.com/leanprover/lean-llvm/releases/download/15.0.1/lean-llvm-aarch64-linux-gnu.tar.zst",
"prepare-llvm": "../script/prepare-llvm-linux.sh lean-llvm-aarch64-* lean-llvm-x86_64-*"
"prepare-llvm": "EXTRA_FLAGS=--target=aarch64-unknown-linux-gnu ../script/prepare-llvm-linux.sh lean-llvm-aarch64-* lean-llvm-x86_64-*"
},
{
"name": "Linux 32bit",
@@ -203,8 +201,8 @@ jobs:
git fetch nightly --tags
LEAN_VERSION_STRING="nightly-$(date -u +%F)"
# do nothing if commit already has a different tag
if [[ "$(git name-rev --name-only --tags --no-undefined HEAD 2> /dev/null || echo "$LEAN_VERSION_STRING")" == "$LEAN_VERSION_STRING" ]]; then
echo "nightly=$LEAN_VERSION_STRING" >> "$GITHUB_OUTPUT"
if [[ $(git name-rev --name-only --tags --no-undefined HEAD 2> /dev/null || echo $LEAN_VERSION_STRING) == $LEAN_VERSION_STRING ]]; then
echo "nightly=$LEAN_VERSION_STRING" >> $GITHUB_OUTPUT
fi
fi
@@ -212,7 +210,7 @@ jobs:
if: startsWith(github.ref, 'refs/tags/') && github.repository == 'leanprover/lean4'
id: set-release
run: |
TAG_NAME="${GITHUB_REF##*/}"
TAG_NAME=${GITHUB_REF##*/}
# From https://github.com/fsaintjacques/semver-tool/blob/master/src/semver
@@ -229,13 +227,11 @@ jobs:
if [[ ${TAG_NAME} =~ ${SEMVER_REGEX} ]]; then
echo "Tag ${TAG_NAME} matches SemVer regex, with groups ${BASH_REMATCH[1]} ${BASH_REMATCH[2]} ${BASH_REMATCH[3]} ${BASH_REMATCH[4]}"
{
echo "LEAN_VERSION_MAJOR=${BASH_REMATCH[1]}"
echo "LEAN_VERSION_MINOR=${BASH_REMATCH[2]}"
echo "LEAN_VERSION_PATCH=${BASH_REMATCH[3]}"
echo "LEAN_SPECIAL_VERSION_DESC=${BASH_REMATCH[4]##-}"
echo "RELEASE_TAG=$TAG_NAME"
} >> "$GITHUB_OUTPUT"
echo "LEAN_VERSION_MAJOR=${BASH_REMATCH[1]}" >> $GITHUB_OUTPUT
echo "LEAN_VERSION_MINOR=${BASH_REMATCH[2]}" >> $GITHUB_OUTPUT
echo "LEAN_VERSION_PATCH=${BASH_REMATCH[3]}" >> $GITHUB_OUTPUT
echo "LEAN_SPECIAL_VERSION_DESC=${BASH_REMATCH[4]##-}" >> $GITHUB_OUTPUT
echo "RELEASE_TAG=$TAG_NAME" >> $GITHUB_OUTPUT
else
echo "Tag ${TAG_NAME} did not match SemVer regex."
fi
@@ -323,15 +319,9 @@ jobs:
mkdir build
cd build
ulimit -c unlimited # coredumps
# arguments passed to `cmake`
# this also enables githash embedding into stage 1 library
OPTIONS=(-DCHECK_OLEAN_VERSION=ON)
OPTIONS+=(-DLEAN_EXTRA_MAKE_OPTS=-DwarningAsError=true)
if [[ -n '${{ matrix.cross_target }}' ]]; then
# used by `prepare-llvm`
export EXTRA_FLAGS=--target=${{ matrix.cross_target }}
OPTIONS+=(-DLEAN_PLATFORM_TARGET=${{ matrix.cross_target }})
fi
if [[ -n '${{ matrix.prepare-llvm }}' ]]; then
wget -q ${{ matrix.llvm-url }}
PREPARE="$(${{ matrix.prepare-llvm }})"
@@ -415,7 +405,7 @@ jobs:
- name: CCache stats
run: ccache -s
- name: Show stacktrace for coredumps
if: ${{ failure() && matrix.os == 'ubuntu-latest' }}
if: ${{ failure() }} && matrix.os == 'ubuntu-latest'
run: |
for c in coredumps/*; do
progbin="$(file $c | sed "s/.*execfn: '\([^']*\)'.*/\1/")"
@@ -423,7 +413,7 @@ jobs:
done
- name: Upload coredumps
uses: actions/upload-artifact@v3
if: ${{ failure() && matrix.os == 'ubuntu-latest' }}
if: ${{ failure() }} && matrix.os == 'ubuntu-latest'
with:
name: coredumps-${{ matrix.name }}
path: |
@@ -490,16 +480,16 @@ jobs:
run: |
git remote add nightly https://foo:'${{ secrets.PUSH_NIGHTLY_TOKEN }}'@github.com/${{ github.repository_owner }}/lean4-nightly.git
git fetch nightly --tags
git tag "${{ needs.configure.outputs.nightly }}"
git push nightly "${{ needs.configure.outputs.nightly }}"
git tag ${{ needs.configure.outputs.nightly }}
git push nightly ${{ needs.configure.outputs.nightly }}
git push -f origin refs/tags/${{ needs.configure.outputs.nightly }}:refs/heads/nightly
last_tag="$(git log HEAD^ --simplify-by-decoration --pretty="format:%d" | grep -o "nightly-[-0-9]*" | head -n 1)"
last_tag=$(git log HEAD^ --simplify-by-decoration --pretty="format:%d" | grep -o "nightly-[-0-9]*" | head -n 1)
echo -e "*Changes since ${last_tag}:*\n\n" > diff.md
git show "$last_tag":RELEASES.md > old.md
git show $last_tag:RELEASES.md > old.md
#./script/diff_changelogs.py old.md doc/changes.md >> diff.md
diff --changed-group-format='%>' --unchanged-group-format='' old.md RELEASES.md >> diff.md || true
echo -e "\n*Full commit log*\n" >> diff.md
git log --oneline "$last_tag"..HEAD | sed 's/^/* /' >> diff.md
git log --oneline $last_tag..HEAD | sed 's/^/* /' >> diff.md
- name: Release Nightly
uses: softprops/action-gh-release@v1
with:

View File

@@ -90,14 +90,6 @@ jobs:
# https://github.com/netlify/cli/issues/1809
cp -r --dereference ./result ./dist
if: matrix.name == 'Nix Linux'
- name: Check manual for broken links
id: lychee
uses: lycheeverse/lychee-action@v1.9.0
with:
fail: false # report errors but do not block CI on temporary failures
# gmplib.org consistently times out from GH actions
# the GitHub token is to avoid rate limiting
args: --base './dist' --no-progress --github-token ${{ secrets.GITHUB_TOKEN }} --exclude 'gmplib.org' './dist/**/*.html'
- name: Push to Cachix
run: |
[ -z "${{ secrets.CACHIX_AUTH_TOKEN }}" ] || cachix push -j4 lean4 ./push-* || true
@@ -105,6 +97,13 @@ jobs:
run: |
rm -rf nix-store-cache || true
nix copy ./push-* --to file://$PWD/nix-store-cache?compression=none
- name: Publish manual to GH Pages
uses: peaceiris/actions-gh-pages@v3
with:
github_token: ${{ secrets.GITHUB_TOKEN }}
publish_dir: ./result
destination_dir: ./doc
if: matrix.name == 'Nix Linux' && github.ref == 'refs/heads/master' && github.event_name == 'push'
- id: deploy-info
name: Compute Deployment Metadata
run: |
@@ -113,7 +112,6 @@ jobs:
echo "message=`git log -1 --pretty=format:"%s"`" >> "$GITHUB_OUTPUT"
- name: Publish manual to Netlify
uses: nwtgck/actions-netlify@v2.0
id: publish-manual
with:
publish-dir: ./dist
production-branch: master

View File

@@ -6,10 +6,6 @@
# Instead we use `workflow_run`, which essentially allows us to escalate privileges
# (but only runs the CI as described in the `master` branch, not in the PR branch).
# The main specification/documentation for this workflow is at
# https://leanprover-community.github.io/contribute/tags_and_branches.html
# Keep that in sync!
name: PR release
on:
@@ -41,7 +37,7 @@ jobs:
name: build-.*
name_is_regexp: true
- name: Push tag
- name: Push branch and tag
if: ${{ steps.workflow-info.outputs.pullRequestNumber != '' }}
run: |
git init --bare lean4.git
@@ -73,20 +69,6 @@ jobs:
# The token used here must have `workflow` privileges.
GITHUB_TOKEN: ${{ secrets.PR_RELEASES_TOKEN }}
- name: Report release status
if: ${{ steps.workflow-info.outputs.pullRequestNumber != '' }}
uses: actions/github-script@v6
with:
script: |
await github.rest.repos.createCommitStatus({
owner: context.repo.owner,
repo: context.repo.repo,
sha: "${{ steps.workflow-info.outputs.sourceHeadSha }}",
state: "success",
context: "PR toolchain",
description: "${{ github.repository_owner }}/lean4-pr-releases:pr-release-${{ steps.workflow-info.outputs.pullRequestNumber }}",
});
- name: Add label
if: ${{ steps.workflow-info.outputs.pullRequestNumber != '' }}
uses: actions/github-script@v7
@@ -107,7 +89,7 @@ jobs:
git -C lean4.git remote add nightly https://github.com/leanprover/lean4-nightly.git
git -C lean4.git fetch nightly '+refs/tags/nightly-*:refs/tags/nightly-*'
git -C lean4.git tag --merged "${{ steps.workflow-info.outputs.sourceHeadSha }}" --list "nightly-*" \
| sort -rV | head -n 1 | sed "s/^nightly-*/MOST_RECENT_NIGHTLY=/" | tee -a "$GITHUB_ENV"
| sort -rV | head -n 1 | sed "s/^nightly-*/MOST_RECENT_NIGHTLY=/" | tee -a $GITHUB_ENV
- name: 'Setup jq'
if: ${{ steps.workflow-info.outputs.pullRequestNumber != '' }}
@@ -118,32 +100,22 @@ jobs:
if: ${{ steps.workflow-info.outputs.pullRequestNumber != '' }}
id: ready
run: |
echo "Most recent nightly release in your branch: $MOST_RECENT_NIGHTLY"
echo "Most recent nightly in your branch: $MOST_RECENT_NIGHTLY"
NIGHTLY_SHA=$(git -C lean4.git rev-parse "nightly-$MOST_RECENT_NIGHTLY^{commit}")
echo "SHA of most recent nightly release: $NIGHTLY_SHA"
echo "SHA of most recent nightly: $NIGHTLY_SHA"
MERGE_BASE_SHA=$(git -C lean4.git merge-base origin/master "${{ steps.workflow-info.outputs.sourceHeadSha }}")
echo "SHA of merge-base: $MERGE_BASE_SHA"
if [ "$NIGHTLY_SHA" = "$MERGE_BASE_SHA" ]; then
echo "The merge base of this PR coincides with the nightly release"
echo "Most recent nightly tag agrees with the merge base."
MATHLIB_REMOTE_TAGS="$(git ls-remote https://github.com/leanprover-community/mathlib4.git nightly-testing-"$MOST_RECENT_NIGHTLY")"
REMOTE_BRANCHES=$(git ls-remote -h https://github.com/leanprover-community/mathlib4.git nightly-testing-$MOST_RECENT_NIGHTLY)
if [[ -n "$MATHLIB_REMOTE_TAGS" ]]; then
echo "... and Mathlib has a 'nightly-testing-$MOST_RECENT_NIGHTLY' tag."
if [[ -n "$REMOTE_BRANCHES" ]]; then
echo "... and Mathlib has a 'nightly-testing-$MOST_RECENT_NIGHTLY' branch."
MESSAGE=""
else
echo "... but Mathlib does not yet have a 'nightly-testing-$MOST_RECENT_NIGHTLY' tag."
MESSAGE="- ❗ Mathlib CI can not be attempted yet, as the \`nightly-testing-$MOST_RECENT_NIGHTLY\` tag does not exist there yet. We will retry when you push more commits. If you rebase your branch onto \`nightly-with-mathlib\`, Mathlib CI should run now."
fi
STD_REMOTE_TAGS="$(git ls-remote https://github.com/leanprover/std4.git nightly-testing-"$MOST_RECENT_NIGHTLY")"
if [[ -n "$STD_REMOTE_TAGS" ]]; then
echo "... and Std has a 'nightly-testing-$MOST_RECENT_NIGHTLY' tag."
MESSAGE=""
else
echo "... but Std does not yet have a 'nightly-testing-$MOST_RECENT_NIGHTLY' tag."
MESSAGE="- ❗ Std CI can not be attempted yet, as the \`nightly-testing-$MOST_RECENT_NIGHTLY\` tag does not exist there yet. We will retry when you push more commits. If you rebase your branch onto \`nightly-with-mathlib\`, Std CI should run now."
echo "... but Mathlib does not yet have a 'nightly-testing-$MOST_RECENT_NIGHTLY' branch."
MESSAGE="- ❗ Mathlib CI can not be attempted yet, as the 'nightly-testing-$MOST_RECENT_NIGHTLY' branch does not exist there yet. We will retry when you push more commits. It may be necessary to rebase onto 'nightly' tomorrow."
fi
else
@@ -151,24 +123,20 @@ jobs:
echo "but 'git merge-base origin/master HEAD' reported: $MERGE_BASE_SHA"
git -C lean4.git log -10 origin/master
MESSAGE="- ❗ Std/Mathlib CI will not be attempted unless your PR branches off the \`nightly-with-mathlib\` branch."
MESSAGE="- ❗ Mathlib CI will not be attempted unless you rebase your PR onto the 'nightly' branch."
fi
if [[ -n "$MESSAGE" ]]; then
echo "Checking existing messages"
# The code for updating comments is duplicated in mathlib's
# scripts/lean-pr-testing-comments.sh
# so keep in sync
# Use GitHub API to check if a comment already exists
existing_comment="$(curl -L -s -H "Authorization: token ${{ secrets.MATHLIB4_BOT }}" \
existing_comment=$(curl -L -s -H "Authorization: token ${{ secrets.MATHLIB4_BOT }}" \
-H "Accept: application/vnd.github.v3+json" \
"https://api.github.com/repos/leanprover/lean4/issues/${{ steps.workflow-info.outputs.pullRequestNumber }}/comments" \
| jq 'first(.[] | select(.body | test("^- . Mathlib") or startswith("Mathlib CI status")) | select(.user.login == "leanprover-community-mathlib4-bot"))')"
existing_comment_id="$(echo "$existing_comment" | jq -r .id)"
existing_comment_body="$(echo "$existing_comment" | jq -r .body)"
| jq '.[] | select(.body | startswith("- Mathlib") or startswith("- ✅ Mathlib") or startswith("- ❌ Mathlib") or startswith("- 💥 Mathlib") or startswith("- 🟡 Mathlib"))')
existing_comment_id=$(echo "$existing_comment" | jq -r .id)
existing_comment_body=$(echo "$existing_comment" | jq -r .body)
if [[ "$existing_comment_body" != *"$MESSAGE"* ]]; then
MESSAGE="$MESSAGE ($(date "+%Y-%m-%d %H:%M:%S"))"
@@ -178,14 +146,13 @@ jobs:
# Append new result to the existing comment or post a new comment
# It's essential we use the MATHLIB4_BOT token here, so that Mathlib CI can subsequently edit the comment.
if [ -z "$existing_comment_id" ]; then
INTRO="Mathlib CI status ([docs](https://leanprover-community.github.io/contribute/tags_and_branches.html)):"
# Post new comment with a bullet point
echo "Posting as new comment at leanprover/lean4/issues/${{ steps.workflow-info.outputs.pullRequestNumber }}/comments"
curl -L -s \
-X POST \
-H "Authorization: token ${{ secrets.MATHLIB4_BOT }}" \
-H "Accept: application/vnd.github.v3+json" \
-d "$(jq --null-input --arg intro "$INTRO" --arg val "$MESSAGE" '{"body":($intro + "\n" + $val)}')" \
-d "$(jq --null-input --arg val "$MESSAGE" '{"body": $val}')" \
"https://api.github.com/repos/leanprover/lean4/issues/${{ steps.workflow-info.outputs.pullRequestNumber }}/comments"
else
# Append new result to the existing comment
@@ -200,93 +167,18 @@ jobs:
else
echo "The message already exists in the comment body."
fi
echo "mathlib_ready=false" >> "$GITHUB_OUTPUT"
echo "mathlib_ready=false" >> $GITHUB_OUTPUT
else
echo "mathlib_ready=true" >> "$GITHUB_OUTPUT"
echo "mathlib_ready=true" >> $GITHUB_OUTPUT
fi
- name: Report mathlib base
if: ${{ steps.workflow-info.outputs.pullRequestNumber != '' && steps.ready.outputs.mathlib_ready == 'true' }}
uses: actions/github-script@v6
with:
script: |
const description =
process.env.MOST_RECENT_NIGHTLY ?
"nightly-" + process.env.MOST_RECENT_NIGHTLY :
"not branched off nightly";
await github.rest.repos.createCommitStatus({
owner: context.repo.owner,
repo: context.repo.repo,
sha: "${{ steps.workflow-info.outputs.sourceHeadSha }}",
state: "success",
context: "PR branched off:",
description: description,
});
# We next automatically create a Std branch using this toolchain.
# Std doesn't itself have a mechanism to report results of CI from this branch back to Lean
# Instead this is taken care of by Mathlib CI, which will fail if Std fails.
- name: Cleanup workspace
if: steps.workflow-info.outputs.pullRequestNumber != '' && steps.ready.outputs.mathlib_ready == 'true'
run: |
sudo rm -rf ./*
# Checkout the Std repository with all branches
- name: Checkout Std repository
if: steps.workflow-info.outputs.pullRequestNumber != '' && steps.ready.outputs.mathlib_ready == 'true'
uses: actions/checkout@v3
with:
repository: leanprover/std4
token: ${{ secrets.MATHLIB4_BOT }}
ref: nightly-testing
fetch-depth: 0 # This ensures we check out all tags and branches.
- name: Check if tag exists
if: steps.workflow-info.outputs.pullRequestNumber != '' && steps.ready.outputs.mathlib_ready == 'true'
id: check_std_tag
run: |
git config user.name "leanprover-community-mathlib4-bot"
git config user.email "leanprover-community-mathlib4-bot@users.noreply.github.com"
if git ls-remote --heads --tags --exit-code origin "nightly-testing-${MOST_RECENT_NIGHTLY}" >/dev/null; then
BASE="nightly-testing-${MOST_RECENT_NIGHTLY}"
else
echo "This shouldn't be possible: couldn't find a 'nightly-testing-${MOST_RECENT_NIGHTLY}' tag at Std. Falling back to 'nightly-testing'."
BASE=nightly-testing
fi
echo "Using base branch: $BASE"
EXISTS="$(git ls-remote --heads origin lean-pr-testing-${{ steps.workflow-info.outputs.pullRequestNumber }} | wc -l)"
echo "Branch exists: $EXISTS"
if [ "$EXISTS" = "0" ]; then
echo "Branch does not exist, creating it."
git switch -c lean-pr-testing-${{ steps.workflow-info.outputs.pullRequestNumber }} "$BASE"
echo "leanprover/lean4-pr-releases:pr-release-${{ steps.workflow-info.outputs.pullRequestNumber }}" > lean-toolchain
git add lean-toolchain
git commit -m "Update lean-toolchain for testing https://github.com/leanprover/lean4/pull/${{ steps.workflow-info.outputs.pullRequestNumber }}"
else
echo "Branch already exists, pushing an empty commit."
git switch lean-pr-testing-${{ steps.workflow-info.outputs.pullRequestNumber }}
# The Std `nightly-testing` or `nightly-testing-YYYY-MM-DD` branch may have moved since this branch was created, so merge their changes.
# (This should no longer be possible once `nightly-testing-YYYY-MM-DD` is a tag, but it is still safe to merge.)
git merge "$BASE" --strategy-option ours --no-commit --allow-unrelated-histories
git commit --allow-empty -m "Trigger CI for https://github.com/leanprover/lean4/pull/${{ steps.workflow-info.outputs.pullRequestNumber }}"
fi
- name: Push changes
if: steps.workflow-info.outputs.pullRequestNumber != '' && steps.ready.outputs.mathlib_ready == 'true'
run: |
git push origin lean-pr-testing-${{ steps.workflow-info.outputs.pullRequestNumber }}
# We next automatically create a Mathlib branch using this toolchain.
# Mathlib CI will be responsible for reporting back success or failure
# to the PR comments asynchronously.
- name: Cleanup workspace
if: steps.workflow-info.outputs.pullRequestNumber != '' && steps.ready.outputs.mathlib_ready == 'true'
run: |
sudo rm -rf ./*
sudo rm -rf *
# Checkout the mathlib4 repository with all branches
- name: Checkout mathlib4 repository
@@ -298,38 +190,37 @@ jobs:
ref: nightly-testing
fetch-depth: 0 # This ensures we check out all tags and branches.
- name: Check if tag exists
- name: Check if branch exists
if: steps.workflow-info.outputs.pullRequestNumber != '' && steps.ready.outputs.mathlib_ready == 'true'
id: check_mathlib_tag
id: check_branch
run: |
git config user.name "leanprover-community-mathlib4-bot"
git config user.email "leanprover-community-mathlib4-bot@users.noreply.github.com"
if git ls-remote --heads --tags --exit-code origin "nightly-testing-${MOST_RECENT_NIGHTLY}" >/dev/null; then
BASE="nightly-testing-${MOST_RECENT_NIGHTLY}"
if git branch -r | grep -q "nightly-testing-${MOST_RECENT_NIGHTLY}"; then
BASE=nightly-testing-${MOST_RECENT_NIGHTLY}
else
echo "This shouldn't be possible: couldn't find a 'nightly-testing-${MOST_RECENT_NIGHTLY}' branch at Mathlib. Falling back to 'nightly-testing'."
BASE=nightly-testing
fi
echo "Using base tag: $BASE"
echo "Using base branch: $BASE"
EXISTS="$(git ls-remote --heads origin lean-pr-testing-${{ steps.workflow-info.outputs.pullRequestNumber }} | wc -l)"
git checkout $BASE
EXISTS=$(git ls-remote --heads origin lean-pr-testing-${{ steps.workflow-info.outputs.pullRequestNumber }} | wc -l)
echo "Branch exists: $EXISTS"
if [ "$EXISTS" = "0" ]; then
echo "Branch does not exist, creating it."
git switch -c lean-pr-testing-${{ steps.workflow-info.outputs.pullRequestNumber }} "$BASE"
git checkout -b lean-pr-testing-${{ steps.workflow-info.outputs.pullRequestNumber }}
echo "leanprover/lean4-pr-releases:pr-release-${{ steps.workflow-info.outputs.pullRequestNumber }}" > lean-toolchain
git add lean-toolchain
sed -i "s/require std from git \"https:\/\/github.com\/leanprover\/std4\" @ \".\+\"/require std from git \"https:\/\/github.com\/leanprover\/std4\" @ \"nightly-testing-${MOST_RECENT_NIGHTLY}\"/" lakefile.lean
git add lakefile.lean
git commit -m "Update lean-toolchain for testing https://github.com/leanprover/lean4/pull/${{ steps.workflow-info.outputs.pullRequestNumber }}"
else
echo "Branch already exists, pushing an empty commit."
git switch lean-pr-testing-${{ steps.workflow-info.outputs.pullRequestNumber }}
# The Mathlib `nightly-testing` branch or `nightly-testing-YYYY-MM-DD` tag may have moved since this branch was created, so merge their changes.
# (This should no longer be possible once `nightly-testing-YYYY-MM-DD` is a tag, but it is still safe to merge.)
git merge "$BASE" --strategy-option ours --no-commit --allow-unrelated-histories
git checkout lean-pr-testing-${{ steps.workflow-info.outputs.pullRequestNumber }}
# The Mathlib `nightly-testing` or `nightly-testing-YYYY-MM-DD` branch may have moved since this branch was created, so merge their changes.
git merge $BASE --strategy-option ours --no-commit --allow-unrelated-histories
git commit --allow-empty -m "Trigger CI for https://github.com/leanprover/lean4/pull/${{ steps.workflow-info.outputs.pullRequestNumber }}"
fi

View File

@@ -1,8 +1,13 @@
This is the repository for **Lean 4**.
We provide [nightly releases](https://github.com/leanprover/lean4-nightly/releases)
and have just begun regular [stable point releases](https://github.com/leanprover/lean4/releases).
# About
- [Quickstart](https://lean-lang.org/lean4/doc/quickstart.html)
- [Quickstart](https://github.com/leanprover/lean4/blob/master/doc/quickstart.md)
- [Walkthrough installation video](https://www.youtube.com/watch?v=yZo6k48L0VY)
- [Quick tour video](https://youtu.be/zyXtbb_eYbY)
- [Homepage](https://lean-lang.org)
- [Theorem Proving Tutorial](https://lean-lang.org/theorem_proving_in_lean4/)
- [Functional Programming in Lean](https://lean-lang.org/functional_programming_in_lean/)

View File

@@ -8,10 +8,7 @@ This file contains work-in-progress notes for the upcoming release, as well as p
Please check the [releases](https://github.com/leanprover/lean4/releases) page for the current status
of each version.
v4.7.0 (development in progress)
---------
v4.6.0
v4.6.0 (development in progress)
---------
* Add custom simplification procedures (aka `simproc`s) to `simp`. Simprocs can be triggered by the simplifier on a specified term-pattern. Here is an small example:
@@ -25,25 +22,20 @@ def foo (x : Nat) : Nat :=
The `simproc` `reduceFoo` is invoked on terms that match the pattern `foo _`.
-/
simproc reduceFoo (foo _) :=
/- A term of type `Expr → SimpM Step -/
fun e => do
/- A term of type `Expr → SimpM (Option Step) -/
fun e => OptionT.run do
/- `simp` uses matching modulo reducibility. So, we ensure the term is a `foo`-application. -/
guard (e.isAppOfArity ``foo 1)
/- `Nat.fromExpr?` tries to convert an expression into a `Nat` value -/
let n Nat.fromExpr? e.appArg!
/-
The `Step` type has three constructors: `.done`, `.visit`, `.continue`.
The `Step` type has two constructors: `.done` and `.visit`.
* The constructor `.done` instructs `simp` that the result does
not need to be simplied further.
* The constructor `.visit` instructs `simp` to visit the resulting expression.
* The constructor `.continue` instructs `simp` to try other simplification procedures.
All three constructors take a `Result`. The `.continue` contructor may also take `none`.
`Result` has two fields `expr` (the new expression), and `proof?` (an optional proof).
If the new expression is definitionally equal to the input one, then `proof?` can be omitted or set to `none`.
If the result holds definitionally as in this example, the field `proof?` can be omitted.
-/
/- `simp` uses matching modulo reducibility. So, we ensure the term is a `foo`-application. -/
unless e.isAppOfArity ``foo 1 do
return .continue
/- `Nat.fromExpr?` tries to convert an expression into a `Nat` value -/
let some n Nat.fromExpr? e.appArg!
| return .continue
return .done { expr := Lean.mkNatLit (n+10) }
```
We disable simprocs support by using the command `set_option simprocs false`. This command is particularly useful when porting files to v4.6.0.
@@ -51,7 +43,7 @@ Simprocs can be scoped, manually added to `simp` commands, and suppressed using
```lean
example : x + foo 2 = 12 + x := by
set_option simprocs false in
/- This `simp` command does not make progress since `simproc`s are disabled. -/
/- This `simp` command does make progress since `simproc`s are disabled. -/
fail_if_success simp
simp_arith
@@ -72,175 +64,7 @@ example : x + foo 2 = 12 + x := by
fail_if_success simp [-reduceFoo]
simp_arith
```
The command `register_simp_attr <id>` now creates a `simp` **and** a `simproc` set with the name `<id>`. The following command instructs Lean to insert the `reduceFoo` simplification procedure into the set `my_simp`. If no set is specified, Lean uses the default `simp` set.
```lean
simproc [my_simp] reduceFoo (foo _) := ...
```
* The syntax of the `termination_by` and `decreasing_by` termination hints is overhauled:
* They are now placed directly after the function they apply to, instead of
after the whole `mutual` block.
* Therefore, the function name no longer has to be mentioned in the hint.
* If the function has a `where` clause, the `termination_by` and
`decreasing_by` for that function come before the `where`. The
functions in the `where` clause can have their own termination hints, each
following the corresponding definition.
* The `termination_by` clause can only bind “extra parameters”, that are not
already bound by the function header, but are bound in a lambda (`:= fun x
y z =>`) or in patterns (`| x, n + 1 => …`). These extra parameters used to
be understood as a suffix of the function parameters; now it is a prefix.
Migration guide: In simple cases just remove the function name, and any
variables already bound at the header.
```diff
def foo : Nat → Nat → Nat := …
-termination_by foo a b => a - b
+termination_by a b => a - b
```
or
```diff
def foo : Nat → Nat → Nat := …
-termination_by _ a b => a - b
+termination_by a b => a - b
```
If the parameters are bound in the function header (before the `:`), remove them as well:
```diff
def foo (a b : Nat) : Nat := …
-termination_by foo a b => a - b
+termination_by a - b
```
Else, if there are multiple extra parameters, make sure to refer to the right
ones; the bound variables are interpreted from left to right, no longer from
right to left:
```diff
def foo : Nat → Nat → Nat → Nat
| a, b, c => …
-termination_by foo b c => b
+termination_by a b => b
```
In the case of a `mutual` block, place the termination arguments (without the
function name) next to the function definition:
```diff
-mutual
-def foo : Nat → Nat → Nat := …
-def bar : Nat → Nat := …
-end
-termination_by
- foo a b => a - b
- bar a => a
+mutual
+def foo : Nat → Nat → Nat := …
+termination_by a b => a - b
+def bar : Nat → Nat := …
+termination_by a => a
+end
```
Similarly, if you have (mutual) recursion through `where` or `let rec`, the
termination hints are now placed directly after the function they apply to:
```diff
-def foo (a b : Nat) : Nat := …
- where bar (x : Nat) : Nat := …
-termination_by
- foo a b => a - b
- bar x => x
+def foo (a b : Nat) : Nat := …
+termination_by a - b
+ where
+ bar (x : Nat) : Nat := …
+ termination_by x
-def foo (a b : Nat) : Nat :=
- let rec bar (x : Nat) : Nat := …
- …
-termination_by
- foo a b => a - b
- bar x => x
+def foo (a b : Nat) : Nat :=
+ let rec bar (x : Nat) : Nat := …
+ termination_by x
+ …
+termination_by a - b
```
In cases where a single `decreasing_by` clause applied to multiple mutually
recursive functions before, the tactic now has to be duplicated.
* The semantics of `decreasing_by` changed; the tactic is applied to all
termination proof goals together, not individually.
This helps when writing termination proofs interactively, as one can focus
each subgoal individually, for example using `·`. Previously, the given
tactic script had to work for _all_ goals, and one had to resort to tactic
combinators like `first`:
```diff
def foo (n : Nat) := … foo e1 … foo e2 …
-decreasing_by
-simp_wf
-first | apply something_about_e1; …
- | apply something_about_e2; …
+decreasing_by
+all_goals simp_wf
+· apply something_about_e1; …
+· apply something_about_e2; …
```
To obtain the old behaviour of applying a tactic to each goal individually,
use `all_goals`:
```diff
def foo (n : Nat) := …
-decreasing_by some_tactic
+decreasing_by all_goals some_tactic
```
In the case of mutual recursion each `decreasing_by` now applies to just its
function. If some functions in a recursive group do not have their own
`decreasing_by`, the default `decreasing_tactic` is used. If the same tactic
ought to be applied to multiple functions, the `decreasing_by` clause has to
be repeated at each of these functions.
* Modify `InfoTree.context` to facilitate augmenting it with partial contexts while elaborating a command. This breaks backwards compatibility with all downstream projects that traverse the `InfoTree` manually instead of going through the functions in `InfoUtils.lean`, as well as those manually creating and saving `InfoTree`s. See [PR #3159](https://github.com/leanprover/lean4/pull/3159) for how to migrate your code.
* Add language server support for [call hierarchy requests](https://www.youtube.com/watch?v=r5LA7ivUb2c) ([PR #3082](https://github.com/leanprover/lean4/pull/3082)). The change to the .ilean format in this PR means that projects must be fully rebuilt once in order to generate .ilean files with the new format before features like "find references" work correctly again.
* Structure instances with multiple sources (for example `{a, b, c with x := 0}`) now have their fields filled from these sources
in strict left-to-right order. Furthermore, the structure instance elaborator now aggressively use sources to fill in subobject
fields, which prevents unnecessary eta expansion of the sources,
and hence greatly reduces the reliance on costly structure eta reduction. This has a large impact on mathlib,
reducing total CPU instructions by 3% and enabling impactful refactors like leanprover-community/mathlib4#8386
which reduces the build time by almost 20%.
See PR [#2478](https://github.com/leanprover/lean4/pull/2478) and RFC [#2451](https://github.com/leanprover/lean4/issues/2451).
* Add pretty printer settings to omit deeply nested terms (`pp.deepTerms false` and `pp.deepTerms.threshold`) ([PR #3201](https://github.com/leanprover/lean4/pull/3201))
* Add pretty printer options `pp.numeralTypes` and `pp.natLit`.
When `pp.numeralTypes` is true, then natural number literals, integer literals, and rational number literals
are pretty printed with type ascriptions, such as `(2 : Rat)`, `(-2 : Rat)`, and `(-2 / 3 : Rat)`.
When `pp.natLit` is true, then raw natural number literals are pretty printed as `nat_lit 2`.
[PR #2933](https://github.com/leanprover/lean4/pull/2933) and [RFC #3021](https://github.com/leanprover/lean4/issues/3021).
Lake updates:
* improved platform information & control [#3226](https://github.com/leanprover/lean4/pull/3226)
* `lake update` from unsupported manifest versions [#3149](https://github.com/leanprover/lean4/pull/3149)
Other improvements:
* make `intro` be aware of `let_fun` [#3115](https://github.com/leanprover/lean4/pull/3115)
* produce simpler proof terms in `rw` [#3121](https://github.com/leanprover/lean4/pull/3121)
* fuse nested `mkCongrArg` calls in proofs generated by `simp` [#3203](https://github.com/leanprover/lean4/pull/3203)
* `induction using` followed by a general term [#3188](https://github.com/leanprover/lean4/pull/3188)
* allow generalization in `let` [#3060](https://github.com/leanprover/lean4/pull/3060, fixing [#3065](https://github.com/leanprover/lean4/issues/3065)
* reducing out-of-bounds `swap!` should return `a`, not `default`` [#3197](https://github.com/leanprover/lean4/pull/3197), fixing [#3196](https://github.com/leanprover/lean4/issues/3196)
* derive `BEq` on structure with `Prop`-fields [#3191](https://github.com/leanprover/lean4/pull/3191), fixing [#3140](https://github.com/leanprover/lean4/issues/3140)
* refine through more `casesOnApp`/`matcherApp` [#3176](https://github.com/leanprover/lean4/pull/3176), fixing [#3175](https://github.com/leanprover/lean4/pull/3175)
* do not strip dotted components from lean module names [#2994](https://github.com/leanprover/lean4/pull/2994), fixing [#2999](https://github.com/leanprover/lean4/issues/2999)
* fix `deriving` only deriving the first declaration for some handlers [#3058](https://github.com/leanprover/lean4/pull/3058), fixing [#3057](https://github.com/leanprover/lean4/issues/3057)
* do not instantiate metavariables in kabstract/rw for disallowed occurrences [#2539](https://github.com/leanprover/lean4/pull/2539), fixing [#2538](https://github.com/leanprover/lean4/issues/2538)
* hover info for `cases h : ...` [#3084](https://github.com/leanprover/lean4/pull/3084)
v4.5.0
---------
@@ -264,7 +88,7 @@ v4.5.0
Migration guide: Use `termination_by` instead, e.g.:
```diff
-termination_by' measure (fun ⟨i, _⟩ => as.size - i)
+termination_by i _ => as.size - i
+termination_by go i _ => as.size - i
```
If the well-founded relation you want to use is not the one that the
@@ -272,7 +96,7 @@ v4.5.0
you can use `WellFounded.wrap` from the std libarary to explicitly give one:
```diff
-termination_by' ⟨r, hwf⟩
+termination_by x => hwf.wrap x
+termination_by _ x => hwf.wrap x
```
* Support snippet edits in LSP `TextEdit`s. See `Lean.Lsp.SnippetString` for more details.

View File

@@ -483,43 +483,7 @@ def baz : Char → Nat
| _ => 3
```
The case where patterns are matched against an argument whose type is an inductive family is known as *dependent pattern matching*. This is more complicated, because the type of the function being defined can impose constraints on the patterns that are matched. In this case, the equation compiler will detect inconsistent cases and rule them out.
```lean
universe u
inductive Vector (α : Type u) : Nat → Type u
| nil : Vector α 0
| cons : α → Vector α n → Vector α (n+1)
namespace Vector
def head : Vector α (n+1) → α
| cons h t => h
def tail : Vector α (n+1) → Vector α n
| cons h t => t
def map (f : α → β → γ) : Vector α n → Vector β n → Vector γ n
| nil, nil => nil
| cons a va, cons b vb => cons (f a b) (map f va vb)
end Vector
```
.. _recursive_functions:
Recursive functions
===================
Lean must ensure that a recursive function terminates, for which there are two strategies: _structural recursion_, in which all recursive calls are made on smaller parts of the input data, and _well-founded recursion_, in which recursive calls are justified by showing that arguments to recursive calls are smaller according to some other measure.
Structural recursion
--------------------
If the definition of a function contains recursive calls, Lean first tries to interpret the definition as a structural recursion. In order for that to succeed, the recursive arguments must be subterms of the corresponding arguments on the left-hand side.
The function is then defined using a *course of values* recursion, using automatically generated functions ``below`` and ``brec`` in the namespace corresponding to the inductive type of the recursive argument. In this case the defining equations hold definitionally, possibly with additional case splits.
If any of the terms ``tᵢ`` in the template above contain a recursive call to ``foo``, the equation compiler tries to interpret the definition as a structural recursion. In order for that to succeed, the recursive arguments must be subterms of the corresponding arguments on the left-hand side. The function is then defined using a *course of values* recursion, using automatically generated functions ``below`` and ``brec`` in the namespace corresponding to the inductive type of the recursive argument. In this case the defining equations hold definitionally, possibly with additional case splits.
```lean
namespace Hide
@@ -540,12 +504,7 @@ example : append [(1 : Nat), 2, 3] [4, 5] = [1, 2, 3, 4, 5] => rfl
end Hide
```
Well-founded recursion
---------------------
If structural recursion fails, the equation compiler falls back on well-founded recursion. It tries to infer an instance of ``SizeOf`` for the type of each argument, and then tries to find a permutation of the arguments such that each recursive call is decreasing under the lexicographic order with respect to ``sizeOf`` measures. Lean uses information in the local context, so you can often provide the relevant proof manually using ``have`` in the body of the definition.
In the case of well-founded recursion, the equation used to declare the function holds only propositionally, but not definitionally, and can be accessed using ``unfold``, ``simp`` and ``rewrite`` with the function name (for example ``unfold foo`` or ``simp [foo]``, where ``foo`` is the function defined with well-founded recursion).
If structural recursion fails, the equation compiler falls back on well-founded recursion. It tries to infer an instance of ``SizeOf`` for the type of each argument, and then show that each recursive call is decreasing under the lexicographic order of the arguments with respect to ``sizeOf`` measure. If it fails, the error message provides information as to the goal that Lean tried to prove. Lean uses information in the local context, so you can often provide the relevant proof manually using ``have`` in the body of the definition. In this case of well-founded recursion, the defining equations hold only propositionally, and can be accessed using ``simp`` and ``rewrite`` with the name ``foo``.
```lean
namespace Hide
@@ -569,53 +528,9 @@ by rw [div]; rfl
end Hide
```
If Lean cannot find a permutation of the arguments for which all recursive calls are decreasing, it will print a table that contains, for every recursive call, which arguments Lean could prove to be decreasing. For example, a function with three recursive calls and four parameters might cause the following message to be printed
```
example.lean:37:0-43:31: error: Could not find a decreasing measure.
The arguments relate at each recursive call as follows:
(<, ≤, =: relation proved, ? all proofs failed, _: no proof attempted)
x1 x2 x3 x4
1) 39:6-27 = = _ =
2) 40:6-25 = ? _ <
3) 41:6-25 < _ _ _
Please use `termination_by` to specify a decreasing measure.
```
This table should be read as follows:
* In the first recursive call, in line 39, arguments 1, 2 and 4 are equal to the function's parameters.
* The second recursive call, in line 40, has an equal first argument, a smaller fourth argument, and nothing could be inferred for the second argument.
* The third recursive call, in line 41, has a decreasing first argument.
* No other proofs were attempted, either because the parameter has a type without a non-trivial ``WellFounded`` instance (parameter 3), or because it is already clear that no decreasing measure can be found.
Lean will print the termination argument it found if ``set_option showInferredTerminationBy true`` is set.
If Lean does not find the termination argument, or if you want to be explicit, you can append a `termination_by` clause to the function definition, after the function's body, but before the `where` clause if present. It is of the form
```
termination_by e
```
where ``e`` is an expression that depends on the parameters of the function and should be decreasing at each recursive call. The type of `e` should be an instance of the class ``WellFoundedRelation``, which determines how to compare two values of that type.
If ``f`` has parameters “after the ``:``” (for example when defining functions via patterns using `|`), then these can be brought into scope using the syntax
```
termination_by a₁ … aₙ => e
```
By default, Lean uses the tactic ``decreasing_tactic`` when proving that an argument is decreasing; see its documentation for how to globally extend it. You can also choose to use a different tactic for a given function definition with the clause
```
decreasing_by <tac>
```
which should come after ``termination_by`, if present.
Note that recursive definitions can in general require nested recursions, that is, recursion on different arguments of ``foo`` in the template above. The equation compiler handles this by abstracting later arguments, and recursively defining higher-order functions to meet the specification.
Mutual recursion
----------------
The equation compiler also allows mutual recursive definitions, with a syntax similar to that of [Mutual and Nested Inductive Definitions](#mutual-and-nested-inductive-definitions). Mutual definitions are always compiled using well-founded recursion, and so once again the defining equations hold only propositionally.
The equation compiler also allows mutual recursive definitions, with a syntax similar to that of [Mutual and Nested Inductive Definitions](#mutual-and-nested-inductive-definitions). They are compiled using well-founded recursion, and so once again the defining equations hold only propositionally.
```lean
mutual
@@ -672,31 +587,29 @@ def num_consts_lst : List Term → Nat
end
```
In a set of mutually recursive function, either all or no functions must have an explicit termination argument (``termination_by``). A change of the default termination tactic (``decreasing_by``) only affects the proofs about the recursive calls of that function, not the other functions in the group.
The case where patterns are matched against an argument whose type is an inductive family is known as *dependent pattern matching*. This is more complicated, because the type of the function being defined can impose constraints on the patterns that are matched. In this case, the equation compiler will detect inconsistent cases and rule them out.
```
mutual
theorem even_of_odd_succ : ∀ n, Odd (n + 1) → Even n
| _, odd_succ n h => h
termination_by n h => h
decreasing_by decreasing_tactic
```lean
universe u
theorem odd_of_even_succ : ∀ n, Even (n + 1) → Odd n
| _, even_succ n h => h
termination_by n h => h
end
```
inductive Vector (α : Type u) : Nat → Type u
| nil : Vector α 0
| cons : α → Vector α n → Vector α (n+1)
Another way to express mutual recursion is using local function definitions in ``where`` or ``let rec`` clauses: these can be mutually recursive with each other and their containing function:
namespace Vector
```
theorem even_of_odd_succ : ∀ n, Odd (n + 1) → Even n
| _, odd_succ n h => h
termination_by n h => h
where
theorem odd_of_even_succ : ∀ n, Even (n + 1) → Odd n
| _, even_succ n h => h
termination_by n h => h
def head {α : Type} : Vector α (n+1) → α
| cons h t => h
def tail {α : Type} : Vector α (n+1) → Vector α n
| cons h t => t
def map {α β γ : Type} (f : α → β → γ) :
∀ {n}, Vector α n → Vector β n → Vector γ n
| 0, nil, nil => nil
| n+1, cons a va, cons b vb => cons (f a b) (map f va vb)
end Vector
```
.. _match_expressions:

View File

@@ -121,4 +121,4 @@ Thus to e.g. run `#eval` on such a declaration, you need to
Note that it is not sufficient to load the foreign library containing the external symbol because the interpreter depends on code that is emitted for each `@[extern]` declaration.
Thus it is not possible to interpret an `@[extern]` declaration in the same file.
See [`tests/compiler/foreign`](https://github.com/leanprover/lean4/tree/master/tests/compiler/foreign/) for an example.
See `tests/compiler/foreign` for an example.

View File

@@ -41,17 +41,17 @@ information is displayed. This option will show all test output.
All these tests are included by [src/shell/CMakeLists.txt](https://github.com/leanprover/lean4/blob/master/src/shell/CMakeLists.txt):
- [`tests/lean`](https://github.com/leanprover/lean4/tree/master/tests/lean/): contains tests that come equipped with a
.lean.expected.out file. The driver script [`test_single.sh`](https://github.com/leanprover/lean4/tree/master/tests/lean/test_single.sh) runs
- `tests/lean`: contains tests that come equipped with a
.lean.expected.out file. The driver script `test_single.sh` runs
each test and checks the actual output (*.produced.out) with the
checked in expected output.
- [`tests/lean/run`](https://github.com/leanprover/lean4/tree/master/tests/lean/run/): contains tests that are run through the lean
- `tests/lean/run`: contains tests that are run through the lean
command line one file at a time. These tests only look for error
codes and do not check the expected output even though output is
produced, it is ignored.
- [`tests/lean/interactive`](https://github.com/leanprover/lean4/tree/master/tests/lean/interactive/): are designed to test server requests at a
- `tests/lean/interactive`: are designed to test server requests at a
given position in the input file. Each .lean file contains comments
that indicate how to simulate a client request at that position.
using a `--^` point to the line position. Example:
@@ -61,7 +61,7 @@ All these tests are included by [src/shell/CMakeLists.txt](https://github.com/le
Bla.
--^ textDocument/completion
```
In this example, the test driver [`test_single.sh`](https://github.com/leanprover/lean4/tree/master/tests/lean/interactive/test_single.sh) will simulate an
In this example, the test driver `test_single.sh` will simulate an
auto-completion request at `Bla.`. The expected output is stored in
a .lean.expected.out in the json format that is part of the
[Language Server
@@ -78,21 +78,21 @@ All these tests are included by [src/shell/CMakeLists.txt](https://github.com/le
--^ collectDiagnostics
```
- [`tests/lean/server`](https://github.com/leanprover/lean4/tree/master/tests/lean/server/): Tests more of the Lean `--server` protocol.
- `tests/lean/server`: Tests more of the Lean `--server` protocol.
There are just a few of them, and it uses .log files containing
JSON.
- [`tests/compiler`](https://github.com/leanprover/lean4/tree/master/tests/compiler/): contains tests that will run the Lean compiler and
- `tests/compiler`: contains tests that will run the Lean compiler and
build an executable that is executed and the output is compared to
the .lean.expected.out file. This test also contains a subfolder
[`foreign`](https://github.com/leanprover/lean4/tree/master/tests/compiler/foreign/) which shows how to extend Lean using C++.
`foreign` which shows how to extend Lean using C++.
- [`tests/lean/trust0`](https://github.com/leanprover/lean4/tree/master/tests/lean/trust0): tests that run Lean in a mode that Lean doesn't
- `tests/lean/trust0`: tests that run Lean in a mode that Lean doesn't
even trust the .olean files (i.e., trust 0).
- [`tests/bench`](https://github.com/leanprover/lean4/tree/master/tests/bench/): contains performance tests.
- `tests/bench`: contains performance tests.
- [`tests/plugin`](https://github.com/leanprover/lean4/tree/master/tests/plugin/): tests that compiled Lean code can be loaded into
- `tests/plugin`: tests that compiled Lean code can be loaded into
`lean` via the `--plugin` command line option.
## Writing Good Tests
@@ -103,7 +103,7 @@ Every test file should contain:
and, if not 100% clear, why that is the desirable behavior
At the time of writing, most tests do not follow these new guidelines yet.
For an example of a conforming test, see [`tests/lean/1971.lean`](https://github.com/leanprover/lean4/tree/master/tests/lean/1971.lean).
For an example of a conforming test, see `tests/lean/1971.lean`.
## Fixing Tests
@@ -119,7 +119,7 @@ First, we must install [meld](http://meldmerge.org/). On Ubuntu, we can do it by
sudo apt-get install meld
```
Now, suppose `bad_class.lean` test is broken. We can see the problem by going to [`tests/lean`](https://github.com/leanprover/lean4/tree/master/tests/lean) directory and
Now, suppose `bad_class.lean` test is broken. We can see the problem by going to `tests/lean` directory and
executing
```

View File

@@ -82,7 +82,7 @@ theorem List.palindrome_ind (motive : List α → Prop)
have ih := palindrome_ind motive h₁ h₂ h₃ (a₂::as').dropLast
have : [a₁] ++ (a₂::as').dropLast ++ [(a₂::as').last (by simp)] = a₁::a₂::as' := by simp
this h₃ _ _ _ ih
termination_by as.length
termination_by _ as => as.length
/-!
We use our new induction principle to prove that if `as.reverse = as`, then `Palindrome as` holds.

9
doc/flake.lock generated
View File

@@ -69,16 +69,15 @@
"leanInk": {
"flake": false,
"locked": {
"lastModified": 1704976501,
"narHash": "sha256-FSBUsbX0HxakSnYRYzRBDN2YKmH9EkA0q9p7TSPEJTI=",
"owner": "leanprover",
"lastModified": 1666154782,
"narHash": "sha256-0ELqEca6jZT4BW/mqkDD+uYuxW5QlZUFlNwZkvugsg8=",
"owner": "digama0",
"repo": "LeanInk",
"rev": "51821e3c2c032c88e4b2956483899d373ec090c4",
"rev": "12a2aec9b5f4aa84e84fb01a9af1da00d8aaff4e",
"type": "github"
},
"original": {
"owner": "leanprover",
"ref": "refs/pull/57/merge",
"repo": "LeanInk",
"type": "github"
}

View File

@@ -12,7 +12,7 @@
flake = false;
};
inputs.leanInk = {
url = "github:leanprover/LeanInk/refs/pull/57/merge";
url = "github:leanprover/LeanInk";
flake = false;
};

View File

@@ -32,8 +32,8 @@ def fact x :=
#eval fact 100
```
By default, Lean only accepts total functions.
The `partial` keyword may be used to define a recursive function without a termination proof; `partial` functions compute in compiled programs, but are opaque in proofs and during type checking.
By default, Lean only accepts total functions. The `partial` keyword should be used when Lean cannot
establish that a function always terminates.
```lean
partial def g (x : Nat) (p : Nat -> Bool) : Nat :=
if p x then

View File

@@ -10,6 +10,7 @@ Platform-Specific Setup
- [Linux (Ubuntu)](ubuntu.md)
- [Windows (msys2)](msys2.md)
- [Windows (Visual Studio)](msvc.md)
- [Windows (WSL)](wsl.md)
- [macOS (homebrew)](osx-10.9.md)
- Linux/macOS/WSL via [Nix](https://nixos.org/nix/): Call `nix-shell` in the project root. That's it.

View File

@@ -60,7 +60,7 @@ While parsing `a * (b + c)`, `(b + c)` is assigned a precedence `60` by the addi
the right argument to have precedence **at least** 71. Thus, this parse is invalid. In contrast, `(a * b) + c` assigns
a precedence of `70` to `(a * b)`. This is compatible with addition which expects the left argument to have precedence
**at least `60` ** (`70` is greater than `60`). Thus, the string `a * b + c` is parsed as `(a * b) + c`.
For more details, please look at the [Lean manual on syntax extensions](./notation.md#notations-and-precedence).
For more details, please look at the [Lean manual on syntax extensions](../syntax.md#notations-and-precedence).
To go from strings into `Arith`, we define a macro to
translate the syntax category `arith` into an `Arith` inductive value that

View File

@@ -2,7 +2,7 @@
### Tier 1
Platforms built & tested by our CI, available as binary releases via elan (see below)
Platforms built & tested by our CI, available as nightly releases via elan (see below)
* x86-64 Linux with glibc 2.27+
* x86-64 macOS 10.15+
@@ -10,7 +10,7 @@ Platforms built & tested by our CI, available as binary releases via elan (see b
### Tier 2
Platforms cross-compiled but not tested by our CI, available as binary releases
Platforms cross-compiled but not tested by our CI, available as nightly releases
Releases may be silently broken due to the lack of automated testing.
Issue reports and fixes are welcome.

View File

@@ -15,7 +15,7 @@ The most fundamental pieces of any Lean program are functions organized into nam
[Functions](./functions.md) perform work on inputs to produce outputs,
and they are organized under [namespaces](./namespaces.md),
which are the primary way you group things in Lean.
They are defined using the `def` command,
They are defined using the [`def`](./definitions.md) command,
which give the function a name and define its arguments.
```lean

View File

@@ -37,6 +37,6 @@ Lean has numerous features, including:
- [Extensible syntax](./syntax.md)
- Hygienic macros
- [Dependent types](https://lean-lang.org/theorem_proving_in_lean4/dependent_type_theory.html)
- [Metaprogramming](./macro_overview.md)
- [Metaprogramming](./metaprogramming.md)
- Multithreading
- Verification: you can prove properties of your functions using Lean itself

View File

@@ -9,7 +9,7 @@ endif()
include(ExternalProject)
project(LEAN CXX C)
set(LEAN_VERSION_MAJOR 4)
set(LEAN_VERSION_MINOR 7)
set(LEAN_VERSION_MINOR 6)
set(LEAN_VERSION_PATCH 0)
set(LEAN_VERSION_IS_RELEASE 0) # This number is 1 in the release revision, and 0 otherwise.
set(LEAN_SPECIAL_VERSION_DESC "" CACHE STRING "Additional version description like 'nightly-2018-03-11'")
@@ -18,14 +18,6 @@ if (LEAN_SPECIAL_VERSION_DESC)
string(APPEND LEAN_VERSION_STRING "-${LEAN_SPECIAL_VERSION_DESC}")
endif()
set(LEAN_PLATFORM_TARGET "" CACHE STRING "LLVM triple of the target platform")
if (NOT LEAN_PLATFORM_TARGET)
# this may fail when the compiler is not clang, but this should only happen in local builds where
# the value of the variable is not of immediate relevance
execute_process(COMMAND ${CMAKE_C_COMPILER} --print-target-triple
OUTPUT_VARIABLE LEAN_PLATFORM_TARGET OUTPUT_STRIP_TRAILING_WHITESPACE)
endif()
set(LEAN_EXTRA_LINKER_FLAGS "" CACHE STRING "Additional flags used by the linker")
set(LEAN_EXTRA_CXX_FLAGS "" CACHE STRING "Additional flags used by the C++ compiler")
set(LEAN_TEST_VARS "LEAN_CC=${CMAKE_C_COMPILER}" CACHE STRING "Additional environment variables used when running tests")

View File

@@ -7,8 +7,6 @@ prelude
import Init.Prelude
import Init.Notation
import Init.Tactics
import Init.TacticsExtra
import Init.RCases
import Init.Core
import Init.Control
import Init.Data.Basic
@@ -25,6 +23,5 @@ import Init.NotationExtra
import Init.SimpLemmas
import Init.Hints
import Init.Conv
import Init.Guard
import Init.Simproc
import Init.SizeOfLemmas

View File

@@ -1,7 +1,7 @@
/-
Copyright (c) 2020 Microsoft Corporation. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Leonardo de Moura, Mario Carneiro
Authors: Leonardo de Moura
-/
prelude
import Init.Core
@@ -123,15 +123,21 @@ theorem byCases {p q : Prop} (hpq : p → q) (hnpq : ¬p → q) : q :=
theorem byContradiction {p : Prop} (h : ¬p False) : p :=
Decidable.byContradiction (dec := propDecidable _) h
end Classical
/--
`by_cases (h :)? p` splits the main goal into two cases, assuming `h : p` in the first branch, and `h : ¬ p` in the second branch.
-/
syntax "by_cases " (atomic(ident " : "))? term : tactic
macro_rules
| `(tactic| by_cases $e) => `(tactic| by_cases h : $e)
macro_rules
| `(tactic| by_cases $h : $e) =>
`(tactic| open Classical in refine if $h:ident : $e then ?pos else ?neg)
`(tactic|
cases em $e with
| inl $h => _
| inr $h => _)
| `(tactic| by_cases $e) =>
`(tactic|
cases em $e with
| inl h => _
| inr h => _)
end Classical

View File

@@ -290,12 +290,6 @@ between e.g. `↑x + ↑y` and `↑(x + y)`.
-/
syntax:1024 (name := coeNotation) "" term:1024 : term
/-- `⇑ t` coerces `t` to a function. -/
syntax:1024 (name := coeFunNotation) "" term:1024 : term
/-- `↥ t` coerces `t` to a type. -/
syntax:1024 (name := coeSortNotation) "" term:1024 : term
/-! # Basic instances -/
instance boolToProp : Coe Bool Prop where

View File

@@ -411,10 +411,9 @@ set_option linter.unusedVariables.funArgs false in
be available and then calls `f` on the result.
`prio`, if provided, is the priority of the task.
If `sync` is set to true, `f` is executed on the current thread if `x` has already finished.
-/
@[noinline, extern "lean_task_map"]
protected def map (f : α β) (x : Task α) (prio := Priority.default) (sync := false) : Task β :=
protected def map {α : Type u} {β : Type v} (f : α β) (x : Task α) (prio := Priority.default) : Task β :=
f x.get
set_option linter.unusedVariables.funArgs false in
@@ -425,11 +424,9 @@ for the value of `x` to be available and then calls `f` on the result,
resulting in a new task which is then run for a result.
`prio`, if provided, is the priority of the task.
If `sync` is set to true, `f` is executed on the current thread if `x` has already finished.
-/
@[noinline, extern "lean_task_bind"]
protected def bind (x : Task α) (f : α Task β) (prio := Priority.default) (sync := false) :
Task β :=
protected def bind {α : Type u} {β : Type v} (x : Task α) (f : α Task β) (prio := Priority.default) : Task β :=
(f x.get).get
end Task
@@ -666,8 +663,6 @@ theorem Iff.refl (a : Prop) : a ↔ a :=
protected theorem Iff.rfl {a : Prop} : a a :=
Iff.refl a
macro_rules | `(tactic| rfl) => `(tactic| exact Iff.rfl)
theorem Iff.trans (h₁ : a b) (h₂ : b c) : a c :=
Iff.intro
(fun ha => Iff.mp h₂ (Iff.mp h₁ ha))
@@ -1685,92 +1680,40 @@ So, you are mainly losing the capability of type checking your development using
-/
axiom ofReduceNat (a b : Nat) (h : reduceNat a = b) : a = b
end Lean
namespace Std
variable {α : Sort u}
/--
`Associative op` indicates `op` is an associative operation,
i.e. `(a ∘ b) ∘ c = a ∘ (b ∘ c)`.
`IsAssociative op` says that `op` is an associative operation,
i.e. `(a ∘ b) ∘ c = a ∘ (b ∘ c)`. It is used by the `ac_rfl` tactic.
-/
class Associative (op : α α α) : Prop where
class IsAssociative {α : Sort u} (op : α α α) where
/-- An associative operation satisfies `(a ∘ b) ∘ c = a ∘ (b ∘ c)`. -/
assoc : (a b c : α) op (op a b) c = op a (op b c)
/--
`Commutative op` says that `op` is a commutative operation,
i.e. `a ∘ b = b ∘ a`.
`IsCommutative op` says that `op` is a commutative operation,
i.e. `a ∘ b = b ∘ a`. It is used by the `ac_rfl` tactic.
-/
class Commutative (op : α α α) : Prop where
class IsCommutative {α : Sort u} (op : α α α) where
/-- A commutative operation satisfies `a ∘ b = b ∘ a`. -/
comm : (a b : α) op a b = op b a
/--
`IdempotentOp op` indicates `op` is an idempotent binary operation.
i.e. `a ∘ a = a`.
`IsIdempotent op` says that `op` is an idempotent operation,
i.e. `a ∘ a = a`. It is used by the `ac_rfl` tactic
(which also simplifies up to idempotence when available).
-/
class IdempotentOp (op : α α α) : Prop where
class IsIdempotent {α : Sort u} (op : α α α) where
/-- An idempotent operation satisfies `a ∘ a = a`. -/
idempotent : (x : α) op x x = x
/--
`LeftIdentify op o` indicates `o` is a left identity of `op`.
This class does not require a proof that `o` is an identity, and
is used primarily for infering the identity using class resoluton.
`IsNeutral op e` says that `e` is a neutral operation for `op`,
i.e. `a ∘ e = a = e ∘ a`. It is used by the `ac_rfl` tactic
(which also simplifies neutral elements when available).
-/
class LeftIdentity (op : α β β) (o : outParam α) : Prop
class IsNeutral {α : Sort u} (op : α α α) (neutral : α) where
/-- A neutral element can be cancelled on the left: `e ∘ a = a`. -/
left_neutral : (a : α) op neutral a = a
/-- A neutral element can be cancelled on the right: `a ∘ e = a`. -/
right_neutral : (a : α) op a neutral = a
/--
`LawfulLeftIdentify op o` indicates `o` is a verified left identity of
`op`.
-/
class LawfulLeftIdentity (op : α β β) (o : outParam α) extends LeftIdentity op o : Prop where
/-- Left identity `o` is an identity. -/
left_id : a, op o a = a
/--
`RightIdentify op o` indicates `o` is a right identity `o` of `op`.
This class does not require a proof that `o` is an identity, and is used
primarily for infering the identity using class resoluton.
-/
class RightIdentity (op : α β α) (o : outParam β) : Prop
/--
`LawfulRightIdentify op o` indicates `o` is a verified right identity of
`op`.
-/
class LawfulRightIdentity (op : α β α) (o : outParam β) extends RightIdentity op o : Prop where
/-- Right identity `o` is an identity. -/
right_id : a, op a o = a
/--
`Identity op o` indicates `o` is a left and right identity of `op`.
This class does not require a proof that `o` is an identity, and is used
primarily for infering the identity using class resoluton.
-/
class Identity (op : α α α) (o : outParam α) extends LeftIdentity op o, RightIdentity op o : Prop
/--
`LawfulIdentity op o` indicates `o` is a verified left and right
identity of `op`.
-/
class LawfulIdentity (op : α α α) (o : outParam α) extends Identity op o, LawfulLeftIdentity op o, LawfulRightIdentity op o : Prop
/--
`LawfulCommIdentity` can simplify defining instances of `LawfulIdentity`
on commutative functions by requiring only a left or right identity
proof.
This class is intended for simplifying defining instances of
`LawfulIdentity` and functions needed commutative operations with
identity should just add a `LawfulIdentity` constraint.
-/
class LawfulCommIdentity (op : α α α) (o : outParam α) [hc : Commutative op] extends LawfulIdentity op o : Prop where
left_id a := Eq.trans (hc.comm o a) (right_id a)
right_id a := Eq.trans (hc.comm a o) (left_id a)
end Std
end Lean

View File

@@ -14,17 +14,15 @@ inductive Expr
| op (lhs rhs : Expr)
deriving Inhabited, Repr, BEq
open Std
structure Variable {α : Sort u} (op : α α α) : Type u where
value : α
neutral : Option $ PLift (LawfulIdentity op value)
neutral : Option $ IsNeutral op value
structure Context (α : Sort u) where
op : α α α
assoc : Associative op
comm : Option $ PLift $ Commutative op
idem : Option $ PLift $ IdempotentOp op
assoc : IsAssociative op
comm : Option $ IsCommutative op
idem : Option $ IsIdempotent op
vars : List (Variable op)
arbitrary : α
@@ -130,14 +128,7 @@ theorem Context.mergeIdem_head2 (h : x ≠ y) : mergeIdem (x :: y :: ys) = x ::
simp [mergeIdem, mergeIdem.loop, h]
theorem Context.evalList_mergeIdem (ctx : Context α) (h : ContextInformation.isIdem ctx) (e : List Nat) : evalList α ctx (mergeIdem e) = evalList α ctx e := by
have h : IdempotentOp ctx.op := by
simp [ContextInformation.isIdem, Option.isSome] at h;
match h₂ : ctx.idem with
| none =>
simp [h₂] at h
| some val =>
simp [h₂] at h
exact val.down
have h : IsIdempotent ctx.op := by simp [ContextInformation.isIdem, Option.isSome] at h; cases h₂ : ctx.idem <;> simp [h₂] at h; assumption
induction e using List.two_step_induction with
| empty => rfl
| single => rfl
@@ -150,18 +141,18 @@ theorem Context.evalList_mergeIdem (ctx : Context α) (h : ContextInformation.is
rfl
| cons z zs =>
by_cases h₂ : x = y
case pos =>
case inl =>
rw [h₂, mergeIdem_head, ih]
simp [evalList, ctx.assoc.1, h.1, EvalInformation.evalOp]
case neg =>
case inr =>
rw [mergeIdem_head2]
by_cases h₃ : y = z
case pos =>
case inl =>
simp [mergeIdem_head, h₃, evalList]
cases h₄ : mergeIdem (z :: zs) with
| nil => apply absurd h₄; apply mergeIdem_nonEmpty; simp
| cons u us => simp_all [mergeIdem, mergeIdem.loop, evalList]
case neg =>
case inr =>
simp [mergeIdem_head2, h₃, evalList] at *
rw [ih]
assumption
@@ -178,7 +169,7 @@ theorem Context.sort_loop_nonEmpty (xs : List Nat) (h : xs ≠ []) : sort.loop x
theorem Context.evalList_insert
(ctx : Context α)
(h : Commutative ctx.op)
(h : IsCommutative ctx.op)
(x : Nat)
(xs : List Nat)
: evalList α ctx (insert x xs) = evalList α ctx (x::xs) := by
@@ -199,7 +190,7 @@ theorem Context.evalList_insert
theorem Context.evalList_sort_congr
(ctx : Context α)
(h : Commutative ctx.op)
(h : IsCommutative ctx.op)
(h₂ : evalList α ctx a = evalList α ctx b)
(h₃ : a [])
(h₄ : b [])
@@ -218,7 +209,7 @@ theorem Context.evalList_sort_congr
theorem Context.evalList_sort_loop_swap
(ctx : Context α)
(h : Commutative ctx.op)
(h : IsCommutative ctx.op)
(xs ys : List Nat)
: evalList α ctx (sort.loop xs (y::ys)) = evalList α ctx (sort.loop (y::xs) ys) := by
induction ys generalizing y xs with
@@ -233,7 +224,7 @@ theorem Context.evalList_sort_loop_swap
theorem Context.evalList_sort_cons
(ctx : Context α)
(h : Commutative ctx.op)
(h : IsCommutative ctx.op)
(x : Nat)
(xs : List Nat)
: evalList α ctx (sort (x :: xs)) = evalList α ctx (x :: sort xs) := by
@@ -256,14 +247,7 @@ theorem Context.evalList_sort_cons
all_goals simp [insert_nonEmpty]
theorem Context.evalList_sort (ctx : Context α) (h : ContextInformation.isComm ctx) (e : List Nat) : evalList α ctx (sort e) = evalList α ctx e := by
have h : Commutative ctx.op := by
simp [ContextInformation.isComm, Option.isSome] at h
match h₂ : ctx.comm with
| none =>
simp only [h₂] at h
| some val =>
simp [h₂] at h
exact val.down
have h : IsCommutative ctx.op := by simp [ContextInformation.isComm, Option.isSome] at h; cases h₂ : ctx.comm <;> simp [h₂] at h; assumption
induction e using List.two_step_induction with
| empty => rfl
| single => rfl
@@ -285,12 +269,10 @@ theorem Context.toList_nonEmpty (e : Expr) : e.toList ≠ [] := by
theorem Context.unwrap_isNeutral
{ctx : Context α}
{x : Nat}
: ContextInformation.isNeutral ctx x = true LawfulIdentity (EvalInformation.evalOp ctx) (EvalInformation.evalVar (β := α) ctx x) := by
: ContextInformation.isNeutral ctx x = true IsNeutral (EvalInformation.evalOp ctx) (EvalInformation.evalVar (β := α) ctx x) := by
simp [ContextInformation.isNeutral, Option.isSome, EvalInformation.evalOp, EvalInformation.evalVar]
match (var ctx x).neutral with
| some hn =>
intro
exact hn.down
| some hn => intro; assumption
| none => intro; contradiction
theorem Context.evalList_removeNeutrals (ctx : Context α) (e : List Nat) : evalList α ctx (removeNeutrals ctx e) = evalList α ctx e := by
@@ -301,12 +283,10 @@ theorem Context.evalList_removeNeutrals (ctx : Context α) (e : List Nat) : eval
case h_1 => rfl
case h_2 h => split at h <;> simp_all
| step x y ys ih =>
cases h₁ : ContextInformation.isNeutral ctx x <;>
cases h₂ : ContextInformation.isNeutral ctx y <;>
cases h₃ : removeNeutrals.loop ctx ys
cases h₁ : ContextInformation.isNeutral ctx x <;> cases h₂ : ContextInformation.isNeutral ctx y <;> cases h₃ : removeNeutrals.loop ctx ys
<;> simp [removeNeutrals, removeNeutrals.loop, h₁, h₂, h₃, evalList, ih]
<;> (try simp [unwrap_isNeutral h₂ |>.right_id])
<;> (try simp [unwrap_isNeutral h₁ |>.left_id])
<;> (try simp [unwrap_isNeutral h₂ |>.2])
<;> (try simp [unwrap_isNeutral h₁ |>.1])
theorem Context.evalList_append
(ctx : Context α)

View File

@@ -21,21 +21,6 @@ def mkArray {α : Type u} (n : Nat) (v : α) : Array α := {
data := List.replicate n v
}
/--
`ofFn f` with `f : Fin n → α` returns the list whose ith element is `f i`.
```
ofFn f = #[f 0, f 1, ... , f(n - 1)]
``` -/
def ofFn {n} (f : Fin n α) : Array α := go 0 (mkEmpty n) where
/-- Auxiliary for `ofFn`. `ofFn.go f i acc = acc ++ #[f i, ..., f(n - 1)]` -/
go (i : Nat) (acc : Array α) : Array α :=
if h : i < n then go (i+1) (acc.push (f i, h)) else acc
termination_by n - i
/-- The array `#[0, 1, ..., n - 1]`. -/
def range (n : Nat) : Array Nat :=
n.fold (flip Array.push) (mkEmpty n)
@[simp] theorem size_mkArray (n : Nat) (v : α) : (mkArray n v).size = n :=
List.length_replicate ..
@@ -86,12 +71,6 @@ abbrev getLit {α : Type u} {n : Nat} (a : Array α) (i : Nat) (h₁ : a.size =
def uset (a : Array α) (i : USize) (v : α) (h : i.toNat < a.size) : Array α :=
a.set i.toNat, h v
/--
Swaps two entries in an array.
This will perform the update destructively provided that `a` has a reference
count of 1 when called.
-/
@[extern "lean_array_fswap"]
def swap (a : Array α) (i j : @& Fin a.size) : Array α :=
let v₁ := a.get i
@@ -99,18 +78,12 @@ def swap (a : Array α) (i j : @& Fin a.size) : Array α :=
let a' := a.set i v₂
a'.set (size_set a i v₂ j) v₁
/--
Swaps two entries in an array, or panics if either index is out of bounds.
This will perform the update destructively provided that `a` has a reference
count of 1 when called.
-/
@[extern "lean_array_swap"]
def swap! (a : Array α) (i j : @& Nat) : Array α :=
if h₁ : i < a.size then
if h₂ : j < a.size then swap a i, h₁ j, h₂
else a
else a
else panic! "index out of bounds"
else panic! "index out of bounds"
@[inline] def swapAt (a : Array α) (i : Fin a.size) (v : α) : α × Array α :=
let e := a.get i
@@ -303,8 +276,8 @@ def mapM {α : Type u} {β : Type v} {m : Type v → Type w} [Monad m] (f : α
map (i+1) (r.push ( f as[i]))
else
pure r
termination_by as.size - i
map 0 (mkEmpty as.size)
termination_by map => as.size - i
@[inline]
def mapIdxM {α : Type u} {β : Type v} {m : Type v Type w} [Monad m] (as : Array α) (f : Fin as.size α m β) : m (Array β) :=
@@ -375,12 +348,12 @@ def anyM {α : Type u} {m : Type → Type w} [Monad m] (p : α → m Bool) (as :
loop (j+1)
else
pure false
termination_by stop - j
loop start
if h : stop as.size then
any stop h
else
any as.size (Nat.le_refl _)
termination_by loop i j => stop - j
@[inline]
def allM {α : Type u} {m : Type Type w} [Monad m] (p : α m Bool) (as : Array α) (start := 0) (stop := as.size) : m Bool :=
@@ -428,10 +401,6 @@ def map {α : Type u} {β : Type v} (f : α → β) (as : Array α) : Array β :
def mapIdx {α : Type u} {β : Type v} (as : Array α) (f : Fin as.size α β) : Array β :=
Id.run <| as.mapIdxM f
/-- Turns `#[a, b]` into `#[(a, 0), (b, 1)]`. -/
def zipWithIndex (arr : Array α) : Array (α × Nat) :=
arr.mapIdx fun i a => (a, i)
@[inline]
def find? {α : Type} (as : Array α) (p : α Bool) : Option α :=
Id.run <| as.findM? p
@@ -506,11 +475,6 @@ def elem [BEq α] (a : α) (as : Array α) : Bool :=
def toList (as : Array α) : List α :=
as.foldr List.cons []
/-- Prepends an `Array α` onto the front of a list. Equivalent to `as.toList ++ l`. -/
@[inline]
def toListAppend (as : Array α) (l : List α) : List α :=
as.foldr List.cons l
instance {α : Type u} [Repr α] : Repr (Array α) where
reprPrec a _ :=
let _ : Std.ToFormat α := repr
@@ -540,13 +504,6 @@ def concatMapM [Monad m] (f : α → m (Array β)) (as : Array α) : m (Array β
def concatMap (f : α Array β) (as : Array α) : Array β :=
as.foldl (init := empty) fun bs a => bs ++ f a
/-- Joins array of array into a single array.
`flatten #[#[a₁, a₂, ⋯], #[b₁, b₂, ⋯], ⋯]` = `#[a₁, a₂, ⋯, b₁, b₂, ⋯]`
-/
def flatten (as : Array (Array α)) : Array α :=
as.foldl (init := empty) fun r a => r ++ a
end Array
export Array (mkArray)
@@ -566,7 +523,7 @@ def isEqvAux (a b : Array α) (hsz : a.size = b.size) (p : αα → Bool) (
p a[i] b[i] && isEqvAux a b hsz p (i+1)
else
true
termination_by a.size - i
termination_by _ => a.size - i
@[inline] def isEqv (a b : Array α) (p : α α Bool) : Bool :=
if h : a.size = b.size then
@@ -670,7 +627,7 @@ def indexOfAux [BEq α] (a : Array α) (v : α) (i : Nat) : Option (Fin a.size)
if a.get idx == v then some idx
else indexOfAux a v (i+1)
else none
termination_by a.size - i
termination_by _ => a.size - i
def indexOf? [BEq α] (a : Array α) (v : α) : Option (Fin a.size) :=
indexOfAux a v 0
@@ -702,7 +659,7 @@ where
loop as (i+1) j-1, this
else
as
termination_by j - i
termination_by _ => j - i
def popWhile (p : α Bool) (as : Array α) : Array α :=
if h : as.size > 0 then
@@ -712,7 +669,7 @@ def popWhile (p : α → Bool) (as : Array α) : Array α :=
as
else
as
termination_by as.size
termination_by popWhile as => as.size
def takeWhile (p : α Bool) (as : Array α) : Array α :=
let rec go (i : Nat) (r : Array α) : Array α :=
@@ -724,8 +681,8 @@ def takeWhile (p : α → Bool) (as : Array α) : Array α :=
r
else
r
termination_by as.size - i
go 0 #[]
termination_by go i r => as.size - i
def eraseIdxAux (i : Nat) (a : Array α) : Array α :=
if h : i < a.size then
@@ -735,7 +692,7 @@ def eraseIdxAux (i : Nat) (a : Array α) : Array α :=
eraseIdxAux (i+1) a'
else
a.pop
termination_by a.size - i
termination_by _ => a.size - i
def feraseIdx (a : Array α) (i : Fin a.size) : Array α :=
eraseIdxAux (i.val + 1) a
@@ -750,7 +707,7 @@ def eraseIdxSzAux (a : Array α) (i : Nat) (r : Array α) (heq : r.size = a.size
eraseIdxSzAux a (i+1) (r.swap idx idx1) ((size_swap r idx idx1).trans heq)
else
r.pop, (size_pop r).trans (heq rfl)
termination_by r.size - i
termination_by _ => r.size - i
def eraseIdx' (a : Array α) (i : Fin a.size) : { r : Array α // r.size = a.size - 1 } :=
eraseIdxSzAux a (i.val + 1) a rfl
@@ -769,10 +726,10 @@ def erase [BEq α] (as : Array α) (a : α) : Array α :=
loop as j', by rw [size_swap]; exact j'.2
else
as
termination_by j.1
let j := as.size
let as := as.push a
loop as j, size_push .. j.lt_succ_self
termination_by loop j => j.1
/-- Insert element `a` at position `i`. Panics if `i` is not `i ≤ as.size`. -/
def insertAt! (as : Array α) (i : Nat) (a : α) : Array α :=
@@ -822,7 +779,7 @@ def isPrefixOfAux [BEq α] (as bs : Array α) (hle : as.size ≤ bs.size) (i : N
false
else
true
termination_by as.size - i
termination_by _ => as.size - i
/-- Return true iff `as` is a prefix of `bs`.
That is, `bs = as ++ t` for some `t : List α`.-/
@@ -843,7 +800,7 @@ private def allDiffAux [BEq α] (as : Array α) (i : Nat) : Bool :=
allDiffAuxAux as as[i] i h && allDiffAux as (i+1)
else
true
termination_by as.size - i
termination_by _ => as.size - i
def allDiff [BEq α] (as : Array α) : Bool :=
allDiffAux as 0
@@ -858,7 +815,7 @@ def allDiff [BEq α] (as : Array α) : Bool :=
cs
else
cs
termination_by as.size - i
termination_by _ => as.size - i
@[inline] def zipWith (as : Array α) (bs : Array β) (f : α β γ) : Array γ :=
zipWithAux f as bs 0 #[]

View File

@@ -47,7 +47,7 @@ where
have hlt : i < as.size := Nat.lt_of_le_of_ne hle h
let b f as[i]
go (i+1) acc.val.push b, by simp [acc.property] hlt
termination_by as.size - i
termination_by go i _ _ => as.size - i
@[inline] private unsafe def mapMonoMImp [Monad m] (as : Array α) (f : α m α) : m (Array α) :=
go 0 as

View File

@@ -20,7 +20,7 @@ theorem eq_of_isEqvAux [DecidableEq α] (a b : Array α) (hsz : a.size = b.size)
· have heq : i = a.size := Nat.le_antisymm hi (Nat.ge_of_not_lt h)
subst heq
exact absurd (Nat.lt_of_lt_of_le high low) (Nat.lt_irrefl j)
termination_by a.size - i
termination_by _ => a.size - i
theorem eq_of_isEqv [DecidableEq α] (a b : Array α) : Array.isEqv a b (fun x y => x = y) a = b := by
simp [Array.isEqv]
@@ -36,7 +36,7 @@ theorem isEqvAux_self [DecidableEq α] (a : Array α) (i : Nat) : Array.isEqvAux
split
case inl h => simp [h, isEqvAux_self a (i+1)]
case inr h => simp [h]
termination_by a.size - i
termination_by _ => a.size - i
theorem isEqv_self [DecidableEq α] (a : Array α) : Array.isEqv a a (fun x y => x = y) = true := by
simp [isEqv, isEqvAux_self]

View File

@@ -26,8 +26,8 @@ def qpartition (as : Array α) (lt : αα → Bool) (lo hi : Nat) : Nat ×
else
let as := as.swap! i hi
(i, as)
termination_by hi - j
loop as lo lo
termination_by _ => hi - j
@[inline] partial def qsort (as : Array α) (lt : α α Bool) (low := 0) (high := as.size - 1) : Array α :=
let rec @[specialize] sort (as : Array α) (low high : Nat) :=

View File

@@ -26,8 +26,6 @@ opaque floatSpec : FloatSpec := {
decLe := fun _ _ => inferInstanceAs (Decidable True)
}
/-- Native floating point type, corresponding to the IEEE 754 *binary64* format
(`double` in C or `f64` in Rust). -/
structure Float where
val : floatSpec.float

View File

@@ -300,18 +300,11 @@ instance : MonadPrettyFormat (StateM State) where
startTag _ := return ()
endTags _ := return ()
/--
Renders a `Format` to a string.
* `width`: the total width
* `indent`: the initial indentation to use for wrapped lines
(subsequent wrapping may increase the indentation)
* `column`: begin the first line wrap `column` characters earlier than usual
(this is useful when the output String will be printed starting at `column`)
-/
/-- Pretty-print a `Format` object as a string with expected width `w`. -/
@[export lean_format_pretty]
def pretty (f : Format) (width : Nat := defWidth) (indent : Nat := 0) (column := 0) : String :=
let act : StateM State Unit := prettyM f width indent
State.out <| act (State.mk "" column) |>.snd
def pretty (f : Format) (w : Nat := defWidth) : String :=
let act: StateM State Unit := prettyM f w
act {} |>.snd.out
end Format

View File

@@ -8,14 +8,14 @@ import Init.Data.Nat.Div
namespace Nat
private def gcdF (x : Nat) : ( x₁, x₁ < x Nat Nat) Nat Nat :=
match x with
| 0 => fun _ y => y
| succ x => fun f y => f (y % succ x) (mod_lt _ (zero_lt_succ _)) (succ x)
@[extern "lean_nat_gcd"]
def gcd (m n : @& Nat) : Nat :=
if m = 0 then
n
else
gcd (n % m) m
termination_by m
decreasing_by simp_wf; apply mod_lt _ (zero_lt_of_ne_zero _); assumption
def gcd (a b : @& Nat) : Nat :=
WellFounded.fix (measure id).wf gcdF a b
@[simp] theorem gcd_zero_left (y : Nat) : gcd 0 y = y :=
rfl

View File

@@ -21,8 +21,8 @@ where
go (power * 2) (Nat.mul_pos h (by decide))
else
power
termination_by n - power
decreasing_by simp_wf; apply nextPowerOfTwo_dec <;> assumption
termination_by go p h => n - p
decreasing_by simp_wf; apply nextPowerOfTwo_dec <;> assumption
def isPowerOfTwo (n : Nat) := k, n = 2 ^ k
@@ -48,7 +48,7 @@ where
split
. exact isPowerOfTwo_go (power*2) (Nat.mul_pos h₁ (by decide)) (Nat.mul2_isPowerOfTwo_of_isPowerOfTwo h₂)
. assumption
termination_by n - power
decreasing_by simp_wf; apply nextPowerOfTwo_dec <;> assumption
termination_by isPowerOfTwo_go p _ _ => n - p
decreasing_by simp_wf; apply nextPowerOfTwo_dec <;> assumption
end Nat

View File

@@ -6,7 +6,7 @@ Authors: Leonardo de Moura
prelude
import Init.Meta
import Init.Data.Float
import Init.Data.Nat.Log2
import Init.Data.Nat
/-- For decimal and scientific numbers (e.g., `1.23`, `3.12e10`).
Examples:

View File

@@ -76,12 +76,10 @@ macro_rules
end Range
end Std
theorem Membership.mem.upper {i : Nat} {r : Std.Range} (h : i r) : i < r.stop := h.2
theorem Membership.mem.upper {i : Nat} {r : Std.Range} (h : i r) : i < r.stop := by
simp [Membership.mem] at h
exact h.2
theorem Membership.mem.lower {i : Nat} {r : Std.Range} (h : i r) : r.start i := h.1
theorem Membership.get_elem_helper {i n : Nat} {r : Std.Range} (h₁ : i r) (h₂ : r.stop = n) :
i < n := h₂ h₁.2
macro_rules
| `(tactic| get_elem_tactic_trivial) => `(tactic| apply Membership.get_elem_helper; assumption; rfl)
theorem Membership.mem.lower {i : Nat} {r : Std.Range} (h : i r) : r.start i := by
simp [Membership.mem] at h
exact h.1

View File

@@ -159,7 +159,7 @@ def posOfAux (s : String) (c : Char) (stopPos : Pos) (pos : Pos) : Pos :=
have := Nat.sub_lt_sub_left h (lt_next s pos)
posOfAux s c stopPos (s.next pos)
else pos
termination_by stopPos.1 - pos.1
termination_by _ => stopPos.1 - pos.1
@[inline] def posOf (s : String) (c : Char) : Pos :=
posOfAux s c s.endPos 0
@@ -171,7 +171,7 @@ def revPosOfAux (s : String) (c : Char) (pos : Pos) : Option Pos :=
let pos := s.prev pos
if s.get pos == c then some pos
else revPosOfAux s c pos
termination_by pos.1
termination_by _ => pos.1
def revPosOf (s : String) (c : Char) : Option Pos :=
revPosOfAux s c s.endPos
@@ -183,7 +183,7 @@ def findAux (s : String) (p : Char → Bool) (stopPos : Pos) (pos : Pos) : Pos :
have := Nat.sub_lt_sub_left h (lt_next s pos)
findAux s p stopPos (s.next pos)
else pos
termination_by stopPos.1 - pos.1
termination_by _ => stopPos.1 - pos.1
@[inline] def find (s : String) (p : Char Bool) : Pos :=
findAux s p s.endPos 0
@@ -195,7 +195,7 @@ def revFindAux (s : String) (p : Char → Bool) (pos : Pos) : Option Pos :=
let pos := s.prev pos
if p (s.get pos) then some pos
else revFindAux s p pos
termination_by pos.1
termination_by _ => pos.1
def revFind (s : String) (p : Char Bool) : Option Pos :=
revFindAux s p s.endPos
@@ -213,8 +213,8 @@ def firstDiffPos (a b : String) : Pos :=
have := Nat.sub_lt_sub_left h (lt_next a i)
loop (a.next i)
else i
termination_by stopPos.1 - i.1
loop 0
termination_by loop => stopPos.1 - i.1
@[extern "lean_string_utf8_extract"]
def extract : (@& String) (@& Pos) (@& Pos) String
@@ -240,7 +240,7 @@ where
splitAux s p i' i' (s.extract b i :: r)
else
splitAux s p b (s.next i) r
termination_by s.endPos.1 - i.1
termination_by _ => s.endPos.1 - i.1
@[specialize] def split (s : String) (p : Char Bool) : List String :=
splitAux s p 0 0 []
@@ -260,7 +260,7 @@ def splitOnAux (s sep : String) (b : Pos) (i : Pos) (j : Pos) (r : List String)
splitOnAux s sep b i j r
else
splitOnAux s sep b (s.next i) 0 r
termination_by s.endPos.1 - i.1
termination_by _ => s.endPos.1 - i.1
def splitOn (s : String) (sep : String := " ") : List String :=
if sep == "" then [s] else splitOnAux s sep 0 0 0 []
@@ -369,7 +369,7 @@ def offsetOfPosAux (s : String) (pos : Pos) (i : Pos) (offset : Nat) : Nat :=
else
have := Nat.sub_lt_sub_left (Nat.gt_of_not_le (mt decide_eq_true h)) (lt_next s _)
offsetOfPosAux s pos (s.next i) (offset+1)
termination_by s.endPos.1 - i.1
termination_by _ => s.endPos.1 - i.1
def offsetOfPos (s : String) (pos : Pos) : Nat :=
offsetOfPosAux s pos 0 0
@@ -379,7 +379,7 @@ def offsetOfPos (s : String) (pos : Pos) : Nat :=
have := Nat.sub_lt_sub_left h (lt_next s i)
foldlAux f s stopPos (s.next i) (f a (s.get i))
else a
termination_by stopPos.1 - i.1
termination_by _ => stopPos.1 - i.1
@[inline] def foldl {α : Type u} (f : α Char α) (init : α) (s : String) : α :=
foldlAux f s s.endPos 0 init
@@ -392,7 +392,7 @@ termination_by stopPos.1 - i.1
let a := f (s.get i) a
foldrAux f a s i begPos
else a
termination_by i.1
termination_by _ => i.1
@[inline] def foldr {α : Type u} (f : Char α α) (init : α) (s : String) : α :=
foldrAux f init s s.endPos 0
@@ -404,7 +404,7 @@ termination_by i.1
have := Nat.sub_lt_sub_left h (lt_next s i)
anyAux s stopPos p (s.next i)
else false
termination_by stopPos.1 - i.1
termination_by _ => stopPos.1 - i.1
@[inline] def any (s : String) (p : Char Bool) : Bool :=
anyAux s s.endPos p 0
@@ -463,7 +463,7 @@ theorem mapAux_lemma (s : String) (i : Pos) (c : Char) (h : ¬s.atEnd i) :
have := mapAux_lemma s i c h
let s := s.set i c
mapAux f (s.next i) s
termination_by s.endPos.1 - i.1
termination_by _ => s.endPos.1 - i.1
@[inline] def map (f : Char Char) (s : String) : String :=
mapAux f 0 s
@@ -490,7 +490,7 @@ where
have := Nat.sub_lt_sub_left h (Nat.add_lt_add_left (one_le_csize c₁) off1.1)
c₁ == c₂ && loop (off1 + c₁) (off2 + c₂) stop1
else true
termination_by stop1.1 - off1.1
termination_by loop => stop1.1 - off1.1
/-- Return true iff `p` is a prefix of `s` -/
def isPrefixOf (p : String) (s : String) : Bool :=
@@ -512,14 +512,8 @@ def replace (s pattern replacement : String) : String :=
else
have := Nat.sub_lt_sub_left this (lt_next s pos)
loop acc accStop (s.next pos)
termination_by s.endPos.1 - pos.1
loop "" 0 0
/-- Return the beginning of the line that contains character `pos`. -/
def findLineStart (s : String) (pos : String.Pos) : String.Pos :=
match s.revFindAux (· = '\n') pos with
| none => 0
| some n => n.byteIdx + 1
termination_by loop => s.endPos.1 - pos.1
end String
@@ -618,8 +612,8 @@ def splitOn (s : Substring) (sep : String := " ") : List Substring :=
else
s.extract b i :: r
r.reverse
termination_by s.bsize - i.1
loop 0 0 0 []
termination_by loop => s.bsize - i.1
@[inline] def foldl {α : Type u} (f : α Char α) (init : α) (s : Substring) : α :=
match s with
@@ -646,7 +640,7 @@ def contains (s : Substring) (c : Char) : Bool :=
takeWhileAux s stopPos p (s.next i)
else i
else i
termination_by stopPos.1 - i.1
termination_by _ => stopPos.1 - i.1
@[inline] def takeWhile : Substring (Char Bool) Substring
| s, b, e, p =>
@@ -667,7 +661,7 @@ termination_by stopPos.1 - i.1
if !p c then i
else takeRightWhileAux s begPos p i'
else i
termination_by i.1
termination_by _ => i.1
@[inline] def takeRightWhile : Substring (Char Bool) Substring
| s, b, e, p =>

View File

@@ -5,6 +5,7 @@ Authors: Leonardo de Moura
-/
prelude
import Init.Data.Fin.Basic
import Init.System.Platform
open Nat
@@ -150,14 +151,6 @@ instance : Min UInt16 := minOfLe
def UInt32.ofNat (n : @& Nat) : UInt32 := Fin.ofNat n
@[extern "lean_uint32_of_nat"]
def UInt32.ofNat' (n : Nat) (h : n < UInt32.size) : UInt32 := n, h
/--
Converts the given natural number to `UInt32`, but returns `2^32 - 1` for natural numbers `>= 2^32`.
-/
def UInt32.ofNatTruncate (n : Nat) : UInt32 :=
if h : n < UInt32.size then
UInt32.ofNat' n h
else
UInt32.ofNat' (UInt32.size - 1) (by decide)
abbrev Nat.toUInt32 := UInt32.ofNat
@[extern "lean_uint32_add"]
def UInt32.add (a b : UInt32) : UInt32 := a.val + b.val

View File

@@ -1,129 +0,0 @@
/-
Copyright (c) 2021 Mario Carneiro. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Mario Carneiro
-/
prelude
import Init.Tactics
import Init.Conv
import Init.NotationExtra
namespace Lean.Parser
/-- Reducible defeq matching for `guard_hyp` types -/
syntax colonR := " : "
/-- Default-reducibility defeq matching for `guard_hyp` types -/
syntax colonD := " :~ "
/-- Syntactic matching for `guard_hyp` types -/
syntax colonS := " :ₛ "
/-- Alpha-eq matching for `guard_hyp` types -/
syntax colonA := " :ₐ "
/-- The `guard_hyp` type specifier, one of `:`, `:~`, `:ₛ`, `:ₐ` -/
syntax colon := colonR <|> colonD <|> colonS <|> colonA
/-- Reducible defeq matching for `guard_hyp` values -/
syntax colonEqR := " := "
/-- Default-reducibility defeq matching for `guard_hyp` values -/
syntax colonEqD := " :=~ "
/-- Syntactic matching for `guard_hyp` values -/
syntax colonEqS := " :=ₛ "
/-- Alpha-eq matching for `guard_hyp` values -/
syntax colonEqA := " :=ₐ "
/-- The `guard_hyp` value specifier, one of `:=`, `:=~`, `:=ₛ`, `:=ₐ` -/
syntax colonEq := colonEqR <|> colonEqD <|> colonEqS <|> colonEqA
/-- Reducible defeq matching for `guard_expr` -/
syntax equalR := " = "
/-- Default-reducibility defeq matching for `guard_expr` -/
syntax equalD := " =~ "
/-- Syntactic matching for `guard_expr` -/
syntax equalS := " =ₛ "
/-- Alpha-eq matching for `guard_expr` -/
syntax equalA := " =ₐ "
/-- The `guard_expr` matching specifier, one of `=`, `=~`, `=ₛ`, `=ₐ` -/
syntax equal := equalR <|> equalD <|> equalS <|> equalA
namespace Tactic
/--
Tactic to check equality of two expressions.
* `guard_expr e = e'` checks that `e` and `e'` are defeq at reducible transparency.
* `guard_expr e =~ e'` checks that `e` and `e'` are defeq at default transparency.
* `guard_expr e =ₛ e'` checks that `e` and `e'` are syntactically equal.
* `guard_expr e =ₐ e'` checks that `e` and `e'` are alpha-equivalent.
Both `e` and `e'` are elaborated then have their metavariables instantiated before the equality
check. Their types are unified (using `isDefEqGuarded`) before synthetic metavariables are
processed, which helps with default instance handling.
-/
syntax (name := guardExpr) "guard_expr " term:51 equal term : tactic
@[inherit_doc guardExpr]
syntax (name := guardExprConv) "guard_expr " term:51 equal term : conv
/--
Tactic to check that the target agrees with a given expression.
* `guard_target = e` checks that the target is defeq at reducible transparency to `e`.
* `guard_target =~ e` checks that the target is defeq at default transparency to `e`.
* `guard_target =ₛ e` checks that the target is syntactically equal to `e`.
* `guard_target =ₐ e` checks that the target is alpha-equivalent to `e`.
The term `e` is elaborated with the type of the goal as the expected type, which is mostly
useful within `conv` mode.
-/
syntax (name := guardTarget) "guard_target " equal term : tactic
@[inherit_doc guardTarget]
syntax (name := guardTargetConv) "guard_target " equal term : conv
/--
Tactic to check that a named hypothesis has a given type and/or value.
* `guard_hyp h : t` checks the type up to reducible defeq,
* `guard_hyp h :~ t` checks the type up to default defeq,
* `guard_hyp h :ₛ t` checks the type up to syntactic equality,
* `guard_hyp h :ₐ t` checks the type up to alpha equality.
* `guard_hyp h := v` checks value up to reducible defeq,
* `guard_hyp h :=~ v` checks value up to default defeq,
* `guard_hyp h :=ₛ v` checks value up to syntactic equality,
* `guard_hyp h :=ₐ v` checks the value up to alpha equality.
The value `v` is elaborated using the type of `h` as the expected type.
-/
syntax (name := guardHyp)
"guard_hyp " term:max (colon term)? (colonEq term)? : tactic
@[inherit_doc guardHyp] syntax (name := guardHypConv)
"guard_hyp " term:max (colon term)? (colonEq term)? : conv
end Tactic
namespace Command
/--
Command to check equality of two expressions.
* `#guard_expr e = e'` checks that `e` and `e'` are defeq at reducible transparency.
* `#guard_expr e =~ e'` checks that `e` and `e'` are defeq at default transparency.
* `#guard_expr e =ₛ e'` checks that `e` and `e'` are syntactically equal.
* `#guard_expr e =ₐ e'` checks that `e` and `e'` are alpha-equivalent.
This is a command version of the `guard_expr` tactic. -/
syntax (name := guardExprCmd) "#guard_expr " term:51 equal term : command
/--
Command to check that an expression evaluates to `true`.
`#guard e` elaborates `e` ensuring its type is `Bool` then evaluates `e` and checks that
the result is `true`. The term is elaborated *without* variables declared using `variable`, since
these cannot be evaluated.
Since this makes use of coercions, so long as a proposition `p` is decidable, one can write
`#guard p` rather than `#guard decide p`. A consequence to this is that if there is decidable
equality one can write `#guard a = b`. Note that this is not exactly the same as checking
if `a` and `b` evaluate to the same thing since it uses the `DecidableEq` instance to do
the evaluation.
Note: this uses the untrusted evaluator, so `#guard` passing is *not* a proof that the
expression equals `true`. -/
syntax (name := guardCmd) "#guard " term : command
end Command
end Lean.Parser

View File

@@ -563,17 +563,8 @@ def SepArray.ofElemsUsingRef [Monad m] [MonadRef m] {sep} (elems : Array Syntax)
instance : Coe (Array Syntax) (SepArray sep) where
coe := SepArray.ofElems
/--
Constructs a typed separated array from elements.
The given array does not include the separators.
Like `Syntax.SepArray.ofElems` but for typed syntax.
-/
def TSepArray.ofElems {sep} (elems : Array (TSyntax k)) : TSepArray k sep :=
.mk (SepArray.ofElems (sep := sep) (TSyntaxArray.raw elems)).1
instance : Coe (TSyntaxArray k) (TSepArray k sep) where
coe := TSepArray.ofElems
coe a := mkSepArray a.raw (mkAtom sep)
/-- Create syntax representing a Lean term application, but avoid degenerate empty applications. -/
def mkApp (fn : Term) : (args : TSyntaxArray `term) Term
@@ -1048,7 +1039,7 @@ where
go (i+1) (args.push (quote xs[i]))
else
Syntax.mkCApp (Name.mkStr2 "Array" ("mkArray" ++ toString xs.size)) args
termination_by xs.size - i
termination_by go i _ => xs.size - i
instance [Quote α `term] : Quote (Array α) `term where
quote := quoteArray

View File

@@ -268,7 +268,6 @@ syntax (name := rawNatLit) "nat_lit " num : term
@[inherit_doc] infixr:90 "" => Function.comp
@[inherit_doc] infixr:35 " × " => Prod
@[inherit_doc] infix:50 " " => Dvd.dvd
@[inherit_doc] infixl:55 " ||| " => HOr.hOr
@[inherit_doc] infixl:58 " ^^^ " => HXor.hXor
@[inherit_doc] infixl:60 " &&& " => HAnd.hAnd
@@ -485,13 +484,6 @@ existing code. It may be removed in a future version of the library.
-/
syntax (name := deprecated) "deprecated" (ppSpace ident)? : attr
/--
The `@[coe]` attribute on a function (which should also appear in a
`instance : Coe A B := ⟨myFn⟩` declaration) allows the delaborator to show
applications of this function as `↑` when printing expressions.
-/
syntax (name := Attr.coe) "coe" : attr
/--
When `parent_dir` contains the current Lean file, `include_str "path" / "to" / "file"` becomes
a string literal with the contents of the file at `"parent_dir" / "path" / "to" / "file"`. If this

View File

@@ -170,20 +170,6 @@ See [Theorem Proving in Lean 4][tpil4] for more information.
-/
syntax (name := calcTactic) "calc" calcSteps : tactic
/--
Denotes a term that was omitted by the pretty printer.
This is only used for pretty printing, and it cannot be elaborated.
The presence of `⋯` is controlled by the `pp.deepTerms` and `pp.deepTerms.threshold`
options.
-/
syntax "" : term
macro_rules | `() => Macro.throwError "\
Error: The '⋯' token is used by the pretty printer to indicate omitted terms, \
and it cannot be elaborated. \
Its presence in pretty printing output is controlled by the 'pp.deepTerms' and \
`pp.deepTerms.threshold` options."
@[app_unexpander Unit.unit] def unexpandUnit : Lean.PrettyPrinter.Unexpander
| `($(_)) => `(())
@@ -191,13 +177,9 @@ macro_rules | `(⋯) => Macro.throwError "\
| `($(_)) => `([])
@[app_unexpander List.cons] def unexpandListCons : Lean.PrettyPrinter.Unexpander
| `($(_) $x $tail) =>
match tail with
| `([]) => `([$x])
| `([$xs,*]) => `([$x, $xs,*])
| `() => `([$x, $tail]) -- Unexpands to `[x, y, z, ⋯]` for `⋯ : List α`
| _ => throw ()
| _ => throw ()
| `($(_) $x []) => `([$x])
| `($(_) $x [$xs,*]) => `([$x, $xs,*])
| _ => throw ()
@[app_unexpander List.toArray] def unexpandListToArray : Lean.PrettyPrinter.Unexpander
| `($(_) [$xs,*]) => `(#[$xs,*])

View File

@@ -9,9 +9,9 @@ set_option linter.missingDocs true -- keep it documented
/-!
# Init.Prelude
This is the first file in the Lean import hierarchy. It is responsible for setting
up basic definitions, most of which Lean already has "built in knowledge" about,
so it is important that they be set up in exactly this way. (For example, Lean will
This is the first file in the lean import hierarchy. It is responsible for setting
up basic definitions, most of which lean already has "built in knowledge" about,
so it is important that they be set up in exactly this way. (For example, lean will
use `PUnit` in the desugaring of `do` notation, or in the pattern match compiler.)
-/
@@ -24,7 +24,7 @@ The identity function. `id` takes an implicit argument `α : Sort u`
Although this may look like a useless function, one application of the identity
function is to explicitly put a type on an expression. If `e` has type `T`,
and `T'` is definitionally equal to `T`, then `@id T' e` typechecks, and Lean
and `T'` is definitionally equal to `T`, then `@id T' e` typechecks, and lean
knows that this expression has type `T'` rather than `T`. This can make a
difference for typeclass inference, since `T` and `T'` may have different
typeclass instances on them. `show T' from e` is sugar for an `@id T' e`
@@ -287,9 +287,9 @@ inductive Eq : αα → Prop where
same as `Eq.refl` except that it takes `a` implicitly instead of explicitly.
This is a more powerful theorem than it may appear at first, because although
the statement of the theorem is `a = a`, Lean will allow anything that is
the statement of the theorem is `a = a`, lean will allow anything that is
definitionally equal to that type. So, for instance, `2 + 2 = 4` is proven in
Lean by `rfl`, because both sides are the same up to definitional equality.
lean by `rfl`, because both sides are the same up to definitional equality.
-/
@[match_pattern] def rfl {α : Sort u} {a : α} : Eq a a := Eq.refl a
@@ -597,7 +597,7 @@ For example, the `Membership` class is defined as:
class Membership (α : outParam (Type u)) (γ : Type v)
```
This means that whenever a typeclass goal of the form `Membership ?α ?γ` comes
up, Lean will wait to solve it until `?γ` is known, but then it will run
up, lean will wait to solve it until `?γ` is known, but then it will run
typeclass inference, and take the first solution it finds, for any value of `?α`,
which thereby determines what `?α` should be.
@@ -712,13 +712,13 @@ nonempty, then `fun i => Classical.choice (h i) : ∀ i, α i` is a family of
chosen elements. This is actually a bit stronger than the ZFC choice axiom;
this is sometimes called "[global choice](https://en.wikipedia.org/wiki/Axiom_of_global_choice)".
In Lean, we use the axiom of choice to derive the law of excluded middle
In lean, we use the axiom of choice to derive the law of excluded middle
(see `Classical.em`), so it will often show up in axiom listings where you
may not expect. You can use `#print axioms my_thm` to find out if a given
theorem depends on this or other axioms.
This axiom can be used to construct "data", but obviously there is no algorithm
to compute it, so Lean will require you to mark any definition that would
to compute it, so lean will require you to mark any definition that would
involve executing `Classical.choice` or other axioms as `noncomputable`, and
will not produce any executable code for such definitions.
-/
@@ -943,7 +943,7 @@ determines how to evaluate `c` to true or false. Write `if h : c then t else e`
instead for a "dependent if-then-else" `dite`, which allows `t`/`e` to use the fact
that `c` is true/false.
Because Lean uses a strict (call-by-value) evaluation strategy, the signature of this
Because lean uses a strict (call-by-value) evaluation strategy, the signature of this
function is problematic in that it would require `t` and `e` to be evaluated before
calling the `ite` function, which would cause both sides of the `if` to be evaluated.
Even if the result is discarded, this would be a big performance problem,
@@ -1033,7 +1033,7 @@ You can prove a theorem `P n` about `n : Nat` by `induction n`, which will
expect a proof of the theorem for `P 0`, and a proof of `P (succ i)` assuming
a proof of `P i`. The same method also works to define functions by recursion
on natural numbers: induction and recursion are two expressions of the same
operation from Lean's point of view.
operation from lean's point of view.
```
open Nat
@@ -1069,14 +1069,14 @@ instance : Inhabited Nat where
/--
The class `OfNat α n` powers the numeric literal parser. If you write
`37 : α`, Lean will attempt to synthesize `OfNat α 37`, and will generate
`37 : α`, lean will attempt to synthesize `OfNat α 37`, and will generate
the term `(OfNat.ofNat 37 : α)`.
There is a bit of infinite regress here since the desugaring apparently
still contains a literal `37` in it. The type of expressions contains a
primitive constructor for "raw natural number literals", which you can directly
access using the macro `nat_lit 37`. Raw number literals are always of type `Nat`.
So it would be more correct to say that Lean looks for an instance of
So it would be more correct to say that lean looks for an instance of
`OfNat α (nat_lit 37)`, and it generates the term `(OfNat.ofNat (nat_lit 37) : α)`.
-/
class OfNat (α : Type u) (_ : Nat) where
@@ -1314,11 +1314,6 @@ class Mod (α : Type u) where
/-- `a % b` computes the remainder upon dividing `a` by `b`. See `HMod`. -/
mod : α α α
/-- Notation typeclass for the `` operation (typed as `\|`), which represents divisibility. -/
class Dvd (α : Type _) where
/-- Divisibility. `a b` (typed as `\|`) means that there is some `c` such that `b = a * c`. -/
dvd : α α Prop
/--
The homogeneous version of `HPow`: `a ^ b : α` where `a : α`, `b : β`.
(The right argument is not the same as the left since we often want this even
@@ -1785,7 +1780,7 @@ Gets the word size of the platform. That is, whether the platform is 64 or 32 bi
This function is opaque because we cannot guarantee at compile time that the target
will have the same size as the host, and also because we would like to avoid
typechecking being architecture-dependent. Nevertheless, Lean only works on
typechecking being architecture-dependent. Nevertheless, lean only works on
64 and 32 bit systems so we can encode this as a fact available for proof purposes.
-/
@[extern "lean_system_platform_nbits"] opaque System.Platform.getNumBits : Unit Subtype fun (n : Nat) => Or (Eq n 32) (Eq n 64) :=
@@ -2523,7 +2518,7 @@ attribute [nospecialize] Inhabited
/--
The class `GetElem cont idx elem dom` implements the `xs[i]` notation.
When you write this, given `xs : cont` and `i : idx`, Lean looks for an instance
When you write this, given `xs : cont` and `i : idx`, lean looks for an instance
of `GetElem cont idx elem dom`. Here `elem` is the type of `xs[i]`, while
`dom` is whatever proof side conditions are required to make this applicable.
For example, the instance for arrays looks like
@@ -2563,7 +2558,7 @@ export GetElem (getElem)
with elements from `α`. This type has special support in the runtime.
An array has a size and a capacity; the size is `Array.size` but the capacity
is not observable from Lean code. Arrays perform best when unshared; as long
is not observable from lean code. Arrays perform best when unshared; as long
as they are used "linearly" all updates will be performed destructively on the
array, so it has comparable performance to mutable arrays in imperative
programming languages.
@@ -3236,7 +3231,7 @@ instance (σ : Type u) (m : Type u → Type v) [MonadStateOf σ m] : MonadState
/--
`modify (f : σσ)` applies the function `f` to the state.
It is equivalent to `do set (f (← get))`, but `modify f` may be preferable
It is equivalent to `do put (f (← get))`, but `modify f` may be preferable
because the former does not use the state linearly (without sufficient inlining).
-/
@[always_inline, inline]

View File

@@ -1,192 +0,0 @@
/-
Copyright (c) 2017 Mario Carneiro. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Mario Carneiro, Jacob von Raumer
-/
prelude
import Init.Tactics
import Init.NotationExtra
/-!
# Recursive cases (`rcases`) tactic and related tactics
`rcases` is a tactic that will perform `cases` recursively, according to a pattern. It is used to
destructure hypotheses or expressions composed of inductive types like `h1 : a ∧ b ∧ c d` or
`h2 : ∃ x y, trans_rel R x y`. Usual usage might be `rcases h1 with ⟨ha, hb, hc⟩ | hd` or
`rcases h2 with ⟨x, y, _ | ⟨z, hxz, hzy⟩⟩` for these examples.
Each element of an `rcases` pattern is matched against a particular local hypothesis (most of which
are generated during the execution of `rcases` and represent individual elements destructured from
the input expression). An `rcases` pattern has the following grammar:
* A name like `x`, which names the active hypothesis as `x`.
* A blank `_`, which does nothing (letting the automatic naming system used by `cases` name the
hypothesis).
* A hyphen `-`, which clears the active hypothesis and any dependents.
* The keyword `rfl`, which expects the hypothesis to be `h : a = b`, and calls `subst` on the
hypothesis (which has the effect of replacing `b` with `a` everywhere or vice versa).
* A type ascription `p : ty`, which sets the type of the hypothesis to `ty` and then matches it
against `p`. (Of course, `ty` must unify with the actual type of `h` for this to work.)
* A tuple pattern `⟨p1, p2, p3⟩`, which matches a constructor with many arguments, or a series
of nested conjunctions or existentials. For example if the active hypothesis is `a ∧ b ∧ c`,
then the conjunction will be destructured, and `p1` will be matched against `a`, `p2` against `b`
and so on.
* A `@` before a tuple pattern as in `@⟨p1, p2, p3⟩` will bind all arguments in the constructor,
while leaving the `@` off will only use the patterns on the explicit arguments.
* An alternation pattern `p1 | p2 | p3`, which matches an inductive type with multiple constructors,
or a nested disjunction like `a b c`.
The patterns are fairly liberal about the exact shape of the constructors, and will insert
additional alternation branches and tuple arguments if there are not enough arguments provided, and
reuse the tail for further matches if there are too many arguments provided to alternation and
tuple patterns.
This file also contains the `obtain` and `rintro` tactics, which use the same syntax of `rcases`
patterns but with a slightly different use case:
* `rintro` (or `rintros`) is used like `rintro x ⟨y, z⟩` and is the same as `intros` followed by
`rcases` on the newly introduced arguments.
* `obtain` is the same as `rcases` but with a syntax styled after `have` rather than `cases`.
`obtain ⟨hx, hy⟩ | hz := foo` is equivalent to `rcases foo with ⟨hx, hy⟩ | hz`. Unlike `rcases`,
`obtain` also allows one to omit `:= foo`, although a type must be provided in this case,
as in `obtain ⟨hx, hy⟩ | hz : a ∧ b c`, in which case it produces a subgoal for proving
`a ∧ b c` in addition to the subgoals `hx : a, hy : b |- goal` and `hz : c |- goal`.
## Tags
rcases, rintro, obtain, destructuring, cases, pattern matching, match
-/
namespace Lean.Parser.Tactic
/-- The syntax category of `rcases` patterns. -/
declare_syntax_cat rcasesPat
/-- A medium precedence `rcases` pattern is a list of `rcasesPat` separated by `|` -/
syntax rcasesPatMed := sepBy1(rcasesPat, " | ")
/-- A low precedence `rcases` pattern is a `rcasesPatMed` optionally followed by `: ty` -/
syntax rcasesPatLo := rcasesPatMed (" : " term)?
/-- `x` is a pattern which binds `x` -/
syntax (name := rcasesPat.one) ident : rcasesPat
/-- `_` is a pattern which ignores the value and gives it an inaccessible name -/
syntax (name := rcasesPat.ignore) "_" : rcasesPat
/-- `-` is a pattern which removes the value from the context -/
syntax (name := rcasesPat.clear) "-" : rcasesPat
/--
A `@` before a tuple pattern as in `@⟨p1, p2, p3⟩` will bind all arguments in the constructor,
while leaving the `@` off will only use the patterns on the explicit arguments.
-/
syntax (name := rcasesPat.explicit) "@" noWs rcasesPat : rcasesPat
/--
`⟨pat, ...⟩` is a pattern which matches on a tuple-like constructor
or multi-argument inductive constructor
-/
syntax (name := rcasesPat.tuple) "" rcasesPatLo,* "" : rcasesPat
/-- `(pat)` is a pattern which resets the precedence to low -/
syntax (name := rcasesPat.paren) "(" rcasesPatLo ")" : rcasesPat
/-- The syntax category of `rintro` patterns. -/
declare_syntax_cat rintroPat
/-- An `rcases` pattern is an `rintro` pattern -/
syntax (name := rintroPat.one) rcasesPat : rintroPat
/--
A multi argument binder `(pat1 pat2 : ty)` binds a list of patterns and gives them all type `ty`.
-/
syntax (name := rintroPat.binder) (priority := default+1) -- to override rcasesPat.paren
"(" rintroPat+ (" : " term)? ")" : rintroPat
/- TODO
/--
`rcases? e` will perform case splits on `e` in the same way as `rcases e`,
but rather than accepting a pattern, it does a maximal cases and prints the
pattern that would produce this case splitting. The default maximum depth is 5,
but this can be modified with `rcases? e : n`.
-/
syntax (name := rcases?) "rcases?" casesTarget,* (" : " num)? : tactic
-/
/--
`rcases` is a tactic that will perform `cases` recursively, according to a pattern. It is used to
destructure hypotheses or expressions composed of inductive types like `h1 : a ∧ b ∧ c d` or
`h2 : ∃ x y, trans_rel R x y`. Usual usage might be `rcases h1 with ⟨ha, hb, hc⟩ | hd` or
`rcases h2 with ⟨x, y, _ | ⟨z, hxz, hzy⟩⟩` for these examples.
Each element of an `rcases` pattern is matched against a particular local hypothesis (most of which
are generated during the execution of `rcases` and represent individual elements destructured from
the input expression). An `rcases` pattern has the following grammar:
* A name like `x`, which names the active hypothesis as `x`.
* A blank `_`, which does nothing (letting the automatic naming system used by `cases` name the
hypothesis).
* A hyphen `-`, which clears the active hypothesis and any dependents.
* The keyword `rfl`, which expects the hypothesis to be `h : a = b`, and calls `subst` on the
hypothesis (which has the effect of replacing `b` with `a` everywhere or vice versa).
* A type ascription `p : ty`, which sets the type of the hypothesis to `ty` and then matches it
against `p`. (Of course, `ty` must unify with the actual type of `h` for this to work.)
* A tuple pattern `⟨p1, p2, p3⟩`, which matches a constructor with many arguments, or a series
of nested conjunctions or existentials. For example if the active hypothesis is `a ∧ b ∧ c`,
then the conjunction will be destructured, and `p1` will be matched against `a`, `p2` against `b`
and so on.
* A `@` before a tuple pattern as in `@⟨p1, p2, p3⟩` will bind all arguments in the constructor,
while leaving the `@` off will only use the patterns on the explicit arguments.
* An alteration pattern `p1 | p2 | p3`, which matches an inductive type with multiple constructors,
or a nested disjunction like `a b c`.
A pattern like `⟨a, b, c⟩ | ⟨d, e⟩` will do a split over the inductive datatype,
naming the first three parameters of the first constructor as `a,b,c` and the
first two of the second constructor `d,e`. If the list is not as long as the
number of arguments to the constructor or the number of constructors, the
remaining variables will be automatically named. If there are nested brackets
such as `⟨⟨a⟩, b | c⟩ | d` then these will cause more case splits as necessary.
If there are too many arguments, such as `⟨a, b, c⟩` for splitting on
`∃ x, ∃ y, p x`, then it will be treated as `⟨a, ⟨b, c⟩⟩`, splitting the last
parameter as necessary.
`rcases` also has special support for quotient types: quotient induction into Prop works like
matching on the constructor `quot.mk`.
`rcases h : e with PAT` will do the same as `rcases e with PAT` with the exception that an
assumption `h : e = PAT` will be added to the context.
-/
syntax (name := rcases) "rcases" casesTarget,* (" with " rcasesPatLo)? : tactic
/--
The `obtain` tactic is a combination of `have` and `rcases`. See `rcases` for
a description of supported patterns.
```lean
obtain ⟨patt⟩ : type := proof
```
is equivalent to
```lean
have h : type := proof
rcases h with ⟨patt⟩
```
If `⟨patt⟩` is omitted, `rcases` will try to infer the pattern.
If `type` is omitted, `:= proof` is required.
-/
syntax (name := obtain) "obtain" (ppSpace rcasesPatMed)? (" : " term)? (" := " term,+)? : tactic
/- TODO
/--
`rintro?` will introduce and case split on variables in the same way as
`rintro`, but will also print the `rintro` invocation that would have the same
result. Like `rcases?`, `rintro? : n` allows for modifying the
depth of splitting; the default is 5.
-/
syntax (name := rintro?) "rintro?" (" : " num)? : tactic
-/
/--
The `rintro` tactic is a combination of the `intros` tactic with `rcases` to
allow for destructuring patterns while introducing variables. See `rcases` for
a description of supported patterns. For example, `rintro (a | ⟨b, c⟩) ⟨d, e⟩`
will introduce two variables, and then do case splits on both of them producing
two subgoals, one with variables `a d e` and the other with `b c d e`.
`rintro`, unlike `rcases`, also supports the form `(x y : ty)` for introducing
and type-ascripting multiple variables at once, similar to binders.
-/
syntax (name := rintro) "rintro" (ppSpace colGt rintroPat)+ (" : " term)? : tactic
end Lean.Parser.Tactic

View File

@@ -29,7 +29,7 @@ simproc ↓ reduce_add (_ + _) := fun e => ...
```
Simplification procedures can be also scoped or local.
-/
syntax (docComment)? attrKind "simproc " (Tactic.simpPre <|> Tactic.simpPost)? ("[" ident,* "]")? ident " (" term ")" " := " term : command
syntax (docComment)? attrKind "simproc " (Tactic.simpPre <|> Tactic.simpPost)? ident " (" term ")" " := " term : command
/--
A user-defined simplification procedure declaration. To activate this procedure in `simp` tactic,
@@ -40,7 +40,7 @@ syntax (docComment)? "simproc_decl " ident " (" term ")" " := " term : command
/--
A builtin simplification procedure.
-/
syntax (docComment)? attrKind "builtin_simproc " (Tactic.simpPre <|> Tactic.simpPost)? ("[" ident,* "]")? ident " (" term ")" " := " term : command
syntax (docComment)? attrKind "builtin_simproc " (Tactic.simpPre <|> Tactic.simpPost)? ident " (" term ")" " := " term : command
/--
A builtin simplification procedure declaration.
@@ -63,21 +63,10 @@ Auxiliary attribute for simplification procedures.
-/
syntax (name := simprocAttr) "simproc" (Tactic.simpPre <|> Tactic.simpPost)? : attr
/--
Auxiliary attribute for symbolic evaluation procedures.
-/
syntax (name := sevalprocAttr) "sevalproc" (Tactic.simpPre <|> Tactic.simpPost)? : attr
/--
Auxiliary attribute for builtin simplification procedures.
-/
syntax (name := simprocBuiltinAttr) "builtin_simproc" (Tactic.simpPre <|> Tactic.simpPost)? : attr
/--
Auxiliary attribute for builtin symbolic evaluation procedures.
-/
syntax (name := sevalprocBuiltinAttr) "builtin_sevalproc" (Tactic.simpPre <|> Tactic.simpPost)? : attr
end Attr
macro_rules
@@ -93,37 +82,13 @@ macro_rules
builtin_simproc_pattern% $pattern => $n)
macro_rules
| `($[$doc?:docComment]? $kind:attrKind simproc $[$pre?]? $[ [ $ids?:ident,* ] ]? $n:ident ($pattern:term) := $body) => do
let mut cmds := #[( `($[$doc?:docComment]? simproc_decl $n ($pattern) := $body))]
let pushDefault (cmds : Array (TSyntax `command)) : MacroM (Array (TSyntax `command)) := do
return cmds.push ( `(attribute [$kind simproc $[$pre?]?] $n))
if let some ids := ids? then
for id in ids.getElems do
let idName := id.getId
let (attrName, attrKey) :=
if idName == `simp then
(`simprocAttr, "simproc")
else if idName == `seval then
(`sevalprocAttr, "sevalproc")
else
let idName := idName.appendAfter "_proc"
(`Parser.Attr ++ idName, idName.toString)
let attrStx : TSyntax `attr := mkNode attrName #[mkAtom attrKey, mkOptionalNode pre?]
cmds := cmds.push ( `(attribute [$kind $attrStx] $n))
else
cmds pushDefault cmds
return mkNullNode cmds
| `($[$doc?:docComment]? $kind:attrKind simproc $[$pre?]? $n:ident ($pattern:term) := $body) => do
`(simproc_decl $n ($pattern) := $body
attribute [$kind simproc $[$pre?]?] $n)
macro_rules
| `($[$doc?:docComment]? $kind:attrKind builtin_simproc $[$pre?]? $n:ident ($pattern:term) := $body) => do
`($[$doc?:docComment]? builtin_simproc_decl $n ($pattern) := $body
`(builtin_simproc_decl $n ($pattern) := $body
attribute [$kind builtin_simproc $[$pre?]?] $n)
| `($[$doc?:docComment]? $kind:attrKind builtin_simproc $[$pre?]? [seval] $n:ident ($pattern:term) := $body) => do
`($[$doc?:docComment]? builtin_simproc_decl $n ($pattern) := $body
attribute [$kind builtin_sevalproc $[$pre?]?] $n)
| `($[$doc?:docComment]? $kind:attrKind builtin_simproc $[$pre?]? [simp, seval] $n:ident ($pattern:term) := $body) => do
`($[$doc?:docComment]? builtin_simproc_decl $n ($pattern) := $body
attribute [$kind builtin_simproc $[$pre?]?] $n
attribute [$kind builtin_sevalproc $[$pre?]?] $n)
end Lean.Parser

View File

@@ -101,21 +101,6 @@ def withFileName (p : FilePath) (fname : String) : FilePath :=
| none => fname
| some p => p / fname
/-- Appends the extension `ext` to a path `p`.
`ext` should not contain a leading `.`, as this function adds one.
If `ext` is the empty string, no `.` is added.
Unlike `System.FilePath.withExtension`, this does not remove any existing extension. -/
def addExtension (p : FilePath) (ext : String) : FilePath :=
match p.fileName with
| none => p
| some fname => p.withFileName (if ext.isEmpty then fname else fname ++ "." ++ ext)
/-- Replace the current extension in a path `p` with `ext`.
`ext` should not contain a `.`, as this function adds one.
If `ext` is the empty string, no `.` is added. -/
def withExtension (p : FilePath) (ext : String) : FilePath :=
match p.fileStem with
| none => p

View File

@@ -117,23 +117,20 @@ opaque asTask (act : BaseIO α) (prio := Task.Priority.default) : BaseIO (Task
/-- See `BaseIO.asTask`. -/
@[extern "lean_io_map_task"]
opaque mapTask (f : α BaseIO β) (t : Task α) (prio := Task.Priority.default) (sync := false) :
BaseIO (Task β) :=
opaque mapTask (f : α BaseIO β) (t : Task α) (prio := Task.Priority.default) : BaseIO (Task β) :=
Task.pure <$> f t.get
/-- See `BaseIO.asTask`. -/
@[extern "lean_io_bind_task"]
opaque bindTask (t : Task α) (f : α BaseIO (Task β)) (prio := Task.Priority.default)
(sync := false) : BaseIO (Task β) :=
opaque bindTask (t : Task α) (f : α BaseIO (Task β)) (prio := Task.Priority.default) : BaseIO (Task β) :=
f t.get
def mapTasks (f : List α BaseIO β) (tasks : List (Task α)) (prio := Task.Priority.default)
(sync := false) : BaseIO (Task β) :=
def mapTasks (f : List α BaseIO β) (tasks : List (Task α)) (prio := Task.Priority.default) : BaseIO (Task β) :=
go tasks []
where
go
| t::ts, as =>
BaseIO.bindTask t (fun a => go ts (a :: as)) prio sync
BaseIO.bindTask t (fun a => go ts (a :: as)) prio
| [], as => f as.reverse |>.asTask prio
end BaseIO
@@ -145,20 +142,16 @@ namespace EIO
act.toBaseIO.asTask prio
/-- `EIO` specialization of `BaseIO.mapTask`. -/
@[inline] def mapTask (f : α EIO ε β) (t : Task α) (prio := Task.Priority.default)
(sync := false) : BaseIO (Task (Except ε β)) :=
BaseIO.mapTask (fun a => f a |>.toBaseIO) t prio sync
@[inline] def mapTask (f : α EIO ε β) (t : Task α) (prio := Task.Priority.default) : BaseIO (Task (Except ε β)) :=
BaseIO.mapTask (fun a => f a |>.toBaseIO) t prio
/-- `EIO` specialization of `BaseIO.bindTask`. -/
@[inline] def bindTask (t : Task α) (f : α EIO ε (Task (Except ε β)))
(prio := Task.Priority.default) (sync := false) : BaseIO (Task (Except ε β)) :=
BaseIO.bindTask t (fun a => f a |>.catchExceptions fun e => return Task.pure <| Except.error e)
prio sync
@[inline] def bindTask (t : Task α) (f : α EIO ε (Task (Except ε β))) (prio := Task.Priority.default) : BaseIO (Task (Except ε β)) :=
BaseIO.bindTask t (fun a => f a |>.catchExceptions fun e => return Task.pure <| Except.error e) prio
/-- `EIO` specialization of `BaseIO.mapTasks`. -/
@[inline] def mapTasks (f : List α EIO ε β) (tasks : List (Task α))
(prio := Task.Priority.default) (sync := false) : BaseIO (Task (Except ε β)) :=
BaseIO.mapTasks (fun as => f as |>.toBaseIO) tasks prio sync
@[inline] def mapTasks (f : List α EIO ε β) (tasks : List (Task α)) (prio := Task.Priority.default) : BaseIO (Task (Except ε β)) :=
BaseIO.mapTasks (fun as => f as |>.toBaseIO) tasks prio
end EIO
@@ -191,19 +184,16 @@ def sleep (ms : UInt32) : BaseIO Unit :=
EIO.asTask act prio
/-- `IO` specialization of `EIO.mapTask`. -/
@[inline] def mapTask (f : α IO β) (t : Task α) (prio := Task.Priority.default) (sync := false) :
BaseIO (Task (Except IO.Error β)) :=
EIO.mapTask f t prio sync
@[inline] def mapTask (f : α IO β) (t : Task α) (prio := Task.Priority.default) : BaseIO (Task (Except IO.Error β)) :=
EIO.mapTask f t prio
/-- `IO` specialization of `EIO.bindTask`. -/
@[inline] def bindTask (t : Task α) (f : α IO (Task (Except IO.Error β)))
(prio := Task.Priority.default) (sync := false) : BaseIO (Task (Except IO.Error β)) :=
EIO.bindTask t f prio sync
@[inline] def bindTask (t : Task α) (f : α IO (Task (Except IO.Error β))) (prio := Task.Priority.default) : BaseIO (Task (Except IO.Error β)) :=
EIO.bindTask t f prio
/-- `IO` specialization of `EIO.mapTasks`. -/
@[inline] def mapTasks (f : List α IO β) (tasks : List (Task α)) (prio := Task.Priority.default)
(sync := false) : BaseIO (Task (Except IO.Error β)) :=
EIO.mapTasks f tasks prio sync
@[inline] def mapTasks (f : List α IO β) (tasks : List (Task α)) (prio := Task.Priority.default) : BaseIO (Task (Except IO.Error β)) :=
EIO.mapTasks f tasks prio
/-- Check if the task's cancellation flag has been set by calling `IO.cancel` or dropping the last reference to the task. -/
@[extern "lean_io_check_canceled"] opaque checkCanceled : BaseIO Bool

View File

@@ -5,7 +5,6 @@ Authors: Leonardo de Moura
-/
prelude
import Init.Data.Nat.Basic
import Init.Data.String.Basic
namespace System
namespace Platform
@@ -18,10 +17,5 @@ def isWindows : Bool := getIsWindows ()
def isOSX : Bool := getIsOSX ()
def isEmscripten : Bool := getIsEmscripten ()
@[extern "lean_system_platform_target"] opaque getTarget : Unit String
/-- The LLVM target triple of the current platform. Empty if missing at Lean compile time. -/
def target : String := getTarget ()
end Platform
end System

View File

@@ -6,15 +6,11 @@ Authors: Gabriel Ebner
prelude
import Init.System.IO
set_option linter.missingDocs true
namespace IO
private opaque PromisePointed : NonemptyType.{0}
private structure PromiseImpl (α : Type) : Type where
prom : PromisePointed.type
h : Nonempty α
/-- Internally, a `Promise` is just a `Task` that is in the "Promised" or "Finished" state. -/
private opaque PromiseImpl (α : Type) : { P : Type // Nonempty α Nonempty P } :=
Task α, fun _ => _, fun _ => _
/--
`Promise α` allows you to create a `Task α` whose value is provided later by calling `resolve`.
@@ -30,10 +26,10 @@ Every promise must eventually be resolved.
Otherwise the memory used for the promise will be leaked,
and any tasks depending on the promise's result will wait forever.
-/
def Promise (α : Type) : Type := PromiseImpl α
def Promise (α : Type) : Type := (PromiseImpl α).1
instance [s : Nonempty α] : Nonempty (Promise α) :=
Nonempty.intro { prom := Classical.choice PromisePointed.property, h := s }
instance [Nonempty α] : Nonempty (Promise α) :=
(PromiseImpl α).2.1 inferInstance
/-- Creates a new `Promise`. -/
@[extern "lean_io_promise_new"]
@@ -47,12 +43,15 @@ Only the first call to this function has an effect.
@[extern "lean_io_promise_resolve"]
opaque Promise.resolve (value : α) (promise : @& Promise α) : BaseIO Unit
private unsafe def Promise.resultImpl (promise : Promise α) : Task α :=
unsafeCast promise
/--
The result task of a `Promise`.
The task blocks until `Promise.resolve` is called.
-/
@[extern "lean_io_promise_result"]
@[implemented_by Promise.resultImpl]
opaque Promise.result (promise : Promise α) : Task α :=
have : Nonempty α := promise.h
have : Nonempty α := (PromiseImpl α).2.2 promise
Classical.choice inferInstance

View File

@@ -39,75 +39,8 @@ be a `let` or function type.
syntax (name := intro) "intro" notFollowedBy("|") (ppSpace colGt term:max)* : tactic
/--
Introduces zero or more hypotheses, optionally naming them.
- `intros` is equivalent to repeatedly applying `intro`
until the goal is not an obvious candidate for `intro`, which is to say
that so long as the goal is a `let` or a pi type (e.g. an implication, function, or universal quantifier),
the `intros` tactic will introduce an anonymous hypothesis.
This tactic does not unfold definitions.
- `intros x y ...` is equivalent to `intro x y ...`,
introducing hypotheses for each supplied argument and unfolding definitions as necessary.
Each argument can be either an identifier or a `_`.
An identifier indicates a name to use for the corresponding introduced hypothesis,
and a `_` indicates that the hypotheses should be introduced anonymously.
## Examples
Basic properties:
```lean
def AllEven (f : Nat → Nat) := ∀ n, f n % 2 = 0
-- Introduces the two obvious hypotheses automatically
example : ∀ (f : Nat → Nat), AllEven f → AllEven (fun k => f (k + 1)) := by
intros
/- Tactic state
f✝ : Nat → Nat
a✝ : AllEven f✝
⊢ AllEven fun k => f✝ (k + 1) -/
sorry
-- Introduces exactly two hypotheses, naming only the first
example : (f : Nat Nat), AllEven f AllEven (fun k => f (k + 1)) := by
intros g _
/- Tactic state
g : Nat → Nat
a✝ : AllEven g
⊢ AllEven fun k => g (k + 1) -/
sorry
-- Introduces exactly three hypotheses, which requires unfolding `AllEven`
example : (f : Nat Nat), AllEven f AllEven (fun k => f (k + 1)) := by
intros f h n
/- Tactic state
f : Nat → Nat
h : AllEven f
n : Nat
⊢ (fun k => f (k + 1)) n % 2 = 0 -/
apply h
```
Implications:
```lean
example (p q : Prop) : p q p := by
intros
/- Tactic state
a✝¹ : p
a✝ : q
⊢ p -/
assumption
```
Let bindings:
```lean
example : let n := 1; let k := 2; n + k = 3 := by
intros
/- n✝ : Nat := 1
k✝ : Nat := 2
⊢ n✝ + k✝ = 3 -/
rfl
```
`intros x...` behaves like `intro x...`, but then keeps introducing (anonymous)
hypotheses until goal is not of a function type.
-/
syntax (name := intros) "intros" (ppSpace colGt (ident <|> hole))* : tactic
@@ -207,28 +140,6 @@ the first matching constructor, or else fails.
-/
syntax (name := constructor) "constructor" : tactic
/--
Applies the second constructor when
the goal is an inductive type with exactly two constructors, or fails otherwise.
```
example : True False := by
left
trivial
```
-/
syntax (name := left) "left" : tactic
/--
Applies the second constructor when
the goal is an inductive type with exactly two constructors, or fails otherwise.
```
example {p q : Prop} (h : q) : p q := by
right
exact h
```
-/
syntax (name := right) "right" : tactic
/--
* `case tag => tac` focuses on the goal with case name `tag` and solves it using `tac`,
or else fails.
@@ -345,14 +256,9 @@ syntax (name := eqRefl) "eq_refl" : tactic
`rfl` tries to close the current goal using reflexivity.
This is supposed to be an extensible tactic and users can add their own support
for new reflexive relations.
Remark: `rfl` is an extensible tactic. We later add `macro_rules` to try different
reflexivity theorems (e.g., `Iff.rfl`).
-/
macro "rfl" : tactic => `(tactic| eq_refl)
macro_rules | `(tactic| rfl) => `(tactic| exact HEq.rfl)
/--
`rfl'` is similar to `rfl`, but disables smart unfolding and unfolds all kinds of definitions,
theorems included (relevant for declarations defined by well-founded recursion).
@@ -362,8 +268,8 @@ macro "rfl'" : tactic => `(tactic| set_option smartUnfolding false in with_unfol
/--
`ac_rfl` proves equalities up to application of an associative and commutative operator.
```
instance : Associative (α := Nat) (.+.) := ⟨Nat.add_assoc⟩
instance : Commutative (α := Nat) (.+.) := ⟨Nat.add_comm⟩
instance : IsAssociative (α := Nat) (.+.) := ⟨Nat.add_assoc⟩
instance : IsCommutative (α := Nat) (.+.) := ⟨Nat.add_comm⟩
example (a b c d : Nat) : a + b + c + d = d + (b + c) + a := by ac_rfl
```
@@ -398,7 +304,7 @@ syntax locationWildcard := " *"
A hypothesis location specification consists of 1 or more hypothesis references
and optionally `⊢` denoting the goal.
-/
syntax locationHyp := (ppSpace colGt term:max)+ patternIgnore(ppSpace (atomic("|" noWs "-") <|> ""))?
syntax locationHyp := (ppSpace colGt term:max)+ ppSpace patternIgnore( atomic("|" noWs "-") <|> "")?
/--
Location specifications are used by many tactics that can operate on either the
@@ -459,17 +365,13 @@ syntax (name := rewriteSeq) "rewrite" (config)? rwRuleSeq (location)? : tactic
/--
`rw` is like `rewrite`, but also tries to close the goal by "cheap" (reducible) `rfl` afterwards.
-/
macro (name := rwSeq) "rw " c:(config)? s:rwRuleSeq l:(location)? : tactic =>
macro (name := rwSeq) "rw" c:(config)? s:rwRuleSeq l:(location)? : tactic =>
match s with
| `(rwRuleSeq| [$rs,*]%$rbrak) =>
-- We show the `rfl` state on `]`
`(tactic| (rewrite $(c)? [$rs,*] $(l)?; with_annotate_state $rbrak (try (with_reducible rfl))))
| _ => Macro.throwUnsupported
/-- `rwa` calls `rw`, then closes any remaining goals using `assumption`. -/
macro "rwa " rws:rwRuleSeq loc:(location)? : tactic =>
`(tactic| (rw $rws:rwRuleSeq $[$loc:location]?; assumption))
/--
The `injection` tactic is based on the fact that constructors of inductive data
types are injections.
@@ -657,7 +559,7 @@ You can use `with` to provide the variables names for each constructor.
- `induction e`, where `e` is an expression instead of a variable,
generalizes `e` in the goal, and then performs induction on the resulting variable.
- `induction e using r` allows the user to specify the principle of induction that should be used.
Here `r` should be a term whose result type must be of the form `C t`,
Here `r` should be a theorem whose result type must be of the form `C t`,
where `C` is a bound variable and `t` is a (possibly empty) sequence of bound variables
- `induction e generalizing z₁ ... zₙ`, where `z₁ ... zₙ` are variables in the local context,
generalizes over `z₁ ... zₙ` before applying the induction but then introduces them in each goal.
@@ -665,7 +567,7 @@ You can use `with` to provide the variables names for each constructor.
- Given `x : Nat`, `induction x with | zero => tac₁ | succ x' ih => tac₂`
uses tactic `tac₁` for the `zero` case, and `tac₂` for the `succ` case.
-/
syntax (name := induction) "induction " term,+ (" using " term)?
syntax (name := induction) "induction " term,+ (" using " ident)?
(" generalizing" (ppSpace colGt term:max)+)? (inductionAlts)? : tactic
/-- A `generalize` argument, of the form `term = x` or `h : term = x`. -/
@@ -708,7 +610,7 @@ You can use `with` to provide the variables names for each constructor.
performs cases on `e` as above, but also adds a hypothesis `h : e = ...` to each hypothesis,
where `...` is the constructor instance for that particular case.
-/
syntax (name := cases) "cases " casesTarget,+ (" using " term)? (inductionAlts)? : tactic
syntax (name := cases) "cases " casesTarget,+ (" using " ident)? (inductionAlts)? : tactic
/-- `rename_i x_1 ... x_n` renames the last `n` inaccessible names using the given names. -/
syntax (name := renameI) "rename_i" (ppSpace colGt binderIdent)+ : tactic
@@ -847,100 +749,6 @@ while `congr 2` produces the intended `⊢ x + y = y + x`.
-/
syntax (name := congr) "congr" (ppSpace num)? : tactic
/--
In tactic mode, `if h : t then tac1 else tac2` can be used as alternative syntax for:
```
by_cases h : t
· tac1
· tac2
```
It performs case distinction on `h : t` or `h : ¬t` and `tac1` and `tac2` are the subproofs.
You can use `?_` or `_` for either subproof to delay the goal to after the tactic, but
if a tactic sequence is provided for `tac1` or `tac2` then it will require the goal to be closed
by the end of the block.
-/
syntax (name := tacDepIfThenElse)
ppRealGroup(ppRealFill(ppIndent("if " binderIdent " : " term " then") ppSpace matchRhsTacticSeq)
ppDedent(ppSpace) ppRealFill("else " matchRhsTacticSeq)) : tactic
/--
In tactic mode, `if t then tac1 else tac2` is alternative syntax for:
```
by_cases t
· tac1
· tac2
```
It performs case distinction on `h† : t` or `h† : ¬t`, where `h†` is an anonymous
hypothesis, and `tac1` and `tac2` are the subproofs. (It doesn't actually use
nondependent `if`, since this wouldn't add anything to the context and hence would be
useless for proving theorems. To actually insert an `ite` application use
`refine if t then ?_ else ?_`.)
-/
syntax (name := tacIfThenElse)
ppRealGroup(ppRealFill(ppIndent("if " term " then") ppSpace matchRhsTacticSeq)
ppDedent(ppSpace) ppRealFill("else " matchRhsTacticSeq)) : tactic
/--
The tactic `nofun` is shorthand for `exact nofun`: it introduces the assumptions, then performs an
empty pattern match, closing the goal if the introduced pattern is impossible.
-/
macro "nofun" : tactic => `(tactic| exact nofun)
/--
The tactic `nomatch h` is shorthand for `exact nomatch h`.
-/
macro "nomatch " es:term,+ : tactic =>
`(tactic| exact nomatch $es:term,*)
/--
Acts like `have`, but removes a hypothesis with the same name as
this one if possible. For example, if the state is:
```lean
f : α → β
h : α
⊢ goal
```
Then after `replace h := f h` the state will be:
```lean
f : α → β
h : β
⊢ goal
```
whereas `have h := f h` would result in:
```lean
f : α → β
h† : α
h : β
⊢ goal
```
This can be used to simulate the `specialize` and `apply at` tactics of Coq.
-/
syntax (name := replace) "replace" haveDecl : tactic
/--
`repeat' tac` runs `tac` on all of the goals to produce a new list of goals,
then runs `tac` again on all of those goals, and repeats until `tac` fails on all remaining goals.
-/
syntax (name := repeat') "repeat' " tacticSeq : tactic
/--
`repeat1' tac` applies `tac` to main goal at least once. If the application succeeds,
the tactic is applied recursively to the generated subgoals until it eventually fails.
-/
syntax (name := repeat1') "repeat1' " tacticSeq : tactic
/-- `and_intros` applies `And.intro` until it does not make progress. -/
syntax "and_intros" : tactic
macro_rules | `(tactic| and_intros) => `(tactic| repeat' refine And.intro ?_ ?_)
end Tactic
namespace Attr

View File

@@ -1,66 +0,0 @@
/-
Copyright (c) 2024 Amazon.com, Inc. or its affiliates. All Rights Reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Leonardo de Moura, Mario Carneiro
-/
prelude
import Init.Tactics
import Init.NotationExtra
/-!
Extra tactics and implementation for some tactics defined at `Init/Tactic.lean`
-/
namespace Lean.Parser.Tactic
private def expandIfThenElse
(ifTk thenTk elseTk pos neg : Syntax)
(mkIf : Term Term MacroM Term) : MacroM (TSyntax `tactic) := do
let mkCase tk holeOrTacticSeq mkName : MacroM (Term × Array (TSyntax `tactic)) := do
if holeOrTacticSeq.isOfKind `Lean.Parser.Term.syntheticHole then
pure (holeOrTacticSeq, #[])
else if holeOrTacticSeq.isOfKind `Lean.Parser.Term.hole then
pure ( mkName, #[])
else
let hole withFreshMacroScope mkName
let holeId := hole.raw[1]
let case (open TSyntax.Compat in `(tactic|
case $holeId:ident =>%$tk
-- annotate `then/else` with state after `case`
with_annotate_state $tk skip
$holeOrTacticSeq))
pure (hole, #[case])
let (posHole, posCase) mkCase thenTk pos `(?pos)
let (negHole, negCase) mkCase elseTk neg `(?neg)
`(tactic| (open Classical in refine%$ifTk $( mkIf posHole negHole); $[$(posCase ++ negCase)]*))
macro_rules
| `(tactic| if%$tk $h : $c then%$ttk $pos else%$etk $neg) =>
expandIfThenElse tk ttk etk pos neg fun pos neg => `(if $h : $c then $pos else $neg)
macro_rules
| `(tactic| if%$tk $c then%$ttk $pos else%$etk $neg) =>
expandIfThenElse tk ttk etk pos neg fun pos neg => `(if h : $c then $pos else $neg)
/--
`iterate n tac` runs `tac` exactly `n` times.
`iterate tac` runs `tac` repeatedly until failure.
`iterate`'s argument is a tactic sequence,
so multiple tactics can be run using `iterate n (tac₁; tac₂; ⋯)` or
```lean
iterate n
tac₁
tac₂
```
-/
syntax "iterate" (ppSpace num)? ppSpace tacticSeq : tactic
macro_rules
| `(tactic| iterate $seq:tacticSeq) =>
`(tactic| try ($seq:tacticSeq); iterate $seq:tacticSeq)
| `(tactic| iterate $n $seq:tacticSeq) =>
match n.1.toNat with
| 0 => `(tactic| skip)
| n+1 => `(tactic| ($seq:tacticSeq); iterate $(quote n) $seq:tacticSeq)
end Lean.Parser.Tactic

View File

@@ -25,13 +25,9 @@ def leanMainFn := "_lean_main"
namespace LLVM
-- TODO(bollu): instantiate target triple and find out what size_t is.
def size_tType (llvmctx : LLVM.Context) : BaseIO (LLVM.LLVMType llvmctx) :=
def size_tType (llvmctx : LLVM.Context) : IO (LLVM.LLVMType llvmctx) :=
LLVM.i64Type llvmctx
-- TODO(bollu): instantiate target triple and find out what unsigned is.
def unsignedType (llvmctx : LLVM.Context) : BaseIO (LLVM.LLVMType llvmctx) :=
LLVM.i32Type llvmctx
-- Helper to add a function if it does not exist, and to return the function handle if it does.
def getOrAddFunction (m : LLVM.Module ctx) (name : String) (type : LLVM.LLVMType ctx) : BaseIO (LLVM.Value ctx) := do
match ( LLVM.getNamedFunction m name) with
@@ -100,15 +96,6 @@ def getDecl (n : Name) : M llvmctx Decl := do
| some d => pure d
| none => throw s!"unknown declaration {n}"
def constInt8 (n : Nat) : M llvmctx (LLVM.Value llvmctx) := do
LLVM.constInt8 llvmctx (UInt64.ofNat n)
def constInt64 (n : Nat) : M llvmctx (LLVM.Value llvmctx) := do
LLVM.constInt64 llvmctx (UInt64.ofNat n)
def constIntSizeT (n : Nat) : M llvmctx (LLVM.Value llvmctx) := do
LLVM.constIntSizeT llvmctx (UInt64.ofNat n)
def constIntUnsigned (n : Nat) : M llvmctx (LLVM.Value llvmctx) := do
LLVM.constIntUnsigned llvmctx (UInt64.ofNat n)
@@ -175,14 +162,14 @@ def callLeanUnsignedToNatFn (builder : LLVM.Builder llvmctx)
let retty LLVM.voidPtrType llvmctx
let f getOrCreateFunctionPrototype mod retty "lean_unsigned_to_nat" argtys
let fnty LLVM.functionType retty argtys
let nv constIntUnsigned n
let nv LLVM.constInt32 llvmctx (UInt64.ofNat n)
LLVM.buildCall2 builder fnty f #[nv] name
def callLeanMkStringFromBytesFn (builder : LLVM.Builder llvmctx)
(strPtr nBytes : LLVM.Value llvmctx) (name : String) : M llvmctx (LLVM.Value llvmctx) := do
let fnName := "lean_mk_string_from_bytes"
let retty LLVM.voidPtrType llvmctx
let argtys := #[ LLVM.voidPtrType llvmctx, LLVM.size_tType llvmctx]
let argtys := #[ LLVM.voidPtrType llvmctx, LLVM.i64Type llvmctx]
let fn getOrCreateFunctionPrototype ( getLLVMModule) retty fnName argtys
let fnty LLVM.functionType retty argtys
LLVM.buildCall2 builder fnty fn #[strPtr, nBytes] name
@@ -231,9 +218,9 @@ def callLeanAllocCtor (builder : LLVM.Builder llvmctx)
let fn getOrCreateFunctionPrototype ( getLLVMModule) retty fnName argtys
let fnty LLVM.functionType retty argtys
let tag constIntUnsigned tag
let num_objs constIntUnsigned num_objs
let scalar_sz constIntUnsigned scalar_sz
let tag LLVM.constInt32 llvmctx (UInt64.ofNat tag)
let num_objs LLVM.constInt32 llvmctx (UInt64.ofNat num_objs)
let scalar_sz LLVM.constInt32 llvmctx (UInt64.ofNat scalar_sz)
LLVM.buildCall2 builder fnty fn #[tag, num_objs, scalar_sz] name
def callLeanCtorSet (builder : LLVM.Builder llvmctx)
@@ -241,7 +228,7 @@ def callLeanCtorSet (builder : LLVM.Builder llvmctx)
let fnName := "lean_ctor_set"
let retty LLVM.voidType llvmctx
let voidptr LLVM.voidPtrType llvmctx
let unsigned LLVM.unsignedType llvmctx
let unsigned LLVM.size_tType llvmctx
let argtys := #[voidptr, unsigned, voidptr]
let fn getOrCreateFunctionPrototype ( getLLVMModule) retty fnName argtys
let fnty LLVM.functionType retty argtys
@@ -261,7 +248,7 @@ def callLeanAllocClosureFn (builder : LLVM.Builder llvmctx)
(f arity nys : LLVM.Value llvmctx) (retName : String := "") : M llvmctx (LLVM.Value llvmctx) := do
let fnName := "lean_alloc_closure"
let retty LLVM.voidPtrType llvmctx
let argtys := #[ LLVM.voidPtrType llvmctx, LLVM.unsignedType llvmctx, LLVM.unsignedType llvmctx]
let argtys := #[ LLVM.voidPtrType llvmctx, LLVM.size_tType llvmctx, LLVM.size_tType llvmctx]
let fn getOrCreateFunctionPrototype ( getLLVMModule) retty fnName argtys
let fnty LLVM.functionType retty argtys
LLVM.buildCall2 builder fnty fn #[f, arity, nys] retName
@@ -270,7 +257,7 @@ def callLeanClosureSetFn (builder : LLVM.Builder llvmctx)
(closure ix arg : LLVM.Value llvmctx) (retName : String := "") : M llvmctx Unit := do
let fnName := "lean_closure_set"
let retty LLVM.voidType llvmctx
let argtys := #[ LLVM.voidPtrType llvmctx, LLVM.unsignedType llvmctx, LLVM.voidPtrType llvmctx]
let argtys := #[ LLVM.voidPtrType llvmctx, LLVM.size_tType llvmctx, LLVM.voidPtrType llvmctx]
let fn getOrCreateFunctionPrototype ( getLLVMModule) retty fnName argtys
let fnty LLVM.functionType retty argtys
let _ LLVM.buildCall2 builder fnty fn #[closure, ix, arg] retName
@@ -298,7 +285,7 @@ def callLeanCtorRelease (builder : LLVM.Builder llvmctx)
(closure i : LLVM.Value llvmctx) (retName : String := "") : M llvmctx Unit := do
let fnName := "lean_ctor_release"
let retty LLVM.voidType llvmctx
let argtys := #[ LLVM.voidPtrType llvmctx, LLVM.unsignedType llvmctx]
let argtys := #[ LLVM.voidPtrType llvmctx, LLVM.size_tType llvmctx]
let fn getOrCreateFunctionPrototype ( getLLVMModule) retty fnName argtys
let fnty LLVM.functionType retty argtys
let _ LLVM.buildCall2 builder fnty fn #[closure, i] retName
@@ -307,7 +294,7 @@ def callLeanCtorSetTag (builder : LLVM.Builder llvmctx)
(closure i : LLVM.Value llvmctx) (retName : String := "") : M llvmctx Unit := do
let fnName := "lean_ctor_set_tag"
let retty LLVM.voidType llvmctx
let argtys := #[ LLVM.voidPtrType llvmctx, LLVM.i8Type llvmctx]
let argtys := #[ LLVM.voidPtrType llvmctx, LLVM.size_tType llvmctx]
let fn getOrCreateFunctionPrototype ( getLLVMModule) retty fnName argtys
let fnty LLVM.functionType retty argtys
let _ LLVM.buildCall2 builder fnty fn #[closure, i] retName
@@ -360,31 +347,6 @@ def builderAppendBasicBlock (builder : LLVM.Builder llvmctx) (name : String) : M
let fn builderGetInsertionFn builder
LLVM.appendBasicBlockInContext llvmctx fn name
/--
Add an alloca to the first BB of the current function. The builders final position
will be the end of the BB that we came from.
If it is possible to put an alloca in the first BB this approach is to be preferred
over putting it in other BBs. This is because mem2reg only inspects allocas in the first BB,
leading to missed optimizations for allocas in other BBs.
-/
def buildPrologueAlloca (builder : LLVM.Builder llvmctx) (ty : LLVM.LLVMType llvmctx) (name : @&String := "") : M llvmctx (LLVM.Value llvmctx) := do
let origBB LLVM.getInsertBlock builder
let fn builderGetInsertionFn builder
if ( LLVM.countBasicBlocks fn) == 0 then
throw "Attempt to obtain first BB of function without BBs"
let entryBB LLVM.getEntryBasicBlock fn
match LLVM.getFirstInstruction entryBB with
| some instr => LLVM.positionBuilderBefore builder instr
| none => LLVM.positionBuilderAtEnd builder entryBB
let alloca LLVM.buildAlloca builder ty name
LLVM.positionBuilderAtEnd builder origBB
return alloca
def buildWhile_ (builder : LLVM.Builder llvmctx) (name : String)
(condcodegen : LLVM.Builder llvmctx M llvmctx (LLVM.Value llvmctx))
(bodycodegen : LLVM.Builder llvmctx M llvmctx Unit) : M llvmctx Unit := do
@@ -466,7 +428,7 @@ def buildIfThenElse_ (builder : LLVM.Builder llvmctx) (name : String) (brval :
-- Recall that lean uses `i8` for booleans, not `i1`, so we need to compare with `true`.
def buildLeanBoolTrue? (builder : LLVM.Builder llvmctx)
(b : LLVM.Value llvmctx) (name : String := "") : M llvmctx (LLVM.Value llvmctx) := do
LLVM.buildICmp builder LLVM.IntPredicate.NE b ( constInt8 0) name
LLVM.buildICmp builder LLVM.IntPredicate.NE b ( LLVM.constInt8 llvmctx 0) name
def emitFnDeclAux (mod : LLVM.Module llvmctx)
(decl : Decl) (cppBaseName : String) (isExternal : Bool) : M llvmctx (LLVM.Value llvmctx) := do
@@ -551,8 +513,8 @@ def emitArgSlot_ (builder : LLVM.Builder llvmctx)
| Arg.var x => emitLhsSlot_ x
| _ => do
let slotty LLVM.voidPtrType llvmctx
let slot buildPrologueAlloca builder slotty "irrelevant_slot"
let v callLeanBox builder ( constIntSizeT 0) "irrelevant_val"
let slot LLVM.buildAlloca builder slotty "irrelevant_slot"
let v callLeanBox builder ( LLVM.constIntUnsigned llvmctx 0) "irrelevant_val"
let _ LLVM.buildStore builder v slot
return (slotty, slot)
@@ -574,7 +536,7 @@ def emitCtorSetArgs (builder : LLVM.Builder llvmctx)
ys.size.forM fun i => do
let zv emitLhsVal builder z
let (_yty, yv) emitArgVal builder ys[i]!
let iv constIntUnsigned i
let iv LLVM.constIntUnsigned llvmctx (UInt64.ofNat i)
callLeanCtorSet builder zv iv yv
emitLhsSlotStore builder z zv
pure ()
@@ -583,7 +545,7 @@ def emitCtor (builder : LLVM.Builder llvmctx)
(z : VarId) (c : CtorInfo) (ys : Array Arg) : M llvmctx Unit := do
let (_llvmty, slot) emitLhsSlot_ z
if c.size == 0 && c.usize == 0 && c.ssize == 0 then do
let v callLeanBox builder ( constIntSizeT c.cidx) "lean_box_outv"
let v callLeanBox builder ( constIntUnsigned c.cidx) "lean_box_outv"
let _ LLVM.buildStore builder v slot
else do
let v emitAllocCtor builder c
@@ -595,7 +557,7 @@ def emitInc (builder : LLVM.Builder llvmctx)
let xv emitLhsVal builder x
if n != 1
then do
let nv constIntSizeT n
let nv LLVM.constIntUnsigned llvmctx (UInt64.ofNat n)
callLeanRefcountFn builder (kind := RefcountKind.inc) (checkRef? := checkRef?) (delta := nv) xv
else callLeanRefcountFn builder (kind := RefcountKind.inc) (checkRef? := checkRef?) xv
@@ -709,7 +671,7 @@ def emitPartialApp (builder : LLVM.Builder llvmctx) (z : VarId) (f : FunId) (ys
def emitApp (builder : LLVM.Builder llvmctx) (z : VarId) (f : VarId) (ys : Array Arg) : M llvmctx Unit := do
if ys.size > closureMaxArgs then do
let aargs buildPrologueAlloca builder ( LLVM.arrayType ( LLVM.voidPtrType llvmctx) (UInt64.ofNat ys.size)) "aargs"
let aargs LLVM.buildAlloca builder ( LLVM.arrayType ( LLVM.voidPtrType llvmctx) (UInt64.ofNat ys.size)) "aargs"
for i in List.range ys.size do
let (yty, yv) emitArgVal builder ys[i]!
let aslot LLVM.buildInBoundsGEP2 builder yty aargs #[ constIntUnsigned 0, constIntUnsigned i] s!"param_{i}_slot"
@@ -718,7 +680,7 @@ def emitApp (builder : LLVM.Builder llvmctx) (z : VarId) (f : VarId) (ys : Array
let retty LLVM.voidPtrType llvmctx
let args := #[ emitLhsVal builder f, constIntUnsigned ys.size, aargs]
-- '1 + ...'. '1' for the fn and 'args' for the arguments
let argtys := #[ LLVM.voidPtrType llvmctx, LLVM.unsignedType llvmctx, LLVM.voidPtrType llvmctx]
let argtys := #[ LLVM.voidPtrType llvmctx]
let fn getOrCreateFunctionPrototype ( getLLVMModule) retty fnName argtys
let fnty LLVM.functionType retty argtys
let zv LLVM.buildCall2 builder fnty fn args
@@ -760,18 +722,18 @@ def emitFullApp (builder : LLVM.Builder llvmctx)
def emitLit (builder : LLVM.Builder llvmctx)
(z : VarId) (t : IRType) (v : LitVal) : M llvmctx (LLVM.Value llvmctx) := do
let llvmty toLLVMType t
let zslot buildPrologueAlloca builder llvmty
let zslot LLVM.buildAlloca builder llvmty
addVartoState z zslot llvmty
let zv match v with
| LitVal.num v => emitNumLit builder t v
| LitVal.str v =>
let zero constIntUnsigned 0
let zero LLVM.constIntUnsigned llvmctx 0
let str_global LLVM.buildGlobalString builder v
-- access through the global, into the 0th index of the array
let strPtr LLVM.buildInBoundsGEP2 builder
( LLVM.opaquePointerTypeInContext llvmctx)
str_global #[zero] ""
let nbytes constIntSizeT v.utf8ByteSize
let nbytes LLVM.constIntUnsigned llvmctx (UInt64.ofNat (v.utf8ByteSize))
callLeanMkStringFromBytesFn builder strPtr nbytes ""
LLVM.buildStore builder zv zslot
return zslot
@@ -795,7 +757,7 @@ def callLeanCtorGetUsize (builder : LLVM.Builder llvmctx)
(x i : LLVM.Value llvmctx) (retName : String) : M llvmctx (LLVM.Value llvmctx) := do
let fnName := "lean_ctor_get_usize"
let retty LLVM.size_tType llvmctx
let argtys := #[ LLVM.voidPtrType llvmctx, LLVM.unsignedType llvmctx]
let argtys := #[ LLVM.voidPtrType llvmctx, LLVM.size_tType llvmctx]
let fnty LLVM.functionType retty argtys
let fn getOrCreateFunctionPrototype ( getLLVMModule) retty fnName argtys
LLVM.buildCall2 builder fnty fn #[x, i] retName
@@ -822,7 +784,7 @@ def emitSProj (builder : LLVM.Builder llvmctx)
| IRType.uint32 => pure ("lean_ctor_get_uint32", LLVM.i32Type llvmctx)
| IRType.uint64 => pure ("lean_ctor_get_uint64", LLVM.i64Type llvmctx)
| _ => throw s!"Invalid type for lean_ctor_get: '{t}'"
let argtys := #[ LLVM.voidPtrType llvmctx, LLVM.unsignedType llvmctx]
let argtys := #[ LLVM.voidPtrType llvmctx, LLVM.size_tType llvmctx]
let fn getOrCreateFunctionPrototype ( getLLVMModule) retty fnName argtys
let xval emitLhsVal builder x
let offset emitOffset builder n offset
@@ -929,7 +891,7 @@ def emitReset (builder : LLVM.Builder llvmctx) (z : VarId) (n : Nat) (x : VarId)
(fun builder => do
let xv emitLhsVal builder x
callLeanDecRef builder xv
let box0 callLeanBox builder ( constIntSizeT 0) "box0"
let box0 callLeanBox builder ( constIntUnsigned 0) "box0"
emitLhsSlotStore builder z box0
return ShouldForwardControlFlow.yes
)
@@ -950,7 +912,7 @@ def emitReuse (builder : LLVM.Builder llvmctx)
emitLhsSlotStore builder z xv
if updtHeader then
let zv emitLhsVal builder z
callLeanCtorSetTag builder zv ( constInt8 c.cidx)
callLeanCtorSetTag builder zv ( constIntUnsigned c.cidx)
return ShouldForwardControlFlow.yes
)
emitCtorSetArgs builder z ys
@@ -973,7 +935,7 @@ def emitVDecl (builder : LLVM.Builder llvmctx) (z : VarId) (t : IRType) (v : Exp
def declareVar (builder : LLVM.Builder llvmctx) (x : VarId) (t : IRType) : M llvmctx Unit := do
let llvmty toLLVMType t
let alloca buildPrologueAlloca builder llvmty "varx"
let alloca LLVM.buildAlloca builder llvmty "varx"
addVartoState x alloca llvmty
partial def declareVars (builder : LLVM.Builder llvmctx) (f : FnBody) : M llvmctx Unit := do
@@ -999,7 +961,7 @@ def emitTag (builder : LLVM.Builder llvmctx) (x : VarId) (xType : IRType) : M ll
def emitSet (builder : LLVM.Builder llvmctx) (x : VarId) (i : Nat) (y : Arg) : M llvmctx Unit := do
let fnName := "lean_ctor_set"
let retty LLVM.voidType llvmctx
let argtys := #[ LLVM.voidPtrType llvmctx, LLVM.unsignedType llvmctx , LLVM.voidPtrType llvmctx]
let argtys := #[ LLVM.voidPtrType llvmctx, LLVM.size_tType llvmctx, LLVM.voidPtrType llvmctx]
let fn getOrCreateFunctionPrototype ( getLLVMModule) retty fnName argtys
let fnty LLVM.functionType retty argtys
let _ LLVM.buildCall2 builder fnty fn #[ emitLhsVal builder x, constIntUnsigned i, ( emitArgVal builder y).2]
@@ -1007,7 +969,7 @@ def emitSet (builder : LLVM.Builder llvmctx) (x : VarId) (i : Nat) (y : Arg) : M
def emitUSet (builder : LLVM.Builder llvmctx) (x : VarId) (i : Nat) (y : VarId) : M llvmctx Unit := do
let fnName := "lean_ctor_set_usize"
let retty LLVM.voidType llvmctx
let argtys := #[ LLVM.voidPtrType llvmctx, LLVM.unsignedType llvmctx, LLVM.size_tType llvmctx]
let argtys := #[ LLVM.voidPtrType llvmctx, LLVM.size_tType llvmctx, LLVM.size_tType llvmctx]
let fn getOrCreateFunctionPrototype ( getLLVMModule) retty fnName argtys
let fnty LLVM.functionType retty argtys
let _ LLVM.buildCall2 builder fnty fn #[ emitLhsVal builder x, constIntUnsigned i, ( emitLhsVal builder y)]
@@ -1046,7 +1008,7 @@ def emitSSet (builder : LLVM.Builder llvmctx) (x : VarId) (n : Nat) (offset : Na
| IRType.uint32 => pure ("lean_ctor_set_uint32", LLVM.i32Type llvmctx)
| IRType.uint64 => pure ("lean_ctor_set_uint64", LLVM.i64Type llvmctx)
| _ => throw s!"invalid type for 'lean_ctor_set': '{t}'"
let argtys := #[ LLVM.voidPtrType llvmctx, LLVM.unsignedType llvmctx, setty]
let argtys := #[ LLVM.voidPtrType llvmctx, LLVM.size_tType llvmctx, setty]
let retty LLVM.voidType llvmctx
let fn getOrCreateFunctionPrototype ( getLLVMModule) retty fnName argtys
let xv emitLhsVal builder x
@@ -1064,12 +1026,12 @@ def emitDel (builder : LLVM.Builder llvmctx) (x : VarId) : M llvmctx Unit := do
let _ LLVM.buildCall2 builder fnty fn #[xv]
def emitSetTag (builder : LLVM.Builder llvmctx) (x : VarId) (i : Nat) : M llvmctx Unit := do
let argtys := #[ LLVM.voidPtrType llvmctx, LLVM.i8Type llvmctx]
let argtys := #[ LLVM.voidPtrType llvmctx, LLVM.size_tType llvmctx]
let retty LLVM.voidType llvmctx
let fn getOrCreateFunctionPrototype ( getLLVMModule) retty "lean_ctor_set_tag" argtys
let xv emitLhsVal builder x
let fnty LLVM.functionType retty argtys
let _ LLVM.buildCall2 builder fnty fn #[xv, constInt8 i]
let _ LLVM.buildCall2 builder fnty fn #[xv, constIntUnsigned i]
def ensureHasDefault' (alts : Array Alt) : Array Alt :=
if alts.any Alt.isDefault then alts
@@ -1095,7 +1057,7 @@ partial def emitCase (builder : LLVM.Builder llvmctx)
match alt with
| Alt.ctor c b =>
let destbb builderAppendBasicBlock builder s!"case_{xType}_{c.name}_{c.cidx}"
LLVM.addCase switch ( constIntSizeT c.cidx) destbb
LLVM.addCase switch ( constIntUnsigned c.cidx) destbb
LLVM.positionBuilderAtEnd builder destbb
emitFnBody builder b
| Alt.default b =>
@@ -1179,14 +1141,14 @@ def emitFnArgs (builder : LLVM.Builder llvmctx)
-- pv := *(argsi) = *(args + i)
let pv LLVM.buildLoad2 builder llvmty argsi
-- slot for arg[i] which is always void* ?
let alloca buildPrologueAlloca builder llvmty s!"arg_{i}"
let alloca LLVM.buildAlloca builder llvmty s!"arg_{i}"
LLVM.buildStore builder pv alloca
addVartoState params[i]!.x alloca llvmty
else
let n LLVM.countParams llvmfn
for i in (List.range n.toNat) do
let llvmty toLLVMType params[i]!.ty
let alloca buildPrologueAlloca builder llvmty s!"arg_{i}"
let alloca LLVM.buildAlloca builder llvmty s!"arg_{i}"
let arg LLVM.getParam llvmfn (UInt64.ofNat i)
let _ LLVM.buildStore builder arg alloca
addVartoState params[i]!.x alloca llvmty
@@ -1338,7 +1300,7 @@ def emitInitFn (mod : LLVM.Module llvmctx) (builder : LLVM.Builder llvmctx) : M
let ginit?v LLVM.buildLoad2 builder ginit?ty ginit?slot "init_v"
buildIfThen_ builder "isGInitialized" ginit?v
(fun builder => do
let box0 callLeanBox builder ( constIntSizeT 0) "box0"
let box0 callLeanBox builder ( LLVM.constIntUnsigned llvmctx 0) "box0"
let out callLeanIOResultMKOk builder box0 "retval"
let _ LLVM.buildRet builder out
pure ShouldForwardControlFlow.no)
@@ -1356,7 +1318,7 @@ def emitInitFn (mod : LLVM.Module llvmctx) (builder : LLVM.Builder llvmctx) : M
callLeanDecRef builder res
let decls := getDecls env
decls.reverse.forM (emitDeclInit builder initFn)
let box0 callLeanBox builder ( constIntSizeT 0) "box0"
let box0 callLeanBox builder ( LLVM.constIntUnsigned llvmctx 0) "box0"
let out callLeanIOResultMKOk builder box0 "retval"
let _ LLVM.buildRet builder out
@@ -1470,15 +1432,15 @@ def emitMainFn (mod : LLVM.Module llvmctx) (builder : LLVM.Builder llvmctx) : M
#endif
-/
let inty LLVM.voidPtrType llvmctx
let inslot buildPrologueAlloca builder ( LLVM.pointerType inty) "in"
let inslot LLVM.buildAlloca builder ( LLVM.pointerType inty) "in"
let resty LLVM.voidPtrType llvmctx
let res buildPrologueAlloca builder ( LLVM.pointerType resty) "res"
let res LLVM.buildAlloca builder ( LLVM.pointerType resty) "res"
if usesLeanAPI then callLeanInitialize builder else callLeanInitializeRuntimeModule builder
/- We disable panic messages because they do not mesh well with extracted closed terms.
See issue #534. We can remove this workaround after we implement issue #467. -/
callLeanSetPanicMessages builder ( LLVM.constFalse llvmctx)
let world callLeanIOMkWorld builder
let resv callModInitFn builder ( getModName) ( constInt8 1) world (( getModName).toString ++ "_init_out")
let resv callModInitFn builder ( getModName) ( LLVM.constInt8 llvmctx 1) world (( getModName).toString ++ "_init_out")
let _ LLVM.buildStore builder resv res
callLeanSetPanicMessages builder ( LLVM.constTrue llvmctx)
@@ -1491,21 +1453,21 @@ def emitMainFn (mod : LLVM.Module llvmctx) (builder : LLVM.Builder llvmctx) : M
callLeanDecRef builder resv
callLeanInitTaskManager builder
if xs.size == 2 then
let inv callLeanBox builder ( constIntSizeT 0) "inv"
let inv callLeanBox builder ( LLVM.constInt ( LLVM.size_tType llvmctx) 0) "inv"
let _ LLVM.buildStore builder inv inslot
let ity LLVM.size_tType llvmctx
let islot buildPrologueAlloca builder ity "islot"
let islot LLVM.buildAlloca builder ity "islot"
let argcval LLVM.getParam main 0
let argvval LLVM.getParam main 1
LLVM.buildStore builder argcval islot
buildWhile_ builder "argv"
(condcodegen := fun builder => do
let iv LLVM.buildLoad2 builder ity islot "iv"
let i_gt_1 LLVM.buildICmp builder LLVM.IntPredicate.UGT iv ( constIntSizeT 1) "i_gt_1"
let i_gt_1 LLVM.buildICmp builder LLVM.IntPredicate.UGT iv ( constIntUnsigned 1) "i_gt_1"
return i_gt_1)
(bodycodegen := fun builder => do
let iv LLVM.buildLoad2 builder ity islot "iv"
let iv_next LLVM.buildSub builder iv ( constIntSizeT 1) "iv.next"
let iv_next LLVM.buildSub builder iv ( constIntUnsigned 1) "iv.next"
LLVM.buildStore builder iv_next islot
let nv callLeanAllocCtor builder 1 2 0 "nv"
let argv_i_next_slot LLVM.buildGEP2 builder ( LLVM.voidPtrType llvmctx) argvval #[iv_next] "argv.i.next.slot"
@@ -1547,7 +1509,7 @@ def emitMainFn (mod : LLVM.Module llvmctx) (builder : LLVM.Builder llvmctx) : M
pure ShouldForwardControlFlow.no
else do
callLeanDecRef builder resv
let _ LLVM.buildRet builder ( constInt64 0)
let _ LLVM.buildRet builder ( LLVM.constInt64 llvmctx 0)
pure ShouldForwardControlFlow.no
)
@@ -1555,7 +1517,7 @@ def emitMainFn (mod : LLVM.Module llvmctx) (builder : LLVM.Builder llvmctx) : M
let resv LLVM.buildLoad2 builder resty res "resv"
callLeanIOResultShowError builder resv
callLeanDecRef builder resv
let _ LLVM.buildRet builder ( constInt64 1)
let _ LLVM.buildRet builder ( LLVM.constInt64 llvmctx 1)
pure ShouldForwardControlFlow.no)
-- at the merge
let _ LLVM.buildUnreachable builder
@@ -1630,8 +1592,6 @@ def emitLLVM (env : Environment) (modName : Name) (filepath : String) : IO Unit
let some fn LLVM.getNamedFunction emitLLVMCtx.llvmmodule name
| throw <| IO.Error.userError s!"ERROR: linked module must have function from runtime module: '{name}'"
LLVM.setLinkage fn LLVM.Linkage.internal
if let some err LLVM.verifyModule emitLLVMCtx.llvmmodule then
throw <| .userError err
LLVM.writeBitcodeToFile emitLLVMCtx.llvmmodule filepath
LLVM.disposeModule emitLLVMCtx.llvmmodule
| .error err => throw (IO.Error.userError err)

View File

@@ -182,18 +182,6 @@ opaque createBuilderInContext (ctx : Context) : BaseIO (Builder ctx)
@[extern "lean_llvm_append_basic_block_in_context"]
opaque appendBasicBlockInContext (ctx : Context) (fn : Value ctx) (name : @&String) : BaseIO (BasicBlock ctx)
@[extern "lean_llvm_count_basic_blocks"]
opaque countBasicBlocks (fn : Value ctx) : BaseIO UInt64
@[extern "lean_llvm_get_entry_basic_block"]
opaque getEntryBasicBlock (fn : Value ctx) : BaseIO (BasicBlock ctx)
@[extern "lean_llvm_get_first_instruction"]
opaque getFirstInstruction (bb : BasicBlock ctx) : BaseIO (Option (Value ctx))
@[extern "lean_llvm_position_builder_before"]
opaque positionBuilderBefore (builder : Builder ctx) (instr : Value ctx) : BaseIO Unit
@[extern "lean_llvm_position_builder_at_end"]
opaque positionBuilderAtEnd (builder : Builder ctx) (bb : BasicBlock ctx) : BaseIO Unit
@@ -338,9 +326,6 @@ opaque disposeTargetMachine (tm : TargetMachine ctx) : BaseIO Unit
@[extern "lean_llvm_dispose_module"]
opaque disposeModule (m : Module ctx) : BaseIO Unit
@[extern "lean_llvm_verify_module"]
opaque verifyModule (m : Module ctx) : BaseIO (Option String)
@[extern "lean_llvm_create_string_attribute"]
opaque createStringAttribute (key : String) (value : String) : BaseIO (Attribute ctx)
@@ -454,11 +439,6 @@ def constInt32 (ctx : Context) (value : UInt64) (signExtend : Bool := false) : B
def constInt64 (ctx : Context) (value : UInt64) (signExtend : Bool := false) : BaseIO (Value ctx) :=
constInt' ctx 64 value signExtend
def constIntSizeT (ctx : Context) (value : UInt64) (signExtend : Bool := false) : BaseIO (Value ctx) :=
-- TODO: make this stick to the actual size_t of the target machine
constInt' ctx 64 value signExtend
def constIntUnsigned (ctx : Context) (value : UInt64) (signExtend : Bool := false) : BaseIO (Value ctx) :=
-- TODO: make this stick to the actual unsigned of the target machine
constInt' ctx 32 value signExtend
constInt' ctx 64 value signExtend
end LLVM

View File

@@ -75,10 +75,10 @@ def eqvLetValue (e₁ e₂ : LetValue) : EqvM Bool := do
go (i+1)
else
x
termination_by params₁.size - i
go 0
else
return false
termination_by go i => params₁.size - i
def sortAlts (alts : Array Alt) : Array Alt :=
alts.qsort fun
@@ -133,4 +133,4 @@ Return `true` if `c₁` and `c₂` are alpha equivalent.
def Code.alphaEqv (c₁ c₂ : Code) : Bool :=
AlphaEqv.eqv c₁ c₂ |>.run {}
end Lean.Compiler.LCNF
end Lean.Compiler.LCNF

View File

@@ -181,8 +181,8 @@ def expandCodeDecls (decls : Array CodeDecl) (body : LetValue) : CompilerM Expr
go (i+1) (subst.push value)
else
(body.toExpr.abstract xs).instantiateRev subst
termination_by values.size - i
return go 0 #[]
termination_by go => values.size - i
/--
Create the "key" that uniquely identifies a code specialization.

View File

@@ -234,7 +234,7 @@ where
throwError "invalid instantiateForall, too many parameters"
else
return type
termination_by ps.size - i
termination_by go i _ => ps.size - i
/--
Return `true` if `type` is a predicate.

View File

@@ -28,8 +28,8 @@ def filterPairsM {m} [Monad m] {α} (a : Array α) (f : αα → m (Bool ×
let mut numRemoved := 0
for h1 : i in [:a.size] do for h2 : j in [i+1:a.size] do
unless removed[i]! || removed[j]! do
let xi := a[i]
let xj := a[j]
let xi := a[i]'h1.2
let xj := a[j]'h2.2
let (keepi, keepj) f xi xj
unless keepi do
numRemoved := numRemoved + 1
@@ -40,7 +40,7 @@ def filterPairsM {m} [Monad m] {α} (a : Array α) (f : αα → m (Bool ×
let mut a' := Array.mkEmpty numRemoved
for h : i in [:a.size] do
unless removed[i]! do
a' := a'.push a[i]
a' := a'.push (a[i]'h.2)
return a'
end Array

View File

@@ -89,7 +89,7 @@ def moveEntries [Hashable α] (i : Nat) (source : Array (AssocList α β)) (targ
let target := es.foldl (reinsertAux hash) target
moveEntries (i+1) source target
else target
termination_by source.size - i
termination_by _ i source _ => source.size - i
def expand [Hashable α] (size : Nat) (buckets : HashMapBucket α β) : HashMapImp α β :=
let bucketsNew : HashMapBucket α β :=
@@ -227,17 +227,3 @@ def ofListWith (l : List (α × β)) (f : β → β → β) : HashMap α β :=
match m.find? p.fst with
| none => m.insert p.fst p.snd
| some v => m.insert p.fst $ f v p.snd)
end Lean.HashMap
/--
Groups all elements `x`, `y` in `xs` with `key x == key y` into the same array
`(xs.groupByKey key).find! (key x)`. Groups preserve the relative order of elements in `xs`.
-/
def Array.groupByKey [BEq α] [Hashable α] (key : β α) (xs : Array β)
: Lean.HashMap α (Array β) := Id.run do
let mut groups :=
for x in xs do
let group := groups.findD (key x) #[]
groups := groups.erase (key x) -- make `group` referentially unique
groups := groups.insert (key x) (group.push x)
return groups

View File

@@ -80,7 +80,7 @@ def moveEntries [Hashable α] (i : Nat) (source : Array (List α)) (target : Has
moveEntries (i+1) source target
else
target
termination_by source.size - i
termination_by _ i source _ => source.size - i
def expand [Hashable α] (size : Nat) (buckets : HashSetBucket α) : HashSetImp α :=
let bucketsNew : HashSetBucket α :=

View File

@@ -8,4 +8,3 @@ import Lean.Data.Json.Stream
import Lean.Data.Json.Printer
import Lean.Data.Json.Parser
import Lean.Data.Json.FromToJson
import Lean.Data.Json.Elab

View File

@@ -1,79 +0,0 @@
/-
Copyright (c) 2022 E.W.Ayers. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: E.W.Ayers, Wojciech Nawrocki
-/
import Lean.Data.Json.FromToJson
import Lean.Syntax
/-!
# JSON-like syntax for Lean.
Now you can write
```lean
open Lean.Json
#eval json% {
hello : "world",
cheese : ["edam", "cheddar", {kind : "spicy", rank : 100.2}],
lemonCount : 100e30,
isCool : true,
isBug : null,
lookACalc: $(23 + 54 * 2)
}
```
-/
namespace Lean.Json
/-- Json syntactic category -/
declare_syntax_cat json (behavior := symbol)
/-- Json null value syntax. -/
syntax "null" : json
/-- Json true value syntax. -/
syntax "true" : json
/-- Json false value syntax. -/
syntax "false" : json
/-- Json string syntax. -/
syntax str : json
/-- Json number negation syntax for ordinary numbers. -/
syntax "-"? num : json
/-- Json number negation syntax for scientific numbers. -/
syntax "-"? scientific : json
/-- Json array syntax. -/
syntax "[" json,* "]" : json
/-- Json identifier syntax. -/
syntax jsonIdent := ident <|> str
/-- Json key/value syntax. -/
syntax jsonField := jsonIdent ": " json
/-- Json object syntax. -/
syntax "{" jsonField,* "}" : json
/-- Allows to use Json syntax in a Lean file. -/
syntax "json% " json : term
macro_rules
| `(json% null) => `(Lean.Json.null)
| `(json% true) => `(Lean.Json.bool Bool.true)
| `(json% false) => `(Lean.Json.bool Bool.false)
| `(json% $n:str) => `(Lean.Json.str $n)
| `(json% $n:num) => `(Lean.Json.num $n)
| `(json% $n:scientific) => `(Lean.Json.num $n)
| `(json% -$n:num) => `(Lean.Json.num (-$n))
| `(json% -$n:scientific) => `(Lean.Json.num (-$n))
| `(json% [$[$xs],*]) => `(Lean.Json.arr #[$[json% $xs],*])
| `(json% {$[$ks:jsonIdent : $vs:json],*}) => do
let ks : Array (TSyntax `term) ks.mapM fun
| `(jsonIdent| $k:ident) => pure (k.getId |> toString |> quote)
| `(jsonIdent| $k:str) => pure k
| _ => Macro.throwUnsupported
`(Lean.Json.mkObj [$[($ks, json% $vs)],*])
| `(json% $stx) =>
if stx.raw.isAntiquot then
let stx := stx.raw.getAntiquotTerm
`(Lean.toJson $stx)
else
Macro.throwUnsupported
end Lean.Json

View File

@@ -74,7 +74,6 @@ structure ServerCapabilities where
declarationProvider : Bool := false
typeDefinitionProvider : Bool := false
referencesProvider : Bool := false
callHierarchyProvider : Bool := false
renameProvider? : Option RenameOptions := none
workspaceSymbolProvider : Bool := false
foldingRangeProvider : Bool := false

View File

@@ -8,8 +8,6 @@ Authors: Joscha Mennicken
import Lean.Expr
import Lean.Data.Lsp.Basic
set_option linter.missingDocs true -- keep it documented
/-! This file contains types for communication between the watchdog and the
workers. These messages are not visible externally to users of the LSP server.
-/
@@ -19,27 +17,17 @@ namespace Lean.Lsp
/-! Most reference-related types have custom FromJson/ToJson implementations to
reduce the size of the resulting JSON. -/
/--
Identifier of a reference.
-/
inductive RefIdent where
/-- Named identifier. These are used in all references that are globally available. -/
| const : Name RefIdent
/-- Unnamed identifier. These are used for all local references. -/
| fvar : FVarId RefIdent
| fvar : FVarId RefIdent
deriving BEq, Hashable, Inhabited
namespace RefIdent
/-- Converts the reference identifier to a string by prefixing it with a symbol. -/
def toString : RefIdent String
| RefIdent.const n => s!"c:{n}"
| RefIdent.fvar id => s!"f:{id.name}"
/--
Converts the string representation of a reference identifier back to a reference identifier.
The string representation must have been created by `RefIdent.toString`.
-/
def fromString (s : String) : Except String RefIdent := do
let sPrefix := s.take 2
let sName := s.drop 2
@@ -55,92 +43,33 @@ def fromString (s : String) : Except String RefIdent := do
| "f:" => return RefIdent.fvar <| FVarId.mk name
| _ => throw "string must start with 'c:' or 'f:'"
instance : FromJson RefIdent where
fromJson?
| (s : String) => fromString s
| j => Except.error s!"expected a String, got {j}"
instance : ToJson RefIdent where
toJson ident := toString ident
end RefIdent
/-- Information about the declaration surrounding a reference. -/
structure RefInfo.ParentDecl where
/-- Name of the declaration surrounding a reference. -/
name : Name
/-- Range of the declaration surrounding a reference. -/
range : Lsp.Range
/-- Selection range of the declaration surrounding a reference. -/
selectionRange : Lsp.Range
deriving ToJson
/--
Denotes the range of a reference, as well as the parent declaration of the reference.
If the reference is itself a declaration, then it contains no parent declaration.
-/
structure RefInfo.Location where
/-- Range of the reference. -/
range : Lsp.Range
/-- Parent declaration of the reference. `none` if the reference is itself a declaration. -/
parentDecl? : Option RefInfo.ParentDecl
/-- Definition site and usage sites of a reference. Obtained from `Lean.Server.RefInfo`. -/
structure RefInfo where
/-- Definition site of the reference. May be `none` when we cannot find a definition site. -/
definition? : Option RefInfo.Location
/-- Usage sites of the reference. -/
usages : Array RefInfo.Location
definition : Option Lsp.Range
usages : Array Lsp.Range
instance : ToJson RefInfo where
toJson i :=
let rangeToList (r : Lsp.Range) : List Nat :=
[r.start.line, r.start.character, r.end.line, r.end.character]
let parentDeclToList (d : RefInfo.ParentDecl) : List Json :=
let name := d.name.toString |> toJson
let range := rangeToList d.range |>.map toJson
let selectionRange := rangeToList d.selectionRange |>.map toJson
[name] ++ range ++ selectionRange
let locationToList (l : RefInfo.Location) : List Json :=
let range := rangeToList l.range |>.map toJson
let parentDecl := l.parentDecl?.map parentDeclToList |>.getD []
range ++ parentDecl
Json.mkObj [
("definition", toJson $ i.definition?.map locationToList),
("usages", toJson $ i.usages.map locationToList)
("definition", toJson $ i.definition.map rangeToList),
("usages", toJson $ i.usages.map rangeToList)
]
instance : FromJson RefInfo where
fromJson? j := do
let toRange : List Nat Except String Lsp.Range
let listToRange (l : List Nat) : Except String Lsp.Range := match l with
| [sLine, sChar, eLine, eChar] => pure sLine, sChar, eLine, eChar
| l => throw s!"Expected list of length 4, not {l.length}"
let toParentDecl (a : Array Json) : Except String RefInfo.ParentDecl := do
let name := String.toName <| fromJson? a[0]!
let range a[1:5].toArray.toList |>.mapM fromJson?
let range toRange range
let selectionRange a[5:].toArray.toList |>.mapM fromJson?
let selectionRange toRange selectionRange
return name, range, selectionRange
let toLocation (l : List Json) : Except String RefInfo.Location := do
let l := l.toArray
if l.size != 4 && l.size != 13 then
.error "Expected list of length 4 or 13, not {l.size}"
let range l[:4].toArray.toList |>.mapM fromJson?
let range toRange range
if l.size == 13 then
let parentDecl toParentDecl l[4:].toArray
return range, parentDecl
else
return range, none
let definition? j.getObjValAs? (Option $ List Json) "definition"
let definition? match definition? with
| _ => throw s!"Expected list of length 4, not {l.length}"
let definition j.getObjValAs? (Option $ List Nat) "definition"
let definition match definition with
| none => pure none
| some list => some <$> toLocation list
let usages j.getObjValAs? (Array $ List Json) "usages"
let usages usages.mapM toLocation
pure { definition?, usages }
| some list => some <$> listToRange list
let usages j.getObjValAs? (Array $ List Nat) "usages"
let usages usages.mapM listToRange
pure { definition, usages }
/-- References from a single module/file -/
def ModuleRefs := HashMap RefIdent RefInfo
@@ -159,8 +88,7 @@ instance : FromJson ModuleRefs where
Contains the file's definitions and references. -/
structure LeanIleanInfoParams where
/-- Version of the file these references are from. -/
version : Nat
/-- All references for the file. -/
version : Nat
references : ModuleRefs
deriving FromJson, ToJson

View File

@@ -36,16 +36,16 @@ instance : FromJson CompletionItemKind where
structure InsertReplaceEdit where
newText : String
insert : Range
insert : Range
replace : Range
deriving FromJson, ToJson
structure CompletionItem where
label : String
detail? : Option String := none
label : String
detail? : Option String := none
documentation? : Option MarkupContent := none
kind? : Option CompletionItemKind := none
textEdit? : Option InsertReplaceEdit := none
kind? : Option CompletionItemKind := none
textEdit? : Option InsertReplaceEdit := none
/-
tags? : CompletionItemTag[]
deprecated? : boolean
@@ -63,7 +63,7 @@ structure CompletionItem where
structure CompletionList where
isIncomplete : Bool
items : Array CompletionItem
items : Array CompletionItem
deriving FromJson, ToJson
structure CompletionParams extends TextDocumentPositionParams where
@@ -74,7 +74,7 @@ structure Hover where
/- NOTE we should also accept MarkedString/MarkedString[] here
but they are deprecated, so maybe can get away without. -/
contents : MarkupContent
range? : Option Range := none
range? : Option Range := none
deriving ToJson, FromJson
structure HoverParams extends TextDocumentPositionParams
@@ -153,76 +153,45 @@ inductive SymbolKind where
| event
| operator
| typeParameter
deriving BEq, Hashable, Inhabited
instance : FromJson SymbolKind where
fromJson?
| 1 => .ok .file
| 2 => .ok .module
| 3 => .ok .namespace
| 4 => .ok .package
| 5 => .ok .class
| 6 => .ok .method
| 7 => .ok .property
| 8 => .ok .field
| 9 => .ok .constructor
| 10 => .ok .enum
| 11 => .ok .interface
| 12 => .ok .function
| 13 => .ok .variable
| 14 => .ok .constant
| 15 => .ok .string
| 16 => .ok .number
| 17 => .ok .boolean
| 18 => .ok .array
| 19 => .ok .object
| 20 => .ok .key
| 21 => .ok .null
| 22 => .ok .enumMember
| 23 => .ok .struct
| 24 => .ok .event
| 25 => .ok .operator
| 26 => .ok .typeParameter
| j => .error s!"invalid symbol kind {j}"
instance : ToJson SymbolKind where
toJson
| .file => 1
| .module => 2
| .namespace => 3
| .package => 4
| .class => 5
| .method => 6
| .property => 7
| .field => 8
| .constructor => 9
| .enum => 10
| .interface => 11
| .function => 12
| .variable => 13
| .constant => 14
| .string => 15
| .number => 16
| .boolean => 17
| .array => 18
| .object => 19
| .key => 20
| .null => 21
| .enumMember => 22
| .struct => 23
| .event => 24
| .operator => 25
| .typeParameter => 26
toJson
| SymbolKind.file => 1
| SymbolKind.module => 2
| SymbolKind.namespace => 3
| SymbolKind.package => 4
| SymbolKind.class => 5
| SymbolKind.method => 6
| SymbolKind.property => 7
| SymbolKind.field => 8
| SymbolKind.constructor => 9
| SymbolKind.enum => 10
| SymbolKind.interface => 11
| SymbolKind.function => 12
| SymbolKind.variable => 13
| SymbolKind.constant => 14
| SymbolKind.string => 15
| SymbolKind.number => 16
| SymbolKind.boolean => 17
| SymbolKind.array => 18
| SymbolKind.object => 19
| SymbolKind.key => 20
| SymbolKind.null => 21
| SymbolKind.enumMember => 22
| SymbolKind.struct => 23
| SymbolKind.event => 24
| SymbolKind.operator => 25
| SymbolKind.typeParameter => 26
structure DocumentSymbolAux (Self : Type) where
name : String
detail? : Option String := none
kind : SymbolKind
name : String
detail? : Option String := none
kind : SymbolKind
-- tags? : Array SymbolTag
range : Range
range : Range
selectionRange : Range
children? : Option (Array Self) := none
deriving FromJson, ToJson
children? : Option (Array Self) := none
deriving ToJson
inductive DocumentSymbol where
| mk (sym : DocumentSymbolAux DocumentSymbol)
@@ -243,56 +212,18 @@ instance : ToJson DocumentSymbolResult where
inductive SymbolTag where
| deprecated
deriving BEq, Hashable, Inhabited
instance : FromJson SymbolTag where
fromJson?
| 1 => .ok .deprecated
| j => .error s!"unknown symbol tag {j}"
instance : ToJson SymbolTag where
toJson
| .deprecated => 1
toJson
| SymbolTag.deprecated => 1
structure SymbolInformation where
name : String
kind : SymbolKind
tags : Array SymbolTag := #[]
location : Location
name : String
kind : SymbolKind
tags : Array SymbolTag := #[]
location : Location
containerName? : Option String := none
deriving FromJson, ToJson
structure CallHierarchyPrepareParams extends TextDocumentPositionParams
deriving FromJson, ToJson
structure CallHierarchyItem where
name : String
kind : SymbolKind
tags? : Option (Array SymbolTag) := none
detail? : Option String := none
uri : DocumentUri
range : Range
selectionRange : Range
-- data? : Option unknown
deriving FromJson, ToJson, BEq, Hashable, Inhabited
structure CallHierarchyIncomingCallsParams where
item : CallHierarchyItem
deriving FromJson, ToJson
structure CallHierarchyIncomingCall where
«from» : CallHierarchyItem
fromRanges : Array Range
deriving FromJson, ToJson, Inhabited
structure CallHierarchyOutgoingCallsParams where
item : CallHierarchyItem
deriving FromJson, ToJson
structure CallHierarchyOutgoingCall where
to : CallHierarchyItem
fromRanges : Array Range
deriving FromJson, ToJson, Inhabited
deriving ToJson
inductive SemanticTokenType where
-- Used by Lean
@@ -373,14 +304,14 @@ example {v : SemanticTokenModifier} : open SemanticTokenModifier in
cases v <;> native_decide
structure SemanticTokensLegend where
tokenTypes : Array String
tokenTypes : Array String
tokenModifiers : Array String
deriving FromJson, ToJson
structure SemanticTokensOptions where
legend : SemanticTokensLegend
range : Bool
full : Bool /- | {
range : Bool
full : Bool /- | {
delta?: boolean;
} -/
deriving FromJson, ToJson
@@ -391,12 +322,12 @@ structure SemanticTokensParams where
structure SemanticTokensRangeParams where
textDocument : TextDocumentIdentifier
range : Range
range : Range
deriving FromJson, ToJson
structure SemanticTokens where
resultId? : Option String := none
data : Array Nat
data : Array Nat
deriving FromJson, ToJson
structure FoldingRangeParams where
@@ -412,12 +343,12 @@ instance : ToJson FoldingRangeKind where
toJson
| FoldingRangeKind.comment => "comment"
| FoldingRangeKind.imports => "imports"
| FoldingRangeKind.region => "region"
| FoldingRangeKind.region => "region"
structure FoldingRange where
startLine : Nat
endLine : Nat
kind? : Option FoldingRangeKind := none
endLine : Nat
kind? : Option FoldingRangeKind := none
deriving ToJson
structure RenameOptions where

View File

@@ -8,7 +8,6 @@ import Init.Data.String
import Init.Data.Array
import Lean.Data.Lsp.Basic
import Lean.Data.Position
import Lean.DeclarationRange
/-! LSP uses UTF-16 for indexing, so we need to provide some primitives
to interact with Lean strings using UTF-16 indices. -/
@@ -87,13 +86,3 @@ def utf8PosToLspPos (text : FileMap) (pos : String.Pos) : Lsp.Position :=
end FileMap
end Lean
/--
Convert the Lean `DeclarationRange` to an LSP `Range` by turning the 1-indexed line numbering into a
0-indexed line numbering and converting the character offset within the line to a UTF-16 indexed
offset.
-/
def Lean.DeclarationRange.toLspRange (r : Lean.DeclarationRange) : Lsp.Range := {
start := r.pos.line - 1, r.charUtf16
«end» := r.endPos.line - 1, r.endCharUtf16
}

View File

@@ -96,12 +96,6 @@ def quickCmp (n₁ n₂ : Name) : Ordering :=
def quickLt (n₁ n₂ : Name) : Bool :=
quickCmp n₁ n₂ == Ordering.lt
/-- Returns true if the name has any numeric components. -/
def hasNum : Name Bool
| .anonymous => false
| .str p _ => p.hasNum
| .num _ _ => true
/-- The frontend does not allow user declarations to start with `_` in any of its parts.
We use name parts starting with `_` internally to create auxiliary names (e.g., `_private`). -/
def isInternal : Name Bool
@@ -109,17 +103,6 @@ def isInternal : Name → Bool
| num p _ => isInternal p
| _ => false
/--
The frontend does not allow user declarations to start with `_` in any of its parts.
We use name parts starting with `_` internally to create auxiliary names (e.g., `_private`).
This function checks if any component of the name starts with `_`, or is numeric.
-/
def isInternalOrNum : Name Bool
| .str p s => s.get 0 == '_' || isInternalOrNum p
| .num _ _ => true
| _ => false
/--
Checks whether the name is an implementation-detail hypothesis name.

View File

@@ -29,16 +29,9 @@ instance : ToExpr Position where
end Position
/-- Content of a file together with precalculated positions of newlines. -/
structure FileMap where
/-- The content of the file. -/
source : String
/-- The positions of newline characters.
The first entry is always `0` and the last always the index of the last character.
In particular, if the last character is a newline, that index will appear twice. -/
positions : Array String.Pos
/-- The line numbers associated with the `positions`.
Has the same length as `positions` and is always of the form `#[1, 2, …, n-1, n-1]`. -/
lines : Array Nat
deriving Inhabited
@@ -84,26 +77,6 @@ partial def toPosition (fmap : FileMap) (pos : String.Pos) : Position :=
-- Can also happen with EOF errors, which are not strictly inside the file.
lines.back, (pos - ps.back).byteIdx
/-- Convert a `Lean.Position` to a `String.Pos`. -/
def ofPosition (text : FileMap) (pos : Position) : String.Pos :=
let colPos :=
if h : pos.line - 1 < text.positions.size then
text.positions.get pos.line - 1, h
else if text.positions.isEmpty then
0
else
text.positions.back
String.Iterator.nextn text.source, colPos pos.column |>.pos
/--
Returns the position of the start of (1-based) line `line`.
This gives the stame result as `map.ofPosition ⟨line, 0⟩`, but is more efficient.
-/
def lineStart (map : FileMap) (line : Nat) : String.Pos :=
if h : line - 1 < map.positions.size then
map.positions.get line - 1, h
else map.positions.back?.getD 0
end FileMap
end Lean

View File

@@ -159,7 +159,7 @@ def appendTrees : RBNode α β → RBNode α β → RBNode α β
| bc => balLeft a kx vx (node black bc ky vy d)
| a, node red b kx vx c => node red (appendTrees a b) kx vx c
| node red a kx vx b, c => node red a kx vx (appendTrees b c)
termination_by x y => x.size + y.size
termination_by _ x y => x.size + y.size
section Erase

View File

@@ -36,12 +36,13 @@ where
if it.atEnd then r
else if it.curr == ' ' || it.curr == '\t' then consumeSpaces n it.next r
else saveLine it r
termination_by (it, 1)
saveLine (it : String.Iterator) (r : String) : String :=
if it.atEnd then r
else if it.curr == '\n' then consumeSpaces n it.next (r.push '\n')
else saveLine it.next (r.push it.curr)
termination_by (it, 0)
termination_by
consumeSpaces n it r => (it, 1)
saveLine it r => (it, 0)
def removeLeadingSpaces (s : String) : String :=
let n := findLeadingSpacesSize s

View File

@@ -690,10 +690,10 @@ builtin_initialize elabAsElim : TagAttribute ←
(applicationTime := .afterCompilation)
fun declName => do
let go : MetaM Unit := do
discard <| getElimInfo declName
let info getConstInfo declName
if ( hasOptAutoParams info.type) then
throwError "[elab_as_elim] attribute cannot be used in declarations containing optional and auto parameters"
discard <| getElimInfo declName
go.run' {} {}
/-! # Eliminator-like function application elaborator -/
@@ -937,7 +937,6 @@ def elabAppArgs (f : Expr) (namedArgs : Array NamedArg) (args : Array Arg)
where
/-- Return `some info` if we should elaborate as an eliminator. -/
elabAsElim? : TermElabM (Option ElimInfo) := do
unless ( read).heedElabAsElim do return none
if explicit || ellipsis then return none
let .const declName _ := f | return none
unless ( shouldElabAsElim declName) do return none
@@ -958,7 +957,8 @@ where
The idea is that the contribute to motive inference. See comment at `ElamElim.Context.extraArgsPos`.
-/
getElabAsElimExtraArgsPos (elimInfo : ElimInfo) : MetaM (Array Nat) := do
forallTelescope elimInfo.elimType fun xs type => do
let cinfo getConstInfo elimInfo.name
forallTelescope cinfo.type fun xs type => do
let resultArgs := type.getAppArgs
let mut extraArgsPos := #[]
for i in [:xs.size] do

View File

@@ -6,7 +6,6 @@ Authors: Leonardo de Moura
import Lean.Elab.Quotation.Precheck
import Lean.Elab.Term
import Lean.Elab.BindersUtil
import Lean.Elab.PreDefinition.WF.TerminationHint
namespace Lean.Elab.Term
open Meta
@@ -571,8 +570,7 @@ def expandMatchAltsIntoMatchTactic (ref : Syntax) (matchAlts : Syntax) : MacroM
-/
def expandMatchAltsWhereDecls (matchAltsWhereDecls : Syntax) : MacroM Syntax :=
let matchAlts := matchAltsWhereDecls[0]
-- matchAltsWhereDecls[1] is the termination hints, collected elsewhere
let whereDeclsOpt := matchAltsWhereDecls[2]
let whereDeclsOpt := matchAltsWhereDecls[1]
let rec loop (i : Nat) (discrs : Array Syntax) : MacroM Syntax :=
match i with
| 0 => do

View File

@@ -656,40 +656,35 @@ unsafe def elabEvalUnsafe : CommandElab
return e
-- Evaluate using term using `MetaEval` class.
let elabMetaEval : CommandElabM Unit := do
-- Generate an action without executing it. We use `withoutModifyingEnv` to ensure
-- we don't polute the environment with auxliary declarations.
-- We have special support for `CommandElabM` to ensure `#eval` can be used to execute commands
-- that modify `CommandElabM` state not just the `Environment`.
let act : Sum (CommandElabM Unit) (Environment Options IO (String × Except IO.Error Environment))
runTermElabM fun _ => Term.withDeclName declName do withoutModifyingEnv do
let e elabEvalTerm
let eType instantiateMVars ( inferType e)
if eType.isAppOfArity ``CommandElabM 1 then
let mut stx Term.exprToSyntax e
unless ( isDefEq eType.appArg! (mkConst ``Unit)) do
stx `($stx >>= fun v => IO.println (repr v))
let act Lean.Elab.Term.evalTerm (CommandElabM Unit) (mkApp (mkConst ``CommandElabM) (mkConst ``Unit)) stx
pure <| Sum.inl act
else
let e mkRunMetaEval e
addAndCompile e
let act evalConst (Environment Options IO (String × Except IO.Error Environment)) declName
pure <| Sum.inr act
match act with
| .inl act => act
| .inr act =>
let (out, res) act ( getEnv) ( getOptions)
logInfoAt tk out
match res with
| Except.error e => throwError e.toString
| Except.ok env => setEnv env; pure ()
-- act? is `some act` if elaborated `term` has type `CommandElabM α`
let act? runTermElabM fun _ => Term.withDeclName declName do
let e elabEvalTerm
let eType instantiateMVars ( inferType e)
if eType.isAppOfArity ``CommandElabM 1 then
let mut stx Term.exprToSyntax e
unless ( isDefEq eType.appArg! (mkConst ``Unit)) do
stx `($stx >>= fun v => IO.println (repr v))
let act Lean.Elab.Term.evalTerm (CommandElabM Unit) (mkApp (mkConst ``CommandElabM) (mkConst ``Unit)) stx
pure <| some act
else
let e mkRunMetaEval e
let env getEnv
let opts getOptions
let act try addAndCompile e; evalConst (Environment Options IO (String × Except IO.Error Environment)) declName finally setEnv env
let (out, res) act env opts -- we execute `act` using the environment
logInfoAt tk out
match res with
| Except.error e => throwError e.toString
| Except.ok env => do setEnv env; pure none
let some act := act? | return ()
act
-- Evaluate using term using `Eval` class.
let elabEval : CommandElabM Unit := runTermElabM fun _ => Term.withDeclName declName do withoutModifyingEnv do
let elabEval : CommandElabM Unit := runTermElabM fun _ => Term.withDeclName declName do
-- fall back to non-meta eval if MetaEval hasn't been defined yet
-- modify e to `runEval e`
let e mkRunEval ( elabEvalTerm)
addAndCompile e
let act evalConst (IO (String × Except IO.Error Unit)) declName
let env getEnv
let act try addAndCompile e; evalConst (IO (String × Except IO.Error Unit)) declName finally setEnv env
let (out, res) liftM (m := IO) act
logInfoAt tk out
match res with
@@ -727,8 +722,6 @@ opaque elabEval : CommandElab
match stx with
| `($doc:docComment add_decl_doc $id) =>
let declName resolveGlobalConstNoOverloadWithInfo id
unless (( getEnv).getModuleIdxFor? declName).isNone do
throwError "invalid 'add_decl_doc', declaration is in an imported module"
if let .none findDeclarationRangesCore? declName then
-- this is only relevant for declarations added without a declaration range
-- in particular `Quot.mk` et al which are added by `init_quot`

View File

@@ -1,14 +1,12 @@
/-
Copyright (c) 2019 Microsoft Corporation. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Leonardo de Moura, Gabriel Ebner
Authors: Leonardo de Moura
-/
import Lean.Compiler.BorrowedAnnotation
import Lean.Meta.KAbstract
import Lean.Meta.Closure
import Lean.Meta.MatchUtil
import Lean.Elab.SyntheticMVars
import Lean.Compiler.ImplementedByAttr
namespace Lean.Elab.Term
open Meta
@@ -21,20 +19,6 @@ open Meta
throwError "invalid coercion notation, expected type is not known"
ensureHasType expectedType? e
@[builtin_term_elab coeFunNotation] def elabCoeFunNotation : TermElab := fun stx _ => do
let x elabTerm stx[1] none
if let some ty coerceToFunction? x then
return ty
else
throwError "cannot coerce to function{indentExpr x}"
@[builtin_term_elab coeSortNotation] def elabCoeSortNotation : TermElab := fun stx _ => do
let x elabTerm stx[1] none
if let some ty coerceToSort? x then
return ty
else
throwError "cannot coerce to sort{indentExpr x}"
@[builtin_term_elab anonymousCtor] def elabAnonymousCtor : TermElab := fun stx expectedType? =>
match stx with
| `($args,*) => do
@@ -427,33 +411,4 @@ private def withLocalIdentFor (stx : Term) (e : Expr) (k : Term → TermElabM Ex
let e elabTerm stx[1] expectedType?
return DiscrTree.mkNoindexAnnotation e
-- TODO: investigate whether we need this function
private def mkAuxNameForElabUnsafe (hint : Name) : TermElabM Name :=
withFreshMacroScope do
let name := ( getDeclName?).getD Name.anonymous ++ hint
return addMacroScope ( getMainModule) name ( getCurrMacroScope)
@[builtin_term_elab «unsafe»]
def elabUnsafe : TermElab := fun stx expectedType? =>
match stx with
| `(unsafe $t) => do
let t elabTermAndSynthesize t expectedType?
if ( logUnassignedUsingErrorInfos ( getMVars t)) then
throwAbortTerm
let t mkAuxDefinitionFor ( mkAuxName `unsafe) t
let .const unsafeFn unsafeLvls .. := t.getAppFn | unreachable!
let .defnInfo unsafeDefn getConstInfo unsafeFn | unreachable!
let implName mkAuxNameForElabUnsafe `impl
addDecl <| Declaration.defnDecl {
name := implName
type := unsafeDefn.type
levelParams := unsafeDefn.levelParams
value := ( mkOfNonempty unsafeDefn.type)
hints := .opaque
safety := .safe
}
setImplementedBy implName unsafeFn
return mkAppN (Lean.mkConst implName unsafeLvls) t.getAppArgs
| _ => throwUnsupportedSyntax
end Lean.Elab.Term

View File

@@ -1,11 +1,10 @@
/-
Copyright (c) 2019 Microsoft Corporation. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Leonardo de Moura, Gabriel Ebner
Authors: Leonardo de Moura
-/
import Lean.Elab.Binders
import Lean.Elab.SyntheticMVars
import Lean.Elab.SetOption
namespace Lean.Elab.Command
@@ -239,11 +238,10 @@ private def mkInfoTree (elaborator : Name) (stx : Syntax) (trees : PersistentArr
let s get
let scope := s.scopes.head!
let tree := InfoTree.node (Info.ofCommandInfo { elaborator, stx }) trees
let ctx := PartialContextInfo.commandCtx {
return InfoTree.context {
env := s.env, fileMap := ctx.fileMap, mctx := {}, currNamespace := scope.currNamespace,
openDecls := scope.openDecls, options := scope.opts, ngen := s.ngen
}
return InfoTree.context ctx tree
} tree
private def elabCommandUsing (s : State) (stx : Syntax) : List (KeyedDeclsAttribute.AttributeEntry CommandElab) CommandElabM Unit
| [] => withInfoTreeContext (mkInfoTree := mkInfoTree `no_elab stx) <| throwError "unexpected syntax{indentD stx}"
@@ -504,49 +502,6 @@ def expandDeclId (declId : Syntax) (modifiers : Modifiers) : CommandElabM Expand
end Elab.Command
open Elab Command MonadRecDepth
/--
Lifts an action in `CommandElabM` into `CoreM`, updating the traces and the environment.
Commands that modify the processing of subsequent commands,
such as `open` and `namespace` commands,
only have an effect for the remainder of the `CommandElabM` computation passed here,
and do not affect subsequent commands.
-/
def liftCommandElabM (cmd : CommandElabM α) : CoreM α := do
let (a, commandState)
cmd.run {
fileName := getFileName
fileMap := getFileMap
ref := getRef
tacticCache? := none
} |>.run {
env := getEnv
maxRecDepth := getMaxRecDepth
scopes := [{ header := "", opts := getOptions }]
}
modify fun coreState => { coreState with
traceState.traces := coreState.traceState.traces ++ commandState.traceState.traces
env := commandState.env
}
if let some err := commandState.messages.msgs.toArray.find? (·.severity matches .error) then
throwError err.data
pure a
/--
Given a command elaborator `cmd`, returns a new command elaborator that
first evaluates any local `set_option ... in ...` clauses and then invokes `cmd` on what remains.
-/
partial def withSetOptionIn (cmd : CommandElab) : CommandElab := fun stx => do
if stx.getKind == ``Lean.Parser.Command.in &&
stx[0].getKind == ``Lean.Parser.Command.set_option then
let opts Elab.elabSetOption stx[0][1] stx[0][2]
Command.withScope (fun scope => { scope with opts }) do
withSetOptionIn cmd stx[1]
else
cmd stx
export Elab.Command (Linter addLinter)
end Lean

View File

@@ -187,6 +187,15 @@ def elabClassInductive (modifiers : Modifiers) (stx : Syntax) : CommandElabM Uni
let v classInductiveSyntaxToView modifiers stx
elabInductiveViews #[v]
def getTerminationHints (stx : Syntax) : TerminationHints :=
let decl := stx[1]
let k := decl.getKind
if k == ``Parser.Command.def || k == ``Parser.Command.abbrev || k == ``Parser.Command.theorem || k == ``Parser.Command.instance then
let args := decl.getArgs
{ terminationBy? := args[args.size - 2]!.getOptional?, decreasingBy? := args[args.size - 1]!.getOptional? }
else
{}
@[builtin_command_elab declaration]
def elabDeclaration : CommandElab := fun stx => do
match ( liftMacroM <| expandDeclNamespace? stx) with
@@ -210,7 +219,7 @@ def elabDeclaration : CommandElab := fun stx => do
let modifiers elabModifiers stx[0]
elabStructure modifiers decl
else if isDefLike decl then
elabMutualDef #[stx]
elabMutualDef #[stx] (getTerminationHints stx)
else
throwError "unexpected declaration"
@@ -323,10 +332,21 @@ def expandMutualPreamble : Macro := fun stx =>
@[builtin_command_elab «mutual»]
def elabMutual : CommandElab := fun stx => do
let hints := { terminationBy? := stx[3].getOptional?, decreasingBy? := stx[4].getOptional? }
if isMutualInductive stx then
if let some bad := hints.terminationBy? then
throwErrorAt bad "invalid 'termination_by' in mutually inductive datatype declaration"
if let some bad := hints.decreasingBy? then
throwErrorAt bad "invalid 'decreasing_by' in mutually inductive datatype declaration"
elabMutualInductive stx[1].getArgs
else if isMutualDef stx then
elabMutualDef stx[1].getArgs
for arg in stx[1].getArgs do
let argHints := getTerminationHints arg
if let some bad := argHints.terminationBy? then
throwErrorAt bad "invalid 'termination_by' in 'mutual' block, it must be used after the 'end' keyword"
if let some bad := argHints.decreasingBy? then
throwErrorAt bad "invalid 'decreasing_by' in 'mutual' block, it must be used after the 'end' keyword"
elabMutualDef stx[1].getArgs hints
else
throwError "invalid mutual block: either all elements of the block must be inductive declarations, or they must all be definitions/theorems/abbrevs"

View File

@@ -124,7 +124,7 @@ def mkDefViewOfOpaque (modifiers : Modifiers) (stx : Syntax) : CommandElabM DefV
| some val => pure val
| none =>
let val if modifiers.isUnsafe then `(default_or_ofNonempty% unsafe) else `(default_or_ofNonempty%)
`(Parser.Command.declValSimple| := $val)
pure <| mkNode ``Parser.Command.declValSimple #[ mkAtomFrom stx ":=", val ]
return {
ref := stx, kind := DefKind.opaque, modifiers := modifiers,
declId := stx[1], binders := binders, type? := some type, value := val

View File

@@ -57,10 +57,7 @@ where
let b := mkIdent ( mkFreshUserName `b)
ctorArgs1 := ctorArgs1.push a
ctorArgs2 := ctorArgs2.push b
let xType inferType x
if ( isProp xType) then
continue
if xType.isAppOf indVal.name then
if ( inferType x).isAppOf indVal.name then
rhs `($rhs && $(mkIdent auxFunName):ident $a:ident $b:ident)
else
rhs `($rhs && $a:ident == $b:ident)
@@ -94,9 +91,9 @@ def mkMutualBlock (ctx : Context) : TermElabM Syntax := do
$auxDefs:command*
end)
private def mkBEqInstanceCmds (declName : Name) : TermElabM (Array Syntax) := do
let ctx mkContext "beq" declName
let cmds := #[ mkMutualBlock ctx] ++ ( mkInstanceCmds ctx `BEq #[declName])
private def mkBEqInstanceCmds (declNames : Array Name) : TermElabM (Array Syntax) := do
let ctx mkContext "beq" declNames[0]!
let cmds := #[ mkMutualBlock ctx] ++ ( mkInstanceCmds ctx `BEq declNames)
trace[Elab.Deriving.beq] "\n{cmds}"
return cmds
@@ -112,18 +109,14 @@ private def mkBEqEnumCmd (name : Name): TermElabM (Array Syntax) := do
open Command
def mkBEqInstance (declName : Name) : CommandElabM Unit := do
let cmds liftTermElabM <|
if ( isEnumType declName) then
mkBEqEnumCmd declName
else
mkBEqInstanceCmds declName
cmds.forM elabCommand
def mkBEqInstanceHandler (declNames : Array Name) : CommandElabM Bool := do
if ( declNames.allM isInductive) then
for declName in declNames do
mkBEqInstance declName
if declNames.size == 1 && ( isEnumType declNames[0]!) then
let cmds liftTermElabM <| mkBEqEnumCmd declNames[0]!
cmds.forM elabCommand
return true
else if ( declNames.allM isInductive) && declNames.size > 0 then
let cmds liftTermElabM <| mkBEqInstanceCmds declNames
cmds.forM elabCommand
return true
else
return false

View File

@@ -67,12 +67,11 @@ where
let b := mkIdent ( mkFreshUserName `b)
ctorArgs1 := ctorArgs1.push a
ctorArgs2 := ctorArgs2.push b
let xType inferType x
let indValNum :=
ctx.typeInfos.findIdx?
(xType.isAppOf ConstantVal.name InductiveVal.toConstantVal)
(( inferType x).isAppOf ConstantVal.name InductiveVal.toConstantVal)
let recField := indValNum.map (ctx.auxFunNames[·]!)
let isProof isProp xType
let isProof := ( inferType ( inferType x)).isProp
todo := todo.push (a, b, recField, isProof)
patterns := patterns.push ( `(@$(mkIdent ctorName₁):ident $ctorArgs1:term*))
patterns := patterns.push ( `(@$(mkIdent ctorName₁):ident $ctorArgs2:term*))
@@ -187,15 +186,12 @@ def mkDecEqEnum (declName : Name) : CommandElabM Unit := do
trace[Elab.Deriving.decEq] "\n{cmd}"
elabCommand cmd
def mkDecEqInstance (declName : Name) : CommandElabM Bool := do
if ( isEnumType declName) then
mkDecEqEnum declName
def mkDecEqInstanceHandler (declNames : Array Name) : CommandElabM Bool := do
if ( isEnumType declNames[0]!) then
mkDecEqEnum declNames[0]!
return true
else
mkDecEq declName
def mkDecEqInstanceHandler (declNames : Array Name) : CommandElabM Bool := do
declNames.foldlM (fun b n => andM (pure b) (mkDecEqInstance n)) true
mkDecEq declNames[0]!
builtin_initialize
registerDerivingHandler `DecidableEq mkDecEqInstanceHandler

View File

@@ -19,58 +19,60 @@ def mkJsonField (n : Name) : CoreM (Bool × Term) := do
let s₁ := s.dropRightWhile (· == '?')
return (s != s₁, Syntax.mkStrLit s₁)
def mkToJsonInstance (declName : Name) : CommandElabM Bool := do
if isStructure ( getEnv) declName then
let cmds liftTermElabM do
let ctx mkContext "toJson" declName
let header mkHeader ``ToJson 1 ctx.typeInfos[0]!
let fields := getStructureFieldsFlattened ( getEnv) declName (includeSubobjectFields := false)
let fields fields.mapM fun field => do
let (isOptField, nm) mkJsonField field
let target := mkIdent header.targetNames[0]!
if isOptField then ``(opt $nm ($target).$(mkIdent field))
else ``([($nm, toJson ($target).$(mkIdent field))])
let cmd `(private def $(mkIdent ctx.auxFunNames[0]!):ident $header.binders:bracketedBinder* : Json :=
mkObj <| List.join [$fields,*])
return #[cmd] ++ ( mkInstanceCmds ctx ``ToJson #[declName])
cmds.forM elabCommand
return true
def mkToJsonInstanceHandler (declNames : Array Name) : CommandElabM Bool := do
if declNames.size == 1 then
if isStructure ( getEnv) declNames[0]! then
let cmds liftTermElabM do
let ctx mkContext "toJson" declNames[0]!
let header mkHeader ``ToJson 1 ctx.typeInfos[0]!
let fields := getStructureFieldsFlattened ( getEnv) declNames[0]! (includeSubobjectFields := false)
let fields fields.mapM fun field => do
let (isOptField, nm) mkJsonField field
let target := mkIdent header.targetNames[0]!
if isOptField then ``(opt $nm ($target).$(mkIdent field))
else ``([($nm, toJson ($target).$(mkIdent field))])
let cmd `(private def $(mkIdent ctx.auxFunNames[0]!):ident $header.binders:bracketedBinder* : Json :=
mkObj <| List.join [$fields,*])
return #[cmd] ++ ( mkInstanceCmds ctx ``ToJson declNames)
cmds.forM elabCommand
return true
else
let indVal getConstInfoInduct declNames[0]!
let cmds liftTermElabM do
let ctx mkContext "toJson" declNames[0]!
let toJsonFuncId := mkIdent ctx.auxFunNames[0]!
-- Return syntax to JSONify `id`, either via `ToJson` or recursively
-- if `id`'s type is the type we're deriving for.
let mkToJson (id : Ident) (type : Expr) : TermElabM Term := do
if type.isAppOf indVal.name then `($toJsonFuncId:ident $id:ident)
else ``(toJson $id:ident)
let header mkHeader ``ToJson 1 ctx.typeInfos[0]!
let discrs mkDiscrs header indVal
let alts mkAlts indVal fun ctor args userNames => do
let ctorStr := ctor.name.eraseMacroScopes.getString!
match args, userNames with
| #[], _ => ``(toJson $(quote ctorStr))
| #[(x, t)], none => ``(mkObj [($(quote ctorStr), $( mkToJson x t))])
| xs, none =>
let xs xs.mapM fun (x, t) => mkToJson x t
``(mkObj [($(quote ctorStr), Json.arr #[$[$xs:term],*])])
| xs, some userNames =>
let xs xs.mapIdxM fun idx (x, t) => do
`(($(quote userNames[idx]!.eraseMacroScopes.getString!), $( mkToJson x t)))
``(mkObj [($(quote ctorStr), mkObj [$[$xs:term],*])])
let auxTerm `(match $[$discrs],* with $alts:matchAlt*)
let auxCmd
if ctx.usePartial then
let letDecls mkLocalInstanceLetDecls ctx ``ToJson header.argNames
let auxTerm mkLet letDecls auxTerm
`(private partial def $toJsonFuncId:ident $header.binders:bracketedBinder* : Json := $auxTerm)
else
`(private def $toJsonFuncId:ident $header.binders:bracketedBinder* : Json := $auxTerm)
return #[auxCmd] ++ ( mkInstanceCmds ctx ``ToJson declNames)
cmds.forM elabCommand
return true
else
let indVal getConstInfoInduct declName
let cmds liftTermElabM do
let ctx mkContext "toJson" declName
let toJsonFuncId := mkIdent ctx.auxFunNames[0]!
-- Return syntax to JSONify `id`, either via `ToJson` or recursively
-- if `id`'s type is the type we're deriving for.
let mkToJson (id : Ident) (type : Expr) : TermElabM Term := do
if type.isAppOf indVal.name then `($toJsonFuncId:ident $id:ident)
else ``(toJson $id:ident)
let header mkHeader ``ToJson 1 ctx.typeInfos[0]!
let discrs mkDiscrs header indVal
let alts mkAlts indVal fun ctor args userNames => do
let ctorStr := ctor.name.eraseMacroScopes.getString!
match args, userNames with
| #[], _ => ``(toJson $(quote ctorStr))
| #[(x, t)], none => ``(mkObj [($(quote ctorStr), $( mkToJson x t))])
| xs, none =>
let xs xs.mapM fun (x, t) => mkToJson x t
``(mkObj [($(quote ctorStr), Json.arr #[$[$xs:term],*])])
| xs, some userNames =>
let xs xs.mapIdxM fun idx (x, t) => do
`(($(quote userNames[idx]!.eraseMacroScopes.getString!), $( mkToJson x t)))
``(mkObj [($(quote ctorStr), mkObj [$[$xs:term],*])])
let auxTerm `(match $[$discrs],* with $alts:matchAlt*)
let auxCmd
if ctx.usePartial then
let letDecls mkLocalInstanceLetDecls ctx ``ToJson header.argNames
let auxTerm mkLet letDecls auxTerm
`(private partial def $toJsonFuncId:ident $header.binders:bracketedBinder* : Json := $auxTerm)
else
`(private def $toJsonFuncId:ident $header.binders:bracketedBinder* : Json := $auxTerm)
return #[auxCmd] ++ ( mkInstanceCmds ctx ``ToJson #[declName])
cmds.forM elabCommand
return true
return false
where
mkAlts
(indVal : InductiveVal)
@@ -101,51 +103,54 @@ where
let rhs rhs ctorInfo binders (if userNames.size == binders.size then some userNames else none)
`(matchAltExpr| | $[$patterns:term],* => $rhs:term)
def mkFromJsonInstance (declName : Name) : CommandElabM Bool := do
if isStructure ( getEnv) declName then
let cmds liftTermElabM do
let ctx mkContext "fromJson" declName
let header mkHeader ``FromJson 0 ctx.typeInfos[0]!
let fields := getStructureFieldsFlattened ( getEnv) declName (includeSubobjectFields := false)
let getters fields.mapM (fun field => do
let getter `(getObjValAs? j _ $(Prod.snd <| mkJsonField field))
let getter `(doElem| Except.mapError (fun s => (toString $(quote declName)) ++ "." ++ (toString $(quote field)) ++ ": " ++ s) <| $getter)
return getter
)
let fields := fields.map mkIdent
let cmd `(private def $(mkIdent ctx.auxFunNames[0]!):ident $header.binders:bracketedBinder* (j : Json)
: Except String $( mkInductiveApp ctx.typeInfos[0]! header.argNames) := do
$[let $fields:ident $getters]*
return { $[$fields:ident := $(id fields)],* })
return #[cmd] ++ ( mkInstanceCmds ctx ``FromJson #[declName])
cmds.forM elabCommand
return true
def mkFromJsonInstanceHandler (declNames : Array Name) : CommandElabM Bool := do
if declNames.size == 1 then
let declName := declNames[0]!
if isStructure ( getEnv) declName then
let cmds liftTermElabM do
let ctx mkContext "fromJson" declName
let header mkHeader ``FromJson 0 ctx.typeInfos[0]!
let fields := getStructureFieldsFlattened ( getEnv) declName (includeSubobjectFields := false)
let getters fields.mapM (fun field => do
let getter `(getObjValAs? j _ $(Prod.snd <| mkJsonField field))
let getter `(doElem| Except.mapError (fun s => (toString $(quote declName)) ++ "." ++ (toString $(quote field)) ++ ": " ++ s) <| $getter)
return getter
)
let fields := fields.map mkIdent
let cmd `(private def $(mkIdent ctx.auxFunNames[0]!):ident $header.binders:bracketedBinder* (j : Json)
: Except String $( mkInductiveApp ctx.typeInfos[0]! header.argNames) := do
$[let $fields:ident $getters]*
return { $[$fields:ident := $(id fields)],* })
return #[cmd] ++ ( mkInstanceCmds ctx ``FromJson declNames)
cmds.forM elabCommand
return true
else
let indVal getConstInfoInduct declName
let cmds liftTermElabM do
let ctx mkContext "fromJson" declName
let header mkHeader ``FromJson 0 ctx.typeInfos[0]!
let fromJsonFuncId := mkIdent ctx.auxFunNames[0]!
let alts mkAlts indVal fromJsonFuncId
let mut auxTerm alts.foldrM (fun xs x => `(Except.orElseLazy $xs (fun _ => $x))) ( `(Except.error "no inductive constructor matched"))
if ctx.usePartial then
let letDecls mkLocalInstanceLetDecls ctx ``FromJson header.argNames
auxTerm mkLet letDecls auxTerm
-- FromJson is not structurally recursive even non-nested recursive inductives,
-- so we also use `partial` then.
let auxCmd
if ctx.usePartial || indVal.isRec then
`(private partial def $fromJsonFuncId:ident $header.binders:bracketedBinder* (json : Json)
: Except String $( mkInductiveApp ctx.typeInfos[0]! header.argNames) :=
$auxTerm)
else
`(private def $fromJsonFuncId:ident $header.binders:bracketedBinder* (json : Json)
: Except String $( mkInductiveApp ctx.typeInfos[0]! header.argNames) :=
$auxTerm)
return #[auxCmd] ++ ( mkInstanceCmds ctx ``FromJson declNames)
cmds.forM elabCommand
return true
else
let indVal getConstInfoInduct declName
let cmds liftTermElabM do
let ctx mkContext "fromJson" declName
let header mkHeader ``FromJson 0 ctx.typeInfos[0]!
let fromJsonFuncId := mkIdent ctx.auxFunNames[0]!
let alts mkAlts indVal fromJsonFuncId
let mut auxTerm alts.foldrM (fun xs x => `(Except.orElseLazy $xs (fun _ => $x))) ( `(Except.error "no inductive constructor matched"))
if ctx.usePartial then
let letDecls mkLocalInstanceLetDecls ctx ``FromJson header.argNames
auxTerm mkLet letDecls auxTerm
-- FromJson is not structurally recursive even non-nested recursive inductives,
-- so we also use `partial` then.
let auxCmd
if ctx.usePartial || indVal.isRec then
`(private partial def $fromJsonFuncId:ident $header.binders:bracketedBinder* (json : Json)
: Except String $( mkInductiveApp ctx.typeInfos[0]! header.argNames) :=
$auxTerm)
else
`(private def $fromJsonFuncId:ident $header.binders:bracketedBinder* (json : Json)
: Except String $( mkInductiveApp ctx.typeInfos[0]! header.argNames) :=
$auxTerm)
return #[auxCmd] ++ ( mkInstanceCmds ctx ``FromJson #[declName])
cmds.forM elabCommand
return true
return false
where
mkAlts (indVal : InductiveVal) (fromJsonFuncId : Ident) : TermElabM (Array Term) := do
let alts
@@ -183,12 +188,6 @@ where
let alts := alts.qsort (fun (_, x) (_, y) => x < y)
return alts.map Prod.fst
def mkToJsonInstanceHandler (declNames : Array Name) : CommandElabM Bool := do
declNames.foldlM (fun b n => andM (pure b) (mkToJsonInstance n)) true
def mkFromJsonInstanceHandler (declNames : Array Name) : CommandElabM Bool := do
declNames.foldlM (fun b n => andM (pure b) (mkFromJsonInstance n)) true
builtin_initialize
registerDerivingHandler ``ToJson mkToJsonInstanceHandler
registerDerivingHandler ``FromJson mkFromJsonInstanceHandler

View File

@@ -75,17 +75,16 @@ def mkHashFuncs (ctx : Context) : TermElabM Syntax := do
auxDefs := auxDefs.push ( mkAuxFunction ctx i)
`(mutual $auxDefs:command* end)
private def mkHashableInstanceCmds (declName : Name) : TermElabM (Array Syntax) := do
let ctx mkContext "hash" declName
let cmds := #[ mkHashFuncs ctx] ++ ( mkInstanceCmds ctx `Hashable #[declName])
private def mkHashableInstanceCmds (declNames : Array Name) : TermElabM (Array Syntax) := do
let ctx mkContext "hash" declNames[0]!
let cmds := #[ mkHashFuncs ctx] ++ ( mkInstanceCmds ctx `Hashable declNames)
trace[Elab.Deriving.hashable] "\n{cmds}"
return cmds
def mkHashableHandler (declNames : Array Name) : CommandElabM Bool := do
if ( declNames.allM isInductive) then
for declName in declNames do
let cmds liftTermElabM <| mkHashableInstanceCmds declName
cmds.forM elabCommand
if ( declNames.allM isInductive) && declNames.size > 0 then
let cmds liftTermElabM <| mkHashableInstanceCmds declNames
cmds.forM elabCommand
return true
else
return false

View File

@@ -86,19 +86,18 @@ def mkMutualBlock (ctx : Context) : TermElabM Syntax := do
$auxDefs:command*
end)
private def mkOrdInstanceCmds (declName : Name) : TermElabM (Array Syntax) := do
let ctx mkContext "ord" declName
let cmds := #[ mkMutualBlock ctx] ++ ( mkInstanceCmds ctx `Ord #[declName])
private def mkOrdInstanceCmds (declNames : Array Name) : TermElabM (Array Syntax) := do
let ctx mkContext "ord" declNames[0]!
let cmds := #[ mkMutualBlock ctx] ++ ( mkInstanceCmds ctx `Ord declNames)
trace[Elab.Deriving.ord] "\n{cmds}"
return cmds
open Command
def mkOrdInstanceHandler (declNames : Array Name) : CommandElabM Bool := do
if ( declNames.allM isInductive) then
for declName in declNames do
let cmds liftTermElabM <| mkOrdInstanceCmds declName
cmds.forM elabCommand
if ( declNames.allM isInductive) && declNames.size > 0 then
let cmds liftTermElabM <| mkOrdInstanceCmds declNames
cmds.forM elabCommand
return true
else
return false

View File

@@ -104,19 +104,18 @@ def mkMutualBlock (ctx : Context) : TermElabM Syntax := do
$auxDefs:command*
end)
private def mkReprInstanceCmd (declName : Name) : TermElabM (Array Syntax) := do
let ctx mkContext "repr" declName
let cmds := #[ mkMutualBlock ctx] ++ ( mkInstanceCmds ctx `Repr #[declName])
private def mkReprInstanceCmds (declNames : Array Name) : TermElabM (Array Syntax) := do
let ctx mkContext "repr" declNames[0]!
let cmds := #[ mkMutualBlock ctx] ++ ( mkInstanceCmds ctx `Repr declNames)
trace[Elab.Deriving.repr] "\n{cmds}"
return cmds
open Command
def mkReprInstanceHandler (declNames : Array Name) : CommandElabM Bool := do
if ( declNames.allM isInductive) then
for declName in declNames do
let cmds liftTermElabM <| mkReprInstanceCmd declName
cmds.forM elabCommand
if ( declNames.allM isInductive) && declNames.size > 0 then
let cmds liftTermElabM <| mkReprInstanceCmds declNames
cmds.forM elabCommand
return true
else
return false

View File

@@ -16,9 +16,8 @@ namespace Lean.Elab.Deriving.SizeOf
open Command
def mkSizeOfHandler (declNames : Array Name) : CommandElabM Bool := do
if ( declNames.allM isInductive) then
for declName in declNames do
liftTermElabM <| Meta.mkSizeOfInstances declName
if ( declNames.allM isInductive) && declNames.size > 0 then
liftTermElabM <| Meta.mkSizeOfInstances declNames[0]!
return true
else
return false

View File

@@ -1368,7 +1368,7 @@ mutual
else
pure doElems.toArray
let contSeq := mkDoSeq contSeq
let auxDo `(do match $val:term with | $pattern:term => $contSeq | _ => $elseSeq)
let auxDo `(do let __discr := $val; match __discr with | $pattern:term => $contSeq | _ => $elseSeq)
doSeqToCode <| getDoSeqElems (getDoSeq auxDo)
/-- Generate `CodeBlock` for `doReassignArrow; doElems`

View File

@@ -118,7 +118,7 @@ def runFrontend
if let some ileanFileName := ileanFileName? then
let trees := s.commandState.infoState.trees.toArray
let references := Lean.Server.findModuleRefs inputCtx.fileMap trees (localVars := false)
let ilean := { module := mainModuleName, references := references.toLspModuleRefs : Lean.Server.Ilean }
let ilean := { module := mainModuleName, references : Lean.Server.Ilean }
IO.FS.writeFile ileanFileName $ Json.compress $ toJson ilean
pure (s.commandState.env, !s.commandState.messages.hasErrors)

View File

@@ -524,14 +524,14 @@ private def updateResultingUniverse (views : Array InductiveView) (numParams : N
register_builtin_option bootstrap.inductiveCheckResultingUniverse : Bool := {
defValue := true,
group := "bootstrap",
descr := "by default the `inductive`/`structure` commands report an error if the resulting universe is not zero, but may be zero for some universe parameters. Reason: unless this type is a subsingleton, it is hardly what the user wants since it can only eliminate into `Prop`. In the `Init` package, we define subsingletons, and we use this option to disable the check. This option may be deleted in the future after we improve the validator"
descr := "by default the `inductive/structure commands report an error if the resulting universe is not zero, but may be zero for some universe parameters. Reason: unless this type is a subsingleton, it is hardly what the user wants since it can only eliminate into `Prop`. In the `Init` package, we define subsingletons, and we use this option to disable the check. This option may be deleted in the future after we improve the validator"
}
def checkResultingUniverse (u : Level) : TermElabM Unit := do
if bootstrap.inductiveCheckResultingUniverse.get ( getOptions) then
let u instantiateLevelMVars u
if !u.isZero && !u.isNeverZero then
throwError "invalid universe polymorphic type, the resultant universe is not Prop (i.e., 0), but it may be Prop for some parameter values (solution: use 'u+1' or 'max 1 u'){indentD u}"
throwError "invalid universe polymorphic type, the resultant universe is not Prop (i.e., 0), but it may be Prop for some parameter values (solution: use 'u+1' or 'max 1 u'{indentD u}"
private def checkResultingUniverses (views : Array InductiveView) (numParams : Nat) (indTypes : List InductiveType) : TermElabM Unit := do
let u := ( instantiateLevelMVars ( getResultingUniverse indTypes)).normalize

View File

@@ -6,11 +6,11 @@ Authors: Wojciech Nawrocki, Leonardo de Moura, Sebastian Ullrich
-/
import Lean.Meta.PPGoal
namespace Lean.Elab.CommandContextInfo
namespace Lean.Elab.ContextInfo
variable [Monad m] [MonadEnv m] [MonadMCtx m] [MonadOptions m] [MonadResolveName m] [MonadNameGenerator m]
def saveNoFileMap : m CommandContextInfo := return {
def saveNoFileMap : m ContextInfo := return {
env := ( getEnv)
fileMap := default
mctx := ( getMCtx)
@@ -20,32 +20,11 @@ def saveNoFileMap : m CommandContextInfo := return {
ngen := ( getNGen)
}
def save [MonadFileMap m] : m CommandContextInfo := do
def save [MonadFileMap m] : m ContextInfo := do
let ctx saveNoFileMap
return { ctx with fileMap := ( getFileMap) }
end CommandContextInfo
/--
Merges the `inner` partial context into the `outer` context s.t. fields of the `inner` context
overwrite fields of the `outer` context. Panics if the invariant described in the documentation
for `PartialContextInfo` is violated.
When traversing an `InfoTree`, this function should be used to combine the context of outer
nodes with the partial context of their subtrees. This ensures that the traversal has the context
from the inner node to the root node of the `InfoTree` available, with partial contexts of
inner nodes taking priority over contexts of outer nodes.
-/
def PartialContextInfo.mergeIntoOuter?
: (inner : PartialContextInfo) (outer? : Option ContextInfo) Option ContextInfo
| .commandCtx info, none =>
some { info with }
| .parentDeclCtx _, none =>
panic! "Unexpected incomplete InfoTree context info."
| .commandCtx innerInfo, some outer =>
some { outer with toCommandContextInfo := innerInfo }
| .parentDeclCtx innerParentDecl, some outer =>
some { outer with parentDecl? := innerParentDecl }
end ContextInfo
def CompletionInfo.stx : CompletionInfo Syntax
| dot i .. => i.stx
@@ -171,9 +150,6 @@ def FVarAliasInfo.format (info : FVarAliasInfo) : Format :=
def FieldRedeclInfo.format (ctx : ContextInfo) (info : FieldRedeclInfo) : Format :=
f!"FieldRedecl @ {formatStxRange ctx info.stx}"
def OmissionInfo.format (ctx : ContextInfo) (info : OmissionInfo) : IO Format := do
return f!"Omission @ {← TermInfo.format ctx info.toTermInfo}"
def Info.format (ctx : ContextInfo) : Info IO Format
| ofTacticInfo i => i.format ctx
| ofTermInfo i => i.format ctx
@@ -186,7 +162,6 @@ def Info.format (ctx : ContextInfo) : Info → IO Format
| ofCustomInfo i => pure <| Std.ToFormat.format i
| ofFVarAliasInfo i => pure <| i.format
| ofFieldRedeclInfo i => pure <| i.format ctx
| ofOmissionInfo i => i.format ctx
def Info.toElabInfo? : Info Option ElabInfo
| ofTacticInfo i => some i.toElabInfo
@@ -200,7 +175,6 @@ def Info.toElabInfo? : Info → Option ElabInfo
| ofCustomInfo _ => none
| ofFVarAliasInfo _ => none
| ofFieldRedeclInfo _ => none
| ofOmissionInfo i => some i.toElabInfo
/--
Helper function for propagating the tactic metavariable context to its children nodes.
@@ -223,7 +197,7 @@ def Info.updateContext? : Option ContextInfo → Info → Option ContextInfo
partial def InfoTree.format (tree : InfoTree) (ctx? : Option ContextInfo := none) : IO Format := do
match tree with
| hole id => return .nestD f!"• ?{toString id.name}"
| context i t => format t <| i.mergeIntoOuter? ctx?
| context i t => format t i
| node i cs => match ctx? with
| none => return "• <context-not-available>"
| some ctx =>
@@ -334,52 +308,20 @@ def withInfoTreeContext [MonadFinally m] (x : m α) (mkInfoTree : PersistentArra
@[inline] def withInfoContext [MonadFinally m] (x : m α) (mkInfo : m Info) : m α := do
withInfoTreeContext x (fun trees => do return InfoTree.node ( mkInfo) trees)
private def withSavedPartialInfoContext [MonadFinally m]
(x : m α)
(ctx? : m (Option PartialContextInfo))
: m α := do
if !( getInfoState).enabled then
return x
let treesSaved getResetInfoTrees
Prod.fst <$> MonadFinally.tryFinally' x fun _ => do
let st getInfoState
let trees st.trees.mapM fun tree => do
let tree := tree.substitute st.assignment
match ( ctx?) with
| none =>
pure tree
| some ctx =>
pure <| InfoTree.context ctx tree
modifyInfoTrees fun _ => treesSaved ++ trees
/--
Resets the trees state `t₀`, runs `x` to produce a new trees state `t₁` and sets the state to be
`t₀ ++ (InfoTree.context (PartialContextInfo.commandCtx Γ) <$> t₁)` where `Γ` is the context derived
from the monad state.
-/
def withSaveInfoContext
[MonadNameGenerator m]
[MonadFinally m]
[MonadEnv m]
[MonadOptions m]
[MonadMCtx m]
[MonadResolveName m]
[MonadFileMap m]
(x : m α)
: m α := do
withSavedPartialInfoContext x do
return some <| .commandCtx ( CommandContextInfo.save)
/--
Resets the trees state `t₀`, runs `x` to produce a new trees state `t₁` and sets the state to be
`t₀ ++ (InfoTree.context (PartialContextInfo.parentDeclCtx Γ) <$> t₁)` where `Γ` is the parent decl
name provided by `MonadParentDecl m`.
-/
def withSaveParentDeclInfoContext [MonadFinally m] [MonadParentDecl m] (x : m α) : m α := do
withSavedPartialInfoContext x do
let some declName getParentDeclName?
| return none
return some <| .parentDeclCtx declName
/-- Resets the trees state `t₀`, runs `x` to produce a new trees
state `t₁` and sets the state to be `t₀ ++ (InfoTree.context Γ <$> t₁)`
where `Γ` is the context derived from the monad state. -/
def withSaveInfoContext [MonadNameGenerator m] [MonadFinally m] [MonadEnv m] [MonadOptions m] [MonadMCtx m] [MonadResolveName m] [MonadFileMap m] (x : m α) : m α := do
if ( getInfoState).enabled then
let treesSaved getResetInfoTrees
Prod.fst <$> MonadFinally.tryFinally' x fun _ => do
let st getInfoState
let trees st.trees.mapM fun tree => do
let tree := tree.substitute st.assignment
pure <| InfoTree.context ( ContextInfo.save) tree
modifyInfoTrees fun _ => treesSaved ++ trees
else
x
def getInfoHoleIdAssignment? (mvarId : MVarId) : m (Option InfoTree) :=
return ( getInfoState).assignment[mvarId]

View File

@@ -14,12 +14,10 @@ import Lean.Widget.Types
namespace Lean.Elab
/--
Context after executing `liftTermElabM`.
Note that the term information collected during elaboration may contain metavariables, and their
assignments are stored at `mctx`.
-/
structure CommandContextInfo where
/-- Context after executing `liftTermElabM`.
Note that the term information collected during elaboration may contain metavariables, and their
assignments are stored at `mctx`. -/
structure ContextInfo where
env : Environment
fileMap : FileMap
mctx : MetavarContext := {}
@@ -28,31 +26,6 @@ structure CommandContextInfo where
openDecls : List OpenDecl := []
ngen : NameGenerator -- We must save the name generator to implement `ContextInfo.runMetaM` and making we not create `MVarId`s used in `mctx`.
/--
Context from the root of the `InfoTree` up to this node.
Note that the term information collected during elaboration may contain metavariables, and their
assignments are stored at `mctx`.
-/
structure ContextInfo extends CommandContextInfo where
parentDecl? : Option Name := none
/--
Context for a sub-`InfoTree`.
Within `InfoTree`, this must fulfill the invariant that every non-`commandCtx` `PartialContextInfo`
node is always contained within a `commandCtx` node.
-/
inductive PartialContextInfo where
| commandCtx (info : CommandContextInfo)
/--
Context for the name of the declaration that surrounds nodes contained within this `context` node.
For example, this makes the name of the surrounding declaration available in `InfoTree` nodes
corresponding to the terms within the declaration.
-/
| parentDeclCtx (parentDecl : Name)
-- TODO: More constructors for the different kinds of scopes `commandCtx` is currently
-- used for (e.g. eliminating `Info.updateContext?` would be nice!).
/-- Base structure for `TermInfo`, `CommandInfo` and `TacticInfo`. -/
structure ElabInfo where
/-- The name of the elaborator that created this info. -/
@@ -154,15 +127,6 @@ structure Bar extends Foo :=
structure FieldRedeclInfo where
stx : Syntax
/--
Denotes information for the term `⋯` that is emitted by the delaborator when omitting a term
due to `pp.deepTerms false`. Omission needs to be treated differently from regular terms because
it has to be delaborated differently in `Lean.Widget.InteractiveDiagnostics.infoToInteractive`:
Regular terms are delaborated explicitly, whereas omitted terms are simply to be expanded with
regular delaboration settings.
-/
structure OmissionInfo extends TermInfo
/-- Header information for a node in `InfoTree`. -/
inductive Info where
| ofTacticInfo (i : TacticInfo)
@@ -176,7 +140,6 @@ inductive Info where
| ofCustomInfo (i : CustomInfo)
| ofFVarAliasInfo (i : FVarAliasInfo)
| ofFieldRedeclInfo (i : FieldRedeclInfo)
| ofOmissionInfo (i : OmissionInfo)
deriving Inhabited
/-- The InfoTree is a structure that is generated during elaboration and used
@@ -201,8 +164,8 @@ inductive Info where
`hole`s which are filled in later in the same way that unassigned metavariables are.
-/
inductive InfoTree where
/-- The context object is created at appropriate points during elaboration -/
| context (i : PartialContextInfo) (t : InfoTree)
/-- The context object is created by `liftTermElabM` at `Command.lean` -/
| context (i : ContextInfo) (t : InfoTree)
/-- The children contain information for nested term elaboration and tactic evaluation -/
| node (i : Info) (children : PersistentArray InfoTree)
/-- The elaborator creates holes (aka metavariables) for tactics and postponed terms -/
@@ -228,7 +191,7 @@ structure InfoState where
trees : PersistentArray InfoTree := {}
deriving Inhabited
class MonadInfoTree (m : Type Type) where
class MonadInfoTree (m : Type Type) where
getInfoState : m InfoState
modifyInfoState : (InfoState InfoState) m Unit
@@ -241,9 +204,4 @@ instance [MonadLift m n] [MonadInfoTree m] : MonadInfoTree n where
def setInfoState [MonadInfoTree m] (s : InfoState) : m Unit :=
modifyInfoState fun _ => s
class MonadParentDecl (m : Type Type) where
getParentDeclName? : m (Option Name)
export MonadParentDecl (getParentDeclName?)
end Lean.Elab

View File

@@ -21,7 +21,6 @@ structure LetRecDeclView where
type : Expr
mvar : Expr -- auxiliary metavariable used to lift the 'let rec'
valStx : Syntax
termination : WF.TerminationHints
structure LetRecView where
decls : Array LetRecDeclView
@@ -60,9 +59,7 @@ private def mkLetRecDeclView (letRec : Syntax) : TermElabM LetRecView := do
pure decl[4]
else
liftMacroM <| expandMatchAltsIntoMatch decl decl[3]
let termination WF.elabTerminationHints attrDeclStx[3]
pure { ref := declId, attrs, shortDeclName, declName, binderIds, type, mvar, valStx,
termination : LetRecDeclView }
pure { ref := declId, attrs, shortDeclName, declName, binderIds, type, mvar, valStx : LetRecDeclView }
else
throwUnsupportedSyntax
return { decls, body := letRec[3] }
@@ -94,23 +91,18 @@ private def registerLetRecsToLift (views : Array LetRecDeclView) (fvars : Array
throwError "'{view.declName}' has already been declared"
let lctx getLCtx
let localInstances getLocalInstances
let toLift views.mapIdxM fun i view => do
let value := values[i]!
let termination := view.termination.rememberExtraParams view.binderIds.size value
pure {
ref := view.ref
fvarId := fvars[i]!.fvarId!
attrs := view.attrs
shortDeclName := view.shortDeclName
declName := view.declName
lctx
localInstances
type := view.type
val := value
mvarId := view.mvar.mvarId!
termination := termination
: LetRecToLift }
let toLift := views.mapIdx fun i view => {
ref := view.ref
fvarId := fvars[i]!.fvarId!
attrs := view.attrs
shortDeclName := view.shortDeclName
declName := view.declName
lctx
localInstances
type := view.type
val := values[i]!
mvarId := view.mvar.mvarId!
: LetRecToLift }
modify fun s => { s with letRecsToLift := toLift.toList ++ s.letRecsToLift }
@[builtin_term_elab «letrec»] def elabLetRec : TermElab := fun stx expectedType? => do

View File

@@ -1,7 +1,7 @@
/-
Copyright (c) 2020 Microsoft Corporation. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Leonardo de Moura, Mario Carneiro
Authors: Leonardo de Moura
-/
import Lean.Util.ForEachExprWhere
import Lean.Meta.Match.Match
@@ -1236,46 +1236,17 @@ where
builtin_initialize
registerTraceClass `Elab.match
-- leading_parser:leadPrec "nomatch " >> sepBy1 termParser ", "
-- leading_parser:leadPrec "nomatch " >> termParser
@[builtin_term_elab «nomatch»] def elabNoMatch : TermElab := fun stx expectedType? => do
match stx with
| `(nomatch $discrs,*) =>
let discrs := discrs.getElems
if ( discrs.allM fun discr => isAtomicDiscr discr.raw) then
| `(nomatch $discrExpr) =>
if ( isAtomicDiscr discrExpr) then
let expectedType waitExpectedType expectedType?
/- Wait for discriminant types. -/
for discr in discrs do
let d elabTerm discr none
let dType inferType d
trace[Elab.match] "discr {d} : {← instantiateMVars dType}"
tryPostponeIfMVar dType
let discrs := discrs.map fun discr => mkNode ``Lean.Parser.Term.matchDiscr #[mkNullNode, discr.raw]
elabMatchAux none discrs #[] mkNullNode expectedType
let discr := mkNode ``Lean.Parser.Term.matchDiscr #[mkNullNode, discrExpr]
elabMatchAux none #[discr] #[] mkNullNode expectedType
else
let rec loop (discrs : List Term) (discrsNew : Array Syntax) : TermElabM Term := do
match discrs with
| [] =>
return stx.setArg 1 (Syntax.mkSep discrsNew (mkAtomFrom stx ", "))
| discr :: discrs =>
if ( isAtomicDiscr discr) then
loop discrs (discrsNew.push discr)
else
withFreshMacroScope do
let discrNew `(?x)
let r loop discrs (discrsNew.push discrNew)
`(let_mvar% ?x := $discr; $r)
let stxNew loop discrs.toList #[]
let stxNew `(let_mvar% ?x := $discrExpr; nomatch ?x)
withMacroExpansion stx stxNew <| elabTerm stxNew expectedType?
| _ => throwUnsupportedSyntax
@[builtin_term_elab «nofun»] def elabNoFun : TermElab := fun stx expectedType? => do
match stx with
| `($tk:nofun) =>
let expectedType waitExpectedType expectedType?
let binders forallTelescopeReducing expectedType fun args _ =>
args.mapM fun _ => withFreshMacroScope do `(a)
let stxNew `(fun%$tk $binders* => nomatch%$tk $binders,*)
withMacroExpansion stx stxNew <| elabTerm stxNew expectedType?
| _ => throwUnsupportedSyntax
end Lean.Elab.Term

View File

@@ -13,7 +13,6 @@ import Lean.Elab.Match
import Lean.Elab.DefView
import Lean.Elab.Deriving.Basic
import Lean.Elab.PreDefinition.Main
import Lean.Elab.PreDefinition.WF.TerminationHint
import Lean.Elab.DeclarationRange
namespace Lean.Elab
@@ -222,16 +221,14 @@ private def expandWhereStructInst : Macro
/-
Recall that
```
def declValSimple := leading_parser " :=\n" >> termParser >> Termination.suffix >> optional Term.whereDecls
def declValSimple := leading_parser " :=\n" >> termParser >> optional Term.whereDecls
def declValEqns := leading_parser Term.matchAltsWhereDecls
def declVal := declValSimple <|> declValEqns <|> Term.whereDecls
```
The `Termination.suffix` is ignored here, and extracted in `declValToTerminationHint`.
-/
private def declValToTerm (declVal : Syntax) : MacroM Syntax := withRef declVal do
if declVal.isOfKind ``Parser.Command.declValSimple then
expandWhereDeclsOpt declVal[3] declVal[1]
expandWhereDeclsOpt declVal[2] declVal[1]
else if declVal.isOfKind ``Parser.Command.declValEqns then
expandMatchAltsWhereDecls declVal[0]
else if declVal.isOfKind ``Parser.Command.whereStructInst then
@@ -241,15 +238,6 @@ private def declValToTerm (declVal : Syntax) : MacroM Syntax := withRef declVal
else
Macro.throwErrorAt declVal "unexpected declaration body"
/-- Elaborates the termination hints in a `declVal` syntax. -/
private def declValToTerminationHint (declVal : Syntax) : TermElabM WF.TerminationHints :=
if declVal.isOfKind ``Parser.Command.declValSimple then
WF.elabTerminationHints declVal[2]
else if declVal.isOfKind ``Parser.Command.declValEqns then
WF.elabTerminationHints declVal[0][1]
else
return .none
private def elabFunValues (headers : Array DefViewElabHeader) : TermElabM (Array Expr) :=
headers.mapM fun header => withDeclName header.declName <| withLevelNames header.levelNames do
let valStx liftMacroM <| declValToTerm header.valueStx
@@ -641,8 +629,6 @@ def pushMain (preDefs : Array PreDefinition) (sectionVars : Array Expr) (mainHea
: TermElabM (Array PreDefinition) :=
mainHeaders.size.foldM (init := preDefs) fun i preDefs => do
let header := mainHeaders[i]!
let termination declValToTerminationHint header.valueStx
let termination := termination.rememberExtraParams header.numParams mainVals[i]!
let value mkLambdaFVars sectionVars mainVals[i]!
let type mkForallFVars sectionVars header.type
return preDefs.push {
@@ -651,7 +637,7 @@ def pushMain (preDefs : Array PreDefinition) (sectionVars : Array Expr) (mainHea
declName := header.declName
levelParams := [], -- we set it later
modifiers := header.modifiers
type, value, termination
type, value
}
def pushLetRecs (preDefs : Array PreDefinition) (letRecClosures : List LetRecClosure) (kind : DefKind) (modifiers : Modifiers) : MetaM (Array PreDefinition) :=
@@ -669,8 +655,7 @@ def pushLetRecs (preDefs : Array PreDefinition) (letRecClosures : List LetRecClo
declName := c.toLift.declName
levelParams := [] -- we set it later
modifiers := { modifiers with attrs := c.toLift.attrs }
kind, type, value,
termination := c.toLift.termination
kind, type, value
}
def getKindForLetRecs (mainHeaders : Array DefViewElabHeader) : DefKind :=
@@ -781,7 +766,7 @@ partial def checkForHiddenUnivLevels (allUserLevelNames : List Name) (preDefs :
for preDef in preDefs do
checkPreDef preDef
def elabMutualDef (vars : Array Expr) (views : Array DefView) : TermElabM Unit :=
def elabMutualDef (vars : Array Expr) (views : Array DefView) (hints : TerminationHints) : TermElabM Unit :=
if isExample views then
withoutModifyingEnv do
-- save correct environment in info tree
@@ -820,7 +805,7 @@ where
for preDef in preDefs do
trace[Elab.definition] "after eraseAuxDiscr, {preDef.declName} : {preDef.type} :=\n{preDef.value}"
checkForHiddenUnivLevels allUserLevelNames preDefs
addPreDefinitions preDefs
addPreDefinitions preDefs hints
processDeriving headers
processDeriving (headers : Array DefViewElabHeader) := do
@@ -835,13 +820,13 @@ where
end Term
namespace Command
def elabMutualDef (ds : Array Syntax) : CommandElabM Unit := do
def elabMutualDef (ds : Array Syntax) (hints : TerminationHints) : CommandElabM Unit := do
let views ds.mapM fun d => do
let modifiers elabModifiers d[0]
if ds.size > 1 && modifiers.isNonrec then
throwErrorAt d "invalid use of 'nonrec' modifier in 'mutual' block"
mkDefView modifiers d[1]
runTermElabM fun vars => Term.elabMutualDef vars views
runTermElabM fun vars => Term.elabMutualDef vars views hints
end Command
end Lean.Elab

View File

@@ -8,13 +8,11 @@ import Lean.Util.CollectLevelParams
import Lean.Meta.AbstractNestedProofs
import Lean.Elab.RecAppSyntax
import Lean.Elab.DefView
import Lean.Elab.PreDefinition.WF.TerminationHint
namespace Lean.Elab
open Meta
open Term
/--
A (potentially recursive) definition.
The elaborator converts it into Kernel definitions using many different strategies.
@@ -27,7 +25,6 @@ structure PreDefinition where
declName : Name
type : Expr
value : Expr
termination : WF.TerminationHints
deriving Inhabited
def instantiateMVarsAtPreDecls (preDefs : Array PreDefinition) : TermElabM (Array PreDefinition) :=

View File

@@ -13,6 +13,11 @@ namespace Lean.Elab
open Meta
open Term
structure TerminationHints where
terminationBy? : Option Syntax := none
decreasingBy? : Option Syntax := none
deriving Inhabited
private def addAndCompilePartial (preDefs : Array PreDefinition) (useSorry := false) : TermElabM Unit := do
for preDef in preDefs do
trace[Elab.definition] "processing {preDef.declName}"
@@ -89,12 +94,15 @@ private def addAsAxioms (preDefs : Array PreDefinition) : TermElabM Unit := do
applyAttributesOf #[preDef] AttributeApplicationTime.afterTypeChecking
applyAttributesOf #[preDef] AttributeApplicationTime.afterCompilation
def addPreDefinitions (preDefs : Array PreDefinition) : TermElabM Unit := withLCtx {} {} do
def addPreDefinitions (preDefs : Array PreDefinition) (hints : TerminationHints) : TermElabM Unit := withLCtx {} {} do
for preDef in preDefs do
trace[Elab.definition.body] "{preDef.declName} : {preDef.type} :=\n{preDef.value}"
let preDefs preDefs.mapM ensureNoUnassignedMVarsAtPreDef
let preDefs betaReduceLetRecApps preDefs
let cliques := partitionPreDefs preDefs
let mut terminationBy liftMacroM <| WF.expandTerminationBy? hints.terminationBy? (cliques.map fun ds => ds.map (·.declName))
let mut decreasingBy liftMacroM <| WF.expandDecreasingBy? hints.decreasingBy? (cliques.map fun ds => ds.map (·.declName))
let mut hasErrors := false
for preDefs in cliques do
trace[Elab.definition.scc] "{preDefs.map (·.declName)}"
if preDefs.size == 1 && isNonRecursive preDefs[0]! then
@@ -108,31 +116,35 @@ def addPreDefinitions (preDefs : Array PreDefinition) : TermElabM Unit := withLC
addNonRec preDef
else
addAndCompileNonRec preDef
preDef.termination.ensureNone "not recursive"
else if preDefs.any (·.modifiers.isUnsafe) then
addAndCompileUnsafe preDefs
preDefs.forM (·.termination.ensureNone "unsafe")
else if preDefs.any (·.modifiers.isPartial) then
for preDef in preDefs do
if preDef.modifiers.isPartial && !( whnfD preDef.type).isForall then
withRef preDef.ref <| throwError "invalid use of 'partial', '{preDef.declName}' is not a function{indentExpr preDef.type}"
addAndCompilePartial preDefs
preDefs.forM (·.termination.ensureNone "partial")
else
try
let hasHints := preDefs.any fun preDef =>
preDef.termination.decreasing_by?.isSome || preDef.termination.termination_by?.isSome
if hasHints then
wfRecursion preDefs
let mut wf? := none
let mut decrTactic? := none
if let some wf := terminationBy.find? (preDefs.map (·.declName)) then
wf? := some wf
terminationBy := terminationBy.markAsUsed (preDefs.map (·.declName))
if let some { ref, value := decrTactic } := decreasingBy.find? (preDefs.map (·.declName)) then
decrTactic? := some ( withRef ref `(by $(decrTactic)))
decreasingBy := decreasingBy.markAsUsed (preDefs.map (·.declName))
if wf?.isSome || decrTactic?.isSome then
wfRecursion preDefs wf? decrTactic?
else
withRef (preDefs[0]!.ref) <| mapError
(orelseMergeErrors
(structuralRecursion preDefs)
(wfRecursion preDefs))
(wfRecursion preDefs none none))
(fun msg =>
let preDefMsgs := preDefs.toList.map (MessageData.ofExpr $ mkConst ·.declName)
m!"fail to show termination for{indentD (MessageData.joinSep preDefMsgs Format.line)}\nwith errors\n{msg}")
catch ex =>
hasErrors := true
logException ex
let s saveState
try
@@ -147,6 +159,9 @@ def addPreDefinitions (preDefs : Array PreDefinition) : TermElabM Unit := withLC
else if preDefs.all fun preDef => preDef.kind == DefKind.theorem then
addAsAxioms preDefs
catch _ => s.restore
unless hasErrors do
liftMacroM <| terminationBy.ensureAllUsed
liftMacroM <| decreasingBy.ensureAllUsed
builtin_initialize
registerTraceClass `Elab.definition.body

View File

@@ -41,12 +41,14 @@ def preprocess (e : Expr) (recFnName : Name) : CoreM Expr :=
return .visit e.headBeta
else
return .continue)
(post := fun e => do
if e.isApp && e.getAppFn.isMData then
let .mdata m f := e.getAppFn | unreachable!
(post := fun e =>
match e with
| .app (.mdata m f) a =>
if m.isRecApp then
return .done (.mdata m (f.beta e.getAppArgs))
return .continue)
return .done (.mdata m (.app f a))
else
return .done e
| _ => return .done e)
end Lean.Elab.Structural

View File

@@ -36,26 +36,106 @@ private def rwFixEq (mvarId : MVarId) : MetaM MVarId := mvarId.withContext do
mvarId.assign ( mkEqTrans h mvarNew)
return mvarNew.mvarId!
private def hasWellFoundedFix (e : Expr) : Bool :=
Option.isSome <| e.find? (·.isConstOf ``WellFounded.fix)
/--
Helper function for decoding the packed argument for a `WellFounded.fix` application.
Recall that we use `PSum` and `PSigma` for packing the arguments of mutually recursive nary functions.
-/
private partial def decodePackedArg? (info : EqnInfo) (e : Expr) : Option (Name × Array Expr) := do
if info.declNames.size == 1 then
let args := decodePSigma e #[]
return (info.declNames[0]!, args)
else
decodePSum? e 0
where
decodePSum? (e : Expr) (i : Nat) : Option (Name × Array Expr) := do
if e.isAppOfArity ``PSum.inl 3 then
decodePSum? e.appArg! i
else if e.isAppOfArity ``PSum.inr 3 then
decodePSum? e.appArg! (i+1)
else
guard (i < info.declNames.size)
return (info.declNames[i]!, decodePSigma e #[])
decodePSigma (e : Expr) (acc : Array Expr) : Array Expr :=
/- TODO: check arity of the given function. If it takes a PSigma as the last argument,
this function will produce incorrect results. -/
if e.isAppOfArity ``PSigma.mk 4 then
decodePSigma e.appArg! (acc.push e.appFn!.appArg!)
else
acc.push e
/--
Try to fold `WellFounded.fix` applications that represent recursive applications of the functions in `info.declNames`.
We need that to make sure `simpMatchWF?` succeeds at goals such as
```lean
...
h : g x = 0
...
|- (match (WellFounded.fix ...) with | ...) = ...
```
where `WellFounded.fix ...` can be folded back to `g x`.
-/
private def tryToFoldWellFoundedFix (info : EqnInfo) (us : List Level) (fixedPrefix : Array Expr) (e : Expr) : MetaM Expr := do
if hasWellFoundedFix e then
transform e (pre := pre)
else
return e
where
pre (e : Expr) : MetaM TransformStep := do
let e' := e.headBeta
if e'.isAppOf ``WellFounded.fix && e'.getAppNumArgs >= 6 then
let args := e'.getAppArgs
let packedArg := args[5]!
let extraArgs := args[6:]
if let some (declName, args) := decodePackedArg? info packedArg then
let candidate := mkAppN (mkAppN (mkAppN (mkConst declName us) fixedPrefix) args) extraArgs
trace[Elab.definition.wf] "found nested WF at discr {candidate}"
if ( withDefault <| isDefEq candidate e) then
return .visit candidate
return .continue
/--
Simplify `match`-expressions when trying to prove equation theorems for a recursive declaration defined using well-founded recursion.
It is similar to `simpMatch?`, but is also tries to fold `WellFounded.fix` applications occurring in discriminants.
See comment at `tryToFoldWellFoundedFix`.
-/
def simpMatchWF? (mvarId : MVarId) : MetaM (Option MVarId) :=
def simpMatchWF? (info : EqnInfo) (us : List Level) (fixedPrefix : Array Expr) (mvarId : MVarId) : MetaM (Option MVarId) :=
mvarId.withContext do
let target instantiateMVars ( mvarId.getType)
let discharge? mvarId.withContext do SplitIf.mkDischarge?
let (targetNew, _) Simp.main target ( Split.getSimpMatchContext) (methods := { pre, discharge? })
let (targetNew, _) Simp.main target ( Split.getSimpMatchContext) (methods := { pre })
let mvarIdNew applySimpResultToTarget mvarId target targetNew
if mvarId != mvarIdNew then return some mvarIdNew else return none
where
pre (e : Expr) : SimpM Simp.Step := do
let some app matchMatcherApp? e
| return Simp.Step.continue
let some app matchMatcherApp? e | return Simp.Step.visit { expr := e }
if app.discrs.any hasWellFoundedFix then
let discrsNew app.discrs.mapM (tryToFoldWellFoundedFix info us fixedPrefix ·)
if discrsNew != app.discrs then
let app := { app with discrs := discrsNew }
let eNew := app.toExpr
trace[Elab.definition.wf] "folded discriminants {indentExpr eNew}"
return Simp.Step.visit { expr := app.toExpr }
-- First try to reduce matcher
match ( reduceRecMatcher? e) with
| some e' => return Simp.Step.done { expr := e' }
| none => Simp.simpMatchCore app.matcherName e
| none =>
match ( Simp.simpMatchCore? app.matcherName e SplitIf.discharge?) with
| some r => return r
| none => return Simp.Step.visit { expr := e }
private def tryToFoldLHS? (info : EqnInfo) (us : List Level) (fixedPrefix : Array Expr) (mvarId : MVarId) : MetaM (Option MVarId) :=
mvarId.withContext do
let target mvarId.getType'
let some (_, lhs, rhs) := target.eq? | unreachable!
let lhsNew tryToFoldWellFoundedFix info us fixedPrefix lhs
if lhs == lhsNew then return none
let targetNew mkEq lhsNew rhs
let mvarNew mkFreshExprSyntheticOpaqueMVar targetNew
mvarId.assign mvarNew
return mvarNew.mvarId!
/--
Given a goal of the form `|- f.{us} a_1 ... a_n b_1 ... b_m = ...`, return `(us, #[a_1, ..., a_n])`
@@ -71,18 +151,19 @@ private def getFixedPrefix (declName : Name) (info : EqnInfo) (mvarId : MVarId)
trace[Elab.definition.wf.eqns] "fixedPrefix: {result}"
return (lhs.getAppFn.constLevels!, result)
private partial def mkProof (declName : Name) (type : Expr) : MetaM Expr := do
private partial def mkProof (declName : Name) (info : EqnInfo) (type : Expr) : MetaM Expr := do
trace[Elab.definition.wf.eqns] "proving: {type}"
withNewMCtxDepth do
let main mkFreshExprSyntheticOpaqueMVar type
let (_, mvarId) main.mvarId!.intros
let (us, fixedPrefix) getFixedPrefix declName info mvarId
let rec go (mvarId : MVarId) : MetaM Unit := do
trace[Elab.definition.wf.eqns] "step\n{MessageData.ofGoal mvarId}"
if ( tryURefl mvarId) then
return ()
else if ( tryContradiction mvarId) then
return ()
else if let some mvarId simpMatchWF? mvarId then
else if let some mvarId simpMatchWF? info us fixedPrefix mvarId then
go mvarId
else if let some mvarId simpIf? mvarId then
go mvarId
@@ -96,10 +177,9 @@ private partial def mkProof (declName : Name) (type : Expr) : MetaM Expr := do
mvarIds.forM go
else if let some mvarIds splitTarget? mvarId then
mvarIds.forM go
else if let some mvarId tryToFoldLHS? info us fixedPrefix mvarId then
go mvarId
else
-- At some point in the past, we looked for occurences of Wf.fix to fold on the
-- LHS (introduced in 096e4eb), but it seems that code path was never used,
-- so #3133 removed it again (and can be recovered from there if this was premature).
throwError "failed to generate equational theorem for '{declName}'\n{MessageData.ofGoal mvarId}"
go ( rwFixEq ( deltaLHSUntilFix mvarId))
instantiateMVars main
@@ -118,7 +198,7 @@ def mkEqns (declName : Name) (info : EqnInfo) : MetaM (Array Name) :=
trace[Elab.definition.wf.eqns] "{eqnTypes[i]!}"
let name := baseName ++ (`_eq).appendIndexAfter (i+1)
thmNames := thmNames.push name
let value mkProof declName type
let value mkProof declName info type
let (type, value) removeUnusedEqnHypotheses type value
addDecl <| Declaration.thmDecl {
name, type, value

View File

@@ -13,7 +13,6 @@ import Lean.Elab.RecAppSyntax
import Lean.Elab.PreDefinition.Basic
import Lean.Elab.PreDefinition.Structural.Basic
import Lean.Elab.PreDefinition.Structural.BRecOn
import Lean.Elab.PreDefinition.WF.PackMutual
import Lean.Data.Array
namespace Lean.Elab.WF
@@ -79,7 +78,9 @@ where
| Expr.app .. =>
match ( matchMatcherApp? e) with
| some matcherApp =>
if let some matcherApp matcherApp.addArg? F then
if !Structural.recArgHasLooseBVarsAt recFnName fixedPrefixSize e then
processApp F e
else if let some matcherApp matcherApp.addArg? F then
if !( Structural.refinedArgType matcherApp F) then
processApp F e
else
@@ -95,7 +96,9 @@ where
| none =>
match ( toCasesOnApp? e) with
| some casesOnApp =>
if let some casesOnApp casesOnApp.addArg? F (checkIfRefined := true) then
if !Structural.recArgHasLooseBVarsAt recFnName fixedPrefixSize e then
processApp F e
else if let some casesOnApp casesOnApp.addArg? F (checkIfRefined := true) then
let altsNew (Array.zip casesOnApp.alts casesOnApp.altNumParams).mapM fun (alt, numParams) =>
lambdaTelescope alt fun xs altBody => do
unless xs.size >= numParams do
@@ -183,48 +186,22 @@ def assignSubsumed (mvars : Array MVarId) : MetaM (Array MVarId) :=
return (false, true)
return (true, true)
/--
The subgoals, created by `mkDecreasingProof`, are of the form `[data _recApp: rel arg param]`, where
`param` is the `PackMutual`'ed parameter of the current function, and thus we can peek at that to
know which function is making the call.
The close coupling with how arguments are packed and termination goals look like is not great,
but it works for now.
-/
def groupGoalsByFunction (numFuncs : Nat) (goals : Array MVarId) : MetaM (Array (Array MVarId)) := do
let mut r := mkArray numFuncs #[]
for goal in goals do
let (.mdata _ (.app _ param)) goal.getType
| throwError "MVar does not look like like a recursive call"
let (funidx, _) unpackMutualArg numFuncs param
r := r.modify funidx (·.push goal)
return r
def solveDecreasingGoals (decrTactics : Array (Option DecreasingBy)) (value : Expr) : MetaM Expr := do
def solveDecreasingGoals (decrTactic? : Option Syntax) (value : Expr) : MetaM Expr := do
let goals getMVarsNoDelayed value
let goals assignSubsumed goals
let goalss groupGoalsByFunction decrTactics.size goals
for goals in goalss, decrTactic? in decrTactics do
Lean.Elab.Term.TermElabM.run' do
goals.forM fun goal => Lean.Elab.Term.TermElabM.run' <|
match decrTactic? with
| none => do
for goal in goals do
let some ref := getRecAppSyntax? ( goal.getType)
| throwError "MVar does not look like like a recursive call"
let some ref := getRecAppSyntax? ( goal.getType)
| throwError "MVar does not look like like a recursive call"
withRef ref <| applyDefaultDecrTactic goal
| some decrTactic => withRef decrTactic.ref do
unless goals.isEmpty do -- unlikely to be empty
-- make info from `runTactic` available
goals.forM fun goal => pushInfoTree (.hole goal)
let remainingGoals Tactic.run goals[0]! do
Tactic.setGoals goals.toList
Tactic.withTacticInfoContext decrTactic.ref do
Tactic.evalTactic decrTactic.tactic
unless remainingGoals.isEmpty do
Term.reportUnsolvedGoals remainingGoals
| some decrTactic => do
-- make info from `runTactic` available
pushInfoTree (.hole goal)
Term.runTactic goal decrTactic
instantiateMVars value
def mkFix (preDef : PreDefinition) (prefixArgs : Array Expr) (wfRel : Expr)
(decrTactics : Array (Option DecreasingBy)) : TermElabM Expr := do
def mkFix (preDef : PreDefinition) (prefixArgs : Array Expr) (wfRel : Expr) (decrTactic? : Option Syntax) : TermElabM Expr := do
let type instantiateForall preDef.type prefixArgs
let (wfFix, varName) forallBoundedTelescope type (some 1) fun x type => do
let x := x[0]!
@@ -247,7 +224,7 @@ def mkFix (preDef : PreDefinition) (prefixArgs : Array Expr) (wfRel : Expr)
let val := preDef.value.beta (prefixArgs.push x)
let val processSumCasesOn x F val fun x F val => do
processPSigmaCasesOn x F val (replaceRecApps preDef.declName prefixArgs.size)
let val solveDecreasingGoals decrTactics val
let val solveDecreasingGoals decrTactic? val
mkLambdaFVars prefixArgs (mkApp wfFix ( mkLambdaFVars #[x, F] val))
end Lean.Elab.WF

View File

@@ -72,42 +72,27 @@ register_builtin_option showInferredTerminationBy : Bool := {
descr := "In recursive definitions, show the inferred `termination_by` measure."
}
/--
Given a predefinition, return the variabe names in the outermost lambdas.
Includes the “fixed prefix”.
Given a predefinition, find good variable names for its parameters.
Use user-given parameter names if present; use x1...xn otherwise.
The length of the returned array is also used to determine the arity
of the function, so it should match what `packDomain` does.
-/
def originalVarNames (preDef : PreDefinition) : MetaM (Array Name) := do
lambdaTelescope preDef.value fun xs _ => xs.mapM (·.fvarId!.getUserName)
/--
Given the original paramter names from `originalVarNames`, remove the fixed prefix and find
good variable names to be used when talking about termination arguments:
Use user-given parameter names if present; use x1...xn otherwise.
The names ought to accessible (no macro scopes) and new names fresh wrt to the current environment,
The names ought to accessible (no macro scopes) and still fresh wrt to the current environment,
so that with `showInferredTerminationBy` we can print them to the user reliably.
We do that by appending `'` as needed.
It is possible (but unlikely without malice) that some of the user-given names
shadow each other, and the guessed relation refers to the wrong one. In that
case, the user gets to keep both pieces (and may have to rename variables).
-/
partial
def naryVarNames (fixedPrefixSize : Nat) (xs : Array Name) : MetaM (Array Name) := do
let xs := xs.extract fixedPrefixSize xs.size
let mut ns : Array Name := #[]
for h : i in [:xs.size] do
let n := xs[i]
let n if n.hasMacroScopes then
freshen ns (.mkSimple s!"x{i+1}")
else
pure n
ns := ns.push n
return ns
def naryVarNames (fixedPrefixSize : Nat) (preDef : PreDefinition) : MetaM (Array Name):= do
lambdaTelescope preDef.value fun xs _ => do
let xs := xs.extract fixedPrefixSize xs.size
let mut ns : Array Name := #[]
for h : i in [:xs.size] do
let n (xs[i]'h.2).fvarId!.getUserName
let n := if n.hasMacroScopes then .mkSimple s!"x{i+1}" else n
ns := ns.push ( freshen ns n)
return ns
where
freshen (ns : Array Name) (n : Name): MetaM Name := do
if !(ns.elem n) && ( resolveGlobalName n).isEmpty then
@@ -129,7 +114,7 @@ or `casesOn` application.
-/
partial def withRecApps {α} (recFnName : Name) (fixedPrefixSize : Nat) (param : Expr) (e : Expr)
(k : Expr Array Expr MetaM α) : MetaM (Array α) := do
trace[Elab.definition.wf] "withRecApps (param {param}): {indentExpr e}"
trace[Elab.definition.wf] "withRecApps: {indentExpr e}"
let (_, as) loop param e |>.run #[] |>.run' {}
return as
where
@@ -178,24 +163,27 @@ where
| Expr.app .. =>
match ( matchMatcherApp? e) with
| some matcherApp =>
if let some altParams matcherApp.refineThrough? param then
matcherApp.discrs.forM (loop param)
(Array.zip matcherApp.alts (Array.zip matcherApp.altNumParams altParams)).forM
fun (alt, altNumParam, altParam) =>
lambdaTelescope altParam fun xs altParam => do
-- TODO: Use boundedLambdaTelescope
unless altNumParam = xs.size do
throwError "unexpected `casesOn` application alternative{indentExpr alt}\nat application{indentExpr e}"
let altBody := alt.beta xs
loop altParam altBody
matcherApp.remaining.forM (loop param)
else
if !Structural.recArgHasLooseBVarsAt recFnName fixedPrefixSize e then
processApp param e
else
if let some altParams matcherApp.refineThrough? param then
(Array.zip matcherApp.alts (Array.zip matcherApp.altNumParams altParams)).forM
fun (alt, altNumParam, altParam) =>
lambdaTelescope altParam fun xs altParam => do
-- TODO: Use boundedLambdaTelescope
unless altNumParam = xs.size do
throwError "unexpected `casesOn` application alternative{indentExpr alt}\nat application{indentExpr e}"
let altBody := alt.beta xs
loop altParam altBody
else
processApp param e
| none =>
match ( toCasesOnApp? e) with
| some casesOnApp =>
if let some altParams casesOnApp.refineThrough? param then
loop param casesOnApp.major
if !Structural.recArgHasLooseBVarsAt recFnName fixedPrefixSize e then
processApp param e
else
if let some altParams casesOnApp.refineThrough? param then
(Array.zip casesOnApp.alts (Array.zip casesOnApp.altNumParams altParams)).forM
fun (alt, altNumParam, altParam) =>
lambdaTelescope altParam fun xs altParam => do
@@ -204,10 +192,8 @@ where
throwError "unexpected `casesOn` application alternative{indentExpr alt}\nat application{indentExpr e}"
let altBody := alt.beta xs
loop altParam altBody
casesOnApp.remaining.forM (loop param)
else
trace[Elab.definition.wf] "withRecApps: casesOnApp.refineThrough? failed"
processApp param e
else
processApp param e
| none => processApp param e
| e => do
let _ ensureNoRecFn recFnName e
@@ -288,12 +274,12 @@ def collectRecCalls (unaryPreDef : PreDefinition) (fixedPrefixSize : Nat) (ariti
unless xs.size == fixedPrefixSize + 1 do
-- Maybe cleaner to have lambdaBoundedTelescope?
throwError "Unexpected number of lambdas in unary pre-definition"
-- trace[Elab.definition.wf] "collectRecCalls: {xs} {body}"
let param := xs[fixedPrefixSize]!
withRecApps unaryPreDef.declName fixedPrefixSize param body fun param args => do
unless args.size fixedPrefixSize + 1 do
throwError "Insufficient arguments in recursive call"
let arg := args[fixedPrefixSize]!
trace[Elab.definition.wf] "collectRecCalls: {unaryPreDef.declName} ({param}) → {unaryPreDef.declName} ({arg})"
let (caller, params) unpackArg arities param
let (callee, args) unpackArg arities arg
RecCallWithContext.create ( getRef) caller params callee args
@@ -332,7 +318,7 @@ def mkSizeOf (e : Expr) : MetaM Expr := do
For a given recursive call, and a choice of parameter and argument index,
try to prove equality, < or ≤.
-/
def evalRecCall (decrTactic? : Option DecreasingBy) (rcc : RecCallWithContext) (paramIdx argIdx : Nat) :
def evalRecCall (decrTactic? : Option Syntax) (rcc : RecCallWithContext) (paramIdx argIdx : Nat) :
MetaM GuessLexRel := do
rcc.ctxt.run do
let param := rcc.params[paramIdx]!
@@ -348,20 +334,25 @@ def evalRecCall (decrTactic? : Option DecreasingBy) (rcc : RecCallWithContext) (
let mvar mkFreshExprSyntheticOpaqueMVar goalExpr
let mvarId := mvar.mvarId!
let mvarId mvarId.cleanup
-- logInfo m!"Remaining goals: {goalsToMessageData [mvarId]}"
try
if rel = .eq then
MVarId.refl mvarId
else do
Lean.Elab.Term.TermElabM.run' do Term.withoutErrToSorry do
let remainingGoals Tactic.run mvarId do Tactic.withoutRecover do
let tacticStx : Syntax
match decrTactic? with
| none => pure ( `(tactic| decreasing_tactic)).raw
| some decrTactic =>
trace[Elab.definition.wf] "Using tactic {decrTactic.tactic.raw}"
pure decrTactic.tactic.raw
Tactic.evalTactic tacticStx
remainingGoals.forM fun _ => throwError "goal not solved"
Lean.Elab.Term.TermElabM.run' do
match decrTactic? with
| none =>
let remainingGoals Tactic.run mvarId do
Tactic.evalTactic ( `(tactic| decreasing_tactic))
remainingGoals.forM fun mvarId => Term.reportUnsolvedGoals [mvarId]
-- trace[Elab.definition.wf] "Found {rel} proof: {← instantiateMVars mvar}"
pure ()
| some decrTactic => Term.withoutErrToSorry do
-- make info from `runTactic` available
pushInfoTree (.hole mvarId)
Term.runTactic mvarId decrTactic
-- trace[Elab.definition.wf] "Found {rel} proof: {← instantiateMVars mvar}"
pure ()
trace[Elab.definition.wf] "inspectRecCall: success!"
return rel
catch _e =>
@@ -371,15 +362,13 @@ def evalRecCall (decrTactic? : Option DecreasingBy) (rcc : RecCallWithContext) (
/- A cache for `evalRecCall` -/
structure RecCallCache where mk'' ::
decrTactic? : Option DecreasingBy
decrTactic? : Option Syntax
rcc : RecCallWithContext
cache : IO.Ref (Array (Array (Option GuessLexRel)))
/-- Create a cache to memoize calls to `evalRecCall descTactic? rcc` -/
def RecCallCache.mk (decrTactics : Array (Option DecreasingBy))
(rcc : RecCallWithContext) :
def RecCallCache.mk (decrTactic? : Option Syntax) (rcc : RecCallWithContext) :
BaseIO RecCallCache := do
let decrTactic? := decrTactics[rcc.caller]!
let cache IO.mkRef <| Array.mkArray rcc.params.size (Array.mkArray rcc.args.size Option.none)
return { decrTactic?, rcc, cache }
@@ -516,7 +505,7 @@ partial def solve {m} {α} [Monad m] (measures : Array α)
-- Find the first measure that has at least one < and otherwise only = or <=
for h : measureIdx in [:measures.size] do
let measure := measures[measureIdx]
let measure := measures[measureIdx]'h.2
let mut has_lt := false
let mut all_le := true
let mut todo := #[]
@@ -547,47 +536,29 @@ def mkTupleSyntax : Array Term → MetaM Term
/--
Given an array of `MutualMeasures`, creates a `TerminationWF` that specifies the lexicographic
combination of these measures. The parameters are
* `originalVarNamess`: For each function in the clique, the original parameter names, _including_
the fixed prefix. Used to determine if we need to fully qualify `sizeOf`.
* `varNamess`: For each function in the clique, the parameter names to be used in the
termination relation. Excludes the fixed prefix. Includes names like `x1` for unnamed parameters.
* `measures`: The measures to be used.
combination of these measures.
-/
def buildTermWF (originalVarNamess : Array (Array Name)) (varNamess : Array (Array Name))
(measures : Array MutualMeasure) : MetaM TerminationWF := do
varNamess.mapIdxM fun funIdx varNames => do
let idents := varNames.map mkIdent
let measureStxs measures.mapM fun
def buildTermWF (declNames : Array Name) (varNamess : Array (Array Name))
(measures : Array MutualMeasure) : MetaM TerminationWF := do
let mut termByElements := #[]
for h : funIdx in [:varNamess.size] do
let vars := (varNamess[funIdx]'h.2).map mkIdent
let body mkTupleSyntax ( measures.mapM fun
| .args varIdxs => do
let varIdx := varIdxs[funIdx]!
let v := idents[varIdx]!
-- Print `sizeOf` as such, unless it is shadowed.
-- Shadowing by a `def` in the current namespace is handled by `unresolveNameGlobal`.
-- But it could also be shadowed by an earlier parameter (including the fixed prefix),
-- so look for unqualified (single tick) occurrences in `originalVarNames`
let sizeOfIdent :=
if originalVarNamess[funIdx]!.any (· = `sizeOf) then
mkIdent ``sizeOf -- fully qualified
else
mkIdent ( unresolveNameGlobal ``sizeOf)
let v := vars.get! (varIdxs[funIdx]!)
let sizeOfIdent := mkIdent ( unresolveNameGlobal ``sizeOf)
`($sizeOfIdent $v)
| .func funIdx' => if funIdx' == funIdx then `(1) else `(0)
let body mkTupleSyntax measureStxs
return { ref := .missing, vars := idents, body, synthetic := true }
)
let declName := declNames[funIdx]!
termByElements := termByElements.push
{ ref := .missing
declName, vars, body,
implicit := true
}
return termByElements
/--
The TerminationWF produced by GuessLex may mention more variables than allowed in the surface
syntax (in case of unnamed or shadowed parameters). So how to print this to the user? Invalid
syntax with more information, or valid syntax with (possibly) unresolved variable names?
The latter works fine in many cases, and is still useful to the user in the tricky corner cases, so
we do that.
-/
def trimTermWF (extraParams : Array Nat) (elems : TerminationWF) : TerminationWF :=
elems.mapIdx fun funIdx elem => { elem with
vars := elem.vars[elem.vars.size - extraParams[funIdx]! : elem.vars.size]
synthetic := false }
/--
Given a matrix (row-major) of strings, arranges them in tabular form.
@@ -596,14 +567,14 @@ Single space as column separator.
-/
def formatTable : Array (Array String) String := fun xss => Id.run do
let mut colWidths := xss[0]!.map (fun _ => 0)
for hi : i in [:xss.size] do
for hj : j in [:xss[i].size] do
if xss[i][j].length > colWidths[j]! then
colWidths := colWidths.set! j xss[i][j].length
for i in [:xss.size] do
for j in [:xss[i]!.size] do
if xss[i]![j]!.length > colWidths[j]! then
colWidths := colWidths.set! j xss[i]![j]!.length
let mut str := ""
for hi : i in [:xss.size] do
for hj : j in [:xss[i].size] do
let s := xss[i][j]
for i in [:xss.size] do
for j in [:xss[i]!.size] do
let s := xss[i]![j]!
if j > 0 then -- right-align
for _ in [:colWidths[j]! - s.length] do
str := str ++ " "
@@ -611,7 +582,7 @@ def formatTable : Array (Array String) → String := fun xss => Id.run do
if j = 0 then -- left-align
for _ in [:colWidths[j]! - s.length] do
str := str ++ " "
if j + 1 < xss[i].size then
if j + 1 < xss[i]!.size then
str := str ++ " "
if i + 1 < xss.size then
str := str ++ "\n"
@@ -697,12 +668,10 @@ Main entry point of this module:
Try to find a lexicographic ordering of the arguments for which the recursive definition
terminates. See the module doc string for a high-level overview.
-/
def guessLex (preDefs : Array PreDefinition) (unaryPreDef : PreDefinition)
(fixedPrefixSize : Nat) :
def guessLex (preDefs : Array PreDefinition) (unaryPreDef : PreDefinition)
(fixedPrefixSize : Nat) (decrTactic? : Option Syntax) :
MetaM TerminationWF := do
let extraParamss := preDefs.map (·.termination.extraParams)
let originalVarNamess preDefs.mapM originalVarNames
let varNamess originalVarNamess.mapM (naryVarNames fixedPrefixSize ·)
let varNamess preDefs.mapM (naryVarNames fixedPrefixSize ·)
let arities := varNamess.map (·.size)
trace[Elab.definition.wf] "varNames is: {varNamess}"
@@ -715,22 +684,24 @@ def guessLex (preDefs : Array PreDefinition) (unaryPreDef : PreDefinition)
-- If there is only one plausible measure, use that
if let #[solution] := measures then
return buildTermWF originalVarNamess varNamess #[solution]
return buildTermWF (preDefs.map (·.declName)) varNamess #[solution]
-- Collect all recursive calls and extract their context
let recCalls collectRecCalls unaryPreDef fixedPrefixSize arities
let recCalls := filterSubsumed recCalls
let rcs recCalls.mapM (RecCallCache.mk (preDefs.map (·.termination.decreasing_by?)) ·)
let rcs recCalls.mapM (RecCallCache.mk decrTactic? ·)
let callMatrix := rcs.map (inspectCall ·)
match liftMetaM <| solve measures callMatrix with
| .some solution => do
let wf buildTermWF originalVarNamess varNamess solution
let wf buildTermWF (preDefs.map (·.declName)) varNamess solution
let wfStx withoutModifyingState do
preDefs.forM (addAsAxiom ·)
wf.unexpand
if showInferredTerminationBy.get ( getOptions) then
let wf' := trimTermWF extraParamss wf
for preDef in preDefs, term in wf' do
logInfoAt preDef.ref m!"Inferred termination argument: {← term.unexpand}"
logInfo m!"Inferred termination argument:{wfStx}"
return wf
| .none =>

View File

@@ -80,9 +80,8 @@ private def isOnlyOneUnaryDef (preDefs : Array PreDefinition) (fixedPrefixSize :
else
return false
def wfRecursion (preDefs : Array PreDefinition) : TermElabM Unit := do
let preDefs preDefs.mapM fun preDef =>
return { preDef with value := ( preprocess preDef.value) }
def wfRecursion (preDefs : Array PreDefinition) (wf? : Option TerminationWF) (decrTactic? : Option Syntax) : TermElabM Unit := do
let preDefs preDefs.mapM fun preDef => return { preDef with value := ( preprocess preDef.value) }
let (unaryPreDef, fixedPrefixSize) withoutModifyingEnv do
for preDef in preDefs do
addAsAxiom preDef
@@ -92,19 +91,11 @@ def wfRecursion (preDefs : Array PreDefinition) : TermElabM Unit := do
let unaryPreDefs packDomain fixedPrefixSize preDefsDIte
return ( packMutual fixedPrefixSize preDefs unaryPreDefs, fixedPrefixSize)
let wf do
let (preDefsWith, preDefsWithout) := preDefs.partition (·.termination.termination_by?.isSome)
if preDefsWith.isEmpty then
-- No termination_by anywhere, so guess one
guessLex preDefs unaryPreDef fixedPrefixSize
else if preDefsWithout.isEmpty then
pure <| preDefsWith.map (·.termination.termination_by?.get!)
let wf
if let .some wf := wf? then
pure wf
else
-- Some have, some do not, so report errors
preDefsWithout.forM fun preDef => do
logErrorAt preDef.ref (m!"Missing `termination_by`; this function is mutually " ++
m!"recursive with {preDefsWith[0]!.declName}, which has a `termination_by` clause.")
return
guessLex preDefs unaryPreDef fixedPrefixSize decrTactic?
let preDefNonRec forallBoundedTelescope unaryPreDef.type fixedPrefixSize fun prefixArgs type => do
let type whnfForall type
@@ -113,7 +104,7 @@ def wfRecursion (preDefs : Array PreDefinition) : TermElabM Unit := do
trace[Elab.definition.wf] "wfRel: {wfRel}"
let (value, envNew) withoutModifyingEnv' do
addAsAxiom unaryPreDef
let value mkFix unaryPreDef prefixArgs wfRel (preDefs.map (·.termination.decreasing_by?))
let value mkFix unaryPreDef prefixArgs wfRel decrTactic?
eraseRecAppSyntaxExpr value
/- `mkFix` invokes `decreasing_tactic` which may add auxiliary theorems to the environment. -/
let value unfoldDeclsFrom envNew value

View File

@@ -9,12 +9,6 @@ import Lean.Elab.RecAppSyntax
namespace Lean.Elab.WF
open Meta
private def shouldBetaReduce (e : Expr) (recFnNames : Array Name) : Bool :=
if e.isHeadBetaTarget then
e.getAppFn.find? (fun e => recFnNames.any (e.isConstOf ·)) |>.isSome
else
false
/--
Preprocesses the expessions to improve the effectiveness of `wfRecursion`.
@@ -31,11 +25,13 @@ remove `let_fun`-lambdas that contain explicit termination proofs.
-/
def preprocess (e : Expr) : CoreM Expr :=
Core.transform e
(post := fun e => do
if e.isApp && e.getAppFn.isMData then
let .mdata m f := e.getAppFn | unreachable!
(post := fun e =>
match e with
| .app (.mdata m f) a =>
if m.isRecApp then
return .done (.mdata m (f.beta e.getAppArgs))
return .continue)
return .done (.mdata m (.app f a))
else
return .done e
| _ => return .done e)
end Lean.Elab.WF

View File

@@ -14,6 +14,12 @@ namespace Lean.Elab.WF
open Meta
open Term
private def getRefFromElems (elems : Array TerminationByElement) : Syntax := Id.run do
for elem in elems do
if !elem.implicit then
return elem.ref
return elems[0]!.ref
private partial def unpackMutual (preDefs : Array PreDefinition) (mvarId : MVarId) (fvarId : FVarId) : TermElabM (Array (FVarId × MVarId)) := do
let rec go (i : Nat) (mvarId : MVarId) (fvarId : FVarId) (result : Array (FVarId × MVarId)) : TermElabM (Array (FVarId × MVarId)) := do
if i < preDefs.size - 1 then
@@ -23,21 +29,15 @@ private partial def unpackMutual (preDefs : Array PreDefinition) (mvarId : MVarI
return result.push (fvarId, mvarId)
go 0 mvarId fvarId #[]
private partial def unpackUnary (preDef : PreDefinition) (prefixSize : Nat) (mvarId : MVarId)
(fvarId : FVarId) (element : TerminationBy) : TermElabM MVarId := do
element.checkVars preDef.declName preDef.termination.extraParams
-- If `synthetic := false`, then this is user-provided, and should be interpreted
-- as left to right. Else it is provided by GuessLex, and may rename non-extra paramters as well.
-- (Not pretty, but it works for now)
let implicit_underscores :=
if element.synthetic then 0 else preDef.termination.extraParams - element.vars.size
private partial def unpackUnary (preDef : PreDefinition) (prefixSize : Nat) (mvarId : MVarId) (fvarId : FVarId) (element : TerminationByElement) : TermElabM MVarId := do
let varNames lambdaTelescope preDef.value fun xs _ => do
let mut varNames xs.mapM fun x => x.fvarId!.getUserName
if element.vars.size > varNames.size then
throwErrorAt element.vars[varNames.size]! "too many variable names"
for h : i in [:element.vars.size] do
let varStx := element.vars[i]
let varStx := element.vars[i]'h.2
if let `($ident:ident) := varStx then
let j := varNames.size - implicit_underscores - element.vars.size + i
varNames := varNames.set! j ident.getId
varNames := varNames.set! (varNames.size - element.vars.size + i) ident.getId
return varNames
let mut mvarId := mvarId
for localDecl in ( Term.getMVarDecl mvarId).lctx, varName in varNames[:prefixSize] do
@@ -60,6 +60,7 @@ def elabWFRel (preDefs : Array PreDefinition) (unaryPreDefName : Name) (fixedPre
let expectedType := mkApp (mkConst ``WellFoundedRelation [u]) α
trace[Elab.definition.wf] "elabWFRel start: {(← mkFreshTypeMVar).mvarId!}"
withDeclName unaryPreDefName do
withRef (getRefFromElems wf) do
let mainMVarId := ( mkFreshExprSyntheticOpaqueMVar expectedType).mvarId!
let [fMVarId, wfRelMVarId, _] mainMVarId.apply ( mkConstWithFreshMVarLevels ``invImage) | throwError "failed to apply 'invImage'"
let (d, fMVarId) fMVarId.intro1

View File

@@ -1,128 +1,213 @@
/-
Copyright (c) 2021 Microsoft Corporation. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Leonardo de Moura, Joachim Breitner
Authors: Leonardo de Moura
-/
import Lean.Parser.Term
import Lean.Parser.Command
set_option autoImplicit false
namespace Lean.Elab.WF
/-! # Support for `decreasing_by` -/
structure DecreasingByTactic where
ref : Syntax
value : Lean.TSyntax `Lean.Parser.Tactic.tacticSeq
deriving Inhabited
inductive DecreasingBy where
| none
| one (val : DecreasingByTactic)
| many (map : NameMap DecreasingByTactic)
deriving Inhabited
open Parser.Command in
/--
This function takes a user-specified `decreasing_by` clause (as `Sytnax`).
If it is a `decreasingByMany` (a set of clauses guarded by the function name) then
* checks that all mentioned names exist in the current declaration
* check that at most one function from each clique is mentioned
and sort the entries by function name.
-/
def expandDecreasingBy? (decreasingBy? : Option Syntax) (cliques : Array (Array Name)) : MacroM DecreasingBy := do
let some decreasingBy := decreasingBy? | return DecreasingBy.none
let ref := decreasingBy
match decreasingBy with
| `(decreasingBy|decreasing_by $hint1:tacticSeq) =>
return DecreasingBy.one { ref, value := hint1 }
| `(decreasingBy|decreasing_by $hints:decreasingByMany) => do
let m hints.raw[0].getArgs.foldlM (init := {}) fun m arg => do
let arg : TSyntax `decreasingByElement := arg -- cannot use syntax pattern match with lookahead
let `(decreasingByElement| $declId:ident => $tac:tacticSeq) := arg | Macro.throwUnsupported
let declName? := cliques.findSome? fun clique => clique.findSome? fun declName =>
if declId.getId.isSuffixOf declName then some declName else none
match declName? with
| none => Macro.throwErrorAt declId s!"function '{declId.getId}' not found in current declaration"
| some declName => return m.insert declName { ref := arg, value := tac }
for clique in cliques do
let mut found? := Option.none
for declName in clique do
if let some { ref, .. } := m.find? declName then
if let some found := found? then
Macro.throwErrorAt ref s!"invalid termination hint element, '{declName}' and '{found}' are in the same clique"
found? := some declName
return DecreasingBy.many m
| _ => Macro.throwUnsupported
def DecreasingBy.markAsUsed (t : DecreasingBy) (clique : Array Name) : DecreasingBy :=
match t with
| DecreasingBy.none => DecreasingBy.none
| DecreasingBy.one .. => DecreasingBy.none
| DecreasingBy.many m => Id.run do
for declName in clique do
if m.contains declName then
let m := m.erase declName
if m.isEmpty then
return DecreasingBy.none
else
return DecreasingBy.many m
return t
def DecreasingBy.find? (t : DecreasingBy) (clique : Array Name) : Option DecreasingByTactic :=
match t with
| DecreasingBy.none => Option.none
| DecreasingBy.one v => some v
| DecreasingBy.many m => clique.findSome? m.find?
def DecreasingBy.ensureAllUsed (t : DecreasingBy) : MacroM Unit := do
match t with
| DecreasingBy.one v => Macro.throwErrorAt v.ref "unused termination hint element"
| DecreasingBy.many m => m.forM fun _ v => Macro.throwErrorAt v.ref "unused termination hint element"
| _ => pure ()
/-! # Support for `termination_by` notation -/
/-- A single `termination_by` clause -/
structure TerminationBy where
structure TerminationByElement where
ref : Syntax
declName : Name
vars : TSyntaxArray [`ident, ``Lean.Parser.Term.hole]
body : Term
/--
If `synthetic := true`, then this `termination_by` clause was
generated by `GuessLex`, and `vars` refers to *all* parameters
of the function, not just the “extra parameters”.
Cf. Lean.Elab.WF.unpackUnary
-/
synthetic : Bool := false
implicit : Bool
deriving Inhabited
open Parser.Termination in
def TerminationBy.unexpand (wf : TerminationBy) : MetaM Syntax := do
-- TODO: Why can I not just use $wf.vars in the quotation below?
let vars : TSyntaxArray `ident := wf.vars.map (·.raw)
if vars.isEmpty then
`(terminationBy|termination_by $wf.body)
else
`(terminationBy|termination_by $vars* => $wf.body)
/-- A complete set of `termination_by` hints, as applicable to a single clique. -/
abbrev TerminationWF := Array TerminationBy
/-- A single `decreasing_by` clause -/
structure DecreasingBy where
ref : Syntax
tactic : TSyntax ``Lean.Parser.Tactic.tacticSeq
deriving Inhabited
/-- The termination annotations for a single function.
For `decreasing_by`, we store the whole `decreasing_by tacticSeq` expression, as this
is what `Term.runTactic` expects.
-/
structure TerminationHints where
ref : Syntax
termination_by? : Option TerminationBy
decreasing_by? : Option DecreasingBy
/-- Here we record the number of parameters past the `:`. It is set by
`TerminationHints.rememberExtraParams` and used as folows:
* When we guess the termination argument in `GuessLex` and want to print it in surface-syntax
compatible form.
* If there are fewer variables in the `termination_by` annotation than there are extra
parameters, we know which parameters they should apply to (`TerminationBy.checkVars`).
-/
extraParams : Nat
deriving Inhabited
def TerminationHints.none : TerminationHints := .missing, .none, .none, 0
/-- Logs warnings when the `TerminationHints` are present. -/
def TerminationHints.ensureNone (hints : TerminationHints) (reason : String): CoreM Unit := do
match hints.termination_by?, hints.decreasing_by? with
| .none, .none => pure ()
| .none, .some dec_by =>
logErrorAt dec_by.ref m!"unused `decreasing_by`, function is {reason}"
| .some term_by, .none =>
logErrorAt term_by.ref m!"unused `termination_by`, function is {reason}"
| .some _, .some _ =>
logErrorAt hints.ref m!"unused termination hints, function is {reason}"
/-- `termination_by` clauses, grouped by clique -/
structure TerminationByClique where
elements : Array TerminationByElement
used : Bool := false
/--
Remembers `extraParams` for later use. Needs to happen early enough where we still know
how many parameters came from the function header (`headerParams`).
A `termination_by` hint, as specified by the user
-/
def TerminationHints.rememberExtraParams (headerParams : Nat) (hints : TerminationHints)
(value : Expr) : TerminationHints :=
{ hints with extraParams := value.getNumHeadLambdas - headerParams }
structure TerminationBy where
cliques : Array TerminationByClique
deriving Inhabited
/--
Checks that `termination_by` binds at most as many variables are present in the outermost
lambda of `value`, and throws appropriate errors.
A `termination_by` hint, as applicable to a single clique
-/
def TerminationBy.checkVars (funName : Name) (extraParams : Nat) (tb : TerminationBy) : MetaM Unit := do
unless tb.synthetic do
if tb.vars.size > extraParams then
let mut msg := m!"{parameters tb.vars.size} bound in `termination_by`, but the body of " ++
m!"{funName} only binds {parameters extraParams}."
if let `($ident:ident) := tb.vars[0]! then
if ident.getId.isSuffixOf funName then
msg := msg ++ m!" (Since Lean v4.6.0, the `termination_by` clause no longer " ++
"expects the function name here.)"
throwErrorAt tb.ref msg
where
parameters : Nat MessageData
| 1 => "one parameter"
| n => m!"{n} parameters"
abbrev TerminationWF := Array TerminationByElement
open Parser.Termination
open Parser.Command in
/--
Expands the syntax for a `termination_by` clause, checking that
* each function is mentioned once
* each function mentioned actually occurs in the current declaration
* if anything is specified, then all functions have a clause
* the else-case (`_`) occurs only once, and only when needed
/-- Takes apart a `Termination.suffix` syntax object -/
def elabTerminationHints {m} [Monad m] [MonadError m] (stx : TSyntax ``suffix) : m TerminationHints := do
-- Fail gracefully upon partial parses
if let .missing := stx.raw then
return { TerminationHints.none with ref := stx }
match stx with
| `(suffix| $[$t?:terminationBy]? $[$d?:decreasingBy]? ) => do
let termination_by? t?.mapM fun t => match t with
| `(terminationBy|termination_by $vars* => $body) =>
if vars.isEmpty then
throwErrorAt t "no extra parameters bounds, please omit the `=>`"
else
pure {ref := t, vars, body}
| `(terminationBy|termination_by $body:term) => pure {ref := t, vars := #[], body}
| _ => throwErrorAt t "unexpected `termination_by` syntax"
let decreasing_by? d?.mapM fun d => match d with
| `(decreasingBy|decreasing_by $tactic) => pure {ref := d, tactic}
| _ => throwErrorAt d "unexpected `decreasing_by` syntax"
return { ref := stx, termination_by?, decreasing_by?, extraParams := 0 }
| _ => throwErrorAt stx s!"Unexpected Termination.suffix syntax: {stx} of kind {stx.raw.getKind}"
NB:
```
def terminationByElement := leading_parser ppLine >> (ident <|> hole) >> many (ident <|> hole) >> " => " >> termParser >> optional ";"
def terminationBy := leading_parser ppLine >> "termination_by " >> many1chIndent terminationByElement
```
-/
def expandTerminationBy? (hint? : Option Syntax) (cliques : Array (Array Name)) :
MacroM TerminationBy := do
let some hint := hint? | return { cliques := #[] }
let `(terminationBy|termination_by $elementStxs*) := hint | Macro.throwUnsupported
let mut alreadyFound : NameSet := {}
let mut elseElemStx? := none
for elementStx in elementStxs do
match elementStx with
| `(terminationByElement|$ident:ident $_* => $_) =>
let declSuffix := ident.getId
if alreadyFound.contains declSuffix then
withRef elementStx <| Macro.throwError s!"invalid `termination_by` syntax, `{declSuffix}` case has already been provided"
alreadyFound := alreadyFound.insert declSuffix
if cliques.all fun clique => clique.all fun declName => !declSuffix.isSuffixOf declName then
withRef elementStx <| Macro.throwError s!"function '{declSuffix}' not found in current declaration"
| `(terminationByElement|_ $_vars* => $_term) =>
if elseElemStx?.isSome then
withRef elementStx <| Macro.throwError "invalid `termination_by` syntax, the else-case (i.e., `_ ... => ...`) has already been specified"
else
elseElemStx? := some elementStx
| _ => Macro.throwUnsupported
let toElement (declName : Name) (elementStx : TSyntax ``terminationByElement) : TerminationByElement :=
match elementStx with
| `(terminationByElement|$ioh $vars* => $body:term) =>
let implicit := !ioh.raw.isIdent
{ ref := elementStx, declName, vars, implicit, body }
| _ => unreachable!
let elementAppliesTo (declName : Name) : TSyntax ``terminationByElement Bool
| `(terminationByElement|$ident:ident $_* => $_) => ident.getId.isSuffixOf declName
| _ => false
let mut result := #[]
let mut usedElse := false
for clique in cliques do
let mut elements := #[]
for declName in clique do
if let some elementStx := elementStxs.find? (elementAppliesTo declName) then
elements := elements.push (toElement declName elementStx)
else if let some elseElemStx := elseElemStx? then
elements := elements.push (toElement declName elseElemStx)
usedElse := true
unless elements.isEmpty do
if let some missing := clique.find? fun declName => elements.find? (·.declName == declName) |>.isNone then
withRef elements[0]!.ref <| Macro.throwError s!"invalid `termination_by` syntax, missing case for function '{missing}'"
result := result.push { elements }
if !usedElse && elseElemStx?.isSome then
withRef elseElemStx?.get! <| Macro.throwError s!"invalid `termination_by` syntax, unnecessary else-case"
return result
open Parser.Command in
def TerminationWF.unexpand (elements : TerminationWF) : MetaM Syntax := do
let elementStxs elements.mapM fun element => do
let fn : Ident := mkIdent ( unresolveNameGlobal element.declName)
`(terminationByElement|$fn $element.vars* => $element.body)
`(terminationBy|termination_by $elementStxs*)
def TerminationBy.markAsUsed (t : TerminationBy) (cliqueNames : Array Name) : TerminationBy :=
.mk <| t.cliques.map fun clique =>
if cliqueNames.any fun name => clique.elements.any fun elem => elem.declName == name then
{ clique with used := true }
else
clique
def TerminationBy.find? (t : TerminationBy) (cliqueNames : Array Name) : Option TerminationWF :=
t.cliques.findSome? fun clique =>
if cliqueNames.any fun name => clique.elements.any fun elem => elem.declName == name then
some <| clique.elements
else
none
def TerminationByClique.allImplicit (c : TerminationByClique) : Bool :=
c.elements.all fun elem => elem.implicit
def TerminationByClique.getExplicitElement? (c : TerminationByClique) : Option TerminationByElement :=
c.elements.find? (!·.implicit)
def TerminationBy.ensureAllUsed (t : TerminationBy) : MacroM Unit := do
let hasUsedAllImplicit := t.cliques.any fun c => c.allImplicit && c.used
let mut reportedAllImplicit := true
for clique in t.cliques do
unless clique.used do
if let some explicitElem := clique.getExplicitElement? then
Macro.throwErrorAt explicitElem.ref "unused termination hint element"
else if !hasUsedAllImplicit then
unless reportedAllImplicit do
reportedAllImplicit := true
Macro.throwErrorAt clique.elements[0]!.ref "unused termination hint element"
end Lean.Elab.WF

View File

@@ -491,10 +491,7 @@ mutual
let valStx := valStx.setArg 2 (mkNullNode <| mkSepArray args (mkAtom ","))
let valStx updateSource valStx
return { field with lhs := [field.lhs.head!], val := FieldVal.term valStx }
/--
Adds in the missing fields using the explicit sources.
Invariant: a missing field always comes from the first source that can provide it.
-/
private partial def addMissingFields (s : Struct) : TermElabM Struct := do
let env getEnv
let fieldNames := getStructureFields env s.structName
@@ -508,36 +505,13 @@ mutual
return { ref, lhs := [FieldLHS.fieldName ref fieldName], val := val } :: fields
match Lean.isSubobjectField? env s.structName fieldName with
| some substructName =>
-- Get all leaf fields of `substructName`
let downFields := getStructureFieldsFlattened env substructName false
-- Filter out all explicit sources that do not share a leaf field keeping
-- structure with no fields
let filtered := s.source.explicit.filter fun source =>
let sourceFields := getStructureFieldsFlattened env source.structName false
sourceFields.any (fun name => downFields.contains name) || sourceFields.isEmpty
-- Take the first such one remaining
match filtered[0]? with
| some src =>
-- If it is the correct type, use it
if src.structName == substructName then
addField (FieldVal.term src.stx)
-- If a projection of it is the correct type, use it
else if let some val mkProjStx? src.stx src.structName fieldName then
addField (FieldVal.term val)
-- No sources could provide this subobject in the proper order.
-- Recurse to handle default values for fields.
else
let substruct := Struct.mk ref substructName #[] [] s.source
let substruct expandStruct substruct
addField (FieldVal.nested substruct)
-- No sources could provide this subobject.
-- Recurse to handle default values for fields.
| none =>
-- If one of the sources has the subobject field, use it
if let some val s.source.explicit.findSomeM? fun source => mkProjStx? source.stx source.structName fieldName then
addField (FieldVal.term val)
else
let substruct := Struct.mk ref substructName #[] [] s.source
let substruct expandStruct substruct
addField (FieldVal.nested substruct)
-- Since this is not a subobject field, we are free to use the first source that can
-- provide it.
| none =>
if let some val s.source.explicit.findSomeM? fun source => mkProjStx? source.stx source.structName fieldName then
addField (FieldVal.term val)

Some files were not shown because too many files have changed in this diff Show More